Remove body for empty objects

Remove body for empty objects

Original commit 71909da31001c8ca8c6881511a0c2ebddd89d21d

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_, null)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

keywords :: Array String
keywords =
    [ "associatedtype", "class", "deinit", "enum", "extension", "fileprivate", "func", "import", "init", "inout", "internal", "let", "open", "operator", "private", "protocol", "public", "static", "struct", "subscript", "typealias", "var"
    , "break", "case", "continue", "default", "defer", "do", "else", "fallthrough", "for", "guard", "if", "in", "repeat", "return", "switch", "where", "while"
    , "as", "Any", "catch", "false", "is", "nil", "rethrows", "super", "self", "Self", "throw", "throws", "true", "try"
    , "_"
    , "associativity", "convenience", "dynamic", "didSet", "final", "get", "infix", "indirect", "lazy", "left", "mutating", "nonmutating", "optional", "override", "postfix", "precedence", "prefix", "Protocol", "required", "right", "set", "Type", "unowned", "weak", "willSet"
    , "String", "Int", "Double", "Bool", "Data", "CommandLine", "FileHandle", "JSONSerialization"
    , "checkNull", "removeNSNull", "nilToNSNull", "convertArray", "convertOptional", "convertDict", "convertDouble"
    ]

renderer :: Renderer
renderer =
    { name: "Swift"
    , aceMode: "swift"
    , extension: "swift"
    , doc: swiftDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: keywords
        , topLevelName: forbidNamer (swiftNameStyle true) (\n -> [swiftNameStyle true n])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (swiftNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (swiftNameStyle true) "Or")
            }
        }
    }

swiftNameStyle :: Boolean -> String -> String
swiftNameStyle isUpper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter isUpper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c = c == '_' || (isAlphaNum c && not (isDigit c))

        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = swiftNameStyle true $ combineNames names

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            ['\\', 'u', '{'] <> intToHex 0 i <> ['}']

swiftDoc :: Doc Unit
swiftDoc = do
    line "// To parse the JSON, add this file to your project and do:"
    line "//"
    forEachTopLevel_ \topLevelName topLevelType -> do
        typ <- renderType topLevelType
        line $ "//   let " <> decapitalize topLevelName <> " = " <> topLevelName <> "(fromString: jsonString)!"
    blank
    line "import Foundation"

    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        top <- renderType topLevelType
        line $ "typealias "<> topLevelName <> " = " <> top

    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions

    forEachClass_ \className properties -> do
        blank
        renderClassExtension className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionExtension unionName unionTypes

    blank
    supportFunctions

supportFunctions :: Doc Unit
supportFunctions = do
    line """// Helpers

fileprivate func convertArray<T>(_ converter: (Any) -> T?, _ json: Any) -> [T]? {
    guard let jsonArr = json as? [Any] else { return nil }
    var arr = [T]()
    for v in jsonArr {
        if let converted = converter(v) {
            arr.append(converted)
        } else {
            return nil
        }
    }
    return arr
}

fileprivate func convertOptional<T>(_ converter: (Any) -> T?, _ json: Any?) -> T?? {
    guard let v = json else { return .some(nil) }
    return converter(v)
}

fileprivate func convertDict<T>(_ converter: (Any) -> T?, _ json: Any?) -> [String: T]? {
    guard let jsonDict = json as? [String: Any] else { return nil }
    var dict = [String: T]()
    for (k, v) in jsonDict {
        if let converted = converter(v) {
            dict[k] = converted
        } else {
            return nil
        }
    }
    return dict
}

fileprivate func convertToAny<T>(_ dictionary: [String: T], _ converter: (T) -> Any) -> Any {
    var result = [String: Any]()
    for (k, v) in dictionary {
        result[k] = converter(v)
    }
    return result
}

fileprivate func convertDouble(_ v: Any) -> Double? {
    if let w = v as? Double { return w }
    if let w = v as? Int { return Double(w) }
    return nil
}

fileprivate let falseType = NSNumber(value: false).objCType
fileprivate let trueNumber = NSNumber(value: true)
fileprivate let trueType = trueNumber.objCType

fileprivate func convertBool(_ v: Any?) -> Bool? {
    guard let number = v as? NSNumber
    else {
        if let b = v as? Bool {
            return b
        }
        return nil
    }

    if number.objCType != falseType && number.objCType != trueType {
        return nil
    }
    return number.isEqual(trueNumber)
}

fileprivate func removeNSNull(_ v: Any?) -> Any? {
    if let w = v {
        if w is NSNull {
            return nil
        }
        return w
    }
    return nil
}

fileprivate func checkNull(_ v: Any?) -> Any?? {
    if v != nil { return .none }
    return .some(nil)
}"""

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromSet $ unionToSet ur of
    Just r -> do
        rendered <- renderType r
        pure $ rendered <> "?"
    Nothing -> lookupUnionName ur

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any?"
    IRNull -> pure "Any?"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion ur

convertAny :: IRType -> String -> Doc String
convertAny (IRArray a) var = do
    converter <- convertAnyFunc a
    pure $ "convertArray(" <> converter <> ", " <> var <> ")"
convertAny (IRMap m) var = do
    converter <- convertAnyFunc m
    pure $ "convertDict(" <> converter <> ", " <> var <> ")"
convertAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(" <> converter <> ", " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRNothing var =
    pure var
convertAny IRBool var =
    pure $ "convertBool(" <> var <> ")"
convertAny IRInteger var =
    pure $ var <> " as? Int"
convertAny IRString var =
    pure $ var <> " as? String"
convertAny t var = do
    converter <- convertAnyFunc t
    pure $ converter <> "(" <> var <> ")"

convertAnyFunc :: IRType -> Doc String
convertAnyFunc = case _ of
    IRClass i -> do
        name <- lookupClassName i
        -- TODO make this look less alien
        pure $ "{ " <> name <> "(fromAny: $0) }"
    IRUnion ur ->
        case nullableFromSet $ unionToSet ur of
        Just t -> do
            converter <- convertAnyFunc t
            pure $ "{ (json: Any) in convertOptional(" <> converter <> ", json) }"
        Nothing -> do
            name <- lookupUnionName ur
            pure $ name <> ".fromJson"
    IRDouble -> pure "convertDouble"
    IRNull -> pure "checkNull"
    t -> do
        converted <- convertAny t "$0"
        pure $ "{ " <> converted <> " }"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    convertCode <- convertToAny a "$0"
    pure $ var <> ".map({ " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    convertCode <- convertToAny m "$0"
    pure $ "convertToAny(" <> var <> ", { "<> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".any"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        convertCode <- convertToAny t "$0"
        pure $ var <> ".map({ " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".any"
convertToAny IRNothing var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull() as Any"
convertToAny _ var =
    pure $ var <> " as Any"

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    let forbidden = keywords <> ["json", "any"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "struct " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType ptype
            line $ "let " <> fieldName <> ": " <> rendered
    line "}"

renderTopLevelExtensions :: String -> IRType -> Doc Unit
renderTopLevelExtensions topLevelName topLevelType = do
    blank

    topLevelRendered <- renderType topLevelType
    extensionType <- case topLevelType of
        IRArray t -> ("Array where Element == " <> _) <$> renderType t
        IRMap t -> ("Dictionary where Key == String, Value == " <> _) <$> renderType t
        _ -> pure topLevelRendered

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "init?(fromString json: String, using encoding: String.Encoding = .utf8) {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line "self.init(fromData: data)"
        line "}"
        blank
        line $ "init?(fromData data: Data) {"
        indent do
            line "guard let json = try? JSONSerialization.jsonObject(with: data, options: []) else { return nil }"
            line "self.init(fromAny: json)"
        line "}"

        case topLevelType of
            IRArray _ ->  do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init(elements)"
                line "}"
            IRMap _ -> do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init()"
                    line $ "elements.forEach { self[$0.key] = $0.value }"
                line "}"
            _ -> pure unit

        blank
        line $ "var jsonData: Data? {"
        indent do
            convertCode <- convertToAny topLevelType "self"
            line $ "let json = " <> convertCode
            line "return try? JSONSerialization.data(withJSONObject: json, options: [])"
        line "}"

        blank
        line $ "var jsonString: String? {"
        indent do
            line $ "guard let data = self.jsonData else { return nil }"
            line $ "return String(data: data, encoding: .utf8)"
        line "}"

    line "}"

renderClassExtension :: String -> Map String IRType -> Doc Unit
renderClassExtension className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "extension " <> className <> " {"
    indent do
        line $ "fileprivate init?(fromAny any: Any) {"
        unless (M.isEmpty properties) $ indent do
            line "guard let json = any as? [String: Any] else { return nil }"
            let forbiddenForUntyped = forbidden <> (A.fromFoldable $ M.keys propertyNames)
            let untypedNames = makePropertyNames properties "Any" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            forEachProperty_ properties untypedNames \pname ptype untypedName _ -> do
                when (canBeNull ptype) do
                    line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"])"
            line "guard"
            indent do
                forEachProperty_ properties untypedNames \pname ptype untypedName isLast -> do
                    let convertedName = lookupName pname propertyNames
                    unless (canBeNull ptype) do
                        line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"]),"
                    convertCode <- convertAny ptype untypedName
                    line $ "let " <> convertedName <> " = " <> convertCode <> (if isLast then "" else ",")
                line "else { return nil }"
            forEachProperty_ properties propertyNames \pname _ fieldName _ -> do
                let convertedName = lookupName pname propertyNames
                line $ "self." <> fieldName <> " = " <> convertedName
        line "}"
        blank
        line "fileprivate var any: Any {"
        indent do
            if null properties
                then line "return [String: Any]()"
                else do
                    line "return ["
                    indent do
                        forEachProperty_ properties propertyNames \pname ptype fieldName _ -> do
                            convertCode <- convertToAny ptype ("self." <> fieldName)
                            line $ "\"" <> stringEscape pname <> "\": " <> convertCode <> ","
                    line "]"
        line "}"
    line "}"

forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> String -> Boolean -> Doc Unit) -> Doc Unit
forEachProperty_ properties propertyNames f =
    let propertyArray = M.toUnfoldable properties :: Array _
        lastIndex = A.length propertyArray - 1
    in
        forWithIndex_ propertyArray \i (Tuple pname ptype) -> do
            let fieldName = lookupName pname propertyNames
            f pname ptype fieldName (i == lastIndex)

makePropertyNames :: Map String IRType -> String -> Array String -> Map String String
makePropertyNames properties suffix forbidden =
    transformPropertyNames (fieldNamer suffix) otherField forbidden properties
    where
        fieldNamer :: String -> Namer String
        fieldNamer suffix = simpleNamer \name -> swiftNameStyle false name <> suffix

        otherField :: String -> String
        otherField name = "other" <> capitalize name

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "enum " <> unionName <> " {"
    indent do
        for_ nonNullTypes \typ -> do
            name <- caseName typ
            rendered <- renderType typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        case emptyOrNull of
            Just t -> do
                name <- caseName t
                line $ "case " <> name
            Nothing -> pure unit
    line "}"

renderUnionExtension :: String -> Set IRType -> Doc Unit
renderUnionExtension unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "extension " <> unionName <> " {"
    indent do
        line $ "fileprivate static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            case emptyOrNull of
                Just t -> do
                    name <- caseName t
                    line "guard let v = removeNSNull(v)"
                    line "else {"
                    indent do
                        line $ "return ." <> name
                    line "}"
                Nothing -> pure unit
            when (S.member IRBool unionTypes) do
                renderCase IRBool
            when (S.member IRInteger unionTypes) do
                renderCase IRInteger
            for_ (S.difference nonNullTypes $ S.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "fileprivate var any: Any {"
        indent do
            line $ "switch self {"
            for_ unionTypes \typ -> do
                name <- caseName typ
                let letString = if typ == IRNull then "" else "(let x)"
                convertCode <- convertToAny typ "x"
                line $ "case ." <> name <> letString <> ": return " <> convertCode
            line "}"
        line "}"
    line "}"
    where
    renderCase :: IRType -> Doc Unit
    renderCase t = do
        convertCode <- convertAny t "v"
        name <- caseName t
        line $ "if let x = " <> convertCode <> " { return ." <> name <> "(x) }"

caseName :: IRType -> Doc String
caseName t = swiftNameStyle false <$> getTypeNameForUnion t

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_, null)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

keywords :: Array String
keywords =
    [ "associatedtype", "class", "deinit", "enum", "extension", "fileprivate", "func", "import", "init", "inout", "internal", "let", "open", "operator", "private", "protocol", "public", "static", "struct", "subscript", "typealias", "var"
    , "break", "case", "continue", "default", "defer", "do", "else", "fallthrough", "for", "guard", "if", "in", "repeat", "return", "switch", "where", "while"
    , "as", "Any", "catch", "false", "is", "nil", "rethrows", "super", "self", "Self", "throw", "throws", "true", "try"
    , "_"
    , "associativity", "convenience", "dynamic", "didSet", "final", "get", "infix", "indirect", "lazy", "left", "mutating", "nonmutating", "optional", "override", "postfix", "precedence", "prefix", "Protocol", "required", "right", "set", "Type", "unowned", "weak", "willSet"
    , "String", "Int", "Double", "Bool", "Data", "CommandLine", "FileHandle", "JSONSerialization"
    , "checkNull", "removeNSNull", "nilToNSNull", "convertArray", "convertOptional", "convertDict", "convertDouble"
    ]

renderer :: Renderer
renderer =
    { name: "Swift"
    , aceMode: "swift"
    , extension: "swift"
    , doc: swiftDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: keywords
        , topLevelName: forbidNamer (swiftNameStyle true) (\n -> [swiftNameStyle true n])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (swiftNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (swiftNameStyle true) "Or")
            }
        }
    }

swiftNameStyle :: Boolean -> String -> String
swiftNameStyle isUpper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter isUpper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c = c == '_' || (isAlphaNum c && not (isDigit c))

        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = swiftNameStyle true $ combineNames names

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            ['\\', 'u', '{'] <> intToHex 0 i <> ['}']

swiftDoc :: Doc Unit
swiftDoc = do
    line "// To parse the JSON, add this file to your project and do:"
    line "//"
    forEachTopLevel_ \topLevelName topLevelType -> do
        typ <- renderType topLevelType
        line $ "//   let " <> decapitalize topLevelName <> " = " <> topLevelName <> "(fromString: jsonString)!"
    blank
    line "import Foundation"

    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        top <- renderType topLevelType
        line $ "typealias "<> topLevelName <> " = " <> top

    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions

    forEachClass_ \className properties -> do
        blank
        renderClassExtension className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionExtension unionName unionTypes

    blank
    supportFunctions

supportFunctions :: Doc Unit
supportFunctions = do
    line """// Helpers

fileprivate func convertArray<T>(_ converter: (Any) -> T?, _ json: Any) -> [T]? {
    guard let jsonArr = json as? [Any] else { return nil }
    var arr = [T]()
    for v in jsonArr {
        if let converted = converter(v) {
            arr.append(converted)
        } else {
            return nil
        }
    }
    return arr
}

fileprivate func convertOptional<T>(_ converter: (Any) -> T?, _ json: Any?) -> T?? {
    guard let v = json else { return .some(nil) }
    return converter(v)
}

fileprivate func convertDict<T>(_ converter: (Any) -> T?, _ json: Any?) -> [String: T]? {
    guard let jsonDict = json as? [String: Any] else { return nil }
    var dict = [String: T]()
    for (k, v) in jsonDict {
        if let converted = converter(v) {
            dict[k] = converted
        } else {
            return nil
        }
    }
    return dict
}

fileprivate func convertToAny<T>(_ dictionary: [String: T], _ converter: (T) -> Any) -> Any {
    var result = [String: Any]()
    for (k, v) in dictionary {
        result[k] = converter(v)
    }
    return result
}

fileprivate func convertDouble(_ v: Any) -> Double? {
    if let w = v as? Double { return w }
    if let w = v as? Int { return Double(w) }
    return nil
}

fileprivate let falseType = NSNumber(value: false).objCType
fileprivate let trueNumber = NSNumber(value: true)
fileprivate let trueType = trueNumber.objCType

fileprivate func convertBool(_ v: Any?) -> Bool? {
    guard let number = v as? NSNumber
    else {
        if let b = v as? Bool {
            return b
        }
        return nil
    }

    if number.objCType != falseType && number.objCType != trueType {
        return nil
    }
    return number.isEqual(trueNumber)
}

fileprivate func removeNSNull(_ v: Any?) -> Any? {
    if let w = v {
        if w is NSNull {
            return nil
        }
        return w
    }
    return nil
}

fileprivate func checkNull(_ v: Any?) -> Any?? {
    if v != nil { return .none }
    return .some(nil)
}"""

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromSet $ unionToSet ur of
    Just r -> do
        rendered <- renderType r
        pure $ rendered <> "?"
    Nothing -> lookupUnionName ur

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any?"
    IRNull -> pure "Any?"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion ur

convertAny :: IRType -> String -> Doc String
convertAny (IRArray a) var = do
    converter <- convertAnyFunc a
    pure $ "convertArray(" <> converter <> ", " <> var <> ")"
convertAny (IRMap m) var = do
    converter <- convertAnyFunc m
    pure $ "convertDict(" <> converter <> ", " <> var <> ")"
convertAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(" <> converter <> ", " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRNothing var =
    pure var
convertAny IRBool var =
    pure $ "convertBool(" <> var <> ")"
convertAny IRInteger var =
    pure $ var <> " as? Int"
convertAny IRString var =
    pure $ var <> " as? String"
convertAny t var = do
    converter <- convertAnyFunc t
    pure $ converter <> "(" <> var <> ")"

convertAnyFunc :: IRType -> Doc String
convertAnyFunc = case _ of
    IRClass i -> do
        name <- lookupClassName i
        -- TODO make this look less alien
        pure $ "{ " <> name <> "(fromAny: $0) }"
    IRUnion ur ->
        case nullableFromSet $ unionToSet ur of
        Just t -> do
            converter <- convertAnyFunc t
            pure $ "{ (json: Any) in convertOptional(" <> converter <> ", json) }"
        Nothing -> do
            name <- lookupUnionName ur
            pure $ name <> ".fromJson"
    IRDouble -> pure "convertDouble"
    IRNull -> pure "checkNull"
    t -> do
        converted <- convertAny t "$0"
        pure $ "{ " <> converted <> " }"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    convertCode <- convertToAny a "$0"
    pure $ var <> ".map({ " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    convertCode <- convertToAny m "$0"
    pure $ "convertToAny(" <> var <> ", { "<> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".any"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        convertCode <- convertToAny t "$0"
        pure $ var <> ".map({ " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".any"
convertToAny IRNothing var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull() as Any"
convertToAny _ var =
    pure $ var <> " as Any"

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    let forbidden = keywords <> ["json", "any"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "struct " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType ptype
            line $ "let " <> fieldName <> ": " <> rendered
    line "}"

renderTopLevelExtensions :: String -> IRType -> Doc Unit
renderTopLevelExtensions topLevelName topLevelType = do
    blank

    topLevelRendered <- renderType topLevelType
    extensionType <- case topLevelType of
        IRArray t -> ("Array where Element == " <> _) <$> renderType t
        IRMap t -> ("Dictionary where Key == String, Value == " <> _) <$> renderType t
        _ -> pure topLevelRendered

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "init?(fromString json: String, using encoding: String.Encoding = .utf8) {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line "self.init(fromData: data)"
        line "}"
        blank
        line $ "init?(fromData data: Data) {"
        indent do
            line "guard let json = try? JSONSerialization.jsonObject(with: data, options: []) else { return nil }"
            line "self.init(fromAny: json)"
        line "}"

        case topLevelType of
            IRArray _ ->  do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init(elements)"
                line "}"
            IRMap _ -> do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init()"
                    line $ "elements.forEach { self[$0.key] = $0.value }"
                line "}"
            _ -> pure unit

        blank
        line $ "var jsonData: Data? {"
        indent do
            convertCode <- convertToAny topLevelType "self"
            line $ "let json = " <> convertCode
            line "return try? JSONSerialization.data(withJSONObject: json, options: [])"
        line "}"

        blank
        line $ "var jsonString: String? {"
        indent do
            line $ "guard let data = self.jsonData else { return nil }"
            line $ "return String(data: data, encoding: .utf8)"
        line "}"

    line "}"

renderClassExtension :: String -> Map String IRType -> Doc Unit
renderClassExtension className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "extension " <> className <> " {"
    indent do
        line $ "fileprivate init?(fromAny any: Any) {"
        indent do
            line "guard let json = any as? [String: Any] else { return nil }"
            let forbiddenForUntyped = forbidden <> (A.fromFoldable $ M.keys propertyNames)
            let untypedNames = makePropertyNames properties "Any" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            forEachProperty_ properties untypedNames \pname ptype untypedName _ -> do
                when (canBeNull ptype) do
                    line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"])"
            unless (M.isEmpty properties) do
                line "guard"
                indent do
                    forEachProperty_ properties untypedNames \pname ptype untypedName isLast -> do
                        let convertedName = lookupName pname propertyNames
                        unless (canBeNull ptype) do
                            line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"]),"
                        convertCode <- convertAny ptype untypedName
                        line $ "let " <> convertedName <> " = " <> convertCode <> (if isLast then "" else ",")
                    line "else { return nil }"
            forEachProperty_ properties propertyNames \pname _ fieldName _ -> do
                let convertedName = lookupName pname propertyNames
                line $ "self." <> fieldName <> " = " <> convertedName
        line "}"
        blank
        line "fileprivate var any: Any {"
        indent do
            if null properties
                then line "return [String: Any]()"
                else do
                    line "return ["
                    indent do
                        forEachProperty_ properties propertyNames \pname ptype fieldName _ -> do
                            convertCode <- convertToAny ptype ("self." <> fieldName)
                            line $ "\"" <> stringEscape pname <> "\": " <> convertCode <> ","
                    line "]"
        line "}"
    line "}"

forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> String -> Boolean -> Doc Unit) -> Doc Unit
forEachProperty_ properties propertyNames f =
    let propertyArray = M.toUnfoldable properties :: Array _
        lastIndex = A.length propertyArray - 1
    in
        forWithIndex_ propertyArray \i (Tuple pname ptype) -> do
            let fieldName = lookupName pname propertyNames
            f pname ptype fieldName (i == lastIndex)

makePropertyNames :: Map String IRType -> String -> Array String -> Map String String
makePropertyNames properties suffix forbidden =
    transformPropertyNames (fieldNamer suffix) otherField forbidden properties
    where
        fieldNamer :: String -> Namer String
        fieldNamer suffix = simpleNamer \name -> swiftNameStyle false name <> suffix

        otherField :: String -> String
        otherField name = "other" <> capitalize name

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "enum " <> unionName <> " {"
    indent do
        for_ nonNullTypes \typ -> do
            name <- caseName typ
            rendered <- renderType typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        case emptyOrNull of
            Just t -> do
                name <- caseName t
                line $ "case " <> name
            Nothing -> pure unit
    line "}"

renderUnionExtension :: String -> Set IRType -> Doc Unit
renderUnionExtension unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "extension " <> unionName <> " {"
    indent do
        line $ "fileprivate static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            case emptyOrNull of
                Just t -> do
                    name <- caseName t
                    line "guard let v = removeNSNull(v)"
                    line "else {"
                    indent do
                        line $ "return ." <> name
                    line "}"
                Nothing -> pure unit
            when (S.member IRBool unionTypes) do
                renderCase IRBool
            when (S.member IRInteger unionTypes) do
                renderCase IRInteger
            for_ (S.difference nonNullTypes $ S.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "fileprivate var any: Any {"
        indent do
            line $ "switch self {"
            for_ unionTypes \typ -> do
                name <- caseName typ
                let letString = if typ == IRNull then "" else "(let x)"
                convertCode <- convertToAny typ "x"
                line $ "case ." <> name <> letString <> ": return " <> convertCode
            line "}"
        line "}"
    line "}"
    where
    renderCase :: IRType -> Doc Unit
    renderCase t = do
        convertCode <- convertAny t "v"
        name <- caseName t
        line $ "if let x = " <> convertCode <> " { return ." <> name <> "(x) }"

caseName :: IRType -> Doc String
caseName t = swiftNameStyle false <$> getTypeNameForUnion t


Clean up notebook cells' lens

Clean up notebook cells' lens

module Model.Notebook where

import Data.Either
import Data.Maybe
import Data.Inject1 (prj, inj)
import Halogen.HTML.Events.Monad (Event())
import Optic.Core (lens, LensP())
import Control.Timer (Timeout())
import Model.Path (Path(), emptyPath)
import Model.File.Item (Item())
import EffectTypes (NotebookAppEff())
import Model.Notebook.Menu (initialDropdowns, DropdownItem())

import Data.Argonaut.Combinators
import qualified Data.Argonaut.Core as Ac
import qualified Data.Argonaut.Decode as Ad
import qualified Data.Argonaut.Encode as Ae
import qualified Data.Argonaut.Printer as Ap
import qualified Network.HTTP.Affjax.Request as Ar
import qualified Data.StrMap as M

type I e = Event (NotebookAppEff e) Input

type State =
  { dropdowns :: [DropdownItem]
  , timeout :: Maybe Timeout
  , path :: Path
  , name :: String
  , items :: [Item]
  , loaded :: Boolean
  , error :: String
  , editable :: Boolean
  , modalError :: String
  , addingCell :: Boolean
  , notebook :: Notebook
  , nextCellId :: Number
  }

dropdowns :: LensP State [DropdownItem]
dropdowns = lens _.dropdowns _{dropdowns = _}

notebook :: LensP State Notebook
notebook = lens _.notebook _{notebook = _}

nextCellId :: LensP State Number
nextCellId = lens _.nextCellId _{nextCellId = _}

initialState :: State
initialState =
  { dropdowns: initialDropdowns
  , timeout: Nothing
  , path: emptyPath
  , name: ""
  , items: []
  , loaded: false
  , error: ""
  , editable: true
  , modalError: ""
  , addingCell: false
  , notebook: newNotebook
  -- TODO: We use CellId = String below - how do we gen one?
  , nextCellId: 0
  }

data Input
  = Dropdown Number
  | CloseDropdowns
  | SetTimeout (Maybe Timeout)
  | SetName String
  | SetPath Path
  | SetItems [Item]
  | SetLoaded Boolean
  | SetError String
  | SetEditable Boolean
  | SetModalError String
  | SetAddingCell Boolean
  | AddCell CellType
  | ToggleEditorCell CellId
  | TrashCell CellId

type CellId = String

string2cellId :: String -> Either String CellId
string2cellId "" = Left "incorrect cellid"
string2cellId a = Right a

data CellType
  = Evaluate
  | Explore
  | Search
  | Query
  | Visualize
  | Markdown

newtype Cell = Cell {
  cellId :: CellId,
  input :: String,
  output :: String,
  cellType :: CellType,
  metadata :: String,
  hiddenEditor :: Boolean
  }

newCell :: CellId -> CellType -> Cell
newCell cellId cellType =
  Cell { cellId: cellId
       , input: ""
       , output: ""
       , cellType: cellType
       , metadata: ""
       , hiddenEditor: false
       }

newtype Notebook = Notebook {
  metadata :: String,
  cells :: [Cell]
  }

newNotebook :: Notebook
newNotebook = Notebook {
  metadata: "",
  cells: []
  }

notebookLens :: LensP Notebook _
notebookLens = lens (\(Notebook obj) -> obj) (const Notebook)

notebookCells :: LensP Notebook [Cell]
notebookCells = notebookLens <<< lens _.cells (_ { cells = _ })

instance cellTypeEncode :: Ae.EncodeJson CellType where
  encodeJson cell = Ac.fromString $ case cell of
    Evaluate -> "evaluate"
    Explore -> "explore"
    Search -> "search"
    Query -> "query"
    Visualize -> "visualize"
    Markdown -> "markdown"

instance cellEncode :: Ae.EncodeJson Cell where
  encodeJson (Cell cell)
    =  "input" := cell.input
    ~> "output" := cell.output
    ~> "cellType" := cell.cellType
    ~> "metadata" := cell.metadata
    ~> Ac.jsonEmptyObject

instance notebookEncode :: Ae.EncodeJson Notebook where
  encodeJson (Notebook {metadata: metadata, cells: cells})
    =  "metadata" := metadata
    ~> "cells" := cells
    ~> Ac.jsonEmptyObject

instance notebookRequestable :: Ar.Requestable Notebook where
  toRequest notebook =
    let str = Ap.printJson (Ae.encodeJson notebook) :: String
    in Ar.toRequest str

module Model.Notebook where

import Data.Either
import Data.Maybe
import Data.Inject1 (prj, inj)
import Halogen.HTML.Events.Monad (Event())
import Optic.Core (lens, LensP())
import Control.Timer (Timeout())
import Model.Path (Path(), emptyPath)
import Model.File.Item (Item())
import EffectTypes (NotebookAppEff())
import Model.Notebook.Menu (initialDropdowns, DropdownItem())

import Data.Argonaut.Combinators
import qualified Data.Argonaut.Core as Ac
import qualified Data.Argonaut.Decode as Ad
import qualified Data.Argonaut.Encode as Ae
import qualified Data.Argonaut.Printer as Ap
import qualified Network.HTTP.Affjax.Request as Ar
import qualified Data.StrMap as M

type I e = Event (NotebookAppEff e) Input

type State =
  { dropdowns :: [DropdownItem]
  , timeout :: Maybe Timeout
  , path :: Path
  , name :: String
  , items :: [Item]
  , loaded :: Boolean
  , error :: String
  , editable :: Boolean
  , modalError :: String
  , addingCell :: Boolean
  , notebook :: Notebook
  , nextCellId :: Number
  }

dropdowns :: LensP State [DropdownItem]
dropdowns = lens _.dropdowns _{dropdowns = _}

notebook :: LensP State Notebook
notebook = lens _.notebook _{notebook = _}

nextCellId :: LensP State Number
nextCellId = lens _.nextCellId _{nextCellId = _}

initialState :: State
initialState =
  { dropdowns: initialDropdowns
  , timeout: Nothing
  , path: emptyPath
  , name: ""
  , items: []
  , loaded: false
  , error: ""
  , editable: true
  , modalError: ""
  , addingCell: false
  , notebook: newNotebook
  -- TODO: We use CellId = String below - how do we gen one?
  , nextCellId: 0
  }

data Input
  = Dropdown Number
  | CloseDropdowns
  | SetTimeout (Maybe Timeout)
  | SetName String
  | SetPath Path
  | SetItems [Item]
  | SetLoaded Boolean
  | SetError String
  | SetEditable Boolean
  | SetModalError String
  | SetAddingCell Boolean
  | AddCell CellType
  | ToggleEditorCell CellId
  | TrashCell CellId

type CellId = String

string2cellId :: String -> Either String CellId
string2cellId "" = Left "incorrect cellid"
string2cellId a = Right a

data CellType
  = Evaluate
  | Explore
  | Search
  | Query
  | Visualize
  | Markdown

newtype Cell = Cell {
  cellId :: CellId,
  input :: String,
  output :: String,
  cellType :: CellType,
  metadata :: String,
  hiddenEditor :: Boolean
  }

newCell :: CellId -> CellType -> Cell
newCell cellId cellType =
  Cell { cellId: cellId
       , input: ""
       , output: ""
       , cellType: cellType
       , metadata: ""
       , hiddenEditor: false
       }

newtype Notebook = Notebook {
  metadata :: String,
  cells :: [Cell]
  }

newNotebook :: Notebook
newNotebook = Notebook {
  metadata: "",
  cells: []
  }

notebookCells :: LensP Notebook [Cell]
notebookCells = lens (\(Notebook {cells = cs}) -> cs) (\(Notebook o) cs -> Notebook $ o { cells = cs })

instance cellTypeEncode :: Ae.EncodeJson CellType where
  encodeJson cell = Ac.fromString $ case cell of
    Evaluate -> "evaluate"
    Explore -> "explore"
    Search -> "search"
    Query -> "query"
    Visualize -> "visualize"
    Markdown -> "markdown"

instance cellEncode :: Ae.EncodeJson Cell where
  encodeJson (Cell cell)
    =  "input" := cell.input
    ~> "output" := cell.output
    ~> "cellType" := cell.cellType
    ~> "metadata" := cell.metadata
    ~> Ac.jsonEmptyObject

instance notebookEncode :: Ae.EncodeJson Notebook where
  encodeJson (Notebook {metadata: metadata, cells: cells})
    =  "metadata" := metadata
    ~> "cells" := cells
    ~> Ac.jsonEmptyObject

instance notebookRequestable :: Ar.Requestable Notebook where
  toRequest notebook =
    let str = Ap.printJson (Ae.encodeJson notebook) :: String
    in Ar.toRequest str


Event name is actually mute not muted

Event name is actually mute not muted

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 (addEventListener, MediaStreamTrack)
import WebRTC.RTC (closeRTCPeerConnection, RTCPeerConnection, iceConnectionState, oniceconnectionstatechange, onconnectionstatechange, onnegotiationneeded, 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
    -- Close rtc connection once a track ends - so parent will notice local problems:
    tracks <- liftEff $ MediaStream.getTracks origStream
    let addListener event = liftEff <<< addEventListener event (const (closeRTCPeerConnection rtcConnection))
    traverse_ (addListener "ended") tracks
    traverse_ (addListener "mute") tracks
    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"
  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 (addEventListener, MediaStreamTrack)
import WebRTC.RTC (closeRTCPeerConnection, RTCPeerConnection, iceConnectionState, oniceconnectionstatechange, onconnectionstatechange, onnegotiationneeded, 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
    -- Close rtc connection once a track ends - so parent will notice local problems:
    tracks <- liftEff $ MediaStream.getTracks origStream
    let addListener event = liftEff <<< addEventListener event (const (closeRTCPeerConnection rtcConnection))
    traverse_ (addListener "ended") tracks
    traverse_ (addListener "muted") tracks
    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"
  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


Add replace'

Add replace'

module Data.String.Regex where

foreign import data Regex :: *

foreign import regex
  "function regex(s1) {\
  \  return function(s2) {\
  \    return new RegExp(s1, s2);\
  \  };\
  \}" :: String -> String -> Regex

foreign import test
  "function test(r) {\
  \  return function (s) {\
  \    return r.test(s);\
  \  };\
  \}" :: Regex -> String -> Boolean

foreign import match
  "function match(r) {\
  \  return function (s) {\
  \    return s.match(r); \
  \  };\
  \}" :: Regex -> String -> [String]

foreign import replace
  "function replace(r) {\
  \  return function(s1) {\
  \    return function(s2) {\
  \      return s2.replace(r, s1);\
  \    };\
  \  };\
  \}" :: Regex -> String -> String -> String

foreign import replace'
  "function replace$prime(r) {\
  \  return function(f) {\
  \    return function(s2) {\
  \      return s2.replace(r, function (match) {\
  \        return f(match)(Array.prototype.splice.call(arguments, 1, arguments.length - 3));\
  \      });\
  \    };\
  \  };\
  \}" :: Regex -> (String -> [String] -> String) -> String -> String

foreign import search
  "function search(r) {\
  \  return function (s) {\
  \    return s.search(r);\
  \  };\
  \}" :: Regex -> String -> Number

module Data.String.Regex where

foreign import data Regex :: *

foreign import regex
  "function regex(s1) {\
  \  return function(s2) {\
  \    return new RegExp(s1, s2);\
  \  };\
  \}" :: String -> String -> Regex

foreign import test
  "function test(r) {\
  \  return function (s) {\
  \    return r.test(s);\
  \  };\
  \}" :: Regex -> String -> Boolean

foreign import match
  "function match(r) {\
  \  return function (s) {\
  \    return s.match(r); \
  \  };\
  \}" :: Regex -> String -> [String]

foreign import replace
  "function replace(r) {\
  \  return function(s1) {\
  \    return function(s2) {\
  \      return s2.replace(r, s1);\
  \    };\
  \  };\
  \}" :: Regex -> String -> String -> String

foreign import search
  "function search(r) {\
  \  return function (s) {\
  \    return s.search(r);\
  \  };\
  \}" :: Regex -> String -> Number


Fix disabled rendering

Fix disabled rendering

module App.BoardView where

import Data.Maybe
import App.FixedMatrix72 as FM
import App.Turn as Turn
import Data.Array as Array
import Pux.CSS as C
import Pux.Html as H
import App.Board (Pit, PitRef, Player, Board, getStore, isBlocked)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import CSS (gray)
import Control.MonadZero (guard)
import Data.Traversable (sequence)
import Data.Unfoldable (replicate)
import Prelude (bind, const, mod, pure, show, (#), ($), (-), (/), (<), (<$>), (<<<), (<=), (<>), (==))
import Pux.CSS (Color, em, pct, hsl, px, style)
import Pux.Html (Attribute, Html, div, text)
import Pux.Html.Events (onClick)

class BoardView state action | state -> action where
  getBoard :: state -> Board
  getHand :: state -> Maybe Hand
  getTurn :: state -> Maybe Turn
  getCurrentPlayer :: state -> Maybe Player
  getPitAction :: state -> PitRef -> Maybe action

type PitState = Maybe Turn

isPlaying :: forall state action. BoardView state action
          => state -> Player -> Boolean
isPlaying state player = fromMaybe false $ do
  currentPlayer <- getCurrentPlayer state
  pure $ player == currentPlayer

isCapturing :: forall state action. BoardView state action
            => state -> Player -> Boolean
isCapturing state player = fromMaybe false $ do
  guard $ isPlaying state player
  guard $ getTurn state == Just (Turn.Capture player)
  pure true

pitState :: forall state action. BoardView state action
         => state -> PitRef -> PitState
pitState state ref = do
  hand <- getHand state
  if ref == hand.pitRef
    then getTurn state
    else Nothing

playerColor :: Player -> Color
playerColor A = C.blue # C.lighten 0.2
playerColor B = C.red # C.lighten 0.2

playerColorFocus :: Player -> Color
playerColorFocus player = playerColor player # C.saturate 0.9

dynamicPlayerColor :: forall state action. BoardView state action
                   => state -> Player -> Color
dynamicPlayerColor state player = go (isPlaying state player) (isCapturing state player)
  where go _ true = playerColorFocus player
        go _ _ = playerColor player

pitColor :: PitState -> Color
pitColor (Just (Turn.Capture player)) = playerColorFocus player
pitColor (Just Turn.Lift) = pitColor Nothing # C.lighten 0.2
pitColor (Just Turn.Sow) = pitColor Nothing # C.lighten 0.4
pitColor _ = C.green

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewRow A
  , viewRow B
  , viewStore state B
  ]
  where
    board =
      getBoard state
    viewRow player =
      div [] $ FM.mapRowWithIndex player (viewPit state) board.cells

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player =
  H.pre [css] [ text s, viewSeeds 20 seeds ]
    where s = viewPlayer player
          seeds = getStore player board
          board = getBoard state
          color = dynamicPlayerColor state player
          css = style do
            C.display C.inlineFlex
            C.textAlign C.center
            C.fontSize (em 2.8)
            C.backgroundColor color
            C.width (pct 40.0)
            C.height (em 2.0)
            C.marginLeft (pct 25.0)
            C.padding (em 0.0) (em padding) (em 0.0) (em padding)
            C.border C.solid (px border) C.black
              where padding = 0.5
                    border = if isPlaying state player then 9.5 else 0.0

viewPit :: forall action state. BoardView state action
        => state -> PitRef -> Pit -> Html action
viewPit state ref count =
  H.div (getJusts [css, event]) [body]
  where
    body = div [] [content ]
    blocked = isBlocked ref (getBoard state)
    content = if blocked then viewDisabledPit else viewSeeds 5 count
    event = onClick <$> const <$> getPitAction state ref
    color = pitColor $ pitState state ref
    css = Just $ style do
      C.display C.inlineFlex
      C.width (pct 10.0)
      C.height (em 3.0)
      C.fontSize (em 2.5)
      C.backgroundColor $ if blocked then gray else color
      apply4 C.margin (em 0.0)
      C.border C.solid (px 1.0) C.black
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
        where padding = 0.5

viewDisabledPit :: forall action. Html action
viewDisabledPit = H.div [compactStyle] [ H. text $ "X" ]

viewSeed :: forall action. Html action
viewSeed = H.span [compactStyle] [ H.text $ "⦿"]

-- Display seeds as a matrix confined to a pit cell
viewSeeds :: forall action. Int -> Int -> Html action
viewSeeds g c | c == 0 = H.div [compactStyle] [ text "-"]
              | c <= g = H.div [compactStyle] $ replicate c viewSeed
              | true   = H.div [compactStyle] $ (viewSeeds g <$> splits)
                          where splits = replicate (c/g) g <> [c `mod` g]

compactStyle :: forall action. Attribute action
compactStyle = style do
  apply4 C.padding (px 0.0)
  apply4 C.margin (px 0.0)
  C.fontSize (px 24.0)
  C.width (em 1.0)
  C.height (em 1.0)

showPadded :: Int -> String
showPadded n =
  if n < 10
    then " " <> show n <> extra
    else show n <> extra
      where extra = "  "

viewPlayer :: Player -> String
viewPlayer A = "A"
viewPlayer B = "B"

getJusts :: forall a. Array (Maybe a) -> Array a
getJusts = fromMaybe [] <<< sequence <<< Array.filter isJust

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a

module App.BoardView where

import Data.Maybe
import App.FixedMatrix72 as FM
import App.Turn as Turn
import Data.Array as Array
import Pux.CSS as C
import Pux.Html as H
import App.Board (Pit, PitRef, Player, Board, getStore, isBlocked)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import CSS (gray)
import Control.MonadZero (guard)
import Data.Traversable (sequence)
import Data.Unfoldable (replicate)
import Prelude (bind, const, mod, pure, show, (#), ($), (-), (/), (<), (<$>), (<<<), (<=), (<>), (==))
import Pux.CSS (Color, em, pct, hsl, px, style)
import Pux.Html (Attribute, Html, div, text)
import Pux.Html.Events (onClick)

class BoardView state action | state -> action where
  getBoard :: state -> Board
  getHand :: state -> Maybe Hand
  getTurn :: state -> Maybe Turn
  getCurrentPlayer :: state -> Maybe Player
  getPitAction :: state -> PitRef -> Maybe action

type PitState = Maybe Turn

isPlaying :: forall state action. BoardView state action
          => state -> Player -> Boolean
isPlaying state player = fromMaybe false $ do
  currentPlayer <- getCurrentPlayer state
  pure $ player == currentPlayer

isCapturing :: forall state action. BoardView state action
            => state -> Player -> Boolean
isCapturing state player = fromMaybe false $ do
  guard $ isPlaying state player
  guard $ getTurn state == Just (Turn.Capture player)
  pure true

pitState :: forall state action. BoardView state action
         => state -> PitRef -> PitState
pitState state ref = do
  hand <- getHand state
  if ref == hand.pitRef
    then getTurn state
    else Nothing

playerColor :: Player -> Color
playerColor A = C.blue # C.lighten 0.2
playerColor B = C.red # C.lighten 0.2

playerColorFocus :: Player -> Color
playerColorFocus player = playerColor player # C.saturate 0.9

dynamicPlayerColor :: forall state action. BoardView state action
                   => state -> Player -> Color
dynamicPlayerColor state player = go (isPlaying state player) (isCapturing state player)
  where go _ true = playerColorFocus player
        go _ _ = playerColor player

pitColor :: PitState -> Color
pitColor (Just (Turn.Capture player)) = playerColorFocus player
pitColor (Just Turn.Lift) = pitColor Nothing # C.lighten 0.2
pitColor (Just Turn.Sow) = pitColor Nothing # C.lighten 0.4
pitColor _ = C.green

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewRow A
  , viewRow B
  , viewStore state B
  ]
  where
    board =
      getBoard state
    viewRow player =
      div [] $ FM.mapRowWithIndex player (viewPit state) board.cells

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player =
  H.pre [css] [ text s, viewSeeds 20 seeds ]
    where s = viewPlayer player <> showPadded seeds
          seeds = getStore player board
          board = getBoard state
          color = dynamicPlayerColor state player
          css = style do
            C.display C.inlineFlex
            C.textAlign C.center
            C.fontSize (em 0.8)
            C.backgroundColor color
            C.width (pct 40.0)
            C.height (em 6.0)
            C.marginLeft (pct 25.0)
            C.padding (em 0.0) (em padding) (em 0.0) (em padding)
            C.border C.dotted (px border) C.black
              where padding = 0.5
                    border = if isPlaying state player then 9.5 else 0.0

viewPit :: forall action state. BoardView state action
        => state -> PitRef -> Pit -> Html action
viewPit state ref count =
  H.div (getJusts [css, event]) [body]
  where
    body = div [] [content ]
    blocked = isBlocked ref (getBoard state)
    content = if blocked then text "X" else viewSeeds 5 count
    event = onClick <$> const <$> getPitAction state ref
    color = pitColor $ pitState state ref
    css = Just $ style do
      C.display C.inlineFlex
      C.width (pct 10.0)
      C.height (em 3.0)
      C.fontSize (em 2.5)
      C.backgroundColor $ if blocked then gray else color
      apply4 C.margin (em 0.0)
      C.border C.solid (px 1.0) C.black
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
        where padding = 0.5

viewSeed :: forall action. Html action
viewSeed = H.span [compactStyle] [ H.text $ "⦿"]

-- Display seeds as a matrix confined to a pit cell
viewSeeds :: forall action. Int -> Int -> Html action
viewSeeds g c | c == 0 = H.div [compactStyle] [ text "-"]
              | c <= g = H.div [compactStyle] $ replicate c viewSeed
              | true   = H.div [compactStyle] $ (viewSeeds g <$> splits)
                          where splits = replicate (c/g) g <> [c `mod` g]

compactStyle :: forall action. Attribute action
compactStyle = style do
  apply4 C.padding (px 0.0)
  apply4 C.margin (px 0.0)
  C.fontSize (px 24.0)
  C.width (em 1.0)
  C.height (em 1.0)

showPadded :: Int -> String
showPadded n =
  if n < 10
    then " " <> show n <> extra
    else show n <> extra
      where extra = "  "

viewPlayer :: Player -> String
viewPlayer A = "A"
viewPlayer B = "B"

getJusts :: forall a. Array (Maybe a) -> Array a
getJusts = fromMaybe [] <<< sequence <<< Array.filter isJust

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a