Omit redundant labels for CodableKeys

Omit redundant labels for CodableKeys

module Language.Swift
    ( swift3Renderer
    , swift4Renderer
    ) where

import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_, null)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.String as String
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Doc (Doc, Namer, Renderer, blank, combineNames, forEachClass_, forEachProperty_, forEachTopLevel_, forEachUnion_, forbidNamer, getTypeNameForUnion, indent, line, lookupClassName, lookupName, lookupUnionName, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, getGraph)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, canBeNull, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionToList, filterTypes)

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"
    ]

data Variant = Swift3 | Swift4

derive instance eqVariant :: Eq Variant

swift3Renderer :: Renderer
swift3Renderer =
    { displayName: "Swift 3"
    , names: [ "swift3" ]
    , aceMode: "swift"
    , extension: "swift"
    , doc: swift3Doc
    , options: []
    , 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")
            }
        }
    }

swift4Renderer :: Renderer
swift4Renderer =
    { displayName: "Swift 4"
    , names: [ "swift4", "swift" ]
    , aceMode: "swift"
    , extension: "swift"
    , doc: swift4Doc
    , options: []
    , 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")
            }
        }
    }

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter
    where
        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

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

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

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            "\\u{" <> (String.fromCharArray $ intToHex 0 i) <> "}"

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

swift3Doc :: Doc Unit
swift3Doc = do
    renderHeader

    renderRenderItems blank (Just $ renderTopLevelAlias Swift3) (renderClassDefinition Swift3 false) (Just $ renderUnionDefinition Swift3 false)

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions3

    forEachClass_ \className properties -> do
        blank
        renderClassExtension3 className properties

    forEachUnion_ \unionName unionRep -> do
        blank
        renderUnionExtension3 unionName unionRep

    blank
    supportFunctions3

swift4Doc :: Doc Unit
swift4Doc = do
    renderHeader

    renderRenderItems blank (Just $ renderTopLevelAlias Swift4) (renderClassDefinition Swift4 true) (Just $ renderUnionDefinition Swift4 true)

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions4

    forEachClass_ \className properties -> do
        blank
        renderClassExtension4 className properties

    forEachUnion_ \unionName unionRep -> do
        blank
        renderUnionExtension4 unionName unionRep

    blank
    supportFunctions4

supportFunctions3 :: Doc Unit
supportFunctions3 = 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?) -> NSNull? {
    if v != nil { return .none }
    return .some(NSNull())
}"""

anyAndNullPredicate :: IRType -> Maybe IRType
anyAndNullPredicate IRNull = Just IRNull
anyAndNullPredicate IRAnyType = Just IRAnyType
anyAndNullPredicate _ = Nothing

supportFunctions4 :: Doc Unit
supportFunctions4 = do
    graph <- getGraph
    let anyAndNullSet = filterTypes anyAndNullPredicate graph
    let needAny = S.member IRAnyType anyAndNullSet
    let needNull = needAny || S.member IRNull anyAndNullSet

    when (needAny || needNull) do
        line "// Helpers"
        blank

    when needNull do
        line """class JSONNull: Codable {
    public init() {
    }

    public required init(from decoder: Decoder) throws {
        let container = try decoder.singleValueContainer()
        if !container.decodeNil() {
            throw DecodingError.typeMismatch(JSONNull.self, DecodingError.Context(codingPath: decoder.codingPath, debugDescription: "Wrong type for JSONNull"))
        }
    }

    public func encode(to encoder: Encoder) throws {
        var container = encoder.singleValueContainer()
        try container.encodeNil()
    }
}"""

    when needAny do
        blank
        line """class JSONCodingKey : CodingKey {
    let key: String

    required init?(intValue: Int) {
        return nil
    }

    required init?(stringValue: String) {
        key = stringValue
    }

    var intValue: Int? {
        return nil
    }

    var stringValue: String {
        return key
    }
}

class JSONAny: Codable {
    public let value: Any

    static func decodingError(forCodingPath codingPath: [CodingKey]) -> DecodingError {
        let context = DecodingError.Context(codingPath: codingPath, debugDescription: "Cannot decode JSONAny")
        return DecodingError.typeMismatch(JSONAny.self, context)
    }

    static func encodingError(forValue value: Any, codingPath: [CodingKey]) -> EncodingError {
        let context = EncodingError.Context(codingPath: codingPath, debugDescription: "Cannot encode JSONAny")
        return EncodingError.invalidValue(value, context)
    }

    static func decode(from container: SingleValueDecodingContainer) throws -> Any {
        if let value = try? container.decode(Bool.self) {
            return value
        }
        if let value = try? container.decode(Int64.self) {
            return value
        }
        if let value = try? container.decode(Double.self) {
            return value
        }
        if let value = try? container.decode(String.self) {
            return value
        }
        if container.decodeNil() {
            return JSONNull()
        }
        throw decodingError(forCodingPath: container.codingPath)
    }

    static func decode(from container: inout UnkeyedDecodingContainer) throws -> Any {
        if let value = try? container.decode(Bool.self) {
            return value
        }
        if let value = try? container.decode(Int64.self) {
            return value
        }
        if let value = try? container.decode(Double.self) {
            return value
        }
        if let value = try? container.decode(String.self) {
            return value
        }
        if let value = try? container.decodeNil() {
            if value {
                return JSONNull()
            }
        }
        if var container = try? container.nestedUnkeyedContainer() {
            return try decodeArray(from: &container)
        }
        if var container = try? container.nestedContainer(keyedBy: JSONCodingKey.self) {
            return try decodeDictionary(from: &container)
        }
        throw decodingError(forCodingPath: container.codingPath)
    }

    static func decode(from container: inout KeyedDecodingContainer<JSONCodingKey>, forKey key: JSONCodingKey) throws -> Any {
        if let value = try? container.decode(Bool.self, forKey: key) {
            return value
        }
        if let value = try? container.decode(Int64.self, forKey: key) {
            return value
        }
        if let value = try? container.decode(Double.self, forKey: key) {
            return value
        }
        if let value = try? container.decode(String.self, forKey: key) {
            return value
        }
        if let value = try? container.decodeNil(forKey: key) {
            if value {
                return JSONNull()
            }
        }
        if var container = try? container.nestedUnkeyedContainer(forKey: key) {
            return try decodeArray(from: &container)
        }
        if var container = try? container.nestedContainer(keyedBy: JSONCodingKey.self, forKey: key) {
            return try decodeDictionary(from: &container)
        }
        throw decodingError(forCodingPath: container.codingPath)
    }

    static func decodeArray(from container: inout UnkeyedDecodingContainer) throws -> [Any] {
        var arr: [Any] = []
        while !container.isAtEnd {
            let value = try decode(from: &container)
            arr.append(value)
        }
        return arr
    }

    static func decodeDictionary(from container: inout KeyedDecodingContainer<JSONCodingKey>) throws -> [String: Any] {
        var dict = [String: Any]()
        for key in container.allKeys {
            let value = try decode(from: &container, forKey: key)
            dict[key.stringValue] = value
        }
        return dict
    }

    static func encode(to container: inout UnkeyedEncodingContainer, array: [Any]) throws {
        for value in array {
            if let value = value as? Bool {
                try container.encode(value)
            } else if let value = value as? Int64 {
                try container.encode(value)
            } else if let value = value as? Double {
                try container.encode(value)
            } else if let value = value as? String {
                try container.encode(value)
            } else if value is JSONNull {
                try container.encodeNil()
            } else if let value = value as? [Any] {
                var container = container.nestedUnkeyedContainer()
                try encode(to: &container, array: value)
            } else if let value = value as? [String: Any] {
                var container = container.nestedContainer(keyedBy: JSONCodingKey.self)
                try encode(to: &container, dictionary: value)
            } else {
                throw encodingError(forValue: value, codingPath: container.codingPath)
            }
        }
    }

    static func encode(to container: inout KeyedEncodingContainer<JSONCodingKey>, dictionary: [String: Any]) throws {
        for (key, value) in dictionary {
            let key = JSONCodingKey(stringValue: key)!
            if let value = value as? Bool {
                try container.encode(value, forKey: key)
            } else if let value = value as? Int64 {
                try container.encode(value, forKey: key)
            } else if let value = value as? Double {
                try container.encode(value, forKey: key)
            } else if let value = value as? String {
                try container.encode(value, forKey: key)
            } else if value is JSONNull {
                try container.encodeNil(forKey: key)
            } else if let value = value as? [Any] {
                var container = container.nestedUnkeyedContainer(forKey: key)
                try encode(to: &container, array: value)
            } else if let value = value as? [String: Any] {
                var container = container.nestedContainer(keyedBy: JSONCodingKey.self, forKey: key)
                try encode(to: &container, dictionary: value)
            } else {
                throw encodingError(forValue: value, codingPath: container.codingPath)
            }
        }
    }

    static func encode(to container: inout SingleValueEncodingContainer, value: Any) throws {
        if let value = value as? Bool {
            try container.encode(value)
        } else if let value = value as? Int64 {
            try container.encode(value)
        } else if let value = value as? Double {
            try container.encode(value)
        } else if let value = value as? String {
            try container.encode(value)
        } else if value is JSONNull {
            try container.encodeNil()
        } else {
            throw encodingError(forValue: value, codingPath: container.codingPath)
        }
    }

    public required init(from decoder: Decoder) throws {
        if var arrayContainer = try? decoder.unkeyedContainer() {
            self.value = try JSONAny.decodeArray(from: &arrayContainer)
        } else if var container = try? decoder.container(keyedBy: JSONCodingKey.self) {
            self.value = try JSONAny.decodeDictionary(from: &container)
        } else {
            let container = try decoder.singleValueContainer()
            self.value = try JSONAny.decode(from: container)
        }
    }

    public func encode(to encoder: Encoder) throws {
        if let arr = self.value as? [Any] {
            var container = encoder.unkeyedContainer()
            try JSONAny.encode(to: &container, array: arr)
        } else if let dict = self.value as? [String: Any] {
            var container = encoder.container(keyedBy: JSONCodingKey.self)
            try JSONAny.encode(to: &container, dictionary: dict)
        } else {
            var container = encoder.singleValueContainer()
            try JSONAny.encode(to: &container, value: self.value)
        }
    }
}"""

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

renderType :: Variant -> IRType -> Doc String
renderType variant = case _ of
    IRNoInformation -> pure "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType ->
        case variant of
        Swift4 -> pure "JSONAny"
        Swift3 -> pure "Any?"
    IRNull ->
        case variant of
        Swift4 -> pure "JSONNull"
        Swift3 -> pure "NSNull"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType variant a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType variant t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion variant 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 nullableFromUnion ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(" <> converter <> ", " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRAnyType 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
        pure $ name <> ".init(fromAny:)"
    IRUnion ur ->
        case nullableFromUnion 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 nullableFromUnion ur of
    Just t -> do
        convertCode <- convertToAny t "$0"
        pure $ var <> ".map({ " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".any"
convertToAny IRAnyType var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull()"
convertToAny _ var =
    pure $ var <> " as Any"

renderTopLevelAlias :: Variant -> String -> IRType -> Doc Unit
renderTopLevelAlias variant topLevelName topLevelType = do
    top <- renderType variant topLevelType
    line $ "typealias "<> topLevelName <> " = " <> top

codableString :: Boolean -> String
codableString true = ": Codable"
codableString false = ""

renderClassDefinition :: Variant -> Boolean -> String -> Map String IRType -> Doc Unit
renderClassDefinition variant codable className properties = do
    let forbidden = keywords <> ["json", "any"]
    -- FIXME: we compute these here, and later again when rendering the extension
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "class " <> className <> codableString codable <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType variant ptype
            line $ "let " <> fieldName <> ": " <> rendered
        when (variant == Swift3) do
            blank
            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 "}"
    line "}"

renderExtensionType :: Variant -> IRType -> Doc String
renderExtensionType variant (IRArray t) = ("Array where Element == " <> _) <$> renderType variant t
renderExtensionType variant (IRMap t) = ("Dictionary where Key == String, Value == " <> _) <$> renderType variant t
renderExtensionType variant t = renderType variant t

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

    topLevelRendered <- renderType Swift3 topLevelType
    extensionType <- renderExtensionType Swift3 topLevelType

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "static func from(string json: String, using encoding: String.Encoding = .utf8) -> " <> topLevelRendered <> "? {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line $ "return " <> topLevelRendered <> ".from(data: data)"
        line "}"
        blank
        line $ "static func from(data: Data) -> " <> topLevelRendered <> "? {"
        indent do
            line "guard let json = try? JSONSerialization.jsonObject(with: data, options: []) else { return nil }"
            line $ "return " <> topLevelRendered <> ".from(any: json)"
        line "}"

        case topLevelType of
            IRArray _ ->  do
                blank
                line $ "static func from(any untyped: Any) -> " <> topLevelRendered <> "? {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "return " <> topLevelRendered <> "(elements)"
                line "}"
            IRMap _ -> do
                blank
                line $ "static func from(any untyped: Any) -> " <> topLevelRendered <> "? {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "var result = " <> topLevelRendered <> "()"
                    line "elements.forEach { result[$0.key] = $0.value }"
                    line "return result"
                line "}"
            IRClass _ -> do
                blank
                line $ "static func from(any untyped: Any) -> " <> topLevelRendered <> "? {"
                indent do
                    line $ "return " <> topLevelRendered <> "(fromAny: untyped)"
                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 "}"

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

    topLevelRendered <- renderType Swift4 topLevelType
    extensionType <- renderExtensionType Swift4 topLevelType

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "static func from(string json: String, using encoding: String.Encoding = .utf8) -> " <> topLevelRendered <> "? {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line $ "return " <> topLevelRendered <> ".from(data: data)"
        line "}"
        blank
        line $ "static func from(data: Data) -> " <> topLevelRendered <> "? {"
        indent do
            line "let decoder = JSONDecoder()"
            line $ "return try? decoder.decode(" <> topLevelRendered <> ".self, from: data)"
        line "}"

        blank
        line $ "var jsonData: Data? {"
        indent do
            line "let encoder = JSONEncoder()"
            line "return try? encoder.encode(self)"
        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 "}"

renderClassExtension3 :: String -> Map String IRType -> Doc Unit
renderClassExtension3 className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "extension " <> className <> " {"
    indent do
        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 "}"

renderClassExtension4 :: String -> Map String IRType -> Doc Unit
renderClassExtension4 className properties = do
    let propertyNames = makePropertyNames properties "" keywords
    when (M.size propertyNames > 0) do
        line $ "extension " <> className <> " {"
        indent do
            line "enum CodingKeys: String, CodingKey {"
            indent do
                for_ (M.toUnfoldable propertyNames :: Array (Tuple String String)) \(Tuple jsonName swiftName) -> do
                    if jsonName == swiftName
                        then line $ "case " <> swiftName
                        else line $ "case " <> swiftName <> " = \"" <> stringEscape jsonName <> "\""
            line "}"
        line "}"

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 :: Variant -> Boolean -> String -> IRUnionRep -> Doc Unit
renderUnionDefinition variant codable unionName unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "enum " <> unionName <> codableString codable <> " {"
    indent do
        forUnion_ nonNullUnion \typ -> do
            name <- caseName typ
            rendered <- renderType variant typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        when hasNull do
            name <- caseName IRNull
            line $ "case " <> name
    line "}"

renderUnionExtension3 :: String -> IRUnionRep -> Doc Unit
renderUnionExtension3 unionName unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "extension " <> unionName <> " {"
    indent do
        line $ "fileprivate static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            when hasNull do
                name <- caseName IRNull
                line "guard let v = removeNSNull(v)"
                line "else {"
                indent do
                    line $ "return ." <> name
                line "}"
            when (isUnionMember IRBool nonNullUnion) do
                renderCase IRBool
            when (isUnionMember IRInteger nonNullUnion) do
                renderCase IRInteger
            -- FIXME: this is ugly and inefficient
            for_ (L.difference (unionToList nonNullUnion) $ L.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "fileprivate var any: Any {"
        indent do
            line $ "switch self {"
            forUnion_ unionRep \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) }"

renderUnionExtension4 :: String -> IRUnionRep -> Doc Unit
renderUnionExtension4 unionName unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "extension " <> unionName <> " {"
    indent do
        line "init(from decoder: Decoder) throws {"
        indent do
            line "let container = try decoder.singleValueContainer()"
            when (isUnionMember IRBool nonNullUnion) do
                renderCase IRBool
            when (isUnionMember IRInteger nonNullUnion) do
                renderCase IRInteger
            -- FIXME: this is ugly and inefficient
            for_ (L.difference (unionToList nonNullUnion) $ L.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            when hasNull do
                name <- caseName IRNull
                line "if container.decodeNil() {"
                indent do
                    line $ "self = ." <> name
                    line "return"
                line "}"
            line $ "throw DecodingError.typeMismatch(" <> unionName <> ".self, DecodingError.Context(codingPath: decoder.codingPath, debugDescription: \"Wrong type for " <> unionName <> "\"))"
        line "}"
        blank
        line "func encode(to encoder: Encoder) throws {"
        indent do
            line "var container = encoder.singleValueContainer()"
            line "switch self {"
            for_ (unionToList nonNullUnion) \t -> do
                name <- caseName t
                line $ "case ." <> name <> "(let x):"
                indent do
                    line "try container.encode(x)"
            when hasNull do
                name <- caseName IRNull
                line $ "case ." <> name <> ":"
                indent do
                    line "try container.encodeNil()"
            line "}"
        line "}"
    line "}"
    where
        renderCase :: IRType -> Doc Unit
        renderCase t = do
            name <- caseName t
            typeName <- renderType Swift4 t
            line $ "if let x = try? container.decode(" <> typeName <> ".self) {"
            indent do
                line $ "self = ." <> name <> "(x)"
                line "return"
            line "}"

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

module Language.Swift
    ( swift3Renderer
    , swift4Renderer
    ) where

import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_, null)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.String as String
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Doc (Doc, Namer, Renderer, blank, combineNames, forEachClass_, forEachProperty_, forEachTopLevel_, forEachUnion_, forbidNamer, getTypeNameForUnion, indent, line, lookupClassName, lookupName, lookupUnionName, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, getGraph)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, canBeNull, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionToList, filterTypes)

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"
    ]

data Variant = Swift3 | Swift4

derive instance eqVariant :: Eq Variant

swift3Renderer :: Renderer
swift3Renderer =
    { displayName: "Swift 3"
    , names: [ "swift3" ]
    , aceMode: "swift"
    , extension: "swift"
    , doc: swift3Doc
    , options: []
    , 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")
            }
        }
    }

swift4Renderer :: Renderer
swift4Renderer =
    { displayName: "Swift 4"
    , names: [ "swift4", "swift" ]
    , aceMode: "swift"
    , extension: "swift"
    , doc: swift4Doc
    , options: []
    , 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")
            }
        }
    }

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter
    where
        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

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

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

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            "\\u{" <> (String.fromCharArray $ intToHex 0 i) <> "}"

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

swift3Doc :: Doc Unit
swift3Doc = do
    renderHeader

    renderRenderItems blank (Just $ renderTopLevelAlias Swift3) (renderClassDefinition Swift3 false) (Just $ renderUnionDefinition Swift3 false)

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions3

    forEachClass_ \className properties -> do
        blank
        renderClassExtension3 className properties

    forEachUnion_ \unionName unionRep -> do
        blank
        renderUnionExtension3 unionName unionRep

    blank
    supportFunctions3

swift4Doc :: Doc Unit
swift4Doc = do
    renderHeader

    renderRenderItems blank (Just $ renderTopLevelAlias Swift4) (renderClassDefinition Swift4 true) (Just $ renderUnionDefinition Swift4 true)

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions4

    forEachClass_ \className properties -> do
        blank
        renderClassExtension4 className properties

    forEachUnion_ \unionName unionRep -> do
        blank
        renderUnionExtension4 unionName unionRep

    blank
    supportFunctions4

supportFunctions3 :: Doc Unit
supportFunctions3 = 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?) -> NSNull? {
    if v != nil { return .none }
    return .some(NSNull())
}"""

anyAndNullPredicate :: IRType -> Maybe IRType
anyAndNullPredicate IRNull = Just IRNull
anyAndNullPredicate IRAnyType = Just IRAnyType
anyAndNullPredicate _ = Nothing

supportFunctions4 :: Doc Unit
supportFunctions4 = do
    graph <- getGraph
    let anyAndNullSet = filterTypes anyAndNullPredicate graph
    let needAny = S.member IRAnyType anyAndNullSet
    let needNull = needAny || S.member IRNull anyAndNullSet

    when (needAny || needNull) do
        line "// Helpers"
        blank

    when needNull do
        line """class JSONNull: Codable {
    public init() {
    }

    public required init(from decoder: Decoder) throws {
        let container = try decoder.singleValueContainer()
        if !container.decodeNil() {
            throw DecodingError.typeMismatch(JSONNull.self, DecodingError.Context(codingPath: decoder.codingPath, debugDescription: "Wrong type for JSONNull"))
        }
    }

    public func encode(to encoder: Encoder) throws {
        var container = encoder.singleValueContainer()
        try container.encodeNil()
    }
}"""

    when needAny do
        blank
        line """class JSONCodingKey : CodingKey {
    let key: String

    required init?(intValue: Int) {
        return nil
    }

    required init?(stringValue: String) {
        key = stringValue
    }

    var intValue: Int? {
        return nil
    }

    var stringValue: String {
        return key
    }
}

class JSONAny: Codable {
    public let value: Any

    static func decodingError(forCodingPath codingPath: [CodingKey]) -> DecodingError {
        let context = DecodingError.Context(codingPath: codingPath, debugDescription: "Cannot decode JSONAny")
        return DecodingError.typeMismatch(JSONAny.self, context)
    }

    static func encodingError(forValue value: Any, codingPath: [CodingKey]) -> EncodingError {
        let context = EncodingError.Context(codingPath: codingPath, debugDescription: "Cannot encode JSONAny")
        return EncodingError.invalidValue(value, context)
    }

    static func decode(from container: SingleValueDecodingContainer) throws -> Any {
        if let value = try? container.decode(Bool.self) {
            return value
        }
        if let value = try? container.decode(Int64.self) {
            return value
        }
        if let value = try? container.decode(Double.self) {
            return value
        }
        if let value = try? container.decode(String.self) {
            return value
        }
        if container.decodeNil() {
            return JSONNull()
        }
        throw decodingError(forCodingPath: container.codingPath)
    }

    static func decode(from container: inout UnkeyedDecodingContainer) throws -> Any {
        if let value = try? container.decode(Bool.self) {
            return value
        }
        if let value = try? container.decode(Int64.self) {
            return value
        }
        if let value = try? container.decode(Double.self) {
            return value
        }
        if let value = try? container.decode(String.self) {
            return value
        }
        if let value = try? container.decodeNil() {
            if value {
                return JSONNull()
            }
        }
        if var container = try? container.nestedUnkeyedContainer() {
            return try decodeArray(from: &container)
        }
        if var container = try? container.nestedContainer(keyedBy: JSONCodingKey.self) {
            return try decodeDictionary(from: &container)
        }
        throw decodingError(forCodingPath: container.codingPath)
    }

    static func decode(from container: inout KeyedDecodingContainer<JSONCodingKey>, forKey key: JSONCodingKey) throws -> Any {
        if let value = try? container.decode(Bool.self, forKey: key) {
            return value
        }
        if let value = try? container.decode(Int64.self, forKey: key) {
            return value
        }
        if let value = try? container.decode(Double.self, forKey: key) {
            return value
        }
        if let value = try? container.decode(String.self, forKey: key) {
            return value
        }
        if let value = try? container.decodeNil(forKey: key) {
            if value {
                return JSONNull()
            }
        }
        if var container = try? container.nestedUnkeyedContainer(forKey: key) {
            return try decodeArray(from: &container)
        }
        if var container = try? container.nestedContainer(keyedBy: JSONCodingKey.self, forKey: key) {
            return try decodeDictionary(from: &container)
        }
        throw decodingError(forCodingPath: container.codingPath)
    }

    static func decodeArray(from container: inout UnkeyedDecodingContainer) throws -> [Any] {
        var arr: [Any] = []
        while !container.isAtEnd {
            let value = try decode(from: &container)
            arr.append(value)
        }
        return arr
    }

    static func decodeDictionary(from container: inout KeyedDecodingContainer<JSONCodingKey>) throws -> [String: Any] {
        var dict = [String: Any]()
        for key in container.allKeys {
            let value = try decode(from: &container, forKey: key)
            dict[key.stringValue] = value
        }
        return dict
    }

    static func encode(to container: inout UnkeyedEncodingContainer, array: [Any]) throws {
        for value in array {
            if let value = value as? Bool {
                try container.encode(value)
            } else if let value = value as? Int64 {
                try container.encode(value)
            } else if let value = value as? Double {
                try container.encode(value)
            } else if let value = value as? String {
                try container.encode(value)
            } else if value is JSONNull {
                try container.encodeNil()
            } else if let value = value as? [Any] {
                var container = container.nestedUnkeyedContainer()
                try encode(to: &container, array: value)
            } else if let value = value as? [String: Any] {
                var container = container.nestedContainer(keyedBy: JSONCodingKey.self)
                try encode(to: &container, dictionary: value)
            } else {
                throw encodingError(forValue: value, codingPath: container.codingPath)
            }
        }
    }

    static func encode(to container: inout KeyedEncodingContainer<JSONCodingKey>, dictionary: [String: Any]) throws {
        for (key, value) in dictionary {
            let key = JSONCodingKey(stringValue: key)!
            if let value = value as? Bool {
                try container.encode(value, forKey: key)
            } else if let value = value as? Int64 {
                try container.encode(value, forKey: key)
            } else if let value = value as? Double {
                try container.encode(value, forKey: key)
            } else if let value = value as? String {
                try container.encode(value, forKey: key)
            } else if value is JSONNull {
                try container.encodeNil(forKey: key)
            } else if let value = value as? [Any] {
                var container = container.nestedUnkeyedContainer(forKey: key)
                try encode(to: &container, array: value)
            } else if let value = value as? [String: Any] {
                var container = container.nestedContainer(keyedBy: JSONCodingKey.self, forKey: key)
                try encode(to: &container, dictionary: value)
            } else {
                throw encodingError(forValue: value, codingPath: container.codingPath)
            }
        }
    }

    static func encode(to container: inout SingleValueEncodingContainer, value: Any) throws {
        if let value = value as? Bool {
            try container.encode(value)
        } else if let value = value as? Int64 {
            try container.encode(value)
        } else if let value = value as? Double {
            try container.encode(value)
        } else if let value = value as? String {
            try container.encode(value)
        } else if value is JSONNull {
            try container.encodeNil()
        } else {
            throw encodingError(forValue: value, codingPath: container.codingPath)
        }
    }

    public required init(from decoder: Decoder) throws {
        if var arrayContainer = try? decoder.unkeyedContainer() {
            self.value = try JSONAny.decodeArray(from: &arrayContainer)
        } else if var container = try? decoder.container(keyedBy: JSONCodingKey.self) {
            self.value = try JSONAny.decodeDictionary(from: &container)
        } else {
            let container = try decoder.singleValueContainer()
            self.value = try JSONAny.decode(from: container)
        }
    }

    public func encode(to encoder: Encoder) throws {
        if let arr = self.value as? [Any] {
            var container = encoder.unkeyedContainer()
            try JSONAny.encode(to: &container, array: arr)
        } else if let dict = self.value as? [String: Any] {
            var container = encoder.container(keyedBy: JSONCodingKey.self)
            try JSONAny.encode(to: &container, dictionary: dict)
        } else {
            var container = encoder.singleValueContainer()
            try JSONAny.encode(to: &container, value: self.value)
        }
    }
}"""

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

renderType :: Variant -> IRType -> Doc String
renderType variant = case _ of
    IRNoInformation -> pure "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType ->
        case variant of
        Swift4 -> pure "JSONAny"
        Swift3 -> pure "Any?"
    IRNull ->
        case variant of
        Swift4 -> pure "JSONNull"
        Swift3 -> pure "NSNull"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType variant a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType variant t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion variant 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 nullableFromUnion ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(" <> converter <> ", " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRAnyType 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
        pure $ name <> ".init(fromAny:)"
    IRUnion ur ->
        case nullableFromUnion 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 nullableFromUnion ur of
    Just t -> do
        convertCode <- convertToAny t "$0"
        pure $ var <> ".map({ " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".any"
convertToAny IRAnyType var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull()"
convertToAny _ var =
    pure $ var <> " as Any"

renderTopLevelAlias :: Variant -> String -> IRType -> Doc Unit
renderTopLevelAlias variant topLevelName topLevelType = do
    top <- renderType variant topLevelType
    line $ "typealias "<> topLevelName <> " = " <> top

codableString :: Boolean -> String
codableString true = ": Codable"
codableString false = ""

renderClassDefinition :: Variant -> Boolean -> String -> Map String IRType -> Doc Unit
renderClassDefinition variant codable className properties = do
    let forbidden = keywords <> ["json", "any"]
    -- FIXME: we compute these here, and later again when rendering the extension
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "class " <> className <> codableString codable <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType variant ptype
            line $ "let " <> fieldName <> ": " <> rendered
        when (variant == Swift3) do
            blank
            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 "}"
    line "}"

renderExtensionType :: Variant -> IRType -> Doc String
renderExtensionType variant (IRArray t) = ("Array where Element == " <> _) <$> renderType variant t
renderExtensionType variant (IRMap t) = ("Dictionary where Key == String, Value == " <> _) <$> renderType variant t
renderExtensionType variant t = renderType variant t

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

    topLevelRendered <- renderType Swift3 topLevelType
    extensionType <- renderExtensionType Swift3 topLevelType

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "static func from(string json: String, using encoding: String.Encoding = .utf8) -> " <> topLevelRendered <> "? {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line $ "return " <> topLevelRendered <> ".from(data: data)"
        line "}"
        blank
        line $ "static func from(data: Data) -> " <> topLevelRendered <> "? {"
        indent do
            line "guard let json = try? JSONSerialization.jsonObject(with: data, options: []) else { return nil }"
            line $ "return " <> topLevelRendered <> ".from(any: json)"
        line "}"

        case topLevelType of
            IRArray _ ->  do
                blank
                line $ "static func from(any untyped: Any) -> " <> topLevelRendered <> "? {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "return " <> topLevelRendered <> "(elements)"
                line "}"
            IRMap _ -> do
                blank
                line $ "static func from(any untyped: Any) -> " <> topLevelRendered <> "? {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "var result = " <> topLevelRendered <> "()"
                    line "elements.forEach { result[$0.key] = $0.value }"
                    line "return result"
                line "}"
            IRClass _ -> do
                blank
                line $ "static func from(any untyped: Any) -> " <> topLevelRendered <> "? {"
                indent do
                    line $ "return " <> topLevelRendered <> "(fromAny: untyped)"
                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 "}"

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

    topLevelRendered <- renderType Swift4 topLevelType
    extensionType <- renderExtensionType Swift4 topLevelType

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "static func from(string json: String, using encoding: String.Encoding = .utf8) -> " <> topLevelRendered <> "? {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line $ "return " <> topLevelRendered <> ".from(data: data)"
        line "}"
        blank
        line $ "static func from(data: Data) -> " <> topLevelRendered <> "? {"
        indent do
            line "let decoder = JSONDecoder()"
            line $ "return try? decoder.decode(" <> topLevelRendered <> ".self, from: data)"
        line "}"

        blank
        line $ "var jsonData: Data? {"
        indent do
            line "let encoder = JSONEncoder()"
            line "return try? encoder.encode(self)"
        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 "}"

renderClassExtension3 :: String -> Map String IRType -> Doc Unit
renderClassExtension3 className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "extension " <> className <> " {"
    indent do
        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 "}"

renderClassExtension4 :: String -> Map String IRType -> Doc Unit
renderClassExtension4 className properties = do
    let propertyNames = makePropertyNames properties "" keywords
    when (M.size propertyNames > 0) do
        line $ "extension " <> className <> " {"
        indent do
            line "enum CodingKeys: String, CodingKey {"
            indent do
                for_ (M.toUnfoldable propertyNames :: Array (Tuple String String)) \(Tuple jsonName swiftName) -> do
                    line $ "case " <> swiftName <> " = \"" <> stringEscape jsonName <> "\""
            line "}"
        line "}"

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 :: Variant -> Boolean -> String -> IRUnionRep -> Doc Unit
renderUnionDefinition variant codable unionName unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "enum " <> unionName <> codableString codable <> " {"
    indent do
        forUnion_ nonNullUnion \typ -> do
            name <- caseName typ
            rendered <- renderType variant typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        when hasNull do
            name <- caseName IRNull
            line $ "case " <> name
    line "}"

renderUnionExtension3 :: String -> IRUnionRep -> Doc Unit
renderUnionExtension3 unionName unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "extension " <> unionName <> " {"
    indent do
        line $ "fileprivate static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            when hasNull do
                name <- caseName IRNull
                line "guard let v = removeNSNull(v)"
                line "else {"
                indent do
                    line $ "return ." <> name
                line "}"
            when (isUnionMember IRBool nonNullUnion) do
                renderCase IRBool
            when (isUnionMember IRInteger nonNullUnion) do
                renderCase IRInteger
            -- FIXME: this is ugly and inefficient
            for_ (L.difference (unionToList nonNullUnion) $ L.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "fileprivate var any: Any {"
        indent do
            line $ "switch self {"
            forUnion_ unionRep \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) }"

renderUnionExtension4 :: String -> IRUnionRep -> Doc Unit
renderUnionExtension4 unionName unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "extension " <> unionName <> " {"
    indent do
        line "init(from decoder: Decoder) throws {"
        indent do
            line "let container = try decoder.singleValueContainer()"
            when (isUnionMember IRBool nonNullUnion) do
                renderCase IRBool
            when (isUnionMember IRInteger nonNullUnion) do
                renderCase IRInteger
            -- FIXME: this is ugly and inefficient
            for_ (L.difference (unionToList nonNullUnion) $ L.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            when hasNull do
                name <- caseName IRNull
                line "if container.decodeNil() {"
                indent do
                    line $ "self = ." <> name
                    line "return"
                line "}"
            line $ "throw DecodingError.typeMismatch(" <> unionName <> ".self, DecodingError.Context(codingPath: decoder.codingPath, debugDescription: \"Wrong type for " <> unionName <> "\"))"
        line "}"
        blank
        line "func encode(to encoder: Encoder) throws {"
        indent do
            line "var container = encoder.singleValueContainer()"
            line "switch self {"
            for_ (unionToList nonNullUnion) \t -> do
                name <- caseName t
                line $ "case ." <> name <> "(let x):"
                indent do
                    line "try container.encode(x)"
            when hasNull do
                name <- caseName IRNull
                line $ "case ." <> name <> ":"
                indent do
                    line "try container.encodeNil()"
            line "}"
        line "}"
    line "}"
    where
        renderCase :: IRType -> Doc Unit
        renderCase t = do
            name <- caseName t
            typeName <- renderType Swift4 t
            line $ "if let x = try? container.decode(" <> typeName <> ".self) {"
            indent do
                line $ "self = ." <> name <> "(x)"
                line "return"
            line "}"

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


Open external links in a new tab

Open external links in a new tab

module App.View where

import Text.Smolder.HTML hiding (address)

import App.State (Event(..), State)
import App.State.Contracts as Contracts
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Signers as Signers
import Data.Array (fromFoldable)
import Data.Map (toUnfoldable, values)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.String (drop, length, take)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.SignHash.Contracts (getAddress)
import Lib.SignHash.Proofs.Display (SignerDisplayStatus(..), signerDisplayStatus)
import Lib.SignHash.Proofs.Methods (ProofMethod(..), canonicalName)
import Lib.SignHash.Proofs.Types (ProofState(..), ProofVerification(..))
import Lib.SignHash.Proofs.Values as ProofValues
import Lib.SignHash.Types (Address(..), HashSigner(..))
import Prelude (discard, show, ($), (<>), (-))
import Pux.DOM.Events (onChange, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, src, type')
import Text.Smolder.HTML.Attributes as A
import Text.Smolder.Markup (Attribute, attribute, text, (!), (#!))

foreign import images ::
  { logo :: String
  , ethIcon :: String }

dataQA :: String -> Attribute
dataQA = attribute "data-qa"

view :: State -> HTML Event
view { file, signer, contracts } =
  do
    div ! className "Content" $ do
      div ! className "Header" $ do
        img ! src images.logo
        span ! className "title" $ text "SignHash"
        hr

      child FileInput viewFileInput $ isJust file
      case file of
        Nothing -> empty
        Just loaded -> do
          viewFile loaded
          div $ signerStatus loaded.signer

      hr
      div ! className "Contracts-info" $ do
        viewContracts contracts
      clear

  where
    signerStatus = case _ of
      Nothing -> signerHeader "Loading signer..."
      Just (NoSigner) -> signerHeader "No signers"
      Just (HashSigner s) -> do
        signerHeader "Signers"
        case signer of
          Nothing -> div do
            text loading
            hr
          Just value -> div do
            child Signer viewSigner $ value

    signerHeader msg =
      h4 ! className "Signer-header" $ text msg

viewContracts :: Contracts.State -> HTML Event
viewContracts Contracts.Loading =
  text $ "Loading contract..."
viewContracts (Contracts.Loaded state) = do
  span $ text $ "Contract: "
  span ! dataQA "contract-address"
    $ text $ show $ getAddress state.signerContract
viewContracts (Contracts.Error err) = do
  div
    ! A.title err
    $ text "Error while loading contract"

viewFileInput :: Boolean -> HTML FileInputs.Event
viewFileInput small =
  div do
    label
      ! for "file-upload"
      ! className ("File-upload" <> if small then " small" else "")
      #! onDrop FileInputs.newFilesEvent
      #! onDragOver (FileInputs.PreventDefault FileInputs.NoOp)
      $ do
        renderIcon "fa-file-o"
        text "Verify a file"
        if small then empty else
          div ! className "hint"
          $ text "Click or drag and drop on the page"

    input
      ! id "file-upload"
      ! type' "file"
      #! onChange FileInputs.newFilesEvent

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } = do
  div ! className "Files Section" $ do
    div ! className "row" $ do
      renderRow "Filename" $ text $ meta.name
      renderRow "SHA256" $ maybe (text loading) renderHash result
      renderRow "Size" $ renderSize meta.size

  where
    renderRow label value =
      div ! className "columns attribute four" $ do
        span ! className "header" $ text (label <> ":")
        span ! className "value" $ value

    renderSigner (HashSigner address) = show address
    renderSigner NoSigner = "Not signed"

    renderHash { hash } =
      let visibleOffset = 6
      in a
         ! dataQA "checksum"
         ! A.title hash
         ! A.href "#"
         $ text $ take visibleOffset hash
           <> "..."
           <> drop (length hash - visibleOffset) hash

    renderSize size = text $ show meta.size <> " B"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs, blockie } = do
  div ! className "Signer" $ do
    div ! className "header" $ do
      span ! className "status" $ do
        viewSignerStatus
    viewProofs address proofArray
    clear
  where
    proofStates = fromFoldable $ values proofs

    proofArray :: Array (Tuple ProofMethod ProofState)
    proofArray = toUnfoldable proofs

    viewSignerStatus =
      case signerDisplayStatus proofStates of
        SignerLoading -> renderIcon "fa-circle-o-notch loading"
        SignerVerified -> renderBlockie blockie
        SignerVerificationFailed -> renderIcon "fa-exclamation-circle failed"
        SignerNetworkError -> renderIcon "fa-question-circle-o network-error"

viewProofs ::
  Address
  -> Array (Tuple ProofMethod ProofState)
  -> HTML Signers.Event
viewProofs address proofs =
  div ! className "proofs" $ do
    renderEthProof
    for_ proofs renderProof
  where
    renderProof (Tuple method state) = do
      case state of
        Finished result -> renderFinishedProof method result
        NetworkError -> renderNetworkError method
        Pending -> empty

    renderFinishedProof method Unavailable = empty
    renderFinishedProof method (Unverified error) =
      div
        ! className ("proof " <> "failed")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          span ! dataQA "error" ! A.title (show error)
            $ text $ show method <> " verification failed"

    renderFinishedProof method (Verified proofValue) =
      div
        ! className ("proof " <> "verified")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          a ! A.href (methodHref method proof) ! A.target "_blank" $ text proof
      where
        proof = ProofValues.extract proofValue

    renderNetworkError method =
      div ! className ("proof" <> "network-error") $ do
        methodIcon method
        text $ "Network error while fetching proof"

    renderEthProof =
      div ! className "proof" $ do
        renderEthIcon
        a ! A.href (addressURL address) ! A.target "_blank" $ text $ (show address)

    methodIcon GitHub = renderIcon "fa-github"
    methodIcon HTTP = renderIcon "fa-world"

    methodHref GitHub username =
      "https://github.com/" <> username
    methodHref HTTP domain =
      "http://" <> domain

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa fa-lg " <> name) $ text ""

renderEthIcon :: forall a. Html a
renderEthIcon =
  img
  ! className "Icon"
  ! src images.ethIcon

renderBlockie :: forall a. String -> HTML a
renderBlockie blockieSrc =
  img ! className "blockie" ! src blockieSrc

loading :: String
loading = "Loading..."

empty :: forall a. HTML a
empty = text ""

clear :: forall a. HTML a
clear = div ! className "Clear" $ empty

addressURL :: Address -> String
addressURL (Address address) =
  "https://etherscan.io/address/" <> address

module App.View where

import Text.Smolder.HTML hiding (address)

import App.State (Event(..), State)
import App.State.Contracts as Contracts
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Signers as Signers
import Data.Array (fromFoldable)
import Data.Map (toUnfoldable, values)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.String (drop, length, take)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.SignHash.Contracts (getAddress)
import Lib.SignHash.Proofs.Display (SignerDisplayStatus(..), signerDisplayStatus)
import Lib.SignHash.Proofs.Methods (ProofMethod(..), canonicalName)
import Lib.SignHash.Proofs.Types (ProofState(..), ProofVerification(..))
import Lib.SignHash.Proofs.Values as ProofValues
import Lib.SignHash.Types (Address(..), HashSigner(..))
import Prelude (discard, show, ($), (<>), (-))
import Pux.DOM.Events (onChange, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, src, type')
import Text.Smolder.HTML.Attributes as A
import Text.Smolder.Markup (Attribute, attribute, text, (!), (#!))

foreign import images ::
  { logo :: String
  , ethIcon :: String }

dataQA :: String -> Attribute
dataQA = attribute "data-qa"

view :: State -> HTML Event
view { file, signer, contracts } =
  do
    div ! className "Content" $ do
      div ! className "Header" $ do
        img ! src images.logo
        span ! className "title" $ text "SignHash"
        hr

      child FileInput viewFileInput $ isJust file
      case file of
        Nothing -> empty
        Just loaded -> do
          viewFile loaded
          div $ signerStatus loaded.signer

      hr
      div ! className "Contracts-info" $ do
        viewContracts contracts
      clear

  where
    signerStatus = case _ of
      Nothing -> signerHeader "Loading signer..."
      Just (NoSigner) -> signerHeader "No signers"
      Just (HashSigner s) -> do
        signerHeader "Signers"
        case signer of
          Nothing -> div do
            text loading
            hr
          Just value -> div do
            child Signer viewSigner $ value

    signerHeader msg =
      h4 ! className "Signer-header" $ text msg

viewContracts :: Contracts.State -> HTML Event
viewContracts Contracts.Loading =
  text $ "Loading contract..."
viewContracts (Contracts.Loaded state) = do
  span $ text $ "Contract: "
  span ! dataQA "contract-address"
    $ text $ show $ getAddress state.signerContract
viewContracts (Contracts.Error err) = do
  div
    ! A.title err
    $ text "Error while loading contract"

viewFileInput :: Boolean -> HTML FileInputs.Event
viewFileInput small =
  div do
    label
      ! for "file-upload"
      ! className ("File-upload" <> if small then " small" else "")
      #! onDrop FileInputs.newFilesEvent
      #! onDragOver (FileInputs.PreventDefault FileInputs.NoOp)
      $ do
        renderIcon "fa-file-o"
        text "Verify a file"
        if small then empty else
          div ! className "hint"
          $ text "Click or drag and drop on the page"

    input
      ! id "file-upload"
      ! type' "file"
      #! onChange FileInputs.newFilesEvent

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } = do
  div ! className "Files Section" $ do
    div ! className "row" $ do
      renderRow "Filename" $ text $ meta.name
      renderRow "SHA256" $ maybe (text loading) renderHash result
      renderRow "Size" $ renderSize meta.size

  where
    renderRow label value =
      div ! className "columns attribute four" $ do
        span ! className "header" $ text (label <> ":")
        span ! className "value" $ value

    renderSigner (HashSigner address) = show address
    renderSigner NoSigner = "Not signed"

    renderHash { hash } =
      let visibleOffset = 6
      in a
         ! dataQA "checksum"
         ! A.title hash
         ! A.href "#"
         $ text $ take visibleOffset hash
           <> "..."
           <> drop (length hash - visibleOffset) hash

    renderSize size = text $ show meta.size <> " B"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs, blockie } = do
  div ! className "Signer" $ do
    div ! className "header" $ do
      span ! className "status" $ do
        viewSignerStatus
    viewProofs address proofArray
    clear
  where
    proofStates = fromFoldable $ values proofs

    proofArray :: Array (Tuple ProofMethod ProofState)
    proofArray = toUnfoldable proofs

    viewSignerStatus =
      case signerDisplayStatus proofStates of
        SignerLoading -> renderIcon "fa-circle-o-notch loading"
        SignerVerified -> renderBlockie blockie
        SignerVerificationFailed -> renderIcon "fa-exclamation-circle failed"
        SignerNetworkError -> renderIcon "fa-question-circle-o network-error"

viewProofs ::
  Address
  -> Array (Tuple ProofMethod ProofState)
  -> HTML Signers.Event
viewProofs address proofs =
  div ! className "proofs" $ do
    renderEthProof
    for_ proofs renderProof
  where
    renderProof (Tuple method state) = do
      case state of
        Finished result -> renderFinishedProof method result
        NetworkError -> renderNetworkError method
        Pending -> empty

    renderFinishedProof method Unavailable = empty
    renderFinishedProof method (Unverified error) =
      div
        ! className ("proof " <> "failed")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          span ! dataQA "error" ! A.title (show error)
            $ text $ show method <> " verification failed"

    renderFinishedProof method (Verified proofValue) =
      div
        ! className ("proof " <> "verified")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          a ! A.href (methodHref method proof) $ text proof
      where
        proof = ProofValues.extract proofValue

    renderNetworkError method =
      div ! className ("proof" <> "network-error") $ do
        methodIcon method
        text $ "Network error while fetching proof"

    renderEthProof =
      div ! className "proof" $ do
        renderEthIcon
        a ! A.href (addressURL address) $ text $ (show address)

    methodIcon GitHub = renderIcon "fa-github"
    methodIcon HTTP = renderIcon "fa-world"

    methodHref GitHub username =
      "https://github.com/" <> username
    methodHref HTTP domain =
      "http://" <> domain

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa fa-lg " <> name) $ text ""

renderEthIcon :: forall a. Html a
renderEthIcon =
  img
  ! className "Icon"
  ! src images.ethIcon

renderBlockie :: forall a. String -> HTML a
renderBlockie blockieSrc =
  img ! className "blockie" ! src blockieSrc

loading :: String
loading = "Loading..."

empty :: forall a. HTML a
empty = text ""

clear :: forall a. HTML a
clear = div ! className "Clear" $ empty

addressURL :: Address -> String
addressURL (Address address) =
  "https://etherscan.com/address/" <> address


Publish method to get foreign minimist output

module Minimist
    ( Arg(..)
    , MinimistOptions
    , interpretAsStrings
    , interpretAsBooleans
    , aliases
    , defaults
    , stopEarly
    , splitOnDoubleDash
    , unknown
    , parseArgs
    ) where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Except (runExcept)
import Data.Either (Either, either, fromRight)
import Data.Foreign (Foreign, toForeign, unsafeFromForeign)
import Data.Foreign.Class (class AsForeign, class IsForeign, read, write)
import Data.Functor.Contravariant ((>#<))
import Data.Options (Option, Options, opt, options)
import Data.StrMap (StrMap)
import Partial.Unsafe (unsafePartial)

-- | Phantom data type of options for the minimist parser
data MinimistOptions

-- | Array of strings to always be interpreted as strings
interpretAsStrings :: Option MinimistOptions (Array String)
interpretAsStrings = opt "strings"

-- | Array of strings to always be interpreted as booleans
-- | or a boolean value indicating that all options starting
-- | with `--` that don't contain an equals sign should be
-- | interpreted as booleans
interpretAsBooleans :: Option MinimistOptions (Either Boolean (Array String))
interpretAsBooleans = opt "boolean" >#< either toForeign toForeign

-- | Mapping of strings to a list of aliases for that option
aliases :: Option MinimistOptions (StrMap (Array String))
aliases = opt "alias"

-- | Mapping of strings to default argument values
defaults :: Option MinimistOptions (StrMap Arg)
defaults = opt "default" >#< (<$>) write

-- | When `true`, argument parsing will stop at the first non-flag
stopEarly :: Option MinimistOptions Boolean
stopEarly = opt "stopEarly"

-- | When `true`, all options appearing after `--` will be placed
-- | into `--` instead of `_` in the result mapping
splitOnDoubleDash :: Option MinimistOptions Boolean
splitOnDoubleDash = opt "--"

-- | Function to be called with every argument not found in the
-- | configuration object. If the function retruns false, then the
-- | argument is not added to argv.
unknown :: Option MinimistOptions (String -> Boolean)
unknown = opt "unknown"

foreign import parseArgsForeign :: Array String -> Foreign -> Foreign

-- | Data type representing the value of an argument in `argv`
data Arg = ArgString String
         | ArgFlag Boolean
         | ArgInt Int
         | ArgNum Number
         | ArgArray (Array Arg)

derive instance eqArg :: Eq Arg

instance showArg :: Show Arg where
    show (ArgString str) = str
    show (ArgFlag flag) = show flag
    show (ArgInt i) = show i
    show (ArgNum n) = show n
    show (ArgArray a) = show a

instance argIsForeign :: IsForeign Arg where
    read value =
        (ArgString <$> read value) <|>
        (ArgFlag <$> read value) <|>
        (ArgInt <$> read value) <|>
        (ArgNum <$> read value) <|>
        (ArgArray <$> read value)

instance argAsForeign :: AsForeign Arg where
    write (ArgString s) = write s
    write (ArgFlag b) = write b
    write (ArgInt i) = write i
    write (ArgNum n) = write n
    write (ArgArray a) = write a

-- | Parse arguments with a set of minimist options into an `argv` representation,
-- | mapping argument names to `Arg` values.
parseArgs :: Array String -> Options MinimistOptions -> StrMap Arg
parseArgs args opts = foreignToArg <$> (unsafeFromForeign $ parseArgsForeign args $ options opts) where
    foreignToArg :: Foreign -> Arg
    foreignToArg value = unsafePartial fromRight (runExcept $ read value)

module Minimist
    ( Arg(..)
    , MinimistOptions
    , interpretAsStrings
    , interpretAsBooleans
    , aliases
    , defaults
    , stopEarly
    , splitOnDoubleDash
    , unknown
    , parseArgs
    ) where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Except (runExcept)
import Data.Either (Either, either, fromRight)
import Data.Foreign (Foreign, toForeign)
import Data.Foreign.Class (class AsForeign, class IsForeign, read, write)
import Data.Functor.Contravariant ((>#<))
import Data.Options (Option, Options, opt, options)
import Data.StrMap (StrMap)
import Partial.Unsafe (unsafePartial)

-- | Phantom data type of options for the minimist parser
data MinimistOptions

-- | Array of strings to always be interpreted as strings
interpretAsStrings :: Option MinimistOptions (Array String)
interpretAsStrings = opt "strings"

-- | Array of strings to always be interpreted as booleans
-- | or a boolean value indicating that all options starting
-- | with `--` that don't contain an equals sign should be
-- | interpreted as booleans
interpretAsBooleans :: Option MinimistOptions (Either Boolean (Array String))
interpretAsBooleans = opt "boolean" >#< either toForeign toForeign

-- | Mapping of strings to a list of aliases for that option
aliases :: Option MinimistOptions (StrMap (Array String))
aliases = opt "alias"

-- | Mapping of strings to default argument values
defaults :: Option MinimistOptions (StrMap Arg)
defaults = opt "default" >#< (<$>) write

-- | When `true`, argument parsing will stop at the first non-flag
stopEarly :: Option MinimistOptions Boolean
stopEarly = opt "stopEarly"

-- | When `true`, all options appearing after `--` will be placed
-- | into `--` instead of `_` in the result mapping
splitOnDoubleDash :: Option MinimistOptions Boolean
splitOnDoubleDash = opt "--"

-- | Function to be called with every argument not found in the
-- | configuration object. If the function retruns false, then the
-- | argument is not added to argv.
unknown :: Option MinimistOptions (String -> Boolean)
unknown = opt "unknown"

foreign import parseArgsForeign :: Array String -> Foreign -> StrMap Foreign

-- | Data type representing the value of an argument in `argv`
data Arg = ArgString String
         | ArgFlag Boolean
         | ArgInt Int
         | ArgNum Number
         | ArgArray (Array Arg)

derive instance eqArg :: Eq Arg

instance showArg :: Show Arg where
    show (ArgString str) = str
    show (ArgFlag flag) = show flag
    show (ArgInt i) = show i
    show (ArgNum n) = show n
    show (ArgArray a) = show a

instance argIsForeign :: IsForeign Arg where
    read value =
        (ArgString <$> read value) <|>
        (ArgFlag <$> read value) <|>
        (ArgInt <$> read value) <|>
        (ArgNum <$> read value) <|>
        (ArgArray <$> read value)

instance argAsForeign :: AsForeign Arg where
    write (ArgString s) = write s
    write (ArgFlag b) = write b
    write (ArgInt i) = write i
    write (ArgNum n) = write n
    write (ArgArray a) = write a

-- | Parse arguments with a set of minimist options into an `argv` representation,
-- | mapping argument names to `Arg` values.
parseArgs :: Array String -> Options MinimistOptions -> StrMap Arg
parseArgs args opts = (<$>) foreignToArg (parseArgsForeign args $ options opts) where
    foreignToArg :: Foreign -> Arg
    foreignToArg value = unsafePartial fromRight (runExcept $ read value)


Switch to set infix

Switch to set infix

module Main where

import Prelude
import Data.Maybe
import Data.Traversable
import Data.JSON
import ChartJs
import WebSocket
import qualified Control.Monad.Eff.Console as C
import Control.Monad.Eff (Eff ())
import Control.Monad.Eff.Exception
import Control.Monad.Trans (lift)
import Control.Monad.Maybe.Trans
import qualified Control.Monad.Eff.JQuery as J
import Data.Either (Either (Left, Right))
import DOM
import Graphics.Canvas
import Optic.Core

main :: forall eff. Eff (ws :: WS, console :: C.CONSOLE, dom :: DOM, canvas::Canvas, err :: EXCEPTION | eff) Unit
main = do
  C.log "START"
  runWebSocket $ do
    result <- withWebSocket config handlers
    case result of
         Right _ -> output "DONE"
         Left err -> output err

config :: WebSocketConfig
config =
  { uri: "ws://127.0.0.1:9001"
  , protocols: []
  }

handlers :: forall eff. WebSocketHandler (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff)
handlers s = (defaultHandlers s)
  { onOpen = onOpenHandler
  , onMessage = onMessageHandler
  }

onOpenHandler :: forall eff. WithWebSocket (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff) Unit
onOpenHandler = C.log "OPEN"

onMessageHandler :: forall eff. String -> WithWebSocket (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff) Unit
onMessageHandler msg = do
  case (decode msg :: Maybe Cpu) of
    Just c -> do
      initGraph "bar" $ initBar c
      C.log $ "Successfully parsed" ++ show c
    Nothing -> C.log "Failed to parse message"
  return unit

output :: forall eff. String -> WebSocket (console :: C.CONSOLE | eff) Unit
output = lift <<< C.log

initGraph
  :: forall eff
   . String
  -> (Chart -> Eff( dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff ) ChartType)
  -> Eff ( dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff ) Unit
initGraph name f = void $ do
  cMay  <- getCanvasElementById cId
  c     <- maybe (die $ "Could not find canvas: " <> cId) pure cMay
  ctx   <- getContext2D c
  chart <- newChart ctx
  ct    <- f chart
  lt    <- generateLegend ct
  leg   <- J.select $ "#" <> lId
  J.appendText lt leg
  where
    cId = name <> "-canvas"
    lId = name <> "-legend"

initBar
  :: forall eff
   . Cpu
  -> Chart
  -> Eff ( dom :: DOM , err :: EXCEPTION, canvas:: Canvas | eff ) ChartType
initBar (Cpu {cpuData = cpuData}) c =
  barChart c barData (responsiveChartConfig hmonBarChartCfg)
  where
    barData = {
      labels : ["user","nice","system","idle","iowait","irq","softirq"],
      datasets : [
        { fillColor : "rgba(2,136,209,0.75)"
        , strokeColor : "rgba(220,220,220,0.8)"
        , highlightFill: "rgba(255,82,82,0.75)"
        , highlightStroke: "rgba(220,220,220,1)"
        , data : cpuData
        }
        ]}

hmonChartCfg :: ChartConfig
hmonChartCfg = animation .~ false $ defGlobalChartConfig

hmonBarChartCfg :: BarChartConfig
hmonBarChartCfg = responsiveChartConfig $ global .~ hmonChartCfg $ legendTemplate .~ "" $ defBarChartConfig

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

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

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

die :: forall eff a. String -> Eff( err:: EXCEPTION | eff ) a
die = error >>> throwException

data Cpu = Cpu {
              cpuData :: Array Number
           }

instance showCpu :: Show Cpu where
  show (Cpu cData) = "CPU: "

instance cpuFromJSON :: FromJSON Cpu where
  parseJSON (JObject o) = do
    d <- o .: "cpu"
    return $ Cpu {cpuData: d}

module Main where

import Prelude
import Data.Maybe
import Data.Traversable
import Data.JSON
import ChartJs
import WebSocket
import qualified Control.Monad.Eff.Console as C
import Control.Monad.Eff (Eff ())
import Control.Monad.Eff.Exception
import Control.Monad.Trans (lift)
import Control.Monad.Maybe.Trans
import qualified Control.Monad.Eff.JQuery as J
import Data.Either (Either (Left, Right))
import DOM
import Graphics.Canvas
import Optic.Core

main :: forall eff. Eff (ws :: WS, console :: C.CONSOLE, dom :: DOM, canvas::Canvas, err :: EXCEPTION | eff) Unit
main = do
  C.log "START"
  runWebSocket $ do
    result <- withWebSocket config handlers
    case result of
         Right _ -> output "DONE"
         Left err -> output err

config :: WebSocketConfig
config =
  { uri: "ws://127.0.0.1:9001"
  , protocols: []
  }

handlers :: forall eff. WebSocketHandler (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff)
handlers s = (defaultHandlers s)
  { onOpen = onOpenHandler
  , onMessage = onMessageHandler
  }

onOpenHandler :: forall eff. WithWebSocket (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff) Unit
onOpenHandler = C.log "OPEN"

onMessageHandler :: forall eff. String -> WithWebSocket (console :: C.CONSOLE, dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff) Unit
onMessageHandler msg = do
  case (decode msg :: Maybe Cpu) of
    Just c -> do
      initGraph "bar" $ initBar c
      C.log $ "Successfully parsed" ++ show c
    Nothing -> C.log "Failed to parse message"
  return unit

output :: forall eff. String -> WebSocket (console :: C.CONSOLE | eff) Unit
output = lift <<< C.log

initGraph
  :: forall eff
   . String
  -> (Chart -> Eff( dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff ) ChartType)
  -> Eff ( dom :: DOM , err :: EXCEPTION, canvas :: Canvas | eff ) Unit
initGraph name f = void $ do
  cMay  <- getCanvasElementById cId
  c     <- maybe (die $ "Could not find canvas: " <> cId) pure cMay
  ctx   <- getContext2D c
  chart <- newChart ctx
  ct    <- f chart
  lt    <- generateLegend ct
  leg   <- J.select $ "#" <> lId
  J.appendText lt leg
  where
    cId = name <> "-canvas"
    lId = name <> "-legend"

initBar
  :: forall eff
   . Cpu
  -> Chart
  -> Eff ( dom :: DOM , err :: EXCEPTION, canvas:: Canvas | eff ) ChartType
initBar (Cpu {cpuData = cpuData}) c =
  barChart c barData (responsiveChartConfig hmonBarChartCfg)
  where
    barData = {
      labels : ["user","nice","system","idle","iowait","irq","softirq"],
      datasets : [
        { fillColor : "rgba(2,136,209,0.75)"
        , strokeColor : "rgba(220,220,220,0.8)"
        , highlightFill: "rgba(255,82,82,0.75)"
        , highlightStroke: "rgba(220,220,220,1)"
        , data : cpuData
        }
        ]}

hmonChartCfg :: ChartConfig
hmonChartCfg = set animation false defGlobalChartConfig

hmonBarChartCfg :: BarChartConfig
hmonBarChartCfg = responsiveChartConfig $ set global hmonChartCfg $ set legendTemplate "" defBarChartConfig -- Pretty way for this ?

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

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

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

die :: forall eff a. String -> Eff( err:: EXCEPTION | eff ) a
die = error >>> throwException

data Cpu = Cpu {
              cpuData :: Array Number
           }

instance showCpu :: Show Cpu where
  show (Cpu cData) = "CPU: "

instance cpuFromJSON :: FromJSON Cpu where
  parseJSON (JObject o) = do
    d <- o .: "cpu"
    return $ Cpu {cpuData: d}