Removed non working user menu

Removed non working user menu

-- TODO: Encapsulation between Loaded and Socket is very very weak! Some parts are here, some parts are there- this should be fixed!
-- | 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.Aria as A
import Pux.Html.Attributes.Bootstrap as A
import Pux.Html.Events as E
import Servant.PureScript.Affjax as Affjax
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.Error.Class (throwError, catchError)
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(AjaxError, RegisterSessionFailed), class ReportErrorAction, Gonimo)
import Gonimo.Pux (noEffects, Component, toParent, runGonimo, liftChild, ComponentType, makeChildData, ToChild, onlyModify, Update, wrapAction)
import Gonimo.Server.Db.Entities (Device(Device), Family(Family))
import Gonimo.Server.Db.Entities.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 (handleError, viewError, class ErrorAction, UserError(NoError, DeviceInvalid))
import Gonimo.UI.Loaded.Central (getCentrals)
import Gonimo.UI.Loaded.Types (mkInviteProps', CentralReq(..), mkInviteProps, mkSettings, mkProps, central, familyIds, authData, currentFamily, socketS, overviewS, Props, acceptS, inviteS, State, Action(..), Central(..), InviteProps)
import Gonimo.UI.Socket.Lenses (sessionId)
import Gonimo.Util (userShow, toString, fromString)
import Gonimo.WebAPI (postSessionByFamilyIdByDeviceId, postInvitationsByFamilyId, postFamilies, getFamiliesByFamilyId, postFunnyName, 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 (ErrorDescription(ConnectionError), errorToString, AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber)
import Servant.Subscriber.Connection (Notification(WebSocketOpened, 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 a@(SocketC.ReportError err))   = append <$> handleError err <*> updateSocket a
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

handleSubscriber :: Notification -> ComponentType Unit State Action
handleSubscriber notification = do
  append <$> Error.handleSubscriber notification
         <*> updateSocket (SocketC.HandleSubscriber notification)

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"]
    -- Brand and toggle get grouped for better mobile display --
          [ div [ A.className "navbar-header"]
            [ burgerButton
            , a [ A.className "navbar-brand"]
              [ img [ A.alt "gonimo"
                    , A.src "./pix/gonimo-brand-01.svg"
                    , A.width "45px"
                    , A.height "45px"
                    , A.style [Tuple "padding" "5px 7.5px 0px 7.5px"]
                    ] []
              ]
            ]

    -- Collect the nav links, forms, and other content for toggling --
          , div [ A.className "collapse navbar-collapse"
                , A.id_ "navbarmenu"
                , A.style [Tuple "width" "100%"]
                , A.dataToggle "collapse"
                , A.dataTarget ".navbar-collapse.in"
                ]
            [ ul [ A.className "nav navbar-nav"] $ (viewCentralItem <$> getCentrals state) <>
              [ viewFamilyChooser state
        --      , viewUserSettings
              ]
            ]
          ]
        ]

  where
    burgerButton :: Html Action
    burgerButton = button [ A.type_ "button"
                          , A.className "navbar-toggle collapsed"
                          , A.dataToggle "collapse"
                          , A.dataTarget "#navbarmenu"
                          , A.ariaExpanded "false"
                          ]
                   [ span [A.className "sr-only"] [text "Toggle navigation"]
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   ]
    viewCentralItem :: Tuple Boolean CentralReq -> Html Action
    viewCentralItem (Tuple active item) =
      li (if active then [ A.className "active" ] else []
          <>    [ A.dataToggle "collapse"
                , A.dataTarget ".navbar-collapse.in"]
         )
         [ a [ E.onClick <<< const $ RequestCentral item ]
           [ text $ userShow item ]
         ]

viewUserSettings :: Html Action
viewUserSettings =
  li [A.className "dropdown navbar-right"]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-user"] []
    , text " "
    , text "Max Mustermann"
    , text " "
    , span [A.className "caret"] []
    ]
  , ul [A.className "dropdown-menu", A.style [Tuple "minWidth" "180px"]]
    [ li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [text "Change user settings (WIP)"]]
    , li [A.className "disabled"] [a [] [text " User settings "
                  ,i [A.className "fa fa-fw fa-cog pull-right"] []]]
    , li [A.className "disabled"] [ a [] [ text "Change password "
                   , i [A.className "fa fa-fw fa-lock pull-right" ][]
                   ]]
    , li [A.className "divider", A.role "separator"] []
    , li [A.className "disabled"] [a [] [ text "Log-Out "
                  , i [A.className "fa fa-fw fa-sign-out pull-right"] []
                  ]]
    ]
  ]

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 =
  li [ A.className "dropdown"
     , A.dataToggle "collapse"
     ]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-users"] []
    , text " "
    , text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)
    {--, span [] [text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)]--}
    , text " "
    , span [A.className "caret"] [] ]
    , H.ul [A.className "dropdown-menu"] $
        [li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [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
    sessionId' = state^.socketS<<<sessionId
    --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 $ do
           _ <- sessionId' -- Avoid error message `FamilyNotOnline` when not yet ready.
           Sub.getSessionByFamilyId (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
    sessionId'    = state ^. socketS <<< to _.sessionId
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.putSessionByFamilyIdByDeviceIdBySessionId onlineStatus'
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _       -> Nothing

getCloseRequest :: State -> Maybe HttpRequest
getCloseRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    familyId = state^?currentFamily
    sessionId' = state ^. socketS <<< to _.sessionId
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.deleteSessionByFamilyIdByDeviceIdBySessionId
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _ -> 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

-- TODO: Encapsulation between Loaded and Socket is very very weak! Some parts are here, some parts are there- this should be fixed!
-- | 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.Aria as A
import Pux.Html.Attributes.Bootstrap as A
import Pux.Html.Events as E
import Servant.PureScript.Affjax as Affjax
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.Error.Class (throwError, catchError)
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(AjaxError, RegisterSessionFailed), class ReportErrorAction, Gonimo)
import Gonimo.Pux (noEffects, Component, toParent, runGonimo, liftChild, ComponentType, makeChildData, ToChild, onlyModify, Update, wrapAction)
import Gonimo.Server.Db.Entities (Device(Device), Family(Family))
import Gonimo.Server.Db.Entities.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 (handleError, viewError, class ErrorAction, UserError(NoError, DeviceInvalid))
import Gonimo.UI.Loaded.Central (getCentrals)
import Gonimo.UI.Loaded.Types (mkInviteProps', CentralReq(..), mkInviteProps, mkSettings, mkProps, central, familyIds, authData, currentFamily, socketS, overviewS, Props, acceptS, inviteS, State, Action(..), Central(..), InviteProps)
import Gonimo.UI.Socket.Lenses (sessionId)
import Gonimo.Util (userShow, toString, fromString)
import Gonimo.WebAPI (postSessionByFamilyIdByDeviceId, postInvitationsByFamilyId, postFamilies, getFamiliesByFamilyId, postFunnyName, 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 (ErrorDescription(ConnectionError), errorToString, AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber)
import Servant.Subscriber.Connection (Notification(WebSocketOpened, 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 a@(SocketC.ReportError err))   = append <$> handleError err <*> updateSocket a
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

handleSubscriber :: Notification -> ComponentType Unit State Action
handleSubscriber notification = do
  append <$> Error.handleSubscriber notification
         <*> updateSocket (SocketC.HandleSubscriber notification)

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"]
    -- Brand and toggle get grouped for better mobile display --
          [ div [ A.className "navbar-header"]
            [ burgerButton
            , a [ A.className "navbar-brand"]
              [ img [ A.alt "gonimo"
                    , A.src "./pix/gonimo-brand-01.svg"
                    , A.width "45px"
                    , A.height "45px"
                    , A.style [Tuple "padding" "5px 7.5px 0px 7.5px"]
                    ] []
              ]
            ]

    -- Collect the nav links, forms, and other content for toggling --
          , div [ A.className "collapse navbar-collapse"
                , A.id_ "navbarmenu"
                , A.style [Tuple "width" "100%"]
                , A.dataToggle "collapse"
                , A.dataTarget ".navbar-collapse.in"
                ]
            [ ul [ A.className "nav navbar-nav"] $ (viewCentralItem <$> getCentrals state) <>
              [ viewFamilyChooser state
              , viewUserSettings
              ]
            ]
          ]
        ]

  where
    burgerButton :: Html Action
    burgerButton = button [ A.type_ "button"
                          , A.className "navbar-toggle collapsed"
                          , A.dataToggle "collapse"
                          , A.dataTarget "#navbarmenu"
                          , A.ariaExpanded "false"
                          ]
                   [ span [A.className "sr-only"] [text "Toggle navigation"]
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   ]
    viewCentralItem :: Tuple Boolean CentralReq -> Html Action
    viewCentralItem (Tuple active item) =
      li (if active then [ A.className "active" ] else []
          <>    [ A.dataToggle "collapse"
                , A.dataTarget ".navbar-collapse.in"]
         )
         [ a [ E.onClick <<< const $ RequestCentral item ]
           [ text $ userShow item ]
         ]

viewUserSettings :: Html Action
viewUserSettings =
  li [A.className "dropdown navbar-right"]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-user"] []
    , text " "
    , text "Max Mustermann"
    , text " "
    , span [A.className "caret"] []
    ]
  , ul [A.className "dropdown-menu", A.style [Tuple "minWidth" "180px"]]
    [ li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [text "Change user settings (WIP)"]]
    , li [A.className "disabled"] [a [] [text " User settings "
                  ,i [A.className "fa fa-fw fa-cog pull-right"] []]]
    , li [A.className "disabled"] [ a [] [ text "Change password "
                   , i [A.className "fa fa-fw fa-lock pull-right" ][]
                   ]]
    , li [A.className "divider", A.role "separator"] []
    , li [A.className "disabled"] [a [] [ text "Log-Out "
                  , i [A.className "fa fa-fw fa-sign-out pull-right"] []
                  ]]
    ]
  ]

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 =
  li [ A.className "dropdown"
     , A.dataToggle "collapse"
     ]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-users"] []
    , text " "
    , text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)
    {--, span [] [text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)]--}
    , text " "
    , span [A.className "caret"] [] ]
    , H.ul [A.className "dropdown-menu"] $
        [li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [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
    sessionId' = state^.socketS<<<sessionId
    --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 $ do
           _ <- sessionId' -- Avoid error message `FamilyNotOnline` when not yet ready.
           Sub.getSessionByFamilyId (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
    sessionId'    = state ^. socketS <<< to _.sessionId
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.putSessionByFamilyIdByDeviceIdBySessionId onlineStatus'
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _       -> Nothing

getCloseRequest :: State -> Maybe HttpRequest
getCloseRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    familyId = state^?currentFamily
    sessionId' = state ^. socketS <<< to _.sessionId
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.deleteSessionByFamilyIdByDeviceIdBySessionId
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _ -> 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


Add test for qualified imports

Add test for qualified imports

module M1 where

  trace x = x

module Main where

  import Prelude
  import Control.Monad.Eff
  import M1
  import qualified Debug.Trace as T

  main = T.trace (trace "Done")

error: pathspec 'examples/manual/passing/ImportQualified.purs' did not match any file(s) known to git


Hopefully fixed whatsapp links

Hopefully fixed whatsapp links

module Gonimo.UI.Invite where

import Gonimo.UI.Html
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.Html as Html
import Gonimo.WebAPI.Types as WebAPI
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Aria as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Apply ((*>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (IO)
import Control.Monad.Reader.Class (ask)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify)
import Data.Either (Either(Right, Left))
import Data.Generic (gShow)
import Data.Maybe (isJust, isNothing, Maybe(..))
import Data.Tuple (uncurry, Tuple(Tuple))
import Global (encodeURIComponent, encodeURI)
import Gonimo.Client.Types (Settings, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Pux (noEffects, onlyModify, Update, runGonimo, class MonadComponent)
import Gonimo.Server.DbEntities (Invitation(Invitation), Family(Family))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Secret(Secret))
import Gonimo.WebAPI (postInvitationsOutbox, postInvitationsByFamilyId, postFamilies, SPParams_(SPParams_), postAccounts, postFunnyName)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (a, button, br, i, input, p, h1, h2, h3, text, span, Html, img, div, small, li, ul, nav)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece, defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)
import Prelude hiding (div)

type Props ps = { settings  :: Settings
                , rFamilyId :: Key Family
                , rFamily   :: Family
                , baseURL :: String
                | ps
                }

type State =
  { email          :: String
  , invitationSent :: Boolean
  , invitationId   :: Key Invitation
  , invitation   :: Invitation
  }

-- | We take our props in init to ensure the caller takes care of providing proper props.
--   Ensuring this on the first call to update is a tad to late.
init :: forall ps. Tuple (Key Invitation) Invitation -> Props ps -> State
init (Tuple invKey inv) _ = { email : ""
                            , invitationSent : false
                            , invitationId : invKey
                            , invitation : inv
                            }

data Action = SetEmail String
            | SendInvitation
            | InvitationSent
            | ReportError GonimoError
            | MakeNewInvitation
            | SetInvitationData (Key Invitation) Invitation
            | GoToOverview
            | GoToBabyStation
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

update :: forall ps. Update (Props ps) State Action
update action = case action of
  (SetEmail email )         -> onlyModify $ _ { email = email, invitationSent = false }
  InvitationSent            -> handleInvitationSent
  SendInvitation            -> handleSendInvitation
  MakeNewInvitation         -> handleMakeNewInvitation
  SetInvitationData id' inv -> onlyModify $ \state -> state { invitationId = id', invitation = inv }
  GoToOverview              -> noEffects
  GoToBabyStation           -> noEffects
  ReportError err           -> noEffects
  Nop                       -> noEffects

makeInviteLink :: String -> Invitation -> String
makeInviteLink baseURL (Invitation inv) = baseURL <> "?" <> "acceptInvitation="
                                          <> gDefaultEncodeURLPiece inv.invitationSecret

handleInvitationSent :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleInvitationSent = do
  modify $ _ { invitationSent = true }
  pure [ pure MakeNewInvitation ] -- Prevent user from re-using the already sent invitation

handleMakeNewInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleMakeNewInvitation = do
  props <- ask
  runGonimo $ uncurry SetInvitationData <$> postInvitationsByFamilyId props.rFamilyId

handleSendInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleSendInvitation = do
  state <- get
  runGonimo $ do
    postInvitationsOutbox $ WebAPI.SendInvitation state.invitationId (EmailInvitation state.email)
    pure InvitationSent

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

view :: forall ps. Props ps -> State -> Html Action
view props state =
    let invitationLink = makeInviteLink (props.baseURL) state.invitation
        escapedLink = encodeURIComponent invitationLink
     in div []
                   [ div [A.className "page-header"]
                     [ div [ A.className "container"
                           , A.style [Tuple "width" "100%"]]
                       [ h3 [] [ text "Device Management"
                               , br [] []
                               , small []
                                 [ text $ "Here you can add new devices to your"
                                       <> " families, you only have to visit the"
                                       <> " following one-time link on another device." ]
                               ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "copy & paste"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "You can either copy & paste it in to your"
                                    <> " favourite messenger (e.g. WhatsApp) to"
                                    <> " send it."
                              ]
                       , div [ A.className "input-group" ]
                           [ span [ A.className "input-group-addon glyphicon glyphicon-copy", A.id_ "sdflkjsll291" ]
                             []
                           , input [ A.type_ "text", A.className "form-control", A.readOnly true
                                   , A.value invitationLink
                                   ] []
                           ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "Share it"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "Or you can share it directly with WhatsApp, Telegram .."
                              ]
                       , p []
                         [
                           H.a [ A.href $ "whatsapp://send?text=" <> escapedLink
                               ] [ H.text "Whatsapp" ]
                         , H.text " "
                         , H.a [ A.href $ "tg://send?text=" <> escapedLink
                               ] [ H.text "Telegram" ]
                         ]
                       ]
                     ]
                   , div [A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "email"]
                     , div [A.className "jumbotron"]
                       [ p []  [ text "Or you can let us do the work send it via email …"
                               ]
                       , div [ E.onKeyUp handleEnter ]
                         [ div [A.className "input-group"]
                           [ span [A.className "input-group-addon glyphicon glyphicon-envelope"] []
                           , input [ A.type_ "text"
                                   , A.className "form-control"
                                   , A.placeholder "mail@example.com"
                                   , E.onInput $ \ev -> SetEmail ev.target.value
                                   , A.value state.email
                                   ] []
                           ]
                         ]
                       , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ SendInvitation
                                 ]
                         [ text " Send Invitation! "
                         , span [A.className "glyphicon glyphicon-send"] []
                         ]
                       , if state.invitationSent
                         then div [ A.className "alert alert-success"]
                              [ h3 [] [text $ "Invitation sent successfully to '"
                                           <> state.email <> "'!"
                                      , br [] []
                                      , small [] [text $ "But don't forget to add"
                                            <> " 'noreply@gonimo.com' to your address book,"
                                            <> " otherwise this invitation might end up in"
                                            <> " your spam-folder!"]
                                      ]
                              , button [ A.className "btn btn-block btn-default"
                                       , A.style [Tuple "margin-left" "0px"] ]
                                [ text $ "Oops - Did you send the invitation to the wrong recipient?"
                                , br [] []
                                , text "No problem just click me and then and then 'decline' to invalidate the link."
                                , br [] []
                                , br [] []
                                , text "TODO: how to preserve the previous one time link?"
                                ]
                              ]
                         else span [] []
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                       [ text "Invitation successfully transmitted? Then go back to overview or make this device a baby station right away .... " ]
                   , nav []
                     [ ul [ A.className "pager" ]
                       [ li [ A.className "previous"
                            , E.onClick $ const $ GoToOverview
                            ] [a [] [ span [A.ariaHidden "true"] [text "← "]
                                    , text "Back to Overview"
                                    ]
                              ]
                       , li [ A.className "next"
                            , E.onClick $ const $ GoToBabyStation
                            ] [ a [] [ text "Make this device a baby station"
                                     , span [A.ariaHidden "true"] [text " →"]
                                     ]
                              ]
                       ]

                     ]
                   , div [A.className "jumbotron"]
                      [ div [A.className "container"]
                        [ p [] [ text "Want to add another device?" ]
                        , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ MakeNewInvitation
                                 ]
                          [ span [ A.className "glyphicon glyphicon-repeat"] []
                          , text " Generate new one-time link "
                          ]
                        ]
                      ]
                    ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

viewSent :: State -> Html Action
viewSent state = viewLogo $ text "Invitation sucessfully sent!"

module Gonimo.UI.Invite where

import Gonimo.UI.Html
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.Html as Html
import Gonimo.WebAPI.Types as WebAPI
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Apply ((*>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (IO)
import Control.Monad.Reader.Class (ask)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify)
import Data.Either (Either(Right, Left))
import Data.Generic (gShow)
import Data.Maybe (isJust, isNothing, Maybe(..))
import Data.Tuple (uncurry, Tuple(Tuple))
import Global (encodeURI)
import Gonimo.Client.Types (Settings, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Pux (noEffects, onlyModify, Update, runGonimo, class MonadComponent)
import Gonimo.Server.DbEntities (Invitation(Invitation), Family(Family))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Secret(Secret))
import Gonimo.WebAPI (postInvitationsOutbox, postInvitationsByFamilyId, postFamilies, SPParams_(SPParams_), postAccounts, postFunnyName)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (a, button, br, i, input, p, h1, h2, h3, text, span, Html, img, div, small, li, ul, nav)
import Pux.Html.Attributes (offset)
import Pux.Html.Attributes.Aria as A
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece, defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)
import Prelude hiding (div)

type Props ps = { settings  :: Settings
                , rFamilyId :: Key Family
                , rFamily   :: Family
                , baseURL :: String
                | ps
                }

type State =
  { email          :: String
  , invitationSent :: Boolean
  , invitationId   :: Key Invitation
  , invitation   :: Invitation
  }

-- | We take our props in init to ensure the caller takes care of providing proper props.
--   Ensuring this on the first call to update is a tad to late.
init :: forall ps. Tuple (Key Invitation) Invitation -> Props ps -> State
init (Tuple invKey inv) _ = { email : ""
                            , invitationSent : false
                            , invitationId : invKey
                            , invitation : inv
                            }

data Action = SetEmail String
            | SendInvitation
            | InvitationSent
            | ReportError GonimoError
            | MakeNewInvitation
            | SetInvitationData (Key Invitation) Invitation
            | GoToOverview
            | GoToBabyStation
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

update :: forall ps. Update (Props ps) State Action
update action = case action of
  (SetEmail email )         -> onlyModify $ _ { email = email, invitationSent = false }
  InvitationSent            -> handleInvitationSent
  SendInvitation            -> handleSendInvitation
  MakeNewInvitation         -> handleMakeNewInvitation
  SetInvitationData id' inv -> onlyModify $ \state -> state { invitationId = id', invitation = inv }
  GoToOverview              -> noEffects
  GoToBabyStation           -> noEffects
  ReportError err           -> noEffects
  Nop                       -> noEffects

makeInviteLink :: String -> Invitation -> String
makeInviteLink baseURL (Invitation inv) = baseURL <> "?" <> "acceptInvitation="
                                          <> gDefaultEncodeURLPiece inv.invitationSecret

handleInvitationSent :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleInvitationSent = do
  modify $ _ { invitationSent = true }
  pure [ pure MakeNewInvitation ] -- Prevent user from re-using the already sent invitation

handleMakeNewInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleMakeNewInvitation = do
  props <- ask
  runGonimo $ uncurry SetInvitationData <$> postInvitationsByFamilyId props.rFamilyId

handleSendInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleSendInvitation = do
  state <- get
  runGonimo $ do
    postInvitationsOutbox $ WebAPI.SendInvitation state.invitationId (EmailInvitation state.email)
    pure InvitationSent

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

view :: forall ps. Props ps -> State -> Html Action
view props state =
    let invitationLink = makeInviteLink (props.baseURL) state.invitation
     in div []
                   [ div [A.className "page-header"]
                     [ div [ A.className "container"
                           , A.style [Tuple "width" "100%"]]
                       [ h3 [] [ text "Device Management"
                               , br [] []
                               , small []
                                 [ text $ "Here you can add new devices to your"
                                       <> " families, you only have to visit the"
                                       <> " following one-time link on another device." ]
                               ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "copy & paste"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "You can either copy & paste it in to your"
                                    <> " favourite messenger (e.g. WhatsApp) to"
                                    <> " send it."
                              ]
                       , div [ A.className "input-group" ]
                           [ span [ A.className "input-group-addon glyphicon glyphicon-copy", A.id_ "sdflkjsll291" ]
                             []
                           , input [ A.type_ "text", A.className "form-control", A.readOnly true
                                   , A.value invitationLink
                                   ] []
                           ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "Share it"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "Or you can share it directly with WhatsApp, Telegram .."
                              ]
                       , p []
                         [
                           H.a [ A.href $ "whatsapp://send?text=" <> invitationLink
                               ] [ H.text "Whatsapp" ]
                         , H.text " "
                         , H.a [ A.href $ "tg://send?text=" <> invitationLink
                               ] [ H.text "Telegram" ]
                         ]
                       ]
                     ]
                   , div [A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "email"]
                     , div [A.className "jumbotron"]
                       [ p []  [ text "Or you can let us do the work send it via email …"
                               ]
                       , div [ E.onKeyUp handleEnter ]
                         [ div [A.className "input-group"]
                           [ span [A.className "input-group-addon glyphicon glyphicon-envelope"] []
                           , input [ A.type_ "text"
                                   , A.className "form-control"
                                   , A.placeholder "mail@example.com"
                                   , E.onInput $ \ev -> SetEmail ev.target.value
                                   , A.value state.email
                                   ] []
                           ]
                         ]
                       , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ SendInvitation
                                 ]
                         [ text " Send Invitation! "
                         , span [A.className "glyphicon glyphicon-send"] []
                         ]
                       , if state.invitationSent
                         then div [ A.className "alert alert-success"]
                              [ h3 [] [text $ "Invitation sent successfully to '"
                                           <> state.email <> "'!"
                                      , br [] []
                                      , small [] [text $ "But don't forget to add"
                                            <> " 'noreply@gonimo.com' to your address book,"
                                            <> " otherwise this invitation might end up in"
                                            <> " your spam-folder!"]
                                      ]
                              , button [ A.className "btn btn-block btn-default"
                                       , A.style [Tuple "margin-left" "0px"] ]
                                [ text $ "Oops - Did you send the invitation to the wrong recipient?"
                                , br [] []
                                , text "No problem just click me and then and then 'decline' to invalidate the link."
                                , br [] []
                                , br [] []
                                , text "TODO: how to preserve the previous one time link?"
                                ]
                              ]
                         else span [] []
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                       [ text "Invitation successfully transmitted? Then go back to overview or make this device a baby station right away .... " ]
                   , nav []
                     [ ul [ A.className "pager" ]
                       [ li [ A.className "previous"
                            , E.onClick $ const $ GoToOverview
                            ] [a [] [ span [A.ariaHidden "true"] [text "← "]
                                    , text "Back to Overview"
                                    ]
                              ]
                       , li [ A.className "next"
                            , E.onClick $ const $ GoToBabyStation
                            ] [ a [] [ text "Make this device a baby station"
                                     , span [A.ariaHidden "true"] [text " →"]
                                     ]
                              ]
                       ]

                     ]
                   , div [A.className "jumbotron"]
                      [ div [A.className "container"]
                        [ p [] [ text "Want to add another device?" ]
                        , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ MakeNewInvitation
                                 ]
                          [ span [ A.className "glyphicon glyphicon-repeat"] []
                          , text " Generate new one-time link "
                          ]
                        ]
                      ]
                    ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

viewSent :: State -> Html Action
viewSent state = viewLogo $ text "Invitation sucessfully sent!"


add Request.GetSpots

add Request.GetSpots

module Request.GetSpots (getSpots) where

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Except (runExcept)
import Data.Either (either)
import Data.Foreign (F)
import Data.Foreign.Class (readJSON)
import Data.GetSpotsResponse (GetSpotsResponse)
import Data.Options ((:=))
import Data.StrMap (fromFoldable) as StrMap
import Data.Tuple (Tuple(..))
import Fetch (HTTP, fetch)
import Fetch.Options (Method(..), headers, method, url) as FetchOptions
import Prelude (($), (<>), (<<<), bind, show)

getSpots :: forall eff
               . String
               -> String
               -> Aff ( http :: HTTP
                      | eff
                      ) GetSpotsResponse
getSpots stampRallyId token = do
  text <- fetch options
  let f = readJSON text :: F GetSpotsResponse
  makeAff (\ng ok -> either (ng <<< error <<< show) ok $ runExcept f)
  where
    headers = StrMap.fromFoldable [ Tuple "Content-Type" "application/json"
                                  , Tuple "User-Agent" "rally-cli"
                                  , Tuple "Authorization" $ "Token token=\"" <> token <> "\""
                                  ]
    url = ( "https://api.rallyapp.jp/stamp_rallies/"
          <> stampRallyId
          <> "/spots"
          <> "?view_type=admin"
          )
    options = FetchOptions.method := FetchOptions.GET
              <> FetchOptions.url := url
              <> FetchOptions.headers := headers

error: pathspec 'src/Request/GetSpots.purs' did not match any file(s) known to git


add Stdin

add Stdin

module Stdin (read) where

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (runPure)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.ST (ST, modifySTRef, newSTRef, readSTRef, runST)
import Data.Either (Either(Left, Right))
import Data.Maybe (Maybe(..))
import Node.Buffer (Buffer, toString) as Buffer
import Node.Encoding (Encoding(UTF8))
import Node.Stream (Readable, onClose, onReadable, readEither) as Stream
import Prelude ((<$>), (<>), ($), bind, void)

toString
  :: Maybe (Either String Buffer.Buffer)
  -> String
toString Nothing = "" -- ignore `null`
toString (Just (Left s)) = s
toString (Just (Right b)) =
  (runPure $ unsafeCoerceEff $ Buffer.toString UTF8 b) -- ?

read
  :: forall e
   . Stream.Readable () e
  -> Aff e String
read stdin = makeAff \_ ok -> do
  ref <- unsafeCoerceEff $ newSTRef "" -- ?
  Stream.onClose stdin $ void do
    s <- unsafeCoerceEff $ readSTRef ref -- ?
    ok s
  Stream.onReadable stdin $ void do
    c <- toString <$> Stream.readEither stdin Nothing
    unsafeCoerceEff $ modifySTRef ref \s -> s <> c -- ?

error: pathspec 'src/Stdin.purs' did not match any file(s) known to git


Update examples for US keyboards

Update examples for US keyboards

-- | This module defines the interpreter for Insect.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.Maybe (Maybe(..))
import Data.StrMap (lookup, insert, foldMap)

import Quantities (Quantity, UnificationError, pow, scalar, qNegate, qAdd,
                   qDivide, qMultiply, qSubtract, quantity, toScalar', sqrt,
                   convertTo, errorMessage, prettyPrint, fullSimplify,
                   derivedUnit, acos, asin, atan, sin, cos, tan, exp, ln,
                   sinh, cosh, tanh, asinh, acosh, atanh, ceil, floor, log10,
                   round)

import Insect.Language (Func(..), BinOp(..), Expression(..), Command(..), Statement(..))
import Insect.Environment (Environment, initialEnvironment)

-- | Types of errors that may appear during evaluation.
data EvalError
  = UnificationError UnificationError
  | LookupError String

-- | A type synonym for error handling. A value of type `Expect Number` is
-- | expected to be a number but might also result in an evaluation error.
type Expect = Either EvalError

-- | Output types for highlighting.
data MessageType = Value | ValueSet | Info | Error | Other

-- | The output type of the interpreter.
data Message = Message MessageType String

-- | Apply a mathematical function to a physical quantity.
applyFunction ∷ Func → Quantity → Expect Quantity
applyFunction fn q = lmap UnificationError $ (run fn) q
  where
    run Acos  = acos
    run Acosh = acosh
    run Asin  = asin
    run Asinh = asinh
    run Atan  = atan
    run Atanh = atanh
    run Ceil  = ceil
    run Cos   = cos
    run Cosh  = cosh
    run Exp   = exp
    run Floor = floor
    run Ln    = ln
    run Log10 = log10
    run Round = round
    run Sin   = sin
    run Sinh  = sinh
    run Sqrt  = sqrt >>> pure
    run Tan   = tan
    run Tanh  = tanh

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Scalar n)      = pure $ scalar n
eval env (Unit u)        = pure $ quantity 1.0 u
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)
eval env (Negate x)      = qNegate <$> eval env x
eval env (Apply fn x)    = eval env x >>= applyFunction fn
eval env (BinOp op x y)  = do
  x' <- eval env x
  y' <- eval env y
  (run op) x' y'
  where
    run :: BinOp -> Quantity -> Quantity -> Expect Quantity
    run Sub       a b = qSubtract' a b
    run Add       a b = qAdd' a b
    run Mul       a b = pure (qMultiply a b)
    run Div       a b = pure (qDivide a b)
    run Pow       a b = pow a <$> toScalar'' b
    run ConvertTo a b = convertTo' a b

    wrap ∷ ∀ a. Either UnificationError a → Either EvalError a
    wrap = lmap UnificationError

    qSubtract' q1 q2 = wrap (qSubtract q1 q2)
    qAdd' q1 q2 = wrap (qAdd q1 q2)
    toScalar'' q = wrap (toScalar' q)
    convertTo' source target = wrap (convertTo source (derivedUnit target))

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

-- | Interpreter return type
type Response = { msg ∷ Message, newEnv ∷ Environment }

-- | Helper to construct an interpreter response
message ∷ MessageType → Environment → Expect Quantity → Response
message _ env (Left e) =
  { msg: Message Error (evalErrorMessage e)
  , newEnv: env
  }
message mt env (Right q) =
  { msg: Message mt (prettyPrint q)
  , newEnv: insert "ans" q env
  }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → Response
runInsect env (Expression e) = message Value env (fullSimplify <$> eval env e)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message Error env (Left evalErr)
    Right value → message ValueSet (insert n value env) (Right (fullSimplify value))
runInsect env (Command Help) = { msg: Message Other (intercalate "\n"
  [ ""
  , "*insect* evaluates mathematical expressions that can"
  , "involve physical quantities. You can start by trying"
  , "one of these examples:"
  , ""
  , "   > `1920/16*9`           > `sin(30deg)`"
  , ""
  , "   > `2min + 30s`          > `6Mbit/s * 1.5h -> Gb`"
  , ""
  , "   > `list`                > `r = 80cm`"
  , "   > `40000km/c -> ms`     > `pi*r^2 -> m^2`"
  , ""
  , "More information: https://github.com/sharkdp/insect"
  ]), newEnv : env }
runInsect env (Command List) =
  { msg: Message Other list
  , newEnv: env }
  where
    list = "List of variables:\n" <> foldMap toLine env
    toLine k v = "\n  * " <> k <> " = `" <> prettyPrint v <> "`"
runInsect env (Command Reset) =
  { msg: Message Info "Environment has been reset"
  , newEnv: initialEnvironment }
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }

-- | This module defines the interpreter for Insect.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.Maybe (Maybe(..))
import Data.StrMap (lookup, insert, foldMap)

import Quantities (Quantity, UnificationError, pow, scalar, qNegate, qAdd,
                   qDivide, qMultiply, qSubtract, quantity, toScalar', sqrt,
                   convertTo, errorMessage, prettyPrint, fullSimplify,
                   derivedUnit, acos, asin, atan, sin, cos, tan, exp, ln,
                   sinh, cosh, tanh, asinh, acosh, atanh, ceil, floor, log10,
                   round)

import Insect.Language (Func(..), BinOp(..), Expression(..), Command(..), Statement(..))
import Insect.Environment (Environment, initialEnvironment)

-- | Types of errors that may appear during evaluation.
data EvalError
  = UnificationError UnificationError
  | LookupError String

-- | A type synonym for error handling. A value of type `Expect Number` is
-- | expected to be a number but might also result in an evaluation error.
type Expect = Either EvalError

-- | Output types for highlighting.
data MessageType = Value | ValueSet | Info | Error | Other

-- | The output type of the interpreter.
data Message = Message MessageType String

-- | Apply a mathematical function to a physical quantity.
applyFunction ∷ Func → Quantity → Expect Quantity
applyFunction fn q = lmap UnificationError $ (run fn) q
  where
    run Acos  = acos
    run Acosh = acosh
    run Asin  = asin
    run Asinh = asinh
    run Atan  = atan
    run Atanh = atanh
    run Ceil  = ceil
    run Cos   = cos
    run Cosh  = cosh
    run Exp   = exp
    run Floor = floor
    run Ln    = ln
    run Log10 = log10
    run Round = round
    run Sin   = sin
    run Sinh  = sinh
    run Sqrt  = sqrt >>> pure
    run Tan   = tan
    run Tanh  = tanh

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Scalar n)      = pure $ scalar n
eval env (Unit u)        = pure $ quantity 1.0 u
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)
eval env (Negate x)      = qNegate <$> eval env x
eval env (Apply fn x)    = eval env x >>= applyFunction fn
eval env (BinOp op x y)  = do
  x' <- eval env x
  y' <- eval env y
  (run op) x' y'
  where
    run :: BinOp -> Quantity -> Quantity -> Expect Quantity
    run Sub       a b = qSubtract' a b
    run Add       a b = qAdd' a b
    run Mul       a b = pure (qMultiply a b)
    run Div       a b = pure (qDivide a b)
    run Pow       a b = pow a <$> toScalar'' b
    run ConvertTo a b = convertTo' a b

    wrap ∷ ∀ a. Either UnificationError a → Either EvalError a
    wrap = lmap UnificationError

    qSubtract' q1 q2 = wrap (qSubtract q1 q2)
    qAdd' q1 q2 = wrap (qAdd q1 q2)
    toScalar'' q = wrap (toScalar' q)
    convertTo' source target = wrap (convertTo source (derivedUnit target))

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

-- | Interpreter return type
type Response = { msg ∷ Message, newEnv ∷ Environment }

-- | Helper to construct an interpreter response
message ∷ MessageType → Environment → Expect Quantity → Response
message _ env (Left e) =
  { msg: Message Error (evalErrorMessage e)
  , newEnv: env
  }
message mt env (Right q) =
  { msg: Message mt (prettyPrint q)
  , newEnv: insert "ans" q env
  }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → Response
runInsect env (Expression e) = message Value env (fullSimplify <$> eval env e)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message Error env (Left evalErr)
    Right value → message ValueSet (insert n value env) (Right (fullSimplify value))
runInsect env (Command Help) = { msg: Message Other (intercalate "\n"
  [ ""
  , "*insect* evaluates mathematical expressions that can"
  , "involve physical quantities. You can start by trying"
  , "one of these examples:"
  , ""
  , "   > `1920/16*9`           > `sin(30°)`"
  , ""
  , "   > `2min + 30s`          > `6Mbit/s * 1.5h -> Gb`"
  , ""
  , "   > `list`                > `r = 80cm`"
  , "   > `40000km/c -> ms`     > `pi r² -> m²`"
  , ""
  , "More information: https://github.com/sharkdp/insect"
  ]), newEnv : env }
runInsect env (Command List) =
  { msg: Message Other list
  , newEnv: env }
  where
    list = "List of variables:\n" <> foldMap toLine env
    toLine k v = "\n  * " <> k <> " = `" <> prettyPrint v <> "`"
runInsect env (Command Reset) =
  { msg: Message Info "Environment has been reset"
  , newEnv: initialEnvironment }
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }


3.15.1

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/mikemcgowan/purescript-book.git/'


resurrect toCharCode and fromCharCode

resurrect toCharCode and fromCharCode

-- | A type and functions for single characters.
module Data.Char
  ( toCharCode
  , fromCharCode
  ) where

-- | Returns the numeric Unicode value of the character.
toCharCode :: Char -> Int
toCharCode = fromEnum

-- | Constructs a character from the given Unicode numeric value.
fromCharCode :: Int -> Maybe Char
fromCharCode = toEnum

error: pathspec 'src/Data/Char.purs' did not match any file(s) known to git