Changed help text

Changed help text

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

import Prelude hiding (degree)

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

import Quantities (Quantity, DerivedUnit, UnificationError, asValueIn, pow,
                   qNegate, qAdd, qDivide, qMultiply, qSubtract, quantity,
                   unity, convert, errorMessage, prettyPrint, fullSimplify)

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

-- | The types of errors that may appear during evaluation
data EvalError
  = UnificationError UnificationError
  | LookupError String

type Expect = Either EvalError

data MessageType = Value | Info | Error

data Message = Message MessageType String

-- A few helper functions
qSubtract' ∷ Quantity → Quantity → Expect Quantity
qSubtract' q1 q2 = lmap UnificationError (qSubtract q1 q2)

qAdd' ∷ Quantity → Quantity → Expect Quantity
qAdd' q1 q2 = lmap UnificationError (qAdd q1 q2)

asScalar ∷ Quantity → Expect Number
asScalar q = lmap UnificationError (q `asValueIn` unity)

convert' ∷ DerivedUnit → Quantity → Expect Quantity
convert' d q = lmap UnificationError (convert d q)

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Q n u)         = pure $ quantity n u
eval env (Negate x)      = qNegate <$> eval env x
eval env (BinOp Sub x y) = join $ qSubtract' <$> eval env x <*> eval env y
eval env (BinOp Add x y) = join $ qAdd'      <$> eval env x <*> eval env y
eval env (BinOp Mul x y) =        qMultiply  <$> eval env x <*> eval env y
eval env (BinOp Div x y) =        qDivide    <$> eval env x <*> eval env y
eval env (BinOp Pow x y) = do
  base ← eval env x
  exp ← eval env y
  expNumber ← asScalar exp
  pure $ base `pow` expNumber
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)

evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

message ∷ Environment → Expect Quantity → { msg ∷ Message, newEnv ∷ Environment }
message env (Left e) =
  { msg: Message Error (evalErrorMessage e)
  , newEnv: env
  }
message env (Right q) =
  { msg: Message Value (prettyPrint q)
  , newEnv: insert "ans" q env
  }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → { msg ∷ Message, newEnv ∷ Environment }
runInsect env (Expression e) = message env (fullSimplify <$> eval env e)
runInsect env (Conversion e u) = message env (eval env e >>= convert' u)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message env (Left evalErr)
    Right value → message (insert n value env) (Right (fullSimplify value))
runInsect env (Command Help) = { msg: Message Info (intercalate "\n"
  [ "insect is a command-line scientific calculator."
  , ""
  , "It evaluates simple calculations like 1920/16·9 as"
  , "well as expressions involving physical quantities."
  , ""
  , "You can start by trying one of these examples:"
  , ""
  , "  > 1920/16*9"
  , ""
  , "  > 2min + 30s"
  , ""
  , "  > 60mph -> m/s"
  , ""
  , "  > 6Mbps*1.5h -> Gb"
  ]), newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command Reset) =
  { msg: Message Info "Environment has been reset"
  , newEnv: initialEnvironment }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }

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

import Prelude hiding (degree)

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

import Quantities (Quantity, DerivedUnit, UnificationError, asValueIn, pow,
                   qNegate, qAdd, qDivide, qMultiply, qSubtract, quantity,
                   unity, convert, errorMessage, prettyPrint, fullSimplify)

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

-- | The types of errors that may appear during evaluation
data EvalError
  = UnificationError UnificationError
  | LookupError String

type Expect = Either EvalError

data MessageType = Value | Info | Error

data Message = Message MessageType String

-- A few helper functions
qSubtract' ∷ Quantity → Quantity → Expect Quantity
qSubtract' q1 q2 = lmap UnificationError (qSubtract q1 q2)

qAdd' ∷ Quantity → Quantity → Expect Quantity
qAdd' q1 q2 = lmap UnificationError (qAdd q1 q2)

asScalar ∷ Quantity → Expect Number
asScalar q = lmap UnificationError (q `asValueIn` unity)

convert' ∷ DerivedUnit → Quantity → Expect Quantity
convert' d q = lmap UnificationError (convert d q)

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Q n u)         = pure $ quantity n u
eval env (Negate x)      = qNegate <$> eval env x
eval env (BinOp Sub x y) = join $ qSubtract' <$> eval env x <*> eval env y
eval env (BinOp Add x y) = join $ qAdd'      <$> eval env x <*> eval env y
eval env (BinOp Mul x y) =        qMultiply  <$> eval env x <*> eval env y
eval env (BinOp Div x y) =        qDivide    <$> eval env x <*> eval env y
eval env (BinOp Pow x y) = do
  base ← eval env x
  exp ← eval env y
  expNumber ← asScalar exp
  pure $ base `pow` expNumber
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)

evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

message ∷ Environment → Expect Quantity → { msg ∷ Message, newEnv ∷ Environment }
message env (Left e) =
  { msg: Message Error (evalErrorMessage e)
  , newEnv: env
  }
message env (Right q) =
  { msg: Message Value (prettyPrint q)
  , newEnv: insert "ans" q env
  }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → { msg ∷ Message, newEnv ∷ Environment }
runInsect env (Expression e) = message env (fullSimplify <$> eval env e)
runInsect env (Conversion e u) = message env (eval env e >>= convert' u)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message env (Left evalErr)
    Right value → message (insert n value env) (Right (fullSimplify value))
runInsect env (Command Help) = { msg: Message Info (intercalate "\n"
  [ "insect is a command-line scientific calculator."
  , ""
  , "It evaluates simple calculations like 1920/16·9 as"
  , "well as expressions involving physical quantities."
  , ""
  , "You can start by trying one of these examples:"
  , ""
  , "--> 1920/16*9"
  , ""
  , "--> 2min + 30s"
  , ""
  , "--> 60mph -> m/s"
  , ""
  , "--> 6Mbps*1.5h -> Gb"
  ]), newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command Reset) =
  { msg: Message Info "Environment has been reset"
  , newEnv: initialEnvironment }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }


add Request.CreateSpotDetail

add Request.CreateSpotDetail

module Request.CreateSpotDetail (createSpotDetail) where

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

body :: Detail -> String
body (Detail { name, value }) =
  ps [ p "view_type" "admin"
     , p "name" name
     , p "value" value
     ]

url :: Int -> String
url spotId =
  "https://api.rallyapp.jp/spots/" <> show spotId <> "/details"

createSpotDetail
  :: forall eff
   . Int
  -> Detail
  -> String
  -> Aff ( http :: HTTP
         | eff
         ) Detail
createSpotDetail spotId detail token = do
  text <- fetch options
  let f = readJSON text :: F Detail
  makeAff (\ng ok -> either (ng <<< error <<< show) ok $ runExcept f)
  where
    headers = StrMap.fromFoldable [ Tuple "Content-Type" "application/json"
                                  , Tuple "User-Agent" "rally-cli"
                                  , Tuple "Authorization" $ "Token token=\"" <> token <> "\""
                                  ]
    options = FetchOptions.method := FetchOptions.POST
              <> FetchOptions.url := (url spotId)
              <> FetchOptions.headers := headers
              <> FetchOptions.body := (body detail)

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


Add some generic classes to help enable styling

-- | This module defines functions for rendering Markdown to HTML.

module Text.Markdown.SlamDown.Html
  ( SlamDownEvent()
  , SlamDownState(..)
  , FormFieldValue(..)
  , initSlamDownState
  , applySlamDownEvent
  , renderHalogen
  )
  where

import Control.Alternative (Alternative)
import Control.Monad.State (State(), evalState)
import Control.Monad.State.Class (get, modify)

import Data.Array (concat, zipWith, mapMaybe)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.String (joinWith)
import Data.Tuple (Tuple(..), zip)
import Data.Traversable (traverse, zipWithA)

import Text.Markdown.SlamDown

import qualified Data.Set as S
import qualified Data.StrMap as M
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E

data FormFieldValue
  = SingleValue TextBoxType String
  | MultipleValues (S.Set String)

instance showFormFieldValue :: Show FormFieldValue where
  show (SingleValue t s) = "(SingleValue " ++ show t ++ " " ++ show s ++ ")"
  show (MultipleValues ss) = "(MultipleValues " ++ show ss ++ ")"

-- | The state of a SlamDown form - a mapping from input keys to values
newtype SlamDownState = SlamDownState (M.StrMap FormFieldValue)

instance showSlamDownState :: Show SlamDownState where
  show (SlamDownState m) = "(SlamDownState " ++ show m ++ ")"

-- | The initial state of form, in which all fields use their default values
initSlamDownState :: SlamDown -> SlamDownState
initSlamDownState = SlamDownState <<< M.fromList <<< everything (const mempty) go
  where
  go :: Inline -> [Tuple String FormFieldValue]
  go (FormField label _ field) = maybe [] (\v -> [Tuple label v]) $ getValue field
  go _ = []

  getValue :: FormField -> Maybe FormFieldValue
  getValue (TextBox tbt (Just (Literal value))) = Just $ SingleValue tbt value
  getValue (CheckBoxes (Literal sels) (Literal vals)) = Just $ MultipleValues $ S.fromList $ chk `mapMaybe` zip sels vals
    where
    chk (Tuple true value) = Just value
    chk _ = Nothing
  getValue (RadioButtons (Literal value) _) = Just $ SingleValue PlainText value
  getValue (DropDown _ (Just (Literal value))) = Just $ SingleValue PlainText value
  getValue _ = Nothing

-- | The type of events which can be raised by SlamDown forms
data SlamDownEvent
  = TextChanged TextBoxType String String
  | CheckBoxChanged String String Boolean

-- | Apply a `SlamDownEvent` to a `SlamDownState`.
applySlamDownEvent :: SlamDownState -> SlamDownEvent -> SlamDownState
applySlamDownEvent (SlamDownState m) (TextChanged t key val) =
  SlamDownState (M.insert key (SingleValue t val) m)
applySlamDownEvent (SlamDownState m) (CheckBoxChanged key val checked) =
  SlamDownState (M.alter (Just <<< updateSet) key m)
  where
  updateSet :: Maybe FormFieldValue -> FormFieldValue
  updateSet (Just (MultipleValues s))
    | checked = MultipleValues (S.insert val s)
    | otherwise = MultipleValues (S.delete val s)
  updateSet _
    | checked = MultipleValues (S.singleton val)
    | otherwise = MultipleValues S.empty

type Fresh = State Number

-- | Render the SlamDown AST to an arbitrary Halogen HTML representation
renderHalogen :: forall f. (Alternative f) => String -> SlamDownState -> SlamDown -> [H.HTML (f SlamDownEvent)]
renderHalogen formName (SlamDownState m) (SlamDown bs) = evalState (traverse renderBlock bs) 1

  where

  renderBlock :: Block -> Fresh (H.HTML (f SlamDownEvent))
  renderBlock (Paragraph is) = H.p_ <$> traverse renderInline is
  renderBlock (Header level is) = h_ level <$> traverse renderInline is
    where
    h_ :: forall a. Number -> [H.HTML (f a)] -> H.HTML (f a)
    h_ 1 = H.h1_
    h_ 2 = H.h2_
    h_ 3 = H.h3_
    h_ 4 = H.h4_
    h_ 5 = H.h5_
    h_ 6 = H.h6_
  renderBlock (Blockquote bs) = H.blockquote_ <$> traverse renderBlock bs
  renderBlock (List lt bss) = el_ lt <$> traverse item bss
    where
    el_ :: forall a. ListType -> [H.HTML (f a)] -> H.HTML (f a)
    el_ (Bullet _)  = H.ul_
    el_ (Ordered _) = H.ol_
    item :: [Block] -> Fresh (H.HTML (f SlamDownEvent))
    item bs = H.li_ <$> traverse renderBlock bs
  renderBlock (CodeBlock _ ss) =
    pure $ H.pre_ [ H.code_ [ H.text (joinWith "\n" ss) ] ]
  renderBlock (LinkReference l url) =
    pure $ H.p_ [ H.text (l <> ": ")
                , H.a [ A.name l, A.id_ l, A.href url ] [ H.text url ]
                ]
  renderBlock Rule = pure $ H.hr_ []

  renderInline :: Inline -> Fresh (H.HTML (f SlamDownEvent))
  renderInline (Str s) = pure $ H.text s
  renderInline (Entity s) = pure $ H.text s
  renderInline Space = pure $ H.text " "
  renderInline SoftBreak = pure $ H.text "\n"
  renderInline LineBreak = pure $ H.br_ []
  renderInline (Emph is) = H.em_ <$> traverse renderInline is
  renderInline (Strong is) = H.strong_ <$> traverse renderInline is
  renderInline (Code _ c) = pure $ H.code_ [ H.text c ]
  renderInline (Link body tgt) = H.a [ A.href (href tgt) ] <$> traverse renderInline body
    where
    href (InlineLink url) = url
    href (ReferenceLink tgt) = maybe "" ("#" ++) tgt
  renderInline (Image body url) = H.img [ A.src url ] <$> traverse renderInline body
  renderInline (FormField label req el) = do
    id <- fresh
    el' <- renderFormElement id label el
    pure $ H.span [ A.class_ (A.className "slamdown-field") ]
                  [ H.label (if requiresId then [ A.for id ] else [])
                            [ H.text (label ++ requiredLabel) ]
                  , el'
                  ]
    where
    requiredLabel = if req then "*" else ""
    requiresId = case el of
      CheckBoxes _ _ -> false
      RadioButtons _ _ -> false
      _ -> true

  renderFormElement :: String -> String -> FormField -> Fresh (H.HTML (f SlamDownEvent))
  renderFormElement id label (TextBox t Nothing) =
    pure $ renderTextInput id label t (lookupTextValue label "")
  renderFormElement id label (TextBox t (Just (Literal value))) =
    pure $ renderTextInput id label t (lookupTextValue label value)
  renderFormElement _ label (RadioButtons (Literal def) (Literal ls)) =
    H.ul [ A.class_ (A.className "slamdown-radios") ] <$> traverse (\val -> radio (val == sel) val) (def : ls)
    where
    sel = lookupTextValue label def
    radio checked value = do
      id <- fresh
      pure $ H.li_ [ H.input [ A.checked checked
                             , A.type_ "radio"
                             , A.id_ id
                             , A.name label
                             , A.value value
                             , E.onChange (E.input_ (TextChanged PlainText label value))
                             ] []
                   , H.label [ A.for id ] [ H.text value ]
                   ]
  renderFormElement _ label (CheckBoxes (Literal bs) (Literal ls)) =
    H.ul [ A.class_ (A.className "slamdown-checkboxes") ] <$> zipWithA checkBox (lookupMultipleValues label bs ls) ls
    where
    checkBox checked value = do
      id <- fresh
      pure $ H.li_ [ H.input [ A.checked checked
                             , A.type_ "checkbox"
                             , A.id_ id
                             , A.name label
                             , A.value value
                             , E.onChecked (E.input (CheckBoxChanged label value))
                             ] []
                   , H.label [ A.for id ] [ H.text value ]
                   ]
  renderFormElement id label (DropDown (Literal ls) Nothing) = do
    pure $ renderDropDown id label ("" : ls) Nothing
  renderFormElement id label (DropDown (Literal ls) (Just (Literal sel))) = do
    pure $ renderDropDown id label ls (Just (lookupTextValue label sel))
  renderFormElement _ _ _ = pure $ unsupportedFormElement

  lookupTextValue :: String -> String -> String
  lookupTextValue key def =
    case M.lookup key m of
      Just (SingleValue _ val) -> val
      _ -> def

  lookupMultipleValues :: String -> [Boolean] -> [String] -> [Boolean]
  lookupMultipleValues key def ls =
    case M.lookup key m of
      Just (MultipleValues val) -> (`S.member` val) <$> ls
      _ -> def

  fresh :: Fresh String
  fresh = do
    n <- get :: Fresh Number
    modify (+ 1)
    pure (formName ++ "-" ++ show n)

renderTextInput :: forall f. (Alternative f) => String -> String -> TextBoxType -> String -> H.HTML (f SlamDownEvent)
renderTextInput id label t value =
  H.input [ A.type_ (textBoxTypeName t)
          , A.id_ id
          , A.name label
          , A.value value
          , E.onInput (E.input (TextChanged t label))
          ] []

renderDropDown :: forall f. (Alternative f) => String -> String -> [String] -> Maybe String -> H.HTML (f SlamDownEvent)
renderDropDown id label ls sel =
  H.select [ A.id_ id
           , A.name label
           , E.onValueChanged (E.input (TextChanged PlainText label))
           ]
           $ maybe option option' sel <$> ls
  where
  option :: String -> H.HTML (f SlamDownEvent)
  option value = H.option [ A.value value ] [ H.text value ]
  option' :: String -> String -> H.HTML (f SlamDownEvent)
  option' sel value = H.option [ A.selected (value == sel), A.value value ] [ H.text value ]

textBoxTypeName :: TextBoxType -> String
textBoxTypeName t = case t of
  PlainText -> "text"
  Date -> "date"
  Time -> "time"
  DateTime -> "datetime-local"

unsupportedFormElement :: forall a. H.HTML a
unsupportedFormElement = H.text "Unsupported form element"

-- | This module defines functions for rendering Markdown to HTML.

module Text.Markdown.SlamDown.Html
  ( SlamDownEvent()
  , SlamDownState(..)
  , FormFieldValue(..)
  , initSlamDownState
  , applySlamDownEvent
  , renderHalogen
  )
  where

import Control.Alternative (Alternative)
import Control.Monad.State (State(), evalState)
import Control.Monad.State.Class (get, modify)

import Data.Array (concat, zipWith, mapMaybe)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.String (joinWith)
import Data.Tuple (Tuple(..), zip)
import Data.Traversable (traverse, zipWithA)

import Text.Markdown.SlamDown

import qualified Data.Set as S
import qualified Data.StrMap as M
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E

data FormFieldValue
  = SingleValue TextBoxType String
  | MultipleValues (S.Set String)

instance showFormFieldValue :: Show FormFieldValue where
  show (SingleValue t s) = "(SingleValue " ++ show t ++ " " ++ show s ++ ")"
  show (MultipleValues ss) = "(MultipleValues " ++ show ss ++ ")"

-- | The state of a SlamDown form - a mapping from input keys to values
newtype SlamDownState = SlamDownState (M.StrMap FormFieldValue)

instance showSlamDownState :: Show SlamDownState where
  show (SlamDownState m) = "(SlamDownState " ++ show m ++ ")"

-- | The initial state of form, in which all fields use their default values
initSlamDownState :: SlamDown -> SlamDownState
initSlamDownState = SlamDownState <<< M.fromList <<< everything (const mempty) go
  where
  go :: Inline -> [Tuple String FormFieldValue]
  go (FormField label _ field) = maybe [] (\v -> [Tuple label v]) $ getValue field
  go _ = []

  getValue :: FormField -> Maybe FormFieldValue
  getValue (TextBox tbt (Just (Literal value))) = Just $ SingleValue tbt value
  getValue (CheckBoxes (Literal sels) (Literal vals)) = Just $ MultipleValues $ S.fromList $ chk `mapMaybe` zip sels vals
    where
    chk (Tuple true value) = Just value
    chk _ = Nothing
  getValue (RadioButtons (Literal value) _) = Just $ SingleValue PlainText value
  getValue (DropDown _ (Just (Literal value))) = Just $ SingleValue PlainText value
  getValue _ = Nothing

-- | The type of events which can be raised by SlamDown forms
data SlamDownEvent
  = TextChanged TextBoxType String String
  | CheckBoxChanged String String Boolean

-- | Apply a `SlamDownEvent` to a `SlamDownState`.
applySlamDownEvent :: SlamDownState -> SlamDownEvent -> SlamDownState
applySlamDownEvent (SlamDownState m) (TextChanged t key val) =
  SlamDownState (M.insert key (SingleValue t val) m)
applySlamDownEvent (SlamDownState m) (CheckBoxChanged key val checked) =
  SlamDownState (M.alter (Just <<< updateSet) key m)
  where
  updateSet :: Maybe FormFieldValue -> FormFieldValue
  updateSet (Just (MultipleValues s))
    | checked = MultipleValues (S.insert val s)
    | otherwise = MultipleValues (S.delete val s)
  updateSet _
    | checked = MultipleValues (S.singleton val)
    | otherwise = MultipleValues S.empty

type Fresh = State Number

-- | Render the SlamDown AST to an arbitrary Halogen HTML representation
renderHalogen :: forall f. (Alternative f) => String -> SlamDownState -> SlamDown -> [H.HTML (f SlamDownEvent)]
renderHalogen formName (SlamDownState m) (SlamDown bs) = evalState (traverse renderBlock bs) 1

  where

  renderBlock :: Block -> Fresh (H.HTML (f SlamDownEvent))
  renderBlock (Paragraph is) = H.p_ <$> traverse renderInline is
  renderBlock (Header level is) = h_ level <$> traverse renderInline is
    where
    h_ :: forall a. Number -> [H.HTML (f a)] -> H.HTML (f a)
    h_ 1 = H.h1_
    h_ 2 = H.h2_
    h_ 3 = H.h3_
    h_ 4 = H.h4_
    h_ 5 = H.h5_
    h_ 6 = H.h6_
  renderBlock (Blockquote bs) = H.blockquote_ <$> traverse renderBlock bs
  renderBlock (List lt bss) = el_ lt <$> traverse item bss
    where
    el_ :: forall a. ListType -> [H.HTML (f a)] -> H.HTML (f a)
    el_ (Bullet _)  = H.ul_
    el_ (Ordered _) = H.ol_
    item :: [Block] -> Fresh (H.HTML (f SlamDownEvent))
    item bs = H.li_ <$> traverse renderBlock bs
  renderBlock (CodeBlock _ ss) =
    pure $ H.pre_ [ H.code_ [ H.text (joinWith "\n" ss) ] ]
  renderBlock (LinkReference l url) =
    pure $ H.p_ [ H.text (l <> ": ")
                , H.a [ A.name l, A.id_ l, A.href url ] [ H.text url ]
                ]
  renderBlock Rule = pure $ H.hr_ []

  renderInline :: Inline -> Fresh (H.HTML (f SlamDownEvent))
  renderInline (Str s) = pure $ H.text s
  renderInline (Entity s) = pure $ H.text s
  renderInline Space = pure $ H.text " "
  renderInline SoftBreak = pure $ H.text "\n"
  renderInline LineBreak = pure $ H.br_ []
  renderInline (Emph is) = H.em_ <$> traverse renderInline is
  renderInline (Strong is) = H.strong_ <$> traverse renderInline is
  renderInline (Code _ c) = pure $ H.code_ [ H.text c ]
  renderInline (Link body tgt) = H.a [ A.href (href tgt) ] <$> traverse renderInline body
    where
    href (InlineLink url) = url
    href (ReferenceLink tgt) = maybe "" ("#" ++) tgt
  renderInline (Image body url) = H.img [ A.src url ] <$> traverse renderInline body
  renderInline (FormField label req el) = do
    id <- fresh
    el' <- renderFormElement id label el
    pure $ H.span_ $ [ H.label (if requiresId then [ A.for id ] else [])
                               [ H.text (label ++ requiredLabel) ]
                     , el'
                     ]
    where
    requiredLabel = if req then "*" else ""
    requiresId = case el of
      CheckBoxes _ _ -> false
      RadioButtons _ _ -> false
      _ -> true

  renderFormElement :: String -> String -> FormField -> Fresh (H.HTML (f SlamDownEvent))
  renderFormElement id label (TextBox t Nothing) =
    pure $ renderTextInput id label t (lookupTextValue label "")
  renderFormElement id label (TextBox t (Just (Literal value))) =
    pure $ renderTextInput id label t (lookupTextValue label value)
  renderFormElement _ label (RadioButtons (Literal def) (Literal ls)) =
    H.ul_ <$> traverse (\val -> radio (val == sel) val) (def : ls)
    where
    sel = lookupTextValue label def
    radio checked value = do
      id <- fresh
      pure $ H.li_ [ H.input [ A.checked checked
                             , A.type_ "radio"
                             , A.id_ id
                             , A.name label
                             , A.value value
                             , E.onChange (E.input_ (TextChanged PlainText label value))
                             ] []
                   , H.label [ A.for id ] [ H.text value ]
                   ]
  renderFormElement _ label (CheckBoxes (Literal bs) (Literal ls)) =
    H.ul_ <$> zipWithA checkBox (lookupMultipleValues label bs ls) ls
    where
    checkBox checked value = do
      id <- fresh
      pure $ H.li_ [ H.input [ A.checked checked
                             , A.type_ "checkbox"
                             , A.id_ id
                             , A.name label
                             , A.value value
                             , E.onChecked (E.input (CheckBoxChanged label value))
                             ] []
                   , H.label [ A.for id ] [ H.text value ]
                   ]
  renderFormElement id label (DropDown (Literal ls) Nothing) = do
    pure $ renderDropDown id label ("" : ls) Nothing
  renderFormElement id label (DropDown (Literal ls) (Just (Literal sel))) = do
    pure $ renderDropDown id label ls (Just (lookupTextValue label sel))
  renderFormElement _ _ _ = pure $ unsupportedFormElement

  lookupTextValue :: String -> String -> String
  lookupTextValue key def =
    case M.lookup key m of
      Just (SingleValue _ val) -> val
      _ -> def

  lookupMultipleValues :: String -> [Boolean] -> [String] -> [Boolean]
  lookupMultipleValues key def ls =
    case M.lookup key m of
      Just (MultipleValues val) -> (`S.member` val) <$> ls
      _ -> def

  fresh :: Fresh String
  fresh = do
    n <- get :: Fresh Number
    modify (+ 1)
    pure (formName ++ "-" ++ show n)

renderTextInput :: forall f. (Alternative f) => String -> String -> TextBoxType -> String -> H.HTML (f SlamDownEvent)
renderTextInput id label t value =
  H.input [ A.type_ (textBoxTypeName t)
          , A.id_ id
          , A.name label
          , A.value value
          , E.onInput (E.input (TextChanged t label))
          ] []

renderDropDown :: forall f. (Alternative f) => String -> String -> [String] -> Maybe String -> H.HTML (f SlamDownEvent)
renderDropDown id label ls sel =
  H.select [ A.id_ id
           , A.name label
           , E.onValueChanged (E.input (TextChanged PlainText label))
           ]
           $ maybe option option' sel <$> ls
  where
  option :: String -> H.HTML (f SlamDownEvent)
  option value = H.option [ A.value value ] [ H.text value ]
  option' :: String -> String -> H.HTML (f SlamDownEvent)
  option' sel value = H.option [ A.selected (value == sel), A.value value ] [ H.text value ]

textBoxTypeName :: TextBoxType -> String
textBoxTypeName t = case t of
  PlainText -> "text"
  Date -> "date"
  Time -> "time"
  DateTime -> "datetime-local"

unsupportedFormElement :: forall a. H.HTML a
unsupportedFormElement = H.text "Unsupported form element"


Match the text

Match the text

module Main where

import Data.Array (concatMap)

import Control.Monad (foldM)
import Control.Monad.Eff

import Graphics.Canvas hiding (translate)

lsystem :: forall a m s. (Monad m) =>
                         [a] ->
                         (a -> [a]) ->
		         (s -> a -> m s) ->
                         Number ->
		         s -> m s
lsystem init prod interpret n state = go init n
  where
  go s 0 = foldM interpret state s
  go s n = go (concatMap prod s) (n - 1)

data Alphabet = L | R | F

type Sentence = [Alphabet]

type State =
  { x :: Number
  , y :: Number
  , theta :: Number
  }

main = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  let
    initial :: Sentence
    initial = [F, R, R, F, R, R, F, R, R]

    productions :: Alphabet -> Sentence
    productions L = [L]
    productions R = [R]
    productions F = [F, L, F, R, R, F, L, F]

    render :: State -> Alphabet -> Eff (canvas :: Canvas) State
    render state L = return $ state { theta = state.theta - Math.pi / 3 }
    render state R = return $ state { theta = state.theta + Math.pi / 3 }
    render state F = do
      let x' = state.x + Math.cos state.theta * 1.5
          y' = state.y + Math.sin state.theta * 1.5
      moveTo ctx state.x state.y
      lineTo ctx x' y'
      return { x: x', y: y', theta: state.theta }

    initialState :: State
    initialState = { x: 120, y: 200, theta: 0 }

  setStrokeStyle "#000000" ctx

  strokePath ctx $ lsystem initial productions render 5 initialState

module Main where

import Data.Array (concatMap)

import Control.Monad (foldM)
import Control.Monad.Eff

import Graphics.Canvas hiding (translate)

lsystem :: forall a m s. (Monad m) =>
                         [a] ->
                         (a -> [a]) ->
		         (s -> a -> m s) ->
                         Number ->
		         s -> m s
lsystem init prod render n state = go init n
  where
  go s 0 = foldM render state s
  go s n = go (concatMap prod s) (n - 1)

data Alphabet = L | R | F

type Sentence = [Alphabet]

type State =
  { x :: Number
  , y :: Number
  , theta :: Number
  }

main = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas

  let
    initial :: Sentence
    initial = [F, R, R, F, R, R, F, R, R]

    productions :: Alphabet -> Sentence
    productions L = [L]
    productions R = [R]
    productions F = [F, L, F, R, R, F, L, F]

    render :: State -> Alphabet -> Eff (canvas :: Canvas) State
    render state L = return $ state { theta = state.theta - Math.pi / 3 }
    render state R = return $ state { theta = state.theta + Math.pi / 3 }
    render state F = do
      let x' = state.x + Math.cos state.theta * 1.5
          y' = state.y + Math.sin state.theta * 1.5
      moveTo ctx state.x state.y
      lineTo ctx x' y'
      return { x: x', y: y', theta: state.theta }

    initialState :: State
    initialState = { x: 120, y: 200, theta: 0 }

  setStrokeStyle "#000000" ctx

  strokePath ctx $ lsystem initial productions render 5 initialState


(almost) validate bed track data for genes

module Genetics.Browser.Track.Bed where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Monad.Aff (Aff, throwError)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Except (runExcept)
import Data.Argonaut (Json, JObject, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..), note)
import Data.Exists (Exists, mkExists)
import Data.Filterable (filtered)
import Data.Foldable (class Foldable)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Int as Int
import Data.Lens (re, to, view, (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.List.NonEmpty (NonEmptyList(..))
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.String as String
import Data.Traversable (traverse)
import Data.Validation.Semigroup (V, invalid)
import Data.Variant (inj)
import Genetics.Browser.Track.Backend (ChrCtx, DrawingV, Feature, LegendEntry, Renderer, Track(Track), VScale, _point, _range, featureInterval, groupToChrs, horPlace, mkIcon, trackLegend, verPlace)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), _ChrId)
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), _Segments, pairSize)
import Graphics.Drawing (circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Simple.JSON (read)
import Unsafe.Coerce (unsafeCoerce)

{- NB this deals with JSON that's currently specified to work with a
bespoke conversion of the gencode.bb genes file from biodalliance.org.
in other words, it is garbage

example converted line:

{"chrom":"chr1"
,"chromStart":"5083172"
,"chromEnd":"5162549"
,"name":"ENSMUST00000044369.7"
,"score":"1000"
,"strand":"+"
,"thickStart":"5084450"
,"thickEnd":"5162162"
,"itemRgb":"0,0,0"
,"blockCount":"14"
,"blockSizes":"106,147,103,90,114,105,54,98,193,179,126,102,114,445"
,"blockStarts":"0,1244,5836,10190,12442,14856,17897,34217,41104,49911,52639,60577,66775,78932"
,"geneId":"ENSMUSG00000033793.7"
,"geneName":"Atp6v1h"
,"type":"protein_coding"
,"tags":"basic,appris_principal,CCDS"}

-}

type BedChrom i c r = ( chromId :: i, chromStart :: c, chromEnd :: c | r )

type BedLineName r = ( lineName :: String | r )
-- a valid score is >= 0 and <= 1000
type BedScore r = ( score :: Int | r )

  -- bad type!!! strand is only one of three characters after all
type BedStrand r = ( strand :: String | r )

type BedThick c r = ( thickStart :: c, thickEnd :: c | r )

-- this is pretty bad too~~
type BedRGB r = ( itemRgb :: Array Int | r )

type BedBlocks c r = ( blockCount :: Int
                     , blockSizes :: Array c
                     , blockStarts :: Array c | r )

type BedGene r = ( geneId :: String
                 , geneName :: String | r )

type BedTranscript r = ( "type" :: String
                       , tags :: Array String | r )

type BedLine i c =
  Record
  (BedChrom i c
   (BedLineName
    (BedScore
     (BedStrand
      (BedThick c
       (BedRGB
        (BedBlocks c
         (BedGene
          (BedTranscript ())))))))))

type RawBedLine = BedLine String Int

type Validated = V (NonEmptyList String)

-- TODO this should compare to browser coord sys used
validChrId :: forall r.
              { chromId :: String | r }
           -> Validated { chromId :: ChrId  }
validChrId r = pure { chromId: wrap r.chromId }

validChrRange :: forall r.
                 { chromStart :: Int, chromEnd :: Int | r }
              -> Validated { chromStart :: BigInt, chromEnd :: BigInt }
validChrRange r
-- this is probably too strict.
  | r.chromStart > r.chromEnd = invalid $ pure "feature start > feature end"
  | otherwise = pure $ { chromStart: BigInt.fromInt r.chromStart
                       , chromEnd: BigInt.fromInt r.chromEnd }

validScore :: forall r.
              Record (BedScore r)
           -> Validated (Record (BedScore ()))
validScore { score } = pure { score }

validStrand :: forall r.
               Record (BedStrand r)
            -> Validated (Record (BedStrand ()))
validStrand { strand } = pure { strand }

-- this could be deduped w/ lens and/or sproxy
validThickRange :: forall r.
                 Record (BedThick Int r)
              -> Validated (Record (BedThick BigInt ()))
validThickRange r
  | r.thickStart > r.thickEnd = invalid $ pure "feature thick start > end"
  | otherwise = pure $ { thickStart: BigInt.fromInt r.thickStart
                       , thickEnd: BigInt.fromInt r.thickEnd }

validRGB :: forall r.
            { itemRgb :: Array Int | r }
         -> Validated { itemRgb :: Array Int  }
validRGB {itemRgb} = pure {itemRgb}

validBlocks :: forall r.
            Record (BedBlocks Int r)
         -> Validated (Record (BedBlocks BigInt ()))
validBlocks r = pure { blockCount: r.blockCount
                     , blockSizes: BigInt.fromInt  <$> r.blockSizes
                     , blockStarts: BigInt.fromInt <$> r.blockStarts }

validGene :: forall r.
             Record (BedGene r)
          -> Validated (Record (BedGene ()))
validGene {geneId, geneName} = pure {geneId, geneName}

validTranscript :: forall r.
                   Record (BedTranscript r)
                -> Validated (Record (BedTranscript ()))
validTranscript r = pure { "type": r."type", tags: r.tags }

validateBed :: Foreign -> Validated (Array (BedLine ChrId BigInt))
validateBed d =
  case (runExcept $ read d) :: Either MultipleErrors (Array RawBedLine) of
    Left err -> invalid $ map renderForeignError err
    Right ls ->
      let f :: _
          f l = { chromId:_, chromRange:_, name: _
                , score: _, thick: _, rgb: _
                , blocks: _, gene: _, transcript: _ }
              <$> validChrId l
              <*> validChrRange l
              <*> validScore l
              <*> validStrand l
              <*> validRGB l
              <*> validBlocks l
              <*> validGene l
              <*> validTranscript l
       in unsafeCoerce unit

error: pathspec 'src/Genetics/Browser/Track/Bed.purs' did not match any file(s) known to git


add test examples

add test examples

module Test.Main where

import Prelude
import Control.Monad.Eff.Console.Foreign
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console.Foreign (logF, infoF, warnF, errorF)
import Data.Foreign (toForeign, Foreign)
import Data.Foreign.Class (class AsForeign, write)

type MyRecord = { sval :: String, ival :: Int }

newtype MyNewtypeRecord = MyNewtypeRecord MyRecord

instance myNewtypeRecordAsForeign :: AsForeign MyNewtypeRecord where
  write = toForeign

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  -- example type with `AsForeign` instance
  let ex1 = MyNewtypeRecord { sval: "test newtype wrapped record", ival: 1 }
  logF ex1
  -- example vanilla `Record` using `toForeign`
  let ex2 = toForeign { sval: "test record", ival: 2 }
  logF ex2
  -- example `Array` of `AsForeign`
  logF [ "Array of words:", "a", "b", "c", "d"]

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


quickfix...

quickfix...

module Openspace.Ui.Stream where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import DOM
import Data.Either
import Data.Foreign
import Openspace.Engine
import Openspace.Network.Socket
import Openspace.Types
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Ui.Render
import Prelude
import Rx.Observable

foreign import setDrag :: forall eff. Eff eff Unit
foreign import unsetDrag :: forall eff. Eff eff Unit

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- socketObserver socket
  return $ actionFromForeign parseAction id <$> (parseMessage <$> onReceive)

dragStream :: forall eff. Eff( dom :: DOM| eff) (Observable Action)
dragStream = do
  lookup <- emitterLookup <$> getEmitters
  let dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left err -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

      dragOverTrash = const DeleteTopic <$> lookup "dragOverTrash"

      -- HTML 5 fires dragLeave before dragEnd occurs
      -- TODO: Find a cleaner solution
      dragLeave = delay 30 $ const UnassignTopic
                  <$> lookup "dragLeaveSlot" `merge` lookup "dragLeaveTrash"

      dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

      dragStart = parseTopic <<< getDetail
                  <$> lookup "dragStartTopic" `merge` lookup "dragStartGridTopic"
      dragEnd = lookup "dragEndTopic" `merge` lookup "dragEndGridTopic"

      {- rebindable "bind" does make this a lot easier -}
      dragTopic :: Observable Action
      dragTopic = do
        let bind = flatMapLatest
        t' <- dragStart
        case t' of
          Right t -> do
            action <- dragOver
            dragEnd
            return (action t)
          Left e -> return $ ShowError (show e)

  runObservable $ const setDrag <$> dragStart
  runObservable $ const unsetDrag <$> dragEnd

  return dragTopic

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  lookup <- emitterLookup <$> getEmitters
  let addTopic    = (actionFromForeign parseTopic AddTopic) <<< getDetail
                    <$> lookup "addTopic"
      addRoom     = (actionFromForeign parseRoom AddRoom) <<< getDetail
                    <$> lookup "addRoom"
      deleteRoom  = (actionFromForeign parseRoom DeleteRoom) <<< getDetail
                    <$> lookup "deleteRoom"
      addBlock    = (actionFromForeign parseBlock AddBlock) <<< getDetail
                    <$> lookup "addBlock"
      deleteBlock = (actionFromForeign parseBlock DeleteBlock) <<< getDetail
                    <$> lookup "deleteBlock"
      changeGrid = addRoom `merge` deleteRoom `merge` addBlock `merge` deleteBlock
  dragTopic <- dragStream
  return $ addTopic `merge` dragTopic `merge` changeGrid

main = do
  socketUrl <- getSocketUrl
  -- Uncomment for testing:
  let sockEmitter = getSocket ("ws://frost.kritzcreek.me/socket/0")
  -- Comment for testing:
  -- let sockEmitter = getSocket ("ws://" ++ socketUrl)

  -- Initial State
  appSt <- newSTRef emptyState
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp

  --Request Initial State
  emitRefresh sockEmitter

  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  subscribe ui (\a -> case a of
                   ShowError e -> log e
                   _ -> emitAction sockEmitter (serialize a))
  -- Evaluate Actions from the Server
  subscribe net (\a -> modifySTRef appSt (evalAction a) >>= renderApp)

module Openspace.Ui.Stream where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import DOM
import Data.Either
import Data.Foreign
import Openspace.Engine
import Openspace.Network.Socket
import Openspace.Types
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Ui.Render
import Prelude
import Rx.Observable

foreign import setDrag :: forall eff. Eff eff Unit
foreign import unsetDrag :: forall eff. Eff eff Unit

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- socketObserver socket
  return $ actionFromForeign parseAction id <$> (parseMessage <$> onReceive)

dragStream :: forall eff. Eff( dom :: DOM| eff) (Observable Action)
dragStream = do
  lookup <- emitterLookup <$> getEmitters
  let dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left err -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

      dragOverTrash = const DeleteTopic <$> lookup "dragOverTrash"

      -- HTML 5 fires dragLeave before dragEnd occurs
      -- TODO: Find a cleaner solution
      dragLeave = delay 30 $ const UnassignTopic
                  <$> lookup "dragLeaveSlot" `merge` lookup "dragLeaveTrash"

      dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

      dragStart = parseTopic <<< getDetail
                  <$> lookup "dragStartTopic" `merge` lookup "dragStartGridTopic"
      dragEnd = lookup "dragEndTopic" `merge` lookup "dragEndGridTopic"

      {- rebindable "bind" does make this a lot easier -}
      dragTopic :: Observable Action
      dragTopic = do
        let bind = flatMapLatest
        t' <- dragStart
        case t' of
          Right t -> do
            action <- dragOver
            dragEnd
            return (action t)
          Left e -> return $ ShowError (show e)

  runObservable $ const setDrag <$> dragStart
  runObservable $ const unsetDrag <$> dragEnd

  return $ dragTopic `merge` reRender

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  lookup <- emitterLookup <$> getEmitters
  let addTopic    = (actionFromForeign parseTopic AddTopic) <<< getDetail
                    <$> lookup "addTopic"
      addRoom     = (actionFromForeign parseRoom AddRoom) <<< getDetail
                    <$> lookup "addRoom"
      deleteRoom  = (actionFromForeign parseRoom DeleteRoom) <<< getDetail
                    <$> lookup "deleteRoom"
      addBlock    = (actionFromForeign parseBlock AddBlock) <<< getDetail
                    <$> lookup "addBlock"
      deleteBlock = (actionFromForeign parseBlock DeleteBlock) <<< getDetail
                    <$> lookup "deleteBlock"
      changeGrid = addRoom `merge` deleteRoom `merge` addBlock `merge` deleteBlock
  dragTopic <- dragStream
  return $ addTopic `merge` dragTopic `merge` changeGrid

main = do
  socketUrl <- getSocketUrl
  -- Uncomment for testing:
  let sockEmitter = getSocket ("ws://frost.kritzcreek.me/socket/0")
  -- Comment for testing:
  -- let sockEmitter = getSocket ("ws://" ++ socketUrl)

  -- Initial State
  appSt <- newSTRef emptyState
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp

  --Request Initial State
  emitRefresh sockEmitter

  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  subscribe ui (\a -> case a of
                   ShowError e -> log e
                   _ -> emitAction sockEmitter (serialize a))
  -- Evaluate Actions from the Server
  subscribe net (\a -> modifySTRef appSt (evalAction a) >>= renderApp)


add Request.UpdateStampRally

add Request.UpdateStampRally

module Request.UpdateStampRally (updateStampRally) where

import Control.Monad.Aff (Aff)
import Data.GetStampRallyResponse (GetStampRallyResponse(..))
import Data.Options ((:=))
import Data.StrMap (fromFoldable) as StrMap
import Data.Tuple (Tuple(..))
import Fetch (HTTP, fetch)
import Fetch.Options (Method(..), body, headers, method, url) as FetchOptions
import Prelude (Unit, ($), (<>), (<$>), const, show, unit)

body :: GetStampRallyResponse -> String
body (GetStampRallyResponse { description
                            , display
                            , displayEndDatetime
                            , displayName
                            , displayStartDatetime
                            , endDatetime
                            , mapVisible
                            , open
                            , spotRadiusDefault
                            , spotStampByLocationDefault
                            , spotStampByQrCodeDefault
                            , startDatetime
                            , tagline
                            , themeBackgroundPattern
                            , themeRewardPattern
                            , themeSpotPattern
                            }) =
  "{"
  <> " " <> show "time_zone" <> ":" <> show "+09:00" <> ","
  <> " " <> show "view_type" <> ":" <> show "admin" <> ","
  <> " " <> show "description" <> ":" <> show description <> ","
  -- TODO: details
  <> " " <> show "display" <> ":" <> show display <> ","
  <> " " <> show "display_end_datetime" <> ":" <> show displayEndDatetime <> ","
  <> " " <> show "display_name" <> ":" <> show displayName <> ","
  <> " " <> show "display_start_datetime" <> ":" <> show displayStartDatetime <> ","
  <> " " <> show "end_datetime" <> ":" <> show endDatetime <> ","
  -- TODO: images
  <> " " <> show "map_visible" <> ":" <> show mapVisible <> ","
  <> " " <> show "open" <> ":" <> show open <> ","
  <> " " <> show "spot_radius_default" <> ":" <> show spotRadiusDefault <> ","
  <> " " <> show "spot_stamp_by_location_default" <> ":" <> show spotStampByLocationDefault <> ","
  <> " " <> show "spot_stamp_by_qr_code_default" <> ":" <> show spotStampByQrCodeDefault <> ","
  <> " " <> show "start_datetime" <> ":" <> show startDatetime <> ","
  <> " " <> show "tagline" <> ":" <> show tagline <> ","
  <> " " <> show "theme_background_pattern" <> ":" <> show themeBackgroundPattern <> ","
  <> " " <> show "theme_reward_pattern" <> ":" <> show themeRewardPattern <> ","
  <> " " <> show "theme_spot_pattern" <> ":" <> show themeSpotPattern
  <> " }"

url :: String -> String
url stampRallyId = "https://api.rallyapp.jp/stamp_rallies/" <> stampRallyId

updateStampRally
  :: forall eff
   . String
  -> GetStampRallyResponse
  -> String
  -> Aff ( http :: HTTP
         | eff
         ) Unit
updateStampRally stampRallyId stampRally token = const unit <$> fetch options
  where
    headers = StrMap.fromFoldable [ Tuple "Content-Type" "application/json"
                                  , Tuple "User-Agent" "rally-cli"
                                  , Tuple "Authorization" $ "Token token=\"" <> token <> "\""
                                  ]
    options = FetchOptions.method := FetchOptions.PATCH
              <> FetchOptions.url := (url stampRallyId)
              <> FetchOptions.headers := headers
              <> FetchOptions.body := (body stampRally)

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


Implement mocha's spec reporter

Implement mocha's spec reporter

module Test.Spec.Reporter.Spec (specReporter) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (Error(), message)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State (StateT, execStateT, evalStateT)
import Control.Monad.State as State
import Data.Foldable (intercalate, traverse_)
import Data.Traversable (for)
import Data.Map (toList)
import Data.Array ((:), reverse)
import Data.Array as Array
import Data.String as String
import Data.Tuple (Tuple(Tuple))
import Data.Tuple.Nested ((/\))
import Test.Spec (Group, Result(..))
import Test.Spec as S
import Test.Spec.Console (withAttrs)
import Test.Spec.Reporter (collapseAll, EntryPath, Entry(..), Reporter)
import Test.Spec.Summary (Summary(..), summarize)

type NamedFailure = Tuple String Error
type ReporterState = { failures :: Array NamedFailure }

red   = withAttrs [31]
green = withAttrs [32]
blue  = withAttrs [33]

specReporter :: forall e. Reporter (console :: CONSOLE | e)
specReporter groups = do
  { failures } <- flip execStateT { failures: [] } $ printGroups 0 [] groups
  log ""
  printSummary groups
  log ""
  printFailures $ reverse failures

  where
  printGroups :: forall r. Int
                  -> Array String
                  -> Array (Group Result)
                  -> StateT ReporterState (Eff (console :: CONSOLE | r)) Unit
  printGroups i crumbs groups = do
    void $ for groups case _ of
      S.Describe n xs -> do
        logPlain n
        printGroups (i + 1) (n : crumbs) xs
      S.Pending n -> logBlue $ "- " <> n
      S.It n result ->
        case result of
          Success -> logGreen $ "✓ " <> n
          Failure err ->
            let label = intercalate " " (reverse $ n : crumbs)
             in do
              State.modify \s -> s { failures = (label /\ err) : s.failures }
              nFailures <- Array.length <<< _.failures <$> State.get
              logRed $ show nFailures <> ") " <> n

    where
    _log msg = log $ indent i <> msg
    logRed   = lift <<< red   <<< _log
    logGreen = lift <<< green <<< _log
    logBlue  = lift <<< red   <<< _log
    logPlain = lift           <<< _log

  printFailures :: forall r. Array NamedFailure
                  -> Eff (console :: CONSOLE | r) Unit
  printFailures failures = void $ flip evalStateT 1 do
    for failures \(n /\ err) -> do
      i <- State.get
      lift $ log $ show i <> ") " <> n
      lift $ red $ log $ indent 2 <> message err
      State.modify $ const $ i + 1

  indent :: Int -> String
  indent i = String.fromCharArray (Array.replicate i ' ')

  printSummary :: forall r. Array (Group Result)
                  -> Eff (console :: CONSOLE | r) Unit
  printSummary = summarize >>> \(Count passed failed pending) -> do
    when (passed  > 0) $ green $ log $ show passed  <> " passing"
    when (pending > 0) $ blue  $ log $ show pending <> " pending"
    when (failed  > 0) $ red   $ log $ show failed  <> " failed"

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


Add Cont monad

Add Cont monad

-- | This module defines the `Cont`inuation monad.

module Control.Monad.Cont
  ( Cont
  , cont
  , runCont
  , module X
  ) where

import Prelude

import Control.Monad.Cont.Trans (ContT(ContT), mapContT, runContT, withContT)
import Control.Monad.Cont.Class (callCC) as X
import Data.Identity (Identity(Identity), runIdentity)

-- | The `Cont` monad is a synonym for the `ContT` monad transformer applied to
-- | the `Identity` monad.
type Cont r a = ContT r Identity a

-- | Creates a computation in the `Cont` monad.
cont :: forall a r. ((a -> r) -> r) -> Cont r a
cont f = ContT (\c -> Identity (f (runIdentity <<< c)))

-- | Runs a computation in the `Cont` monad.
runCont :: forall r a. ContT r Identity a -> (a -> r) -> r
runCont cc k = runIdentity (runContT cc (Identity <<< k))

-- | Transform the result of a continuation-passing function.
mapCont :: forall r a. (r -> r) -> Cont r a -> Cont r a
mapCont f = mapContT (Identity <<< f <<< runIdentity)

-- | Transform the continuation passed into the continuation-passing function.
withCont :: forall a b r. ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b
withCont f = withContT (compose Identity <<< f <<< compose runIdentity)

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


Only listen on socket if we are a baby station

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 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 (fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (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.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Lenses (currentFamily, onlineStatus, authData)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (makeChannelId, BabyStation, 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
                 }

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 baby constraints)            -> handleStartBabyStation baby constraints
  (InitBabyStation baby stream)                  -> onlineStatus .= Just { babyName : baby, mediaStream : stream }
                                                    *> 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.
                          String
                       -> MediaStreamConstraints
                       -> ComponentType (Props ps) State Action
handleStartBabyStation baby constraints =
  runGonimo $
    InitBabyStation baby <$> 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 BabyStation)
  let action = case state.onlineStatus of
        Nothing -> []
        Just station -> [ toIO props.settings <<< liftEff $ do
                             stopStream station.mediaStream
                             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 :: State -> Html Action
-- view state =
--   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 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 (fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (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.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Lenses (currentFamily, onlineStatus, authData)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (makeChannelId, BabyStation, 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
                 }

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 baby constraints)            -> handleStartBabyStation baby constraints
  (InitBabyStation baby stream)                  -> onlineStatus .= Just { babyName : baby, mediaStream : stream }
                                                    *> 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.
                          String
                       -> MediaStreamConstraints
                       -> ComponentType (Props ps) State Action
handleStartBabyStation baby constraints =
  runGonimo $
    InitBabyStation baby <$> 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 BabyStation)
  let action = case state.onlineStatus of
        Nothing -> []
        Just station -> [ toIO props.settings <<< liftEff $ do
                             stopStream station.mediaStream
                             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

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 ))
        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 (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
                                       }