Fixed: Stopping baby station now also closes existing streams

module Gonimo.UI.Socket where

import Prelude
import Data.Array as Arr
import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream.Track as Track
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, runReader)
import Control.Monad.Reader.Class (class MonadReader, ask)
import Control.Monad.State.Class (gets, modify, put, get, class MonadState)
import Data.Array (concat, fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (isJust, maybe, fromMaybe, Maybe(Nothing, Just))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Traversable (traverse_)
import Data.Tuple (uncurry, snd, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (wrapAction, noEffects, runGonimo, Component, liftChild, toParent, ComponentType, makeChildData, ToChild, onlyModify, Update, class MonadComponent)
import Gonimo.Server.DbEntities (Family(Family), Device(Device))
import Gonimo.Server.DbEntities.Helpers (runFamily)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Lenses (babyName, currentFamily, onlineStatus, authData, newBabyName)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (makeChannelId, toCSecret, toTheirId, ChannelId(ChannelId), channel, Props, State, Action(..))
import Gonimo.WebAPI (postSocketByFamilyIdByToDevice, deleteOnlineStatusByFamilyIdByDeviceId)
import Gonimo.WebAPI.Lenses (deviceId, _AuthData)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByToDevice, receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Pux.Html (Html)
import Servant.Subscriber (Subscriptions)
import WebRTC.MediaStream (stopStream, MediaStreamConstraints(MediaStreamConstraints), getUserMedia, MediaStream, getTracks)
import WebRTC.RTC (RTCPeerConnection)

-- We only use props for initialization
init :: AuthData-> State
init authData' = { authData : authData'
                 , currentFamily : Nothing
                 , channels : Map.empty
                 , onlineStatus : Nothing
                 , babyName : "baby"
                 , newBabyName : "baby"
                 }

update :: forall ps. Update (Props ps) State Action
update action = case action of
  AcceptConnection channelId'                    -> handleAcceptConnection channelId'
  AddChannel channelId' cState                   -> do channel channelId' .= Just cState
                                                       updateChannel channelId' ChannelC.InitConnection
  ChannelA channelId' (ChannelC.ReportError err) -> pure [pure $ ReportError err]
  ChannelA channelId' action'                    -> updateChannel channelId' action'
  CloseChannel channelId'                        -> pure [ pure $ ChannelA channelId' ChannelC.CloseConnection
                                                         , pure $ RemoveChannel channelId'
                                                         ]
  CloseBabyChannel channelId'                    -> do
    isBabyStation' <- gets (_^?channel channelId' <<< _Just <<< to _.isBabyStation)
    case isBabyStation' of
         Just true                               -> pure $ wrapAction (CloseChannel channelId')
         _                                       -> pure []
  RemoveChannel channelId'                       -> channel channelId' .= Nothing
                                                    *> pure []
  (SwitchFamily familyId')                       -> handleFamilySwitch familyId'
  (ServerFamilyGoOffline familyId)               -> handleServerFamilyGoOffline familyId
  (SetAuthData auth)                             -> handleSetAuthData auth
  (StartBabyStation constraints)                 -> handleStartBabyStation constraints
  (InitBabyStation stream)                       -> onlineStatus .= Just stream
                                                    *> pure []

  SetBabyName name                               -> babyName .= name *> pure []
  SetNewBabyName name                            -> do
    newBabyName .= name
    babyName .= name
    pure []
  (ConnectToBaby babyId)                         -> handleConnectToBaby babyId
  StopBabyStation                                -> handleStopBabyStation
  (ReportError _)                                -> noEffects
  Nop                                            -> noEffects

toChannel :: forall ps. ChannelId -> ToChild (Props ps) State (ChannelC.Props {}) ChannelC.State
toChannel channelId' = do
  state <- get
  pProps <- ask
  let
    props :: ChannelC.Props {}
    props = mkChannelProps pProps state channelId'
  pure $ makeChildData (channel channelId' <<< _Just) props

handleStartBabyStation :: forall ps.
                          MediaStreamConstraints
                       -> ComponentType (Props ps) State Action
handleStartBabyStation constraints =
  runGonimo $
    InitBabyStation <$> liftAff (getUserMedia constraints)

handleAcceptConnection :: forall ps. ChannelId -> ComponentType (Props ps) State  Action
handleAcceptConnection channelId' = do
  state <- get
  pure [ AddChannel channelId' <$> ChannelC.init state.onlineStatus ]

handleFamilySwitch :: forall ps. Key Family -> ComponentType (Props ps) State Action
handleFamilySwitch familyId' = do
    state <- get :: Component (Props ps) State State
    let oldFamily = state.currentFamily
    modify $ _ { currentFamily = Just familyId' }
    let action = fromFoldable
                 $ pure <<< ServerFamilyGoOffline
                 <$> oldFamily
    pure $ doCleanup state CloseChannel action

handleSetAuthData :: forall ps. AuthData -> ComponentType (Props ps) State Action
handleSetAuthData auth = do
  state <- get
  authData .= auth
  pure $ doCleanup state CloseChannel []

handleStopBabyStation :: forall ps. ComponentType (Props ps) State Action
handleStopBabyStation = do
  state <- get :: Component (Props ps) State State
  props <- ask :: Component (Props ps) State (Props ps)
  onlineStatus .= (Nothing :: Maybe MediaStream)
  let action = case state.onlineStatus of
        Nothing -> []
        Just stream -> [ toIO props.settings <<< liftEff $ do
                             stopStream stream
                             pure Nop
                        ]
  pure $ doCleanup state CloseBabyChannel action

handleServerFamilyGoOffline :: forall ps. Key Family -> ComponentType (Props ps) State Action
handleServerFamilyGoOffline familyId = do
    state <- get
    let deviceId = (runAuthData state.authData).deviceId
    runGonimo $ do
      deleteOnlineStatusByFamilyIdByDeviceId familyId deviceId
      pure Nop

handleConnectToBaby :: forall ps. Key Device -> ComponentType (Props ps) State Action
handleConnectToBaby babyId = do
  state <- get
  props <- ask
  let ourId = state ^. authData <<< to runAuthData <<< deviceId
  let actions = fromMaybe [] $ do
        familyId <- state.currentFamily
        pure [ toIO props.settings $ do
                  secret <- postSocketByFamilyIdByToDevice ourId familyId babyId
                  let channelId' = makeChannelId babyId secret
                  AddChannel channelId' <$> liftIO (ChannelC.init Nothing)
             ]
  pure actions

updateChannel :: forall ps. ChannelId -> ChannelC.Action -> ComponentType (Props ps) State Action
updateChannel channelId' = toParent [] (ChannelA channelId')
                           <<< liftChild (toChannel channelId')
                           <<< ChannelC.update

doCleanup :: State -> (ChannelId -> Action) -> Array (IO Action) -> Array (IO Action)
doCleanup state cleanup action =
    if Map.isEmpty state.channels
    then action
    else Arr.fromFoldable (pure <<< cleanup <$> Map.keys state.channels)
         <> action

getParentChannels :: State -> Array (Tuple ChannelId ChannelC.State)
getParentChannels =  Arr.filter (not _.isBabyStation <<< snd ) <<< Arr.fromFoldable
                     <<< Map.toList <<< _.channels

view :: forall ps. Props ps -> State -> Html Action
view props state = H.div []
       [ viewBabyNameSelect props state
       , if isJust state.onlineStatus
         then viewStopButton state
         else viewStartButton state
       ]

viewBabyNameSelect :: forall ps. Props ps -> State -> Html Action
viewBabyNameSelect props state =
  let
    lastBabies = concat
                 <<< fromFoldable -- Maybe Array -> Array Array
                 <<< map (_.familyLastUsedBabyNames <<< runFamily)
                 $ props.family

  in
    H.div [ A.className "well", A.role "group" ]
    [ H.div [ A.className "btn-group btn-group btn-group-justified", A.role "group" ]
      $ viewBabyButton state <$> lastBabies
    , H.div [ A.className "input-group"]
      [ H.span [ A.className "input-group-btn"]
        [
          H.button [ A.className $ "btn btn-default"
                                 <> if state.newBabyName == state.babyName
                                    then " active"
                                    else ""
                   , A.type_ "button"
                   , E.onClick $ const (SetBabyName state.newBabyName) ]
          [
            H.text "New baby: "
          ]
        ]
      , H.input [ A.type_ "text", A.className "form-control", A.placeholder "New baby name"
                , E.onInput $ \ev -> SetNewBabyName ev.target.value
                , A.value state.newBabyName
                ] []
      ]
    ]

viewBabyButton :: State -> String -> Html Action
viewBabyButton state baby =
  H.div [ A.className "btn-group", A.role "group" ]
  [
    H.button [ A.className $ "btn btn-default" <> if baby == state.babyName then " active" else ""
             , A.type_ "button"
             , E.onClick $ const $ SetBabyName baby
             ]
    [ H.text baby ]
  ]

viewStopButton :: State -> Html Action
viewStopButton state =
    H.div [ A.className "btn-group", A.role "group" ]
    [ H.h2 [] [ H.text $ "Baby monitor running for cute " <> state.babyName <> " ..." ]
    , H.button [ A.className "btn btn-block btn-danger"
                , A.type_ "button"
                , E.onClick $ const $ StopBabyStation
                ]
      [ H.text "Stop Baby Monitor "
      , H.span [A.className "glyphicon glyphicon-off"] []
      ]
    ]

viewStartButton :: State -> Html Action
viewStartButton state =
  H.div [ A.className "btn-group", A.role "group" ]
  [
    H.button [ A.className "btn btn-block btn-info"
             , A.type_ "button"
             , E.onClick $ const $ StartBabyStation (MediaStreamConstraints { video : true, audio : true })
             ]
    [ H.text $ "Start Baby Station for cute " <> state.babyName <> " "
    , H.span [A.className "glyphicon glyphicon-transfer"] []
    ]
  ]
  --   case state.onlineStatus of
--     Nothing -> text "Sorry - no video there yet!"
--     Just station -> H.div []
--                     [ text $ "Got video, is enabled: "
--                             <> show ((unsafeCoerce station.mediaStream).enabled :: Boolean)
--                     , H.video [ A.src stream.objectURL, A.autoPlay "true" ] []
--                     ]

viewParentChannels :: State -> Array (Html Action)
viewParentChannels state = let
    channels = getParentChannels state
    makeView :: Tuple ChannelId ChannelC.State -> Html Action
    makeView (Tuple chanId state) = ChannelA chanId <$> ChannelC.view state
  in
     makeView <$> channels

getSubscriptions :: forall ps. Props ps -> State -> Subscriptions Action
getSubscriptions props state =
  let
    authData' = state ^. authData <<< to runAuthData
    familyId' = state ^. currentFamily
    receiveAChannel deviceId' familyId'' =
      receiveSocketByFamilyIdByToDevice
        (maybe Nop (AcceptConnection <<< uncurry makeChannelId ) <<< join)
        familyId''
        deviceId'

    getChannelSubscriptions :: forall m. (MonadReader Settings m)
                                  => ChannelId -> m (Subscriptions Action)
    getChannelSubscriptions channelId' =
      let
        cProps = mkChannelProps props state channelId'
      in
      map (ChannelA channelId') <$> ChannelC.getSubscriptions cProps

    getChannelsSubscriptions :: forall m. (MonadReader Settings m)
                                => Map ChannelId ChannelC.State
                                -> Array (m (Subscriptions Action))
    getChannelsSubscriptions = Arr.fromFoldable <<< map getChannelSubscriptions <<< Map.keys

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader props.settings)
                $ getChannelsSubscriptions state.channels
                <> ( fromFoldable $ do
                        r <- state.onlineStatus -- Get only online if a baby.
                        familyId'' <- familyId'
                        pure $ receiveAChannel authData'.deviceId familyId''
                   )
  in
     foldl append mempty subArray

mkChannelProps :: forall ps. Props ps -> State -> ChannelId -> ChannelC.Props {}
mkChannelProps props state channelId = { ourId : state ^. authData <<< to runAuthData <<< deviceId
                                       , theirId : toTheirId channelId
                                       , cSecret : toCSecret channelId
                                       , familyId : ChannelC.unsafeMakeFamilyId state.currentFamily
                                       , settings : props.settings
                                       , sendAction : lmap (ChannelA channelId) props.sendActionSocket
                                       }

module Gonimo.UI.Socket where

import Prelude
import Data.Array as Arr
import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream.Track as Track
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, runReader)
import Control.Monad.Reader.Class (class MonadReader, ask)
import Control.Monad.State.Class (gets, modify, put, get, class MonadState)
import Data.Array (concat, fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (isJust, maybe, fromMaybe, Maybe(Nothing, Just))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Traversable (traverse_)
import Data.Tuple (uncurry, snd, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (wrapAction, noEffects, runGonimo, Component, liftChild, toParent, ComponentType, makeChildData, ToChild, onlyModify, Update, class MonadComponent)
import Gonimo.Server.DbEntities (Family(Family), Device(Device))
import Gonimo.Server.DbEntities.Helpers (runFamily)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Lenses (babyName, currentFamily, onlineStatus, authData, newBabyName)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (makeChannelId, toCSecret, toTheirId, ChannelId(ChannelId), channel, Props, State, Action(..))
import Gonimo.WebAPI (postSocketByFamilyIdByToDevice, deleteOnlineStatusByFamilyIdByDeviceId)
import Gonimo.WebAPI.Lenses (deviceId, _AuthData)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByToDevice, receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Pux.Html (Html)
import Servant.Subscriber (Subscriptions)
import WebRTC.MediaStream (stopStream, MediaStreamConstraints(MediaStreamConstraints), getUserMedia, MediaStream, getTracks)
import WebRTC.RTC (RTCPeerConnection)

-- We only use props for initialization
init :: AuthData-> State
init authData' = { authData : authData'
                 , currentFamily : Nothing
                 , channels : Map.empty
                 , onlineStatus : Nothing
                 , babyName : "baby"
                 , newBabyName : "baby"
                 }

update :: forall ps. Update (Props ps) State Action
update action = case action of
  AcceptConnection channelId'                    -> handleAcceptConnection channelId'
  AddChannel channelId' cState                   -> do channel channelId' .= Just cState
                                                       updateChannel channelId' ChannelC.InitConnection
  ChannelA channelId' (ChannelC.ReportError err) -> pure [pure $ ReportError err]
  ChannelA channelId' action'                    -> updateChannel channelId' action'
  CloseChannel channelId'                        -> pure [ pure $ ChannelA channelId' ChannelC.CloseConnection
                                                         , pure $ RemoveChannel channelId'
                                                         ]
  CloseBabyChannel channelId'                    -> do
    isBabyStation' <- gets (_^?channel channelId' <<< _Just <<< to _.isBabyStation)
    case isBabyStation' of
         Just true                               -> pure $ wrapAction (CloseBabyChannel channelId')
         _                                       -> pure []
  RemoveChannel channelId'                       -> channel channelId' .= Nothing
                                                    *> pure []
  (SwitchFamily familyId')                       -> handleFamilySwitch familyId'
  (ServerFamilyGoOffline familyId)               -> handleServerFamilyGoOffline familyId
  (SetAuthData auth)                             -> handleSetAuthData auth
  (StartBabyStation constraints)                 -> handleStartBabyStation constraints
  (InitBabyStation stream)                       -> onlineStatus .= Just stream
                                                    *> pure []

  SetBabyName name                               -> babyName .= name *> pure []
  SetNewBabyName name                            -> do
    newBabyName .= name
    babyName .= name
    pure []
  (ConnectToBaby babyId)                         -> handleConnectToBaby babyId
  StopBabyStation                                -> handleStopBabyStation
  (ReportError _)                                -> noEffects
  Nop                                            -> noEffects

toChannel :: forall ps. ChannelId -> ToChild (Props ps) State (ChannelC.Props {}) ChannelC.State
toChannel channelId' = do
  state <- get
  pProps <- ask
  let
    props :: ChannelC.Props {}
    props = mkChannelProps pProps state channelId'
  pure $ makeChildData (channel channelId' <<< _Just) props

handleStartBabyStation :: forall ps.
                          MediaStreamConstraints
                       -> ComponentType (Props ps) State Action
handleStartBabyStation constraints =
  runGonimo $
    InitBabyStation <$> liftAff (getUserMedia constraints)

handleAcceptConnection :: forall ps. ChannelId -> ComponentType (Props ps) State  Action
handleAcceptConnection channelId' = do
  state <- get
  pure [ AddChannel channelId' <$> ChannelC.init state.onlineStatus ]

handleFamilySwitch :: forall ps. Key Family -> ComponentType (Props ps) State Action
handleFamilySwitch familyId' = do
    state <- get :: Component (Props ps) State State
    let oldFamily = state.currentFamily
    modify $ _ { currentFamily = Just familyId' }
    let action = fromFoldable
                 $ pure <<< ServerFamilyGoOffline
                 <$> oldFamily
    pure $ doCleanup state CloseChannel action

handleSetAuthData :: forall ps. AuthData -> ComponentType (Props ps) State Action
handleSetAuthData auth = do
  state <- get
  authData .= auth
  pure $ doCleanup state CloseChannel []

handleStopBabyStation :: forall ps. ComponentType (Props ps) State Action
handleStopBabyStation = do
  state <- get :: Component (Props ps) State State
  props <- ask :: Component (Props ps) State (Props ps)
  onlineStatus .= (Nothing :: Maybe MediaStream)
  let action = case state.onlineStatus of
        Nothing -> []
        Just stream -> [ toIO props.settings <<< liftEff $ do
                             stopStream stream
                             pure Nop
                        ]
  pure $ doCleanup state CloseBabyChannel action

handleServerFamilyGoOffline :: forall ps. Key Family -> ComponentType (Props ps) State Action
handleServerFamilyGoOffline familyId = do
    state <- get
    let deviceId = (runAuthData state.authData).deviceId
    runGonimo $ do
      deleteOnlineStatusByFamilyIdByDeviceId familyId deviceId
      pure Nop

handleConnectToBaby :: forall ps. Key Device -> ComponentType (Props ps) State Action
handleConnectToBaby babyId = do
  state <- get
  props <- ask
  let ourId = state ^. authData <<< to runAuthData <<< deviceId
  let actions = fromMaybe [] $ do
        familyId <- state.currentFamily
        pure [ toIO props.settings $ do
                  secret <- postSocketByFamilyIdByToDevice ourId familyId babyId
                  let channelId' = makeChannelId babyId secret
                  AddChannel channelId' <$> liftIO (ChannelC.init Nothing)
             ]
  pure actions

updateChannel :: forall ps. ChannelId -> ChannelC.Action -> ComponentType (Props ps) State Action
updateChannel channelId' = toParent [] (ChannelA channelId')
                           <<< liftChild (toChannel channelId')
                           <<< ChannelC.update

doCleanup :: State -> (ChannelId -> Action) -> Array (IO Action) -> Array (IO Action)
doCleanup state cleanup action =
    if Map.isEmpty state.channels
    then action
    else Arr.fromFoldable (pure <<< cleanup <$> Map.keys state.channels)
         <> action

getParentChannels :: State -> Array (Tuple ChannelId ChannelC.State)
getParentChannels =  Arr.filter (not _.isBabyStation <<< snd ) <<< Arr.fromFoldable
                     <<< Map.toList <<< _.channels

view :: forall ps. Props ps -> State -> Html Action
view props state = H.div []
       [ viewBabyNameSelect props state
       , if isJust state.onlineStatus
         then viewStopButton state
         else viewStartButton state
       ]

viewBabyNameSelect :: forall ps. Props ps -> State -> Html Action
viewBabyNameSelect props state =
  let
    lastBabies = concat
                 <<< fromFoldable -- Maybe Array -> Array Array
                 <<< map (_.familyLastUsedBabyNames <<< runFamily)
                 $ props.family

  in
    H.div [ A.className "well", A.role "group" ]
    [ H.div [ A.className "btn-group btn-group btn-group-justified", A.role "group" ]
      $ viewBabyButton state <$> lastBabies
    , H.div [ A.className "input-group"]
      [ H.span [ A.className "input-group-btn"]
        [
          H.button [ A.className $ "btn btn-default"
                                 <> if state.newBabyName == state.babyName
                                    then " active"
                                    else ""
                   , A.type_ "button"
                   , E.onClick $ const (SetBabyName state.newBabyName) ]
          [
            H.text "New baby: "
          ]
        ]
      , H.input [ A.type_ "text", A.className "form-control", A.placeholder "New baby name"
                , E.onInput $ \ev -> SetNewBabyName ev.target.value
                , A.value state.newBabyName
                ] []
      ]
    ]

viewBabyButton :: State -> String -> Html Action
viewBabyButton state baby =
  H.div [ A.className "btn-group", A.role "group" ]
  [
    H.button [ A.className $ "btn btn-default" <> if baby == state.babyName then " active" else ""
             , A.type_ "button"
             , E.onClick $ const $ SetBabyName baby
             ]
    [ H.text baby ]
  ]

viewStopButton :: State -> Html Action
viewStopButton state =
    H.div [ A.className "btn-group", A.role "group" ]
    [ H.h2 [] [ H.text $ "Baby monitor running for cute " <> state.babyName <> " ..." ]
    , H.button [ A.className "btn btn-block btn-danger"
                , A.type_ "button"
                , E.onClick $ const $ StopBabyStation
                ]
      [ H.text "Stop Baby Monitor "
      , H.span [A.className "glyphicon glyphicon-off"] []
      ]
    ]

viewStartButton :: State -> Html Action
viewStartButton state =
  H.div [ A.className "btn-group", A.role "group" ]
  [
    H.button [ A.className "btn btn-block btn-info"
             , A.type_ "button"
             , E.onClick $ const $ StartBabyStation (MediaStreamConstraints { video : true, audio : true })
             ]
    [ H.text $ "Start Baby Station for cute " <> state.babyName <> " "
    , H.span [A.className "glyphicon glyphicon-transfer"] []
    ]
  ]
  --   case state.onlineStatus of
--     Nothing -> text "Sorry - no video there yet!"
--     Just station -> H.div []
--                     [ text $ "Got video, is enabled: "
--                             <> show ((unsafeCoerce station.mediaStream).enabled :: Boolean)
--                     , H.video [ A.src stream.objectURL, A.autoPlay "true" ] []
--                     ]

viewParentChannels :: State -> Array (Html Action)
viewParentChannels state = let
    channels = getParentChannels state
    makeView :: Tuple ChannelId ChannelC.State -> Html Action
    makeView (Tuple chanId state) = ChannelA chanId <$> ChannelC.view state
  in
     makeView <$> channels

getSubscriptions :: forall ps. Props ps -> State -> Subscriptions Action
getSubscriptions props state =
  let
    authData' = state ^. authData <<< to runAuthData
    familyId' = state ^. currentFamily
    receiveAChannel deviceId' familyId'' =
      receiveSocketByFamilyIdByToDevice
        (maybe Nop (AcceptConnection <<< uncurry makeChannelId ) <<< join)
        familyId''
        deviceId'

    getChannelSubscriptions :: forall m. (MonadReader Settings m)
                                  => ChannelId -> m (Subscriptions Action)
    getChannelSubscriptions channelId' =
      let
        cProps = mkChannelProps props state channelId'
      in
      map (ChannelA channelId') <$> ChannelC.getSubscriptions cProps

    getChannelsSubscriptions :: forall m. (MonadReader Settings m)
                                => Map ChannelId ChannelC.State
                                -> Array (m (Subscriptions Action))
    getChannelsSubscriptions = Arr.fromFoldable <<< map getChannelSubscriptions <<< Map.keys

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader props.settings)
                $ getChannelsSubscriptions state.channels
                <> ( fromFoldable $ do
                        r <- state.onlineStatus -- Get only online if a baby.
                        familyId'' <- familyId'
                        pure $ receiveAChannel authData'.deviceId familyId''
                   )
  in
     foldl append mempty subArray

mkChannelProps :: forall ps. Props ps -> State -> ChannelId -> ChannelC.Props {}
mkChannelProps props state channelId = { ourId : state ^. authData <<< to runAuthData <<< deviceId
                                       , theirId : toTheirId channelId
                                       , cSecret : toCSecret channelId
                                       , familyId : ChannelC.unsafeMakeFamilyId state.currentFamily
                                       , settings : props.settings
                                       , sendAction : lmap (ChannelA channelId) props.sendActionSocket
                                       }


Lock down runner exports

Lock down runner exports

module Test.Spec.Runner (
    run
  , run'
  , runSpec
  , runSpec'
  , defaultConfig
  , Config
  , RunEffects
  ) where

import Prelude

import Pipes as P
import Pipes (yield)
import Pipes.Core (Producer(), (//>))
import Pipes.Core as P
import Pipes.Prelude as P

import Data.Array       (singleton)
import Data.Traversable (for, sequence_)
import Data.Foldable    (foldl)
import Data.Tuple       (snd)
import Data.Either      (either)
import Data.Maybe       (Maybe(..), fromMaybe)

import Control.Monad.Aff           (Aff(), runAff, attempt)
import Control.Monad.Eff           (Eff())
import Control.Monad.Eff.Class     (liftEff)
import Control.Monad.Eff.Console   (CONSOLE(), logShow)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Eff.Exception as Error
import Control.Monad.Trans.Class   (lift)
import Control.Alternative ((<|>))

import Node.Process (PROCESS())
import Node.Process as Process

import Test.Spec.Runner.Event (Event)
import Test.Spec.Runner.Event as Event
import Test.Spec              (Spec(), Group(..), Result(..), collect)
import Test.Spec              as Spec
import Test.Spec.Reporter     (BaseReporter())
import Test.Spec.Reporter     as Reporter
import Test.Spec.Console      (withAttrs)
import Test.Spec.Summary      (successful)
import Test.Spec.Speed        (speedOf)
import Test.Spec.Speed as     Speed

foreign import dateNow :: ∀ e. Eff e Int

type RunEffects e = (process :: PROCESS, console :: CONSOLE | e)

type Config = { slow :: Int }

defaultConfig :: Config
defaultConfig = {
  slow: 75
}

trim :: ∀ r. Array (Group r) -> Array (Group r)
trim xs = fromMaybe xs (singleton <$> findJust findOnly xs)
  where
  findOnly :: forall r. Group r -> Maybe (Group r)
  findOnly g@(It true _ _) = pure g
  findOnly g@(Describe o _ gs) = findJust findOnly gs <|> if o then pure g else Nothing
  findOnly _ = Nothing

  findJust :: forall a. (a -> Maybe a) -> Array a -> Maybe a
  findJust f = foldl go Nothing
    where
    go Nothing x = f x
    go acc _ = acc

-- Run the given spec as `Producer` in the underlying `Aff` monad.
-- This producer has two responsibilities:
--      1) emit events for key moments in the runner's lifecycle
--      2) collect the tst output into an array of results
-- This allows downstream consumers to report about the tests even before the
-- prodocer has completed and still benefit from the array of results the way
-- the runner sees it.
_run
  :: ∀ e
   . Config
  -> Spec e Unit
  -> Producer Event (Aff e) (Array (Group Result))
_run { slow } spec = do
  yield (Event.Start (Spec.countTests spec))
  for (trim $ collect spec) runGroup
  <* yield Event.End

  where
  runGroup (It only name test) = do
    yield Event.Test
    start    <- lift $ liftEff dateNow
    e        <- lift $ attempt test
    duration <- lift $ (_ - start) <$> liftEff dateNow
    yield $ either
      (Event.Fail name <<< Error.message)
      (const $ Event.Pass name (speedOf slow duration) duration)
      e
    yield Event.TestEnd
    pure $ It only name $ either Failure (const Success) e

  runGroup (Pending name) = do
    yield $ Event.Pending name
    pure $ Pending name

  runGroup (Describe only name xs) = do
    yield $ Event.Suite name
    Describe only name <$> (for xs runGroup)
    <* yield Event.SuiteEnd

-- Run a spec, returning the results, without any reporting
runSpec'
  :: ∀ e
   . Config
  -> Spec e Unit
  -> Aff e (Array (Group Result))
runSpec' config spec = P.runEffect $ _run config spec //> const (pure unit)

runSpec
  :: ∀ e
   . Spec e Unit
  -> Aff e (Array (Group Result))
runSpec spec = P.runEffect $ _run defaultConfig spec //> const (pure unit)

-- Run the spec, report results and exit the program upon completion
run'
  :: ∀ c s e
   . Config
  -> Array (BaseReporter c s (Eff (RunEffects e)))
  -> Spec (RunEffects e) Unit
  -> Eff  (RunEffects e) Unit
run' config reporters spec = void do
  runAff onError onSuccess do
    snd <$> do
      P.foldM' step begin done do
        _run config spec

  where
    begin       = pure reporters
    step rs evt = for rs (liftEff <<< Reporter.update evt)
    done _      = pure unit

    onError :: Error -> Eff (RunEffects e) Unit
    onError err = do withAttrs [31] $ logShow err
                     Process.exit 1

    onSuccess :: Array (Group Result) -> Eff (RunEffects e) Unit
    onSuccess results = do sequence_ (map (Reporter.summarize results) reporters)
                           if (successful results)
                             then Process.exit 0
                             else Process.exit 1

run
  :: ∀ c s e
   . Array (BaseReporter c s (Eff (RunEffects e)))
  -> Spec (RunEffects e) Unit
  -> Eff  (RunEffects e) Unit
run = run' defaultConfig

module Test.Spec.Runner where

import Prelude

import Pipes as P
import Pipes (yield)
import Pipes.Core (Producer(), (//>))
import Pipes.Core as P
import Pipes.Prelude as P

import Data.Array       (singleton)
import Data.Traversable (for, sequence_)
import Data.Foldable    (foldl)
import Data.Tuple       (snd)
import Data.Either      (either)
import Data.Maybe       (Maybe(..), fromMaybe)

import Control.Monad.Aff           (Aff(), runAff, attempt)
import Control.Monad.Eff           (Eff())
import Control.Monad.Eff.Class     (liftEff)
import Control.Monad.Eff.Console   (CONSOLE(), logShow)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Eff.Exception as Error
import Control.Monad.Trans.Class   (lift)
import Control.Alternative ((<|>))

import Node.Process (PROCESS())
import Node.Process as Process

import Test.Spec.Runner.Event (Event)
import Test.Spec.Runner.Event as Event
import Test.Spec              (Spec(), Group(..), Result(..), collect)
import Test.Spec              as Spec
import Test.Spec.Reporter     (BaseReporter())
import Test.Spec.Reporter     as Reporter
import Test.Spec.Console      (withAttrs)
import Test.Spec.Summary      (successful)
import Test.Spec.Speed        (speedOf)
import Test.Spec.Speed as     Speed

foreign import dateNow :: ∀ e. Eff e Int

type RunEffects e = (process :: PROCESS, console :: CONSOLE | e)

type Config = { slow :: Int }

defaultConfig :: Config
defaultConfig = {
  slow: 75
}

trim :: ∀ r. Array (Group r) -> Array (Group r)
trim xs = fromMaybe xs (singleton <$> findJust findOnly xs)
  where
  findOnly :: forall r. Group r -> Maybe (Group r)
  findOnly g@(It true _ _) = pure g
  findOnly g@(Describe o _ gs) = findJust findOnly gs <|> if o then pure g else Nothing
  findOnly _ = Nothing

  findJust :: forall a. (a -> Maybe a) -> Array a -> Maybe a
  findJust f = foldl go Nothing
    where
    go Nothing x = f x
    go acc _ = acc

-- Run the given spec as `Producer` in the underlying `Aff` monad.
-- This producer has two responsibilities:
--      1) emit events for key moments in the runner's lifecycle
--      2) collect the tst output into an array of results
-- This allows downstream consumers to report about the tests even before the
-- prodocer has completed and still benefit from the array of results the way
-- the runner sees it.
_run
  :: ∀ e
   . Config
  -> Spec e Unit
  -> Producer Event (Aff e) (Array (Group Result))
_run { slow } spec = do
  yield (Event.Start (Spec.countTests spec))
  for (trim $ collect spec) runGroup
  <* yield Event.End

  where
  runGroup (It only name test) = do
    yield Event.Test
    start    <- lift $ liftEff dateNow
    e        <- lift $ attempt test
    duration <- lift $ (_ - start) <$> liftEff dateNow
    yield $ either
      (Event.Fail name <<< Error.message)
      (const $ Event.Pass name (speedOf slow duration) duration)
      e
    yield Event.TestEnd
    pure $ It only name $ either Failure (const Success) e

  runGroup (Pending name) = do
    yield $ Event.Pending name
    pure $ Pending name

  runGroup (Describe only name xs) = do
    yield $ Event.Suite name
    Describe only name <$> (for xs runGroup)
    <* yield Event.SuiteEnd

-- Run a spec, returning the results, without any reporting
runSpec'
  :: ∀ e
   . Config
  -> Spec e Unit
  -> Aff e (Array (Group Result))
runSpec' config spec = P.runEffect $ _run config spec //> const (pure unit)

runSpec
  :: ∀ e
   . Spec e Unit
  -> Aff e (Array (Group Result))
runSpec spec = P.runEffect $ _run defaultConfig spec //> const (pure unit)

-- Run the spec, report results and exit the program upon completion
run'
  :: ∀ c s e
   . Config
  -> Array (BaseReporter c s (Eff (RunEffects e)))
  -> Spec (RunEffects e) Unit
  -> Eff  (RunEffects e) Unit
run' config reporters spec = void do
  runAff onError onSuccess do
    snd <$> do
      P.foldM' step begin done do
        _run config spec

  where
    begin       = pure reporters
    step rs evt = for rs (liftEff <<< Reporter.update evt)
    done _      = pure unit

    onError :: Error -> Eff (RunEffects e) Unit
    onError err = do withAttrs [31] $ logShow err
                     Process.exit 1

    onSuccess :: Array (Group Result) -> Eff (RunEffects e) Unit
    onSuccess results = do sequence_ (map (Reporter.summarize results) reporters)
                           if (successful results)
                             then Process.exit 0
                             else Process.exit 1

run
  :: ∀ c s e
   . Array (BaseReporter c s (Eff (RunEffects e)))
  -> Spec (RunEffects e) Unit
  -> Eff  (RunEffects e) Unit
run = run' defaultConfig


Clean up test

Clean up test

module Test.Spec.ParserGenSpec (parserGenSpec) where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Tuple (uncurry)
import Data.Map as Map
import Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import Text.Parsing.Parser as P

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)

import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Value
import Language.Docopt.Usage
import Language.Docopt.ParserGen (genParser, runParser)
import Language.Docopt.Argument as D
import Language.Docopt.Trans    as T
import Test.Support.Docopt      as D

data Test = Test (Array Argument) (Array Case)
data Case = Case (Array String) (Either String (Map Argument Value))

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Array String -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Array String -> String -> Case
fail i e = Case i (Left e)

(:>) = Tuple
infixr 0 :>

parserGenSpec = \_ -> describe "The generator" do

  -- Some options that will be used for these tests
  let testCases = [

      test
        [ D.poR "qux" ]
        [ pass
            [ "a", "b", "c" ]
            [ D.poR "qux" :> D.array [ D.str "a"
                                     , D.str "b"
                                     , D.str "c"
                                     ]
            ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument: \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test
        [ D.poR "qux", D.eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ D.poR "qux" :> D.array [ D.str "a"
                                     , D.str "b"
                                     , D.str "c"
                                     ]
            , D.eoa :> D.array []
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ D.poR "qux" :> D.array [ D.str "a"
                                     , D.str "b"
                                     , D.str "c"
                                     ]
            , D.eoa :> D.array [ D.str "--" , D.str "--" ]
            ]
        ]

    , test
        [ D.grr false [] ]
        [ pass [] [] ]

    , test
        [ D.gro false [] ]
        [ pass [] [] ]

    , test
        [ D.opt 'h' "host" (D.oa "host[:port]"
                           (D.str "http://localhost:3000"))
        ]
        [ pass
            [ "-hhttp://localhost:5000" ]
            [ D.opt 'h'
                    "host"
                    (D.oa "host[:port]" (D.str "http://localhost:3000"))
              :> D.str "http://localhost:5000"
            ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ D.opt 'i' "input" (D.oa_ "FILE") :> (D.str "bar") ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ D.opt 'i' "input" (D.oa_ "FILE") :> (D.str "bar") ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail []
          $ "Missing required options: "
              ++ "-o, --output=FILE, (-i, --input=FILE)"

        , fail [ "-i", "bar" ]
          $ "Missing required options: -o, --output=FILE"

        , pass [ "-i", "bar", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]

          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
        ]

    , test
        [ D.grr false [[
            D.grr false [[
              D.opt 'i' "input" (D.oa_ "FILE")
            ]]
          , D.opt 'r' "redirect" (D.oa_ "FILE")
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail []
          $ "Missing required options: "
              ++ "-o, --output=FILE, "
              ++ "((-i, --input=FILE) -r, --redirect=FILE)"

        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"

        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE")   :> D.str "bar"
            , D.opt 'r' "redirect" (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE")   :> D.str "bar" ]

          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE")   :> D.str "bar"
            , D.opt 'r' "redirect" (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE")   :> D.str "bar" ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          , D.po  "env"
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.po  "env"                       :> D.str "x"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ D.co    "foo"
        , D.opt_  'o' "out"
        , D.optR_ 'q' "qux"
        , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax")
        , D.opt_  'i' "input"
        , D.optR  'f' "foo" (D.oa_ "FOZ")
        , D.co     "baz"
        ]
        [ pass
            [ "foo", "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ D.co    "foo"                   :> D.bool true
            , D.opt_  'o' "out"               :> D.bool true
            , D.opt_  'i' "input"             :> D.bool true
            , D.optR_ 'q' "qux"               :> D.array [ D.bool true ]
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox" ]
            , D.co    "baz"                   :> D.bool true
            -- should have added default value that was not provided above:
            , D.opt 'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ D.co    "foo"     :> D.bool true
            , D.opt_  'o' "out" :> D.bool true
            , D.optR_ 'q' "qux" :> D.array [ D.bool true
                                           , D.bool true
                                           , D.bool true
                                           ]
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox"
                                                         ]
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.opt_  'i' "input" :> D.bool true
            , D.co    "baz"       :> D.bool true
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ D.co    "foo"       :> D.bool true
            , D.optR_ 'q' "qux"   :> D.array [ D.bool true , D.bool true ]
            , D.opt_  'o' "out"   :> D.bool true
            , D.opt_  'i' "input" :> D.bool true
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox" ]
            , D.co    "baz"       :> D.bool true
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ D.co    "foo"       :> D.bool true
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.opt_  'o' "out"   :> D.bool true
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox" ]
            , D.opt_  'i' "input" :> D.bool true
            , D.co     "baz"      :> D.bool true
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ D.co    "foo"       :> D.bool true
            , D.opt_  'o' "out"   :> D.bool true
            , D.opt_  'i' "input" :> D.bool true
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.co    "baz"       :> D.bool true
            -- should have added default value that was not provided above:
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ D.gro false [[ D.co "foo" ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ D.grr false [[ D.co "foo" ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ D.br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  prettyPrintOut
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

      prettyPrintOut :: Map Argument Value -> String
      prettyPrintOut m = "\n\t" ++ (prettyPrintMap m prettyPrintArg)

      prettyPrintMap :: forall a. Map a Value -> (a -> String) -> String
      prettyPrintMap m p = intercalate "\n\t" $
        Map.toList m <#> \(Tuple arg val) ->
          p arg ++ " => " ++ prettyPrintValue val

      validate :: forall eff.  Array Argument
                            -> Array String
                            -> Either String (Map Argument Value)
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = uncurry T.reduce
              <$> runParser
                    argv
                    (genParser $ singleton $ Usage $ singleton $ D.br args)

        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOut r
                  else return unit)
              expected

module Test.Spec.ParserGenSpec (parserGenSpec) where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Tuple (uncurry)
import Data.Map as Map
import Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import Text.Parsing.Parser as P

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)

import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Value
import Language.Docopt.Usage
import Language.Docopt.ParserGen (genParser, runParser)
import Language.Docopt.Argument as D
import Language.Docopt.Trans    as T
import Test.Support.Docopt      as D

data Test = Test (Array Argument) (Array Case)
data Case = Case (Array String) (Either String (Map Argument Value))

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Array String -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Array String -> String -> Case
fail i e = Case i (Left e)

(:>) = Tuple
infixr 0 :>

parserGenSpec = \_ -> describe "The generator" do

  -- Some options that will be used for these tests
  let testCases = [

      test
        [ D.poR "qux" ]
        [ pass
            [ "a", "b", "c" ]
            [ D.poR "qux" :> D.array [ D.str "a"
                                     , D.str "b"
                                     , D.str "c"
                                     ]
            ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument: \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test
        [ D.poR "qux", D.eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ D.poR "qux" :> D.array [ D.str "a"
                                     , D.str "b"
                                     , D.str "c"
                                     ]
            , D.eoa :> D.array []
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ D.poR "qux" :> D.array [ D.str "a"
                                     , D.str "b"
                                     , D.str "c"
                                     ]
            , D.eoa :> D.array [ D.str "--" , D.str "--" ]
            ]
        ]

    , test
        [ D.grr false [] ]
        [ pass [] [] ]

    , test
        [ D.gro false [] ]
        [ pass [] [] ]

    , test
        [ D.opt 'h' "host" (D.oa "host[:port]"
                           (D.str "http://localhost:3000"))
        ]
        [ pass
            [ "-hhttp://localhost:5000" ]
            [ D.opt 'h'
                    "host"
                    (D.oa "host[:port]" (D.str "http://localhost:3000"))
              :> D.str "http://localhost:5000"
            ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ D.opt 'i' "input" (D.oa_ "FILE") :> (D.str "bar") ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ D.opt 'i' "input" (D.oa_ "FILE") :> (D.str "bar") ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail [] "Missing required options: -o, --output=FILE, (-i, --input=FILE)"
        , fail [ "-i", "bar" ] "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
        ]

    , test
        [ D.grr false [[
            D.grr false [[
              D.opt 'i' "input" (D.oa_ "FILE")
            ]]
          , D.opt 'r' "redirect" (D.oa_ "FILE")
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail []
            "Missing required options: -o, --output=FILE, ((-i, --input=FILE) -r, --redirect=FILE)"
        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE")   :> D.str "bar"
            , D.opt 'r' "redirect" (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE")   :> D.str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE")   :> D.str "bar"
            , D.opt 'r' "redirect" (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE")   :> D.str "bar" ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          , D.po  "env"
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.po  "env"                       :> D.str "x"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ D.co "foo"
        , D.opt_  'o' "out"
        , D.optR_ 'q' "qux"
        , D.opt 'b' "baz" (D.oa "BAZ" $ D.str "ax")
        , D.opt_  'i' "input"
        , D.optR  'f' "foo" (D.oa_ "FOZ")
        , D.co     "baz"
        ]
        [ pass
            [ "foo" , "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ D.co    "foo"                   :> D.bool true
            , D.opt_  'o' "out"               :> D.bool true
            , D.opt_  'i' "input"             :> D.bool true
            , D.optR_ 'q' "qux"               :> D.array [ D.bool true ]
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox" ]
            , D.co     "baz"                  :> D.bool true
            -- should have added default value that was not provided above:
            , D.opt 'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ D.co    "foo"     :> D.bool true
            , D.opt_  'o' "out" :> D.bool true
            , D.optR_ 'q' "qux" :> D.array [ D.bool true
                                           , D.bool true
                                           , D.bool true
                                           ]
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox"
                                                         ]
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.opt_  'i' "input" :> D.bool true
            , D.co    "baz"       :> D.bool true
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ D.co    "foo"       :> D.bool true
            , D.optR_ 'q' "qux"   :> D.array [ D.bool true , D.bool true ]
            , D.opt_  'o' "out"   :> D.bool true
            , D.opt_  'i' "input" :> D.bool true
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox" ]
            , D.co    "baz"       :> D.bool true
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ D.co    "foo"       :> D.bool true
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.opt_  'o' "out"   :> D.bool true
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox" ]
            , D.opt_  'i' "input" :> D.bool true
            , D.co     "baz"      :> D.bool true
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ D.co    "foo"       :> D.bool true
            , D.opt_  'o' "out"   :> D.bool true
            , D.opt_  'i' "input" :> D.bool true
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.co    "baz"       :> D.bool true
            -- should have added default value that was not provided above:
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ D.gro false [[ D.co "foo" ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ D.grr false [[ D.co "foo" ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ D.br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  prettyPrintOut
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

      prettyPrintOut :: Map Argument Value -> String
      prettyPrintOut m = "\n\t" ++ (prettyPrintMap m prettyPrintArg)

      prettyPrintMap :: forall a. Map a Value -> (a -> String) -> String
      prettyPrintMap m p = intercalate "\n\t" $
        Map.toList m <#> \(Tuple arg val) ->
          p arg ++ " => " ++ prettyPrintValue val

      validate :: forall eff.  Array Argument
                            -> Array String
                            -> Either String (Map Argument Value)
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = uncurry T.reduce
              <$> runParser
                    argv
                    (genParser $ singleton $ Usage $ singleton $ D.br args)

        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOut r
                  else return unit)
              expected


Functions using any from ch. 4 p. 44

Functions using any from ch. 4 p. 44

module Data.Recursion where
import Data.Maybe
import Data.Array (concatMap, filter, length, map, null, range)
import Data.Array.Unsafe (head, last, tail)
import Prelude.Unsafe (unsafeIndex)
import Control.MonadPlus (guard)
import Data.Foldable (any)
import Debug.Trace

-- re-implement the `length` function as `size`
size :: forall a. [a] -> Number
size arr =
  if null arr
     then 0
     else 1 + size (tail arr)

fact :: Number -> Number
fact 0 = 1
fact n = n * fact (n - 1)

fib :: Number -> Number
fib 0 = 1
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

isEven :: Number -> Boolean
isEven 0 = true
isEven 1 = false
isEven n = isEven (n % 2)

countEven :: forall a. [Number] -> Number
countEven [] = 0
countEven arr =
  if isEven $ head arr
     then 1 + (countEven $ tail arr)
     else 0 + (countEven $ tail arr)

square :: forall a. [Number] -> [Number]
square arr = map (\n -> n * n) arr

infix 1 <$?>

(<$?>) fn arr = filter fn arr

positives :: forall a. [Number] -> [Number]
positives arr = (\n -> n >= 0) <$?> arr

product :: forall a. [Number] -> Number
product pair = (head pair) * (last pair)

pairs :: Number -> [[Number]]
pairs n = concatMap (\i -> map (\j -> [i, j]) (i..n)) (1..n)

--factors :: Number -> [[Number]]
--factors n = filter (\pair -> product pair == n) (pairs n)

factors :: Number -> [[Number]]
factors n = do
  i <- (1..n)
  j <- (i..n)
  guard $ i * j == n
  return [i, j]

containsNumber :: [Number] -> Number -> Boolean
containsNumber arr match = any (\item -> item == match) arr

hasFactors :: Number -> Boolean
hasFactors n = any (\pair -> (not (pair `containsNumber` 1)) && (not (pair `containsNumber` n))) (factors n)

isPrime :: Number -> Boolean
isPrime n = length (factors n) == 1

--foreign import unsafeAt
--  "function unsafeAt (arr) {\
--  \  return function (i) {\
--  \    return arr[i];\
--  \  };\
--  \}" :: forall a. [a] -> Number -> a

cartesian :: forall a. [Number] -> [Number] -> [[Number]]
cartesian a b = do
  i <- (0..(length a)-1)
  j <- (0..(length b)-1)
  return [(unsafeIndex a i), (unsafeIndex b j)]

main = do
  let array = (1..10)
  --print $ size array
  --print $ fact 10
  --print $ fib 10
  --print $ square array
  --print $ positives (-5..5)
  --print $ pairs 3
  --print $ pairs 10
  --print $ factors 3
  --print $ factors 10
  --print $ isPrime 13
  --print $ isPrime 14
  --print $ unsafeAt [1,2,3] 1
  --print $ cartesian [1,2,3] [4,5,6]
  --print $ containsNumber [1,5] 5
  --print $ containsNumber [1,5] 3
  print $ hasFactors 3
  print $ hasFactors 10

module Data.Recursion where
import Data.Maybe
import Data.Array (concatMap, filter, length, map, null, range)
import Data.Array.Unsafe (head, last, tail)
import Prelude.Unsafe (unsafeIndex)
import Control.MonadPlus (guard)
import Debug.Trace

-- re-implement the `length` function as `size`
size :: forall a. [a] -> Number
size arr =
  if null arr
     then 0
     else 1 + size (tail arr)

fact :: Number -> Number
fact 0 = 1
fact n = n * fact (n - 1)

fib :: Number -> Number
fib 0 = 1
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

isEven :: Number -> Boolean
isEven 0 = true
isEven 1 = false
isEven n = isEven (n % 2)

countEven :: forall a. [Number] -> Number
countEven [] = 0
countEven arr =
  if isEven $ head arr
     then 1 + (countEven $ tail arr)
     else 0 + (countEven $ tail arr)

square :: forall a. [Number] -> [Number]
square arr = map (\n -> n * n) arr

infix 1 <$?>

(<$?>) fn arr = filter fn arr

positives :: forall a. [Number] -> [Number]
positives arr = (\n -> n >= 0) <$?> arr

product :: forall a. [Number] -> Number
product pair = (head pair) * (last pair)

pairs :: Number -> [[Number]]
pairs n = concatMap (\i -> map (\j -> [i, j]) (i..n)) (1..n)

--factors :: Number -> [[Number]]
--factors n = filter (\pair -> product pair == n) (pairs n)

factors :: Number -> [[Number]]
factors n = do
  i <- (1..n)
  j <- (i..n)
  guard $ i * j == n
  return [i, j]

isPrime :: Number -> Boolean
isPrime n = length (factors n) == 1

--foreign import unsafeAt
--  "function unsafeAt (arr) {\
--  \  return function (i) {\
--  \    return arr[i];\
--  \  };\
--  \}" :: forall a. [a] -> Number -> a

cartesian :: forall a. [Number] -> [Number] -> [[Number]]
cartesian a b = do
  i <- (0..(length a)-1)
  j <- (0..(length b)-1)
  return [(unsafeIndex a i), (unsafeIndex b j)]

main = do
  let array = (1..10)
  --print $ size array
  --print $ fact 10
  --print $ fib 10
  --print $ square array
  --print $ positives (-5..5)
  --print $ pairs 3
  --print $ factors 10
  --print $ isPrime 13
  --print $ isPrime 14
  --print $ unsafeAt [1,2,3] 1
  print $ cartesian [1,2,3] [4,5,6]