Hopefully fixed vibra not stopping

Hopefully fixed vibra not stopping

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Control.Monad.Eff.Console as Console
import Data.CatQueue as Q
import Data.List as List
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.MediaStream.Track as Track
import WebRTC.RTC as RTC
import WebRTC.RTCRtpSender as Sender
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (catchException)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Array (zip)
import Data.Foldable (traverse_)
import Data.Identity (runIdentity)
import Data.Lens ((+=), (-=), (^?), _Just, lens, Lens, (.=), use, (%=), to, LensP)
import Data.List (List(Cons, Nil))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Data.Traversable (traverse)
import Data.Tuple (snd, fst, uncurry, curry, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Client.Vibrations (stopVibration, startVibration, Vibrator)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.State.Types (MessageNumber(MessageNumber))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (audioStats, maxMessagesInFlight, messagesInFlight, messageQueue, Action(EnqueueMessage), Action(..), State, Props, StreamConnectionState(..), StreamConnectionStats, videoStats, connectionState, packetsReceived, TrackKind(..), vibrator)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber, putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (getSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (unsafeToString)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.MediaStream.Track (MediaStreamTrack)
import WebRTC.RTC (RTCPeerConnection, iceConnectionState, oniceconnectionstatechange, onconnectionstatechange, onnegotiationneeded, closeRTCPeerConnection, MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, Ice, newRTCPeerConnection)
import WebRTC.Util (onConnectionDrop)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ { urls : [ "turn:gonimo.com:3478" ]
                                                                  , username : "gonimo"
                                                                  , credential : "Aeloh5chai2eil1" -- FIXME: For production this obviously should not be hardcoded.
                                                                  , credentialType : "password"
                                                                  }
                                                                ]
                                                 }
                           )
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  connState <- liftEff $ iceConnectionState rtcConnection
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          , messageQueue  : Nil
          , messagesInFlight : 0
          , audioStats : initStreamConnectionStats
          , videoStats : initStreamConnectionStats
          , vibrator   : Nothing
          }

initStreamConnectionStats :: StreamConnectionStats
initStreamConnectionStats = { packetsReceived : 0
                            , connectionState : ConnectionNotAvailable
                            }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  StartNegotiation                   -> handleStartNegotiation
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeConnection
  CloseConnection                    -> handleCloseConnection
  AcceptMessages num messages        -> handleAcceptMessages num messages
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  OnAudioConnectionDrop mPackets     -> handleOnConnectionDrop audioStats mPackets
  OnVideoConnectionDrop mPackets     -> handleOnConnectionDrop videoStats mPackets
  RegisterMediaTracks tracks         -> traverse_ handleRegisterMediaTrack tracks *> pure []
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  EnqueueMessage message             -> handleEnqueueMessage message
  MessageSent nAction                -> handleMessageSent nAction
  SetVibrator mVibrator              -> handleSetVibrator mVibrator
  ConnectionClosed                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         liftEff $ onnegotiationneeded (coerceEffects <<< props.sendAction $ StartNegotiation) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else pure $ EnqueueMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            pure Nop
       ]

handleStartNegotiation :: forall ps. ComponentType (Props ps) State Action
handleStartNegotiation = do
  state <- get
  pure [ do
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            pure <<< EnqueueMessage $ Message.SessionDescriptionOffer offer
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  pure [ pure <<< EnqueueMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
    state <- get
    props <- ask
    let registerConnDrop = if state.isBabyStation
                           then []
                           else [ registerOnConnectionDrop props state ]
    pure $ registerConnDrop
         <> [ do
              url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
              pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
            ]
  where
    registerOnConnectionDrop :: Props ps -> State -> IO Action
    registerOnConnectionDrop props state = do
      mVideoTrack <- map Arr.head <<< liftEff $ MediaStream.getVideoTracks event.stream
      mAudioTrack <- map Arr.head <<< liftEff $ MediaStream.getAudioTracks event.stream
      let kindArray kind = Arr.fromFoldable <<< map (const kind)
      maybeRegister props OnAudioConnectionDrop mAudioTrack state.rtcConnection
      maybeRegister props OnVideoConnectionDrop mVideoTrack state.rtcConnection
      -- pure $ RegisterMediaTracks (kindArray audioStats mAudioTrack <> kindArray videoStats mVideoTrack)
      pure $ RegisterMediaTracks (kindArray AudioTrack mAudioTrack <> kindArray VideoTrack mVideoTrack)

    maybeRegister :: Props ps -> (Maybe Int -> Action) -> Maybe MediaStreamTrack -> RTCPeerConnection -> IO Unit
    maybeRegister _ _ Nothing _ = pure unit
    maybeRegister props mkAction mTrack pc =
      liftEff $ onConnectionDrop (coerceEffects <<< props.sendAction <<< mkAction) mTrack pc

handleOnConnectionDrop :: forall ps. LensP State StreamConnectionStats
                          -> Maybe Int -> ComponentType (Props ps) State Action
handleOnConnectionDrop stats mPackets= do
    case mPackets of
      Nothing -> do
        stats <<< connectionState %= updateState ConnectionDied
        status <- use (stats <<< connectionState)
        case status of
          ConnectionDied ->
            pure [ do
                      vibrator' <- liftEff $ startVibration [200, 100, 250, 100, 300]
                      pure $ (SetVibrator <<< Just) vibrator'
                 ]
          _ -> pure []
      Just packets -> do
        stats <<< packetsReceived .= packets
        stats <<< connectionState %= updateState ConnectionReliable
        pure []
  where
    -- updateState new old
    updateState :: StreamConnectionState -> StreamConnectionState -> StreamConnectionState
    updateState ConnectionNotAvailable ConnectionDied = ConnectionNotAvailable -- User can stop a dead connection.
    updateState _ ConnectionDied = ConnectionDied -- In all other cases it remains dead.
    updateState ConnectionUnknown ConnectionNotAvailable = ConnectionUnknown
    updateState _ ConnectionNotAvailable = ConnectionNotAvailable
    updateState new _ = new

handleSetVibrator :: forall ps. Maybe Vibrator -> ComponentType (Props ps) State Action
handleSetVibrator mVibrator = do
  state <- get :: Component (Props ps) State State
  let oldVibrator = state.vibrator
  vibrator .= mVibrator
  pure [ liftEff $ do
            traverse_ stopVibration oldVibrator
            pure Nop
       ]

handleRegisterMediaTrack :: forall ps. TrackKind -> Component (Props ps) State Unit
handleRegisterMediaTrack AudioTrack = audioStats <<< connectionState .= ConnectionUnknown
handleRegisterMediaTrack VideoTrack = videoStats <<< connectionState .= ConnectionUnknown

getSendMessages :: forall ps. Component (Props ps) State (Array String -> IO Action)
getSendMessages = do
  let sendMessages = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  let sendMessage = map MessageSent
                    <<< toIO props.settings
                    <<< ( \msgs ->  do
                             sendMessages msgs familyId' fromDevice' toDevice' channelId'
                             pure Nop
                        )
  pure sendMessage

handleAcceptMessages :: forall ps. MessageNumber -> Array String -> ComponentType (Props ps) State Action
handleAcceptMessages msgNumber msgs = do
  let decoded = Arr.mapMaybe decodeFromString msgs
  props <- ask
  let deleteMessage = deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber
  deleteActions <- runGonimo $ do
    deleteMessage props.familyId props.theirId props.ourId props.cSecret msgNumber
    pure Nop
  messageActions <- Arr.concat <$> traverse handleMessage decoded
  pure $ deleteActions <> messageActions

handleMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleMessage msg = do
  state <- get
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescriptionOffer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              answer <- liftAff $ createAnswer state.rtcConnection
              liftAff $ setLocalDescription answer state.rtcConnection
              pure <<< EnqueueMessage $ Message.SessionDescriptionAnswer answer
          ]
    Message.SessionDescriptionAnswer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
          ]
    Message.IceCandidate candidate ->
      pure [ do
              let test = runMaybeIceCandidate candidate
              case test of
                Nothing -> pure unit -- let's see whether this helps
                Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
              pure Nop
          ]
    Message.CloseConnection -> closeConnection

closeConnection :: forall ps. ComponentType (Props ps) State Action
closeConnection = do
  state <- get :: Component (Props ps) State State
  let conn = state.rtcConnection
  audioStats <<< connectionState .= ConnectionNotAvailable
  videoStats <<< connectionState .= ConnectionNotAvailable
  pure [ liftEff $ do
            catchException (\_ -> Console.log "Stopping vibrations failed!")
              $ traverse_ stopVibration state.vibrator
            pure $ SetVibrator Nothing
        , liftEff $ do
            catchException (\_ -> Console.log "Closing RTC connection failed!")
              $ closeRTCPeerConnection conn
            pure ConnectionClosed
        ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  state <- get :: Component (Props ps) State State
  closeActions <- closeConnection
  pure $ [ pure $ EnqueueMessage Message.CloseConnection ] <> closeActions

handleEnqueueMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleEnqueueMessage message = do
  let strMsg = encodeToString message
  allClear <- use $ messagesInFlight <<< to (_ < maxMessagesInFlight)
  sendMessages <- getSendMessages
  if allClear
    then do
      messagesInFlight += 1
      pure [ sendMessages $ Arr.singleton strMsg ] -- Ready to take off!
    else do
      messageQueue %= Cons strMsg
      pure []

handleMessageSent :: forall ps. Action -> ComponentType (Props ps) State Action
handleMessageSent nAction = do
  messagesInFlight -= 1
  newActions <- update nAction
  queue :: List String <- use messageQueue
  sendMessages <- getSendMessages
  let messages = Arr.fromFoldable $ List.reverse queue
  ourActions <-
        if Arr.null messages
        then pure []
        else do
          messageQueue .= Nil :: (List String)
          messagesInFlight += 1
          pure [ sendMessages messages ]
  pure $ newActions <> ourActions

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , H.div [ A.style [Tuple "position" "relative"]] -- Needed so absolute positioning of error works.
              [ viewVideo state
              , viewError state
              ]
            , viewStreamStatus state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

viewError :: State -> Html Action
viewError state =
  let
    isBroken connState = case connState of
      ConnectionDied -> true
      _              -> false
    audioBroken = isBroken state.audioStats.connectionState
    videoBroken = isBroken state.videoStats.connectionState
    brokenText = if audioBroken && not videoBroken
                 then "Audio connection broken!"
                 else if not audioBroken && videoBroken
                      then "Video connection broken!"
                      else "Connection broken!"

    errorView = H.div [ A.className "brokenConnectionOverlay" ]
                [ H.h2 [] [ H.text brokenText ]
                , H.p []
                  [
                    H.text "Please reconnect or check on your baby!"
                  ]
                , H.audio [ A.src "sounds/pup_alert.mp3", A.autoPlay "true", A.loop true
                          ] []
                ]
  in
   if audioBroken || videoBroken
   then errorView
   else H.div [] []

viewStreamStatus :: State -> Html Action
viewStreamStatus state =
  let
     getStatus connState = case connState of
       ConnectionNotAvailable -> H.text "x"
       ConnectionUnknown  -> H.text "Might break unnoticed"
       ConnectionReliable -> H.text "Reliable"
       ConnectionDied     -> H.text "Dead"
     videoStatus = getStatus state.videoStats.connectionState
     audioStatus = getStatus state.audioStats.connectionState
  in
   H.div []
   [ H.text "Audio: " , audioStatus
   , H.text ", "
   , H.text "Video: ", videoStatus
   ]

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = getSocketByFamilyIdByFromDeviceByToDeviceByChannelId toAction
    toAction :: Maybe (Maybe (Tuple MessageNumber (Array String))) -> Action
    toAction (Just (Just (Tuple num messages))) = AcceptMessages num messages
    toAction (Just Nothing) = Nop
    toAction Nothing = Nop
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Control.Monad.Eff.Console as Console
import Data.CatQueue as Q
import Data.List as List
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.MediaStream.Track as Track
import WebRTC.RTC as RTC
import WebRTC.RTCRtpSender as Sender
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (catchException)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Array (zip)
import Data.Foldable (traverse_)
import Data.Identity (runIdentity)
import Data.Lens ((+=), (-=), (^?), _Just, lens, Lens, (.=), use, (%=), to, LensP)
import Data.List (List(Cons, Nil))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Data.Traversable (traverse)
import Data.Tuple (snd, fst, uncurry, curry, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Client.Vibrations (stopVibration, startVibration, Vibrator)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.State.Types (MessageNumber(MessageNumber))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (audioStats, maxMessagesInFlight, messagesInFlight, messageQueue, Action(EnqueueMessage), Action(..), State, Props, StreamConnectionState(..), StreamConnectionStats, videoStats, connectionState, packetsReceived, TrackKind(..), vibrator)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber, putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (getSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (unsafeToString)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.MediaStream.Track (MediaStreamTrack)
import WebRTC.RTC (RTCPeerConnection, iceConnectionState, oniceconnectionstatechange, onconnectionstatechange, onnegotiationneeded, closeRTCPeerConnection, MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, Ice, newRTCPeerConnection)
import WebRTC.Util (onConnectionDrop)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ { urls : [ "turn:gonimo.com:3478" ]
                                                                  , username : "gonimo"
                                                                  , credential : "Aeloh5chai2eil1" -- FIXME: For production this obviously should not be hardcoded.
                                                                  , credentialType : "password"
                                                                  }
                                                                ]
                                                 }
                           )
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  connState <- liftEff $ iceConnectionState rtcConnection
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          , messageQueue  : Nil
          , messagesInFlight : 0
          , audioStats : initStreamConnectionStats
          , videoStats : initStreamConnectionStats
          , vibrator   : Nothing
          }

initStreamConnectionStats :: StreamConnectionStats
initStreamConnectionStats = { packetsReceived : 0
                            , connectionState : ConnectionNotAvailable
                            }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  StartNegotiation                   -> handleStartNegotiation
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeConnection
  CloseConnection                    -> handleCloseConnection
  AcceptMessages num messages        -> handleAcceptMessages num messages
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  OnAudioConnectionDrop mPackets     -> handleOnConnectionDrop audioStats mPackets
  OnVideoConnectionDrop mPackets     -> handleOnConnectionDrop videoStats mPackets
  RegisterMediaTracks tracks         -> traverse_ handleRegisterMediaTrack tracks *> pure []
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  EnqueueMessage message             -> handleEnqueueMessage message
  MessageSent nAction                -> handleMessageSent nAction
  SetVibrator mVibrator              -> vibrator .= mVibrator *> pure []
  ConnectionClosed                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         liftEff $ onnegotiationneeded (coerceEffects <<< props.sendAction $ StartNegotiation) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else pure $ EnqueueMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            pure Nop
       ]

handleStartNegotiation :: forall ps. ComponentType (Props ps) State Action
handleStartNegotiation = do
  state <- get
  pure [ do
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            pure <<< EnqueueMessage $ Message.SessionDescriptionOffer offer
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  pure [ pure <<< EnqueueMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
    state <- get
    props <- ask
    let registerConnDrop = if state.isBabyStation
                           then []
                           else [ registerOnConnectionDrop props state ]
    pure $ registerConnDrop
         <> [ do
              url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
              pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
            ]
  where
    registerOnConnectionDrop :: Props ps -> State -> IO Action
    registerOnConnectionDrop props state = do
      mVideoTrack <- map Arr.head <<< liftEff $ MediaStream.getVideoTracks event.stream
      mAudioTrack <- map Arr.head <<< liftEff $ MediaStream.getAudioTracks event.stream
      let kindArray kind = Arr.fromFoldable <<< map (const kind)
      maybeRegister props OnAudioConnectionDrop mAudioTrack state.rtcConnection
      maybeRegister props OnVideoConnectionDrop mVideoTrack state.rtcConnection
      -- pure $ RegisterMediaTracks (kindArray audioStats mAudioTrack <> kindArray videoStats mVideoTrack)
      pure $ RegisterMediaTracks (kindArray AudioTrack mAudioTrack <> kindArray VideoTrack mVideoTrack)

    maybeRegister :: Props ps -> (Maybe Int -> Action) -> Maybe MediaStreamTrack -> RTCPeerConnection -> IO Unit
    maybeRegister _ _ Nothing _ = pure unit
    maybeRegister props mkAction mTrack pc =
      liftEff $ onConnectionDrop (coerceEffects <<< props.sendAction <<< mkAction) mTrack pc

handleOnConnectionDrop :: forall ps. LensP State StreamConnectionStats
                          -> Maybe Int -> ComponentType (Props ps) State Action
handleOnConnectionDrop stats mPackets= do
    case mPackets of
      Nothing -> do
        stats <<< connectionState %= updateState ConnectionDied
        status <- use (stats <<< connectionState)
        case status of
          ConnectionDied -> pure [ do
                                      vibrator' <- liftEff $ startVibration [200, 100, 250, 100, 300]
                                      pure $ (SetVibrator <<< Just) vibrator'
                                 ]
          _ -> pure []
      Just packets -> do
        stats <<< packetsReceived .= packets
        stats <<< connectionState %= updateState ConnectionReliable
        pure []
  where
    -- updateState new old
    updateState :: StreamConnectionState -> StreamConnectionState -> StreamConnectionState
    updateState ConnectionNotAvailable ConnectionDied = ConnectionNotAvailable -- User can stop a dead connection.
    updateState _ ConnectionDied = ConnectionDied -- In all other cases it remains dead.
    updateState ConnectionUnknown ConnectionNotAvailable = ConnectionUnknown
    updateState _ ConnectionNotAvailable = ConnectionNotAvailable
    updateState new _ = new

handleRegisterMediaTrack :: forall ps. TrackKind -> Component (Props ps) State Unit
handleRegisterMediaTrack AudioTrack = audioStats <<< connectionState .= ConnectionUnknown
handleRegisterMediaTrack VideoTrack = videoStats <<< connectionState .= ConnectionUnknown

getSendMessages :: forall ps. Component (Props ps) State (Array String -> IO Action)
getSendMessages = do
  let sendMessages = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  let sendMessage = map MessageSent
                    <<< toIO props.settings
                    <<< ( \msgs ->  do
                             sendMessages msgs familyId' fromDevice' toDevice' channelId'
                             pure Nop
                        )
  pure sendMessage

handleAcceptMessages :: forall ps. MessageNumber -> Array String -> ComponentType (Props ps) State Action
handleAcceptMessages msgNumber msgs = do
  let decoded = Arr.mapMaybe decodeFromString msgs
  props <- ask
  let deleteMessage = deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber
  deleteActions <- runGonimo $ do
    deleteMessage props.familyId props.theirId props.ourId props.cSecret msgNumber
    pure Nop
  messageActions <- Arr.concat <$> traverse handleMessage decoded
  pure $ deleteActions <> messageActions

handleMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleMessage msg = do
  state <- get
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescriptionOffer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              answer <- liftAff $ createAnswer state.rtcConnection
              liftAff $ setLocalDescription answer state.rtcConnection
              pure <<< EnqueueMessage $ Message.SessionDescriptionAnswer answer
          ]
    Message.SessionDescriptionAnswer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
          ]
    Message.IceCandidate candidate ->
      pure [ do
              let test = runMaybeIceCandidate candidate
              case test of
                Nothing -> pure unit -- let's see whether this helps
                Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
              pure Nop
          ]
    Message.CloseConnection -> closeConnection

closeConnection :: forall ps. ComponentType (Props ps) State Action
closeConnection = do
  state <- get :: Component (Props ps) State State
  let conn = state.rtcConnection
  audioStats <<< connectionState .= ConnectionNotAvailable
  videoStats <<< connectionState .= ConnectionNotAvailable
  pure [ liftEff $ do
            catchException (\_ -> Console.log "Stopping vibrations failed!")
              $ traverse_ stopVibration state.vibrator
            pure $ SetVibrator Nothing
        , liftEff $ do
            catchException (\_ -> Console.log "Closing RTC connection failed!")
              $ closeRTCPeerConnection conn
            pure ConnectionClosed
        ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  state <- get :: Component (Props ps) State State
  closeActions <- closeConnection
  pure $ [ pure $ EnqueueMessage Message.CloseConnection ] <> closeActions

handleEnqueueMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleEnqueueMessage message = do
  let strMsg = encodeToString message
  allClear <- use $ messagesInFlight <<< to (_ < maxMessagesInFlight)
  sendMessages <- getSendMessages
  if allClear
    then do
      messagesInFlight += 1
      pure [ sendMessages $ Arr.singleton strMsg ] -- Ready to take off!
    else do
      messageQueue %= Cons strMsg
      pure []

handleMessageSent :: forall ps. Action -> ComponentType (Props ps) State Action
handleMessageSent nAction = do
  messagesInFlight -= 1
  newActions <- update nAction
  queue :: List String <- use messageQueue
  sendMessages <- getSendMessages
  let messages = Arr.fromFoldable $ List.reverse queue
  ourActions <-
        if Arr.null messages
        then pure []
        else do
          messageQueue .= Nil :: (List String)
          messagesInFlight += 1
          pure [ sendMessages messages ]
  pure $ newActions <> ourActions

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , H.div [ A.style [Tuple "position" "relative"]] -- Needed so absolute positioning of error works.
              [ viewVideo state
              , viewError state
              ]
            , viewStreamStatus state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

viewError :: State -> Html Action
viewError state =
  let
    isBroken connState = case connState of
      ConnectionDied -> true
      _              -> false
    audioBroken = isBroken state.audioStats.connectionState
    videoBroken = isBroken state.videoStats.connectionState
    brokenText = if audioBroken && not videoBroken
                 then "Audio connection broken!"
                 else if not audioBroken && videoBroken
                      then "Video connection broken!"
                      else "Connection broken!"

    errorView = H.div [ A.className "brokenConnectionOverlay" ]
                [ H.h2 [] [ H.text brokenText ]
                , H.p []
                  [
                    H.text "Please reconnect or check on your baby!"
                  ]
                , H.audio [ A.src "sounds/pup_alert.mp3", A.autoPlay "true", A.loop true
                          ] []
                ]
  in
   if audioBroken || videoBroken
   then errorView
   else H.div [] []

viewStreamStatus :: State -> Html Action
viewStreamStatus state =
  let
     getStatus connState = case connState of
       ConnectionNotAvailable -> H.text "x"
       ConnectionUnknown  -> H.text "Might break unnoticed"
       ConnectionReliable -> H.text "Reliable"
       ConnectionDied     -> H.text "Dead"
     videoStatus = getStatus state.videoStats.connectionState
     audioStatus = getStatus state.audioStats.connectionState
  in
   H.div []
   [ H.text "Audio: " , audioStatus
   , H.text ", "
   , H.text "Video: ", videoStatus
   ]

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = getSocketByFamilyIdByFromDeviceByToDeviceByChannelId toAction
    toAction :: Maybe (Maybe (Tuple MessageNumber (Array String))) -> Action
    toAction (Just (Just (Tuple num messages))) = AcceptMessages num messages
    toAction (Just Nothing) = Nop
    toAction Nothing = Nop
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret


Generalise `and`, `or` documentation

Generalise `and`, `or` documentation

module Data.Foldable
  ( Foldable, foldr, foldl, foldMap
  , foldrDefault, foldlDefault, foldMapDefaultL, foldMapDefaultR
  , fold
  , traverse_
  , for_
  , sequence_
  , mconcat
  , intercalate
  , and
  , or
  , any
  , all
  , sum
  , product
  , elem
  , notElem
  , find
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  ) where

import Prelude

import Control.Apply ((*>))

import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid (Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..), runConj)
import Data.Monoid.Disj (Disj(..), runDisj)
import Data.Monoid.Dual (Dual(..), runDual)
import Data.Monoid.Endo (Endo(..), runEndo)
import Data.Monoid.Multiplicative (Multiplicative(..))

-- | `Foldable` represents data structures which can be _folded_.
-- |
-- | - `foldr` folds a structure from the right
-- | - `foldl` folds a structure from the left
-- | - `foldMap` folds a structure by accumulating values in a `Monoid`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrDefault`
-- | - `foldlDefault`
-- | - `foldMapDefaultR`
-- | - `foldMapDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. (Monoid m) => (a -> m) -> f a -> m

-- | A default implementation of `foldr` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultR`.
foldrDefault :: forall f a b. (Foldable f) =>
                (a -> b -> b) -> b -> f a -> b
foldrDefault c u xs = runEndo (foldMap (Endo <<< c) xs) u

-- | A default implementation of `foldl` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultL`.
foldlDefault :: forall f a b. (Foldable f) =>
                (b -> a -> b) -> b -> f a -> b
foldlDefault c u xs = runEndo (runDual (foldMap (Dual <<< Endo <<< flip c) xs)) u

-- | A default implementation of `foldMap` using `foldr`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldrDefault`.
foldMapDefaultR :: forall f a m. (Foldable f, Monoid m) =>
                   (a -> m) -> f a -> m
foldMapDefaultR f xs = foldr (\x acc -> f x <> acc) mempty xs

-- | A default implementation of `foldMap` using `foldl`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldlDefault`.
foldMapDefaultL :: forall f a m. (Foldable f, Monoid m) =>
                   (a -> m) -> f a -> m
foldMapDefaultL f xs = foldl (\acc x -> f x <> acc) mempty xs

instance foldableArray :: Foldable Array where
  foldr   = foldrArray
  foldl   = foldlArray
  foldMap = foldMapDefaultR

foreign import foldrArray :: forall a b. (a -> b -> b) -> b -> Array a -> b
foreign import foldlArray :: forall a b. (b -> a -> b) -> b -> Array a -> b

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z
  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x
  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableFirst :: Foldable First where
  foldr f z (First x) = foldr f z x
  foldl f z (First x) = foldl f z x
  foldMap f (First x) = foldMap f x

instance foldableLast :: Foldable Last where
  foldr f z (Last x) = foldr f z x
  foldl f z (Last x) = foldl f z x
  foldMap f (Last x) = foldMap f x

instance foldableAdditive :: Foldable Additive where
  foldr f z (Additive x) = x `f` z
  foldl f z (Additive x) = z `f` x
  foldMap f (Additive x) = f x

instance foldableDual :: Foldable Dual where
  foldr f z (Dual x) = x `f` z
  foldl f z (Dual x) = z `f` x
  foldMap f (Dual x) = f x

instance foldableDisj :: Foldable Disj where
  foldr f z (Disj x) = f x z
  foldl f z (Disj x) = f z x
  foldMap f (Disj x) = f x

instance foldableConj :: Foldable Conj where
  foldr f z (Conj x) = f x z
  foldl f z (Conj x) = f z x
  foldMap f (Conj x) = f x

instance foldableMultiplicative :: Foldable Multiplicative where
  foldr f z (Multiplicative x) = x `f` z
  foldl f z (Multiplicative x) = z `f` x
  foldMap f (Multiplicative x) = f x

-- | Fold a data structure, accumulating values in some `Monoid`.
fold :: forall f m. (Foldable f, Monoid m) => f m -> m
fold = foldMap id

-- | Traverse a data structure, performing some effects encoded by an
-- | `Applicative` functor at each value, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | traverse_ print [1, 2, 3]
-- | ```
traverse_ :: forall a b f m. (Applicative m, Foldable f) => (a -> m b) -> f a -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

-- | A version of `traverse_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for_ [1, 2, 3] \n -> do
-- |   print n
-- |   trace "squared is"
-- |   print (n * n)
-- | ```
for_ :: forall a b f m. (Applicative m, Foldable f) => f a -> (a -> m b) -> m Unit
for_ = flip traverse_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable` instance, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | sequence_ [ trace "Hello, ", trace " world!" ]
-- | ```
sequence_ :: forall a f m. (Applicative m, Foldable f) => f (m a) -> m Unit
sequence_ = traverse_ id

-- | Fold a data structure, accumulating values in some `Monoid`.
mconcat :: forall f m. (Foldable f, Monoid m) => f m -> m
mconcat = foldl (<>) mempty

-- | Fold a data structure, accumulating values in some `Monoid`,
-- | combining adjacent elements using the specified separator.
intercalate :: forall f m. (Foldable f, Monoid m) => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init = true } x = { init: false, acc: x }
  go { acc = acc }   x = { init: false, acc: acc <> sep <> x }

-- | The conjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether all of the values in a data
-- | structure are `true`.
and :: forall a f. (Foldable f, BooleanAlgebra a) => f a -> a
and = all id

-- | The disjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether any of the values in a data
-- | structure is `true`.
or :: forall a f. (Foldable f, BooleanAlgebra a) => f a -> a
or = any id

-- | Test whether a predicate holds for any element in a data structure.
any :: forall a b f. (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b
any p = runDisj <<< foldMap (Disj <<< p)

-- | Test whether a predicate holds for all elements in a data structure.
all :: forall a b f. (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b
all p = runConj <<< foldMap (Conj <<< p)

-- | Find the sum of the numeric values in a data structure.
sum :: forall a f. (Foldable f, Semiring a) => f a -> a
sum = foldl (+) zero

-- | Find the product of the numeric values in a data structure.
product :: forall a f. (Foldable f, Semiring a) => f a -> a
product = foldl (*) one

-- | Test whether a value is an element of a data structure.
elem :: forall a f. (Foldable f, Eq a) => a -> f a -> Boolean
elem = any <<< (==)

-- | Test whether a value is not an element of a data structure.
notElem :: forall a f. (Foldable f, Eq a) => a -> f a -> Boolean
notElem x = not <<< elem x

-- | Try to find an element in a data structure which satisfies a predicate.
find :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Maybe a
find p = foldl (\r x -> if p x then Just x else r) Nothing

-- | Find the largest element of a structure, according to its `Ord` instance.
maximum :: forall a f. (Ord a, Foldable f) => f a -> Maybe a
maximum = maximumBy compare

-- | Find the largest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
maximumBy :: forall a f. (Foldable f) => (a -> a -> Ordering) -> f a -> Maybe a
maximumBy cmp = foldl max' Nothing
  where
  max' Nothing x  = Just x
  max' (Just x) y = Just (case cmp x y of
                            GT -> x
                            _  -> y)

-- | Find the smallest element of a structure, according to its `Ord` instance.
minimum :: forall a f. (Ord a, Foldable f) => f a -> Maybe a
minimum = minimumBy compare

-- | Find the smallest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
minimumBy :: forall a f. (Foldable f) => (a -> a -> Ordering) -> f a -> Maybe a
minimumBy cmp = foldl min' Nothing
  where
  min' Nothing x  = Just x
  min' (Just x) y = Just (case cmp x y of
                            LT -> x
                            _  -> y)

module Data.Foldable
  ( Foldable, foldr, foldl, foldMap
  , foldrDefault, foldlDefault, foldMapDefaultL, foldMapDefaultR
  , fold
  , traverse_
  , for_
  , sequence_
  , mconcat
  , intercalate
  , and
  , or
  , any
  , all
  , sum
  , product
  , elem
  , notElem
  , find
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  ) where

import Prelude

import Control.Apply ((*>))

import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid (Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..), runConj)
import Data.Monoid.Disj (Disj(..), runDisj)
import Data.Monoid.Dual (Dual(..), runDual)
import Data.Monoid.Endo (Endo(..), runEndo)
import Data.Monoid.Multiplicative (Multiplicative(..))

-- | `Foldable` represents data structures which can be _folded_.
-- |
-- | - `foldr` folds a structure from the right
-- | - `foldl` folds a structure from the left
-- | - `foldMap` folds a structure by accumulating values in a `Monoid`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrDefault`
-- | - `foldlDefault`
-- | - `foldMapDefaultR`
-- | - `foldMapDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. (Monoid m) => (a -> m) -> f a -> m

-- | A default implementation of `foldr` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultR`.
foldrDefault :: forall f a b. (Foldable f) =>
                (a -> b -> b) -> b -> f a -> b
foldrDefault c u xs = runEndo (foldMap (Endo <<< c) xs) u

-- | A default implementation of `foldl` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultL`.
foldlDefault :: forall f a b. (Foldable f) =>
                (b -> a -> b) -> b -> f a -> b
foldlDefault c u xs = runEndo (runDual (foldMap (Dual <<< Endo <<< flip c) xs)) u

-- | A default implementation of `foldMap` using `foldr`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldrDefault`.
foldMapDefaultR :: forall f a m. (Foldable f, Monoid m) =>
                   (a -> m) -> f a -> m
foldMapDefaultR f xs = foldr (\x acc -> f x <> acc) mempty xs

-- | A default implementation of `foldMap` using `foldl`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldlDefault`.
foldMapDefaultL :: forall f a m. (Foldable f, Monoid m) =>
                   (a -> m) -> f a -> m
foldMapDefaultL f xs = foldl (\acc x -> f x <> acc) mempty xs

instance foldableArray :: Foldable Array where
  foldr   = foldrArray
  foldl   = foldlArray
  foldMap = foldMapDefaultR

foreign import foldrArray :: forall a b. (a -> b -> b) -> b -> Array a -> b
foreign import foldlArray :: forall a b. (b -> a -> b) -> b -> Array a -> b

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z
  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x
  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableFirst :: Foldable First where
  foldr f z (First x) = foldr f z x
  foldl f z (First x) = foldl f z x
  foldMap f (First x) = foldMap f x

instance foldableLast :: Foldable Last where
  foldr f z (Last x) = foldr f z x
  foldl f z (Last x) = foldl f z x
  foldMap f (Last x) = foldMap f x

instance foldableAdditive :: Foldable Additive where
  foldr f z (Additive x) = x `f` z
  foldl f z (Additive x) = z `f` x
  foldMap f (Additive x) = f x

instance foldableDual :: Foldable Dual where
  foldr f z (Dual x) = x `f` z
  foldl f z (Dual x) = z `f` x
  foldMap f (Dual x) = f x

instance foldableDisj :: Foldable Disj where
  foldr f z (Disj x) = f x z
  foldl f z (Disj x) = f z x
  foldMap f (Disj x) = f x

instance foldableConj :: Foldable Conj where
  foldr f z (Conj x) = f x z
  foldl f z (Conj x) = f z x
  foldMap f (Conj x) = f x

instance foldableMultiplicative :: Foldable Multiplicative where
  foldr f z (Multiplicative x) = x `f` z
  foldl f z (Multiplicative x) = z `f` x
  foldMap f (Multiplicative x) = f x

-- | Fold a data structure, accumulating values in some `Monoid`.
fold :: forall f m. (Foldable f, Monoid m) => f m -> m
fold = foldMap id

-- | Traverse a data structure, performing some effects encoded by an
-- | `Applicative` functor at each value, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | traverse_ print [1, 2, 3]
-- | ```
traverse_ :: forall a b f m. (Applicative m, Foldable f) => (a -> m b) -> f a -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

-- | A version of `traverse_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for_ [1, 2, 3] \n -> do
-- |   print n
-- |   trace "squared is"
-- |   print (n * n)
-- | ```
for_ :: forall a b f m. (Applicative m, Foldable f) => f a -> (a -> m b) -> m Unit
for_ = flip traverse_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable` instance, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | sequence_ [ trace "Hello, ", trace " world!" ]
-- | ```
sequence_ :: forall a f m. (Applicative m, Foldable f) => f (m a) -> m Unit
sequence_ = traverse_ id

-- | Fold a data structure, accumulating values in some `Monoid`.
mconcat :: forall f m. (Foldable f, Monoid m) => f m -> m
mconcat = foldl (<>) mempty

-- | Fold a data structure, accumulating values in some `Monoid`,
-- | combining adjacent elements using the specified separator.
intercalate :: forall f m. (Foldable f, Monoid m) => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init = true } x = { init: false, acc: x }
  go { acc = acc }   x = { init: false, acc: acc <> sep <> x }

-- | Test whether all `Boolean` values in a data structure are `true`.
and :: forall a f. (Foldable f, BooleanAlgebra a) => f a -> a
and = all id

-- | Test whether any `Boolean` value in a data structure is `true`.
or :: forall a f. (Foldable f, BooleanAlgebra a) => f a -> a
or = any id

-- | Test whether a predicate holds for any element in a data structure.
any :: forall a b f. (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b
any p = runDisj <<< foldMap (Disj <<< p)

-- | Test whether a predicate holds for all elements in a data structure.
all :: forall a b f. (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b
all p = runConj <<< foldMap (Conj <<< p)

-- | Find the sum of the numeric values in a data structure.
sum :: forall a f. (Foldable f, Semiring a) => f a -> a
sum = foldl (+) zero

-- | Find the product of the numeric values in a data structure.
product :: forall a f. (Foldable f, Semiring a) => f a -> a
product = foldl (*) one

-- | Test whether a value is an element of a data structure.
elem :: forall a f. (Foldable f, Eq a) => a -> f a -> Boolean
elem = any <<< (==)

-- | Test whether a value is not an element of a data structure.
notElem :: forall a f. (Foldable f, Eq a) => a -> f a -> Boolean
notElem x = not <<< elem x

-- | Try to find an element in a data structure which satisfies a predicate.
find :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Maybe a
find p = foldl (\r x -> if p x then Just x else r) Nothing

-- | Find the largest element of a structure, according to its `Ord` instance.
maximum :: forall a f. (Ord a, Foldable f) => f a -> Maybe a
maximum = maximumBy compare

-- | Find the largest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
maximumBy :: forall a f. (Foldable f) => (a -> a -> Ordering) -> f a -> Maybe a
maximumBy cmp = foldl max' Nothing
  where
  max' Nothing x  = Just x
  max' (Just x) y = Just (case cmp x y of
                            GT -> x
                            _  -> y)

-- | Find the smallest element of a structure, according to its `Ord` instance.
minimum :: forall a f. (Ord a, Foldable f) => f a -> Maybe a
minimum = minimumBy compare

-- | Find the smallest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
minimumBy :: forall a f. (Foldable f) => (a -> a -> Ordering) -> f a -> Maybe a
minimumBy cmp = foldl min' Nothing
  where
  min' Nothing x  = Just x
  min' (Just x) y = Just (case cmp x y of
                            LT -> x
                            _  -> y)


Updates for 0.7

Updates for 0.7

module Data.Either where

import Control.Alt (Alt)
import Control.Extend (Extend)
import Data.Bifunctor (Bifunctor)

-- | The `Either` type is used to represent a choice between two types of value.
-- |
-- | A common use case for `Either` is error handling, where `Left` is used to
-- | carry an error value and `Right` is used to carry a success value.
data Either a b = Left a | Right b

-- | Takes two functions and an `Either` value, if the value is a `Left` the
-- | inner value is applied to the first function, if the value is a `Right`
-- | the inner value is applied to the second function.
-- |
-- | ``` purescript
-- | either f g (Left x) == f x
-- | either f g (Right y) == g y
-- | ```
either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left a) = f a
either _ g (Right b) = g b

-- | Returns `true` when the `Either` value was constructed with `Left`.
isLeft :: forall a b. Either a b -> Boolean
isLeft = either (const true) (const false)

-- | Returns `true` when the `Either` value was constructed with `Right`.
isRight :: forall a b. Either a b -> Boolean
isRight = either (const false) (const true)

-- | The `Functor` instance allows functions to transform the contents of a
-- | `Right` with the `<$>` operator:
-- |
-- | ``` purescript
-- | f <$> Right x == Right (f x)
-- | ```
-- |
-- | `Left` values are untouched:
-- |
-- | ``` purescript
-- | f <$> Left y == Left y
-- | ```
instance functorEither :: Functor (Either a) where
  map _ (Left x) = Left x
  map f (Right y) = Right (f y)

instance bifunctorEither :: Bifunctor Either where
  bimap f _ (Left l) = Left (f l)
  bimap _ g (Right r) = Right (g r)

-- | The `Apply` instance allows functions contained within a `Right` to
-- | transform a value contained within a `Right` using the `(<*>)` operator:
-- |
-- | ``` purescript
-- | Right f <*> Right x == Right (f x)
-- | ```
-- |
-- | `Left` values are left untouched:
-- |
-- | ``` purescript
-- | Left f <*> Right x == Left x
-- | Right f <*> Left y == Left y
-- | ```
-- |
-- | Combining `Functor`'s `<$>` with `Apply`'s `<*>` can be used transform a
-- | pure function to take `Either`-typed arguments so `f :: a -> b -> c`
-- | becomes `f :: Either l a -> Either l b -> Either l c`:
-- |
-- | ``` purescript
-- | f <$> Right x <*> Right y == Right (f x y)
-- | ```
-- |
-- | The `Left`-preserving behaviour of both operators means the result of
-- | an expression like the above but where any one of the values is `Left`
-- | means the whole result becomes `Left` also, taking the first `Left` value
-- | found:
-- |
-- | ``` purescript
-- | f <$> Left x <*> Right y == Left x
-- | f <$> Right x <*> Left y == Left y
-- | f <$> Left x <*> Left y == Left x
-- | ```
instance applyEither :: Apply (Either e) where
  apply (Left e) _ = Left e
  apply (Right f) r = f <$> r

-- | The `Applicative` instance enables lifting of values into `Either` with the
-- | `pure` or `return` function (`return` is an alias for `pure`):
-- |
-- | ``` purescript
-- | pure x :: Either _ _ == Right x
-- | return x :: Either _ _ == Right x
-- | ```
-- |
-- | Combining `Functor`'s `<$>` with `Apply`'s `<*>` and `Applicative`'s
-- | `pure` can be used to pass a mixture of `Either` and non-`Either` typed
-- | values to a function that does not usually expect them, by using `pure`
-- | for any value that is not already `Either` typed:
-- |
-- | ``` purescript
-- | f <$> Right x <*> pure y == Right (f x y)
-- | ```
-- |
-- | Even though `pure = Right` it is recommended to use `pure` in situations
-- | like this as it allows the choice of `Applicative` to be changed later
-- | without having to go through and replace `Right` with a new constructor.
instance applicativeEither :: Applicative (Either e) where
  pure = Right

-- | The `Alt` instance allows for a choice to be made between two `Either`
-- | values with the `<|>` operator, where the first `Right` encountered
-- | is taken.
-- |
-- | ``` purescript
-- | Right x <|> Right y == Right x
-- | Left x <|> Right y == Right y
-- | Left x <|> Left y == Left y
-- | ```
instance altEither :: Alt (Either e) where
  alt (Left _) r = r
  alt l        _ = l

-- | The `Bind` instance allows sequencing of `Either` values and functions that
-- | return an `Either` by using the `>>=` operator:
-- |
-- | ``` purescript
-- | Left x >>= f = Left x
-- | Right x >>= f = f x
-- | ```
instance bindEither :: Bind (Either e) where
  bind = either (\e _ -> Left e) (\a f -> f a)

-- | The `Monad` instance guarantees that there are both `Applicative` and
-- | `Bind` instances for `Either`. This also enables the `do` syntactic sugar:
-- |
-- | ``` purescript
-- | do
-- |   x' <- x
-- |   y' <- y
-- |   pure (f x' y')
-- | ```
-- |
-- | Which is equivalent to:
-- |
-- | ``` purescript
-- | x >>= (\x' -> y >>= (\y' -> pure (f x' y')))
-- | ```
instance monadEither :: Monad (Either e)

-- | The `Extend` instance allows sequencing of `Either` values and functions
-- | that accept an `Either` and return a non-`Either` result using the
-- | `<<=` operator.
-- |
-- | ``` purescript
-- | f <<= Left x = Left x
-- | f <<= Right x = Right (f x)
-- | ```
instance extendEither :: Extend (Either e) where
  extend _ (Left y)  = Left y
  extend f x         = Right (f x)

-- | The `Show` instance allows `Either` values to be rendered as a string with
-- | `show` whenever there is an `Show` instance for both type the `Either` can
-- | contain.
instance showEither :: (Show a, Show b) => Show (Either a b) where
  show (Left x) = "Left (" ++ show x ++ ")"
  show (Right y) = "Right (" ++ show y ++ ")"

-- | The `Eq` instance allows `Either` values to be checked for equality with
-- | `==` and inequality with `/=` whenever there is an `Eq` instance for both
-- | types the `Either` can contain.
instance eqEither :: (Eq a, Eq b) => Eq (Either a b) where
  eq (Left a1)  (Left a2)  = a1 == a2
  eq (Right b1) (Right b2) = b1 == b2
  eq _          _          = false

-- | The `Ord` instance allows `Either` values to be compared with
-- | `compare`, `>`, `>=`, `<` and `<=` whenever there is an `Ord` instance for
-- | both types the `Either` can contain.
-- |
-- | Any `Left` value is considered to be less than a `Right` value.
instance ordEither :: (Ord a, Ord b) => Ord (Either a b) where
  compare (Left a1)  (Left a2)  = compare a1 a2
  compare (Right b1) (Right b2) = compare b1 b2
  compare (Left a)   _          = LT
  compare _          (Left b)   = GT

instance boundedEither :: (Bounded a, Bounded b) => Bounded (Either a b) where
  top = Right top
  bottom = Left bottom

module Data.Either where

import Control.Alt (Alt)
import Control.Extend (Extend)
import Data.Bifunctor (Bifunctor)

-- | The `Either` type is used to represent a choice between two types of value.
-- |
-- | A common use case for `Either` is error handling, where `Left` is used to
-- | carry an error value and `Right` is used to carry a success value.
data Either a b = Left a | Right b

-- | Takes two functions and an `Either` value, if the value is a `Left` the
-- | inner value is applied to the first function, if the value is a `Right`
-- | the inner value is applied to the second function.
-- |
-- | ``` purescript
-- | either f g (Left x) == f x
-- | either f g (Right y) == g y
-- | ```
either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left a) = f a
either _ g (Right b) = g b

-- | Returns `true` when the `Either` value was constructed with `Left`.
isLeft :: forall a b. Either a b -> Boolean
isLeft = either (const true) (const false)

-- | Returns `true` when the `Either` value was constructed with `Right`.
isRight :: forall a b. Either a b -> Boolean
isRight = either (const false) (const true)

-- | The `Functor` instance allows functions to transform the contents of a
-- | `Right` with the `<$>` operator:
-- |
-- | ``` purescript
-- | f <$> Right x == Right (f x)
-- | ```
-- |
-- | `Left` values are untouched:
-- |
-- | ``` purescript
-- | f <$> Left y == Left y
-- | ```
instance functorEither :: Functor (Either a) where
  (<$>) _ (Left x) = Left x
  (<$>) f (Right y) = Right (f y)

instance bifunctorEither :: Bifunctor Either where
  bimap f _ (Left l) = Left (f l)
  bimap _ g (Right r) = Right (g r)

-- | The `Apply` instance allows functions contained within a `Right` to
-- | transform a value contained within a `Right` using the `(<*>)` operator:
-- |
-- | ``` purescript
-- | Right f <*> Right x == Right (f x)
-- | ```
-- |
-- | `Left` values are left untouched:
-- |
-- | ``` purescript
-- | Left f <*> Right x == Left x
-- | Right f <*> Left y == Left y
-- | ```
-- |
-- | Combining `Functor`'s `<$>` with `Apply`'s `<*>` can be used transform a
-- | pure function to take `Either`-typed arguments so `f :: a -> b -> c`
-- | becomes `f :: Either l a -> Either l b -> Either l c`:
-- |
-- | ``` purescript
-- | f <$> Right x <*> Right y == Right (f x y)
-- | ```
-- |
-- | The `Left`-preserving behaviour of both operators means the result of
-- | an expression like the above but where any one of the values is `Left`
-- | means the whole result becomes `Left` also, taking the first `Left` value
-- | found:
-- |
-- | ``` purescript
-- | f <$> Left x <*> Right y == Left x
-- | f <$> Right x <*> Left y == Left y
-- | f <$> Left x <*> Left y == Left x
-- | ```
instance applyEither :: Apply (Either e) where
  (<*>) (Left e) _ = Left e
  (<*>) (Right f) r = f <$> r

-- | The `Applicative` instance enables lifting of values into `Either` with the
-- | `pure` or `return` function (`return` is an alias for `pure`):
-- |
-- | ``` purescript
-- | pure x :: Either _ _ == Right x
-- | return x :: Either _ _ == Right x
-- | ```
-- |
-- | Combining `Functor`'s `<$>` with `Apply`'s `<*>` and `Applicative`'s
-- | `pure` can be used to pass a mixture of `Either` and non-`Either` typed
-- | values to a function that does not usually expect them, by using `pure`
-- | for any value that is not already `Either` typed:
-- |
-- | ``` purescript
-- | f <$> Right x <*> pure y == Right (f x y)
-- | ```
-- |
-- | Even though `pure = Right` it is recommended to use `pure` in situations
-- | like this as it allows the choice of `Applicative` to be changed later
-- | without having to go through and replace `Right` with a new constructor.
instance applicativeEither :: Applicative (Either e) where
  pure = Right

-- | The `Alt` instance allows for a choice to be made between two `Either`
-- | values with the `<|>` operator, where the first `Right` encountered
-- | is taken.
-- |
-- | ``` purescript
-- | Right x <|> Right y == Right x
-- | Left x <|> Right y == Right y
-- | Left x <|> Left y == Left y
-- | ```
instance altEither :: Alt (Either e) where
  (<|>) (Left _) r = r
  (<|>) l        _ = l

-- | The `Bind` instance allows sequencing of `Either` values and functions that
-- | return an `Either` by using the `>>=` operator:
-- |
-- | ``` purescript
-- | Left x >>= f = Left x
-- | Right x >>= f = f x
-- | ```
instance bindEither :: Bind (Either e) where
  (>>=) = either (\e _ -> Left e) (\a f -> f a)

-- | The `Monad` instance guarantees that there are both `Applicative` and
-- | `Bind` instances for `Either`. This also enables the `do` syntactic sugar:
-- |
-- | ``` purescript
-- | do
-- |   x' <- x
-- |   y' <- y
-- |   pure (f x' y')
-- | ```
-- |
-- | Which is equivalent to:
-- |
-- | ``` purescript
-- | x >>= (\x' -> y >>= (\y' -> pure (f x' y')))
-- | ```
instance monadEither :: Monad (Either e)

-- | The `Extend` instance allows sequencing of `Either` values and functions
-- | that accept an `Either` and return a non-`Either` result using the
-- | `<<=` operator.
-- |
-- | ``` purescript
-- | f <<= Left x = Left x
-- | f <<= Right x = Right (f x)
-- | ```
instance extendEither :: Extend (Either e) where
  (<<=) _ (Left y)  = Left y
  (<<=) f x         = Right (f x)

-- | The `Show` instance allows `Either` values to be rendered as a string with
-- | `show` whenever there is an `Show` instance for both type the `Either` can
-- | contain.
instance showEither :: (Show a, Show b) => Show (Either a b) where
  show (Left x) = "Left (" ++ show x ++ ")"
  show (Right y) = "Right (" ++ show y ++ ")"

-- | The `Eq` instance allows `Either` values to be checked for equality with
-- | `==` and inequality with `/=` whenever there is an `Eq` instance for both
-- | types the `Either` can contain.
instance eqEither :: (Eq a, Eq b) => Eq (Either a b) where
  (==) (Left a1)  (Left a2)  = a1 == a2
  (==) (Right b1) (Right b2) = b1 == b2
  (==) _          _          = false
  (/=) a          b          = not (a == b)

-- | The `Ord` instance allows `Either` values to be compared with
-- | `compare`, `>`, `>=`, `<` and `<=` whenever there is an `Ord` instance for
-- | both types the `Either` can contain.
-- |
-- | Any `Left` value is considered to be less than a `Right` value.
instance ordEither :: (Ord a, Ord b) => Ord (Either a b) where
  compare (Left a1)  (Left a2)  = compare a1 a2
  compare (Right b1) (Right b2) = compare b1 b2
  compare (Left a)   _          = LT
  compare _          (Left b)   = GT

instance boundedEither :: (Bounded a, Bounded b) => Bounded (Either a b) where
  top = Right top
  bottom = Left bottom


Fix show instance

Fix show instance

module Data.Either where

data Either a b = Left a | Right b

either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left a) = f a
either _ g (Right b) = g b

isLeft :: forall a b. Either a b -> Boolean
isLeft = either (const true) (const false)

isRight :: forall a b. Either a b -> Boolean
isRight = either (const false) (const true)

instance functorEither :: Functor (Either a) where
  (<$>) _ (Left x) = Left x
  (<$>) f (Right y) = Right (f y)

instance applyEither :: Apply (Either e) where
  (<*>) (Left e) _ = Left e
  (<*>) (Right f) r = f <$> r

instance applicativeEither :: Applicative (Either e) where
  pure = Right

instance bindEither :: Bind (Either e) where
  (>>=) = either (\e _ -> Left e) (\a f -> f a)

instance monadEither :: Monad (Either e)

instance showEither :: (Show a, Show b) => Show (Either a b) where
  show (Left x) = "Left (" ++ show x ++ ")"
  show (Right y) = "Right (" ++ show y ++ ")"

instance eqEither :: (Eq a, Eq b) => Eq (Either a b) where
  (==) (Left a1)  (Left a2)  = a1 == a2
  (==) (Right b1) (Right b2) = b1 == b2
  (==) _          _          = false
  (/=) a          b          = not (a == b)

instance ordEither :: (Ord a, Ord b) => Ord (Either a b) where
  compare (Left a1)  (Left a2)  = compare a1 a2
  compare (Right b1) (Right b2) = compare b1 b2
  compare (Left a)   _          = LT
  compare _          (Left b)   = GT

module Data.Either where

data Either a b = Left a | Right b

either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left a) = f a
either _ g (Right b) = g b

isLeft :: forall a b. Either a b -> Boolean
isLeft = either (const true) (const false)

isRight :: forall a b. Either a b -> Boolean
isRight = either (const false) (const true)

instance functorEither :: Functor (Either a) where
  (<$>) _ (Left x) = Left x
  (<$>) f (Right y) = Right (f y)

instance applyEither :: Apply (Either e) where
  (<*>) (Left e) _ = Left e
  (<*>) (Right f) r = f <$> r

instance applicativeEither :: Applicative (Either e) where
  pure = Right

instance bindEither :: Bind (Either e) where
  (>>=) = either (\e _ -> Left e) (\a f -> f a)

instance monadEither :: Monad (Either e)

instance showEither :: (Show a, Show b) => Show (Either a b) where
  show (Left x) = "Left " ++ (show x)
  show (Right y) = "Right " ++ (show y)

instance eqEither :: (Eq a, Eq b) => Eq (Either a b) where
  (==) (Left a1)  (Left a2)  = a1 == a2
  (==) (Right b1) (Right b2) = b1 == b2
  (==) _          _          = false
  (/=) a          b          = not (a == b)

instance ordEither :: (Ord a, Ord b) => Ord (Either a b) where
  compare (Left a1)  (Left a2)  = compare a1 a2
  compare (Right b1) (Right b2) = compare b1 b2
  compare (Left a)   _          = LT
  compare _          (Left b)   = GT


Make StrMap.size return an integer instead of a float

-- | This module defines a type of native Javascript maps which
-- | require the keys to be strings.
-- |
-- | To maximize performance, Javascript objects are not wrapped,
-- | and some native code is used even when it's not necessary.

module Data.StrMap
  ( StrMap
  , empty
  , isEmpty
  , size
  , singleton
  , insert
  , lookup
  , toList
  , toUnfoldable
  , fromFoldable
  , fromFoldableWith
  , delete
  , pop
  , member
  , alter
  , update
  , mapWithKey
  , keys
  , values
  , union
  , unions
  , isSubmap
  , fold
  , foldMap
  , foldM
  , foldMaybe
  , all
  , thawST
  , freezeST
  , runST
  , pureST
  ) where

import Prelude

import Control.Monad.Eff (Eff, runPure)
import Control.Monad.ST as ST

import Data.Foldable (class Foldable, foldl, foldr, for_)
import Data.Function.Uncurried (Fn2, runFn2, Fn4, runFn4)
import Data.List as L
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.StrMap.ST as SM
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..), uncurry)
import Data.Unfoldable (class Unfoldable)

-- | `StrMap a` represents a map from `String`s to values of type `a`.
foreign import data StrMap :: * -> *

foreign import _copyEff :: forall a b h r. a -> Eff (st :: ST.ST h | r) b

-- | Convert an immutable map into a mutable map
thawST :: forall a h r. StrMap a -> Eff (st :: ST.ST h | r) (SM.STStrMap h a)
thawST = _copyEff

-- | Convert a mutable map into an immutable map
freezeST :: forall a h r. SM.STStrMap h a -> Eff (st :: ST.ST h | r) (StrMap a)
freezeST = _copyEff

-- | Freeze a mutable map, creating an immutable map. Use this function as you would use
-- | `Prelude.runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the map from escaping the scope of `runST`.
foreign import runST :: forall a r. (forall h. Eff (st :: ST.ST h | r) (SM.STStrMap h a)) -> Eff r (StrMap a)

pureST :: forall a. (forall h e. Eff (st :: ST.ST h | e) (SM.STStrMap h a)) -> StrMap a
pureST f = runPure (runST f)

mutate :: forall a b. (forall h e. SM.STStrMap h a -> Eff (st :: ST.ST h | e) b) -> StrMap a -> StrMap a
mutate f m = pureST do
  s <- thawST m
  _ <- f s
  pure s

foreign import _fmapStrMap :: forall a b. Fn2 (StrMap a) (a -> b) (StrMap b)

instance functorStrMap :: Functor StrMap where
  map f m = runFn2 _fmapStrMap m f

foreign import _foldM :: forall a m z. (m -> (z -> m) -> m) -> (z -> String -> a -> m) -> m -> StrMap a -> m

-- | Fold the keys and values of a map
fold :: forall a z. (z -> String -> a -> z) -> z -> StrMap a -> z
fold = _foldM ((#))

-- | Fold the keys and values of a map, accumulating values using
-- | some `Monoid`.
foldMap :: forall a m. (Monoid m) => (String -> a -> m) -> StrMap a -> m
foldMap f = fold (\acc k v -> acc <> f k v) mempty

-- | Fold the keys and values of a map, accumulating values and effects in
-- | some `Monad`.
foldM :: forall a m z. (Monad m) => (z -> String -> a -> m z) -> z -> StrMap a -> m z
foldM f z = _foldM (>>=) f (pure z)

instance foldableStrMap :: Foldable StrMap where
  foldl f = fold (\z _ -> f z)
  foldr f z m = foldr f z (values m)
  foldMap f = foldMap (const f)

instance traversableStrMap :: Traversable StrMap where
  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) ((map (uncurry singleton)) <$> (traverse f <$> toList ms))
  sequence = traverse id

-- Unfortunately the above are not short-circuitable (consider using purescript-machines)
-- so we need special cases:

foreign import _foldSCStrMap :: forall a z. Fn4 (StrMap a) z (z -> String -> a -> Maybe z) (forall b. b -> Maybe b -> b) z

-- | Fold the keys and values of a map.
-- |
-- | This function allows the folding function to terminate the fold early,
-- | using `Maybe`.
foldMaybe :: forall a z. (z -> String -> a -> Maybe z) -> z -> StrMap a -> z
foldMaybe f z m = runFn4 _foldSCStrMap m z f fromMaybe

-- | Test whether all key/value pairs in a `StrMap` satisfy a predicate.
foreign import all :: forall a. (String -> a -> Boolean) -> StrMap a -> Boolean

instance eqStrMap :: (Eq a) => Eq (StrMap a) where
  eq m1 m2 = (isSubmap m1 m2) && (isSubmap m2 m1)

instance showStrMap :: (Show a) => Show (StrMap a) where
  show m = "fromList " <> show (toList m)

-- | An empty map
foreign import empty :: forall a. StrMap a

-- | Test whether one map contains all of the keys and values contained in another map
isSubmap :: forall a. (Eq a) => StrMap a -> StrMap a -> Boolean
isSubmap m1 m2 = all f m1 where
  f k v = runFn4 _lookup false ((==) v) k m2

-- | Test whether a map is empty
isEmpty :: forall a. StrMap a -> Boolean
isEmpty = all (\_ _ -> false)

-- | Calculate the number of key/value pairs in a map
foreign import size :: forall a. StrMap a -> Int

-- | Create a map with one key/value pair
singleton :: forall a. String -> a -> StrMap a
singleton k v = pureST do
  s <- SM.new
  _ <- SM.poke s k v
  pure s

foreign import _lookup :: forall a z. Fn4 z (a -> z) String (StrMap a) z

-- | Lookup the value for a key in a map
lookup :: forall a. String -> StrMap a -> Maybe a
lookup = runFn4 _lookup Nothing Just

-- | Test whether a `String` appears as a key in a map
member :: forall a. String -> StrMap a -> Boolean
member = runFn4 _lookup false (const true)

-- | Insert a key and value into a map
insert :: forall a. String -> a -> StrMap a -> StrMap a
insert k v = mutate (\s -> void $ SM.poke s k v)

foreign import _unsafeDeleteStrMap :: forall a. Fn2 (StrMap a) String (StrMap a)

-- | Delete a key and value from a map
delete :: forall a. String -> StrMap a -> StrMap a
delete k = mutate (\s -> void $ SM.delete s k)

-- | Delete a key and value from a map, returning the value
-- | as well as the subsequent map
pop :: forall a. String -> StrMap a -> Maybe (Tuple a (StrMap a))
pop k m = lookup k m <#> \a -> Tuple a (delete k m)

-- | Insert, remove or update a value for a key in a map
alter :: forall a. (Maybe a -> Maybe a) -> String -> StrMap a -> StrMap a
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Remove or update a value for a key in a map
update :: forall a. (a -> Maybe a) -> String -> StrMap a -> StrMap a
update f k m = alter (maybe Nothing f) k m

-- | Create a map from a foldable collection of key/value pairs
fromFoldable :: forall f a. Foldable f => f (Tuple String a) -> StrMap a
fromFoldable l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> SM.poke s k v)
  pure s)

foreign import _lookupST :: forall a h r z. Fn4 z (a -> z) String (SM.STStrMap h a) (Eff (st :: ST.ST h | r) z)

-- | Create a map from a foldable collection of key/value pairs, using the
-- | specified function to combine values for duplicate keys.
fromFoldableWith :: forall f a. Foldable f => (a -> a -> a) -> f (Tuple String a) -> StrMap a
fromFoldableWith f l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> runFn4 _lookupST v (f v) k s >>= SM.poke s k)
  pure s)

foreign import _collect :: forall a b . (String -> a -> b) -> StrMap a -> Array b

-- | Convert a map into a list of key/value pairs
toList :: forall a. StrMap a -> L.List (Tuple String a)
toList = L.fromFoldable <<< _collect Tuple

toUnfoldable :: forall f a. Unfoldable f => StrMap a -> f (Tuple String a)
toUnfoldable = L.toUnfoldable <<< toList

-- | Get an array of the keys in a map
foreign import keys :: forall a. StrMap a -> Array String

-- | Get a list of the values in a map
values :: forall a. StrMap a -> L.List a
values = L.fromFoldable <<< _collect (\_ v -> v)

-- | Compute the union of two maps, preferring the first map in the case of
-- | duplicate keys.
union :: forall a. StrMap a -> StrMap a -> StrMap a
union m = mutate (\s -> void $ foldM SM.poke s m)

-- | Compute the union of a collection of maps
unions :: forall a. L.List (StrMap a) -> StrMap a
unions = foldl union empty

foreign import _mapWithKey :: forall a b. Fn2 (StrMap a) (String -> a -> b) (StrMap b)

-- | Apply a function of two arguments to each key/value pair, producing a new map
mapWithKey :: forall a b. (String -> a -> b) -> StrMap a -> StrMap b
mapWithKey f m = runFn2 _mapWithKey m f

instance semigroupStrMap :: (Semigroup a) => Semigroup (StrMap a) where
  append m1 m2 = mutate (\s1 -> void $ foldM (\s2 k v2 -> SM.poke s2 k (runFn4 _lookup v2 (\v1 -> v1 <> v2) k m2)) s1 m1) m2

instance monoidStrMap :: (Semigroup a) => Monoid (StrMap a) where
  mempty = empty

-- | This module defines a type of native Javascript maps which
-- | require the keys to be strings.
-- |
-- | To maximize performance, Javascript objects are not wrapped,
-- | and some native code is used even when it's not necessary.

module Data.StrMap
  ( StrMap
  , empty
  , isEmpty
  , size
  , singleton
  , insert
  , lookup
  , toList
  , toUnfoldable
  , fromFoldable
  , fromFoldableWith
  , delete
  , pop
  , member
  , alter
  , update
  , mapWithKey
  , keys
  , values
  , union
  , unions
  , isSubmap
  , fold
  , foldMap
  , foldM
  , foldMaybe
  , all
  , thawST
  , freezeST
  , runST
  , pureST
  ) where

import Prelude

import Control.Monad.Eff (Eff, runPure)
import Control.Monad.ST as ST

import Data.Foldable (class Foldable, foldl, foldr, for_)
import Data.Function.Uncurried (Fn2, runFn2, Fn4, runFn4)
import Data.List as L
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.StrMap.ST as SM
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..), uncurry)
import Data.Unfoldable (class Unfoldable)

-- | `StrMap a` represents a map from `String`s to values of type `a`.
foreign import data StrMap :: * -> *

foreign import _copyEff :: forall a b h r. a -> Eff (st :: ST.ST h | r) b

-- | Convert an immutable map into a mutable map
thawST :: forall a h r. StrMap a -> Eff (st :: ST.ST h | r) (SM.STStrMap h a)
thawST = _copyEff

-- | Convert a mutable map into an immutable map
freezeST :: forall a h r. SM.STStrMap h a -> Eff (st :: ST.ST h | r) (StrMap a)
freezeST = _copyEff

-- | Freeze a mutable map, creating an immutable map. Use this function as you would use
-- | `Prelude.runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the map from escaping the scope of `runST`.
foreign import runST :: forall a r. (forall h. Eff (st :: ST.ST h | r) (SM.STStrMap h a)) -> Eff r (StrMap a)

pureST :: forall a. (forall h e. Eff (st :: ST.ST h | e) (SM.STStrMap h a)) -> StrMap a
pureST f = runPure (runST f)

mutate :: forall a b. (forall h e. SM.STStrMap h a -> Eff (st :: ST.ST h | e) b) -> StrMap a -> StrMap a
mutate f m = pureST do
  s <- thawST m
  _ <- f s
  pure s

foreign import _fmapStrMap :: forall a b. Fn2 (StrMap a) (a -> b) (StrMap b)

instance functorStrMap :: Functor StrMap where
  map f m = runFn2 _fmapStrMap m f

foreign import _foldM :: forall a m z. (m -> (z -> m) -> m) -> (z -> String -> a -> m) -> m -> StrMap a -> m

-- | Fold the keys and values of a map
fold :: forall a z. (z -> String -> a -> z) -> z -> StrMap a -> z
fold = _foldM ((#))

-- | Fold the keys and values of a map, accumulating values using
-- | some `Monoid`.
foldMap :: forall a m. (Monoid m) => (String -> a -> m) -> StrMap a -> m
foldMap f = fold (\acc k v -> acc <> f k v) mempty

-- | Fold the keys and values of a map, accumulating values and effects in
-- | some `Monad`.
foldM :: forall a m z. (Monad m) => (z -> String -> a -> m z) -> z -> StrMap a -> m z
foldM f z = _foldM (>>=) f (pure z)

instance foldableStrMap :: Foldable StrMap where
  foldl f = fold (\z _ -> f z)
  foldr f z m = foldr f z (values m)
  foldMap f = foldMap (const f)

instance traversableStrMap :: Traversable StrMap where
  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) ((map (uncurry singleton)) <$> (traverse f <$> toList ms))
  sequence = traverse id

-- Unfortunately the above are not short-circuitable (consider using purescript-machines)
-- so we need special cases:

foreign import _foldSCStrMap :: forall a z. Fn4 (StrMap a) z (z -> String -> a -> Maybe z) (forall b. b -> Maybe b -> b) z

-- | Fold the keys and values of a map.
-- |
-- | This function allows the folding function to terminate the fold early,
-- | using `Maybe`.
foldMaybe :: forall a z. (z -> String -> a -> Maybe z) -> z -> StrMap a -> z
foldMaybe f z m = runFn4 _foldSCStrMap m z f fromMaybe

-- | Test whether all key/value pairs in a `StrMap` satisfy a predicate.
foreign import all :: forall a. (String -> a -> Boolean) -> StrMap a -> Boolean

instance eqStrMap :: (Eq a) => Eq (StrMap a) where
  eq m1 m2 = (isSubmap m1 m2) && (isSubmap m2 m1)

instance showStrMap :: (Show a) => Show (StrMap a) where
  show m = "fromList " <> show (toList m)

-- | An empty map
foreign import empty :: forall a. StrMap a

-- | Test whether one map contains all of the keys and values contained in another map
isSubmap :: forall a. (Eq a) => StrMap a -> StrMap a -> Boolean
isSubmap m1 m2 = all f m1 where
  f k v = runFn4 _lookup false ((==) v) k m2

-- | Test whether a map is empty
isEmpty :: forall a. StrMap a -> Boolean
isEmpty = all (\_ _ -> false)

-- | Calculate the number of key/value pairs in a map
foreign import size :: forall a. StrMap a -> Number

-- | Create a map with one key/value pair
singleton :: forall a. String -> a -> StrMap a
singleton k v = pureST do
  s <- SM.new
  _ <- SM.poke s k v
  pure s

foreign import _lookup :: forall a z. Fn4 z (a -> z) String (StrMap a) z

-- | Lookup the value for a key in a map
lookup :: forall a. String -> StrMap a -> Maybe a
lookup = runFn4 _lookup Nothing Just

-- | Test whether a `String` appears as a key in a map
member :: forall a. String -> StrMap a -> Boolean
member = runFn4 _lookup false (const true)

-- | Insert a key and value into a map
insert :: forall a. String -> a -> StrMap a -> StrMap a
insert k v = mutate (\s -> void $ SM.poke s k v)

foreign import _unsafeDeleteStrMap :: forall a. Fn2 (StrMap a) String (StrMap a)

-- | Delete a key and value from a map
delete :: forall a. String -> StrMap a -> StrMap a
delete k = mutate (\s -> void $ SM.delete s k)

-- | Delete a key and value from a map, returning the value
-- | as well as the subsequent map
pop :: forall a. String -> StrMap a -> Maybe (Tuple a (StrMap a))
pop k m = lookup k m <#> \a -> Tuple a (delete k m)

-- | Insert, remove or update a value for a key in a map
alter :: forall a. (Maybe a -> Maybe a) -> String -> StrMap a -> StrMap a
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Remove or update a value for a key in a map
update :: forall a. (a -> Maybe a) -> String -> StrMap a -> StrMap a
update f k m = alter (maybe Nothing f) k m

-- | Create a map from a foldable collection of key/value pairs
fromFoldable :: forall f a. Foldable f => f (Tuple String a) -> StrMap a
fromFoldable l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> SM.poke s k v)
  pure s)

foreign import _lookupST :: forall a h r z. Fn4 z (a -> z) String (SM.STStrMap h a) (Eff (st :: ST.ST h | r) z)

-- | Create a map from a foldable collection of key/value pairs, using the
-- | specified function to combine values for duplicate keys.
fromFoldableWith :: forall f a. Foldable f => (a -> a -> a) -> f (Tuple String a) -> StrMap a
fromFoldableWith f l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> runFn4 _lookupST v (f v) k s >>= SM.poke s k)
  pure s)

foreign import _collect :: forall a b . (String -> a -> b) -> StrMap a -> Array b

-- | Convert a map into a list of key/value pairs
toList :: forall a. StrMap a -> L.List (Tuple String a)
toList = L.fromFoldable <<< _collect Tuple

toUnfoldable :: forall f a. Unfoldable f => StrMap a -> f (Tuple String a)
toUnfoldable = L.toUnfoldable <<< toList

-- | Get an array of the keys in a map
foreign import keys :: forall a. StrMap a -> Array String

-- | Get a list of the values in a map
values :: forall a. StrMap a -> L.List a
values = L.fromFoldable <<< _collect (\_ v -> v)

-- | Compute the union of two maps, preferring the first map in the case of
-- | duplicate keys.
union :: forall a. StrMap a -> StrMap a -> StrMap a
union m = mutate (\s -> void $ foldM SM.poke s m)

-- | Compute the union of a collection of maps
unions :: forall a. L.List (StrMap a) -> StrMap a
unions = foldl union empty

foreign import _mapWithKey :: forall a b. Fn2 (StrMap a) (String -> a -> b) (StrMap b)

-- | Apply a function of two arguments to each key/value pair, producing a new map
mapWithKey :: forall a b. (String -> a -> b) -> StrMap a -> StrMap b
mapWithKey f m = runFn2 _mapWithKey m f

instance semigroupStrMap :: (Semigroup a) => Semigroup (StrMap a) where
  append m1 m2 = mutate (\s1 -> void $ foldM (\s2 k v2 -> SM.poke s2 k (runFn4 _lookup v2 (\v1 -> v1 <> v2) k m2)) s1 m1) m2

instance monoidStrMap :: (Semigroup a) => Monoid (StrMap a) where
  mempty = empty