Use closure shorthand syntax

Use closure shorthand syntax

Original commit d1a78db273952d0ca0667d8b5053e4cd55e3e519

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 <> ["jsonUntyped", "json"]
    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 "Untyped" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            let convertedNames = makePropertyNames properties "" forbidden
            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 convertedNames
                        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 convertedNames
                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 "json"
        pure $ "{ (json: Any) in " <> converted <> " }"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    rendered <- renderType a
    convertCode <- convertToAny a "v"
    pure $ var <> ".map({ (v: " <> rendered <> ") in " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    rendered <- renderType m
    convertCode <- convertToAny m "v"
    pure $ "convertToAny(" <> var <> ", { (v: " <> rendered <> ") in " <> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".any"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        rendered <- renderType t
        convertCode <- convertToAny t "v"
        pure $ var <> ".map({ (v: " <> rendered <> ") in " <> 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 <> ["jsonUntyped", "json"]
    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 "Untyped" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            let convertedNames = makePropertyNames properties "" forbidden
            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 convertedNames
                        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 convertedNames
                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


remove Newtype instance for CodePoint

remove Newtype instance for CodePoint

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char as Char
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: This list must be updated to re-export any exports added to Data.String. That makes me sad.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

codePointFromSurrogatePair :: Int -> Int -> Maybe CodePoint
codePointFromSurrogatePair lead trail | isLead lead && isTrail trail =
  Just (unsurrogate lead trail)
codePointFromSurrogatePair _ _ = Nothing

unsurrogate :: Int -> Int -> CodePoint
unsurrogate h l = CodePoint ((h - 0xD800) * 0x400 + (l - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s | String.length s == 1 = CodePoint (Unsafe.charCodeAt 0 s)
unsafeCodePointAt0Fallback s = CodePoint (((lead - 0xD800) * 0x400) + (trail - 0xDC00) + 0x10000)
  where
    lead = Unsafe.charCodeAt 0 s
    trail = Unsafe.charCodeAt 1 s

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count = _count isLead isTrail unsurrogate

foreign import _count
  :: (Int -> Boolean)
  -> (Int -> Boolean)
  -> (Int -> Int -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.lastIndexOf p s'

length :: String -> Int
length = Array.length <<< toCodePointArray

singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) = fromCharCode lead <> fromCharCode trail
  where
    lead = ((cp - 0x10000) / 0x400) + 0xD800
    trail = (cp - 0x10000) `mod` 0x400 + 0xDC00

splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps < i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (Char.toCharCode <$> String.toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons h (Cons l rest)) | isLead h && isTrail l
    = Just (Tuple (unsurrogate h l) rest)
  decode (Cons c rest) = Just (Tuple (CodePoint c) rest)
  decode Nil = Nothing

uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s  = { head: _, tail: drop 1 s } <$> codePointAt 0 s

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char as Char
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype)
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: This list must be updated to re-export any exports added to Data.String. That makes me sad.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint
derive instance newtypeCodePoint :: Newtype CodePoint _

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

codePointFromSurrogatePair :: Int -> Int -> Maybe CodePoint
codePointFromSurrogatePair lead trail | isLead lead && isTrail trail =
  Just (unsurrogate lead trail)
codePointFromSurrogatePair _ _ = Nothing

unsurrogate :: Int -> Int -> CodePoint
unsurrogate h l = CodePoint ((h - 0xD800) * 0x400 + (l - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s | String.length s == 1 = CodePoint (Unsafe.charCodeAt 0 s)
unsafeCodePointAt0Fallback s = CodePoint (((lead - 0xD800) * 0x400) + (trail - 0xDC00) + 0x10000)
  where
    lead = Unsafe.charCodeAt 0 s
    trail = Unsafe.charCodeAt 1 s

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count = _count isLead isTrail unsurrogate

foreign import _count
  :: (Int -> Boolean)
  -> (Int -> Boolean)
  -> (Int -> Int -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.lastIndexOf p s'

length :: String -> Int
length = Array.length <<< toCodePointArray

singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) = fromCharCode lead <> fromCharCode trail
  where
    lead = ((cp - 0x10000) / 0x400) + 0xD800
    trail = (cp - 0x10000) `mod` 0x400 + 0xDC00

splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps < i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (Char.toCharCode <$> String.toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons h (Cons l rest)) | isLead h && isTrail l
    = Just (Tuple (unsurrogate h l) rest)
  decode (Cons c rest) = Just (Tuple (CodePoint c) rest)
  decode Nil = Nothing

uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s  = { head: _, tail: drop 1 s } <$> codePointAt 0 s


Add readSnapshot function

Add readSnapshot function

to chain with on SomeEvent and read data out

module Web.Firebase.Monad.Aff
(
  child
, convertError
, key
, on
, once
, onceValue
, push
, set
, fb2error
, firebaseErrToString
-- conveniencde functions to be split out at some point
, readRecord
, valueAt
)
where

import Prelude (Unit, ($), (<<<), bind, show, pure)

import Data.Maybe (Maybe(Just,Nothing))
import Control.Monad.Eff (Eff())
import Control.Monad.Aff (Aff(), makeAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error(), error)
import Control.Monad.Error.Class (throwError)

import Data.Either (Either(Left,Right))

import Data.Foreign (Foreign)
import Data.Foreign.Class (class IsForeign, readWith)

import Web.Firebase as FB
import Web.Firebase.Types as FBT
import Web.Firebase.DataSnapshot (val)

-- | Inspired by its Eff relative.
-- Throw takes a message and throws a MonadError in Aff with that message
throw :: forall eff a. String -> Aff eff a
throw = throwError <<< error

foreign import fb2error :: FBT.FirebaseErr -> Error
foreign import firebaseErrToString :: FBT.FirebaseErr -> String

-- | Gets a Firebase reference for the location at the specified relative path.
-- https://www.firebase.com/docs/web/api/firebase/child.html

child :: forall eff.
       FBT.Key ->
       FBT.Firebase ->
       Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
child aKey ref = liftEff $ FB.child aKey ref

-- | Returns the key of the current firebase reference
-- throws a MonadError if there was no key (i.e. when you ask for the key of the root reference, according to
-- https://www.firebase.com/docs/web/api/firebase/key.html
-- We made it an error, because asking a key of the root reference is a programming error, and should normally not happen.
-- One could specialize this in a Firebase type that can't be the root, or return '/' as the key.
key :: forall eff.
       FBT.Firebase ->
       Aff (firebase :: FBT.FirebaseEff | eff) FBT.Key
key fb = do
  mKey <- liftEff $ FB.key fb
  case mKey of
       Nothing -> throw "Key was null. Did you ask key of root reference?"
       Just k -> pure k

-- | This is the start of a more 'purescript-ish' interface than can be found in Web.Firebase
-- We use the Aff monad to eliminate callback hell
-- This way we can deal with callbacks that are called once.
-- We envision Web.Firebase.Signals to generate signals from callbacks that can be called multiple times

-- TODO this works for value, but will ignore the prevChild argument for onChildAdded etc.
on :: forall eff.
      FB.EventType ->
      FBT.Firebase ->
      Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
on etype fb = makeAff (\eb cb -> FB.on etype cb (convertError eb) fb)

-- convert firebase error to purescript Error in javascript
-- see .js file for firebase Error documentation
convertError :: forall eff. (Error -> Eff (firebase :: FBT.FirebaseEff | eff) Unit) ->
	 FBT.FirebaseErr ->
         Eff (firebase :: Web.Firebase.Types.FirebaseEff | eff) Unit
convertError errorCallback firebaseError = errorCallback (fb2error firebaseError)

-- We also take the liberty to write more specific functions, e.g. once and on() in firebase have 4 event types. we get better error messages and code completion by making specific functions, e.g.
-- onvalue and onchildadded instead of on(value) and on(childAdded)

once :: forall e. FB.EventType -> FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | e) FBT.DataSnapshot
once eventType root = makeAff (\errorCb successCb ->
		                FB.once eventType successCb (convertError errorCb) root)

push :: forall e. FBT.Firebase -> Foreign -> Aff (firebase :: FBT.FirebaseEff | e) FBT.Firebase
push ref value = makeAff (\onError onSuccess -> FB.pushA value onSuccess (convertError onError) ref)

set :: forall e. FBT.Firebase -> Foreign -> Aff (firebase :: FBT.FirebaseEff | e) Unit
set ref value = makeAff (\onError onSuccess -> FB.setA value onSuccess (convertError onError) ref)

-- | Extra functions not part of firebase api, grown out of our use
onceValue :: forall e. FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | e) FBT.DataSnapshot
onceValue root = once FB.Value root

valueAt :: forall eff. FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | eff) Foreign
valueAt ref = do
       snap <- onceValue ref
       pure $ (val snap)

-- | read a record from a reference. Throws exception when any part fails
-- possible failures include network, database and conversion from Foreign value to purescript.
readRecord :: forall a eff. (IsForeign a) => FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | eff) a
readRecord ref = do
  value <- valueAt ref
  case (readWith show value) of
    Left msg    -> throw msg
    Right value -> pure value

-- | read a snapshot to a record. Throws exception when any part fails
-- possible failures include network, database and conversion from Foreign value to purescript.
readSnapshot :: forall a eff. (IsForeign a) => FBT.DataSnapshot -> Aff (firebase :: FBT.FirebaseEff | eff) a
readSnapshot snapshot = do
  let value = val snapshot
  case (readWith show value) of
    Left msg    -> throw msg
    Right value -> pure value


Get rid of separate PitState type

Get rid of separate PitState type

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)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import Data.Traversable (sequence)
import Prelude (bind, const, show, ($), (<>), (<), (==), pure, (<$>), (<<<))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, px, rotateHue, style)
import Pux.Html (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

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

type PitState = Maybe Turn

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

pitColor :: PitState -> Color
pitColor = go
  where go (Just Turn.Capture) = rotateHue 50.0 $ go (Just Turn.Lift)
        go (Just Turn.Lift) = rotateHue 100.0 $ go Nothing
        go (Just Turn.Sow) = lighten 0.3 $ go Nothing
        go _ = hsl 40.0 1.0 0.3

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 [css] $ rows
      where rows = FM.mapRowWithIndex player viewCell' board.cells
            viewCell' ref = viewCell state ref
            css = style $ do
              apply4 C.padding (em 0.5)

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player = div [css] [text s]
    where s = "Player "
                <> show player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitColor (Just Turn.Sow)
                  else pitColor Nothing

viewCell :: forall action state. BoardView state action
          => state -> PitRef -> Pit -> Html action
viewCell state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ numberPadded count
    event = onClick <$> const <$> getPitAction state ref
    numberPadded num =
      if num < 10
        then " " <> show num
        else show num
    css = Just $ style do
      C.display C.inline
      C.fontSize (em 2.0)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      C.border C.solid (px 1.0) C.black
      where
        color = pitColor $ pitState state ref
        padding = 0.5

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)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import Data.Traversable (sequence)
import Prelude (bind, const, show, ($), (<>), (<), (==), pure, (<$>), (<<<))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, px, rotateHue, style)
import Pux.Html (Html, div, text)
import Pux.Html.Events (onClick)

-- TODO: drop in favour of direct use of Turn
data PitState = Normal | Lifted | Captured | Sowed

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

pitState :: forall state action. BoardView state action => state -> PitRef -> PitState
pitState state ref = fromMaybe Normal $ do
  hand <- getHand state
  turn <- getTurn state
  if ref == hand.pitRef
    then pure $ c turn
    else Nothing
      where c Turn.Capture = Captured
            c Turn.Lift = Lifted
            c Turn.Sow = Sowed
            c _ = Normal

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

pitStateColor :: PitState -> Color
pitStateColor = go
  where go Normal = hsl 40.0 1.0 0.3
        go Captured = rotateHue 50.0 $ go Lifted
        go Lifted = rotateHue 100.0 $ go Normal
        go Sowed = lighten 0.3 $ go Normal

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 [css] $ rows
      where rows = FM.mapRowWithIndex player viewCell' board.cells
            viewCell' ref = viewCell state ref
            css = style $ do
              apply4 C.padding (em 0.5)

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player = div [css] [text s]
    where s = "Player "
                <> show player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitStateColor Sowed
                  else pitStateColor Normal

viewCell :: forall action state. BoardView state action
          => state -> PitRef -> Pit -> Html action
viewCell state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ numberPadded count
    event = onClick <$> const <$> getPitAction state ref
    numberPadded num =
      if num < 10
        then " " <> show num
        else show num
    css = Just $ style do
      C.display C.inline
      C.fontSize (em 2.0)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      C.border C.solid (px 1.0) C.black
      where
        color = pitStateColor $ pitState state ref
        padding = 0.5

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


Simplify hand UI

Simplify hand UI

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)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import Data.Traversable (sequence)
import Prelude (bind, const, pure, show, ($), (<), (<$>), (<<<), (<>), (==), (#))
import Pux.CSS (Color, Display, em, 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

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

type PitState = Maybe Turn

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

pitColor :: PitState -> Color
pitColor (Just Turn.Capture) = hsl 300.0 1.0 0.3
pitColor (Just Turn.Lift) = hsl 150.0 1.0 0.3
pitColor (Just Turn.Sow) = C.lighten 0.4 $ pitColor Nothing
pitColor _ = hsl 70.0 1.0 0.3

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 ]
    where s = viewPlayer player <> showPadded seeds
          seeds = getStore player board
          board = getBoard state
          color = if isPlaying state player
                    then pitColor (Just Turn.Sow)
                    else pitColor Nothing # C.darken 0.1
          css = style do
            C.display C.block
            C.textAlign C.center
            C.fontSize (em 2.0)
            C.backgroundColor color
            C.width (em 5.0)
            C.margin (em 1.0) (em 0.0) (em 1.0) (em 8.5)
            C.border C.solid (px 1.0) C.black

viewPit :: forall action state. BoardView state action
        => state -> PitRef -> Pit -> Html action
viewPit state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ showPadded count
    event = onClick <$> const <$> getPitAction state ref
    color = pitColor $ pitState state ref
    css = Just $ style do
      C.display C.inlineFlex
      C.position C.relative
      C.width boxSize
      C.height boxSize
      C.textAlign C.center
      C.fontSize (em 2.5)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      apply4 C.margin (em 0.0)
      C.border C.solid (px 1.0) C.black
      where
        padding = 0.5
        boxSize = (em 1.5)

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

viewPlayer :: Player -> String
viewPlayer player = viewPlayerEmoji player

viewPlayerEmoji :: Player -> String
viewPlayerEmoji A = "🐼"
viewPlayerEmoji B = "🐔"

cellStyle :: forall a. Color -> Display -> Attribute a
cellStyle color display = style do
    C.display display
    C.position C.relative
    C.width boxSize
    C.height boxSize
    C.textAlign C.center
    C.fontSize (em 2.5)
    C.backgroundColor color
    C.padding (em 0.0) (em padding) (em 0.0) (em padding)
    apply4 C.margin (em 0.0)
    C.border C.solid (px 1.0) C.black
    where
      padding = 0.5
      boxSize = (em 1.5)

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)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import Data.Traversable (sequence)
import Prelude (bind, const, pure, show, ($), (<), (<$>), (<<<), (<>), (==))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, px, rotateHue, 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

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

type PitState = Maybe Turn

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

pitColor :: PitState -> Color
pitColor (Just Turn.Capture) = hsl 300.0 1.0 0.3
pitColor (Just Turn.Lift) = hsl 150.0 1.0 0.3
pitColor (Just Turn.Sow) = lighten 0.3 $ pitColor Nothing
pitColor _ = hsl 70.0 1.0 0.3

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewHandRow A
  , viewRow A
  , viewRow B
  , viewHandRow B
  , viewStore state B
  ]
  where
    board =
      getBoard state
    viewHandRow player =
      div [css] $ FM.mapRowWithIndex player (\ref pit -> viewHandInPit state ref) board.cells
    viewRow player =
      div [css] $ FM.mapRowWithIndex player (viewPit state) board.cells
    css = style $ do
            apply4 C.padding (em 0.5)

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player = div [css] [text s]
    where s = viewPlayer player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitColor (Just Turn.Sow)
                  else pitColor Nothing

viewPlayer :: Player -> String
viewPlayer player = "Player " <> show player <> " " <> viewPlayerEmoji (Just player)

viewPlayerEmoji :: Maybe Player -> String
viewPlayerEmoji (Just A) = "🐼"
viewPlayerEmoji (Just B) = "🐔"
viewPlayerEmoji Nothing = numberPadded 0

viewPitEmoji :: forall action state. BoardView state action
              => state -> PitRef -> String
viewPitEmoji state ref = viewPlayerEmoji $ do
  hand <- getHand state
  if hand.pitRef == ref
    then pure hand.player
    else Nothing

viewPit :: forall action state. BoardView state action
        => state -> PitRef -> Pit -> Html action
viewPit state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ numberPadded count
    event = onClick <$> const <$> getPitAction state ref
    color = pitColor $ pitState state ref
    css = Just $ cellStyle color

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

cellStyle :: forall a. Color -> Attribute a
cellStyle color = style do
    C.display C.inline
    C.fontSize (em 2.0)
    C.backgroundColor color
    C.padding (em 0.0) (em padding) (em 0.0) (em padding)
    C.border C.solid (px 1.0) C.black
    where
      padding = 0.5

viewHandInPit :: forall action state. BoardView state action
              => state -> PitRef -> Html action
viewHandInPit state ref =
  H.pre [cellStyle color] [ text s ]
    where color = C.white
          s = fromMaybe (viewPlayerEmoji Nothing) do
                hand <- getHand state
                if hand.pitRef == ref
                  then pure $ (viewPlayerEmoji $ Just hand.player) <> show hand.seeds
                  else Nothing

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