Add missing semicolon

Add missing semicolon

module Data.Int
  ( Int()
  , fromNumber
  , toNumber
  ) where

newtype Int = Int Number

-- | Creates an `Int` from a `Number` value. If the value is not already an
-- | integer it is rounded down.
foreign import fromNumber
  """
  function fromNumber(n) {
    return n|0;
  }
  """ :: Number -> Int

toNumber :: Int -> Number
toNumber (Int n) = n

instance showInt :: Show Int where
  show (Int n) = "fromNumber " ++ show n

instance eqInt :: Eq Int where
  (==) (Int x) (Int y) = x == y
  (/=) (Int x) (Int y) = x /= y

instance ordInt :: Ord Int where
  compare (Int x) (Int y) = compare x y

instance semiringInt :: Semiring Int where
  (+) = intAdd
  zero = Int 0
  (*) = intMul
  one = Int 1

instance moduloSemiringInt :: ModuloSemiring Int where
  (/) = intDiv
  mod = intMod

instance ringInt :: Ring Int where
  (-) = intMinus

instance bitsInt :: Bits Int where
  (.&.) (Int x) (Int y) = Int (x .&. y)
  (.|.) (Int x) (Int y) = Int (x .|. y)
  (.^.) (Int x) (Int y) = Int (x .^. y)
  shl (Int x) y = Int (x `shl` y)
  shr (Int x) y = Int (x `shr` y)
  zshr (Int x) y = Int (x `zshr` y)
  complement (Int n) = Int (complement n)

foreign import intAdd
  """
  function intAdd(x) {
    return function(y) {
      return x + y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMul
  """
  function intMul(x) {
    return function(y) {
      return x * y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intDiv
  """
  function intDiv(x) {
    return function(y) {
      return (x / y)|0;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMod
  """
  function intDiv(x) {
    return function(y) {
      return (x % y + y) % y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMinus
  """
  function intDiv(x) {
    return function(y) {
      return x - y;
    };
  }
  """ :: Int -> Int -> Int

module Data.Int
  ( Int()
  , fromNumber
  , toNumber
  ) where

newtype Int = Int Number

-- | Creates an `Int` from a `Number` value. If the value is not already an
-- | integer it is rounded down.
foreign import fromNumber
  """
  function fromNumber(n) {
    return n|0
  }
  """ :: Number -> Int

toNumber :: Int -> Number
toNumber (Int n) = n

instance showInt :: Show Int where
  show (Int n) = "fromNumber " ++ show n

instance eqInt :: Eq Int where
  (==) (Int x) (Int y) = x == y
  (/=) (Int x) (Int y) = x /= y

instance ordInt :: Ord Int where
  compare (Int x) (Int y) = compare x y

instance semiringInt :: Semiring Int where
  (+) = intAdd
  zero = Int 0
  (*) = intMul
  one = Int 1

instance moduloSemiringInt :: ModuloSemiring Int where
  (/) = intDiv
  mod = intMod

instance ringInt :: Ring Int where
  (-) = intMinus

instance bitsInt :: Bits Int where
  (.&.) (Int x) (Int y) = Int (x .&. y)
  (.|.) (Int x) (Int y) = Int (x .|. y)
  (.^.) (Int x) (Int y) = Int (x .^. y)
  shl (Int x) y = Int (x `shl` y)
  shr (Int x) y = Int (x `shr` y)
  zshr (Int x) y = Int (x `zshr` y)
  complement (Int n) = Int (complement n)

foreign import intAdd
  """
  function intAdd(x) {
    return function(y) {
      return x + y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMul
  """
  function intMul(x) {
    return function(y) {
      return x * y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intDiv
  """
  function intDiv(x) {
    return function(y) {
      return (x / y)|0;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMod
  """
  function intDiv(x) {
    return function(y) {
      return (x % y + y) % y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMinus
  """
  function intDiv(x) {
    return function(y) {
      return x - y;
    };
  }
  """ :: Int -> Int -> Int


Language.PureScript.Optimizer.Common

Language.PureScript.Optimizer.Common

module Language.PureScript.Optimizer.Common where

import Data.Foldable (foldl, lookup, elem, any)
import Data.Maybe (fromMaybe)
import Data.Tuple
import Language.PureScript.Errors
import Language.PureScript.CodeGen.JS.AST

applyAll :: forall a. [a -> a] -> a -> a
applyAll (f : fs) = foldl (<<<) f fs

replaceIdent :: String -> JS -> JS -> JS
replaceIdent var1 js = everywhereOnJS replace
  where
  replace (JSVar var2) | var1 == var2 = js
  replace other = other

replaceIdents :: [Tuple String JS] -> JS -> JS
replaceIdents vars = everywhereOnJS replace
  where
  replace v@(JSVar var) = fromMaybe v $ lookup var vars
  replace other = other

isReassigned :: String -> JS -> Boolean
isReassigned var1 = everythingOnJS (||) check
  where
  check :: JS -> Boolean
  check (JSFunction _ args _) | var1 `elem` args = true
  check (JSVariableIntroduction arg _) | var1 == arg = true
  check (JSAssignment (JSVar arg) _) | var1 == arg = true
  check (JSFor arg _ _ _) | var1 == arg = true
  check (JSForIn arg _ _) | var1 == arg = true
  check _ = false

isRebound :: JS -> JS -> Boolean
isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)
  where
  variablesOf (JSVar var) = [var]
  variablesOf _ = []

isUsed :: String -> JS -> Boolean
isUsed var1 = everythingOnJS (||) check
  where
  check :: JS -> Boolean
  check (JSVar var2) | var1 == var2 = true
  check (JSAssignment target _) | var1 == targetVariable target = true
  check _ = false

targetVariable :: JS -> String
targetVariable (JSVar var) = var
targetVariable (JSAccessor _ tgt) = targetVariable tgt
targetVariable (JSIndexer _ tgt) = targetVariable tgt
targetVariable _ = theImpossibleHappened "Invalid argument to targetVariable"

isUpdated :: String -> JS -> Boolean
isUpdated var1 = everythingOnJS (||) check
  where
  check :: JS -> Boolean
  check (JSAssignment target _) | var1 == targetVariable target = true
  check _ = false

removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
removeFromBlock go (JSBlock sts) = JSBlock (go sts)
removeFromBlock _  js = js

error: pathspec 'src/Language/PureScript/Optimizer/Common.purs' did not match any file(s) known to git


whoops

whoops

module Openspace.Types where

import           Data.Either
import           Data.Foreign
import           Data.Foreign.Class
import           Data.Foreign.Index
import qualified Data.Map as M
import           Data.Maybe
import           Data.Tuple

-----------------
--| TopicType |--
-----------------

data TopicType = Discussion
               | Presentation
               | Workshop

instance eqTopicType :: Eq TopicType where
(==) tt1 tt2 = show tt1 == show tt2
(/=) tt1 tt2 = show tt1 /= show tt2

instance showTopicType :: Show TopicType where
  show Discussion = "Discussion"
  show Presentation = "Presentation"
  show Workshop = "Workshop"

instance foreignTopicType :: IsForeign TopicType where
  read val = case readString val of
    Right "Discussion"   -> Right Discussion
    Right "Presentation" -> Right Presentation
    Right "Workshop"     -> Right Workshop
    _                    -> Left $ JSONError "Cant read TopicType"

-- Used to fill Dropdowns etc.
topicTypes = [Discussion, Presentation, Workshop]

--------------
--| Topics |--
--------------

newtype Topic = Topic { description :: String
                      , typ   :: TopicType }

instance eqTopic :: Eq Topic where
  (==) (Topic t1) (Topic t2) = t1.description == t2.description && t1.typ == t2.typ
  (/=) t1 t2 = not (t1 == t2)

instance foreignTopic :: IsForeign Topic where
  read val = Topic <$> (
    { description: _, typ: _ } <$>
    readProp "description" val <*>
    readProp "typ" val
    )

------------
--| Slot |--
------------

newtype Slot = Slot { room :: Room, block :: Block }

instance eqSlot :: Eq Slot where
  (==) (Slot s1) (Slot s2) = s1.room == s2.room && s1.block == s2.block
  (/=) (Slot s1) (Slot s2) = s1.room /= s2.room || s1.block /= s2.block

instance ordSlot :: Ord Slot where
  compare (Slot s1) (Slot s2) =
    (show s1.room ++ show s1.block) `compare` (show s2.room ++ show s2.block)

instance showSlot :: Show Slot where
  show (Slot s) = "{ room: " ++ show s.room ++" block: " ++ show s.block ++ "}"

instance foreignSlot :: IsForeign Slot where
  read val = Slot <$> (
    { room: _, block: _} <$>
    readProp "room" val  <*>
    readProp "block" val
    )

------------
--| Room |--
------------

newtype Room = Room { name :: String, capacity :: Number }

instance showRoom :: Show Room where
  show (Room r) = r.name

instance eqRoom :: Eq Room where
  (==) (Room r1) (Room r2) = r1.name == r2.name
  (/=) (Room r1) (Room r2) = r1.name /= r2.name

instance foreignRoom :: IsForeign Room where
  read val = Room <$> (
    { name: _, capacity: _} <$>
    readProp "name" val     <*>
    readProp "capacity" val
    )

-------------
--| Block |--
-------------

newtype Block = Block { description :: String
                      , startHours :: Number
                      , startMinutes :: Number
                      , endHours :: Number
                      , endMinutes :: Number}

instance showBlock :: Show Block where
  show (Block b) = b.description

instance eqBlock :: Eq Block where
  (==) (Block b1) (Block b2) = b1.description == b2.description
                               && b1.startHours == b2.startHours
                               && b1.startMinutes == b2.startMinutes
                               && b1.endHours == b2.endHours
                               && b1.endMinutes == b2.endMinutes

  (/=) b1 b2 = not (b1 == b2)

instance ordBlock :: Ord Block where
  compare (Block b1) (Block b2) = compare (hourDiff * 60 + minDiff) 0
    where hourDiff = b1.startHours - b2.startHours
          minDiff = b1.startMinutes - b2.startMinutes

instance foreignBlock :: IsForeign Block where
  read val = Block <$> (
    { description: _
    , startHours: _
    , startMinutes: _
    , endHours: _
    , endMinutes: _
    } <$>
    readProp "description" val <*>
    readProp "startHours" val <*>
    readProp "startMinutes" val <*>
    readProp "endHours" val <*>
    readProp "endMinutes" val
    )

---------------
--| Actions |--
---------------

data Action = AddTopic Topic
            | DeleteTopic Topic
            | AddRoom Room
            | DeleteRoom Room
            | AddBlock Block
            | DeleteBlock Block
            | AssignTopic Slot Topic
            | UnassignTopic Topic
            | ReplayActions [Action]
            | ShowError String
            | NOP

instance foreignAction :: IsForeign Action where
read val = case readProp "tag" val of
  Right "AddTopic" -> AddTopic <$> readProp "contents" val
  Right "DeleteTopic" -> DeleteTopic <$> readProp "contents" val
  Right "AddRoom" -> AddRoom <$> readProp "contents" val
  Right "DeleteRoom" -> DeleteRoom <$> readProp "contents" val
  Right "AddBlock" -> AddBlock <$> readProp "contents" val
  Right "DeleteBlock" -> DeleteBlock <$> readProp "contents" val
  Right "AssignTopic" -> let val' = parseAssignTopic val
                         in AssignTopic <$> readProp "slot" val' <*> readProp "topic" val'
  Right "UnassignTopic" -> UnassignTopic <$> readProp "contents" val
  Right "ReplayEvents" -> ReplayActions <$> readProp "contents" val
  Right "ShowError" -> ShowError <$> readProp "message" val
  Left e -> Right $ ShowError (show e)

class AsForeign a where
  serialize :: a -> Foreign

instance actionAsForeign :: AsForeign Action where
  serialize (AddTopic (Topic t)) =
    toForeign { tag: "AddTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }

  serialize (DeleteTopic (Topic t)) =
    toForeign { tag: "DeleteTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }
  serialize (AddRoom (Room r)) =
    toForeign { tag: "AddRoom"
              , contents: r }

  serialize (DeleteRoom (Room r)) =
    toForeign { tag: "DeleteRoom"
              , contents: r }

  serialize (AddBlock (Block b)) =
    toForeign { tag: "AddBlock"
              , contents: b }

  serialize (DeleteBlock (Block b)) =
    toForeign { tag: "DeleteBlock"
              , contents: b }

  serialize (AssignTopic s t) = serializeAssignTopic s t
  serialize (UnassignTopic (Topic t)) =
    toForeign { tag: "UnassignTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }

foreign import parseAssignTopic
"""
function parseAssignTopic(foreign) {
  return {
    topic : foreign.contents[1],
    slot : foreign.contents[0]
    }
  }
  """ :: Foreign -> Foreign

foreign import serializeAssignTopic
"""
function serializeAssignTopic(slot) {
  return function(topic){
    return { tag: "AssignTopic",
             contents:[
               slot,
               {
                 description: topic.description
                 , typ: Prelude.show(showTopicType)(topic.typ)
               }
             ]
           }
  }
}
""" :: Slot -> Topic -> Foreign

-------------------------
--| Entire AppState |--
-------------------------

type Timeslot = Tuple Slot Topic

type AppState = { topics :: [Topic]
                , rooms :: [Room]
                , blocks :: [Block]
                , timeslots :: M.Map Slot Topic
                }

 --------------------
 --| Dummy Values |--
 --------------------

emptyState = {topics: [], rooms:[], blocks:[], timeslots: (M.empty) :: M.Map Slot Topic }

myRoom = Room {name: "Berlin", capacity: 100}
myRoom1 = Room {name: "Hamburg", capacity: 80}
myRoom2 = Room {name: "Koeln", capacity: 30}

myBlock = Block {
  description:"First",
  startHours: 8,
  startMinutes: 0,
  endHours: 10,
  endMinutes: 0}
myBlock1 = Block {
  description:"Second",
  startHours: 8,
  startMinutes: 0,
  endHours: 10,
  endMinutes: 0}

mySlot = Slot {room:myRoom, block:myBlock}
mySlot1 = Slot {room:myRoom1, block:myBlock1}

myTopic = Topic  {description:"Purescript is great", typ:Workshop}
myTopic1 = Topic {description:"Reactive Design", typ:Presentation}
myTopic2 = Topic {description:"Functional Javascript", typ:Discussion}
myTopic3 = Topic {description:"Enemy of the State", typ:Presentation}
myTopic4 = Topic {description:"Wayyyyyyy too long name for a Topic.", typ:Workshop}
myTopic5 = Topic {description:"fix", typ:Discussion}

myState1 = { topics: [myTopic, myTopic1, myTopic2, myTopic3, myTopic4, myTopic5]
           , rooms : [myRoom, myRoom1, myRoom2]
           , blocks : [myBlock, myBlock1]
           , timeslots: M.fromList [Tuple mySlot myTopic, Tuple mySlot1 myTopic1]
           }

module Openspace.Types where

import           Data.Either
import           Data.Foreign
import           Data.Foreign.Class
import           Data.Foreign.Index
import qualified Data.Map as M
import           Data.Maybe
import           Data.Tuple

-----------------
--| TopicType |--
-----------------

data TopicType = Discussion
               | Presentation
               | Workshop

instance eqTopicType :: Eq TopicType where
(==) tt1 tt2 = show tt1 == show tt2
(/=) tt1 tt2 = show tt1 /= show tt2

instance showTopicType :: Show TopicType where
  show Discussion = "Discussion"
  show Presentation = "Presentation"
  show Workshop = "Workshop"

instance foreignTopicType :: IsForeign TopicType where
  read val = case readString val of
    Right "Discussion"   -> Right Discussion
    Right "Presentation" -> Right Presentation
    Right "Workshop"     -> Right Workshop
    _                    -> Left $ JSONError "Cant read TopicType"

-- Used to fill Dropdowns etc.
topicTypes = [Discussion, Presentation, Workshop]

--------------
--| Topics |--
--------------

newtype Topic = Topic { description :: String
                      , typ   :: TopicType }

instance eqTopic :: Eq Topic where
  (==) (Topic t1) (Topic t2) = t1.description == t2.description && t1.typ == t2.typ
  (/=) t1 t2 = not (t1 == t2)

instance foreignTopic :: IsForeign Topic where
  read val = Topic <$> (
    { description: _, typ: _ } <$>
    readProp "description" val <*>
    readProp "typ" val
    )

------------
--| Slot |--
------------

newtype Slot = Slot { room :: Room, block :: Block }

instance eqSlot :: Eq Slot where
  (==) (Slot s1) (Slot s2) = s1.room == s2.room && s1.block == s2.block
  (/=) (Slot s1) (Slot s2) = s1.room /= s2.room || s1.block /= s2.block

instance ordSlot :: Ord Slot where
  compare (Slot s1) (Slot s2) =
    (show s1.room ++ show s1.block) `compare` (show s2.room ++ show s2.block)

instance showSlot :: Show Slot where
  show (Slot s) = "{ room: " ++ show s.room ++" block: " ++ show s.block ++ "}"

instance foreignSlot :: IsForeign Slot where
  read val = Slot <$> (
    { room: _, block: _} <$>
    readProp "room" val  <*>
    readProp "block" val
    )

------------
--| Room |--
------------

newtype Room = Room { name :: String, capacity :: Number }

instance showRoom :: Show Room where
  show (Room r) = r.name

instance eqRoom :: Eq Room where
  (==) (Room r1) (Room r2) = r1.name == r2.name
  (/=) (Room r1) (Room r2) = r1.name /= r2.name

instance foreignRoom :: IsForeign Room where
  read val = Room <$> (
    { name: _, capacity: _} <$>
    readProp "name" val     <*>
    readProp "capacity" val
    )

-------------
--| Block |--
-------------

newtype Block = Block { description :: String
                      , startHours :: Number
                      , startMinutes :: Number
                      , endHours :: Number
                      , endMinutes :: Number}

instance showBlock :: Show Block where
  show (Block b) = b.description

instance eqBlock :: Eq Block where
  (==) (Block b1) (Block b2) = b1.description == b2.description
                               && b1.startHours == b2.startHours
                               && b1.startMinutes == b2.startMinutes
                               && b1.endHours == b2.endHours
                               && b1.endMinutes == b2.endMinutes

  (/=) b1 b2 = not (b1 == b2)

instance ordBlock :: Ord Block where
  compare (Block b1) (Block b2) = compare (hourDiff * 60 + minDiff) 0
    where hourDiff = b1.startHours - b2.startHours
          minDiff = b1.startMinutes - b2.startMinutes

instance foreignBlock :: IsForeign Block where
  read val = Block <$> (
    { description: _
    , startHours: _
    , startMinutes: _
    , endHours: _
    , endMinutes: _
    } <$>
    readProp "description" val <*>
    readProp "startHours" val <*>
    readProp "startMinutes" val <*>
    readProp "endHours" val <*>
    readProp "endMinutes" val
    )

---------------
--| Actions |--
---------------

data Action = AddTopic Topic
            | DeleteTopic Topic
            | AddRoom Room
            | DeleteRoom Room
            | AddBlock Block
            | DeleteBlock Block
            | AssignTopic Slot Topic
            | UnassignTopic Topic
            | ReplayActions [Action]
            | ShowError String
            | NOP

instance foreignAction :: IsForeign Action where
read val = case readProp "tag" val of
  Right "AddTopic" -> AddTopic <$> readProp "contents" val
  Right "DeleteTopic" -> DeleteTopic <$> readProp "contents" val
  Right "AddRoom" -> AddRoom <$> readProp "contents" val
  Right "DeleteRoom" -> DeleteRoom <$> readProp "contents" val
  Right "AddBlock" -> AddBlock <$> readProp "contents" val
  Right "DeleteBlock" -> DeleteBlock <$> readProp "contents" val
  Right "AssignTopic" -> let val' = parseAssignTopic val
                         in AssignTopic <$> readProp "slot" val <*> readProp "topic" val
  Right "UnassignTopic" -> UnassignTopic <$> readProp "contents" val
  Right "ReplayEvents" -> ReplayActions <$> readProp "contents" val
  Right "ShowError" -> ShowError <$> readProp "message" val
  Left e -> Right $ ShowError (show e)

class AsForeign a where
  serialize :: a -> Foreign

instance actionAsForeign :: AsForeign Action where
  serialize (AddTopic (Topic t)) =
    toForeign { tag: "AddTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }

  serialize (DeleteTopic (Topic t)) =
    toForeign { tag: "DeleteTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }
  serialize (AddRoom (Room r)) =
    toForeign { tag: "AddRoom"
              , contents: r }

  serialize (DeleteRoom (Room r)) =
    toForeign { tag: "DeleteRoom"
              , contents: r }

  serialize (AddBlock (Block b)) =
    toForeign { tag: "AddBlock"
              , contents: b }

  serialize (DeleteBlock (Block b)) =
    toForeign { tag: "DeleteBlock"
              , contents: b }

  serialize (AssignTopic s t) = serializeAssignTopic s t
  serialize (UnassignTopic (Topic t)) =
    toForeign { tag: "UnassignTopic"
              , contents: { description: t.description
                          , typ: show t.typ
                          }
              }

foreign import parseAssignTopic
"""
function parseAssignTopic(foreign) {
  return {
    topic : foreign.contents[1],
    slot : foreign.contents[0]
    }
  }
  """ :: Foreign -> Foreign

foreign import serializeAssignTopic
"""
function serializeAssignTopic(slot) {
  return function(topic){
    return { tag: "AssignTopic",
             contents:[
               slot,
               {
                 description: topic.description
                 , typ: Prelude.show(showTopicType)(topic.typ)
               }
             ]
           }
  }
}
""" :: Slot -> Topic -> Foreign

-------------------------
--| Entire AppState |--
-------------------------

type Timeslot = Tuple Slot Topic

type AppState = { topics :: [Topic]
                , rooms :: [Room]
                , blocks :: [Block]
                , timeslots :: M.Map Slot Topic
                }

 --------------------
 --| Dummy Values |--
 --------------------

emptyState = {topics: [], rooms:[], blocks:[], timeslots: (M.empty) :: M.Map Slot Topic }

myRoom = Room {name: "Berlin", capacity: 100}
myRoom1 = Room {name: "Hamburg", capacity: 80}
myRoom2 = Room {name: "Koeln", capacity: 30}

myBlock = Block {
  description:"First",
  startHours: 8,
  startMinutes: 0,
  endHours: 10,
  endMinutes: 0}
myBlock1 = Block {
  description:"Second",
  startHours: 8,
  startMinutes: 0,
  endHours: 10,
  endMinutes: 0}

mySlot = Slot {room:myRoom, block:myBlock}
mySlot1 = Slot {room:myRoom1, block:myBlock1}

myTopic = Topic  {description:"Purescript is great", typ:Workshop}
myTopic1 = Topic {description:"Reactive Design", typ:Presentation}
myTopic2 = Topic {description:"Functional Javascript", typ:Discussion}
myTopic3 = Topic {description:"Enemy of the State", typ:Presentation}
myTopic4 = Topic {description:"Wayyyyyyy too long name for a Topic.", typ:Workshop}
myTopic5 = Topic {description:"fix", typ:Discussion}

myState1 = { topics: [myTopic, myTopic1, myTopic2, myTopic3, myTopic4, myTopic5]
           , rooms : [myRoom, myRoom1, myRoom2]
           , blocks : [myBlock, myBlock1]
           , timeslots: M.fromList [Tuple mySlot myTopic, Tuple mySlot1 myTopic1]
           }


Add Graphics.SVG module

Add Graphics.SVG module

module Graphics.SVG where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.State (get, put)
import Control.Monad.State.Trans (StateT)
import Control.Monad.Writer (Writer, tell)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document)
import DOM.Node.Document as Document
import DOM.Node.Element as Element
import DOM.Node.Node (appendChild)
import DOM.Node.Types (Element, elementToNode)
import Data.Array (uncons)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..))
import Data.Nullable (toNullable)
import Data.Traversable (intercalate, traverse_)
import Data.Tuple (Tuple(..))

createElementSVG :: ∀ eff. String -> Eff (dom :: DOM | eff) Element
createElementSVG tag = do
  win <- window
  doc <- document win
  Document.createElementNS
    (toNullable $ Just "http://www.w3.org/2000/svg")
    tag
    (htmlDocumentToDocument doc)

type Attribute = Tuple String String

setAttributes :: ∀ eff. Array Attribute -> Element -> Eff (dom :: DOM | eff) Unit
setAttributes attrs ele = traverse_ (\ (Tuple n v) -> Element.setAttribute n v ele) attrs

data SVGElement = SVGElement String (Array Attribute)

data SVGPathOp = SVGPathMoveTo Number Number
               | SVGPathLineTo Number Number
               | SVGPathClose

derive instance eqSVGPathOp :: Eq SVGPathOp

instance showSVGPathOp :: Show SVGPathOp where
  show (SVGPathMoveTo x y) = "M " <> show x <> " " <> show y
  show (SVGPathLineTo x y) = "L " <> show x <> " " <> show y
  show SVGPathClose = "Z"

renderSVGElement :: ∀ eff. SVGElement -> Eff (dom :: DOM | eff) Element
renderSVGElement (SVGElement tag as) = do
  ele <- createElementSVG tag
  setAttributes as ele
  pure ele

renderSVG :: ∀ eff. Array SVGElement -> Eff (dom :: DOM | eff) Element
renderSVG as = do
  win <- window
  doc <- document win
  root <- createElementSVG "g"
  let parent = elementToNode root
  traverse_ (\ svgEle -> do
                rendered <- renderSVGElement svgEle
                appendChild (elementToNode rendered) parent) as
  pure root

derive instance genericSVGElement :: Generic SVGElement _
derive instance eqSVGElement :: Eq SVGElement
instance showSVGElement :: Show SVGElement where
  show x = genericShow x

type SVGTransform = { translate :: { x :: Number, y :: Number }
                    , scale :: { x :: Number, y :: Number}
                    }

showTransform :: SVGTransform -> String
showTransform t = "translate(" <> show t.translate.x <> "," <> show t.translate.y <> ") " <>
                  "scale(" <> show t.scale.x <> "," <> show t.scale.y <> ")"

type SVGContext = { stroke :: String
                  , fill :: String
                  , strokeWidth :: Number
                  , transform :: SVGTransform
                  }

type SVG a = StateT SVGContext (Writer (Array SVGElement)) a

svgToAttribs :: SVGContext -> Array Attribute
svgToAttribs svg = [ Tuple "fill" svg.fill
                   , Tuple "stroke" svg.stroke
                   , Tuple "strokeWidth" (show svg.strokeWidth <> "px")
                   , Tuple "transform" (showTransform svg.transform)
                   ]

initialSVG :: SVGContext
initialSVG = { stroke: "none"
             , fill: "none"
             , strokeWidth: 1.0
             , transform: { translate: { x: 0.0, y: 0.0 }
                          , scale: { x: 1.0, y: 1.0 }
                          }
             }

setStrokeStyle :: String -> SVG Unit
setStrokeStyle color = do
  cur <- get
  let cur' = cur { stroke = color }
  put cur'

setFillStyle :: String ->  SVG Unit
setFillStyle color = do
  cur <- get
  let cur' = cur { fill = color }
  put cur'

-- TODO use Point instead...

circle :: Number -> Number -> Number
       -> SVG Unit
circle x y r = do
  cur <- get
  let circle' = [ Tuple "cx" (show x)
                , Tuple "cy" (show y)
                , Tuple "r" (show r)
                ] <> svgToAttribs cur
  tell [SVGElement "circle" circle']

line ::  Number -> Number -> Number -> Number
     -> SVG Unit
line x1 y1 x2 y2 = path [ {x:x1, y:y1}, {x:x2, y:y2} ]

path :: Array { x :: Number, y :: Number }
     -> SVG Unit
path ps = do
  case uncons ps of
    Nothing -> pure unit
    Just { head, tail } -> do
      cur <- get
      let fst = [ SVGPathMoveTo head.x head.y
                ]
          rest = (\p -> SVGPathLineTo p.x p.y) <$> ps
          path' = intercalate " " $ show <$> fst <> rest <> [SVGPathClose]
          attribs = [ Tuple "d" path' ] <> svgToAttribs cur
      tell [SVGElement "path" attribs]

rect :: Number -> Number -> Number -> Number
     -> SVG Unit
rect x1 y1 x2 y2 = do
  cur <- get
  let rect' = [ Tuple "x" (show x1)
              , Tuple "y" (show y1)
              , Tuple "width" (show (x2 - x1))
              , Tuple "height" (show (y2 - y1))
              ] <> svgToAttribs cur
  tell [SVGElement "rect" rect']

translate :: Number -> Number
          -> SVG Unit
translate x y = do
  cur <- get
  let t = cur.transform.translate
      t' = t { x = t.x + x, y = t.y + y }
      new = cur { transform = ( cur.transform { translate = t })}
  put new

scale :: Number -> Number
      -> SVG Unit
scale x y = do
  cur <- get
  let s = cur.transform.scale
      s' = s { x = s.x * x, y = s.y * y }
      new = cur { transform = ( cur.transform { scale = s })}
  put new

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


Stripped off the type signatures of the functions in the tests.

Updating them was becoming too much of a pain.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/gcross/habit-of-fate.git/'


Sketch some swift

Sketch some swift

Original commit 5b8a03325b2cbe356b7c12713820a45ba97eeffa

module Swift where

import Prelude

import Data.Foldable (foldMap)
import Data.Maybe (Maybe(..), fromMaybe)

data SType =
    Struct
    { name :: Maybe String
    , fields :: Array TValue
    }

data TPrim = TString | TInt | TArray TPrim | TExtern String

type TValue = { name :: String, typ :: TPrim }

render :: SType -> String
render (Struct { name, fields }) =
    """struct """ <> fromMaybe "MyStruct" name <> """
    {
    """ <>
    foldMap renderValue fields <>
    """
    }"""

renderValue :: TValue -> String
renderValue { name, typ } = "let " <> name <> ": " <> renderTPrim typ

renderTPrim :: TPrim -> String
renderTPrim TString = "string"
renderTPrim TInt = "int"
renderTPrim (TArray typ) = "[" <> renderTPrim typ <> "]"
renderTPrim (TExtern name) = name

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


added HelloWorldServer.purs as example

added HelloWorldServer.purs as example

module HelloWorldServer where

import Prelude hiding (apply)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Node.Express.App (App, listenHttp, get)
import Node.Express.Response (send)
import Node.Express.Types (EXPRESS)
import Node.HTTP (Server)

app :: forall e. App (console :: CONSOLE | e)
app = get "/" $ send "Hello, World!"

main :: forall e. Eff (express :: EXPRESS, console :: CONSOLE | e) Server
main = do
    listenHttp app 8080 \_ ->
        log $ "Listening on " <> show 8080

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


5.9.3

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/mikemcgowan/purescript-book.git/'


5.5.2


Rename to .purs

Rename to .purs

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/aspidites/purescript-node-readline.git/'


Add Reader

Add Reader

module Control.Monad.Run.Reader
  ( Reader(..)
  , READER
  , _READER
  , liftReader
  , ask
  , local
  , runReader
  ) where

import Prelude
import Control.Monad.Run (Run, REffect, RProxy(..), liftEffect, peel, send, decomp)
import Data.Either (Either(..))

newtype Reader e a = Reader (e → a)

derive newtype instance functorReader ∷ Functor (Reader e)

type READER e = REffect (Reader e)

_READER ∷ ∀ e. RProxy "reader" (Reader e)
_READER = RProxy

liftReader ∷ ∀ e a r. Reader e a → Run (reader ∷ READER e | r) a
liftReader = liftEffect _READER

ask ∷ ∀ e r. Run (reader ∷ READER e | r) e
ask = liftReader (Reader id)

local ∷ ∀ e a r. (e → e) → Run (reader ∷ READER e | r) a → Run (reader ∷ READER e | r) a
local = \f r → map f ask >>= flip runLocal r
  where
  handle = decomp _READER
  runLocal = loop
    where
    loop e r = case peel r of
      Left a → case handle a of
        Left a' →
          send a >>= runLocal e
        Right (Reader k) →
          loop e (k e)
      Right a →
        pure a

runReader ∷ ∀ e a r. e → Run (reader ∷ READER e | r) a → Run r a
runReader = loop
  where
  handle = decomp _READER
  loop e r = case peel r of
    Left a → case handle a of
      Left a' →
        send a' >>= runReader e
      Right (Reader k) →
        loop e (k e)
    Right a →
      pure a

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


Trigger alarm if remote stream ends

Trigger alarm if remote stream ends

Seems to never happen - but let's see.

module Gonimo.UI.Socket.Channel where

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

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ { urls : [ "turn:gonimo.com:3478" ]
                                                                  , username : "gonimo"
                                                                  , credential : "Aeloh5chai2eil1" -- FIXME: For production this obviously should not be hardcoded.
                                                                  , credentialType : "password"
                                                                  }
                                                                ]
                                                 }
                           )
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ boostVolumeMediaStream origStream
  connState <- liftEff $ iceConnectionState rtcConnection
  let isBabyStation = isJust stream
  alarm' <- if isBabyStation -- We only need alarm at the parent side
            then pure Nothing
            else map Just <<< liftAff $ loadSound "/sounds/pup_alert.mp3"
  Gonimo.log "Got alarm!"
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isBabyStation
          , messageQueue  : Nil
          , messagesInFlight : 0
          , audioStats : initStreamConnectionStats
          , videoStats : initStreamConnectionStats
          , vibrator   : Nothing
          , alarm : alarm'
          , alarmIsOn : false
          }

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

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

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

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

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

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

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

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

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

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

    maybeRegister :: Props ps -> (Maybe Int -> Action) -> Maybe MediaStreamTrack -> RTCPeerConnection -> IO Unit
    maybeRegister _ _ Nothing _ = pure unit
    maybeRegister props mkAction mTrack@(Just track) pc = do
      let eventHandler = coerceEffects <<< props.sendAction <<< mkAction
      liftEff $ onConnectionDrop eventHandler mTrack pc
      liftEff $ addEventListener "ended" (const (eventHandler Nothing)) track
      liftEff $ addEventListener "ended" (const (Console.log "Track ended")) track

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

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

handleTurnOnAlarm :: forall ps. Boolean -> ComponentType (Props ps) State Action
handleTurnOnAlarm onOff = do
  state <- get :: Component (Props ps) State State
  let old = state.alarmIsOn
  modify $ _ { alarmIsOn = onOff }
  let actions =
        if onOff
        then [ do
                  liftEff $ traverse_ playSound state.alarm
                  pure Nop
            ]
        else [ do
                  liftEff $ traverse_ stopSound state.alarm
                  pure Nop
            ]
  if old /= onOff
    then pure actions
    else pure []

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

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

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

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

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

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

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

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

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

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

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

    errorView = H.div [ A.className "brokenConnectionOverlay" ]
                [ H.h2 [] [ H.text brokenText ]
                , H.p []
                  [
                    H.text "Please reconnect or check on your baby!"
                  ]
                ]
  in
   if audioBroken || videoBroken
   then errorView
   else H.div [] []

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

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

module Gonimo.UI.Socket.Channel where

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

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ { urls : [ "turn:gonimo.com:3478" ]
                                                                  , username : "gonimo"
                                                                  , credential : "Aeloh5chai2eil1" -- FIXME: For production this obviously should not be hardcoded.
                                                                  , credentialType : "password"
                                                                  }
                                                                ]
                                                 }
                           )
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ boostVolumeMediaStream origStream
  connState <- liftEff $ iceConnectionState rtcConnection
  let isBabyStation = isJust stream
  alarm' <- if isBabyStation -- We only need alarm at the parent side
            then pure Nothing
            else map Just <<< liftAff $ loadSound "/sounds/pup_alert.mp3"
  Gonimo.log "Got alarm!"
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isBabyStation
          , messageQueue  : Nil
          , messagesInFlight : 0
          , audioStats : initStreamConnectionStats
          , videoStats : initStreamConnectionStats
          , vibrator   : Nothing
          , alarm : alarm'
          , alarmIsOn : false
          }

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

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

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

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

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

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

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

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

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

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

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

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

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

handleTurnOnAlarm :: forall ps. Boolean -> ComponentType (Props ps) State Action
handleTurnOnAlarm onOff = do
  state <- get :: Component (Props ps) State State
  let old = state.alarmIsOn
  modify $ _ { alarmIsOn = onOff }
  let actions =
        if onOff
        then [ do
                  liftEff $ traverse_ playSound state.alarm
                  pure Nop
            ]
        else [ do
                  liftEff $ traverse_ stopSound state.alarm
                  pure Nop
            ]
  if old /= onOff
    then pure actions
    else pure []

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

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

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

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

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

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

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

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

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

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

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

    errorView = H.div [ A.className "brokenConnectionOverlay" ]
                [ H.h2 [] [ H.text brokenText ]
                , H.p []
                  [
                    H.text "Please reconnect or check on your baby!"
                  ]
                ]
  in
   if audioBroken || videoBroken
   then errorView
   else H.div [] []

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

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


Going to switch approach for divideAllEfforts() to use mapWithKey().

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/0dB/cats-utils.git/'


add Request.CreateStampRallyDetail

add Request.CreateStampRallyDetail

module Request.CreateStampRallyDetail (createStampRallyDetail) 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 Fetch (HTTP, fetch)
import Fetch.Options (Method(..), body, headers, method, url) as FetchOptions
import Prelude (($), (<>), (<<<), bind, show)
import Request.Helper.P (p, ps)
import Request.Helper.Headers (headers)

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

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

createStampRallyDetail
  :: forall eff
   . String
  -> Detail
  -> String
  -> Aff ( http :: HTTP
         | eff
         ) Detail
createStampRallyDetail stampRallyId detail token = do
  text <- fetch options
  let f = readJSON text :: F Detail
  makeAff (\ng ok -> either (ng <<< error <<< show) ok $ runExcept f)
  where
    options = FetchOptions.method := FetchOptions.POST
              <> FetchOptions.url := (url stampRallyId)
              <> FetchOptions.headers := (headers token)
              <> FetchOptions.body := (body detail)

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


new state ui

new state ui

module Model.App.New where

import Prelude (class Functor, class Applicative)
import Data.Either(Either(..))
import Data.Maybe(Maybe(..))
import Optic.Core
import Model.Presentation.New as P

type AppR = {
  _presentation :: Either P.PresentationError P.Presentation
}
newtype App = App AppR

-- prism :: forall f p s t a b. Applicative f => Choice p =>
--   (b -> t) -> (s -> Either t a) -> p a (f b) -> p s (f t)

-- prism' :: forall s a b.
--   (b -> s) -> (s -> Maybe a) -> Prism s s a b

_right :: forall l r. Prism' (Either l r) r
_right = prism' bs' sMa'
  where bs' = Right
        sMa' (Right a) = Just a
        sMa' (Left _) = Nothing

_left :: forall l r. Prism' (Either l r) l
_left = prism' bs' sMa'
  where bs' = Left
        sMa' (Left a) = Just a
        sMa' (Right _) = Nothing

presentation' :: Lens' App (Either P.PresentationError P.Presentation)
presentation' = lens get' set'
  where get' (App {_presentation} ) = _presentation
        set' (App r) p = App (r {_presentation = p})

-- presentation :: forall p.
--   Functor p
--   => Applicative p
--   => (String -> p String) -> App -> p App
presentation ::
  forall p. Functor p
  => Applicative p
  => (P.Presentation -> p P.Presentation) -> App -> p App
presentation = presentation' .. _right

presentationError :: forall
  p. Functor p
  => Applicative p
  => (P.PresentationError -> p P.PresentationError) -> App -> p App
presentationError = presentation' .. _left

-- initial :: App
-- initial = { presentation: P.initial }

-- presentation :: App -> P.Presentation
-- presentation = _.presentation

-- presentation' :: Lens' App P.Presentation
-- presentation' = lens  _.presentation  (\s p -> s { presentation = p } )

error: pathspec 'src/model/State.1.purs' did not match any file(s) known to git


Operator sections test

Operator sections test

module Main where

foreign import eqeqeq
  """
  function eqeqeq(x) {
    return function (y) {
      if (x == y) return x;
      throw new Error("Unexpected result: " + x + " /== " + y);
    };
  };
  """ :: forall a. a -> a -> a

(===) = eqeqeq
infixl 4 ===

main = do
  Debug.Trace.print $ (/ 2) 4 === 2
  Debug.Trace.print $ (2 /) 4 === 0.5
  Debug.Trace.print $ (`const` 1) 2 === 2
  Debug.Trace.print $ (1 `const`) 2 === 1
  Debug.Trace.trace "Done!"

error: pathspec 'examples/passing/OperatorSections.purs' did not match any file(s) known to git