[CSE-172] Extract `optionalRedeemedRow`

[CSE-172] Extract `optionalRedeemedRow`

module Explorer.View.Address where

import Prelude

import Data.Array (length, null, slice)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe, isJust)
import Data.Monoid (mempty)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (addNotFound, cAddress, cBack2Dashboard, common, cAddressIsRedeemed, cLoading, cOf, cTransactions, cYes, cNo, address, addScan, addQrCode, addFinalBalance, tx, txEmpty, txNotFound) as I18nL
import Explorer.Lenses.State (_PageNumber, addressDetail, addressTxPagination, addressTxPaginationEditable, currentAddressSummary, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (addressQRImageId, minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), PageNumber(..), State, CTxBriefs)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, getMaxPaginationNumber, mkTxBodyViewProps, mkTxHeaderViewProps, txBodyView, txEmptyContentView, txHeaderView, txPaginationView)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.ClientTypes (CAddressSummary(..), CTxBrief)
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, _CHash, _CTxBrief, _CTxId, caAddress, caBalance, caIsRedeemed, caTxNum, ctbId)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Pux.Renderer.React (dangerouslySetInnerHTML) as P
import Text.Smolder.HTML (a, div, span, h3, p) as S
import Text.Smolder.HTML.Attributes (className, href, id) as S
import Text.Smolder.Markup ((#!), (!))
import Text.Smolder.Markup (text) as S

addressView :: State -> P.HTML Action
addressView state =
    let lang' = state ^. lang in
    S.div ! S.className "explorer-address" $ do
        S.div ! S.className "explorer-address__wrapper" $ do
            S.div ! S.className "explorer-address__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cAddress) lang')
                addressOverview (state ^. currentAddressSummary) lang'
            S.div ! S.className "explorer-address__wrapper"
                  $ S.div ! S.className "explorer-address__container"
                          $ case state ^. currentAddressSummary of
                                NotAsked  -> txEmptyContentView ""
                                Loading   -> txEmptyContentView $
                                    translate (I18nL.common <<< I18nL.cLoading) lang'
                                Failure _ -> txEmptyContentView $
                                    translate (I18nL.tx <<< I18nL.txNotFound) lang'
                                Success (CAddressSummary addressSummary) ->
                                    addressTxsView addressSummary.caTxList state

-- | Address overview, we leave the error abstract (we are not using it)
addressOverview :: forall e. RemoteData e CAddressSummary -> Language -> P.HTML Action
addressOverview NotAsked    lang = emptyAddressDetail ""
addressOverview Loading     lang = emptyAddressDetail <<< translate (I18nL.common <<< I18nL.cLoading) $ lang
addressOverview (Failure _) lang = failureView lang
addressOverview (Success addressSummary) lang =
    S.div ! S.className "address-overview" $ do
        addressDetailView addressSummary lang
        addressQr addressSummary lang

addressDetailView :: CAddressSummary -> Language -> P.HTML Action
addressDetailView addressSummary lang =
    S.div ! S.className "address-detail"
          $ for_ (addressDetailRowItems addressSummary lang) addressDetailRow

addressQr :: CAddressSummary -> Language -> P.HTML Action
addressQr _ lang =
    S.div ! S.className "address-qr" $ do
        S.p ! S.className "address-qr__tab"
            $ S.text $ translate (I18nL.address <<< I18nL.addQrCode) lang
        S.div ! S.className "address-qr__wrapper" $ do
            S.div ! S.className "address-qr__image"
                  ! S.id addressQRImageId
                  $ mempty
            S.p ! S.className "address-qr__description"
                $ S.text (translate (I18nL.address <<< I18nL.addScan) lang)

type SummaryRowItem =
    { key :: String -- needed by React https://facebook.github.io/react/docs/lists-and-keys.html
    , label :: String
    , value :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

addressDetailRowItems :: CAddressSummary -> Language -> SummaryItems
addressDetailRowItems (CAddressSummary address) lang =
    [ { key: "0"
      , label: translate (I18nL.common <<< I18nL.cAddress) lang
      , value: address ^. (caAddress <<< _CAddress)
      , mCurrency: Nothing
      }
    , { key: "1"
      , label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , value: show $ address ^. caTxNum
      , mCurrency: Nothing
      }
    , { key: "2"
      ,label: translate (I18nL.address <<< I18nL.addFinalBalance) lang
      , value: formatADA (address ^. caBalance) lang
      , mCurrency: Just ADA
      }
    ] <> optionalRedeemedRow
    where
        optionalRedeemedRow :: SummaryItems
        optionalRedeemedRow =
            if isJust (address ^. caIsRedeemed)
               -- ^ add `isRedeemed` info if available only
                  then  [ { key: "3"
                        , label: translate (I18nL.common <<< I18nL.cAddressIsRedeemed) lang
                        , value:  if fromMaybe false (address ^. caIsRedeemed)
                                      then translate (I18nL.common <<< I18nL.cYes) lang
                                      else translate (I18nL.common <<< I18nL.cNo) lang
                        , mCurrency: Nothing
                        }]
                  else  []

addressDetailRow :: SummaryRowItem -> P.HTML Action
addressDetailRow item =
    S.div ! S.className "address-detail__row"
          ! P.key item.key
          $ do
          S.div ! S.className "address-detail__column label"
                $ S.text item.label
          S.div ! S.className "address-detail__column amount"
                $ if isJust item.mCurrency
                      then S.span ! S.className (currencyCSSClass item.mCurrency)
                                  $ S.text item.value
                      else S.text item.value

emptyAddressDetail :: String -> P.HTML Action
emptyAddressDetail message =
    S.div ! S.className "message"
          $ S.div ! P.dangerouslySetInnerHTML message
                  $ mempty

maxTxRows :: Int
maxTxRows = 5

addressTxsView :: CTxBriefs -> State -> P.HTML Action
addressTxsView txs state =
    if null txs then
        txEmptyContentView $ translate (I18nL.tx <<< I18nL.txEmpty) (state ^. lang)
    else
    let txPagination = state ^. (viewStates <<< addressDetail <<< addressTxPagination <<< _PageNumber)
        lang' = state ^. lang
        minTxIndex = (txPagination - minPagination) * maxTxRows
        currentTxs = slice minTxIndex (minTxIndex + maxTxRows) txs
    in
    do
        for_ currentTxs (\tx -> addressTxView tx lang')
        txPaginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                          , currentPage: PageNumber txPagination
                          , minPage: PageNumber minPagination
                          , maxPage: PageNumber $ getMaxPaginationNumber (length txs) maxTxRows
                          , changePageAction: AddressPaginateTxs
                          , editable: state ^. (viewStates <<< addressDetail <<< addressTxPaginationEditable)
                          , editableAction: AddressEditTxsPageNumber
                          , invalidPageAction: AddressInvalidTxsPageNumber
                          , disabled: false
                          }

addressTxView :: CTxBrief -> Language -> P.HTML Action
addressTxView tx lang =
    S.div ! P.key (tx ^. (_CTxBrief <<< ctbId <<< _CTxId <<< _CHash))
          ! S.className "explorer-address__tx-container"
          $ do
          txHeaderView lang $ mkTxHeaderViewProps tx
          txBodyView lang $ mkTxBodyViewProps tx

failureView :: Language -> P.HTML Action
failureView lang =
    S.div do
        S.p ! S.className "address-failed"
            $ S.text (translate (I18nL.address <<< I18nL.addNotFound) lang)
        S.a ! S.href (toUrl Dashboard)
            #! P.onClick (Navigate $ toUrl Dashboard)
            ! S.className "btn-back"
            $ S.text (translate (I18nL.common <<< I18nL.cBack2Dashboard) lang)

module Explorer.View.Address where

import Prelude

import Data.Array (length, null, slice)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe, isJust)
import Data.Monoid (mempty)
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (addNotFound, cAddress, cBack2Dashboard, common, cAddressIsRedeemed, cLoading, cOf, cTransactions, cYes, cNo, address, addScan, addQrCode, addFinalBalance, tx, txEmpty, txNotFound) as I18nL
import Explorer.Lenses.State (_PageNumber, addressDetail, addressTxPagination, addressTxPaginationEditable, currentAddressSummary, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (addressQRImageId, minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), PageNumber(..), State, CTxBriefs)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, getMaxPaginationNumber, mkTxBodyViewProps, mkTxHeaderViewProps, txBodyView, txEmptyContentView, txHeaderView, txPaginationView)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.ClientTypes (CAddressSummary(..), CTxBrief)
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, _CHash, _CTxBrief, _CTxId, caAddress, caBalance, caIsRedeemed, caTxNum, ctbId)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Pux.Renderer.React (dangerouslySetInnerHTML) as P
import Text.Smolder.HTML (a, div, span, h3, p) as S
import Text.Smolder.HTML.Attributes (className, href, id) as S
import Text.Smolder.Markup ((#!), (!))
import Text.Smolder.Markup (text) as S

addressView :: State -> P.HTML Action
addressView state =
    let lang' = state ^. lang in
    S.div ! S.className "explorer-address" $ do
        S.div ! S.className "explorer-address__wrapper" $ do
            S.div ! S.className "explorer-address__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cAddress) lang')
                addressOverview (state ^. currentAddressSummary) lang'
            S.div ! S.className "explorer-address__wrapper"
                  $ S.div ! S.className "explorer-address__container"
                          $ case state ^. currentAddressSummary of
                                NotAsked  -> txEmptyContentView ""
                                Loading   -> txEmptyContentView $
                                    translate (I18nL.common <<< I18nL.cLoading) lang'
                                Failure _ -> txEmptyContentView $
                                    translate (I18nL.tx <<< I18nL.txNotFound) lang'
                                Success (CAddressSummary addressSummary) ->
                                    addressTxsView addressSummary.caTxList state

-- | Address overview, we leave the error abstract (we are not using it)
addressOverview :: forall e. RemoteData e CAddressSummary -> Language -> P.HTML Action
addressOverview NotAsked    lang = emptyAddressDetail ""
addressOverview Loading     lang = emptyAddressDetail <<< translate (I18nL.common <<< I18nL.cLoading) $ lang
addressOverview (Failure _) lang = failureView lang
addressOverview (Success addressSummary) lang =
    S.div ! S.className "address-overview" $ do
        addressDetailView addressSummary lang
        addressQr addressSummary lang

addressDetailView :: CAddressSummary -> Language -> P.HTML Action
addressDetailView addressSummary lang =
    S.div ! S.className "address-detail"
          $ for_ (addressDetailRowItems addressSummary lang) addressDetailRow

addressQr :: CAddressSummary -> Language -> P.HTML Action
addressQr _ lang =
    S.div ! S.className "address-qr" $ do
        S.p ! S.className "address-qr__tab"
            $ S.text $ translate (I18nL.address <<< I18nL.addQrCode) lang
        S.div ! S.className "address-qr__wrapper" $ do
            S.div ! S.className "address-qr__image"
                  ! S.id addressQRImageId
                  $ mempty
            S.p ! S.className "address-qr__description"
                $ S.text (translate (I18nL.address <<< I18nL.addScan) lang)

type SummaryRowItem =
    { key :: String -- needed by React https://facebook.github.io/react/docs/lists-and-keys.html
    , label :: String
    , value :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

addressDetailRowItems :: CAddressSummary -> Language -> SummaryItems
addressDetailRowItems (CAddressSummary address) lang =
    [ { key: "0"
      , label: translate (I18nL.common <<< I18nL.cAddress) lang
      , value: address ^. (caAddress <<< _CAddress)
      , mCurrency: Nothing
      }
    , { key: "1"
      , label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , value: show $ address ^. caTxNum
      , mCurrency: Nothing
      }
    , { key: "2"
      ,label: translate (I18nL.address <<< I18nL.addFinalBalance) lang
      , value: formatADA (address ^. caBalance) lang
      , mCurrency: Just ADA
      }
    ] <> if isJust (address ^. caIsRedeemed)
            -- ^ add `isRedeemed` info if available only
              then  [ { key: "3"
                    , label: translate (I18nL.common <<< I18nL.cAddressIsRedeemed) lang
                    , value:  if fromMaybe false (address ^. caIsRedeemed)
                                  then translate (I18nL.common <<< I18nL.cYes) lang
                                  else translate (I18nL.common <<< I18nL.cNo) lang
                    , mCurrency: Nothing
                    }]
              else  []

addressDetailRow :: SummaryRowItem -> P.HTML Action
addressDetailRow item =
    S.div ! S.className "address-detail__row"
          ! P.key item.key
          $ do
          S.div ! S.className "address-detail__column label"
                $ S.text item.label
          S.div ! S.className "address-detail__column amount"
                $ if isJust item.mCurrency
                      then S.span ! S.className (currencyCSSClass item.mCurrency)
                                  $ S.text item.value
                      else S.text item.value

emptyAddressDetail :: String -> P.HTML Action
emptyAddressDetail message =
    S.div ! S.className "message"
          $ S.div ! P.dangerouslySetInnerHTML message
                  $ mempty

maxTxRows :: Int
maxTxRows = 5

addressTxsView :: CTxBriefs -> State -> P.HTML Action
addressTxsView txs state =
    if null txs then
        txEmptyContentView $ translate (I18nL.tx <<< I18nL.txEmpty) (state ^. lang)
    else
    let txPagination = state ^. (viewStates <<< addressDetail <<< addressTxPagination <<< _PageNumber)
        lang' = state ^. lang
        minTxIndex = (txPagination - minPagination) * maxTxRows
        currentTxs = slice minTxIndex (minTxIndex + maxTxRows) txs
    in
    do
        for_ currentTxs (\tx -> addressTxView tx lang')
        txPaginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                          , currentPage: PageNumber txPagination
                          , minPage: PageNumber minPagination
                          , maxPage: PageNumber $ getMaxPaginationNumber (length txs) maxTxRows
                          , changePageAction: AddressPaginateTxs
                          , editable: state ^. (viewStates <<< addressDetail <<< addressTxPaginationEditable)
                          , editableAction: AddressEditTxsPageNumber
                          , invalidPageAction: AddressInvalidTxsPageNumber
                          , disabled: false
                          }

addressTxView :: CTxBrief -> Language -> P.HTML Action
addressTxView tx lang =
    S.div ! P.key (tx ^. (_CTxBrief <<< ctbId <<< _CTxId <<< _CHash))
          ! S.className "explorer-address__tx-container"
          $ do
          txHeaderView lang $ mkTxHeaderViewProps tx
          txBodyView lang $ mkTxBodyViewProps tx

failureView :: Language -> P.HTML Action
failureView lang =
    S.div do
        S.p ! S.className "address-failed"
            $ S.text (translate (I18nL.address <<< I18nL.addNotFound) lang)
        S.a ! S.href (toUrl Dashboard)
            #! P.onClick (Navigate $ toUrl Dashboard)
            ! S.className "btn-back"
            $ S.text (translate (I18nL.common <<< I18nL.cBack2Dashboard) lang)


Fix identifier in Site2 example

Fix identifier in Site2 example

module Site2 where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT)
import Control.IxMonad ((:*>))
import Data.Array (find)
import Data.Maybe (Maybe(..), maybe)
import Data.MediaType.Common (textHTML)
import Hyper.HTML (class EncodeHTML, HTML, element_, h1, li, linkTo, p, text, ul)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Port (Port(..))
import Hyper.Response (closeHeaders, contentType, respond, writeStatus)
import Hyper.Routing (type (:/), type (:<|>), type (:>), Capture, (:<|>))
import Hyper.Routing.Links (linksTo)
import Hyper.Routing.Method (Get)
import Hyper.Routing.Router (RoutingError(..), router)
import Hyper.Status (statusNotFound)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)
import Type.Proxy (Proxy(..))

data Home = Home

data AllUsers = AllUsers (Array User)

newtype User = User { id :: Int, name :: String }

type Site2 =
  Get HTML Home
  :<|> "users" :/ Get HTML AllUsers
  :<|> "users" :/ Capture "user-id" Int :> Get HTML User

site2 :: Proxy Site2
site2 = Proxy

home :: forall m. Monad m => ExceptT RoutingError m Home
home = pure Home

allUsers :: forall m. Monad m => ExceptT RoutingError m AllUsers
allUsers = AllUsers <$> getUsers

getUser :: forall m. Monad m => Int -> ExceptT RoutingError m User
getUser id' =
  find userWithId <$> getUsers >>=
  case _ of
    Just user -> pure user
    Nothing ->
      throwError (HTTPError { status: statusNotFound
                            , message: Just "User not found."
                            })
  where
    userWithId (User u) = u.id == id'

instance encodeHTMLHome :: EncodeHTML Home where
  encodeHTML Home =
    case linksTo site2 of
      _ :<|> allUsers' :<|> _ ->
        p [] [ text "Welcome to my site! Go check out my "
             , linkTo allUsers' [ text "Users" ]
             , text "."
             ]

instance encodeHTMLAllUsers :: EncodeHTML AllUsers where
  encodeHTML (AllUsers users) =
    element_ "div" [ h1 [] [ text "Users" ]
                   , ul [] (map linkToUser users)
                   ]
    where
      linkToUser (User u) =
        case linksTo site2 of
          _ :<|> _ :<|> getUser' ->
            li [] [ linkTo (getUser' u.id) [ text u.name ] ]

instance encodeHTMLUser :: EncodeHTML User where
  encodeHTML (User { name }) =
    h1 [] [ text name ]

getUsers :: forall m. Applicative m => m (Array User)
getUsers =
  pure
  [ User { id: 1, name: "John Paul Jones" }
  , User { id: 2, name: "Tal Wilkenfeld" }
  , User { id: 3, name: "John Patitucci" }
  , User { id: 4, name: "Jaco Pastorious" }
  ]

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, buffer :: BUFFER | e) Unit
main =
  let otherSiteRouter =
        router site2 (home :<|> allUsers :<|> getUser) onRoutingError

      onRoutingError status msg =
        writeStatus status
        :*> contentType textHTML
        :*> closeHeaders
        :*> respond (maybe "" id msg)

      onListening (Port port) =
        log ("Listening on http://localhost:" <> show port)

      onRequestError err =
        log ("Request failed: " <> show err)

  in runServer defaultOptions onListening onRequestError {} otherSiteRouter

module Site2 where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT)
import Control.IxMonad ((:*>))
import Data.Array (find)
import Data.Maybe (Maybe(..), maybe)
import Data.MediaType.Common (textHTML)
import Hyper.HTML (class EncodeHTML, HTML, element_, h1, li, linkTo, p, text, ul)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Port (Port(..))
import Hyper.Response (closeHeaders, contentType, respond, writeStatus)
import Hyper.Routing (type (:/), type (:<|>), type (:>), Capture, (:<|>))
import Hyper.Routing.Links (linksTo)
import Hyper.Routing.Method (Get)
import Hyper.Routing.Router (RoutingError(..), router)
import Hyper.Status (statusNotFound)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)
import Type.Proxy (Proxy(..))

data Home = Home

data AllUsers = AllUsers (Array User)

newtype User = User { id :: Int, name :: String }

type Site2 =
  Get HTML Home
  :<|> "users" :/ Get HTML AllUsers
  :<|> "users" :/ Capture "user-id" Int :> Get HTML User

otherSite :: Proxy Site2
otherSite = Proxy

home :: forall m. Monad m => ExceptT RoutingError m Home
home = pure Home

allUsers :: forall m. Monad m => ExceptT RoutingError m AllUsers
allUsers = AllUsers <$> getUsers

getUser :: forall m. Monad m => Int -> ExceptT RoutingError m User
getUser id' =
  find userWithId <$> getUsers >>=
  case _ of
    Just user -> pure user
    Nothing ->
      throwError (HTTPError { status: statusNotFound
                            , message: Just "User not found."
                            })
  where
    userWithId (User u) = u.id == id'

instance encodeHTMLHome :: EncodeHTML Home where
  encodeHTML Home =
    case linksTo otherSite of
      _ :<|> allUsers' :<|> _ ->
        p [] [ text "Welcome to my site! Go check out my "
             , linkTo allUsers' [ text "Users" ]
             , text "."
             ]

instance encodeHTMLAllUsers :: EncodeHTML AllUsers where
  encodeHTML (AllUsers users) =
    element_ "div" [ h1 [] [ text "Users" ]
                   , ul [] (map linkToUser users)
                   ]
    where
      linkToUser (User u) =
        case linksTo otherSite of
          _ :<|> _ :<|> getUser' ->
            li [] [ linkTo (getUser' u.id) [ text u.name ] ]

instance encodeHTMLUser :: EncodeHTML User where
  encodeHTML (User { name }) =
    h1 [] [ text name ]

getUsers :: forall m. Applicative m => m (Array User)
getUsers =
  pure
  [ User { id: 1, name: "John Paul Jones" }
  , User { id: 2, name: "Tal Wilkenfeld" }
  , User { id: 3, name: "John Patitucci" }
  , User { id: 4, name: "Jaco Pastorious" }
  ]

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, buffer :: BUFFER | e) Unit
main =
  let otherSiteRouter =
        router otherSite (home :<|> allUsers :<|> getUser) onRoutingError

      onRoutingError status msg =
        writeStatus status
        :*> contentType textHTML
        :*> closeHeaders
        :*> respond (maybe "" id msg)

      onListening (Port port) =
        log ("Listening on http://localhost:" <> show port)

      onRequestError err =
        log ("Request failed: " <> show err)

  in runServer defaultOptions onListening onRequestError {} otherSiteRouter


Use IDBKey type-class to make add & put more friendly

module Database.IndexedDB.IDBObjectStore
  ( class IDBObjectStore, add, clear, createIndex, delete, deleteIndex, index, put
  , module Database.IndexedDB.IDBIndex.Internal
  , IDBObjectStoreParameters
  , IndexName
  , autoIncrement
  , indexNames
  , keyPath
  , name
  , transaction
  , defaultParameters
  ) where

import Prelude                              (Unit, ($), (<$>), (>>>))

import Control.Monad.Aff                    (Aff)
import Control.Monad.Eff                    (Eff)
import Control.Monad.Eff.Exception          (EXCEPTION)
import Data.Foreign                         (Foreign)
import Data.Function.Uncurried               as Fn
import Data.Function.Uncurried              (Fn2, Fn3, Fn4)
import Data.Maybe                           (Maybe)
import Data.Nullable                        (Nullable, toNullable)

import Database.IndexedDB.Core              (IDB, Index, KeyRange, KeyPath, ObjectStore, Transaction)
import Database.IndexedDB.IDBIndex.Internal (class IDBIndex, IDBIndexParameters, count, get, getAllKeys, getKey, openCursor, openKeyCursor)
import Database.IndexedDB.IDBKey.Internal   (class IDBKey, Key(Key), extractForeign, toKey)

--------------------
-- INTERFACES
--
class IDBObjectStore store where
  add :: forall v k e. (IDBKey k) => store -> v -> Maybe k -> Aff (idb :: IDB | e) Key
  clear :: forall e. store -> Aff (idb :: IDB | e) Unit
  createIndex :: forall e. store -> IndexName -> KeyPath -> IDBIndexParameters -> Eff (idb :: IDB, exception :: EXCEPTION | e) Index
  delete :: forall e. store -> KeyRange -> Aff (idb :: IDB | e) Unit
  deleteIndex :: forall e. store -> IndexName -> Eff (idb :: IDB, exception :: EXCEPTION | e) Unit
  index :: forall e. store -> IndexName -> Eff (idb :: IDB, exception :: EXCEPTION | e) Index
  put :: forall v k e. (IDBKey k) => store -> v -> Maybe k -> Aff (idb :: IDB | e) Key

type IndexName = String

type IDBObjectStoreParameters =
  { keyPath       :: KeyPath
  , autoIncrement :: Boolean
  }

--------------------
-- ATTRIBUTES
--
autoIncrement :: ObjectStore -> Boolean
autoIncrement =
  _autoIncrement

indexNames :: ObjectStore -> Array String
indexNames =
  _indexNames

keyPath :: ObjectStore -> Array String
keyPath =
  _keyPath

name :: ObjectStore -> String
name =
  _name

transaction :: ObjectStore -> Transaction
transaction =
  _transaction

--------------------
-- INSTANCES
--
instance idbObjectStoreObjectStore :: IDBObjectStore ObjectStore where
  add store value key =
    Key <$> Fn.runFn3 _add store value (toNullable $ (toKey >>> extractForeign) <$> key)

  clear =
    _clear

  createIndex store name' path params =
    Fn.runFn4 _createIndex store name' path params

  delete store range =
    Fn.runFn2 _delete store range

  deleteIndex store name' =
    Fn.runFn2 _deleteIndex store name'

  index store name' =
    Fn.runFn2 _index store name'

  put store value key =
    Key <$> Fn.runFn3 _put store value (toNullable $ (toKey >>> extractForeign) <$> key)

defaultParameters :: IDBObjectStoreParameters
defaultParameters =
  { keyPath       : []
  , autoIncrement : false
  }

--------------------
-- FFI
--
foreign import _add :: forall value e. Fn3 ObjectStore value (Nullable Foreign) (Aff (idb :: IDB | e) Foreign)

foreign import _autoIncrement :: ObjectStore -> Boolean

foreign import _clear :: forall e. ObjectStore -> Aff (idb :: IDB | e) Unit

foreign import _createIndex :: forall e. Fn4 ObjectStore String (Array String) { unique :: Boolean, multiEntry :: Boolean } (Eff (idb :: IDB | e) Index)

foreign import _delete :: forall e. Fn2 ObjectStore KeyRange (Aff (idb :: IDB | e) Unit)

foreign import _deleteIndex :: forall e. Fn2 ObjectStore String (Eff (idb :: IDB | e) Unit)

foreign import _index :: forall e. Fn2 ObjectStore String (Eff (idb :: IDB | e) Index)

foreign import _indexNames :: ObjectStore -> Array String

foreign import _keyPath :: ObjectStore -> Array String

foreign import _name :: ObjectStore -> String

foreign import _put :: forall value e. Fn3 ObjectStore value (Nullable Foreign) (Aff (idb :: IDB | e) Foreign)

foreign import _transaction :: ObjectStore -> Transaction

module Database.IndexedDB.IDBObjectStore
  ( class IDBObjectStore, add, clear, createIndex, delete, deleteIndex, index, put
  , module Database.IndexedDB.IDBIndex.Internal
  , IDBObjectStoreParameters
  , IndexName
  , autoIncrement
  , indexNames
  , keyPath
  , name
  , transaction
  , defaultParameters
  ) where

import Prelude                              (Unit, ($), (<$>))

import Control.Monad.Aff                    (Aff)
import Control.Monad.Eff                    (Eff)
import Control.Monad.Eff.Exception          (EXCEPTION)
import Data.Foreign                         (Foreign)
import Data.Function.Uncurried               as Fn
import Data.Function.Uncurried              (Fn2, Fn3, Fn4)
import Data.Maybe                           (Maybe)
import Data.Nullable                        (Nullable, toNullable)

import Database.IndexedDB.Core              (IDB, Index, KeyRange, KeyPath, ObjectStore, Transaction)
import Database.IndexedDB.IDBIndex.Internal (class IDBIndex, IDBIndexParameters, count, get, getAllKeys, getKey, openCursor, openKeyCursor)
import Database.IndexedDB.IDBKey.Internal   (Key(Key), extractForeign)

--------------------
-- INTERFACES
--
class IDBObjectStore store where
  add :: forall value e. store -> value -> Maybe Key -> Aff (idb :: IDB | e) Key
  clear :: forall e. store -> Aff (idb :: IDB | e) Unit
  createIndex :: forall e. store -> IndexName -> KeyPath -> IDBIndexParameters -> Eff (idb :: IDB, exception :: EXCEPTION | e) Index
  delete :: forall e. store -> KeyRange -> Aff (idb :: IDB | e) Unit
  deleteIndex :: forall e. store -> IndexName -> Eff (idb :: IDB, exception :: EXCEPTION | e) Unit
  index :: forall e. store -> IndexName -> Eff (idb :: IDB, exception :: EXCEPTION | e) Index
  put :: forall value e. store -> value -> Maybe Key -> Aff (idb :: IDB | e) Key

type IndexName = String

type IDBObjectStoreParameters =
  { keyPath       :: KeyPath
  , autoIncrement :: Boolean
  }

--------------------
-- ATTRIBUTES
--
autoIncrement :: ObjectStore -> Boolean
autoIncrement =
  _autoIncrement

indexNames :: ObjectStore -> Array String
indexNames =
  _indexNames

keyPath :: ObjectStore -> Array String
keyPath =
  _keyPath

name :: ObjectStore -> String
name =
  _name

transaction :: ObjectStore -> Transaction
transaction =
  _transaction

--------------------
-- INSTANCES
--
instance idbObjectStoreObjectStore :: IDBObjectStore ObjectStore where
  add store value key =
    Key <$> Fn.runFn3 _add store value (toNullable $ extractForeign <$> key)

  clear =
    _clear

  createIndex store name' path params =
    Fn.runFn4 _createIndex store name' path params

  delete store range =
    Fn.runFn2 _delete store range

  deleteIndex store name' =
    Fn.runFn2 _deleteIndex store name'

  index store name' =
    Fn.runFn2 _index store name'

  put store value key =
    Key <$> Fn.runFn3 _put store value (toNullable $ extractForeign <$> key)

defaultParameters :: IDBObjectStoreParameters
defaultParameters =
  { keyPath       : []
  , autoIncrement : false
  }

--------------------
-- FFI
--
foreign import _add :: forall value e. Fn3 ObjectStore value (Nullable Foreign) (Aff (idb :: IDB | e) Foreign)

foreign import _autoIncrement :: ObjectStore -> Boolean

foreign import _clear :: forall e. ObjectStore -> Aff (idb :: IDB | e) Unit

foreign import _createIndex :: forall e. Fn4 ObjectStore String (Array String) { unique :: Boolean, multiEntry :: Boolean } (Eff (idb :: IDB | e) Index)

foreign import _delete :: forall e. Fn2 ObjectStore KeyRange (Aff (idb :: IDB | e) Unit)

foreign import _deleteIndex :: forall e. Fn2 ObjectStore String (Eff (idb :: IDB | e) Unit)

foreign import _index :: forall e. Fn2 ObjectStore String (Eff (idb :: IDB | e) Index)

foreign import _indexNames :: ObjectStore -> Array String

foreign import _keyPath :: ObjectStore -> Array String

foreign import _name :: ObjectStore -> String

foreign import _put :: forall value e. Fn3 ObjectStore value (Nullable Foreign) (Aff (idb :: IDB | e) Foreign)

foreign import _transaction :: ObjectStore -> Transaction


Add basic Pux app

Add basic Pux app

module Main where

import Prelude hiding (div)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Signal.Channel (CHANNEL)

import Pux (renderToDOM, fromSimple, start)
import Pux.Html (Html, text, button, span, div)
import Pux.Html.Events (onClick)

data Action = Increment | Decrement

type State = Int

update :: Action -> State -> State
update Increment count = count + 1
update Decrement count = count - 1

view :: State -> Html Action
view count =
  div
    []
    [ button [ onClick (const Increment) ] [ text "Increment" ]
    , span [] [ text (show count) ]
    , button [ onClick (const Decrement) ] [ text "Decrement" ]
    ]

main :: forall e. Eff (err :: EXCEPTION, channel :: CHANNEL | e) Unit
main = do
  app <- start
    { initialState: 0
    , update: fromSimple update
    , view: view
    , inputs: []
    }
  renderToDOM "#app" app.html

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  log "Hello sailor!"


Fix comment typo

Fix comment typo

module Simple.JSON
( E
, readJSON
, readJSON'
, readJSON_
, writeJSON
, write
, read
, read'
, read_
, parseJSON
, undefined

, class ReadForeign
, readImpl
, class ReadForeignFields
, getFields
, class ReadForeignVariant
, readVariantImpl

, class WriteForeign
, writeImpl
, class WriteForeignFields
, writeImplFields
, class WriteForeignVariant
, writeVariantImpl

) where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Except (ExceptT(..), runExcept, runExceptT, withExcept)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), hush)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (Nullable, toMaybe, toNullable)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse)
import Data.Variant (Variant, inj, on)
import Effect.Exception (message, try)
import Effect.Uncurried as EU
import Effect.Unsafe (unsafePerformEffect)
import Foreign (F, Foreign, ForeignError(..), MultipleErrors, fail, isNull, isUndefined, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, tagOf, unsafeFromForeign, unsafeToForeign)
import Foreign.Index (readProp)
import Foreign.Object (Object)
import Foreign.Object as Object
import Global.Unsafe (unsafeStringify)
import Partial.Unsafe (unsafeCrashWith)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (get)
import Record.Builder (Builder)
import Record.Builder as Builder
import Type.Prelude (RLProxy(..))

-- | An alias for the Either result of decoding
type E a = Either MultipleErrors a

-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
-- | parsing failed.
readJSON :: forall a
  .  ReadForeign a
  => String
  -> E a
readJSON = runExcept <<< (readImpl <=< parseJSON)

-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
readJSON' :: forall a
  .  ReadForeign a
  => String
  -> F a
readJSON' = readImpl <=< parseJSON

-- | Read a JSON string to a type `a` while returning `Nothing` if the parsing
-- | failed.
readJSON_ ::  forall a
   . ReadForeign a
  => String
  -> Maybe a
readJSON_ = hush <<< readJSON

-- | Write a JSON string from a type `a`.
writeJSON :: forall a
  .  WriteForeign a
  => a
  -> String
writeJSON = unsafeStringify <<< writeImpl

write :: forall a
  .  WriteForeign a
  => a
  -> Foreign
write = writeImpl

-- | Read a Foreign value to a type
read :: forall a
   . ReadForeign a
  => Foreign
  -> E a
read = runExcept <<< readImpl

-- | Read a value of any type as Foreign to a type
readAsForeign :: forall a b
   . ReadForeign a
  => b
  -> E a
readAsForeign = read <<< unsafeToForeign

read' :: forall a
  .  ReadForeign a
  => Foreign
  -> F a
read' = readImpl

-- | Read a Foreign value to a type, as a Maybe of type
read_ :: forall a
   . ReadForeign a
  => Foreign
  -> Maybe a
read_ = hush <<< read

foreign import _parseJSON :: EU.EffectFn1 String Foreign

parseJSON :: String -> F Foreign
parseJSON
    = ExceptT
  <<< Identity
  <<< lmap (pure <<< ForeignError <<< message)
  <<< runPure
  <<< try
  <<< EU.runEffectFn1 _parseJSON
  where
    -- Nate Faubion: "It uses unsafePerformEffect because that’s the only way to catch exceptions and still use the builtin json decoder"
    runPure = unsafePerformEffect

foreign import _undefined :: Foreign

undefined :: Foreign
undefined = _undefined

-- | A class for reading foreign values to a type
class ReadForeign a where
  readImpl :: Foreign -> F a

instance readForeign :: ReadForeign Foreign where
  readImpl = pure

instance readChar :: ReadForeign Char where
  readImpl = readChar

instance readNumber :: ReadForeign Number where
  readImpl = readNumber

instance readInt :: ReadForeign Int where
  readImpl = readInt

instance readString :: ReadForeign String where
  readImpl = readString

instance readBoolean :: ReadForeign Boolean where
  readImpl = readBoolean

instance readArray :: ReadForeign a => ReadForeign (Array a) where
  readImpl = traverse readImpl <=< readArray

instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
  readImpl = readNullOrUndefined readImpl
    where
      readNullOrUndefined _ value | isNull value || isUndefined value = pure Nothing
      readNullOrUndefined f value = Just <$> f value

instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
  readImpl o = withExcept (map reformat) $
    map toNullable <$> traverse readImpl =<< readNull o
    where
      reformat error = case error of
        TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
        _ -> error

instance readObject :: ReadForeign a => ReadForeign (Object.Object a) where
  readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
    where
      readObject' :: Foreign -> F (Object Foreign)
      readObject' value
        | tagOf value == "Object" = pure $ unsafeFromForeign value
        | otherwise = fail $ TypeMismatch "Object" (tagOf value)

instance readRecord ::
  ( RowToList fields fieldList
  , ReadForeignFields fieldList () fields
  ) => ReadForeign (Record fields) where
  readImpl o = flip Builder.build {} <$> getFields fieldListP o
    where
      fieldListP = RLProxy :: RLProxy fieldList

-- | A class for reading foreign values from properties
class ReadForeignFields (xs :: RowList) (from :: # Type) (to :: # Type)
  | xs -> from to where
  getFields :: RLProxy xs
    -> Foreign
    -> F (Builder (Record from) (Record to))

instance readFieldsCons ::
  ( IsSymbol name
  , ReadForeign ty
  , ReadForeignFields tail from from'
  , Row.Lacks name from'
  , Row.Cons name ty from' to
  ) => ReadForeignFields (Cons name ty tail) from to where
  getFields _ obj = (compose <$> first) `exceptTApply` rest
    where
      first = do
        value <- withExcept' (readImpl =<< readProp name obj)
        pure $ Builder.insert nameP value
      rest = getFields tailP obj
      nameP = SProxy :: SProxy name
      tailP = RLProxy :: RLProxy tail
      name = reflectSymbol nameP
      withExcept' = withExcept <<< map $ ErrorAtProperty name

exceptTApply :: forall a b e m. Semigroup e => Applicative m => ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
exceptTApply fun a = ExceptT $ applyEither
  <$> runExceptT fun
  <*> runExceptT a

applyEither :: forall e a b. Semigroup e => Either e (a -> b) -> Either e a -> Either e b
applyEither (Left e) (Right _) = Left e
applyEither (Left e1) (Left e2) = Left (e1 <> e2)
applyEither (Right _) (Left e) = Left e
applyEither (Right fun) (Right a) = Right (fun a)

instance readFieldsNil ::
  ReadForeignFields Nil () () where
  getFields _ _ =
    pure identity

instance readForeignVariant ::
  ( RowToList variants rl
  , ReadForeignVariant rl variants
  ) => ReadForeign (Variant variants) where
  readImpl o = readVariantImpl (RLProxy :: RLProxy rl) o

class ReadForeignVariant (xs :: RowList) (row :: # Type)
  | xs -> row where
  readVariantImpl :: RLProxy xs
    -> Foreign
    -> F (Variant row)

instance readVariantNil ::
  ReadForeignVariant Nil trash where
  readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."

instance readVariantCons ::
  ( IsSymbol name
  , ReadForeign ty
  , Row.Cons name ty trash row
  , ReadForeignVariant tail row
  ) => ReadForeignVariant (Cons name ty tail) row where
  readVariantImpl _ o = do
    obj :: { type :: String, value :: Foreign } <- readImpl o
    if obj.type == name
      then do
        value :: ty <- readImpl obj.value
        pure $ inj namep value
      else
        (fail <<< ForeignError $ "Did not match variant tag " <> name)
    <|> readVariantImpl (RLProxy :: RLProxy tail) o
    where
      namep = SProxy :: SProxy name
      name = reflectSymbol namep

-- -- | A class for writing a value into JSON
-- -- | need to do this intelligently using Foreign probably, because of null and undefined whatever
class WriteForeign a where
  writeImpl :: a -> Foreign

instance writeForeignForeign :: WriteForeign Foreign where
  writeImpl = identity

instance writeForeignString :: WriteForeign String where
  writeImpl = unsafeToForeign

instance writeForeignInt :: WriteForeign Int where
  writeImpl = unsafeToForeign

instance writeForeignChar :: WriteForeign Char where
  writeImpl = unsafeToForeign

instance writeForeignNumber :: WriteForeign Number where
  writeImpl = unsafeToForeign

instance writeForeignBoolean :: WriteForeign Boolean where
  writeImpl = unsafeToForeign

instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
  writeImpl xs = unsafeToForeign $ writeImpl <$> xs

instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
  writeImpl = maybe undefined writeImpl

instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) where
  writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe

instance writeForeignObject :: WriteForeign a => WriteForeign (Object.Object a) where
  writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)

instance recordWriteForeign ::
  ( RowToList row rl
  , WriteForeignFields rl row () to
  ) => WriteForeign (Record row) where
  writeImpl rec = unsafeToForeign $ Builder.build steps {}
    where
      rlp = RLProxy :: RLProxy rl
      steps = writeImplFields rlp rec

class WriteForeignFields (rl :: RowList) row (from :: # Type) (to :: # Type)
  | rl -> row from to where
  writeImplFields :: forall g. g rl -> Record row -> Builder (Record from) (Record to)

instance consWriteForeignFields ::
  ( IsSymbol name
  , WriteForeign ty
  , WriteForeignFields tail row from from'
  , Row.Cons name ty whatever row
  , Row.Lacks name from'
  , Row.Cons name Foreign from' to
  ) => WriteForeignFields (Cons name ty tail) row from to where
  writeImplFields _ rec = result
    where
      namep = SProxy :: SProxy name
      value = writeImpl $ get namep rec
      tailp = RLProxy :: RLProxy tail
      rest = writeImplFields tailp rec
      result = Builder.insert namep value <<< rest
instance nilWriteForeignFields ::
  WriteForeignFields Nil row () () where
  writeImplFields _ _ = identity

instance writeForeignVariant ::
  ( RowToList row rl
  , WriteForeignVariant rl row
  ) => WriteForeign (Variant row) where
  writeImpl variant = writeVariantImpl (RLProxy :: RLProxy rl) variant

class WriteForeignVariant (rl :: RowList) (row :: # Type)
  | rl -> row where
  writeVariantImpl :: forall g. g rl -> Variant row -> Foreign

instance nilWriteForeignVariant ::
  WriteForeignVariant Nil () where
  writeVariantImpl _ _ =
    -- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
    unsafeCrashWith "Variant was not able to be writen row WriteForeign."

instance consWriteForeignVariant ::
  ( IsSymbol name
  , WriteForeign ty
  , Row.Cons name ty subRow row
  , WriteForeignVariant tail subRow
  ) => WriteForeignVariant (Cons name ty tail) row where
  writeVariantImpl _ variant =
    on
      namep
      writeVariant
      (writeVariantImpl (RLProxy :: RLProxy tail))
      variant
    where
    namep = SProxy :: SProxy name
    writeVariant value = unsafeToForeign
      { type: reflectSymbol namep
      , value: writeImpl value
      }

module Simple.JSON
( E
, readJSON
, readJSON'
, readJSON_
, writeJSON
, write
, read
, read'
, read_
, parseJSON
, undefined

, class ReadForeign
, readImpl
, class ReadForeignFields
, getFields
, class ReadForeignVariant
, readVariantImpl

, class WriteForeign
, writeImpl
, class WriteForeignFields
, writeImplFields
, class WriteForeignVariant
, writeVariantImpl

) where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Except (ExceptT(..), runExcept, runExceptT, withExcept)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), hush)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (Nullable, toMaybe, toNullable)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse)
import Data.Variant (Variant, inj, on)
import Effect.Exception (message, try)
import Effect.Uncurried as EU
import Effect.Unsafe (unsafePerformEffect)
import Foreign (F, Foreign, ForeignError(..), MultipleErrors, fail, isNull, isUndefined, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, tagOf, unsafeFromForeign, unsafeToForeign)
import Foreign.Index (readProp)
import Foreign.Object (Object)
import Foreign.Object as Object
import Global.Unsafe (unsafeStringify)
import Partial.Unsafe (unsafeCrashWith)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (get)
import Record.Builder (Builder)
import Record.Builder as Builder
import Type.Prelude (RLProxy(..))

-- | An alias for the Either result of decoding
type E a = Either MultipleErrors a

-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
-- | parsing failed.
readJSON :: forall a
  .  ReadForeign a
  => String
  -> E a
readJSON = runExcept <<< (readImpl <=< parseJSON)

-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
readJSON' :: forall a
  .  ReadForeign a
  => String
  -> F a
readJSON' = readImpl <=< parseJSON

-- | Read a JSON string to a type `a` while returning `Nothing` is the parsing
-- | failed.
readJSON_ ::  forall a
   . ReadForeign a
  => String
  -> Maybe a
readJSON_ = hush <<< readJSON

-- | Write a JSON string from a type `a`.
writeJSON :: forall a
  .  WriteForeign a
  => a
  -> String
writeJSON = unsafeStringify <<< writeImpl

write :: forall a
  .  WriteForeign a
  => a
  -> Foreign
write = writeImpl

-- | Read a Foreign value to a type
read :: forall a
   . ReadForeign a
  => Foreign
  -> E a
read = runExcept <<< readImpl

-- | Read a value of any type as Foreign to a type
readAsForeign :: forall a b
   . ReadForeign a
  => b
  -> E a
readAsForeign = read <<< unsafeToForeign

read' :: forall a
  .  ReadForeign a
  => Foreign
  -> F a
read' = readImpl

-- | Read a Foreign value to a type, as a Maybe of type
read_ :: forall a
   . ReadForeign a
  => Foreign
  -> Maybe a
read_ = hush <<< read

foreign import _parseJSON :: EU.EffectFn1 String Foreign

parseJSON :: String -> F Foreign
parseJSON
    = ExceptT
  <<< Identity
  <<< lmap (pure <<< ForeignError <<< message)
  <<< runPure
  <<< try
  <<< EU.runEffectFn1 _parseJSON
  where
    -- Nate Faubion: "It uses unsafePerformEffect because that’s the only way to catch exceptions and still use the builtin json decoder"
    runPure = unsafePerformEffect

foreign import _undefined :: Foreign

undefined :: Foreign
undefined = _undefined

-- | A class for reading foreign values to a type
class ReadForeign a where
  readImpl :: Foreign -> F a

instance readForeign :: ReadForeign Foreign where
  readImpl = pure

instance readChar :: ReadForeign Char where
  readImpl = readChar

instance readNumber :: ReadForeign Number where
  readImpl = readNumber

instance readInt :: ReadForeign Int where
  readImpl = readInt

instance readString :: ReadForeign String where
  readImpl = readString

instance readBoolean :: ReadForeign Boolean where
  readImpl = readBoolean

instance readArray :: ReadForeign a => ReadForeign (Array a) where
  readImpl = traverse readImpl <=< readArray

instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
  readImpl = readNullOrUndefined readImpl
    where
      readNullOrUndefined _ value | isNull value || isUndefined value = pure Nothing
      readNullOrUndefined f value = Just <$> f value

instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
  readImpl o = withExcept (map reformat) $
    map toNullable <$> traverse readImpl =<< readNull o
    where
      reformat error = case error of
        TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
        _ -> error

instance readObject :: ReadForeign a => ReadForeign (Object.Object a) where
  readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
    where
      readObject' :: Foreign -> F (Object Foreign)
      readObject' value
        | tagOf value == "Object" = pure $ unsafeFromForeign value
        | otherwise = fail $ TypeMismatch "Object" (tagOf value)

instance readRecord ::
  ( RowToList fields fieldList
  , ReadForeignFields fieldList () fields
  ) => ReadForeign (Record fields) where
  readImpl o = flip Builder.build {} <$> getFields fieldListP o
    where
      fieldListP = RLProxy :: RLProxy fieldList

-- | A class for reading foreign values from properties
class ReadForeignFields (xs :: RowList) (from :: # Type) (to :: # Type)
  | xs -> from to where
  getFields :: RLProxy xs
    -> Foreign
    -> F (Builder (Record from) (Record to))

instance readFieldsCons ::
  ( IsSymbol name
  , ReadForeign ty
  , ReadForeignFields tail from from'
  , Row.Lacks name from'
  , Row.Cons name ty from' to
  ) => ReadForeignFields (Cons name ty tail) from to where
  getFields _ obj = (compose <$> first) `exceptTApply` rest
    where
      first = do
        value <- withExcept' (readImpl =<< readProp name obj)
        pure $ Builder.insert nameP value
      rest = getFields tailP obj
      nameP = SProxy :: SProxy name
      tailP = RLProxy :: RLProxy tail
      name = reflectSymbol nameP
      withExcept' = withExcept <<< map $ ErrorAtProperty name

exceptTApply :: forall a b e m. Semigroup e => Applicative m => ExceptT e m (a -> b) -> ExceptT e m a -> ExceptT e m b
exceptTApply fun a = ExceptT $ applyEither
  <$> runExceptT fun
  <*> runExceptT a

applyEither :: forall e a b. Semigroup e => Either e (a -> b) -> Either e a -> Either e b
applyEither (Left e) (Right _) = Left e
applyEither (Left e1) (Left e2) = Left (e1 <> e2)
applyEither (Right _) (Left e) = Left e
applyEither (Right fun) (Right a) = Right (fun a)

instance readFieldsNil ::
  ReadForeignFields Nil () () where
  getFields _ _ =
    pure identity

instance readForeignVariant ::
  ( RowToList variants rl
  , ReadForeignVariant rl variants
  ) => ReadForeign (Variant variants) where
  readImpl o = readVariantImpl (RLProxy :: RLProxy rl) o

class ReadForeignVariant (xs :: RowList) (row :: # Type)
  | xs -> row where
  readVariantImpl :: RLProxy xs
    -> Foreign
    -> F (Variant row)

instance readVariantNil ::
  ReadForeignVariant Nil trash where
  readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."

instance readVariantCons ::
  ( IsSymbol name
  , ReadForeign ty
  , Row.Cons name ty trash row
  , ReadForeignVariant tail row
  ) => ReadForeignVariant (Cons name ty tail) row where
  readVariantImpl _ o = do
    obj :: { type :: String, value :: Foreign } <- readImpl o
    if obj.type == name
      then do
        value :: ty <- readImpl obj.value
        pure $ inj namep value
      else
        (fail <<< ForeignError $ "Did not match variant tag " <> name)
    <|> readVariantImpl (RLProxy :: RLProxy tail) o
    where
      namep = SProxy :: SProxy name
      name = reflectSymbol namep

-- -- | A class for writing a value into JSON
-- -- | need to do this intelligently using Foreign probably, because of null and undefined whatever
class WriteForeign a where
  writeImpl :: a -> Foreign

instance writeForeignForeign :: WriteForeign Foreign where
  writeImpl = identity

instance writeForeignString :: WriteForeign String where
  writeImpl = unsafeToForeign

instance writeForeignInt :: WriteForeign Int where
  writeImpl = unsafeToForeign

instance writeForeignChar :: WriteForeign Char where
  writeImpl = unsafeToForeign

instance writeForeignNumber :: WriteForeign Number where
  writeImpl = unsafeToForeign

instance writeForeignBoolean :: WriteForeign Boolean where
  writeImpl = unsafeToForeign

instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
  writeImpl xs = unsafeToForeign $ writeImpl <$> xs

instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
  writeImpl = maybe undefined writeImpl

instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) where
  writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe

instance writeForeignObject :: WriteForeign a => WriteForeign (Object.Object a) where
  writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)

instance recordWriteForeign ::
  ( RowToList row rl
  , WriteForeignFields rl row () to
  ) => WriteForeign (Record row) where
  writeImpl rec = unsafeToForeign $ Builder.build steps {}
    where
      rlp = RLProxy :: RLProxy rl
      steps = writeImplFields rlp rec

class WriteForeignFields (rl :: RowList) row (from :: # Type) (to :: # Type)
  | rl -> row from to where
  writeImplFields :: forall g. g rl -> Record row -> Builder (Record from) (Record to)

instance consWriteForeignFields ::
  ( IsSymbol name
  , WriteForeign ty
  , WriteForeignFields tail row from from'
  , Row.Cons name ty whatever row
  , Row.Lacks name from'
  , Row.Cons name Foreign from' to
  ) => WriteForeignFields (Cons name ty tail) row from to where
  writeImplFields _ rec = result
    where
      namep = SProxy :: SProxy name
      value = writeImpl $ get namep rec
      tailp = RLProxy :: RLProxy tail
      rest = writeImplFields tailp rec
      result = Builder.insert namep value <<< rest
instance nilWriteForeignFields ::
  WriteForeignFields Nil row () () where
  writeImplFields _ _ = identity

instance writeForeignVariant ::
  ( RowToList row rl
  , WriteForeignVariant rl row
  ) => WriteForeign (Variant row) where
  writeImpl variant = writeVariantImpl (RLProxy :: RLProxy rl) variant

class WriteForeignVariant (rl :: RowList) (row :: # Type)
  | rl -> row where
  writeVariantImpl :: forall g. g rl -> Variant row -> Foreign

instance nilWriteForeignVariant ::
  WriteForeignVariant Nil () where
  writeVariantImpl _ _ =
    -- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
    unsafeCrashWith "Variant was not able to be writen row WriteForeign."

instance consWriteForeignVariant ::
  ( IsSymbol name
  , WriteForeign ty
  , Row.Cons name ty subRow row
  , WriteForeignVariant tail subRow
  ) => WriteForeignVariant (Cons name ty tail) row where
  writeVariantImpl _ variant =
    on
      namep
      writeVariant
      (writeVariantImpl (RLProxy :: RLProxy tail))
      variant
    where
    namep = SProxy :: SProxy name
    writeVariant value = unsafeToForeign
      { type: reflectSymbol namep
      , value: writeImpl value
      }


Changed integration of AcceptS and InviteS

module Gonimo.UI.Loaded.Types where

import Prelude
import Data.Map as Map
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Home as HomeC
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Socket.Lenses as SocketC
import Gonimo.UI.Socket.Types as SocketC
import Control.Monad.Eff (Eff)
import Control.Monad.IO (IO)
import Data.Either (Either(Left, Right))
import Data.Generic (class Generic)
import Data.Lens ((^?), (^.), prism, PrismP, to, _Just, TraversalP, lens, LensP)
import Data.Map (Map)
import Data.Maybe (Maybe)
import Data.Profunctor (lmap)
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (Settings, class ReportErrorAction, GonimoError)
import Gonimo.Server.DbEntities (Device(Device), Family(Family))
import Gonimo.Server.Types (DeviceType)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Error (class ErrorAction, UserError)
import Gonimo.WebAPI (SPParams_(SPParams_))
import Gonimo.WebAPI.Types (DeviceInfo(DeviceInfo), AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Servant.PureScript.Settings (defaultSettings)
import Servant.Subscriber.Connection (Notification)

type State = { subscriberUrl :: String
             , homeS    :: HomeC.State
             , socketS   :: SocketC.State
             , central  :: Central
             , familyIds :: Array (Key Family)
             , families  :: Map (Key Family) Family
             , onlineDevices :: Array (Tuple (Key Device) DeviceType)
             , deviceInfos :: Array (Tuple (Key Device) DeviceInfo)
             , userError :: UserError
             , url :: String
             , sendAction :: Action -> Eff () Unit
             }

type Props = { settings :: Settings
             , deviceId :: Key Device
             , familyId :: Maybe (Key Family)
             , family :: Maybe Family
             , onlineStatus :: DeviceType
             , onlineDevices :: Array (Tuple (Key Device) DeviceType)
             , deviceInfos :: Array (Tuple (Key Device) DeviceInfo)
             , sendActionSocket :: SocketC.Action -> Eff () Unit
             }

data Action = ReportError GonimoError
            | SetState State
            | InviteA InviteC.Action
            | AcceptA AcceptC.Action
            | HomeA HomeC.Action
            | SocketA SocketC.Action
            | SetFamilyIds (Array (Key Family))
            | UpdateFamily (Key Family) Family
            | SetCentral Central
            | SetOnlineDevices (Array (Tuple (Key Device) DeviceType))
            | SetDeviceInfos (Array (Tuple (Key Device) DeviceInfo))
            | SetURL String
            | HandleSubscriber Notification
            | ResetDevice -- Reinitialize basically everything.
            | ClearError
            | Nop

data Central = CentralInvite InviteC.State
             | CentralAccept AcceptC.State
             | CentralHome

centralHome :: Central
centralHome = CentralHome

mkProps :: State -> Props
mkProps state = { settings : mkSettings $ state^.authData
                , deviceId : (runAuthData $ state^.authData).deviceId
                , familyId : state^?currentFamily
                , onlineStatus  : state ^. socketS <<< SocketC.onlineStatus <<< to SocketC.toDeviceType
                , family : flip Map.lookup state.families =<< state^?currentFamily
                , onlineDevices : state.onlineDevices
                , deviceInfos : state.deviceInfos
                , sendActionSocket : lmap SocketA state.sendAction
                }

mkSettings :: AuthData -> Settings
mkSettings (AuthData auth) = defaultSettings $ SPParams_ {
      authorization : auth.authToken
    , baseURL       : "http://localhost:8081/"
    }

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

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

_CentralInvite :: PrismP Central InviteC.State
_CentralInvite = prism CentralInvite unwrap
  where
    unwrap (CentralInvite s) = Right s
    unwrap y = Left y

_CentralAccept :: PrismP Central AcceptC.State
_CentralAccept = prism CentralAccept unwrap
  where
    unwrap (CentralAccept s) = Right s
    unwrap y = Left y

inviteS :: TraversalP State InviteC.State
inviteS = central <<< _CentralInvite

acceptS :: TraversalP State AcceptC.State
acceptS = central <<< _CentralAccept

homeS :: LensP State HomeC.State
homeS = lens _.homeS (_ { homeS = _ })

central :: LensP State Central
central = lens _.central (_ { central = _})

socketS :: LensP State SocketC.State
socketS = lens _.socketS (_ { socketS = _ })

authData :: LensP State AuthData
authData = socketS <<< SocketC.authData

currentFamily :: TraversalP State (Key Family)
currentFamily = socketS <<< SocketC.currentFamily <<< _Just

familyIds :: LensP State (Array (Key Family))
familyIds = lens _.familyIds (_ { familyIds = _ })

module Gonimo.UI.Loaded.Types where

import Prelude
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Home as HomeC
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Socket.Lenses as SocketC
import Gonimo.UI.Socket.Types as SocketC
import Control.Monad.Eff (Eff)
import Control.Monad.IO (IO)
import Data.Generic (class Generic)
import Data.Lens (to, _Just, TraversalP, lens, LensP)
import Data.Map (Map)
import Data.Maybe (Maybe)
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (Settings, class ReportErrorAction, GonimoError)
import Gonimo.Server.DbEntities (Device(Device), Family(Family))
import Gonimo.Server.Types (DeviceType)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Error (class ErrorAction, UserError)
import Gonimo.WebAPI.Types (DeviceInfo(DeviceInfo), AuthData(AuthData))
import Servant.Subscriber.Connection (Notification)

type State = { subscriberUrl :: String
             , inviteS  :: InviteC.State
             , acceptS  :: AcceptC.State
             , homeS    :: HomeC.State
             , socketS   :: SocketC.State
             , central  :: Central
             , familyIds :: Array (Key Family)
             , families  :: Map (Key Family) Family
             , onlineDevices :: Array (Tuple (Key Device) DeviceType)
             , deviceInfos :: Array (Tuple (Key Device) DeviceInfo)
             , userError :: UserError
             , url :: String
             , sendAction :: Action -> Eff () Unit
             }

type Props = { settings :: Settings
             , deviceId :: Key Device
             , familyId :: Maybe (Key Family)
             , family :: Maybe Family
             , onlineStatus :: DeviceType
             , onlineDevices :: Array (Tuple (Key Device) DeviceType)
             , deviceInfos :: Array (Tuple (Key Device) DeviceInfo)
             , sendActionSocket :: SocketC.Action -> Eff () Unit
             }

data Action = ReportError GonimoError
            | SetState State
            | InviteA InviteC.Action
            | AcceptA AcceptC.Action
            | HomeA HomeC.Action
            | SocketA SocketC.Action
            | SetFamilyIds (Array (Key Family))
            | UpdateFamily (Key Family) Family
            | SetCentral Central
            | SetOnlineDevices (Array (Tuple (Key Device) DeviceType))
            | SetDeviceInfos (Array (Tuple (Key Device) DeviceInfo))
            | SetURL String
            | HandleSubscriber Notification
            | ResetDevice -- Reinitialize basically everything.
            | ClearError
            | Nop

data Central = CentralInvite
             | CentralAccept
             | CentralHome

centralHome :: Central
centralHome = CentralHome

derive instance genericCentral :: Generic Central

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

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

inviteS :: LensP State InviteC.State
inviteS = lens _.inviteS (_ { inviteS = _ })

acceptS :: LensP State AcceptC.State
acceptS = lens _.acceptS (_ { acceptS = _ })

homeS :: LensP State HomeC.State
homeS = lens _.homeS (_ { homeS = _ })

central :: LensP State Central
central = lens _.central (_ { central = _})

socketS :: LensP State SocketC.State
socketS = lens _.socketS (_ { socketS = _ })

authData :: LensP State AuthData
authData = socketS <<< SocketC.authData

currentFamily :: TraversalP State (Key Family)
currentFamily = socketS <<< SocketC.currentFamily <<< _Just

familyIds :: LensP State (Array (Key Family))
familyIds = lens _.familyIds (_ { familyIds = _ })


Remove Show instance for Char, we have that in Prelude

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

import Prelude

-- | Returns the string of length `1` containing only the given character.
foreign import toString :: Char -> String

-- | Returns the numeric Unicode value of the character.
foreign import toCharCode :: Char -> Int

-- | Constructs a character from the given Unicode numeric value.
foreign import fromCharCode :: Int -> Char

-- | Characters fall within the Unicode range.
instance boundedChar :: Bounded Char where
  top = fromCharCode zero
  bottom = fromCharCode 65535

-- | Characters can be rendered as a string with `show`.
instance showChar :: Show Char where
  show c = "Char " ++ show (toString c)