Dictionary literal

Dictionary literal

Original commit ba13edde8263f652fd93ed18bc5b4b9e3abf8132

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

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

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

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

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

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

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

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

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

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

    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions

    forEachClass_ \className properties -> do
        blank
        renderClassExtension className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionExtension unionName unionTypes

    blank
    supportFunctions

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    line "}"

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

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

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

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

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

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

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

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

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

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

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

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

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

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

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

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

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

    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions

    forEachClass_ \className properties -> do
        blank
        renderClassExtension className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionExtension unionName unionTypes

    blank
    supportFunctions

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    line "}"

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

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

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

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

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

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

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


Updated guide text

Updated guide text

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}
module SlamData.Guide where

import Prelude
import Data.Array as Array
import Data.Maybe (Maybe(..), maybe)
import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Events.Handler as EH
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA

type Step = { imageUri ∷ String, text ∷ String }
data Arrow = RightArrow | DownArrow

arrowClassName ∷ Arrow → HH.ClassName
arrowClassName =
  case _ of
    RightArrow -> HH.className "sd-guide-right-arrow"
    DownArrow -> HH.className "sd-guide-down-arrow"

render ∷ ∀ f a. Arrow → HH.ClassName → (Unit → f Unit) → String → HH.HTML a (f Unit)
render arrow className dismissQuery text =
  HH.div
    [ HP.classes [ HH.className "sd-guide", className ] ]
    [ HH.div
        [ HP.classes
            [ HH.className "sd-notification"
            , arrowClassName arrow
            ]
        ]
        [ HH.div
            [ HP.class_ $ HH.className "sd-notification-text" ]
            [ HH.text text ]
        , HH.div
            [ HP.class_ $ HH.className "sd-notification-buttons" ]
            [ HH.button
                [ HP.classes [ HH.className "sd-notification-dismiss" ]
                , HE.onClick (HE.input_ dismissQuery)
                , ARIA.label "Dismiss"
                ]
                [ HH.text "×" ]
            ]
        ]
    ]

renderStepByStepWithArray
  ∷ ∀ f a
  . { next ∷ Unit → f Unit, dismiss ∷ Unit → f Unit }
  → Maybe Int
  → Array Step
  → Array (HH.HTML a (f Unit))
renderStepByStepWithArray queries stepIndex steps =
  maybe [] pure do
    index ← stepIndex
    step ← Array.index steps index
    pure
      $ renderStepByStep
          queries
          step.imageUri
          step.text
          (index == Array.length steps - 1)

renderStepByStep
  ∷ ∀ f a
  . { next ∷ Unit → f Unit, dismiss ∷ Unit → f Unit }
  → String
  → String
  → Boolean
  → HH.HTML a (f Unit)
renderStepByStep queries imageUri text last =
  HH.div
    [ HE.onClick \_ → EH.stopPropagation $> Just (H.action $ queries.dismiss)
    , HP.class_ $ HH.className "sd-step-by-step-guide-backdrop"
    ]
    [ HH.div
      [ HP.class_ $ HH.className "sd-step-by-step-guide"
      , HE.onClick (\_ → EH.stopPropagation $> Nothing)
      ]
      ([ HH.img [ HP.src imageUri ] , HH.p_ [ HH.text text ] ] <> pure buttons)
    ]
      where
      buttons =
        HH.div_
          $ if last
            then
              [ HH.button
                  [ HE.onClick \_ → EH.stopPropagation $> Just (H.action queries.dismiss) ]
                  [ HH.text "Get started!" ]
              ]
            else
              [ HH.button
                 [ HE.onClick \_ → EH.stopPropagation $> Just (H.action queries.next) ]
                 [ HH.text "Next" ]
              , HH.button
                 [ HE.onClick \_ → EH.stopPropagation $> Just (H.action queries.dismiss) ]
                  [ HH.text "Skip" ]
              ]

preloadStepByStepWithArray ∷ ∀ a f. Array Step → HH.HTML a f
preloadStepByStepWithArray steps =
  HH.div
    [ ARIA.hidden "true" ]
    ((\url → HH.img [ HP.src url ]) <<< _.imageUri <$> steps)

cardGuideSteps ∷ Array Step
cardGuideSteps =
  [ { imageUri: "img/cardGuide/1.gif"
    , text: "Welcome to SlamData! When using SlamData we think about analytics in terms of cards."
    }
  , { imageUri: "img/cardGuide/2.gif"
    , text: "Each card performs a function like showing a pie chart or opening a data set."
    }
  , { imageUri: "img/cardGuide/3.gif"
    , text: "Each card passes an output to the card after it, for example passing a data set to a chart."
    }
  , { imageUri: "img/cardGuide/4.gif"
    , text: "This is done by stacking cards ontop of each other to build decks. Decks represent analytic workflows."
    }
  , { imageUri: "img/cardGuide/5.gif"
    , text: "Check out the deck flip side, slide the card grippers and visit the next action card to see more of what's possible with SlamData."
    }
  ]

flipGuideSteps ∷ Array Step
flipGuideSteps =
  [ { imageUri: "img/flipGuide/1.gif"
    , text: "Welcome to the flip side of your deck. The flip side lists actions for the deck and current card."
    }
  , { imageUri: "img/flipGuide/2.gif"
    , text: "Delete Card deletes the current card and any cards inserted after it. Error cards and next action cards aren't inserted so are not deleted."
    }
  , { imageUri: "img/flipGuide/3.gif"
    , text: "Wrap Deck places the deck on a dashboard card in a new deck."
    }
  , { imageUri: "img/flipGuide/4.gif"
    , text: "Dashboard cards allow muliple decks to be laid out on one card."
    }
  , { imageUri: "img/flipGuide/5.gif"
    , text: "Decks can be removed using Delete Deck."
    }
  , { imageUri: "img/flipGuide/6.gif"
    , text: "Mirror Deck creates a live copy of the cards in the deck and places them in a new deck on the current dashboard card."
    }
  , { imageUri: "img/flipGuide/7.gif"
    , text: "Any changes made to the original or mirrored cards are reflected in each other except for deletion."
    }
  , { imageUri: "img/flipGuide/8.gif"
    , text: "Adding cards to either deck will not affect the other. Mirroring is great for adding form controls to your dashboard."
    }
  , { imageUri: "img/flipGuide/9.gif"
    , text: "Sharing is easy and secure with SlamData Advanced."
    }
  , { imageUri: "img/flipGuide/10.gif"
    , text: "Share deck allows decks to be shared for viewing or editing with people and groups. It also allows for the creation of access tokens."
    }
  , { imageUri: "img/flipGuide/11.gif"
    , text: "Access can be managed or revoked using Unshare Deck"
    }
  , { imageUri: "img/flipGuide/12.gif"
    , text: "With both SlamData and SlamData Advanced decks can be embedded on web and intranet sites using Embed Deck."
    }
  , { imageUri: "img/flipGuide/13.gif"
    , text: "And public viewing links can be created with Publish Deck."
    }
  , { imageUri: "img/flipGuide/14.gif"
    , text: "Thanks for exploring your Deck's flip side with us. If you get stuck or want to learn more please check out the help menu."
    }
  ]

dismissedCardGuideKey ∷ String
dismissedCardGuideKey = "dismissedCardGuide"

dismissedFlipGuideKey ∷ String
dismissedFlipGuideKey = "dismissedFlipGuide"

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}
module SlamData.Guide where

import Prelude
import Data.Array as Array
import Data.Maybe (Maybe(..), maybe)
import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Events.Handler as EH
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA

type Step = { imageUri ∷ String, text ∷ String }
data Arrow = RightArrow | DownArrow

arrowClassName ∷ Arrow → HH.ClassName
arrowClassName =
  case _ of
    RightArrow -> HH.className "sd-guide-right-arrow"
    DownArrow -> HH.className "sd-guide-down-arrow"

render ∷ ∀ f a. Arrow → HH.ClassName → (Unit → f Unit) → String → HH.HTML a (f Unit)
render arrow className dismissQuery text =
  HH.div
    [ HP.classes [ HH.className "sd-guide", className ] ]
    [ HH.div
        [ HP.classes
            [ HH.className "sd-notification"
            , arrowClassName arrow
            ]
        ]
        [ HH.div
            [ HP.class_ $ HH.className "sd-notification-text" ]
            [ HH.text text ]
        , HH.div
            [ HP.class_ $ HH.className "sd-notification-buttons" ]
            [ HH.button
                [ HP.classes [ HH.className "sd-notification-dismiss" ]
                , HE.onClick (HE.input_ dismissQuery)
                , ARIA.label "Dismiss"
                ]
                [ HH.text "×" ]
            ]
        ]
    ]

renderStepByStepWithArray
  ∷ ∀ f a
  . { next ∷ Unit → f Unit, dismiss ∷ Unit → f Unit }
  → Maybe Int
  → Array Step
  → Array (HH.HTML a (f Unit))
renderStepByStepWithArray queries stepIndex steps =
  maybe [] pure do
    index ← stepIndex
    step ← Array.index steps index
    pure
      $ renderStepByStep
          queries
          step.imageUri
          step.text
          (index == Array.length steps - 1)

renderStepByStep
  ∷ ∀ f a
  . { next ∷ Unit → f Unit, dismiss ∷ Unit → f Unit }
  → String
  → String
  → Boolean
  → HH.HTML a (f Unit)
renderStepByStep queries imageUri text last =
  HH.div
    [ HE.onClick \_ → EH.stopPropagation $> Just (H.action $ queries.dismiss)
    , HP.class_ $ HH.className "sd-step-by-step-guide-backdrop"
    ]
    [ HH.div
      [ HP.class_ $ HH.className "sd-step-by-step-guide"
      , HE.onClick (\_ → EH.stopPropagation $> Nothing)
      ]
      ([ HH.img [ HP.src imageUri ] , HH.p_ [ HH.text text ] ] <> pure buttons)
    ]
      where
      buttons =
        HH.div_
          $ if last
            then
              [ HH.button
                  [ HE.onClick \_ → EH.stopPropagation $> Just (H.action queries.dismiss) ]
                  [ HH.text "Get started!" ]
              ]
            else
              [ HH.button
                 [ HE.onClick \_ → EH.stopPropagation $> Just (H.action queries.next) ]
                 [ HH.text "Next" ]
              , HH.button
                 [ HE.onClick \_ → EH.stopPropagation $> Just (H.action queries.dismiss) ]
                  [ HH.text "Skip" ]
              ]

preloadStepByStepWithArray ∷ ∀ a f. Array Step → HH.HTML a f
preloadStepByStepWithArray steps =
  HH.div
    [ ARIA.hidden "true" ]
    ((\url → HH.img [ HP.src url ]) <<< _.imageUri <$> steps)

cardGuideSteps ∷ Array Step
cardGuideSteps =
  [ { imageUri: "img/cardGuide/1.gif"
    , text: "Welcome to SlamData! When using SlamData we think about analytics in terms of cards."
    }
  , { imageUri: "img/cardGuide/2.gif"
    , text: "Each card performs a function like showing a pie chart or opening a data set."
    }
  , { imageUri: "img/cardGuide/3.gif"
    , text: "Each card passes an output to the card after it, for example passing a data set to a chart."
    }
  , { imageUri: "img/cardGuide/4.gif"
    , text: "This is done by stacking cards ontop of each other to build decks. Decks represent analytic workflows."
    }
  , { imageUri: "img/cardGuide/5.gif"
    , text: "Check out the deck backside, slide the card grippers and visit the next action card to see more of what's possible with SlamData."
    }
  ]

flipGuideSteps ∷ Array Step
flipGuideSteps =
  [ { imageUri: "img/flipGuide/1.gif"
    , text: "Welcome to the flip side of your deck. The flip side lists actions for the deck and current card."
    }
  , { imageUri: "img/flipGuide/2.gif"
    , text: "Delete Card deletes the current card and any cards inserted after it. Error cards and next action cards aren't inserted so are not deleted."
    }
  , { imageUri: "img/flipGuide/3.gif"
    , text: "Wrap Deck places the deck on a dashboard card in a new deck."
    }
  , { imageUri: "img/flipGuide/4.gif"
    , text: "Dashboard cards allow muliple decks to be laid out on one card."
    }
  , { imageUri: "img/flipGuide/5.gif"
    , text: "Decks can be removed using Delete Deck."
    }
  , { imageUri: "img/flipGuide/6.gif"
    , text: "Mirror Deck creates a live copy of the cards in the deck and places them in a new deck on the current draftboard card."
    }
  , { imageUri: "img/flipGuide/7.gif"
    , text: "Any changes made to the original or mirrored cards are reflected in each other except for deletion."
    }
  , { imageUri: "img/flipGuide/8.gif"
    , text: "Adding cards to either deck will not affect the other. Mirroring is great for adding form controls to your dashboard."
    }
  , { imageUri: "img/flipGuide/9.gif"
    , text: "Sharing is easy and secure with SlamData Advanced."
    }
  , { imageUri: "img/flipGuide/10.gif"
    , text: "Share deck allows decks to be shared for viewing or editing with people and groups. It also allows for the creation of access tokens."
    }
  , { imageUri: "img/flipGuide/11.gif"
    , text: "Access can be managed or revoked using Unshare Deck"
    }
  , { imageUri: "img/flipGuide/12.gif"
    , text: "With both SlamData and SlamData Advanced decks can be embedded on web and intranet sites using Embed Deck."
    }
  , { imageUri: "img/flipGuide/13.gif"
    , text: "And public viewing links can be created with Publish Deck."
    }
  , { imageUri: "img/flipGuide/14.gif"
    , text: "Thanks for exploring your Deck's flip side with us. If you get stuck or want to learn more please check out the help menu."
    }
  ]

dismissedCardGuideKey ∷ String
dismissedCardGuideKey = "dismissedCardGuide"

dismissedFlipGuideKey ∷ String
dismissedFlipGuideKey = "dismissedFlipGuide"


Easier to understand

Easier to understand

module Main where

import Data.Maybe
import Data.String
import Data.Either

import Data.Coords
import Data.GameItem
import Data.GameState
import Data.GameEnvironment

import Control.Monad.Eff
import Control.Monad.RWS
import Control.Monad.RWS.Class

import Game

import Debug.Trace

import qualified Node.ReadLine as RL

import qualified Node.Yargs as Y
import qualified Node.Yargs.Setup as Y
import qualified Node.Yargs.Applicative as Y

runGame :: GameEnvironment -> Eff (console :: RL.Console, trace :: Trace) Unit
runGame env = do
  interface <- RL.createInterface RL.process.stdin RL.process.stdout RL.noCompletion
  RL.setPrompt "> " 2 interface

  let
    lineHandler :: GameState -> String -> Eff (console :: RL.Console, trace :: Trace) Unit
    lineHandler currentState input = do
      let result = runRWS (game (split " " input)) env currentState
      foreachE result.log trace
      RL.setLineHandler (lineHandler result.state) interface
      RL.prompt interface
      return unit

  RL.setLineHandler (lineHandler initialGameState) interface
  RL.prompt interface

  return unit

main =
  let env = gameEnvironment <$> Y.yarg "p" ["player"]
                                       (Just "Player name")
                                       (Right "The player name is required")
                                       false
                            <*> Y.flag "d" ["debug"]
                                       (Just "Use debug mode")
  in Y.runY (Y.usage "$0 -p <player name>") $ runGame <$> env

module Main where

import Data.Maybe
import Data.String
import Data.Either

import Data.Coords
import Data.GameItem
import Data.GameState
import Data.GameEnvironment

import Control.Monad.Eff
import Control.Monad.RWS
import Control.Monad.RWS.Class

import Game

import Debug.Trace

import qualified Node.ReadLine as RL

import qualified Node.Yargs as Y
import qualified Node.Yargs.Setup as Y
import qualified Node.Yargs.Applicative as Y

runGame :: GameEnvironment -> Eff (console :: RL.Console, trace :: Trace) Unit
runGame env = do
  interface <- RL.createInterface RL.process.stdin RL.process.stdout RL.noCompletion
  RL.setPrompt "> " 2 interface

  let
    lineHandler :: GameState -> String -> Eff (console :: RL.Console, trace :: Trace) Unit
    lineHandler currentState input = do
      let result = runRWS (game (split " " input)) env currentState
      foreachE result.log trace
      RL.setLineHandler (lineHandler result.state) interface
      RL.prompt interface
      return unit

  RL.setLineHandler (lineHandler initialGameState) interface
  RL.prompt interface

  return unit

main = Y.runY (Y.usage "$0 -p <player name>") $
  let env = gameEnvironment <$> Y.yarg "p" ["player"]
                                       (Just "Player name")
                                       (Right "The player name is required")
                                       false
                            <*> Y.flag "d" ["debug"]
                                       (Just "Use debug mode")
   in runGame <$> env


Breathe

Breathe

Original commit b0b761023a0efaeb5c6dee1f27225526f4cfe605

module IR where

import Prelude

import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), fromJust, maybe)
import Data.Foldable (find, all, any, for_, foldM)

import Data.List as L
import Data.List (List, (:))

import Data.Map as M
import Data.Map (Map)

import Data.Sequence as Seq

import Data.Set as S
import Data.Set (Set)

import Data.Tuple as T
import Data.Tuple (Tuple(..))

import Control.Monad.State (State, execState)
import Control.Monad.State.Class (get, put)

import Partial.Unsafe (unsafePartial)

type IR = State IRGraph

newtype IRGraph = IRGraph { classes :: Seq.Seq (Either IRClassData Int) }

newtype IRClassData = IRClassData { names :: Set String, properties :: Map String IRType }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRUnion (Set IRType)

derive instance eqIRType :: Eq IRType
derive instance ordIRType :: Ord IRType
derive instance eqIRClassData :: Eq IRClassData

runIR :: forall a. IR a -> IRGraph
runIR ir = execState ir emptyGraph

makeClass :: String -> Map String IRType -> IRClassData
makeClass name properties = IRClassData { names: S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: Seq.empty }

addClassWithIndex :: IRClassData -> IR (Tuple Int IRType)
addClassWithIndex classData = do
    IRGraph { classes } <- get
    case Seq.elemIndex (Left classData) classes of
        Nothing -> do
            let index = Seq.length classes
            put $ IRGraph { classes: Seq.snoc classes (Left classData) }
            pure $ Tuple index (IRClass index)
        Just index -> pure $ Tuple index (IRClass index)

addClass :: IRClassData -> IR IRType
addClass classData = T.snd <$> addClassWithIndex classData

followIndex :: IRGraph -> Int -> Tuple Int IRClassData
followIndex graph@(IRGraph { classes }) index =
    case unsafePartial $ fromJust $ Seq.index index classes of
    Left cd -> Tuple index cd
    Right i -> followIndex graph i

redirectClass :: Int -> Int -> IR Unit
redirectClass from to = do
    graph@(IRGraph { classes: c1 }) <- get
    let realTo = T.fst $ followIndex graph to
    if from == realTo
        then pure unit
        else do
            let c2 = Seq.replace (Right realTo) from c1
            put $ IRGraph { classes: c2 }

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph index = T.snd $ followIndex graph index

getClass :: Int -> IR IRClassData
getClass index = do
    graph <- get
    pure $ getClassFromGraph graph index

combineClasses :: Int -> Int -> IRClassData -> IR IRType
combineClasses ia ib combined = do
    IRGraph { classes } <- get
    Tuple newIndex t <- addClassWithIndex combined
    -- FIXME: could newIndex be ia or ib?
    redirectClass ia newIndex
    redirectClass ib newIndex
    pure t

mapClasses :: forall a. (Int -> IRClassData -> a) -> IRGraph -> List a
mapClasses f (IRGraph { classes }) = L.concat $ L.mapWithIndex mapper (L.fromFoldable classes)
    where mapper i = either (L.singleton <<< f i) (const L.Nil)

classesInGraph :: IRGraph -> List IRClassData
classesInGraph  = mapClasses (const id)

lookupOrDefault :: forall k v. Ord k => v -> k -> Map k v -> v
lookupOrDefault default key m = maybe default id $ M.lookup key m

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s = { element, rest: maybe s (\x -> S.delete x s) element }
    where element = find p s

mapM :: forall a b. (a -> IR b) -> List a -> IR (List b)
mapM _ L.Nil = pure L.Nil
mapM f (x : xs) = L.Cons <$> f x <*> mapM f xs

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> IR v) -> v -> Map k v -> Map k v -> IR (Map k v)
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ M.keys m1) (S.fromFoldable $ M.keys m2)
        valueFor k = unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2)
        keyMapper k = Tuple k <$> valueFor k
    in M.fromFoldable <$> mapM keyMapper allKeys

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

decomposeTypeSet :: S.Set IRType -> { maybeArray :: Maybe IRType, maybeClass :: Maybe IRType, rest :: S.Set IRType }
decomposeTypeSet s =
    let { element: maybeArray, rest: rest } = removeElement isArray s
        { element: maybeClass, rest: rest } = removeElement isClass rest
    in { maybeArray, maybeClass, rest }

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

unifyClasses :: IRClassData -> IRClassData -> IR IRClassData
unifyClasses (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) = do
    properties <- unionWithDefault unifyTypesWithNull IRNothing pa pb
    pure $ IRClassData { names: S.union na nb, properties }

unifyMaybes :: Maybe IRType -> Maybe IRType -> IR IRType
unifyMaybes Nothing Nothing = pure IRNothing
unifyMaybes (Just a) Nothing = pure a
unifyMaybes Nothing (Just b) = pure b
unifyMaybes (Just a) (Just b) = unifyTypes a b

unifyUnion :: S.Set IRType -> S.Set IRType -> IR (S.Set IRType)
unifyUnion sa sb = do
    let { maybeArray: arrayA, maybeClass: classA, rest: sa } = decomposeTypeSet sa
    let { maybeArray: arrayB, maybeClass: classB, rest: sb } = decomposeTypeSet sb
    unifiedArray <- unifyMaybes arrayA arrayB
    unifiedClasses <- unifyMaybes classA classB
    pure $ S.unions [sa, sb, setFromType unifiedArray, setFromType unifiedClasses]

unifyTypes :: IRType -> IRType -> IR IRType
unifyTypes IRNothing x = pure x
unifyTypes x IRNothing = pure x
unifyTypes (IRArray a) (IRArray b) = IRArray <$> unifyTypes a b
unifyTypes a@(IRClass ia) (IRClass ib) =
    if ia == ib
    then pure a
    else do
        a <- getClass ia
        b <- getClass ib
        unified <- unifyClasses a b
        combineClasses ia ib unified
unifyTypes (IRUnion a) (IRUnion b) = IRUnion <$> unifyUnion a b
unifyTypes (IRUnion a) b = IRUnion <$> unifyUnion a (S.singleton b)
unifyTypes a (IRUnion b) = IRUnion <$> unifyUnion (S.singleton a) b
unifyTypes a b | a == b = pure a
               | otherwise = pure $ IRUnion (S.fromFoldable [a, b])

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

unifyTypesWithNull :: IRType -> IRType -> IR IRType
unifyTypesWithNull IRNothing IRNothing = pure IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb = M.fromFoldable $ L.concatMap getFromB (M.toUnfoldable ma)
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb | va == vb -> Tuple k vb : L.Nil
                    | otherwise -> L.Nil
            Nothing -> L.Nil

propertiesSimilar :: forall v. Eq v => Map String v -> Map String v -> Boolean
propertiesSimilar pa pb =
    let aInB = M.size $ matchingProperties pa pb
        bInA = M.size $ matchingProperties pb pa
    in
        (aInB * 4 >= (M.size pa) * 3) && (bInA * 4 >= (M.size pb) * 3)

isMaybeSubtypeOfMaybe :: IRGraph -> Maybe IRType -> Maybe IRType -> Boolean
isMaybeSubtypeOfMaybe _ Nothing Nothing = true
isMaybeSubtypeOfMaybe graph (Just a) (Just b) = isSubtypeOf graph a b
isMaybeSubtypeOfMaybe _ _ _ = false

isSubtypeOf :: IRGraph ->  IRType -> IRType -> Boolean
isSubtypeOf _ IRNothing _ = true
isSubtypeOf graph (IRUnion sa) (IRUnion sb) = all (\ta -> any (isSubtypeOf graph ta) sb) sa
isSubtypeOf graph (IRArray a) (IRArray b) = isSubtypeOf graph a b
isSubtypeOf graph (IRClass ia) (IRClass ib) =
    let IRClassData { properties: pa } = getClassFromGraph graph ia
        IRClassData { properties: pb } = getClassFromGraph graph ib
    in propertiesAreSubset graph pa pb
isSubtypeOf _ a b = a == b

propertiesAreSubset :: IRGraph -> Map String IRType -> Map String IRType -> Boolean
propertiesAreSubset graph ma mb = all isInB (M.toUnfoldable ma :: List _)
    where isInB (Tuple n ta) = maybe false (isSubtypeOf graph ta) (M.lookup n mb)

classesSimilar :: IRGraph -> IRClassData -> IRClassData -> Boolean
classesSimilar graph (IRClassData { properties: pa }) (IRClassData { properties: pb }) =
    propertiesSimilar pa pb --||
    --propertiesAreSubset graph pa pb ||
    --propertiesAreSubset graph pb pa

similarClasses :: IRGraph -> Set (Set Int)
similarClasses graph = accumulate (mapClasses Tuple graph)
    where
        accumulate :: List (Tuple Int IRClassData) -> Set (Set Int)
        accumulate L.Nil = S.empty
        accumulate (Tuple i thisClass : rest) =
            let { yes: similar, no: others } = L.partition (isSimilar thisClass) rest
                recursiveResult = accumulate others
            in case similar of
                L.Nil -> recursiveResult
                _ ->
                    let similarSet = S.fromFoldable (i : map T.fst similar)
                    in S.insert similarSet recursiveResult

        isSimilar cd1 (Tuple _ cd2) = classesSimilar graph cd1 cd2

unifySetOfClasses :: Set Int -> (IR Unit)
unifySetOfClasses indexes =
    case L.fromFoldable indexes of
        L.Nil -> pure unit
        _ : L.Nil -> pure unit
        first : rest ->  do
            firstClass <- getClass first

            let folder cd1 i2 = getClass i2 >>= unifyClasses cd1
            combined <- foldM folder firstClass rest

            Tuple newIndex _ <- addClassWithIndex combined
            for_ indexes \i ->  redirectClass i newIndex

replaceSimilarClasses :: IR Unit
replaceSimilarClasses = do
    graph <- get
    let similar = similarClasses graph
    for_ similar unifySetOfClasses

combineNames :: S.Set String -> String
combineNames s = case L.fromFoldable s of
    L.Nil -> "NONAME"
    n : _ -> n


button submit type

button submit type

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.FileSystem.Dialog.Rename.Component where

import SlamData.Prelude

import Control.UI.Browser (reload)

import Data.Array (elemIndex, singleton, sort, nub)
import Data.Lens ((^.), (%~), (.~), (?~), lens, Lens')
import Data.Path.Pathy (printPath, parseAbsDir, sandbox, rootDir, (</>))
import Data.String as S

import DOM.Event.Event as DEE

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Config as Config
import SlamData.Dialog.Render (modalDialog, modalHeader, modalBody, modalFooter)
import SlamData.FileSystem.Dialog.Component.Message (Message(..))
import SlamData.FileSystem.Listing.Item.Component.CSS as ItemCSS
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.Monad (Slam)
import SlamData.Quasar.FS as API
import SlamData.Render.Common (formGroup)
import SlamData.Render.ClassName as CN

import Utils.Path (DirPath, dropWorkspaceExt)
import Utils.DOM as DOM

type State =
  { showList ∷ Boolean
  , initial ∷ R.Resource
  , name ∷ String
  , dirs ∷ Array R.Resource
  , dir ∷ DirPath
  , typedDir ∷ String
  , siblings ∷ Array R.Resource
  , error ∷ Maybe String
  }

initialState ∷ R.Resource → State
initialState resource =
  { showList: false
  , initial: resource
  , name: if R.isWorkspace resource
          then dropWorkspaceExt $ R.resourceName resource
          else R.resourceName resource
  , dir: R.resourceDir resource
  , typedDir: printPath $ R.resourceDir resource
  , siblings: mempty
  , dirs: singleton R.root
  , error: Nothing
  }

_showList ∷ Lens' State Boolean
_showList = lens _.showList (_ { showList = _ })

_initial ∷ Lens' State R.Resource
_initial = lens _.initial (_ { initial = _ })

_name ∷ Lens' State String
_name = lens _.name (_ { name = _ })

_typedDir ∷ Lens' State String
_typedDir = lens _.typedDir (_ { typedDir = _ })

_dirs ∷ Lens' State (Array R.Resource)
_dirs = lens _.dirs (_ { dirs = _ })

_dir ∷ Lens' State DirPath
_dir = lens _.dir (_ { dir = _ })

_siblings ∷ Lens' State (Array R.Resource)
_siblings = lens _.siblings (_ { siblings = _ })

_error ∷ Lens' State (Maybe String)
_error = lens _.error (_ { error = _ })

renameSlam ∷ State → R.Resource
renameSlam r =
  let initial = r.initial
      name = r.name
      nameWithExt = if R.isWorkspace initial
                    then name <> "." <> Config.workspaceExtension
                    else name
  in initial # (R._name .~ nameWithExt)
           <<< (R._root .~ r.dir)

validate ∷ State → State
validate r
  | r.initial == renameSlam r = r # _error .~ Nothing
  | otherwise = r # _error .~ either Just (const Nothing) do
    let name = r.name
    when (name == "")
      $ throwError "Please enter a name for the file"

    when (isJust $ S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension) name)
      $ throwError $ "Please choose an alternative name, ."
      <> Config.workspaceExtension
      <> " is a reserved extension"

    when (isJust $ S.indexOf (S.Pattern "/") name)
      $ throwError "Please enter a valid name for the file"

    let nameWithExt = if R.isWorkspace (r.initial)
                      then name <> "." <> Config.workspaceExtension
                      else name
    when (isJust $ elemIndex nameWithExt (map (_ ^. R._name) (r.siblings)))
      $ throwError "An item with this name already exists in the target folder"

data Query a
  = RaiseDismiss a
  | SetShowList Boolean a
  | ToggleShowList a
  | NameTyped String a
  | DirTyped String a
  | DirClicked R.Resource a
  | SetSiblings (Array R.Resource) a
  | AddDirs (Array R.Resource) a
  | PreventDefaultAndRename DOM.Event a
  | StopPropagation DOM.Event (Query a)
  | Init a

type DSL = H.ComponentDSL State Query Message Slam
type HTML = H.ComponentHTML Query

component ∷ H.Component HH.HTML Query R.Resource Message Slam
component =
  H.lifecycleComponent
    { initialState
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render dialog =
  HH.form
    [ HE.onSubmit $ HE.input PreventDefaultAndRename ]
    [ modalDialog
      [ modalHeader "Move/rename"
      , modalBody
        $ HH.div
            [ HP.classes [ CN.renameDialogForm ]
            , HE.onClick \e → Just $ StopPropagation (DOM.toEvent e) $ H.action $ SetShowList false
            ]
            [ nameInput
            , dirDropdownField
            , dirDropdownList
            , errorMessage
            ]
      , modalFooter
          [ HH.button
              [ HP.type_ HP.ButtonSubmit
              , HP.classes [ CN.btn, CN.btnPrimary ]
              , HP.disabled $ isJust dialog.error
              ]
              [ HH.text "Rename" ]
          , HH.button
              [ HP.type_ HP.ButtonButton
              , HP.classes
                [ CN.btn
                , CN.btnDefault
                ]
              , HE.onClick $ HE.input_ RaiseDismiss
              ]
              [ HH.text "Cancel" ]
          ]
      ]
    ]
  where
  nameInput ∷ HTML
  nameInput =
    formGroup [ HH.input [ HP.classes [ CN.formControl ]
                        , HP.value (dialog.name)
                        , HP.placeholder "New name"
                        , HE.onValueInput (HE.input NameTyped)
                        ]
              ]

  dirDropdownField ∷ HTML
  dirDropdownField =
    HH.div
      [ HP.classes [ CN.inputGroup, HH.ClassName "file-list-field" ] ]
      [ HH.input
          [ HP.type_ HP.InputText
          , HP.classes [ CN.formControl ]
          , HP.placeholder "New directory"
          , HE.onValueInput (HE.input DirTyped)
          , HP.value $ dialog ^. _typedDir
          ]
      , HH.span
          [ HP.classes [ CN.inputGroupBtn ] ]
          [ HH.button
              [ HP.type_ HP.ButtonButton
              , HP.classes [ CN.btn, CN.btnDefault ]
              , HE.onClick \e →
                   Just $ StopPropagation (DOM.toEvent e) $ H.action $ ToggleShowList
              , ARIA.label "Select a destination folder"
              , HP.title "Select a destination folder"
              ]
              [ HH.span [ HP.classes [ CN.caret ] ] [ ] ]
          ]
      ]
  dirDropdownList ∷ HTML
  dirDropdownList =
    HH.ul
      ([ HP.classes  [ CN.listGroup, CN.fileListGroup ] ]
       <> if dialog.showList then [] else [ ARIA.hidden "true" ])
    $ renameItem <$> dialog.dirs

  errorMessage ∷ HTML
  errorMessage =
    HH.div
      ([ HP.classes $ [ CN.alert, CN.alertDanger ] ]
       <> if isJust dialog.error then [] else [ ARIA.hidden "true" ])
      $ maybe [ ] (pure <<< HH.text) (dialog.error)

  renameItem ∷ R.Resource → HTML
  renameItem res =
    HH.button
      [ HP.classes ([ CN.listGroupItem ] <> (guard (R.isHidden res) $> ItemCSS.itemHidden))
      , HE.onClick (HE.input_ (DirClicked res))
      , HP.type_ HP.ButtonButton
      ]
      [ HH.text (R.resourcePath res) ]

eval ∷ Query ~> DSL
eval (RaiseDismiss next) = do
  H.raise Dismiss
  pure next
eval (StopPropagation e q) = do
  H.liftEff $ DEE.stopPropagation e
  eval q
eval (SetShowList bool next) = do
  H.modify (_showList .~ bool)
  H.modify validate
  pure next
eval (ToggleShowList next) = do
  H.modify (_showList %~ not)
  H.modify validate
  pure next
eval (PreventDefaultAndRename ev next) = do
  H.liftEff $ DEE.preventDefault ev
  dirStr <- endingInSlash <$> H.gets _.typedDir
  maybe presentDirNotExistError moveIfDirAccessible (parsedDir dirStr)
  pure next
  where
  parsedDir =
    map (rootDir </> _) ∘ sandbox rootDir <=< parseAbsDir

  presentSourceMissingError =
    H.modify $ _error .~ Just "The file you are trying to move is unavailable, please refresh."

  presentDirNotExistError =
    H.modify $ _error .~ Just "Target directory does not exist."

  presentError e =
    case GE.fromQError e of
      Left msg → H.modify $ _error .~ Just msg
      Right ge → GE.raiseGlobalError ge

  moveIfDirAccessible dir =
    maybe (move dir) presentError =<< API.dirNotAccessible dir

  move dir = do
    H.modify $ (_dir .~ dir) <<< (_showList .~ false)
    state ← H.get
    let src = state.initial
        tgt = R.getPath $ renameSlam state
    result ← H.lift $ API.move src tgt
    case result of
      Left e ->
        case GE.fromQError e of
          Left msg -> H.modify (_error ?~ msg)
          Right ge -> GE.raiseGlobalError ge
      Right x ->
        maybe
          presentSourceMissingError
          (const $ H.modify (_error .~ Nothing) *> H.liftEff reload)
          x
    pure unit

  lastChar s = S.drop (S.length s - 1) s

  endingInSlash s = if lastChar s == "/" then s else s <> "/"

eval (NameTyped str next) = do
  H.modify (_name .~ str)
  H.modify validate
  pure next
eval (DirTyped str next) = do
  H.modify $ _typedDir .~ str
  pure next
eval (DirClicked res next) = do
  dirItemClicked res
  pure next
eval (SetSiblings ss next) = do
  H.modify (_siblings .~ ss)
  pure next
eval (AddDirs ds next) = do
  H.modify (_dirs %~ append ds >>> nub >>> sort)
  pure next
eval (Init next) = do
  state <- H.get
  dirItemClicked $ R.parent $ state.initial
  pure next

dirItemClicked ∷ R.Resource → DSL Unit
dirItemClicked res = do
  case R.getPath res of
    Right _ → pure unit
    Left dir → do
      siblings ← API.children dir
      H.modify
        $ (_dir .~ dir)
        <<< (_showList .~ false)
        <<< (_siblings .~ either (const []) id siblings)
        <<< (_typedDir .~ printPath dir)

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.FileSystem.Dialog.Rename.Component where

import SlamData.Prelude

import Control.UI.Browser (reload)

import Data.Array (elemIndex, singleton, sort, nub)
import Data.Lens ((^.), (%~), (.~), (?~), lens, Lens')
import Data.Path.Pathy (printPath, parseAbsDir, sandbox, rootDir, (</>))
import Data.String as S

import DOM.Event.Event as DEE

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Config as Config
import SlamData.Dialog.Render (modalDialog, modalHeader, modalBody, modalFooter)
import SlamData.FileSystem.Dialog.Component.Message (Message(..))
import SlamData.FileSystem.Listing.Item.Component.CSS as ItemCSS
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.Monad (Slam)
import SlamData.Quasar.FS as API
import SlamData.Render.Common (formGroup)
import SlamData.Render.ClassName as CN

import Utils.Path (DirPath, dropWorkspaceExt)
import Utils.DOM as DOM

type State =
  { showList ∷ Boolean
  , initial ∷ R.Resource
  , name ∷ String
  , dirs ∷ Array R.Resource
  , dir ∷ DirPath
  , typedDir ∷ String
  , siblings ∷ Array R.Resource
  , error ∷ Maybe String
  }

initialState ∷ R.Resource → State
initialState resource =
  { showList: false
  , initial: resource
  , name: if R.isWorkspace resource
          then dropWorkspaceExt $ R.resourceName resource
          else R.resourceName resource
  , dir: R.resourceDir resource
  , typedDir: printPath $ R.resourceDir resource
  , siblings: mempty
  , dirs: singleton R.root
  , error: Nothing
  }

_showList ∷ Lens' State Boolean
_showList = lens _.showList (_ { showList = _ })

_initial ∷ Lens' State R.Resource
_initial = lens _.initial (_ { initial = _ })

_name ∷ Lens' State String
_name = lens _.name (_ { name = _ })

_typedDir ∷ Lens' State String
_typedDir = lens _.typedDir (_ { typedDir = _ })

_dirs ∷ Lens' State (Array R.Resource)
_dirs = lens _.dirs (_ { dirs = _ })

_dir ∷ Lens' State DirPath
_dir = lens _.dir (_ { dir = _ })

_siblings ∷ Lens' State (Array R.Resource)
_siblings = lens _.siblings (_ { siblings = _ })

_error ∷ Lens' State (Maybe String)
_error = lens _.error (_ { error = _ })

renameSlam ∷ State → R.Resource
renameSlam r =
  let initial = r.initial
      name = r.name
      nameWithExt = if R.isWorkspace initial
                    then name <> "." <> Config.workspaceExtension
                    else name
  in initial # (R._name .~ nameWithExt)
           <<< (R._root .~ r.dir)

validate ∷ State → State
validate r
  | r.initial == renameSlam r = r # _error .~ Nothing
  | otherwise = r # _error .~ either Just (const Nothing) do
    let name = r.name
    when (name == "")
      $ throwError "Please enter a name for the file"

    when (isJust $ S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension) name)
      $ throwError $ "Please choose an alternative name, ."
      <> Config.workspaceExtension
      <> " is a reserved extension"

    when (isJust $ S.indexOf (S.Pattern "/") name)
      $ throwError "Please enter a valid name for the file"

    let nameWithExt = if R.isWorkspace (r.initial)
                      then name <> "." <> Config.workspaceExtension
                      else name
    when (isJust $ elemIndex nameWithExt (map (_ ^. R._name) (r.siblings)))
      $ throwError "An item with this name already exists in the target folder"

data Query a
  = RaiseDismiss a
  | SetShowList Boolean a
  | ToggleShowList a
  | NameTyped String a
  | DirTyped String a
  | DirClicked R.Resource a
  | SetSiblings (Array R.Resource) a
  | AddDirs (Array R.Resource) a
  | PreventDefaultAndRename DOM.Event a
  | StopPropagation DOM.Event (Query a)
  | Init a

type DSL = H.ComponentDSL State Query Message Slam
type HTML = H.ComponentHTML Query

component ∷ H.Component HH.HTML Query R.Resource Message Slam
component =
  H.lifecycleComponent
    { initialState
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render dialog =
  HH.form
    [ HE.onSubmit $ HE.input PreventDefaultAndRename ]
    [ modalDialog
      [ modalHeader "Move/rename"
      , modalBody
        $ HH.div
            [ HP.classes [ CN.renameDialogForm ]
            , HE.onClick \e → Just $ StopPropagation (DOM.toEvent e) $ H.action $ SetShowList false
            ]
            [ nameInput
            , dirDropdownField
            , dirDropdownList
            , errorMessage
            ]
      , modalFooter
          [ HH.button
              [ HP.type_ HP.ButtonButton
              , HP.classes [ CN.btn, CN.btnPrimary ]
              , HP.disabled $ isJust dialog.error
              ]
              [ HH.text "Rename" ]
          , HH.button
              [ HP.type_ HP.ButtonButton
              , HP.classes
                [ CN.btn
                , CN.btnDefault
                ]
              , HE.onClick $ HE.input_ RaiseDismiss
              ]
              [ HH.text "Cancel" ]
          ]
      ]
    ]
  where
  nameInput ∷ HTML
  nameInput =
    formGroup [ HH.input [ HP.classes [ CN.formControl ]
                        , HP.value (dialog.name)
                        , HP.placeholder "New name"
                        , HE.onValueInput (HE.input NameTyped)
                        ]
              ]

  dirDropdownField ∷ HTML
  dirDropdownField =
    HH.div
      [ HP.classes [ CN.inputGroup, HH.ClassName "file-list-field" ] ]
      [ HH.input
          [ HP.type_ HP.InputText
          , HP.classes [ CN.formControl ]
          , HP.placeholder "New directory"
          , HE.onValueInput (HE.input DirTyped)
          , HP.value $ dialog ^. _typedDir
          ]
      , HH.span
          [ HP.classes [ CN.inputGroupBtn ] ]
          [ HH.button
              [ HP.type_ HP.ButtonButton
              , HP.classes [ CN.btn, CN.btnDefault ]
              , HE.onClick \e →
                   Just $ StopPropagation (DOM.toEvent e) $ H.action $ ToggleShowList
              , ARIA.label "Select a destination folder"
              , HP.title "Select a destination folder"
              ]
              [ HH.span [ HP.classes [ CN.caret ] ] [ ] ]
          ]
      ]
  dirDropdownList ∷ HTML
  dirDropdownList =
    HH.ul
      ([ HP.classes  [ CN.listGroup, CN.fileListGroup ] ]
       <> if dialog.showList then [] else [ ARIA.hidden "true" ])
    $ renameItem <$> dialog.dirs

  errorMessage ∷ HTML
  errorMessage =
    HH.div
      ([ HP.classes $ [ CN.alert, CN.alertDanger ] ]
       <> if isJust dialog.error then [] else [ ARIA.hidden "true" ])
      $ maybe [ ] (pure <<< HH.text) (dialog.error)

  renameItem ∷ R.Resource → HTML
  renameItem res =
    HH.button
      [ HP.classes ([ CN.listGroupItem ] <> (guard (R.isHidden res) $> ItemCSS.itemHidden))
      , HE.onClick (HE.input_ (DirClicked res))
      , HP.type_ HP.ButtonButton
      ]
      [ HH.text (R.resourcePath res) ]

eval ∷ Query ~> DSL
eval (RaiseDismiss next) = do
  H.raise Dismiss
  pure next
eval (StopPropagation e q) = do
  H.liftEff $ DEE.stopPropagation e
  eval q
eval (SetShowList bool next) = do
  H.modify (_showList .~ bool)
  H.modify validate
  pure next
eval (ToggleShowList next) = do
  H.modify (_showList %~ not)
  H.modify validate
  pure next
eval (PreventDefaultAndRename ev next) = do
  H.liftEff $ DEE.preventDefault ev
  dirStr <- endingInSlash <$> H.gets _.typedDir
  maybe presentDirNotExistError moveIfDirAccessible (parsedDir dirStr)
  pure next
  where
  parsedDir =
    map (rootDir </> _) ∘ sandbox rootDir <=< parseAbsDir

  presentSourceMissingError =
    H.modify $ _error .~ Just "The file you are trying to move is unavailable, please refresh."

  presentDirNotExistError =
    H.modify $ _error .~ Just "Target directory does not exist."

  presentError e =
    case GE.fromQError e of
      Left msg → H.modify $ _error .~ Just msg
      Right ge → GE.raiseGlobalError ge

  moveIfDirAccessible dir =
    maybe (move dir) presentError =<< API.dirNotAccessible dir

  move dir = do
    H.modify $ (_dir .~ dir) <<< (_showList .~ false)
    state ← H.get
    let src = state.initial
        tgt = R.getPath $ renameSlam state
    result ← H.lift $ API.move src tgt
    case result of
      Left e ->
        case GE.fromQError e of
          Left msg -> H.modify (_error ?~ msg)
          Right ge -> GE.raiseGlobalError ge
      Right x ->
        maybe
          presentSourceMissingError
          (const $ H.modify (_error .~ Nothing) *> H.liftEff reload)
          x
    pure unit

  lastChar s = S.drop (S.length s - 1) s

  endingInSlash s = if lastChar s == "/" then s else s <> "/"

eval (NameTyped str next) = do
  H.modify (_name .~ str)
  H.modify validate
  pure next
eval (DirTyped str next) = do
  H.modify $ _typedDir .~ str
  pure next
eval (DirClicked res next) = do
  dirItemClicked res
  pure next
eval (SetSiblings ss next) = do
  H.modify (_siblings .~ ss)
  pure next
eval (AddDirs ds next) = do
  H.modify (_dirs %~ append ds >>> nub >>> sort)
  pure next
eval (Init next) = do
  state <- H.get
  dirItemClicked $ R.parent $ state.initial
  pure next

dirItemClicked ∷ R.Resource → DSL Unit
dirItemClicked res = do
  case R.getPath res of
    Right _ → pure unit
    Left dir → do
      siblings ← API.children dir
      H.modify
        $ (_dir .~ dir)
        <<< (_showList .~ false)
        <<< (_siblings .~ either (const []) id siblings)
        <<< (_typedDir .~ printPath dir)


fix more unused import warnings

fix more unused import warnings

{--
  This file contains code copied from the purescript-affjax project from slamdata.
  It is therefore licensed under Apache License version 2.0.
--}
module Servant.PureScript.Settings where

import Prelude
import Data.Argonaut.Generic.Aeson as Aeson
import Data.Argonaut.Core (Json)
import Data.Either (Either)
import Data.Generic (class Generic, GenericSpine(SString), toSpine)
import Global (encodeURIComponent)

-- | WARNING: encodeJson, decodeJson, toURLPiece: currently ignored due to compiler bug:
--   https://github.com/purescript/purescript/issues/1957
newtype SPSettings_ params = SPSettings_ {
    encodeJson :: forall a. Generic a => a -> Json -- Currently not used (does not work - compiler bug: )
  , decodeJson :: forall a. Generic a => Json -> Either String a
  , toURLPiece :: forall a. Generic a => a -> URLPiece
  , params :: params
  }

type URLPiece = String

-- | Just use the robust JSON format.
gDefaultToURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultToURLPiece = gDefaultEncodeHeader

-- | Just use the robust JSON format.
gDefaultEncodeHeader :: forall a. Generic a => a -> URLPiece
gDefaultEncodeHeader v =
  case toSpine v of
    SString s -> s -- Special case string - just use it as is (http-api-data compatibility).
    _ -> show <<< Aeson.encodeJson $ v

-- | Full encoding based on gDefaultToURLPiece
gDefaultEncodeURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultEncodeURLPiece = encodeURIComponent <<< gDefaultToURLPiece

defaultSettings :: forall params. params -> SPSettings_ params
defaultSettings params = SPSettings_ {
    encodeJson : Aeson.encodeJson
  , decodeJson : Aeson.decodeJson
  , toURLPiece : gDefaultToURLPiece
  , params : params
}

{--
  This file contains code copied from the purescript-affjax project from slamdata.
  It is therefore licensed under Apache License version 2.0.
--}
module Servant.PureScript.Settings where

import Prelude
import Data.Argonaut.Generic.Aeson as Aeson
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Util (stripModulePath)
import Data.Array (null)
import Data.Either (Either)
import Data.Generic (class Generic, GenericSpine(SArray, SChar, SString, SNumber, SInt, SBoolean, SRecord, SProd, SUnit), toSpine)
import Data.String (joinWith)
import Global (encodeURIComponent)

-- | WARNING: encodeJson, decodeJson, toURLPiece: currently ignored due to compiler bug:
--   https://github.com/purescript/purescript/issues/1957
newtype SPSettings_ params = SPSettings_ {
    encodeJson :: forall a. Generic a => a -> Json -- Currently not used (does not work - compiler bug: )
  , decodeJson :: forall a. Generic a => Json -> Either String a
  , toURLPiece :: forall a. Generic a => a -> URLPiece
  , params :: params
  }

type URLPiece = String

-- | Just use the robust JSON format.
gDefaultToURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultToURLPiece = gDefaultEncodeHeader

-- | Just use the robust JSON format.
gDefaultEncodeHeader :: forall a. Generic a => a -> URLPiece
gDefaultEncodeHeader v =
  case toSpine v of
    SString s -> s -- Special case string - just use it as is (http-api-data compatibility).
    _ -> show <<< Aeson.encodeJson $ v

-- | Full encoding based on gDefaultToURLPiece
gDefaultEncodeURLPiece :: forall a. Generic a => a -> URLPiece
gDefaultEncodeURLPiece = encodeURIComponent <<< gDefaultToURLPiece

defaultSettings :: forall params. params -> SPSettings_ params
defaultSettings params = SPSettings_ {
    encodeJson : Aeson.encodeJson
  , decodeJson : Aeson.decodeJson
  , toURLPiece : gDefaultToURLPiece
  , params : params
}