Package name option for Java

Package name option for Java

module Language.Java
    ( renderer
    ) where

import Prelude

import Data.Char.Unicode (isAscii, isDigit, isLetter)
import Data.Foldable (for_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.String.Util (camelCase, capitalize, legalizeCharacters, startWithLetter, stringEscape)
import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getOptionValue, getTypeNameForUnion, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, unlessOption)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Options (Option, booleanOption, stringOption)

forbiddenNames :: Array String
forbiddenNames =
    [ "Object", "Class", "System", "Long", "Double", "Boolean", "String", "Map", "Exception", "IOException"
    , "JsonProperty", "JsonDeserialize", "JsonDeserializer", "JsonSerialize", "JsonSerializer"
    , "JsonParser", "JsonProcessingException", "DeserializationContext", "SerializerProvider"
    , "Converter"
    , "abstract", "continue", "for", "new", "switch"
    , "assert", "default", "goto", "package", "synchronized"
    , "boolean", "do", "if", "private", "this"
    , "break", "double", "implements", "protected", "throw"
    , "byte", "else", "import", "public", "throws"
    , "case", "enum", "instanceof", "return", "transient"
    , "catch", "extends", "int", "short", "try"
    , "char", "final", "interface", "static", "void"
    , "class", "finally", "long", "strictfp", "volatile"
    , "const", "float", "native", "super", "while"
    , "null", "false", "true"
    ]

pojoOption :: Option Boolean
pojoOption = booleanOption "just-types" "Plain Java objects only" false

packageOption :: Option String
packageOption = stringOption "package" "The package name for the classes" "NAME" "io.quicktype"

renderer :: Renderer
renderer =
    { displayName: "Java"
    , names: [ "java" ]
    , aceMode: "java"
    , extension: "java"
    , doc: javaDoc
    , options:
        [ pojoOption.specification
        , packageOption.specification
        ]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        , topLevelName: noForbidNamer (javaNameStyle true)
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (javaNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (javaNameStyle true) "Or")
            }
        }
    }

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

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    (isAscii c && isLetter c) || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isStartCharacter c || (isAscii c && isDigit c)

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

javaNameStyle :: Boolean -> String -> String
javaNameStyle upper =
    legalize >>> camelCase >>> startWithLetter isStartCharacter upper

javaDoc :: Doc Unit
javaDoc = do
    unlessOption pojoOption do
        renderConverter
        blank
    renderRenderItems blank Nothing renderClassDefinition (Just renderUnionDefinition)

renderUnionWithTypeRenderer :: (Boolean -> IRType -> Doc String) -> IRUnionRep -> Doc String
renderUnionWithTypeRenderer typeRenderer ur =
    case nullableFromUnion ur of
    Just x -> typeRenderer true x
    Nothing -> lookupUnionName ur

renderType :: Boolean -> IRType -> Doc String
renderType reference = case _ of
    IRNoInformation -> pure "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> pure "Object"
    IRNull -> pure "Object"
    IRInteger -> pure $ if reference then "Long" else "long"
    IRDouble -> pure $ if reference then "Double" else "double"
    IRBool -> pure $ if reference then "Boolean" else "boolean"
    IRString -> pure "String"
    IRArray t -> do
        rendered <- renderType false t
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType true t
        pure $ "Map<String, " <> rendered <> ">"
    IRUnion ur -> renderUnionWithTypeRenderer renderType ur

renderTypeWithoutGenerics :: Boolean -> IRType -> Doc String
renderTypeWithoutGenerics reference = case _ of
    IRArray t -> do
        rendered <- renderTypeWithoutGenerics false t
        pure $ rendered <> "[]"
    IRMap t -> pure "Map"
    IRUnion ur -> renderUnionWithTypeRenderer renderTypeWithoutGenerics ur
    t -> renderType reference t

renderFileComment :: String -> Doc Unit
renderFileComment fileName = do
    line $ "// " <> fileName <> ".java"

renderPackageAndImports :: Array String -> Doc Unit
renderPackageAndImports imports = do
    pojo <- getOptionValue pojoOption
    let allImports = ["java.util.Map"] <> if pojo then [] else imports
    packageName <- getOptionValue packageOption
    line $ "package " <> packageName <> ";"
    blank
    for_ allImports \package -> do
        line $ "import " <> package <> ";"

renderFileHeader :: String -> Array String -> Doc Unit
renderFileHeader fileName imports = do
    renderFileComment fileName
    blank
    renderPackageAndImports imports
    blank

renderConverter :: Doc Unit
renderConverter = do
    renderFileComment "Converter"
    blank
    line """// To use this code, add the following Maven dependency to your project:
//
//     com.fasterxml.jackson.core : jackson-databind : 2.9.0
//
// Import this package:
//"""
    packageName <- getOptionValue packageOption
    line $ "//     import " <> packageName <> ".Converter;"
    line """//
// Then you can deserialize a JSON string with
//"""
    forEachTopLevel_ \topLevelName topLevelType -> do
        topLevelTypeRendered <- renderType false topLevelType
        decoderName <- getDecoderName topLevelName
        line $ "//     " <> topLevelTypeRendered <> " data = Converter." <> decoderName <> "(jsonString);"
    blank
    renderPackageAndImports ["java.io.IOException", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.core.JsonProcessingException"]
    blank
    line "public class Converter {"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderType false topLevelType
            decoderName <- getDecoderName topLevelName
            line $ "public static " <> topLevelTypeRendered <> " " <> decoderName <> "(String json) throws IOException {"
            indent do
                getReaderName <- getReaderGetterName topLevelName
                line $ "return " <> getReaderName <> "().readValue(json);"
            line "}"
            blank
            encoderName <- getEncoderName topLevelName
            line $ "public static String " <> encoderName <> "(" <> topLevelTypeRendered <> " obj) throws JsonProcessingException {"
            indent do
                getWriterName <- getWriterGetterName topLevelName
                line $ "return " <> getWriterName <> "().writeValueAsString(obj);"
            line "}"
        forEachTopLevel_ \topLevelName topLevelType -> do
            readerName <- getFieldOrMethodName "reader" topLevelName
            writerName <- getFieldOrMethodName "writer" topLevelName
            instantiateName <- getMethodName "instantiate" "Mapper" topLevelName
            getReaderName <- getReaderGetterName topLevelName
            getWriterName <- getWriterGetterName topLevelName
            blank
            line $ "private static ObjectReader " <> readerName <> ";"
            line $ "private static ObjectWriter " <> writerName <> ";"
            blank
            line $ "private static void " <> instantiateName <> "() {"
            indent do
                renderedForClass <- renderTypeWithoutGenerics false topLevelType
                line "ObjectMapper mapper = new ObjectMapper();"
                line $ readerName <> " = mapper.reader(" <> renderedForClass <> ".class);"
                line $ writerName <> " = mapper.writerFor(" <> renderedForClass <> ".class);"
            line "}"
            blank
            line $ "private static ObjectReader " <> getReaderName <> "() {"
            indent do
                line $ "if (" <> readerName <> " == null) instantiateMapper();"
                line $ "return " <> readerName <> ";"
            line "}"
            blank
            line $ "private static ObjectWriter " <> getWriterName <> "() {"
            indent do
                line $ "if (" <> writerName <> " == null) instantiateMapper();"
                line $ "return " <> writerName <> ";"
            line "}"
    line "}"
    where
        getDecoderName = getFieldOrMethodName "fromJsonString"
        getEncoderName = getFieldOrMethodName "toJsonString"
        getReaderGetterName = getMethodName "get" "ObjectReader"
        getWriterGetterName = getMethodName "get" "ObjectWriter"

        getFieldOrMethodName :: String -> String -> Doc String
        getFieldOrMethodName methodName topLevelName =
            getForSingleOrMultipleTopLevels methodName (topLevelName <> capitalize methodName)

        getMethodName :: String -> String -> String -> Doc String
        getMethodName prefix suffix topLevelName =
            getForSingleOrMultipleTopLevels (prefix <> suffix) (prefix <> capitalize topLevelName <> suffix)

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    renderFileHeader className ["com.fasterxml.jackson.annotation.*"]
    let propertyNames = transformPropertyNames (simpleNamer $ javaNameStyle false) (\n -> "other" <>  capitalize n) forbiddenNames properties
    pojo <- getOptionValue pojoOption
    when (M.isEmpty properties && not pojo) do
        line "@JsonAutoDetect(fieldVisibility=JsonAutoDetect.Visibility.NONE)"
    line $ "public class " <> className <> " {"
    indent do
        forEachProp_ properties propertyNames \_ javaName fieldName rendered -> do
            line $ "private " <> rendered <> " " <> fieldName <> ";"
        forEachProp_ properties propertyNames \pname javaName fieldName rendered -> do
            blank
            unless pojo do
                line $ "@JsonProperty(\"" <> stringEscape pname <> "\")"
            line $ "public " <> rendered <> " get" <> javaName <> "() { return " <> fieldName <> "; }"
            line $ "public void set" <> javaName <> "(" <> rendered <> " value) { this." <> fieldName <> " = value; }"
    line "}"
    where
        forEachProp_ :: Map String IRType -> Map String String -> (String -> String -> String -> String -> Doc Unit) -> Doc Unit
        forEachProp_ properties' propertyNames f =
            forEachProperty_ properties' propertyNames \pname ptype fieldName _ -> do
                let javaName = capitalize fieldName
                rendered <- renderType false ptype
                f pname javaName fieldName rendered

renderUnionField :: IRType -> Doc { renderedType :: String, fieldName :: String }
renderUnionField t = do
    renderedType <- renderType true t
    fieldName <- javaNameStyle false <$> (_ <> "_value") <$> getTypeNameForUnion t
    pure { renderedType, fieldName }

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case " <> tokenType <> ":"

renderNullCase :: Doc Unit
renderNullCase = do
    tokenCase "VALUE_NULL"
    indent do
        line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    { fieldName } <- renderUnionField t
    renderedType <- renderTypeWithoutGenerics true t
    line $ "value." <> fieldName <> " = jsonParser.readValueAs(" <> renderedType <> ".class);"
    line "break;"

renderPrimitiveCase :: Array String -> IRType -> IRUnionRep -> Doc Unit
renderPrimitiveCase tokenTypes t union =
    when (isUnionMember t union) do
        for_ tokenTypes \tokenType ->
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleCase :: IRUnionRep -> Doc Unit
renderDoubleCase union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "VALUE_NUMBER_INT"
        tokenCase "VALUE_NUMBER_FLOAT"
        indent do
            deserializeType IRDouble

renderGenericCase :: (IRUnionRep -> Maybe IRType) -> String -> IRUnionRep -> Doc Unit
renderGenericCase predicate tokenType union =
    case predicate union of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderUnionDefinition :: String -> IRUnionRep -> Doc Unit
renderUnionDefinition unionName unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    renderFileHeader unionName ["java.io.IOException", "com.fasterxml.jackson.core.*", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.databind.annotation.*"]
    pojo <- getOptionValue pojoOption
    unless pojo do
        line $ "@JsonDeserialize(using = " <> unionName <> ".Deserializer.class)"
        line $ "@JsonSerialize(using = " <> unionName <> ".Serializer.class)"
    line $ "public class " <> unionName <> " {"
    indent do
        forUnion_ nonNullUnion \t -> do
            { renderedType, fieldName } <- renderUnionField t
            line $ "public " <> renderedType <> " " <> fieldName <> ";"

        unless pojo do
            blank
            line $ "static class Deserializer extends JsonDeserializer<" <> unionName <> "> {"
            indent do
                line "@Override"
                line $ "public " <> unionName <> " deserialize(JsonParser jsonParser, DeserializationContext deserializationContext) throws IOException, JsonProcessingException {"
                indent do
                    line $ unionName <> " value = new " <> unionName <> "();"
                    line "switch (jsonParser.getCurrentToken()) {"
                    when hasNull renderNullCase
                    renderPrimitiveCase ["VALUE_NUMBER_INT"] IRInteger nonNullUnion
                    renderDoubleCase nonNullUnion
                    renderPrimitiveCase ["VALUE_TRUE", "VALUE_FALSE"] IRBool nonNullUnion
                    renderPrimitiveCase ["VALUE_STRING"] IRString nonNullUnion
                    renderGenericCase unionHasArray "START_ARRAY" nonNullUnion
                    renderGenericCase unionHasClass "START_OBJECT" nonNullUnion
                    renderGenericCase unionHasMap "START_OBJECT" nonNullUnion
                    line $ "default: throw new IOException(\"Cannot deserialize " <> unionName <> "\");"
                    line "}"
                    line "return value;"
                line "}"
            line "}"
            blank

            line $ "static class Serializer extends JsonSerializer<" <> unionName <> "> {"
            indent do
                line "@Override"
                line $ "public void serialize(" <> unionName <> " obj, JsonGenerator jsonGenerator, SerializerProvider serializerProvider) throws IOException {"
                indent do
                    forUnion_ nonNullUnion \field -> do
                        { fieldName } <- renderUnionField field
                        line $ "if (obj." <> fieldName <> " != null) {"
                        indent do
                            line $ "jsonGenerator.writeObject(obj." <> fieldName <> ");"
                            line "return;"
                        line "}"
                    if hasNull
                        then
                            line "jsonGenerator.writeNull();"
                        else
                            line $ "throw new IOException(\"" <> unionName <> " must not be null\");"
                line "}"
            line "}"
    line "}"

module Language.Java
    ( renderer
    ) where

import Prelude

import Data.Char.Unicode (isAscii, isDigit, isLetter)
import Data.Foldable (for_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.String.Util (camelCase, capitalize, legalizeCharacters, startWithLetter, stringEscape)
import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getOptionValue, getTypeNameForUnion, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, unlessOption)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Options (Option, booleanOption)

forbiddenNames :: Array String
forbiddenNames =
    [ "Object", "Class", "System", "Long", "Double", "Boolean", "String", "Map", "Exception", "IOException"
    , "JsonProperty", "JsonDeserialize", "JsonDeserializer", "JsonSerialize", "JsonSerializer"
    , "JsonParser", "JsonProcessingException", "DeserializationContext", "SerializerProvider"
    , "Converter"
    , "abstract", "continue", "for", "new", "switch"
    , "assert", "default", "goto", "package", "synchronized"
    , "boolean", "do", "if", "private", "this"
    , "break", "double", "implements", "protected", "throw"
    , "byte", "else", "import", "public", "throws"
    , "case", "enum", "instanceof", "return", "transient"
    , "catch", "extends", "int", "short", "try"
    , "char", "final", "interface", "static", "void"
    , "class", "finally", "long", "strictfp", "volatile"
    , "const", "float", "native", "super", "while"
    , "null", "false", "true"
    ]

pojoOption :: Option Boolean
pojoOption = booleanOption "just-types" "Plain Java objects only" false

renderer :: Renderer
renderer =
    { displayName: "Java"
    , names: [ "java" ]
    , aceMode: "java"
    , extension: "java"
    , doc: javaDoc
    , options: [pojoOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        , topLevelName: noForbidNamer (javaNameStyle true)
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (javaNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (javaNameStyle true) "Or")
            }
        }
    }

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

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    (isAscii c && isLetter c) || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isStartCharacter c || (isAscii c && isDigit c)

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

javaNameStyle :: Boolean -> String -> String
javaNameStyle upper =
    legalize >>> camelCase >>> startWithLetter isStartCharacter upper

javaDoc :: Doc Unit
javaDoc = do
    unlessOption pojoOption do
        renderConverter
        blank
    renderRenderItems blank Nothing renderClassDefinition (Just renderUnionDefinition)

renderUnionWithTypeRenderer :: (Boolean -> IRType -> Doc String) -> IRUnionRep -> Doc String
renderUnionWithTypeRenderer typeRenderer ur =
    case nullableFromUnion ur of
    Just x -> typeRenderer true x
    Nothing -> lookupUnionName ur

renderType :: Boolean -> IRType -> Doc String
renderType reference = case _ of
    IRNoInformation -> pure "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> pure "Object"
    IRNull -> pure "Object"
    IRInteger -> pure $ if reference then "Long" else "long"
    IRDouble -> pure $ if reference then "Double" else "double"
    IRBool -> pure $ if reference then "Boolean" else "boolean"
    IRString -> pure "String"
    IRArray t -> do
        rendered <- renderType false t
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType true t
        pure $ "Map<String, " <> rendered <> ">"
    IRUnion ur -> renderUnionWithTypeRenderer renderType ur

renderTypeWithoutGenerics :: Boolean -> IRType -> Doc String
renderTypeWithoutGenerics reference = case _ of
    IRArray t -> do
        rendered <- renderTypeWithoutGenerics false t
        pure $ rendered <> "[]"
    IRMap t -> pure "Map"
    IRUnion ur -> renderUnionWithTypeRenderer renderTypeWithoutGenerics ur
    t -> renderType reference t

renderFileComment :: String -> Doc Unit
renderFileComment fileName = do
    line $ "// " <> fileName <> ".java"

renderPackageAndImports :: Array String -> Doc Unit
renderPackageAndImports imports = do
    pojo <- getOptionValue pojoOption
    let allImports = ["java.util.Map"] <> if pojo then [] else imports
    line "package io.quicktype;"
    blank
    for_ allImports \package -> do
        line $ "import " <> package <> ";"

renderFileHeader :: String -> Array String -> Doc Unit
renderFileHeader fileName imports = do
    renderFileComment fileName
    blank
    renderPackageAndImports imports
    blank

renderConverter :: Doc Unit
renderConverter = do
    renderFileComment "Converter"
    blank
    line """// To use this code, add the following Maven dependency to your project:
//
//     com.fasterxml.jackson.core : jackson-databind : 2.9.0
//
// Import this package:
//
//     import io.quicktype.Converter;
//
// Then you can deserialize a JSON string with
//"""
    forEachTopLevel_ \topLevelName topLevelType -> do
        topLevelTypeRendered <- renderType false topLevelType
        decoderName <- getDecoderName topLevelName
        line $ "//     " <> topLevelTypeRendered <> " data = Converter." <> decoderName <> "(jsonString);"
    blank
    renderPackageAndImports ["java.io.IOException", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.core.JsonProcessingException"]
    blank
    line "public class Converter {"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderType false topLevelType
            decoderName <- getDecoderName topLevelName
            line $ "public static " <> topLevelTypeRendered <> " " <> decoderName <> "(String json) throws IOException {"
            indent do
                getReaderName <- getReaderGetterName topLevelName
                line $ "return " <> getReaderName <> "().readValue(json);"
            line "}"
            blank
            encoderName <- getEncoderName topLevelName
            line $ "public static String " <> encoderName <> "(" <> topLevelTypeRendered <> " obj) throws JsonProcessingException {"
            indent do
                getWriterName <- getWriterGetterName topLevelName
                line $ "return " <> getWriterName <> "().writeValueAsString(obj);"
            line "}"
        forEachTopLevel_ \topLevelName topLevelType -> do
            readerName <- getFieldOrMethodName "reader" topLevelName
            writerName <- getFieldOrMethodName "writer" topLevelName
            instantiateName <- getMethodName "instantiate" "Mapper" topLevelName
            getReaderName <- getReaderGetterName topLevelName
            getWriterName <- getWriterGetterName topLevelName
            blank
            line $ "private static ObjectReader " <> readerName <> ";"
            line $ "private static ObjectWriter " <> writerName <> ";"
            blank
            line $ "private static void " <> instantiateName <> "() {"
            indent do
                renderedForClass <- renderTypeWithoutGenerics false topLevelType
                line "ObjectMapper mapper = new ObjectMapper();"
                line $ readerName <> " = mapper.reader(" <> renderedForClass <> ".class);"
                line $ writerName <> " = mapper.writerFor(" <> renderedForClass <> ".class);"
            line "}"
            blank
            line $ "private static ObjectReader " <> getReaderName <> "() {"
            indent do
                line $ "if (" <> readerName <> " == null) instantiateMapper();"
                line $ "return " <> readerName <> ";"
            line "}"
            blank
            line $ "private static ObjectWriter " <> getWriterName <> "() {"
            indent do
                line $ "if (" <> writerName <> " == null) instantiateMapper();"
                line $ "return " <> writerName <> ";"
            line "}"
    line "}"
    where
        getDecoderName = getFieldOrMethodName "fromJsonString"
        getEncoderName = getFieldOrMethodName "toJsonString"
        getReaderGetterName = getMethodName "get" "ObjectReader"
        getWriterGetterName = getMethodName "get" "ObjectWriter"

        getFieldOrMethodName :: String -> String -> Doc String
        getFieldOrMethodName methodName topLevelName =
            getForSingleOrMultipleTopLevels methodName (topLevelName <> capitalize methodName)

        getMethodName :: String -> String -> String -> Doc String
        getMethodName prefix suffix topLevelName =
            getForSingleOrMultipleTopLevels (prefix <> suffix) (prefix <> capitalize topLevelName <> suffix)

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    renderFileHeader className ["com.fasterxml.jackson.annotation.*"]
    let propertyNames = transformPropertyNames (simpleNamer $ javaNameStyle false) (\n -> "other" <>  capitalize n) forbiddenNames properties
    pojo <- getOptionValue pojoOption
    when (M.isEmpty properties && not pojo) do
        line "@JsonAutoDetect(fieldVisibility=JsonAutoDetect.Visibility.NONE)"
    line $ "public class " <> className <> " {"
    indent do
        forEachProp_ properties propertyNames \_ javaName fieldName rendered -> do
            line $ "private " <> rendered <> " " <> fieldName <> ";"
        forEachProp_ properties propertyNames \pname javaName fieldName rendered -> do
            blank
            unless pojo do
                line $ "@JsonProperty(\"" <> stringEscape pname <> "\")"
            line $ "public " <> rendered <> " get" <> javaName <> "() { return " <> fieldName <> "; }"
            line $ "public void set" <> javaName <> "(" <> rendered <> " value) { this." <> fieldName <> " = value; }"
    line "}"
    where
        forEachProp_ :: Map String IRType -> Map String String -> (String -> String -> String -> String -> Doc Unit) -> Doc Unit
        forEachProp_ properties' propertyNames f =
            forEachProperty_ properties' propertyNames \pname ptype fieldName _ -> do
                let javaName = capitalize fieldName
                rendered <- renderType false ptype
                f pname javaName fieldName rendered

renderUnionField :: IRType -> Doc { renderedType :: String, fieldName :: String }
renderUnionField t = do
    renderedType <- renderType true t
    fieldName <- javaNameStyle false <$> (_ <> "_value") <$> getTypeNameForUnion t
    pure { renderedType, fieldName }

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case " <> tokenType <> ":"

renderNullCase :: Doc Unit
renderNullCase = do
    tokenCase "VALUE_NULL"
    indent do
        line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    { fieldName } <- renderUnionField t
    renderedType <- renderTypeWithoutGenerics true t
    line $ "value." <> fieldName <> " = jsonParser.readValueAs(" <> renderedType <> ".class);"
    line "break;"

renderPrimitiveCase :: Array String -> IRType -> IRUnionRep -> Doc Unit
renderPrimitiveCase tokenTypes t union =
    when (isUnionMember t union) do
        for_ tokenTypes \tokenType ->
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleCase :: IRUnionRep -> Doc Unit
renderDoubleCase union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "VALUE_NUMBER_INT"
        tokenCase "VALUE_NUMBER_FLOAT"
        indent do
            deserializeType IRDouble

renderGenericCase :: (IRUnionRep -> Maybe IRType) -> String -> IRUnionRep -> Doc Unit
renderGenericCase predicate tokenType union =
    case predicate union of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderUnionDefinition :: String -> IRUnionRep -> Doc Unit
renderUnionDefinition unionName unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    renderFileHeader unionName ["java.io.IOException", "com.fasterxml.jackson.core.*", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.databind.annotation.*"]
    pojo <- getOptionValue pojoOption
    unless pojo do
        line $ "@JsonDeserialize(using = " <> unionName <> ".Deserializer.class)"
        line $ "@JsonSerialize(using = " <> unionName <> ".Serializer.class)"
    line $ "public class " <> unionName <> " {"
    indent do
        forUnion_ nonNullUnion \t -> do
            { renderedType, fieldName } <- renderUnionField t
            line $ "public " <> renderedType <> " " <> fieldName <> ";"

        unless pojo do
            blank
            line $ "static class Deserializer extends JsonDeserializer<" <> unionName <> "> {"
            indent do
                line "@Override"
                line $ "public " <> unionName <> " deserialize(JsonParser jsonParser, DeserializationContext deserializationContext) throws IOException, JsonProcessingException {"
                indent do
                    line $ unionName <> " value = new " <> unionName <> "();"
                    line "switch (jsonParser.getCurrentToken()) {"
                    when hasNull renderNullCase
                    renderPrimitiveCase ["VALUE_NUMBER_INT"] IRInteger nonNullUnion
                    renderDoubleCase nonNullUnion
                    renderPrimitiveCase ["VALUE_TRUE", "VALUE_FALSE"] IRBool nonNullUnion
                    renderPrimitiveCase ["VALUE_STRING"] IRString nonNullUnion
                    renderGenericCase unionHasArray "START_ARRAY" nonNullUnion
                    renderGenericCase unionHasClass "START_OBJECT" nonNullUnion
                    renderGenericCase unionHasMap "START_OBJECT" nonNullUnion
                    line $ "default: throw new IOException(\"Cannot deserialize " <> unionName <> "\");"
                    line "}"
                    line "return value;"
                line "}"
            line "}"
            blank

            line $ "static class Serializer extends JsonSerializer<" <> unionName <> "> {"
            indent do
                line "@Override"
                line $ "public void serialize(" <> unionName <> " obj, JsonGenerator jsonGenerator, SerializerProvider serializerProvider) throws IOException {"
                indent do
                    forUnion_ nonNullUnion \field -> do
                        { fieldName } <- renderUnionField field
                        line $ "if (obj." <> fieldName <> " != null) {"
                        indent do
                            line $ "jsonGenerator.writeObject(obj." <> fieldName <> ");"
                            line "return;"
                        line "}"
                    if hasNull
                        then
                            line "jsonGenerator.writeNull();"
                        else
                            line $ "throw new IOException(\"" <> unionName <> " must not be null\");"
                line "}"
            line "}"
    line "}"


Get text value of a node

Get text value of a node

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.HTML
import DOM.HTML.Types
import DOM.HTML.Window
import DOM.HTML.Document
import DOM.Node.Types
import DOM.Node.Element hiding (id)
import qualified DOM.Node.HTMLCollection as C
import Data.Nullable (Nullable(), toMaybe)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import qualified DOM.Node.Node as N

cardImgURL :: String -> String
cardImgURL "Purelace"       = "http://magiccards.info/scans/en/4e/293.jpg"
cardImgURL "Thoughtflare"   = "http://magiccards.info/scans/en/rtr/203.jpg"
cardImgURL "Memoricide"     = "http://magiccards.info/scans/en/mbp/29.jpg"
cardImgURL "Chill"          = "http://magiccards.info/scans/en/arena/19.jpg"
cardImgURL _                = "http://magiccards.info/scans/en/uhaa/44.jpg"

coerceE :: HTMLElement -> Element
coerceE = htmlElementToElement

coerceD :: HTMLDocument -> Document
coerceD = htmlDocumentToDocument

htmlBody :: forall eff. Eff (dom :: DOM | eff) (Nullable HTMLElement)
htmlBody = do
  w <- window
  d <- document w
  body d

main :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
main = do
  hb <- htmlBody
  let b = coerceE $ fromJust $ toMaybe $ hb
  hes  <- getElementsByClassName "card" b
  one  <- C.item 1 hes
  v    <- N.textContent $ elementToNode $ fromJust $ toMaybe $ one
  log $ "Wow! " ++ show v

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.HTML
import DOM.HTML.Types
import DOM.HTML.Window
import DOM.HTML.Document
import DOM.Node.Types
import DOM.Node.Element hiding (id)
import qualified DOM.Node.HTMLCollection as C
import Data.Nullable (Nullable(), toMaybe)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)

cardImgURL :: String -> String
cardImgURL "Purelace"       = "http://magiccards.info/scans/en/4e/293.jpg"
cardImgURL "Thoughtflare"   = "http://magiccards.info/scans/en/rtr/203.jpg"
cardImgURL "Memoricide"     = "http://magiccards.info/scans/en/mbp/29.jpg"
cardImgURL "Chill"          = "http://magiccards.info/scans/en/arena/19.jpg"
cardImgURL _                = "http://magiccards.info/scans/en/uhaa/44.jpg"

coerceE :: HTMLElement -> Element
coerceE = htmlElementToElement

coerceD :: HTMLDocument -> Document
coerceD = htmlDocumentToDocument

htmlBody :: forall eff. Eff (dom :: DOM | eff) (Nullable HTMLElement)
htmlBody = do
  w <- window
  d <- document w
  body d

main :: forall eff. Eff (console :: CONSOLE, dom :: DOM | eff) Unit
main = do
  hb <- htmlBody
  let b = coerceE $ fromJust $ toMaybe $ hb
  hes <- getElementsByClassName "card" b
  x   <- C.length hes
  log $ "Wow! " ++ show x


Clarify

Clarify

Original commit e605900e15e88c40f1f7b2462d2c92265d4af441

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import Environment (Environment(..))
import Environment as Env

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

type Pipeline = Doc.Renderer -> Json -> Either Error String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

jsonPipeline :: Pipeline
jsonPipeline renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

jsonSchemaPipeline :: Pipeline
jsonSchemaPipeline renderer json =
    json
    # J.decodeJson
    >>= makeTypeFromSchema "TopLevel"
    <#> regatherClassNames
    <#> Doc.runRenderer renderer

pipelines :: Environment -> Array Pipeline
pipelines Development = [jsonSchemaPipeline, jsonPipeline]
pipelines Production = [jsonPipeline]

firstSuccess :: Array Pipeline -> Pipeline
firstSuccess pipes renderer json = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline renderer json

renderForUI :: Doc.Renderer -> String -> Either Error String
renderForUI renderer json = do
    obj <- J.jsonParser json
    firstSuccess (pipelines Env.current) renderer obj

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import Environment (Environment(..))
import Environment as Env

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

type Pipeline = Doc.Renderer -> Json -> Either Error String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

jsonPipeline :: Pipeline
jsonPipeline renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

jsonSchemaPipeline :: Pipeline
jsonSchemaPipeline renderer json =
    json
    # J.decodeJson
    >>= makeTypeFromSchema "TopLevel"
    <#> regatherClassNames
    <#> Doc.runRenderer renderer

pipelines :: Environment -> Array Pipeline
pipelines Development = [jsonSchemaPipeline, jsonPipeline]
pipelines Production = [jsonPipeline]

firstSuccess :: Array Pipeline -> Pipeline
firstSuccess pipes renderer json = foldl takeFirstRight (Left "") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline renderer json

renderForUI :: Doc.Renderer -> String -> Either Error String
renderForUI renderer json = do
    obj <- J.jsonParser json
    firstSuccess (pipelines Env.current) renderer obj


Simpler

Simpler

Original commit fd9cbf065d8f5ac3f201cab8f639db706a18da28

module Main where

import Prelude

import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Foldable (for_)

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

import Data.StrMap (StrMap, foldMap) as StrMap

import Doc

type IRProperty = { name :: String, typ :: IRType }
type IRClassData = { name :: String, properties :: L.List IRProperty }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Array IRType)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    -- Convert from Array to List before we match to make things tidier (foldJson is pretty crude)
    (L.fromFoldable >>> case _ of
        Nil -> IRArray IRNothing
        Cons x _ -> IRArray $ makeTypeFromJson (singularize name) x)
    (\o -> IRClass { name, properties: mapProperties o })
    json

mapProperties :: StrMap.StrMap Json -> L.List IRProperty
mapProperties sm = StrMap.foldMap toProperty sm
  where toProperty name json = L.singleton { name, typ: makeTypeFromJson name json }

singularize :: String -> String
singularize s = "OneOf" <> s

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType (IRClass cls) = cls : L.concatMap (gatherClassesFromType <<< _.typ) cls.properties
gatherClassesFromType (IRArray t) = gatherClassesFromType t
gatherClassesFromType _ = empty

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp IRNothing = "object"
renderTypeToCSharp IRNull = "object"
renderTypeToCSharp IRInteger = "int"
renderTypeToCSharp IRDouble = "double"
renderTypeToCSharp IRBool = "bool"
renderTypeToCSharp IRString = "string"
renderTypeToCSharp (IRArray a) = renderTypeToCSharp a <> "[]"
renderTypeToCSharp (IRClass { name }) = name
renderTypeToCSharp (IRUnion _) = "FIXME"

renderClassToCSharp :: IRClassData -> Doc Unit
renderClassToCSharp { name, properties } = do
    line $ words ["class", name]
    line "{"
    indent do
        for_ properties \p -> line do
            string "public "
            string $ renderTypeToCSharp p.typ
            words ["", p.name, "{ get; set; }"]
    line "}"

renderClassesToCSharp :: L.List IRClassData -> Doc Unit
renderClassesToCSharp classes = for_ classes \cls -> do
    renderClassToCSharp cls
    blank

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClassesToCSharp
    <#> render

module Main where

import Prelude

import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Foldable (for_)

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

import Data.StrMap (StrMap, foldMap) as StrMap

import Doc

type IRProperty = { name :: String, typ :: IRType }
type IRClassData = { name :: String, properties :: L.List IRProperty }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Array IRType)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    -- Convert from Array to List before we match to make things tidier (foldJson is pretty crude)
    (L.fromFoldable >>> case _ of
        Nil -> IRArray IRNothing
        Cons x _ -> IRArray $ makeTypeFromJson (singularize name) x)
    (\o -> IRClass { name, properties: mapProperties o })
    json

mapProperties :: StrMap.StrMap Json -> L.List IRProperty
mapProperties sm = StrMap.foldMap toProperty sm
  where toProperty name json = L.singleton { name, typ: makeTypeFromJson name json }

singularize :: String -> String
singularize s = "OneOf" <> s

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType (IRClass classData@{ name, properties }) =
     classData : L.concatMap gatherClassesFromType (_.typ <$> properties)
gatherClassesFromType (IRArray t) = gatherClassesFromType t
gatherClassesFromType _ = empty

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp IRNothing = "object"
renderTypeToCSharp IRNull = "object"
renderTypeToCSharp IRInteger = "int"
renderTypeToCSharp IRDouble = "double"
renderTypeToCSharp IRBool = "bool"
renderTypeToCSharp IRString = "string"
renderTypeToCSharp (IRArray a) = renderTypeToCSharp a <> "[]"
renderTypeToCSharp (IRClass { name }) = name
renderTypeToCSharp (IRUnion _) = "FIXME"

renderClassToCSharp :: IRClassData -> Doc Unit
renderClassToCSharp { name, properties } = do
    line $ words ["class", name]
    line "{"
    indent do
        for_ properties \p -> line do
            string "public "
            string $ renderTypeToCSharp p.typ
            words ["", p.name, "{ get; set; }"]
    line "}"

renderClassesToCSharp :: L.List IRClassData -> Doc Unit
renderClassesToCSharp classes = for_ classes \cls -> do
    renderClassToCSharp cls
    blank

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClassesToCSharp
    <#> render


Refactor.

Refactor.

module Main where

import Prelude hiding (append)

import Control.Comonad (extract)
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.JQuery (JQuery, append, body, clone, find, getText, hide, on', ready, select, setAttr, setClass, setText, toArray)
import Control.Monad.Eff.Now (NOW, nowDate)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, newRef)
import Control.Monad.Except (runExcept)

import Data.AppState (AppState(..), CardKey, SelectedCity(..), selectedCitiesKey)
import Data.Array (drop, elem, findIndex, index, singleton, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F)
import Data.Foreign.Generic (defaultOptions, readJSONGeneric)
import Data.Foreign.WeatherService as WeatherService
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, fromMaybe')
import Data.Tuple.Nested (Tuple3, get1, get2, get3)
import Data.WeatherCard (WeatherCard, ForecastData, fromWeatherService)
import Data.Zippable (zip3)

import DOM (DOM)
import DOM.WebStorage (STORAGE, getItem, setItem, getLocalStorage)
import Partial.Unsafe (unsafePartial)

import Network.HTTP.Affjax (AJAX, get)

foreign import test :: Int

type WeekDay = String

main :: forall e. Eff ( ajax :: AJAX
                      , console :: CONSOLE
                      , dom :: DOM
                      , err :: EXCEPTION
                      , locale :: LOCALE
                      , now :: NOW
                      , ref :: REF
                      , storage :: STORAGE
                      | e ) Unit
main = ready $ do
  spinner <- select ".loader"
  cardTemplate <- select ".cardTemplate"
  container <- select ".main"
  addDialog <- select ".dialog-container"

  body <- body
  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body

  localStorage <- getLocalStorage
  storedSelectedCities <- getItem localStorage selectedCitiesKey

  let selectedCities = fromMaybe' (\_ -> initialSelectedCity) storedSelectedCities

  stateRef <- newRef $ AppState { isLoading: true
                                , visibleCards: Map.empty
                                , selectedCities
                                , spinner
                                , cardTemplate
                                , container
                                , addDialog }

  case storedSelectedCities of
    Just cities ->
      foreachE cities \(SelectedCity { key, label }) -> getForecast stateRef key label
    Nothing -> do
      -- The user is using the app for the first time, or the user has not
      -- saved any cities, so show the user some fake data. A real app in this
      -- scenario could guess the user's location via IP lookup and then inject
      -- that data into the page.
      updateForecastCard stateRef initialWeatherForecast
      saveSelectedCities stateRef

-- Methods to update/refresh the UI --

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData =
  let key = cardData.key
      current = cardData.channel.item.condition
      forcast = cardData.channel.item.forecast
      astronomy = cardData.channel.astronomy
  in do
    card <- getOrCreateCard stateRef key
    cardLastUpdatedElem <- find "> .card-last-updated" card
    cardLastUpdatedStr <- getText cardLastUpdatedElem

    dataIsOld <- if cardLastUpdatedStr == ""
      then pure false
      else do
        dataLastUpdatedJSDate <- parse cardData.created
        cardLastUpdatedJSDate <- parse cardLastUpdatedStr
        pure $ let dataLastUpdated = unsafePartial $ fromJust (toDateTime dataLastUpdatedJSDate)
                   cardLastUpdated = unsafePartial $ fromJust (toDateTime cardLastUpdatedJSDate)
               in cardLastUpdated > dataLastUpdated

    if dataIsOld
      then log $ "Old data: " <> cardLastUpdatedStr <> ", " <> cardData.created
      else do
        setText cardData.created cardLastUpdatedElem
        find "> .location" card >>= setText cardData.label
        find "> .description" card >>= setText current.text
        find "> .date" card >>= setText current.date
        find ".current .icon" card >>= setClass (getIconClass current.code) true
        find ".current .temperature .value" card >>= (setText $ show current.temp)
        find ".current .sunrise" card >>= setText astronomy.sunrise
        find ".current .sunset" card >>= setText astronomy.sunset
        find ".current .humidity" card >>= (setText $ show cardData.channel.atmosphere.humidity <> "%")
        find ".current .wind .value" card >>= (setText $ show cardData.channel.wind.speed)
        find ".current .wind .direction" card >>= (setText $ show cardData.channel.wind.direction)

        nextDays <- find ".future .oneday" card >>= toArray
        ndw <- nextDaysOfWeek
        foreachE (zip3 nextDays forcast ndw) updateNextDay

        AppState state <- readRef stateRef
        when state.isLoading do
          hide state.spinner
          modifyRef stateRef \(AppState s) -> AppState s { isLoading = false }

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t =
  let c = get1 t
      daily = get2 t
      wd = get3 t
  in do
    find ".icon" c >>= setClass (getIconClass daily.code) true
    find ".date" c >>= setText wd
    find ".temp-high .value" c >>= (setText $ show daily.high)
    find ".temp-low .value" c >>= (setText $ show daily.low)

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case Map.lookup key state.visibleCards of
    Just card -> pure card
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      newCard <- clone state.cardTemplate
      setClass "cardTemplate" false newCard
      setAttr "hidden" false newCard
      append newCard state.container
      modifyRef stateRef $ addCardForKey key newCard
      pure newCard

-- Methods for dealing with the model --

-- | Gets a forecast for a specific city and updates the card with the data.
-- | `getForecast` first checks if the weather data is in the cache. If so,
-- | then it gets that data and populates the card with the cached data.
-- | Then, `getForecast` goes to the network for fresh data. If the network
-- | request goes through, then the card gets updated a second time with the
-- | freshest data.
getForecast
  :: forall e
   . Ref AppState
  -> CardKey
  -> String
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
getForecast stateRef key label =
  let statement = "select * from weather.forecast where woeid=" <> key
      url = "https://query.yahooapis.com/v1/public/yql?format=json&q=" <> statement
      readOpts = defaultOptions { unwrapSingleConstructors = true }
  in void $ launchAff do
    request <- get url
    case runExcept (readJSONGeneric readOpts request.response :: F WeatherService.Response) of
      Left err -> liftEff $ log (show err)
      Right response ->
        case fromWeatherService key label response of
          Just cardData -> liftEff $ updateForecastCard stateRef cardData
          Nothing -> liftEff $ log "Bad weather service response"

-- | Save list of cities to localStorage.
saveSelectedCities
  :: forall e
   . Ref AppState
  -> Eff (dom :: DOM, ref :: REF, storage :: STORAGE | e) Unit
saveSelectedCities stateRef = do
  AppState state <- readRef stateRef
  localStorage <- getLocalStorage
  setItem localStorage selectedCitiesKey state.selectedCities

today :: forall e. Eff (now :: NOW | e) Date
today = extract <$> nowDate

weekdayFromEnum :: Date -> Int
weekdayFromEnum = fromEnum <<< weekday

daysOfWeek :: Array WeekDay
daysOfWeek = ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"]

nextDaysOfWeek :: forall e. Eff (now :: NOW | e) (Array WeekDay)
nextDaysOfWeek = do
  d <- weekdayFromEnum <$> today
  pure $ drop d (daysOfWeek <> daysOfWeek)

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = Map.insert key card state.visibleCards }

-- | Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes :: Array (Array Int)
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses :: Array String
weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast =
  { key: "2459115"
  , label: "New York, NY"
  , created: "2016-07-22T01:00:00Z"
  , channel: {
      astronomy: {
        sunrise: "5:43 am"
      , sunset: "8:21 pm"
      }
    , item: {
        condition: {
          text: "Windy"
        , date: "Thu, 21 Jul 2016 09:00 PM EDT"
        , temp: 56
        , code: 24
        }
      , forecast: [
          {code: 44, high: 86, low: 70}
        , {code: 44, high: 94, low: 73}
        , {code: 4, high: 95, low: 78}
        , {code: 24, high: 75, low: 89}
        , {code: 24, high: 89, low: 77}
        , {code: 44, high: 92, low: 79}
        , {code: 44, high: 89, low: 77}
        ]
      }
    , atmosphere: {humidity: 56}
    , wind: {
        speed: 25
      , direction: 195
      }
    }
  }

initialSelectedCity :: Array SelectedCity
initialSelectedCity = singleton $ SelectedCity { key: initialWeatherForecast.key
                                               , label: initialWeatherForecast.label }

module Main where

import Prelude hiding (append)

import Control.Comonad (extract)
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.JQuery (JQuery, append, body, clone, find, getText, hide, on', ready, select, setAttr, setClass, setText, toArray)
import Control.Monad.Eff.Now (NOW, nowDate)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, newRef)
import Control.Monad.Except (runExcept)

import Data.AppState (AppState(..), CardKey, SelectedCity(..), selectedCitiesKey)
import Data.Array (drop, elem, findIndex, index, singleton, (..))
import Data.Date (Date, weekday)
import Data.Either (Either(..))
import Data.Enum (fromEnum)
import Data.Foreign (F)
import Data.Foreign.Generic (defaultOptions, readJSONGeneric)
import Data.Foreign.WeatherService as WeatherService
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, fromMaybe')
import Data.Tuple.Nested (Tuple3, get1, get2, get3)
import Data.WeatherCard (WeatherCard, ForecastData, fromWeatherService)
import Data.Zippable (zip3)

import DOM (DOM)
import DOM.WebStorage (STORAGE, getItem, setItem, getLocalStorage)
import Partial.Unsafe (unsafePartial)

import Network.HTTP.Affjax (AJAX, get)

foreign import test :: Int

type WeekDay = String

main :: forall e. Eff ( ajax :: AJAX
                      , console :: CONSOLE
                      , dom :: DOM
                      , err :: EXCEPTION
                      , locale :: LOCALE
                      , now :: NOW
                      , ref :: REF
                      , storage :: STORAGE
                      | e ) Unit
main = ready $ do
  spinner <- select ".loader"
  cardTemplate <- select ".cardTemplate"
  container <- select ".main"
  addDialog <- select ".dialog-container"

  body <- body
  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body

  localStorage <- getLocalStorage
  storedSelectedCities <- getItem localStorage selectedCitiesKey

  let selectedCities = fromMaybe' (\_ -> initialSelectedCity) storedSelectedCities

  stateRef <- newRef $ AppState { isLoading: true
                                , visibleCards: Map.empty
                                , selectedCities
                                , spinner
                                , cardTemplate
                                , container
                                , addDialog }

  case storedSelectedCities of
    Just cities ->
      foreachE cities \(SelectedCity { key, label }) -> getForecast stateRef key label
    Nothing -> do
      -- The user is using the app for the first time, or the user has not
      -- saved any cities, so show the user some fake data. A real app in this
      -- scenario could guess the user's location via IP lookup and then inject
      -- that data into the page.
      updateForecastCard stateRef initialWeatherForecast
      saveSelectedCities stateRef

-- Methods to update/refresh the UI --

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, now :: NOW, ref :: REF | e) Unit
updateForecastCard stateRef cardData =
  let key = cardData.key
      current = cardData.channel.item.condition
      forcast = cardData.channel.item.forecast
  in do
    card <- getOrCreateCard stateRef key
    cardLastUpdatedElem <- find "> .card-last-updated" card
    cardLastUpdatedStr <- getText cardLastUpdatedElem

    dataIsOld <- if cardLastUpdatedStr == ""
      then pure Nothing
      else do
        dataLastUpdatedJSDate <- parse cardData.created
        cardLastUpdatedJSDate <- parse cardLastUpdatedStr
        pure $ let dataLastUpdated = unsafePartial $ fromJust (toDateTime dataLastUpdatedJSDate)
                   cardLastUpdated = unsafePartial $ fromJust (toDateTime cardLastUpdatedJSDate)
               in Just (cardLastUpdated > dataLastUpdated)

    let updateCard = do
          setText cardData.created cardLastUpdatedElem
          find "> .location" card >>= setText cardData.label
          find "> .description" card >>= setText current.text
          find "> .date" card >>= setText current.date
          find ".current .icon" card >>= setClass (getIconClass current.code) true
          find ".current .temperature .value" card >>= (setText $ show current.temp)
          find ".current .sunrise" card >>= setText cardData.channel.astronomy.sunrise
          find ".current .sunset" card >>= setText cardData.channel.astronomy.sunset
          find ".current .humidity" card >>= (setText $ show cardData.channel.atmosphere.humidity <> "%")
          find ".current .wind .value" card >>= (setText $ show cardData.channel.wind.speed)
          find ".current .wind .direction" card >>= (setText $ show cardData.channel.wind.direction)

          nextDays <- find ".future .oneday" card >>= toArray
          ndw <- nextDaysOfWeek
          foreachE (zip3 nextDays forcast ndw) updateNextDay

          AppState state <- readRef stateRef
          when state.isLoading do
            hide state.spinner
            modifyRef stateRef \(AppState s) -> AppState s { isLoading = false }

    case dataIsOld of
      Just true -> log $ "Not updating: " <> cardLastUpdatedStr <> ", " <> cardData.created
      Just false -> updateCard
      Nothing -> updateCard

updateNextDay
  :: forall e
   . Tuple3 JQuery ForecastData WeekDay
  -> Eff (dom :: DOM | e) Unit
updateNextDay t =
  let c = get1 t
      daily = get2 t
      wd = get3 t
  in do
    find ".icon" c >>= setClass (getIconClass daily.code) true
    find ".date" c >>= setText wd
    find ".temp-high .value" c >>= (setText $ show daily.high)
    find ".temp-low .value" c >>= (setText $ show daily.low)

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case Map.lookup key state.visibleCards of
    Just card -> pure card
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      newCard <- clone state.cardTemplate
      setClass "cardTemplate" false newCard
      setAttr "hidden" false newCard
      append newCard state.container
      modifyRef stateRef $ addCardForKey key newCard
      pure newCard

-- Methods for dealing with the model --

-- | Gets a forecast for a specific city and updates the card with the data.
-- | `getForecast` first checks if the weather data is in the cache. If so,
-- | then it gets that data and populates the card with the cached data.
-- | Then, `getForecast` goes to the network for fresh data. If the network
-- | request goes through, then the card gets updated a second time with the
-- | freshest data.
getForecast
  :: forall e
   . Ref AppState
  -> CardKey
  -> String
  -> Eff ( ajax :: AJAX
         , console :: CONSOLE
         , err :: EXCEPTION
         , dom :: DOM
         , locale :: LOCALE
         , now :: NOW
         , ref :: REF
         | e) Unit
getForecast stateRef key label =
  let statement = "select * from weather.forecast where woeid=" <> key
      url = "https://query.yahooapis.com/v1/public/yql?format=json&q=" <> statement
      readOpts = defaultOptions { unwrapSingleConstructors = true }
  in void $ launchAff do
    request <- get url
    case runExcept (readJSONGeneric readOpts request.response :: F WeatherService.Response) of
      Left err -> liftEff $ log (show err)
      Right response ->
        case fromWeatherService key label response of
          Just cardData -> liftEff $ updateForecastCard stateRef cardData
          Nothing -> liftEff $ log "Bad weather service response"

-- | Save list of cities to localStorage.
saveSelectedCities
  :: forall e
   . Ref AppState
  -> Eff (dom :: DOM, ref :: REF, storage :: STORAGE | e) Unit
saveSelectedCities stateRef = do
  AppState state <- readRef stateRef
  localStorage <- getLocalStorage
  setItem localStorage selectedCitiesKey state.selectedCities

today :: forall e. Eff (now :: NOW | e) Date
today = extract <$> nowDate

weekdayFromEnum :: Date -> Int
weekdayFromEnum = fromEnum <<< weekday

daysOfWeek :: Array WeekDay
daysOfWeek = ["Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"]

nextDaysOfWeek :: forall e. Eff (now :: NOW | e) (Array WeekDay)
nextDaysOfWeek = do
  d <- weekdayFromEnum <$> today
  pure $ drop d (daysOfWeek <> daysOfWeek)

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = Map.insert key card state.visibleCards }

-- | Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes :: Array (Array Int)
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses :: Array String
weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast =
  { key: "2459115"
  , label: "New York, NY"
  , created: "2016-07-22T01:00:00Z"
  , channel: {
      astronomy: {
        sunrise: "5:43 am"
      , sunset: "8:21 pm"
      }
    , item: {
        condition: {
          text: "Windy"
        , date: "Thu, 21 Jul 2016 09:00 PM EDT"
        , temp: 56
        , code: 24
        }
      , forecast: [
          {code: 44, high: 86, low: 70}
        , {code: 44, high: 94, low: 73}
        , {code: 4, high: 95, low: 78}
        , {code: 24, high: 75, low: 89}
        , {code: 24, high: 89, low: 77}
        , {code: 44, high: 92, low: 79}
        , {code: 44, high: 89, low: 77}
        ]
      }
    , atmosphere: {humidity: 56}
    , wind: {
        speed: 25
      , direction: 195
      }
    }
  }

initialSelectedCity :: Array SelectedCity
initialSelectedCity = singleton $ SelectedCity { key: initialWeatherForecast.key
                                               , label: initialWeatherForecast.label }


Properly clean <select>

Properly clean <select>

module Main (main) where

import Prelude
import Control.Apply
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Enum
import Data.Foldable
import Data.Int
import Data.List
import Data.Maybe
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import qualified Data.StrMap as SM

import DOMHelper
import Isomer
import Level
import Sortable
import Storage
import Transformer
import Types

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Cyan = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

-- | Like traverse_, but the function also takes an index parameter
traverseWithIndex_ :: forall a b m. (Applicative m) => (Int -> a -> m b) -> (List a) -> m Unit
traverseWithIndex_ f xs = go xs 0
    where go Nil _ = return unit
          go (Cons x xs) i = f i x *> go xs (i + 1)

-- | Spacing between two walls
spacing :: Number
spacing = 5.5

-- | Render a single stack of cubes
renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (\z -> renderCube isomer x (-spacing * y) (toNumber z)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y Nil =
    -- Render a gray placeholder for the empty wall
    renderBlock isomer 1.0 (-spacing * y) 0.0 5.0 0.9 0.1 (colorFromRGB 100 100 100)
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (toNumber (length wall - x))) (reverse wall)

-- | Render a series of walls
renderWalls :: forall eff. IsomerInstance -> (List Wall) -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40.0 40.0 400.0
    traverseWithIndex_ (\y -> renderWall isomer (toNumber y)) walls

-- | Render the target shape
renderTarget isomer target = do
    setIsomerConfig isomer 30.0 1280.0 550.0
    renderWall isomer 0.0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> (List TransformerId)
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> Nil

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> _
render setupUI gs = do
    doc <- document globalWindow
    isomer <- getIsomerInstance "canvas"

    let level = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        Just ulAvailable <- getElementById "available" doc
        Just ulProgram <- getElementById "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused = foldl (flip SM.delete) chapter.transformers tids
            insert sm id = case (getTransformerRecord chapter id) of
                               (Just tr) -> SM.insert id tr sm
                               Nothing ->   sm
            active = foldl insert SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addMouseEventListener MouseClickEvent (clickLi li) li
        children ulAvailable >>= traverse_ installClickHandler
        children ulProgram >>=   traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel -> do
            setInnerHTML "" selectLevel
            traverse_ (appendLevelElement selectLevel gs.currentLevel) allLevelIds

    let transformers = mapMaybe (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let message = if (maybe false (== (level.target)) (last steps))
                  then "Solved!"
                  else ""
    withElementById "message" doc (setInnerHTML message)
    let helpHTML = maybe "" (nameToHTML <<< replaceTransformers chapter) level.help
    withElementById "help" doc (setInnerHTML helpHTML)

    -- DEBUG:
    log $ "Program: " ++ show tids
    log $ "Initial: " ++ show level.initial
    log "Steps:"
    traverse_ print steps
    log "---"
    log $ "Target: " ++ show level.target
    log ""

-- | Replace all occurences of a pattern in a string with a replacement
replaceAll :: String -> String -> String -> String
replaceAll pattern replacement = replace (regex pattern flags) replacement
    where flags = parseFlags "g"

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (toList $ Cyan `enumFromTo` Yellow))
        where replaceColor s c = replaceAll (pattern c) (replacement c) s
              pattern c = "{" ++ c ++ "}"
              replacement c = "

"

-- | Replace stack markers
replaceStacks :: String -> String
replaceStacks = replaceAll "\\[" """
""" <<<
                replaceAll "\\]" "
"

-- | Render a transformer name as HTML
nameToHTML :: String -> String
nameToHTML = replaceColors <<< replaceStacks

-- | Replace transformer names by boxes
replaceTransformers :: Chapter -> String -> String
replaceTransformers ch initial = SM.fold replaceT initial ch.transformers
    where replaceT text id tr = replaceAll (pattern id) (replacement tr) text
          pattern id = "`" ++ id ++ "`"
          replacement tr = "" ++ tr.name ++ ""

-- | Clear all functions for the current level
resetLevel = modifyGameStateAndRender true mod
    where mod gs = gs { levelState = SM.insert gs.currentLevel Nil gs.levelState }

-- | General key press handler
keyPress :: forall eff. DOMEvent -> _
keyPress event = do
    doc <- document globalWindow
    code <- keyCode event
    case code of
         -- 'r': reset lists
         82 -> do
                   ctrlPressed <- ctrlKey event
                   when (not ctrlPressed) resetLevel
         _ -> return unit
    return unit

-- | Click handler for the
 elements (transformers)
clickLi :: forall eff. HTMLElement
        -> DOMEvent
        -> Eff (dom :: DOM, console :: CONSOLE, isomer :: Isomer, storage :: Storage | eff) Unit
clickLi liEl event = do
    newId <- getAttribute "id" liEl
    ulId <- parentElement liEl >>= getAttribute "id"
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (/= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: forall eff. HTMLElement -> String -> TransformerRecord -> Eff (dom :: DOM | eff) Unit
appendTransformerElement ul id t = do
    doc <- document globalWindow
    li <- createElement "li" doc
    setAttribute "id" id li
    setInnerHTML (nameToHTML t.name) li
    appendChild ul li

-- | Add an option-element corresponding to the given Level
appendLevelElement :: forall eff. HTMLElement -> LevelId -> LevelId -> Eff (dom :: DOM | eff) Unit
appendLevelElement select currentId lid = do
    let chapter = getChapter lid
        level = getLevel lid
    doc <- document globalWindow
    option <- createElement "option" doc
    setAttribute "value" lid option
    when (currentId == lid) $
        setAttribute "selected" "selected" option
    setTextContent (levelTitle lid level) option
    appendChild select option

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: "0.1", levelState: SM.empty }

-- | Load game, modify and store the game state. Render the new state
modifyGameStateAndRender :: forall eff.  Boolean
                         -> (GameState -> GameState)
                         -> Eff (storage :: Storage, dom :: DOM, isomer :: Isomer, console :: CONSOLE | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: forall eff. HTMLElement -> _
levelChangeHandler selectLevel = do
    levelId <- getSelectedValue selectLevel

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler = do
    doc <- document globalWindow

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    program <- toList <$> traverse (getAttribute "id") lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

main = do
    doc <- document globalWindow

    -- install sortable
    Just ulAvailable <- getElementById "available" doc
    Just ulProgram   <- getElementById "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    addKeyboardEventListener KeydownEvent keyPress globalWindow

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addChangeEventListener levelChangeHandler selectLevel

    -- Click handlers for buttons
    withElementById "reset" doc $ \button ->
        addMouseEventListener MouseClickEvent (const resetLevel :: DOMEvent -> _) button

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs

module Main (main) where

import Prelude
import Control.Apply
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Enum
import Data.Foldable
import Data.Int
import Data.List
import Data.Maybe
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import qualified Data.StrMap as SM

import DOMHelper
import Isomer
import Level
import Sortable
import Storage
import Transformer
import Types

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Cyan = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

-- | Like traverse_, but the function also takes an index parameter
traverseWithIndex_ :: forall a b m. (Applicative m) => (Int -> a -> m b) -> (List a) -> m Unit
traverseWithIndex_ f xs = go xs 0
    where go Nil _ = return unit
          go (Cons x xs) i = f i x *> go xs (i + 1)

-- | Spacing between two walls
spacing :: Number
spacing = 5.5

-- | Render a single stack of cubes
renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (\z -> renderCube isomer x (-spacing * y) (toNumber z)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y Nil =
    -- Render a gray placeholder for the empty wall
    renderBlock isomer 1.0 (-spacing * y) 0.0 5.0 0.9 0.1 (colorFromRGB 100 100 100)
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (toNumber (length wall - x))) (reverse wall)

-- | Render a series of walls
renderWalls :: forall eff. IsomerInstance -> (List Wall) -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40.0 40.0 400.0
    traverseWithIndex_ (\y -> renderWall isomer (toNumber y)) walls

-- | Render the target shape
renderTarget isomer target = do
    setIsomerConfig isomer 30.0 1280.0 550.0
    renderWall isomer 0.0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> (List TransformerId)
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> Nil

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> _
render setupUI gs = do
    doc <- document globalWindow
    isomer <- getIsomerInstance "canvas"

    let level = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        Just ulAvailable <- getElementById "available" doc
        Just ulProgram <- getElementById "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused = foldl (flip SM.delete) chapter.transformers tids
            insert sm id = case (getTransformerRecord chapter id) of
                               (Just tr) -> SM.insert id tr sm
                               Nothing ->   sm
            active = foldl insert SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addMouseEventListener MouseClickEvent (clickLi li) li
        children ulAvailable >>= traverse_ installClickHandler
        children ulProgram >>=   traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel ->
            traverse_ (appendLevelElement selectLevel gs.currentLevel) allLevelIds

    let transformers = mapMaybe (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let message = if (maybe false (== (level.target)) (last steps))
                  then "Solved!"
                  else ""
    withElementById "message" doc (setInnerHTML message)
    let helpHTML = maybe "" (nameToHTML <<< replaceTransformers chapter) level.help
    withElementById "help" doc (setInnerHTML helpHTML)

    -- DEBUG:
    log $ "Program: " ++ show tids
    log $ "Initial: " ++ show level.initial
    log "Steps:"
    traverse_ print steps
    log "---"
    log $ "Target: " ++ show level.target
    log ""

-- | Replace all occurences of a pattern in a string with a replacement
replaceAll :: String -> String -> String -> String
replaceAll pattern replacement = replace (regex pattern flags) replacement
    where flags = parseFlags "g"

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (toList $ Cyan `enumFromTo` Yellow))
        where replaceColor s c = replaceAll (pattern c) (replacement c) s
              pattern c = "{" ++ c ++ "}"
              replacement c = "

"

-- | Replace stack markers
replaceStacks :: String -> String
replaceStacks = replaceAll "\\[" """
""" <<<
                replaceAll "\\]" "
"

-- | Render a transformer name as HTML
nameToHTML :: String -> String
nameToHTML = replaceColors <<< replaceStacks

-- | Replace transformer names by boxes
replaceTransformers :: Chapter -> String -> String
replaceTransformers ch initial = SM.fold replaceT initial ch.transformers
    where replaceT text id tr = replaceAll (pattern id) (replacement tr) text
          pattern id = "`" ++ id ++ "`"
          replacement tr = "" ++ tr.name ++ ""

-- | Clear all functions for the current level
resetLevel = modifyGameStateAndRender true mod
    where mod gs = gs { levelState = SM.insert gs.currentLevel Nil gs.levelState }

-- | General key press handler
keyPress :: forall eff. DOMEvent -> _
keyPress event = do
    doc <- document globalWindow
    code <- keyCode event
    case code of
         -- 'r': reset lists
         82 -> do
                   ctrlPressed <- ctrlKey event
                   when (not ctrlPressed) resetLevel
         _ -> return unit
    return unit

-- | Click handler for the
 elements (transformers)
clickLi :: forall eff. HTMLElement
        -> DOMEvent
        -> Eff (dom :: DOM, console :: CONSOLE, isomer :: Isomer, storage :: Storage | eff) Unit
clickLi liEl event = do
    newId <- getAttribute "id" liEl
    ulId <- parentElement liEl >>= getAttribute "id"
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (/= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: forall eff. HTMLElement -> String -> TransformerRecord -> Eff (dom :: DOM | eff) Unit
appendTransformerElement ul id t = do
    doc <- document globalWindow
    li <- createElement "li" doc
    setAttribute "id" id li
    setInnerHTML (nameToHTML t.name) li
    appendChild ul li

-- | Add an option-element corresponding to the given Level
appendLevelElement :: forall eff. HTMLElement -> LevelId -> LevelId -> Eff (dom :: DOM | eff) Unit
appendLevelElement select currentId lid = do
    let chapter = getChapter lid
        level = getLevel lid
    doc <- document globalWindow
    option <- createElement "option" doc
    setAttribute "value" lid option
    when (currentId == lid) $
        setAttribute "selected" "selected" option
    setTextContent (levelTitle lid level) option
    appendChild select option

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: "0.1", levelState: SM.empty }

-- | Load game, modify and store the game state. Render the new state
modifyGameStateAndRender :: forall eff.  Boolean
                         -> (GameState -> GameState)
                         -> Eff (storage :: Storage, dom :: DOM, isomer :: Isomer, console :: CONSOLE | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: forall eff. HTMLElement -> _
levelChangeHandler selectLevel = do
    levelId <- getSelectedValue selectLevel

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler = do
    doc <- document globalWindow

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    program <- toList <$> traverse (getAttribute "id") lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

main = do
    doc <- document globalWindow

    -- install sortable
    Just ulAvailable <- getElementById "available" doc
    Just ulProgram   <- getElementById "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    addKeyboardEventListener KeydownEvent keyPress globalWindow

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addChangeEventListener levelChangeHandler selectLevel

    -- Click handlers for buttons
    withElementById "reset" doc $ \button ->
        addMouseEventListener MouseClickEvent (const resetLevel :: DOMEvent -> _) button

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs


Tidy up

Tidy up

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import DOM (DOM)
import DOM.Classy.Node (fromNode)
import DOM.Event.Event (target)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.Event.Types (Event)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (keyup)
import DOM.HTML.HTMLTextAreaElement (value)
import DOM.HTML.Types (HTMLTextAreaElement, htmlDocumentToParentNode)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (querySelector, QuerySelector(QuerySelector))
import DOM.Node.Types (elementToEventTarget)
import Data.Maybe (maybe)
import Prelude

-- Problems encountered
-- 1. What do I need?
-- 2. How do I access document.querySelector
-- 3. how do I access document?
-- 4. how do I create a QuerySelector ... oh, and it needs to be wrapped
-- 5. the document is not a parentNode
-- 6. how do I make an event listener
-- 7. the element is a maybe element
-- 8. the element is not an event target
-- 9. How can I access e.target.value?

f :: forall eff. Event -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
f e = maybe
  (log "No node found")
  (\textarea -> value (textarea :: HTMLTextAreaElement) >>= log)
  ((fromNode <<< target) e)

main :: forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
main = do
  doc <- window >>= document
  el  <- querySelector (QuerySelector "#in") (htmlDocumentToParentNode doc)
  maybe
    (log "No element #in found")
    (addEventListener keyup (eventListener f) true)
    (elementToEventTarget <$> el)

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import DOM (DOM)
import DOM.Event.Event (target)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.Event.Types (Event)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (keyup)
import DOM.HTML.Types (HTMLTextAreaElement, htmlDocumentToParentNode)
import DOM.HTML.Window (document)
import DOM.HTML.HTMLTextAreaElement (value)
import DOM.Classy.Node (fromNode)
import DOM.Node.ParentNode (querySelector, QuerySelector(QuerySelector))
import DOM.Node.Types (elementToEventTarget)
import Data.Maybe (Maybe(Just), maybe)
import Prelude

-- Problems encountered
-- 1. What do I need?
-- 2. How do I access document.querySelector
-- 3. how do I access document?
-- 4. how do I create a QuerySelector ... oh, and it needs to be wrapped
-- 5. the document is not a parentNode
-- 6. how do I make an event listener
-- 7. the element is a maybe element
-- 8. the element is not an event target
-- 9. How can I access e.target.value?

f :: forall eff. Event -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
f e = case (fromNode <<< target) e of
  Just (ta :: HTMLTextAreaElement) -> do
    val <- value ta
    log val
  _ -> log "?"

main :: forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
main = do
  doc <- window >>= document
  el  <- querySelector (QuerySelector "#in") (htmlDocumentToParentNode doc)
  maybe (log "No #in found!") (addEventListener keyup (eventListener f) true) (elementToEventTarget <$> el)