Restructured invite screen to make it more intuitive.

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.Attributes.Bootstrap 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 (Eff)
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 (Component, ComponentType, noEffects, onlyModify, Update, runGonimo, class MonadComponent, onClickWithDefault)
import Gonimo.Server.Db.Entities (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 (letterSpacing, offset)
import Pux.Html.Elements (br)
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
  , invitationId   :: Key Invitation
  , invitation     :: Invitation
  , sentInvitation :: Maybe SentInvitation
  }

-- | 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 : ""
                            , sentInvitation : Nothing
                            , invitationId : invKey
                            , invitation : inv
                            }

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

type SentInvitation = { invitation :: Invitation
                      , sentMethod :: SentMethod
                      }

data SentMethod = SentWhatsApp | SentTelegram | SentCopyPaste | SentEmail String

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, sentInvitation = Nothing :: Maybe SentInvitation }
  InvitationSent sent       -> handleInvitationSent sent
  SendInvitation            -> handleSendInvitation
  MakeNewInvitation         -> handleMakeNewInvitation
  SetInvitationData id' inv -> onlyModify $ \state -> state { invitationId = id', invitation = inv }
  GoToOverview              -> noEffects
  GoToBabyStation           -> noEffects
  CopyToClipboard elemId    -> handleCopyToClipboard elemId
  ReportError err           -> noEffects
  Nop                       -> noEffects

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

handleInvitationSent :: forall ps. SentMethod -> ComponentType (Props ps) State Action
handleInvitationSent method = do
  state <- get :: Component (Props ps) State State
  modify $ _ { sentInvitation = Just $ { invitation : state.invitation , sentMethod : method } }
  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 (SentEmail state.email)

handleCopyToClipboard :: forall ps. String -> ComponentType (Props ps) State Action
handleCopyToClipboard elemId = pure [ do
                                         liftEff $ copyTextFromId elemId
                                         pure $ InvitationSent SentCopyPaste
                                    ]
--------------------------------------------------------------------------------

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"
                            <> " family, you only have to visit the"
                            <> " following one-time link on another device." ]
                    ]
            , div []
              [ div [ A.className "input-group"]
                [ input [ A.type_ "text", A.className "form-control", A.readOnly true
                        , A.value invitationLink
                        , A.id_ "invitationLinkUrlInput"
                        ] []
                ,  H.span [ A.className "input-group-btn"]
                   [ button [ A.className "btn btn-default"
                            , A.type_ "button"
                            , A.title "Generate new link ..."
                            , E.onClick $ const $ MakeNewInvitation
                            ]
                     [ span [ A.className "glyphicon glyphicon-repeat"] []
                     ]
                   ]
                ]
                , p [] [ br [] []
                       , text $ "You can either share it directly with WhatsApp or Telegram"
                         <> " or copy & paste it to send it via some other means:"
                  ]
            , H.div [ A.className "btn-group btn-group-justified" ]
              [ H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                      , A.href $ "whatsapp://send?text=" <> escapedLink
                      , A.role "button"
                      , A.type_ "button"
                      , onClickWithDefault $ const $ InvitationSent SentWhatsApp
                      ]
                  [
                    -- H.img [ A.src "../static/pix/WhatsApp.svg", A.alt "WhatsApp" ] []
                    H.i [A.className "fa fa-fw fa-whatsapp"] []
                  , H.span [A.className "hidden-xs"] [H.text " WhatsApp"]
                  ]
                ]
              , H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                      , A.href $ "tg://msg?text=" <> escapedLink -- "https://telegram.me/share/url?url=" <> escapedLink
                      , A.role "button"
                      , A.type_ "button"
                      , onClickWithDefault $ const $ InvitationSent SentTelegram
                      ]
                  [ H.i [A.className "fa fa-fw fa-telegram"] []
                  , H.span [A.className "hidden-xs"] [H.text " Telegram"]
                  ]
                ]
              , H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                           , A.role "button"
                           , A.type_ "button"
                           , E.onClick $ const $ CopyToClipboard "invitationLinkUrlInput"
                           ]
                  [ H.span [ A.className "glyphicon glyphicon-copy"] []
                  , H.span [ A.className "hidden-xs"] [H.text " Copy to Clipboard"]
                  ]
                ]
              ]
            , br [] []
            , p []  [ text "Or you can let us 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"] []
              ]
            ]
          ]
          , div [ A.className "container"
                , A.style [Tuple "width" "100%"]]
              [ br [] []
              , 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 "← "]
                            , span [A.className "hidden-xs"] [text "Back to "]
                            , text "Overview"
                            ]
                      ]
              , li [ A.className "next"
                    , E.onClick $ const $ GoToBabyStation
                    ] [ a [] [ span [A.className "hidden-xs"] [text "Make this device a "]
                             , text "Baby Station"
                             , span [A.ariaHidden "true"] [text " →"]
                             ]
                      ]
              ]

            ]
          , viewSent props state
          ]
        ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

viewSent :: forall ps. Props ps -> State -> Html Action
viewSent props state =
  case state.sentInvitation of
    Nothing -> H.span [] []
    Just sent ->
      let
        invLink = makeInviteLink (props.baseURL) sent.invitation
      in
        H.div [ A.className "alert alert-success"]
        [ viewSentMethod sent
        , H.a [ A.href invLink ]
          [ H.text "Oops - Did you send the invitation to the wrong recipient?"
          , br [] []
          , H.text "No problem! Just click me and then press 'Decline' to invalidate the invitation."
          ]
        ]

viewSentMethod :: SentInvitation -> Html Action
viewSentMethod sent = case sent.sentMethod of
  SentCopyPaste -> H.div []
                   [ H.h3 [] [ text $ "Copied invitation link to clipboard!" ]
                   , H.text "Now just paste it somewhere in order to transfer it to another device."
                   ]
  SentWhatsApp -> H.div []
                   [ H.h3 [] [ text $ "Sent link with WhatsApp!" ]
                   , H.text "That did not work out? Just copy and paste the link yourself!"
                   ]
  SentTelegram -> H.div []
                   [ H.h3 [] [ text $ "Sent link with Telegram!" ]
                   , H.text "That did not work out? Just copy and paste the link yourself!"
                   ]
  SentEmail addr -> H.div []
                   [ H.h3 [] [ text $ "Invitation successfully sent to '"  <> addr <> "'!" ]
                   , H.text "Did not receive the e-mail? Please check your spam folder!"
                   ]

foreign import copyTextFromId :: String -> Eff () Boolean

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.Attributes.Bootstrap 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 (Eff)
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 (Component, ComponentType, noEffects, onlyModify, Update, runGonimo, class MonadComponent, onClickWithDefault)
import Gonimo.Server.Db.Entities (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 (letterSpacing, 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
  , invitationId   :: Key Invitation
  , invitation     :: Invitation
  , sentInvitation :: Maybe SentInvitation
  }

-- | 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 : ""
                            , sentInvitation : Nothing
                            , invitationId : invKey
                            , invitation : inv
                            }

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

type SentInvitation = { invitation :: Invitation
                      , sentMethod :: SentMethod
                      }

data SentMethod = SentWhatsApp | SentTelegram | SentCopyPaste | SentEmail String

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, sentInvitation = Nothing :: Maybe SentInvitation }
  InvitationSent sent       -> handleInvitationSent sent
  SendInvitation            -> handleSendInvitation
  MakeNewInvitation         -> handleMakeNewInvitation
  SetInvitationData id' inv -> onlyModify $ \state -> state { invitationId = id', invitation = inv }
  GoToOverview              -> noEffects
  GoToBabyStation           -> noEffects
  CopyToClipboard elemId    -> handleCopyToClipboard elemId
  ReportError err           -> noEffects
  Nop                       -> noEffects

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

handleInvitationSent :: forall ps. SentMethod -> ComponentType (Props ps) State Action
handleInvitationSent method = do
  state <- get :: Component (Props ps) State State
  modify $ _ { sentInvitation = Just $ { invitation : state.invitation , sentMethod : method } }
  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 (SentEmail state.email)

handleCopyToClipboard :: forall ps. String -> ComponentType (Props ps) State Action
handleCopyToClipboard elemId = pure [ do
                                         liftEff $ copyTextFromId elemId
                                         pure $ InvitationSent SentCopyPaste
                                    ]
--------------------------------------------------------------------------------

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 "input-group"]
              [ input [ A.type_ "text", A.className "form-control", A.readOnly true
                      , A.value invitationLink
                      , A.id_ "invitationLinkUrlInput"
                      ] []
              ,  H.span [ A.className "input-group-btn"]
                [ button [ A.className "btn btn-default"
                          , A.type_ "button"
                          , A.title "Generate new link ..."
                          , E.onClick $ const $ MakeNewInvitation
                          ]
                  [ span [ A.className "glyphicon glyphicon-repeat"] []
                  ]
                ]
              ]
            ]
          ]
        , div [ A.className "container"
              , A.style [Tuple "width" "100%"]]
          [ h3 [] [text "copy & paste or share directly"]
          , div [A.className "jumbotron"]
            [ p [] [ text $ "You can either copy & paste it to send it via some means"
                        <> " or share it directly with WhatsApp or Telegram."
                  ]
            , H.div [ A.className "btn-group btn-group-justified" ]
              [
                H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                           , A.role "button"
                           , A.type_ "button"
                           , E.onClick $ const $ CopyToClipboard "invitationLinkUrlInput"
                           ]
                  [ H.span [ A.className "glyphicon glyphicon-copy"] []
                  , H.span [ A.className "hidden-xs"] [H.text " Copy to Clipboard"]
                  ]
                ]
              , H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                      , A.href $ "whatsapp://send?text=" <> escapedLink
                      , A.role "button"
                      , A.type_ "button"
                      , onClickWithDefault $ const $ InvitationSent SentWhatsApp
                      ]
                  [
                    -- H.img [ A.src "../static/pix/WhatsApp.svg", A.alt "WhatsApp" ] []
                    H.i [A.className "fa fa-fw fa-whatsapp"] []
                  , H.span [A.className "hidden-xs"] [H.text " WhatsApp"]
                  ]
                ]
              , H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                      , A.href $ "tg://msg?text=" <> escapedLink -- "https://telegram.me/share/url?url=" <> escapedLink
                      , A.role "button"
                      , A.type_ "button"
                      , onClickWithDefault $ const $ InvitationSent SentTelegram
                      ]
                  [ H.i [A.className "fa fa-fw fa-telegram"] []
                  , H.span [A.className "hidden-xs"] [H.text " Telegram"]
                  ]
                ]
              ]
            , br [] []
            , p []  [ text "Or you can let us 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"] []
              ]
            ]
          , viewSent props state
          , 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 "← "]
                            , span [A.className "hidden-xs"] [text "Back to "]
                            , text "Overview"
                            ]
                      ]
              , li [ A.className "next"
                    , E.onClick $ const $ GoToBabyStation
                    ] [ a [] [ span [A.className "hidden-xs"] [text "Make this device a "]
                             , text "Baby Station"
                             , span [A.ariaHidden "true"] [text " →"]
                             ]
                      ]
              ]

            ]
          ]
        ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

viewSent :: forall ps. Props ps -> State -> Html Action
viewSent props state =
  case state.sentInvitation of
    Nothing -> H.span [] []
    Just sent ->
      let
        invLink = makeInviteLink (props.baseURL) sent.invitation
      in
        H.div [ A.className "alert alert-success"]
        [ viewSentMethod sent
        , H.a [ A.href invLink ]
          [ H.text "Oops - Did you send the invitation to the wrong recipient?"
          , br [] []
          , H.text "No problem! Just click me and then press 'Decline' to invalidate the invitation."
          ]
        ]

viewSentMethod :: SentInvitation -> Html Action
viewSentMethod sent = case sent.sentMethod of
  SentCopyPaste -> H.div []
                   [ H.h3 [] [ text $ "Copied invitation link to clipboard!" ]
                   , H.text "Now just paste it somewhere in order to transfer it to another device."
                   ]
  SentWhatsApp -> H.div []
                   [ H.h3 [] [ text $ "Sent link with WhatsApp!" ]
                   , H.text "That did not work out? Just copy and paste the link yourself!"
                   ]
  SentTelegram -> H.div []
                   [ H.h3 [] [ text $ "Sent link with Telegram!" ]
                   , H.text "That did not work out? Just copy and paste the link yourself!"
                   ]
  SentEmail addr -> H.div []
                   [ H.h3 [] [ text $ "Invitation successfully sent to '"  <> addr <> "'!" ]
                   , H.text "Did not receive the e-mail? Please check your spam folder!"
                   ]

foreign import copyTextFromId :: String -> Eff () Boolean


Remove unnecessary bindings/annotations

Remove unnecessary bindings/annotations

module Control.Monad.Run
  ( Run
  , RunF
  , RProxy(..)
  , REffect
  , RBase
  , run
  , runBase
  , interpret
  , liftEffect
  , liftBase
  , peel
  , send
  , decomp
  , BaseEff
  , BaseAff
  ) where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Free (Free, liftF, runFree, foldFree, substFree, resume)
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Data.Either (Either(..))
import Data.Newtype (class Newtype, unwrap, wrap, over)
import Data.Symbol (SProxy(..), class IsSymbol, reflectSymbol)
import Data.Yoneda (Yoneda, liftYoneda, lowerYoneda, hoistYoneda)
import Partial.Unsafe (unsafeCrashWith)
import Type.Equality (class TypeEquals)
import Unsafe.Coerce (unsafeCoerce)

-- | Phantom type for effect rows. Effect functors need to be tagged because
-- | the type level row constraints only works on rows of kind `Type`.
data REffect (f ∷ Type → Type)

-- | Phantom type the base, or terminal, effect. This may be something like
-- | `Eff`, `Aff`, or `IO`.
data RBase (f ∷ Type → Type)

newtype FTag = FTag String

data FBox a

mkFBox ∷ ∀ a f. Yoneda f a → FBox a
mkFBox = unsafeCoerce

runFBox ∷ ∀ a r. (∀ f. Yoneda f a → r) → FBox a → r
runFBox = unsafeCoerce

-- | A proxy type which links a label with an effect functor.
data RProxy (sym ∷ Symbol) (f ∷ Type → Type) = RProxy

-- | An opaque instruction in the `Run` Monad. Instructions can be inspected
-- | using `decomp` and an `RProxy` for a given effect.
data RunF (r ∷ # Type) a = RunF FTag (FBox a)

-- | An extensible effect Monad, indexed by a set of effect functors. Effects
-- | are eliminated by interpretation into a pure value or into some base
-- | effect Monad. The `Run` Monad is an alternative to Monad Transformers,
-- | and can represent both associative and non-associative effects.
-- |
-- | An example using `State` and `Except`:
-- | ```purescript
-- | type MyEffects =
-- |   ( state ∷ STATE Int
-- |   , except ∷ EXCEPT String
-- |   , base ∷ BaseEff (console ∷ CONSOLE)
-- |   )
-- |
-- | yesProgram ∷ Run MyEffects Unit
-- | yesProgram = do
-- |   whenM (gets (_ < 0)) do
-- |     throw "Number is less than 0"
-- |   whileM_ (gets (_ > 0)) do
-- |     liftEff $ log "Yes"
-- |     modify (_ - 1)
-- |
-- | main =
-- |   yesProgram
-- |     # catch (liftEff <<< log)
-- |     # runState 10
-- |     # runBase
-- |     # void
-- | ````
newtype Run (r ∷ # Type) a = RunM (Free (RunF r) a)

instance functorRunF ∷ Functor (RunF r) where
  map f (RunF tag ex) = RunF tag $ runFBox (mkFBox <<< map f) ex

derive instance newtypeRun ∷ Newtype (Run r a) _
derive newtype instance functorRun :: Functor (Run r)
derive newtype instance applyRun :: Apply (Run r)
derive newtype instance applicativeRun :: Applicative (Run r)
derive newtype instance bindRun :: Bind (Run r)
derive newtype instance monadRun :: Monad (Run r)

-- | Lifts an effect functor into the `Run` Monad according to the provided
-- | `RProxy` slot.
liftEffect
  ∷ ∀ sym r1 r2 f a
  . RowCons sym (REffect f) r1 r2
  ⇒ IsSymbol sym
  ⇒ Functor f
  ⇒ RProxy sym f
  → f a
  → Run r2 a
liftEffect _ f = RunM $ liftF $ RunF (FTag (reflectSymbol (SProxy ∷ SProxy sym))) (mkFBox (liftYoneda f))

-- | Lifts a base effect into the `Run` Monad (eg. `Eff`, `Aff`, or `IO`).
liftBase
  ∷ ∀ r f a
  . Functor f
  ⇒ f a
  → Run (base ∷ RBase f | r) a
liftBase f = RunM $ liftF $ RunF (FTag "base") (mkFBox (liftYoneda f))

-- | Reflects the next instruction or the final value if there are no more
-- | instructions.
peel
  ∷ ∀ a r
  . Run r a
  → Either (RunF r (Run r a)) a
peel (RunM r) = unsafeCoerce (resume r)

-- | Enqueues an instruction in the `Run` Monad.
send
  ∷ ∀ a r
  . RunF r a
  → Run r a
send = wrap <<< liftF

-- | Attempts to read an instruction according to the provided `RProxy`. If the
-- | instruction does not match, it will yield the instruction with the effect
-- | label removed.
decomp
  ∷ ∀ sym r1 r2 f a
  . RowCons sym (REffect f) r1 r2
  ⇒ IsSymbol sym
  ⇒ RProxy sym f
  → RunF r2 a
  → Either (RunF r1 a) (f a)
decomp _ r@(RunF (FTag tag) f) =
  if tag == reflectSymbol (SProxy ∷ SProxy sym)
    then Right (runFBox (coerceN <<< lowerYoneda) f)
    else Left (coerceR r)
  where
  coerceN ∷ ∀ g. g ~> f
  coerceN = unsafeCoerce

  coerceR ∷ RunF r2 a → RunF r1 a
  coerceR = unsafeCoerce

-- | Extracts the value from a fully interpreted program.
run ∷ ∀ a. Run () a → a
run = unwrap >>> runFree \_ → unsafeCrashWith "Control.Monad.Run: the impossible happened"

-- | Extracts the value from a program with only base effects.
runBase
  ∷ ∀ f a
  . MonadRec f
  ⇒ Run (base ∷ RBase f) a
  → f a
runBase = unwrap >>> foldFree go
  where
  go ∷ RunF (base ∷ RBase f) ~> f
  go (RunF _ fb) = runFBox (coerceY <<< lowerYoneda) fb

  coerceY ∷ ∀ g. g ~> f
  coerceY = unsafeCoerce

-- | Interprets an effect functor into the base effect, eliminating the label.
interpret
  ∷ ∀ sym f m r1 r2 r3 a
  . RowCons sym (REffect f) r2 r1
  ⇒ RowCons "base" (RBase m) r2 r3
  ⇒ IsSymbol sym
  ⇒ RProxy sym f
  → (f ~> m)
  → Run r1 a
  → Run r3 a
interpret _ k = over RunM (substFree (\a → liftF (go a)))
  where
  tag =
    reflectSymbol (SProxy ∷ SProxy sym)

  go ∷ RunF r1 ~> RunF r3
  go r@(RunF (FTag tag') f) =
    if tag == tag'
      then RunF (FTag "base") (runFBox (mkFBox <<< hoistYoneda (k <<< coerceN)) f)
      else coerceR r

  coerceN ∷ ∀ g. g ~> f
  coerceN = unsafeCoerce

  coerceR ∷ RunF r1 ~> RunF r3
  coerceR = unsafeCoerce

data R (r ∷ # Type)

-- Type synonym for using `Eff` as a base effect.
type BaseEff eff = RBase (Eff eff)

-- Type synonym for using `Aff` as a base effect.
type BaseAff eff = RBase (Aff eff)

instance monadRecRun ∷ MonadRec (Run r) where
  tailRecM f = loop
    where
    loop a = do
      b ← f a
      case b of
        Done r → pure r
        Loop n → loop n

instance monadEffRun ∷ (TypeEquals (R rs) (R (base ∷ RBase m | r)), MonadEff eff m) ⇒ MonadEff eff (Run rs) where
  liftEff = coerceR <<< liftBase <<< liftEff
    where
    coerceR ∷ Run (base ∷ RBase m | r) ~> Run rs
    coerceR = unsafeCoerce

instance monadAffRun ∷ (TypeEquals (R rs) (R (base ∷ RBase m | r)), MonadAff eff m) ⇒ MonadAff eff (Run rs) where
  liftAff = coerceR <<< liftBase <<< liftAff
    where
    coerceR ∷ Run (base ∷ RBase m | r) ~> Run rs
    coerceR = unsafeCoerce

module Control.Monad.Run
  ( Run
  , RunF
  , RProxy(..)
  , REffect
  , RBase
  , run
  , runBase
  , interpret
  , liftEffect
  , liftBase
  , peel
  , send
  , decomp
  , BaseEff
  , BaseAff
  ) where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Free (Free, liftF, runFree, foldFree, substFree, resume)
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Data.Either (Either(..))
import Data.Newtype (class Newtype, unwrap, wrap, over)
import Data.Symbol (SProxy(..), class IsSymbol, reflectSymbol)
import Data.Yoneda (Yoneda, liftYoneda, lowerYoneda, hoistYoneda)
import Partial.Unsafe (unsafeCrashWith)
import Type.Equality (class TypeEquals)
import Unsafe.Coerce (unsafeCoerce)

-- | Phantom type for effect rows. Effect functors need to be tagged because
-- | the type level row constraints only works on rows of kind `Type`.
data REffect (f ∷ Type → Type)

-- | Phantom type the base, or terminal, effect. This may be something like
-- | `Eff`, `Aff`, or `IO`.
data RBase (f ∷ Type → Type)

newtype FTag = FTag String

data FBox a

mkFBox ∷ ∀ a f. Yoneda f a → FBox a
mkFBox = unsafeCoerce

runFBox ∷ ∀ a r. (∀ f. Yoneda f a → r) → FBox a → r
runFBox = unsafeCoerce

-- | A proxy type which links a label with an effect functor.
data RProxy (sym ∷ Symbol) (f ∷ Type → Type) = RProxy

-- | An opaque instruction in the `Run` Monad. Instructions can be inspected
-- | using `decomp` and an `RProxy` for a given effect.
data RunF (r ∷ # Type) a = RunF FTag (FBox a)

-- | An extensible effect Monad, indexed by a set of effect functors. Effects
-- | are eliminated by interpretation into a pure value or into some base
-- | effect Monad. The `Run` Monad is an alternative to Monad Transformers,
-- | and can represent both associative and non-associative effects.
-- |
-- | An example using `State` and `Except`:
-- | ```purescript
-- | type MyEffects =
-- |   ( state ∷ STATE Int
-- |   , except ∷ EXCEPT String
-- |   , base ∷ BaseEff (console ∷ CONSOLE)
-- |   )
-- |
-- | yesProgram ∷ Run MyEffects Unit
-- | yesProgram = do
-- |   whenM (gets (_ < 0)) do
-- |     throw "Number is less than 0"
-- |   whileM_ (gets (_ > 0)) do
-- |     liftEff $ log "Yes"
-- |     modify (_ - 1)
-- |
-- | main =
-- |   yesProgram
-- |     # catch (liftEff <<< log)
-- |     # runState 10
-- |     # runBase
-- |     # void
-- | ````
newtype Run (r ∷ # Type) a = RunM (Free (RunF r) a)

instance functorRunF ∷ Functor (RunF r) where
  map f (RunF tag ex) = RunF tag $ runFBox (mkFBox <<< map f) ex

derive instance newtypeRun ∷ Newtype (Run r a) _
derive newtype instance functorRun :: Functor (Run r)
derive newtype instance applyRun :: Apply (Run r)
derive newtype instance applicativeRun :: Applicative (Run r)
derive newtype instance bindRun :: Bind (Run r)
derive newtype instance monadRun :: Monad (Run r)

-- | Lifts an effect functor into the `Run` Monad according to the provided
-- | `RProxy` slot.
liftEffect
  ∷ ∀ sym r1 r2 f a
  . RowCons sym (REffect f) r1 r2
  ⇒ IsSymbol sym
  ⇒ Functor f
  ⇒ RProxy sym f
  → f a
  → Run r2 a
liftEffect _ f = RunM $ liftF $ RunF (FTag (reflectSymbol (SProxy ∷ SProxy sym))) (mkFBox (liftYoneda f))

-- | Lifts a base effect into the `Run` Monad (eg. `Eff`, `Aff`, or `IO`).
liftBase
  ∷ ∀ r f a
  . Functor f
  ⇒ f a
  → Run (base ∷ RBase f | r) a
liftBase f = RunM $ liftF $ RunF (FTag "base") (mkFBox (liftYoneda f))

-- | Reflects the next instruction or the final value if there are no more
-- | instructions.
peel
  ∷ ∀ a r
  . Run r a
  → Either (RunF r (Run r a)) a
peel (RunM r) = unsafeCoerce (resume r)

-- | Enqueues an instruction in the `Run` Monad.
send
  ∷ ∀ a r
  . RunF r a
  → Run r a
send = wrap <<< liftF

-- | Attempts to read an instruction according to the provided `RProxy`. If the
-- | instruction does not match, it will yield the instruction with the effect
-- | label removed.
decomp
  ∷ ∀ sym r1 r2 f a
  . RowCons sym (REffect f) r1 r2
  ⇒ IsSymbol sym
  ⇒ RProxy sym f
  → RunF r2 a
  → Either (RunF r1 a) (f a)
decomp _ r@(RunF (FTag tag) f) =
  if tag == reflectSymbol (SProxy ∷ SProxy sym)
    then Right (runFBox (coerceN <<< lowerYoneda) f)
    else Left (coerceR r)
  where
  coerceN ∷ ∀ g. g ~> f
  coerceN = unsafeCoerce

  coerceR ∷ RunF r2 a → RunF r1 a
  coerceR = unsafeCoerce

-- | Extracts the value from a fully interpreted program.
run ∷ ∀ a. Run () a → a
run = unwrap >>> runFree \_ → unsafeCrashWith "Control.Monad.Run: the impossible happened"

-- | Extracts the value from a program with only base effects.
runBase
  ∷ ∀ f a
  . MonadRec f
  ⇒ Run (base ∷ RBase f) a
  → f a
runBase = unwrap >>> foldFree go
  where
  go ∷ RunF (base ∷ RBase f) ~> f
  go (RunF _ fb) = runFBox (coerceY <<< lowerYoneda) fb

  coerceY ∷ ∀ g. g ~> f
  coerceY = unsafeCoerce

-- | Interprets an effect functor into the base effect, eliminating the label.
interpret
  ∷ ∀ sym f m r1 r2 r3 a
  . RowCons sym (REffect f) r2 r1
  ⇒ RowCons "base" (RBase m) r2 r3
  ⇒ IsSymbol sym
  ⇒ RProxy sym f
  → (f ~> m)
  → Run r1 a
  → Run r3 a
interpret _ k = over RunM (substFree (\a → liftF (go a)))
  where
  tag =
    reflectSymbol (SProxy ∷ SProxy sym)

  go ∷ RunF r1 ~> RunF r3
  go r@(RunF (FTag tag') f) =
    if tag == tag'
      then RunF (FTag "base") (runFBox (mkFBox <<< hoistYoneda (k <<< coerceN)) f)
      else coerceR r

  coerceN ∷ ∀ g. g ~> f
  coerceN = unsafeCoerce

  coerceR ∷ RunF r1 ~> RunF r3
  coerceR = unsafeCoerce

data R (r ∷ # Type)

-- Type synonym for using `Eff` as a base effect.
type BaseEff eff = RBase (Eff eff)

-- Type synonym for using `Aff` as a base effect.
type BaseAff eff = RBase (Aff eff)

instance monadRecRun ∷ MonadRec (Run r) where
  tailRecM f = loop
    where
    loop a = do
      b ← f a
      case b of
        Done r → pure r
        Loop n → loop n

instance monadEffRun ∷ (TypeEquals (R rs) (R (base ∷ RBase m | r)), MonadEff eff m) ⇒ MonadEff eff (Run rs) where
  liftEff = coerceR <<< liftBase' <<< liftEff'
    where
    liftEff' ∷ ∀ a. Eff eff a → m a
    liftEff' = liftEff

    liftBase' ∷ ∀ a. m a → Run (base ∷ RBase m | r) a
    liftBase' = liftBase

    coerceR ∷ Run (base ∷ RBase m | r) ~> Run rs
    coerceR = unsafeCoerce

instance monadAffRun ∷ (TypeEquals (R rs) (R (base ∷ RBase m | r)), MonadAff eff m) ⇒ MonadAff eff (Run rs) where
  liftAff = coerceR <<< liftBase' <<< liftAff'
    where
    liftAff' ∷ ∀ a. Aff eff a → m a
    liftAff' = liftAff

    liftBase' ∷ ∀ a. m a → Run (base ∷ RBase m | r) a
    liftBase' = liftBase

    coerceR ∷ Run (base ∷ RBase m | r) ~> Run rs
    coerceR = unsafeCoerce


UserInfo JSON serialization

UserInfo JSON serialization

module Common.Data.UserInfo where

import Data.Argonaut.Core (toObject, fromObject)
import Data.Argonaut.Combinators ((:=), (?>>=), (.?))
import Data.Argonaut.Decode (class DecodeJson)
import Data.Argonaut.Encode (class EncodeJson)
import Data.List (toList)
import Data.StrMap (fromList) as S
import Prelude

newtype UserInfo =
  UserInfo
  { _id :: String
  , _rev :: String
  , displayName :: String
  }

instance decodeJsonUserInfo :: DecodeJson UserInfo where
  decodeJson json = do
    o <- toObject json ?>>= "Expected object"
    _id <- o .? "_id"
    _rev <- o .? "_rev"
    displayName <- o .? "displayName"
    return $ UserInfo { _id, _rev, displayName }

instance encodeJsonUserInfo :: EncodeJson UserInfo where
  encodeJson (UserInfo info) =
    fromObject $ S.fromList $ toList
    [ "_id" := info._id
    , "_rev" := info._rev
    , "displayName" := info.displayName
    ]

userInfoId :: String
userInfoId = "userInfo"

module Common.Data.UserInfo where

import Data.Argonaut.Core (toObject, jsonEmptyObject)
import Data.Argonaut.Combinators ((:=), (~>), (?>>=), (.?))
import Data.Argonaut.Decode (class DecodeJson)
import Data.Argonaut.Encode (class EncodeJson)
import Prelude

newtype UserInfo =
  UserInfo
  { _id :: String
  , _rev :: String
  , displayName :: String
  }

instance decodeJsonUserInfo :: DecodeJson UserInfo where
  decodeJson json = do
    o <- toObject json ?>>= "Expected object"
    _id <- o .? "_id"
    _rev <- o .? "_rev"
    displayName <- o .? "displayName"
    return $ UserInfo { _id, _rev, displayName }

instance encodeJsonUserInfo :: EncodeJson UserInfo where
  encodeJson (UserInfo info) =
    ("_id" := info._id) ~> ("_rev" := info._rev) ~> ("displayName" := info.displayName) ~> jsonEmptyObject

userInfoId :: String
userInfoId = "userInfo"


Fix duplicate initializers

Fix duplicate initializers

module Halogen.Aff.Driver
  ( RenderSpec
  , runUI
  , module Halogen
  ) where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Fork.Class (fork)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Parallel (parSequence_)
import Data.Either (Either(..), either)
import Data.List ((:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, isJust, isNothing)
import Data.Traversable (for_, traverse_)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff (Aff, runAff_)
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Console (warn)
import Effect.Exception (error, throw, throwException)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Halogen (HalogenIO)
import Halogen.Aff.Driver.Eval as Eval
import Halogen.Aff.Driver.State (DriverState(..), DriverStateRef(..), DriverStateX, LifecycleHandlers, RenderStateX, initDriverState, mapDriverState, renderStateX, renderStateX_, unDriverStateX)
import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.Slot as Slot
import Halogen.Query.EventSource as ES
import Halogen.Query.HalogenQ (HalogenQ(..))
import Halogen.Query.Input (Input(..))

-- | `RenderSpec` allows for alternative driver implementations without the need
-- | to provide all of the driver machinery again, focusing just on the code
-- | needed to render components.
-- |
-- | The type variables are as follows:
-- | - `h` is the type of value being rendered (`Halogen.HTML.Core.HTML`, for
-- |   example).
-- | - `r` is the type for the "render state" for the driver. This is a value
-- |   that is stored for each component, that allows the driver to persist
-- |   state between each rendering of a component. This will differ entirely
-- |   for each driver. `r` accepts a number of parameters that will be
-- |   explained below.
-- |
-- | The "inner" type variables, used by `r` and the other functions are as
-- | follows:
-- | - `s` is the state type for the component.
-- | - `act` is the action type for the component
-- | - `ps` is the set of slots for addressing child components
-- | - `o` is the output message type for the component
-- |
-- | Note that none of these variables can escape `RenderSpec`'s functions. They
-- | need to be instantiated with each function call, as the same `RenderSpec`
-- | is used to deal with all components in the hierarchy.
-- |
-- | The `render` function is the main part of the spec, it accepts:
-- | - A "handler" function, for evaluating component queries. This is used to
-- |   implement event handlers in HTML-based drivers.
-- | - A "child" function for dealing with the rendering of children, returning
-- |   the render state for the child component in an existentially hidden
-- |   package. This return value would commonly be used to extract the rendered
-- |   subtree for the child to graft it in place of the child slot. The
-- |   existential package can be unwrapped with `Halogen.Aff.Driver.State.unRenderStateX`.
-- | - The `h` value to render, parameterised by the slot type for the
-- |   component's children. This slot type is what the "child" function
-- |   accepts.
-- | - The previous render state for the component. If the component has not
-- |   previously been initalized, this will be `Nothing`.
-- |
-- | The render function then returns the updated (or initial) render state for
-- | the component, which will be fed back into `render` the next time the
-- | component needs to update.
-- |
-- | The `renderChild` function's behaviour will be highly dependant on the
-- | particular driver implementing `RenderSpec`. Its purpose is to take a
-- | driver render state for a component and produce a new one that may remap
-- | the rendered value to be something more suitable for grafting during
-- | `render` of the parent. For the built-in `halogen-vdom` driver this is
-- | just `identity`. For the `virtual-dom` driver it wraps the rendered HTML
-- | in a widget, to prevent the `virtual-dom` algorithm from re-diffing
-- | values that we know are unchanged.
-- |
-- | The `removeChild` function is for drivers that need to perform some special
-- | cleanup when removing a component from the hierarchy. In the `halogen-vdom`
-- | driver this actually performs the `removeChild` from the DOM. For the
-- | `virtual-dom` driver nothing needs to happen here, so it is
-- | `const (pure unit)`.
type RenderSpec h r =
  { render
      :: forall s act ps o
       . (Input act -> Effect Unit)
      -> (ComponentSlot h ps Aff act -> Effect (RenderStateX r))
      -> h (ComponentSlot h ps Aff act) act
      -> Maybe (r s act ps o)
      -> Effect (r s act ps o)
  , renderChild :: forall s act ps o. r s act ps o -> r s act ps o
  , removeChild :: forall s act ps o. r s act ps o -> Effect Unit
  }

runUI
  :: forall h r f i o
   . RenderSpec h r
  -> Component h f i o Aff
  -> i
  -> Aff (HalogenIO f o Aff)
runUI renderSpec component i = do
  lchs <- liftEffect newLifecycleHandlers
  fresh <- liftEffect $ Ref.new 0
  Eval.handleLifecycle lchs do
    listeners <- Ref.new M.empty
    runComponent lchs (rootHandler listeners) i component
      >>= Ref.read
      >>= unDriverStateX \st ->
        pure
          { query: evalDriver st.selfRef
          , subscribe: subscribe fresh listeners
          }

  where

  evalDriver
    :: forall s f' act ps i' o'
     . Ref (DriverState h r s f' act ps i' o')
    -> f'
    ~> Aff
  evalDriver ref = Eval.evalQ render ref

  rootHandler :: Ref (M.Map Int (AV.AVar o)) -> o -> Aff Unit
  rootHandler ref message = do
    listeners <- liftEffect $ Ref.read ref
    traverse_ fork $ map (AV.put message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o Aff Unit
    -> Aff Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.empty
    listenerId <- liftEffect do
      listenerId <- Ref.read fresh
      Ref.modify_ (_ + 1) fresh
      Ref.modify_ (M.insert listenerId inputVar) ref
      pure listenerId
    let producer = CR.producer (Left <$> AV.take inputVar)
    void $ fork do
      CR.runProcess (CR.connect producer consumer)
      liftEffect $ Ref.modify_ (M.delete listenerId) ref
      AV.kill (error "ended") inputVar

  runComponent
    :: forall f' i' o'
     . Ref LifecycleHandlers
    -> (o' -> Aff Unit)
    -> i'
    -> Component h f' i' o' Aff
    -> Effect (Ref (DriverStateX h r f' o'))
  runComponent lchs handler j = unComponent \c -> do
    lchs' <- newLifecycleHandlers
    var <- initDriverState c j handler lchs'
    pre <- Ref.read lchs
    Ref.write { initializers: L.Nil, finalizers: pre.finalizers } lchs
    unDriverStateX (render lchs <<< _.selfRef) =<< Ref.read var
    squashChildInitializers lchs pre.initializers =<< Ref.read var
    pure var

  render
    :: forall s f' act ps i' o'
     . Ref LifecycleHandlers
    -> Ref (DriverState h r s f' act ps i' o')
    -> Effect Unit
  render lchs var = Ref.read var >>= \(DriverState ds) -> do
    shouldProcessHandlers <- isNothing <$> Ref.read ds.pendingHandlers
    when shouldProcessHandlers $ Ref.write (Just L.Nil) ds.pendingHandlers
    Ref.write Slot.empty ds.childrenOut
    Ref.write ds.children ds.childrenIn
    let
      handler :: Input act -> Aff Unit
      handler = Eval.queueOrRun ds.pendingHandlers <<< void <<< Eval.evalF render ds.selfRef
      childHandler :: act -> Aff Unit
      childHandler = Eval.queueOrRun ds.pendingQueries <<< handler <<< Action
    rendering <-
      renderSpec.render
        (handleAff <<< handler)
        (renderChild lchs childHandler ds.childrenIn ds.childrenOut)
        (ds.component.render ds.state)
        ds.rendering
    children <- Ref.read ds.childrenOut
    childrenIn <- Ref.read ds.childrenIn
    Slot.foreachSlot childrenIn \(DriverStateRef childVar) -> do
      childDS <- Ref.read childVar
      renderStateX_ renderSpec.removeChild childDS
      finalize lchs childDS
    flip Ref.modify_ ds.selfRef $ mapDriverState \ds' ->
      ds' { rendering = Just rendering, children = children }
    when shouldProcessHandlers do
      flip tailRecM unit \_ -> do
        handlers <- Ref.read ds.pendingHandlers
        Ref.write (Just L.Nil) ds.pendingHandlers
        traverse_ (handleAff <<< traverse_ fork <<< L.reverse) handlers
        mmore <- Ref.read ds.pendingHandlers
        if maybe false L.null mmore
          then Ref.write Nothing ds.pendingHandlers $> Done unit
          else pure $ Loop unit

  renderChild
    :: forall ps act
     . Ref LifecycleHandlers
    -> (act -> Aff Unit)
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> ComponentSlot h ps Aff act
    -> Effect (RenderStateX r)
  renderChild lchs handler childrenInRef childrenOutRef =
    unComponentSlot \slot -> do
      childrenIn <- Ref.read childrenInRef
      var <- case slot.pop childrenIn of
        Just (Tuple (DriverStateRef existing) childrenIn') -> do
          Ref.write childrenIn' childrenInRef
          dsx <- Ref.read existing
          unDriverStateX (\st -> do
            flip Ref.write st.handlerRef $ maybe (pure unit) handler <<< slot.output
            handleAff $ Eval.evalM render st.selfRef (st.component.eval slot.input)) dsx
          pure existing
        Nothing ->
          case slot.input of
            Receive si _ ->
              runComponent lchs (maybe (pure unit) handler <<< slot.output) si slot.component
            _ ->
              throw "Halogen internal error: slot input was not a Receive query"
      isDuplicate <- isJust <<< slot.get <$> Ref.read childrenOutRef
      when isDuplicate
        $ warn "Halogen: Duplicate slot address was detected during rendering, unexpected results may occur"
      Ref.modify_ (slot.set $ DriverStateRef var) childrenOutRef
      Ref.read var >>= renderStateX case _ of
        Nothing -> throw "Halogen internal error: child was not initialized in renderChild"
        Just r -> pure (renderSpec.renderChild r)

  squashChildInitializers
    :: forall f' o'
     . Ref LifecycleHandlers
    -> L.List (Aff Unit)
    -> DriverStateX h r f' o'
    -> Effect Unit
  squashChildInitializers lchs preInits =
    unDriverStateX \st -> do
      let parentInitializer = Eval.evalM render st.selfRef (st.component.eval (Initialize unit))
      Ref.modify_ (\handlers ->
        { initializers: (do
            parSequence_ (L.reverse handlers.initializers)
            parentInitializer
            liftEffect do
              handlePending st.pendingQueries
              handlePending st.pendingOuts) : preInits
        , finalizers: handlers.finalizers
        }) lchs

  finalize
    :: forall f' o'
     . Ref LifecycleHandlers
    -> DriverStateX h r f' o'
    -> Effect Unit
  finalize lchs = do
    unDriverStateX \st -> do
      cleanupSubscriptions (DriverState st)
      let f = Eval.evalM render st.selfRef (st.component.eval (Finalize unit))
      Ref.modify_ (\handlers ->
        { initializers: handlers.initializers
        , finalizers: f : handlers.finalizers
        }) lchs
      Slot.foreachSlot st.children \(DriverStateRef ref) -> do
        dsx <- Ref.read ref
        finalize lchs dsx

newLifecycleHandlers :: Effect (Ref LifecycleHandlers)
newLifecycleHandlers = Ref.new { initializers: L.Nil, finalizers: L.Nil }

handlePending :: Ref (Maybe (L.List (Aff Unit))) -> Effect Unit
handlePending ref = do
  queue <- Ref.read ref
  Ref.write Nothing ref
  for_ queue (handleAff <<< traverse_ fork <<< L.reverse)

cleanupSubscriptions
  :: forall h r s f act ps i o
   . DriverState h r s f act ps i o
  -> Effect Unit
cleanupSubscriptions (DriverState ds) = do
  traverse_ (handleAff <<< traverse_ (fork <<< ES.finalize)) =<< Ref.read ds.subscriptions
  Ref.write Nothing ds.subscriptions

-- We could perhaps do something more intelligent now this isn't baked into
-- the virtual-dom rendering. It hasn't really been a problem so far though.
handleAff :: forall a. Aff a -> Effect Unit
handleAff = runAff_ (either throwException (const (pure unit)))

module Halogen.Aff.Driver
  ( RenderSpec
  , runUI
  , module Halogen
  ) where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Fork.Class (fork)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Parallel (parSequence_)
import Data.Either (Either(..), either)
import Data.List ((:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, isJust, isNothing)
import Data.Traversable (for_, traverse_)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff (Aff, runAff_)
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Console (warn)
import Effect.Exception (error, throw, throwException)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Halogen (HalogenIO)
import Halogen.Aff.Driver.Eval as Eval
import Halogen.Aff.Driver.State (DriverState(..), DriverStateRef(..), DriverStateX, LifecycleHandlers, RenderStateX, initDriverState, mapDriverState, renderStateX, renderStateX_, unDriverStateX)
import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.Slot as Slot
import Halogen.Query.EventSource as ES
import Halogen.Query.HalogenQ (HalogenQ(..))
import Halogen.Query.Input (Input(..))

-- | `RenderSpec` allows for alternative driver implementations without the need
-- | to provide all of the driver machinery again, focusing just on the code
-- | needed to render components.
-- |
-- | The type variables are as follows:
-- | - `h` is the type of value being rendered (`Halogen.HTML.Core.HTML`, for
-- |   example).
-- | - `r` is the type for the "render state" for the driver. This is a value
-- |   that is stored for each component, that allows the driver to persist
-- |   state between each rendering of a component. This will differ entirely
-- |   for each driver. `r` accepts a number of parameters that will be
-- |   explained below.
-- |
-- | The "inner" type variables, used by `r` and the other functions are as
-- | follows:
-- | - `s` is the state type for the component.
-- | - `act` is the action type for the component
-- | - `ps` is the set of slots for addressing child components
-- | - `o` is the output message type for the component
-- |
-- | Note that none of these variables can escape `RenderSpec`'s functions. They
-- | need to be instantiated with each function call, as the same `RenderSpec`
-- | is used to deal with all components in the hierarchy.
-- |
-- | The `render` function is the main part of the spec, it accepts:
-- | - A "handler" function, for evaluating component queries. This is used to
-- |   implement event handlers in HTML-based drivers.
-- | - A "child" function for dealing with the rendering of children, returning
-- |   the render state for the child component in an existentially hidden
-- |   package. This return value would commonly be used to extract the rendered
-- |   subtree for the child to graft it in place of the child slot. The
-- |   existential package can be unwrapped with `Halogen.Aff.Driver.State.unRenderStateX`.
-- | - The `h` value to render, parameterised by the slot type for the
-- |   component's children. This slot type is what the "child" function
-- |   accepts.
-- | - The previous render state for the component. If the component has not
-- |   previously been initalized, this will be `Nothing`.
-- |
-- | The render function then returns the updated (or initial) render state for
-- | the component, which will be fed back into `render` the next time the
-- | component needs to update.
-- |
-- | The `renderChild` function's behaviour will be highly dependant on the
-- | particular driver implementing `RenderSpec`. Its purpose is to take a
-- | driver render state for a component and produce a new one that may remap
-- | the rendered value to be something more suitable for grafting during
-- | `render` of the parent. For the built-in `halogen-vdom` driver this is
-- | just `identity`. For the `virtual-dom` driver it wraps the rendered HTML
-- | in a widget, to prevent the `virtual-dom` algorithm from re-diffing
-- | values that we know are unchanged.
-- |
-- | The `removeChild` function is for drivers that need to perform some special
-- | cleanup when removing a component from the hierarchy. In the `halogen-vdom`
-- | driver this actually performs the `removeChild` from the DOM. For the
-- | `virtual-dom` driver nothing needs to happen here, so it is
-- | `const (pure unit)`.
type RenderSpec h r =
  { render
      :: forall s act ps o
       . (Input act -> Effect Unit)
      -> (ComponentSlot h ps Aff act -> Effect (RenderStateX r))
      -> h (ComponentSlot h ps Aff act) act
      -> Maybe (r s act ps o)
      -> Effect (r s act ps o)
  , renderChild :: forall s act ps o. r s act ps o -> r s act ps o
  , removeChild :: forall s act ps o. r s act ps o -> Effect Unit
  }

runUI
  :: forall h r f i o
   . RenderSpec h r
  -> Component h f i o Aff
  -> i
  -> Aff (HalogenIO f o Aff)
runUI renderSpec component i = do
  lchs <- liftEffect newLifecycleHandlers
  fresh <- liftEffect $ Ref.new 0
  Eval.handleLifecycle lchs do
    listeners <- Ref.new M.empty
    runComponent lchs (rootHandler listeners) i component
      >>= Ref.read
      >>= unDriverStateX \st ->
        pure
          { query: evalDriver st.selfRef
          , subscribe: subscribe fresh listeners
          }

  where

  evalDriver
    :: forall s f' act ps i' o'
     . Ref (DriverState h r s f' act ps i' o')
    -> f'
    ~> Aff
  evalDriver ref = Eval.evalQ render ref

  rootHandler :: Ref (M.Map Int (AV.AVar o)) -> o -> Aff Unit
  rootHandler ref message = do
    listeners <- liftEffect $ Ref.read ref
    traverse_ fork $ map (AV.put message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o Aff Unit
    -> Aff Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.empty
    listenerId <- liftEffect do
      listenerId <- Ref.read fresh
      Ref.modify_ (_ + 1) fresh
      Ref.modify_ (M.insert listenerId inputVar) ref
      pure listenerId
    let producer = CR.producer (Left <$> AV.take inputVar)
    void $ fork do
      CR.runProcess (CR.connect producer consumer)
      liftEffect $ Ref.modify_ (M.delete listenerId) ref
      AV.kill (error "ended") inputVar

  runComponent
    :: forall f' i' o'
     . Ref LifecycleHandlers
    -> (o' -> Aff Unit)
    -> i'
    -> Component h f' i' o' Aff
    -> Effect (Ref (DriverStateX h r f' o'))
  runComponent lchs handler j = unComponent \c -> do
    lchs' <- newLifecycleHandlers
    var <- initDriverState c j handler lchs'
    dsx <- Ref.read var
    unDriverStateX (\st -> do
      let initialize = Eval.evalM render st.selfRef (st.component.eval (Initialize unit))
      Ref.write (Just (L.singleton initialize)) st.pendingQueries) dsx
    pre <- Ref.read lchs
    Ref.write { initializers: L.Nil, finalizers: pre.finalizers } lchs
    unDriverStateX (render lchs <<< _.selfRef) =<< Ref.read var
    squashChildInitializers lchs pre.initializers =<< Ref.read var
    pure var

  render
    :: forall s f' act ps i' o'
     . Ref LifecycleHandlers
    -> Ref (DriverState h r s f' act ps i' o')
    -> Effect Unit
  render lchs var = Ref.read var >>= \(DriverState ds) -> do
    shouldProcessHandlers <- isNothing <$> Ref.read ds.pendingHandlers
    when shouldProcessHandlers $ Ref.write (Just L.Nil) ds.pendingHandlers
    Ref.write Slot.empty ds.childrenOut
    Ref.write ds.children ds.childrenIn
    let
      handler :: Input act -> Aff Unit
      handler = Eval.queueOrRun ds.pendingHandlers <<< void <<< Eval.evalF render ds.selfRef
      childHandler :: act -> Aff Unit
      childHandler = Eval.queueOrRun ds.pendingQueries <<< handler <<< Action
    rendering <-
      renderSpec.render
        (handleAff <<< handler)
        (renderChild lchs childHandler ds.childrenIn ds.childrenOut)
        (ds.component.render ds.state)
        ds.rendering
    children <- Ref.read ds.childrenOut
    childrenIn <- Ref.read ds.childrenIn
    Slot.foreachSlot childrenIn \(DriverStateRef childVar) -> do
      childDS <- Ref.read childVar
      renderStateX_ renderSpec.removeChild childDS
      finalize lchs childDS
    flip Ref.modify_ ds.selfRef $ mapDriverState \ds' ->
      ds' { rendering = Just rendering, children = children }
    when shouldProcessHandlers do
      flip tailRecM unit \_ -> do
        handlers <- Ref.read ds.pendingHandlers
        Ref.write (Just L.Nil) ds.pendingHandlers
        traverse_ (handleAff <<< traverse_ fork <<< L.reverse) handlers
        mmore <- Ref.read ds.pendingHandlers
        if maybe false L.null mmore
          then Ref.write Nothing ds.pendingHandlers $> Done unit
          else pure $ Loop unit

  renderChild
    :: forall ps act
     . Ref LifecycleHandlers
    -> (act -> Aff Unit)
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> ComponentSlot h ps Aff act
    -> Effect (RenderStateX r)
  renderChild lchs handler childrenInRef childrenOutRef =
    unComponentSlot \slot -> do
      childrenIn <- Ref.read childrenInRef
      var <- case slot.pop childrenIn of
        Just (Tuple (DriverStateRef existing) childrenIn') -> do
          Ref.write childrenIn' childrenInRef
          dsx <- Ref.read existing
          unDriverStateX (\st -> do
            flip Ref.write st.handlerRef $ maybe (pure unit) handler <<< slot.output
            handleAff $ Eval.evalM render st.selfRef (st.component.eval slot.input)) dsx
          pure existing
        Nothing ->
          case slot.input of
            Receive si _ ->
              runComponent lchs (maybe (pure unit) handler <<< slot.output) si slot.component
            _ ->
              throw "Halogen internal error: slot input was not a Receive query"
      isDuplicate <- isJust <<< slot.get <$> Ref.read childrenOutRef
      when isDuplicate
        $ warn "Halogen: Duplicate slot address was detected during rendering, unexpected results may occur"
      Ref.modify_ (slot.set $ DriverStateRef var) childrenOutRef
      Ref.read var >>= renderStateX case _ of
        Nothing -> throw "Halogen internal error: child was not initialized in renderChild"
        Just r -> pure (renderSpec.renderChild r)

  squashChildInitializers
    :: forall f' o'
     . Ref LifecycleHandlers
    -> L.List (Aff Unit)
    -> DriverStateX h r f' o'
    -> Effect Unit
  squashChildInitializers lchs preInits =
    unDriverStateX \st -> do
      let parentInitializer = Eval.evalM render st.selfRef (st.component.eval (Initialize unit))
      Ref.modify_ (\handlers ->
        { initializers: (do
            parSequence_ (L.reverse handlers.initializers)
            parentInitializer
            liftEffect do
              handlePending st.pendingQueries
              handlePending st.pendingOuts) : preInits
        , finalizers: handlers.finalizers
        }) lchs
      pure unit

  finalize
    :: forall f' o'
     . Ref LifecycleHandlers
    -> DriverStateX h r f' o'
    -> Effect Unit
  finalize lchs = do
    unDriverStateX \st -> do
      cleanupSubscriptions (DriverState st)
      let f = Eval.evalM render st.selfRef (st.component.eval (Finalize unit))
      Ref.modify_ (\handlers ->
        { initializers: handlers.initializers
        , finalizers: f : handlers.finalizers
        }) lchs
      Slot.foreachSlot st.children \(DriverStateRef ref) -> do
        dsx <- Ref.read ref
        finalize lchs dsx

newLifecycleHandlers :: Effect (Ref LifecycleHandlers)
newLifecycleHandlers = Ref.new { initializers: L.Nil, finalizers: L.Nil }

handlePending :: Ref (Maybe (L.List (Aff Unit))) -> Effect Unit
handlePending ref = do
  queue <- Ref.read ref
  Ref.write Nothing ref
  for_ queue (handleAff <<< traverse_ fork <<< L.reverse)

cleanupSubscriptions
  :: forall h r s f act ps i o
   . DriverState h r s f act ps i o
  -> Effect Unit
cleanupSubscriptions (DriverState ds) = do
  traverse_ (handleAff <<< traverse_ (fork <<< ES.finalize)) =<< Ref.read ds.subscriptions
  Ref.write Nothing ds.subscriptions

-- We could perhaps do something more intelligent now this isn't baked into
-- the virtual-dom rendering. It hasn't really been a problem so far though.
handleAff :: forall a. Aff a -> Effect Unit
handleAff = runAff_ (either throwException (const (pure unit)))


Add Writing

Add Writing

module TMDBMetadataLoader where

import Data.String
import Data.Function
import Data.Either
import Prelude
import Control.Bind
import Control.Monad.Eff
import Control.Monad.Trans
import Control.Monad.Cont.Trans
import Data.Foreign
import Data.Foreign.Class
import Data.Traversable
import Data.Foldable
import HttpClient
import Config
import Data.Array.Unsafe
import qualified Data.Array as Array
import qualified Data.Map as Map
import Data.Tuple
import Data.Maybe.Unsafe
import TMDBTypes

getState :: Url -> Http State
getState url = do myList <- getMyList url
                  genres <- fetchGenreList
                  mvs <- fetchMoviesDetails (myList.movies)
                  tvs <- fetchTVShowsDetails (myList.tvshows)
                  return ({ movies: (\m -> m { genre = joinWith ", " ((\k -> fromJust(Map.lookup k genres)) <$> m.genresIds) }) <$> mvs,
                            tvshows: tvs })

getMyList ::  String -> Http MyList
getMyList url = fetch url

fetchGenreList :: Http (Map.Map Number String)
fetchGenreList = do x <- (fetch ("http://api.themoviedb.org/3/genre/movie/list?api_key=" ++ apiKey) :: Http TMBMovieGenres)
                    return (Map.fromList ((\y -> Tuple (y.id) (y.name)) <$> x.genres))

fetchMoviesDetails :: [MovieSpec] -> Http [MovieDetails]
fetchMoviesDetails moviesSpecs = sequence (fetchMovie <$> moviesSpecs)

fetchTVShowsDetails :: [TVShowSpec] -> Http [TVShowDetails]
fetchTVShowsDetails tvShowsSpecs = sequence (f <$> tvShowsSpecs)
	where f x = do dt <- fetchTVShow x
	               sdt <- fetchTVShowsSeasonsDetails (x { seriesId = dt.seriesId })
 	               return (dt { seasons = sdt })

fetchTVShowsSeasonsDetails :: TVShowSpec -> Http [TVShowSeasonDetails]
fetchTVShowsSeasonsDetails tvshow = sequence (f <$> (tvshow.seasons))
    where f x = (\eps -> { season : x.season, episodes : eps }) <$>
                fetchTVShowEpisodesDetails ((\v -> v { seriesId = tvshow.seriesId }) <$> x.episodes)

fetchTVShowEpisodesDetails :: [TVShowEpisodeSpec] -> Http [TVShowEpisodeDetails]
fetchTVShowEpisodesDetails episodesSpecs = sequence (fetchTVShowEpisode <$> episodesSpecs)

fetchMovieExtraInfo :: Number -> Http MovieCredits
fetchMovieExtraInfo movieId = (\details -> {
		    movieId : details.id,
        director: joinWith "," ((\x -> x.name) <$> (Array.filter (\x-> x.job == "Director") details.credits.crew)),
        writer: joinWith "," ((\x -> x.name) <$> (Array.filter (\x-> x.job == "Writer" || x.job == "Writing") details.credits.crew)),
        actors: joinWith "," (Array.take 5 ((\x -> x.name) <$> details.credits.cast)),
        rated: (head (details.releases.countries)).certification,
        runtime: details.runtime
       }) <$> response
  where url = "http://api.themoviedb.org/3/movie/" ++ (show movieId) ++ "?api_key=" ++ apiKey ++ "&append_to_response=credits,releases"
        response = (fetch url) :: Http TMDBMovieCredits

fetchMovie :: MovieSpec -> Http MovieDetails
fetchMovie movie = do dt <- fetchMovie' movie
                      info <- fetchMovieExtraInfo (dt.movieId)
                      return dt { director = info.director,
                                  writer = info.writer,
                                  actors = info.actors,
                                  runtime = info.runtime,
                                  rated = info.rated }

fetchMovie' :: MovieSpec ->  Http MovieDetails
fetchMovie' movie = (\details -> {
		movieId : details.id,
        title : details.title,
        plot: details.overview,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.poster_path,
        year : movie.year,
        release: details.release_date,
        genresIds: details.genre_ids,
        genre:"",
		    source : movie.source,
		    director: "",
        writer:"",
        actors:"",
        runtime:0,
        popularity: details.popularity,
        rated:"" }) <$> ((\x -> head (x.results)) <$> response)
  where url = "http://api.themoviedb.org/3/search/movie?api_key=" ++ apiKey ++ query ++ year
        query = "&query=" ++ replaceSpaceWithPlus (movie.title)
        year = "&year=" ++ movie.year
        response = (fetch url) :: Http TMDBMovieDetails

fetchTVShow :: TVShowSpec ->  Http TVShowDetails
fetchTVShow tvshow = (\details -> {
		seriesId: details.id,
        title : details.name,
        year : details.first_air_date,
        plot: details.overview,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.poster_path,
		    seasons: [] }) <$> ((\x -> head (x.results)) <$> response)
  where url = "http://api.themoviedb.org/3/search/tv?api_key=" ++ apiKey ++ query ++ year
        query = "&query=" ++ replaceSpaceWithPlus (tvshow.title)
        year = "&year=" ++ tvshow.year
        response = (fetch url) :: Http TMDBTVShowDetails

fetchTVShowEpisode :: TVShowEpisodeSpec -> Http TVShowEpisodeDetails
fetchTVShowEpisode episode = (\details -> {
        title : details.name,
        season: show details.season_number,
        episode: show details.episode_number,
        plot: details.overview,
        released: details.air_date,
		    source : episode.source,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.still_path }) <$> response
  where url = "http://api.themoviedb.org/3/tv/" ++ (show episode.seriesId) ++
                "/season/" ++ episode.season ++
                "/episode/" ++ episode.episode ++
                "?api_key=" ++ apiKey
        response = (fetch url) :: Http TMDBTVShowEpisodeDetails

replaceSpaceWithPlus :: String -> String
replaceSpaceWithPlus =  (joinWith "+") <<< (split " ")

module TMDBMetadataLoader where

import Data.String
import Data.Function
import Data.Either
import Prelude
import Control.Bind
import Control.Monad.Eff
import Control.Monad.Trans
import Control.Monad.Cont.Trans
import Data.Foreign
import Data.Foreign.Class
import Data.Traversable
import Data.Foldable
import HttpClient
import Config
import Data.Array.Unsafe
import qualified Data.Array as Array
import qualified Data.Map as Map
import Data.Tuple
import Data.Maybe.Unsafe
import TMDBTypes

getState :: Url -> Http State
getState url = do myList <- getMyList url
                  genres <- fetchGenreList
                  mvs <- fetchMoviesDetails (myList.movies)
                  tvs <- fetchTVShowsDetails (myList.tvshows)
                  return ({ movies: (\m -> m { genre = joinWith ", " ((\k -> fromJust(Map.lookup k genres)) <$> m.genresIds) }) <$> mvs,
                            tvshows: tvs })

getMyList ::  String -> Http MyList
getMyList url = fetch url

fetchGenreList :: Http (Map.Map Number String)
fetchGenreList = do x <- (fetch ("http://api.themoviedb.org/3/genre/movie/list?api_key=" ++ apiKey) :: Http TMBMovieGenres)
                    return (Map.fromList ((\y -> Tuple (y.id) (y.name)) <$> x.genres))

fetchMoviesDetails :: [MovieSpec] -> Http [MovieDetails]
fetchMoviesDetails moviesSpecs = sequence (fetchMovie <$> moviesSpecs)

fetchTVShowsDetails :: [TVShowSpec] -> Http [TVShowDetails]
fetchTVShowsDetails tvShowsSpecs = sequence (f <$> tvShowsSpecs)
	where f x = do dt <- fetchTVShow x
	               sdt <- fetchTVShowsSeasonsDetails (x { seriesId = dt.seriesId })
 	               return (dt { seasons = sdt })

fetchTVShowsSeasonsDetails :: TVShowSpec -> Http [TVShowSeasonDetails]
fetchTVShowsSeasonsDetails tvshow = sequence (f <$> (tvshow.seasons))
    where f x = (\eps -> { season : x.season, episodes : eps }) <$>
                fetchTVShowEpisodesDetails ((\v -> v { seriesId = tvshow.seriesId }) <$> x.episodes)

fetchTVShowEpisodesDetails :: [TVShowEpisodeSpec] -> Http [TVShowEpisodeDetails]
fetchTVShowEpisodesDetails episodesSpecs = sequence (fetchTVShowEpisode <$> episodesSpecs)

fetchMovieExtraInfo :: Number -> Http MovieCredits
fetchMovieExtraInfo movieId = (\details -> {
		    movieId : details.id,
        director: joinWith "," ((\x -> x.name) <$> (Array.filter (\x-> x.job == "Director") details.credits.crew)),
        writer: joinWith "," ((\x -> x.name) <$> (Array.filter (\x-> x.job == "Writer") details.credits.crew)),
        actors: joinWith "," (Array.take 5 ((\x -> x.name) <$> details.credits.cast)),
        rated: (head (details.releases.countries)).certification,
        runtime: details.runtime
       }) <$> response
  where url = "http://api.themoviedb.org/3/movie/" ++ (show movieId) ++ "?api_key=" ++ apiKey ++ "&append_to_response=credits,releases"
        response = (fetch url) :: Http TMDBMovieCredits

fetchMovie :: MovieSpec -> Http MovieDetails
fetchMovie movie = do dt <- fetchMovie' movie
                      info <- fetchMovieExtraInfo (dt.movieId)
                      return dt { director = info.director,
                                  writer = info.writer,
                                  actors = info.actors,
                                  runtime = info.runtime,
                                  rated = info.rated }

fetchMovie' :: MovieSpec ->  Http MovieDetails
fetchMovie' movie = (\details -> {
		movieId : details.id,
        title : details.title,
        plot: details.overview,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.poster_path,
        year : movie.year,
        release: details.release_date,
        genresIds: details.genre_ids,
        genre:"",
		    source : movie.source,
		    director: "",
        writer:"",
        actors:"",
        runtime:0,
        popularity: details.popularity,
        rated:"" }) <$> ((\x -> head (x.results)) <$> response)
  where url = "http://api.themoviedb.org/3/search/movie?api_key=" ++ apiKey ++ query ++ year
        query = "&query=" ++ replaceSpaceWithPlus (movie.title)
        year = "&year=" ++ movie.year
        response = (fetch url) :: Http TMDBMovieDetails

fetchTVShow :: TVShowSpec ->  Http TVShowDetails
fetchTVShow tvshow = (\details -> {
		seriesId: details.id,
        title : details.name,
        year : details.first_air_date,
        plot: details.overview,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.poster_path,
		    seasons: [] }) <$> ((\x -> head (x.results)) <$> response)
  where url = "http://api.themoviedb.org/3/search/tv?api_key=" ++ apiKey ++ query ++ year
        query = "&query=" ++ replaceSpaceWithPlus (tvshow.title)
        year = "&year=" ++ tvshow.year
        response = (fetch url) :: Http TMDBTVShowDetails

fetchTVShowEpisode :: TVShowEpisodeSpec -> Http TVShowEpisodeDetails
fetchTVShowEpisode episode = (\details -> {
        title : details.name,
        season: show details.season_number,
        episode: show details.episode_number,
        plot: details.overview,
        released: details.air_date,
		    source : episode.source,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.still_path }) <$> response
  where url = "http://api.themoviedb.org/3/tv/" ++ (show episode.seriesId) ++
                "/season/" ++ episode.season ++
                "/episode/" ++ episode.episode ++
                "?api_key=" ++ apiKey
        response = (fetch url) :: Http TMDBTVShowEpisodeDetails

replaceSpaceWithPlus :: String -> String
replaceSpaceWithPlus =  (joinWith "+") <<< (split " ")


Reanimate MessageEvent - got lost

Reanimate MessageEvent - got lost

module DOM.Websocket.Event.Types where

import Data.Foreign (Foreign, F, unsafeReadTagged)
import Data.Foreign.Class (class IsForeign)
import DOM.Event.Types (Event)
import Unsafe.Coerce as U

foreign import data CloseEvent :: *

closeEventToEvent :: CloseEvent -> Event
closeEventToEvent = U.unsafeCoerce

readCloseEvent :: Foreign -> F CloseEvent
readCloseEvent = unsafeReadTagged "CloseEvent"

instance isForeignCloseEvent :: IsForeign CloseEvent where
  read = readCloseEvent

foreign import data MessageEvent :: *

messageEventToEvent :: MessageEvent -> Event
messageEventToEvent = U.unsafeCoerce

readMessageEvent :: Foreign -> F MessageEvent
readMessageEvent = unsafeReadTagged "MessageEvent"

instance isForeignMessageEvent :: IsForeign MessageEvent where
  read = readMessageEvent