Note about POCOs

Note about POCOs

module Language.CSharp
    ( renderer
    ) where

import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.String.Util (camelCase, legalizeCharacters, startWithLetter, stringEscape, isLetterOrLetterNumber)
import Data.Tuple (Tuple(..))
import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getModuleName, getTypeNameForUnion, getUnionNames, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, getOptionValue)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, Named, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Options (Option, booleanOption, enumOption)

forbiddenNames :: Array String
forbiddenNames = ["Converter", "JsonConverter", "Type", "Serialize"]

listOption :: Option Boolean
listOption = enumOption "array-type" "Select C# type to use for JSON arrays" [Tuple "array" false, Tuple "list" true]

pocoOption :: Option Boolean
pocoOption = booleanOption "poco" "[EXPERIMENTAL] Generate 'Plain Old C# Objects' only" false

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , options: [listOption.specification, pocoOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer csNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer nameForType
            , nameFromTypes: simpleNamer (unionNameIntercalated csNameStyle "Or")
            }
        }
    }

nameForType :: Named (Set String) -> String
nameForType = csNameStyle <<< combineNames

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = nameForType names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterOrLetterNumber c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    _ -> isStartCharacter c

renderNullableToCSharp :: IRType -> Doc String
renderNullableToCSharp x = do
    rendered <- renderTypeToCSharp x
    pure if isValueType x then rendered <> "?" else rendered

renderUnionToCSharp :: IRUnionRep -> Doc String
renderUnionToCSharp ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToCSharp x
    Nothing -> lookupUnionName ur

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNoInformation -> pure "FIXME"
    IRAnyType -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        useList <- getOptionValue listOption
        if useList
            then
                pure $ "List<" <> rendered <> ">"
            else
                pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion ur -> renderUnionToCSharp ur

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

csNameStyle :: String -> String
csNameStyle = legalize >>> camelCase >>> startWithLetter isStartCharacter true

csharpDoc :: Doc Unit
csharpDoc = do
    module_ <- getModuleName csNameStyle
    whenSerializers do
        oneOfThese <- getForSingleOrMultipleTopLevels "" " one of these"
        line $ "// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do" <> oneOfThese <> ":"
        line "//"
        line $ "//    using " <> module_ <> ";"
        forEachTopLevel_ \topLevelName topLevelType -> do
            line "//"
            line $ "//    var data = " <> module_ <> ".FromJson(jsonString);"
        line "//"
        line "// For POCOs visit quicktype.io?poco"
        line "//"

    line $ "namespace " <> module_
    line "{"
    indent do
        let using s = line $ "using " <> s <> ";"
        using "System"
        using "System.Net"
        using "System.Collections.Generic"
        whenSerializers do
            blank
            using "Newtonsoft.Json"
        blank
        renderRenderItems blank Nothing renderCSharpClass (Just renderCSharpUnion)
        whenSerializers do
            blank
            renderCSharpClassJSONPartials
            renderRenderItems (pure unit) Nothing (\_ _ -> pure unit) (Just renderCSharpUnionReadWritePartial)
            renderJsonConverter
    line "}"

whenSerializers :: Doc Unit -> Doc Unit
whenSerializers doc = do
    poco <- getOptionValue pocoOption
    unless poco doc

stringIfTrue :: Boolean -> String -> String
stringIfTrue true s = s
stringIfTrue false _ = ""

renderCSharpClassJSONPartials :: Doc Unit
renderCSharpClassJSONPartials = do
    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        topLevelTypeRendered <- renderTypeToCSharp topLevelType
        line $ "public partial class " <> topLevelName
        line "{"
        indent do
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Converter.Settings);"
        line "}"

    whenSerializers do
        blank
        line $ "public static class Serialize"
        line "{"
        indent do
            forEachTopLevel_ \topLevelName topLevelType -> do
                topLevelTypeRendered <- renderTypeToCSharp topLevelType
                line $
                    "public static string ToJson(this "
                    <> topLevelTypeRendered
                    <> " self) => JsonConvert.SerializeObject(self, Converter.Settings);"
    line "}"

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    blank
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Converter" <> stringIfTrue haveUnions ": JsonConverter"
    line "{"
    indent do
        when haveUnions do
            line "public override bool CanConvert(Type t)"
            line "{"
            indent $ line $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            line "}"
            blank
            line "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer)"
            line "{"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> "))"
                    indent $ line $ "return new " <> name <> "(reader, serializer);"
                line "throw new Exception(\"Unknown type\");"
            line "}"

            whenSerializers do
                blank
                line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
                line "{"
                indent do
                    line "var t = value.GetType();"
                    for_ names \name -> do
                        line $ "if (t == typeof(" <> name <> ")) {"
                        indent do
                            line $ "((" <> name <> ")value).WriteJson(writer, serializer);"
                            line "return;"
                        line "}"
                    line "throw new Exception(\"Unknown type\");"
                line "}"
            blank

        line "public static readonly JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Converter() },"
        line "};"
    line "}"

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

renderNullDeserializer :: Doc Unit
renderNullDeserializer = do
    tokenCase "Null"
    indent do
        line "break;"

unionFieldName :: IRType -> Doc String
unionFieldName t = csNameStyle <$> getTypeNameForUnion t

deserialize :: String -> String -> Doc Unit
deserialize fieldName typeName = do
    line $ fieldName <> " = serializer.Deserialize<" <> typeName <> ">(reader);"
    line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    fieldName <- unionFieldName t
    renderedType <- renderTypeToCSharp t
    deserialize fieldName renderedType

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

renderDoubleDeserializer :: IRUnionRep -> Doc Unit
renderDoubleDeserializer union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

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

renderCSharpUnion :: String -> IRUnionRep -> Doc Unit
renderCSharpUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    poco <- getOptionValue pocoOption
    line $ "public" <> (if poco then "" else " partial") <> " struct " <> name
    line "{"
    indent do
        forUnion_ nonNullUnion \t -> do
            typeString <- renderNullableToCSharp t
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
    line "}"

renderCSharpUnionReadWritePartial :: String -> IRUnionRep -> Doc Unit
renderCSharpUnionReadWritePartial name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep

    blank
    line $ "public partial struct " <> name
    line "{"
    indent do
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                when hasNull renderNullDeserializer
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger nonNullUnion
                renderDoubleDeserializer nonNullUnion
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool nonNullUnion
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString nonNullUnion
                renderGenericDeserializer unionHasArray "StartArray" nonNullUnion
                renderGenericDeserializer unionHasClass "StartObject" nonNullUnion
                renderGenericDeserializer unionHasMap "StartObject" nonNullUnion
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"

        blank
        line $ "public void WriteJson(JsonWriter writer, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ "if (" <> fieldName <> " != null) {"
                indent do
                    line $ "serializer.Serialize(writer, " <> fieldName <> ");"
                    line "return;"
                line "}"
            if hasNull
                then
                    line "writer.WriteNull();"
                else
                    line "throw new Exception(\"Union must not be null\");"
        line "}"
    line "}"

renderCSharpClass :: String -> Map String IRType -> Doc Unit
renderCSharpClass className properties = do
    let propertyNames = transformPropertyNames (simpleNamer csNameStyle) ("Other" <> _) [className] properties
    poco <- getOptionValue pocoOption
    line $ "public" <> (if poco then "" else " partial") <> " class " <> className
    line "{"
    indent do
        forEachProperty_ properties propertyNames \pname ptype csPropName isLast -> do
            whenSerializers do
                line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            whenSerializers do
                unless isLast blank
    line "}"

module Language.CSharp
    ( renderer
    ) where

import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.String.Util (camelCase, legalizeCharacters, startWithLetter, stringEscape, isLetterOrLetterNumber)
import Data.Tuple (Tuple(..))
import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getModuleName, getTypeNameForUnion, getUnionNames, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, getOptionValue)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, Named, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Options (Option, booleanOption, enumOption)

forbiddenNames :: Array String
forbiddenNames = ["Converter", "JsonConverter", "Type", "Serialize"]

listOption :: Option Boolean
listOption = enumOption "array-type" "Select C# type to use for JSON arrays" [Tuple "array" false, Tuple "list" true]

pocoOption :: Option Boolean
pocoOption = booleanOption "poco" "[EXPERIMENTAL] Generate 'Plain Old C# Objects' only" false

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , options: [listOption.specification, pocoOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer csNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer nameForType
            , nameFromTypes: simpleNamer (unionNameIntercalated csNameStyle "Or")
            }
        }
    }

nameForType :: Named (Set String) -> String
nameForType = csNameStyle <<< combineNames

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = nameForType names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterOrLetterNumber c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    _ -> isStartCharacter c

renderNullableToCSharp :: IRType -> Doc String
renderNullableToCSharp x = do
    rendered <- renderTypeToCSharp x
    pure if isValueType x then rendered <> "?" else rendered

renderUnionToCSharp :: IRUnionRep -> Doc String
renderUnionToCSharp ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToCSharp x
    Nothing -> lookupUnionName ur

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNoInformation -> pure "FIXME"
    IRAnyType -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        useList <- getOptionValue listOption
        if useList
            then
                pure $ "List<" <> rendered <> ">"
            else
                pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion ur -> renderUnionToCSharp ur

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

csNameStyle :: String -> String
csNameStyle = legalize >>> camelCase >>> startWithLetter isStartCharacter true

csharpDoc :: Doc Unit
csharpDoc = do
    module_ <- getModuleName csNameStyle
    whenSerializers do
        oneOfThese <- getForSingleOrMultipleTopLevels "" " one of these"
        line $ "// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do" <> oneOfThese <> ":"
        line "//"
        line $ "//    using " <> module_ <> ";"
        forEachTopLevel_ \topLevelName topLevelType -> do
            line "//"
            line $ "//    var data = " <> module_ <> ".FromJson(jsonString);"
        line "//"

    line $ "namespace " <> module_
    line "{"
    indent do
        let using s = line $ "using " <> s <> ";"
        using "System"
        using "System.Net"
        using "System.Collections.Generic"
        whenSerializers do
            blank
            using "Newtonsoft.Json"
        blank
        renderRenderItems blank Nothing renderCSharpClass (Just renderCSharpUnion)
        whenSerializers do
            blank
            renderCSharpClassJSONPartials
            renderRenderItems (pure unit) Nothing (\_ _ -> pure unit) (Just renderCSharpUnionReadWritePartial)
            renderJsonConverter
    line "}"

whenSerializers :: Doc Unit -> Doc Unit
whenSerializers doc = do
    poco <- getOptionValue pocoOption
    unless poco doc

stringIfTrue :: Boolean -> String -> String
stringIfTrue true s = s
stringIfTrue false _ = ""

renderCSharpClassJSONPartials :: Doc Unit
renderCSharpClassJSONPartials = do
    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        topLevelTypeRendered <- renderTypeToCSharp topLevelType
        line $ "public partial class " <> topLevelName
        line "{"
        indent do
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Converter.Settings);"
        line "}"

    whenSerializers do
        blank
        line $ "public static class Serialize"
        line "{"
        indent do
            forEachTopLevel_ \topLevelName topLevelType -> do
                topLevelTypeRendered <- renderTypeToCSharp topLevelType
                line $
                    "public static string ToJson(this "
                    <> topLevelTypeRendered
                    <> " self) => JsonConvert.SerializeObject(self, Converter.Settings);"
    line "}"

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    blank
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Converter" <> stringIfTrue haveUnions ": JsonConverter"
    line "{"
    indent do
        when haveUnions do
            line "public override bool CanConvert(Type t)"
            line "{"
            indent $ line $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            line "}"
            blank
            line "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer)"
            line "{"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> "))"
                    indent $ line $ "return new " <> name <> "(reader, serializer);"
                line "throw new Exception(\"Unknown type\");"
            line "}"

            whenSerializers do
                blank
                line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
                line "{"
                indent do
                    line "var t = value.GetType();"
                    for_ names \name -> do
                        line $ "if (t == typeof(" <> name <> ")) {"
                        indent do
                            line $ "((" <> name <> ")value).WriteJson(writer, serializer);"
                            line "return;"
                        line "}"
                    line "throw new Exception(\"Unknown type\");"
                line "}"
            blank

        line "public static readonly JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Converter() },"
        line "};"
    line "}"

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

renderNullDeserializer :: Doc Unit
renderNullDeserializer = do
    tokenCase "Null"
    indent do
        line "break;"

unionFieldName :: IRType -> Doc String
unionFieldName t = csNameStyle <$> getTypeNameForUnion t

deserialize :: String -> String -> Doc Unit
deserialize fieldName typeName = do
    line $ fieldName <> " = serializer.Deserialize<" <> typeName <> ">(reader);"
    line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    fieldName <- unionFieldName t
    renderedType <- renderTypeToCSharp t
    deserialize fieldName renderedType

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

renderDoubleDeserializer :: IRUnionRep -> Doc Unit
renderDoubleDeserializer union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

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

renderCSharpUnion :: String -> IRUnionRep -> Doc Unit
renderCSharpUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    poco <- getOptionValue pocoOption
    line $ "public" <> (if poco then "" else " partial") <> " struct " <> name
    line "{"
    indent do
        forUnion_ nonNullUnion \t -> do
            typeString <- renderNullableToCSharp t
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
    line "}"

renderCSharpUnionReadWritePartial :: String -> IRUnionRep -> Doc Unit
renderCSharpUnionReadWritePartial name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep

    blank
    line $ "public partial struct " <> name
    line "{"
    indent do
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                when hasNull renderNullDeserializer
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger nonNullUnion
                renderDoubleDeserializer nonNullUnion
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool nonNullUnion
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString nonNullUnion
                renderGenericDeserializer unionHasArray "StartArray" nonNullUnion
                renderGenericDeserializer unionHasClass "StartObject" nonNullUnion
                renderGenericDeserializer unionHasMap "StartObject" nonNullUnion
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"

        blank
        line $ "public void WriteJson(JsonWriter writer, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ "if (" <> fieldName <> " != null) {"
                indent do
                    line $ "serializer.Serialize(writer, " <> fieldName <> ");"
                    line "return;"
                line "}"
            if hasNull
                then
                    line "writer.WriteNull();"
                else
                    line "throw new Exception(\"Union must not be null\");"
        line "}"
    line "}"

renderCSharpClass :: String -> Map String IRType -> Doc Unit
renderCSharpClass className properties = do
    let propertyNames = transformPropertyNames (simpleNamer csNameStyle) ("Other" <> _) [className] properties
    poco <- getOptionValue pocoOption
    line $ "public" <> (if poco then "" else " partial") <> " class " <> className
    line "{"
    indent do
        forEachProperty_ properties propertyNames \pname ptype csPropName isLast -> do
            whenSerializers do
                line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            whenSerializers do
                unless isLast blank
    line "}"


Insert missing blank lines in Go

Insert missing blank lines in Go

module Language.Golang
    ( renderer
    ) where

import Doc (Doc, Renderer, blank, combineNames, forEachTopLevel_, forbidNamer, getTypeNameForUnion, getUnions, indent, line, lookupClassName, lookupName, lookupUnionName, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, isClass, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap, unionToList)
import Prelude

import Data.Array as A
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Map (Map)
import Data.Maybe (Maybe(..), maybe)
import Data.String as Str
import Data.String.Util (camelCase, stringEscape, legalizeCharacters, isLetterOrUnderscore, isLetterOrUnderscoreOrDigit, startWithLetter)
import Data.Tuple (Tuple(..), fst)
import Utils (mapM, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , options: []
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: forbidNamer goNameStyle (\n -> let gn = goNameStyle n in [gn, "Unmarshal" <> gn])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (goNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer unionNameFromTypes
            }
        }
    }

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

unionNameFromTypes :: Array String -> String
unionNameFromTypes names =
    names
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderNullableToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderNullableToGolang x = do
    { rendered, comment } <- renderTypeToGolang x
    pure
        if isValueType x then
            { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
        else
            { rendered, comment: Nothing }

renderUnionToGolang :: IRUnionRep -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToGolang x
    Nothing -> do
        noComment =<< lookupUnionName ur

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRAnything -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

legalize :: String -> String
legalize = legalizeCharacters isLetterOrUnderscoreOrDigit

goNameStyle :: String -> String
goNameStyle = legalize >>> camelCase >>> startWithLetter isLetterOrUnderscore true

golangDoc :: Doc Unit
golangDoc = do
    line "// To parse and unparse this JSON data, add this code to your project and do:"
    forEachTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    r, err := Unmarshal" <> topLevelName <> "(bytes)"
        line $ "//    bytes, err = r.Marshal()"
    blank
    line "package main"
    blank
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    blank
    renderRenderItems blank (Just renderTopLevel) renderGolangType (Just renderGolangUnion)
    unless (unions == L.Nil) do
        blank
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""

renderTopLevel :: String -> IRType -> Doc Unit
renderTopLevel topLevelName topLevelType = do
    { rendered: renderedToplevel, comment: toplevelComment } <- renderTypeToGolang topLevelType
    line $ "type " <> topLevelName <> " " <> renderedToplevel <> (renderComment toplevelComment)
    blank
    line $ "func Unmarshal" <> topLevelName <> "(data []byte) (" <> topLevelName <> ", error) {"
    line $ "    var r " <> topLevelName
    line """    err := json.Unmarshal(data, &r)
    return r, err
}
"""
    line $ "func (r *" <> topLevelName <> ") Marshal() ([]byte, error) {"
    indent do
        line "return json.Marshal(r)"
    line "}"

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: String -> Map String IRType -> Doc Unit
renderGolangType className properties = do
    let propertyNames = transformPropertyNames (simpleNamer goNameStyle) ("Other" <> _) [] properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    columns <- propsList # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

unionFieldName :: IRType -> Doc String
unionFieldName t = goNameStyle <$> getTypeNameForUnion t

compoundPredicates :: Array (IRUnionRep -> Maybe IRType)
compoundPredicates = [unionHasArray, unionHasClass, unionHasMap]

renderGolangUnion :: String -> IRUnionRep -> Doc Unit
renderGolangUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    let isNullableString = if hasNull then "true" else "false"
    fields <- unionToList nonNullUnion # sortByKeyM unionFieldName
    columns <- fields # mapM \t -> do
        { rendered, comment } <- renderNullableToGolang t
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name' _ -> do
            indent do
                line $ "x." <> name' <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let element = unionHasClass unionRep
            in
                case element of
                Just t -> do
                    name' <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name' rendered
                Nothing -> pure unit
        maybeAssignNil p =
            case p unionRep of
            Just t -> do
                name' <- unionFieldName t
                line $ "x." <> name' <> " = nil"
            Nothing -> pure unit
        predicateForType :: IRType -> IRUnionRep -> Maybe IRType
        predicateForType t ur =
            if isUnionMember t ur then Just t else Nothing
        makeArgs :: ((IRUnionRep -> Maybe IRType) -> Doc String) -> ((IRUnionRep -> Maybe IRType) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ map predicateForType [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound compoundPredicates
            pure $ intercalate ", " $ A.concat [primitiveArgs, compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRUnionRep -> Maybe IRType) -> Doc String
        memberArg notPresentValue renderPresent p =
            case p unionRep of
            Just t -> do
                name' <- unionFieldName t
                pure $ renderPresent t name'
            Nothing -> pure notPresentValue
        primitiveUnmarshalArg p =
            memberArg "nil" (\_ n -> "&x." <> n) p
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: (IRUnionRep -> Maybe IRType) -> Doc String
        primitiveMarshalArg p =
            memberArg "nil" (\_ n -> "x." <> n) p
        compoundMarshalArg :: (IRUnionRep -> Maybe IRType) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p

module Language.Golang
    ( renderer
    ) where

import Doc (Doc, Renderer, blank, combineNames, forEachTopLevel_, forbidNamer, getTypeNameForUnion, getUnions, indent, line, lookupClassName, lookupName, lookupUnionName, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, isClass, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap, unionToList)
import Prelude

import Data.Array as A
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Map (Map)
import Data.Maybe (Maybe(..), maybe)
import Data.String as Str
import Data.String.Util (camelCase, stringEscape, legalizeCharacters, isLetterOrUnderscore, isLetterOrUnderscoreOrDigit, startWithLetter)
import Data.Tuple (Tuple(..), fst)
import Utils (mapM, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , options: []
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: forbidNamer goNameStyle (\n -> let gn = goNameStyle n in [gn, "Unmarshal" <> gn])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (goNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer unionNameFromTypes
            }
        }
    }

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

unionNameFromTypes :: Array String -> String
unionNameFromTypes names =
    names
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderNullableToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderNullableToGolang x = do
    { rendered, comment } <- renderTypeToGolang x
    pure
        if isValueType x then
            { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
        else
            { rendered, comment: Nothing }

renderUnionToGolang :: IRUnionRep -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToGolang x
    Nothing -> do
        noComment =<< lookupUnionName ur

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRAnything -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

legalize :: String -> String
legalize = legalizeCharacters isLetterOrUnderscoreOrDigit

goNameStyle :: String -> String
goNameStyle = legalize >>> camelCase >>> startWithLetter isLetterOrUnderscore true

golangDoc :: Doc Unit
golangDoc = do
    line "// To parse and unparse this JSON data, add this code to your project and do:"
    forEachTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    r, err := Unmarshal" <> topLevelName <> "(bytes)"
        line $ "//    bytes, err = r.Marshal()"
    blank
    line "package main"
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    renderRenderItems blank (Just renderTopLevel) renderGolangType (Just renderGolangUnion)
    unless (unions == L.Nil) do
        blank
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""

renderTopLevel :: String -> IRType -> Doc Unit
renderTopLevel topLevelName topLevelType = do
    { rendered: renderedToplevel, comment: toplevelComment } <- renderTypeToGolang topLevelType
    line $ "type " <> topLevelName <> " " <> renderedToplevel <> (renderComment toplevelComment)
    blank
    line $ "func Unmarshal" <> topLevelName <> "(data []byte) (" <> topLevelName <> ", error) {"
    line $ "    var r " <> topLevelName
    line """    err := json.Unmarshal(data, &r)
    return r, err
}
"""
    line $ "func (r *" <> topLevelName <> ") Marshal() ([]byte, error) {"
    indent do
        line "return json.Marshal(r)"
    line "}"

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: String -> Map String IRType -> Doc Unit
renderGolangType className properties = do
    let propertyNames = transformPropertyNames (simpleNamer goNameStyle) ("Other" <> _) [] properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    columns <- propsList # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

unionFieldName :: IRType -> Doc String
unionFieldName t = goNameStyle <$> getTypeNameForUnion t

compoundPredicates :: Array (IRUnionRep -> Maybe IRType)
compoundPredicates = [unionHasArray, unionHasClass, unionHasMap]

renderGolangUnion :: String -> IRUnionRep -> Doc Unit
renderGolangUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    let isNullableString = if hasNull then "true" else "false"
    fields <- unionToList nonNullUnion # sortByKeyM unionFieldName
    columns <- fields # mapM \t -> do
        { rendered, comment } <- renderNullableToGolang t
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name' _ -> do
            indent do
                line $ "x." <> name' <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let element = unionHasClass unionRep
            in
                case element of
                Just t -> do
                    name' <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name' rendered
                Nothing -> pure unit
        maybeAssignNil p =
            case p unionRep of
            Just t -> do
                name' <- unionFieldName t
                line $ "x." <> name' <> " = nil"
            Nothing -> pure unit
        predicateForType :: IRType -> IRUnionRep -> Maybe IRType
        predicateForType t ur =
            if isUnionMember t ur then Just t else Nothing
        makeArgs :: ((IRUnionRep -> Maybe IRType) -> Doc String) -> ((IRUnionRep -> Maybe IRType) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ map predicateForType [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound compoundPredicates
            pure $ intercalate ", " $ A.concat [primitiveArgs, compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRUnionRep -> Maybe IRType) -> Doc String
        memberArg notPresentValue renderPresent p =
            case p unionRep of
            Just t -> do
                name' <- unionFieldName t
                pure $ renderPresent t name'
            Nothing -> pure notPresentValue
        primitiveUnmarshalArg p =
            memberArg "nil" (\_ n -> "&x." <> n) p
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: (IRUnionRep -> Maybe IRType) -> Doc String
        primitiveMarshalArg p =
            memberArg "nil" (\_ n -> "x." <> n) p
        compoundMarshalArg :: (IRUnionRep -> Maybe IRType) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p


Obligatory Douglas Adams reference

Obligatory Douglas Adams reference

module Levels.Chapter3 where

import Data.Array
import Data.Foldable
import Math
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

toDigit :: Cube -> Number
toDigit Orange = 0
toDigit Brown  = 1

toCube :: Number -> Cube
toCube 0 = Orange
toCube 1 = Brown

toNumber :: Stack -> Number
toNumber w = sum $ zipWith (\f c -> f * toDigit c) [1, 2, 4] w

foreign import digits
    """
    function digits(num) {
      var bin = ((num % 8 + 8) % 8).toString(2);
      bin = '000'.split('').slice( 0, 3 - bin.length ).join('') + bin;
      return bin.split('').map(Number).reverse();
    }
    """ :: Number -> [Number]

toStack :: Number -> Stack
toStack num = map toCube (digits num)

transformNumbers :: (Number -> Number) -> Transformer
transformNumbers f = map (toNumber >>> f >>> toStack)

foreign import even
    """
    function even(num) {
        return num % 2 == 0;
    }
    """:: Number -> Boolean

chapter3 :: Chapter
chapter3 = {
    name: "Chapter 3",

    transformers: SM.fromList [
        "mapAdd1" :> {
            name: "map (+1)",
            function: transformNumbers (+1)
        },
        "mapSub1" :> {
            name: "map (-1)",
            function: transformNumbers (\x -> x - 1)
        },
        "mapMul2" :> {
            name: "map (×2)",
            function: transformNumbers (*2)
        },
        "mapPow2" :> {
            name: "map (^2)",
            function: transformNumbers (`pow` 2)
        },
        "filterEven" :> {
            name: "filter even",
            function: filter (toNumber >>> even)
        }
    ],

    levels: SM.fromList [
        "3.1" :> {
            name: "0b0 .. 0b111",
            difficulty: Easy,
            initial: map toStack [0, 1, 2, 3, 4, 5, 6, 7],
            target: map toStack [1, 3, 5, 7, 1, 3, 5, 7]
        },
        "3.2" :> {
            name: "Odd..",
            difficulty: Easy,
            initial: map toStack [0, 1, 2, 3, 4, 5, 6, 7],
            target: map toStack [1, 3, 5, 7]
        },
        "3.3" :> {
            name: "Zero",
            difficulty: Hard,
            initial: map toStack [0, 1, 2, 3, 4, 5, 6, 7],
            target: map toStack [0, 0, 0, 0, 0, 0, 0, 0]
        },
        "3.4" :> {
            name: "Don't panic",
            difficulty: Hard,
            initial: map toStack [0, 1, 2, 3, 4, 5, 6, 7],
            target: map toStack [4, 2, 4, 2, 4, 2, 4, 2]
        }
    ]
}

module Levels.Chapter3 where

import Data.Array
import Data.Foldable
import Math
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

toDigit :: Cube -> Number
toDigit Orange = 0
toDigit Brown  = 1

toCube :: Number -> Cube
toCube 0 = Orange
toCube 1 = Brown

toNumber :: Stack -> Number
toNumber w = sum $ zipWith (\f c -> f * toDigit c) [1, 2, 4] w

foreign import digits
    """
    function digits(num) {
      var bin = ((num % 8 + 8) % 8).toString(2);
      bin = '000'.split('').slice( 0, 3 - bin.length ).join('') + bin;
      return bin.split('').map(Number).reverse();
    }
    """ :: Number -> [Number]

toStack :: Number -> Stack
toStack num = map toCube (digits num)

transformNumbers :: (Number -> Number) -> Transformer
transformNumbers f = map (toNumber >>> f >>> toStack)

foreign import even
    """
    function even(num) {
        return num % 2 == 0;
    }
    """:: Number -> Boolean

chapter3 :: Chapter
chapter3 = {
    name: "Chapter 3",

    transformers: SM.fromList [
        "mapAdd1" :> {
            name: "map (+1)",
            function: transformNumbers (+1)
        },
        "mapSub1" :> {
            name: "map (-1)",
            function: transformNumbers (\x -> x - 1)
        },
        "mapMul2" :> {
            name: "map (×2)",
            function: transformNumbers (*2)
        },
        "mapPow2" :> {
            name: "map (^2)",
            function: transformNumbers (`pow` 2)
        },
        "filterEven" :> {
            name: "filter even",
            function: filter (toNumber >>> even)
        }
    ],

    levels: SM.fromList [
        "3.1" :> {
            name: "0b0 .. 0b111",
            difficulty: Easy,
            initial: map toStack [0, 1, 2, 3, 4, 5, 6, 7],
            target: map toStack [1, 3, 5, 7, 1, 3, 5, 7]
        },
        "3.2" :> {
            name: "Odd..",
            difficulty: Easy,
            initial: map toStack [0, 1, 2, 3, 4, 5, 6, 7],
            target: map toStack [1, 3, 5, 7]
        },
        "3.3" :> {
            name: "Zero",
            difficulty: Hard,
            initial: map toStack [0, 1, 2, 3, 4, 5, 6, 7],
            target: map toStack [0, 0, 0, 0, 0, 0, 0, 0]
        }
    ]
}


Write down initial thoughts on canoicalisation

{-
# Simplify the spec by unnesting groups.

* Singleton groups that contain only a single other group, or "required" groups
  that contain only a single required element. Since the set of "required"
  arguments changes with the 'options.requireFlags' setting, only consider
  positional arguments and commands truely required... As a special case, we
  consider a group compromised entirely of "free" arguments (i.e. options and
  flags) to be "similar enough" to the list of singleton groups, where each
  singleton group is compromised of one component of the original listing.

  Consider:
    * (a)       = a
    * ((a))     = (a) -> a
    * ((a b c)) = (a b c)
    * ([a])     = [a]
    * [([a])]   = [a]
    * [-abc]    = [-a] [-b] [-c]                                  (special case)
    * [-abc -e] = [-a] [-b] [-c] [-e]                             (special case)
    * [-abc -e] = [-a] [-b] [-c] [-e]                             (special case)
    * [-abc  x] = [-abc x]                   (note: no expansion because of 'x')
    * (a...)    = a...
    * (a)...    = a...
    * ((a)...)  = (a)... = a...
    * ((a... b c)...) = ((a... b c)...)    (note: no expansion because of '...')
    * ([a])     = [a]
    * [([a])]   = [a]

  This essentially canonicalises the specification. No meaning is lost in the
  process. At least not in terms of parsing user input against the specification
  later on.
-}

module Language.Docopt.Solver.Ungroup where

import Prelude
import Data.List (List(), singleton)
import Language.Docopt

unGroup :: Specification -> Specification
unGroup spec = do
  usage <- spec
  pure do
    branch <- usage
    pure do
      arg <- branch
      unGroupArg arg

unGroupArg :: Argument -> List Argument
-- unGroupArg (Group { branches }) =
unGroupArg a = singleton a

-- | Ungroup groups into their super groups if they only have one branch and all
-- | contained elements are optional.

module Language.Docopt.Solver.Ungroup where

import Prelude
import Data.List (List(), singleton)
import Language.Docopt

unGroup :: Specification -> Specification
unGroup spec = do
  usage <- spec
  pure do
    branch <- usage
    pure do
      arg <- branch
      unGroupArg arg

unGroupArg :: Argument -> List Argument
-- unGroupArg (Group { branches }) =
unGroupArg a = singleton a


[DAE-4] Minor nedpoint fix

[DAE-4] Minor nedpoint fix

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error, Error)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic)
import Data.HTTP.Method (Method(POST, DELETE))
import Data.Maybe (Maybe (Just))
import Data.Tuple (Tuple)
import Network.HTTP.Affjax (affjax, defaultRequest, AJAX, get)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, _ctxIdValue, CTxId, CTxMeta)
import Daedalus.Constants (backendPrefix)

-- TODO: remove traces, they are adding to increase verbosity in development
makeRequest :: forall eff a. (Generic a) => String -> Aff (ajax :: AJAX | eff) a
makeRequest url = do
  res <- get $ backendPrefix <> url
  either throwError pure $ decodeResult res

decodeResult :: forall a eff. (Generic a) => {response :: Json | eff} -> Either Error a
decodeResult res = bimap error id $ decodeJson res.response

getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = makeRequest $ "/api/get_wallets"

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = makeRequest $ "/api/get_wallet/" <> _address addr

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = makeRequest $ "/api/history/" <> _address addr

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) Unit
send addrFrom addrTo amount = do
  res <- affjax $ defaultRequest
    -- TODO: use url constructor
    { url = backendPrefix <> "/api/send/" <> _address addrFrom <> "/" <> _address addrTo <> "/" <> show (_coin amount)
    , method = Left POST
    }
  either throwError pure $ decodeResult res

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet wMeta = do
  res <- affjax $ defaultRequest
    { url = backendPrefix <> "/api/new_wallet"
    , method = Left POST
    , content = Just $ encodeJson wMeta
    }
  either throwError pure $ decodeResult res

--updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) ()
--updateTransaction addr ctxId ctxMeta = do
--  res <- affjax $ defaultRequest
--    { url = backendPrefix <> "/api/update_transaction/" <> _address addr <> "/" <> _ctxIdValue ctxId
--    , method = Left POST
--    , content = Just $ encodeJson ctxMeta
--    }
--  either throwError pure $ decodeResult res

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr wMeta = do
  res <- affjax $ defaultRequest
    { url = backendPrefix <> "/api/update_wallet/" <> _address addr
    , method = Left POST
    , content = Just $ encodeJson wMeta
    }
  either throwError pure $ decodeResult res

deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = do
  -- FIXME: use DELETE method
  res <- affjax $ defaultRequest { url = backendPrefix <> "/api/delete_wallet/" <> _address addr, method = Left POST }
  either throwError pure $ decodeResult res

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error, Error)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic)
import Data.HTTP.Method (Method(POST, DELETE))
import Data.Maybe (Maybe (Just))
import Data.Tuple (Tuple)
import Network.HTTP.Affjax (affjax, defaultRequest, AJAX, get)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, _ctxIdValue, CTxId, CTxMeta)
import Daedalus.Constants (backendPrefix)

-- TODO: remove traces, they are adding to increase verbosity in development
makeRequest :: forall eff a. (Generic a) => String -> Aff (ajax :: AJAX | eff) a
makeRequest url = do
  res <- get $ backendPrefix <> url
  either throwError pure $ decodeResult res

decodeResult :: forall a eff. (Generic a) => {response :: Json | eff} -> Either Error a
decodeResult res = bimap error id $ decodeJson res.response

getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = makeRequest $ "/api/get_wallets"

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = makeRequest $ "/api/get_wallet/" <> _address addr

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = makeRequest $ "/api/history/" <> _address addr

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) Unit
send addrFrom addrTo amount = do
  res <- affjax $ defaultRequest
    -- TODO: use url constructor
    { url = backendPrefix <> "/api/send/" <> _address addrFrom <> "/" <> _address addrTo <> "/" <> show (_coin amount)
    , method = Left POST
    }
  either throwError pure $ decodeResult res

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet wMeta = do
  res <- affjax $ defaultRequest
    { url = backendPrefix <> "/api/new_wallet"
    , method = Left POST
    , content = Just $ encodeJson wMeta
    }
  either throwError pure $ decodeResult res

--updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) ()
--updateTransaction addr ctxId ctxMeta = do
--  res <- affjax $ defaultRequest
--    { url = backendPrefix <> "/api/update_transaction/" <> _address addr <> "/" <> _ctxIdValue ctxId
--    , method = Left POST
--    , content = Just $ encodeJson ctxMeta
--    }
--  either throwError pure $ decodeResult res

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr wMeta = do
  res <- affjax $ defaultRequest
    { url = backendPrefix <> "/api/update_wallet" <> _address addr
    , method = Left POST
    , content = Just $ encodeJson wMeta
    }
  either throwError pure $ decodeResult res

deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = do
  -- FIXME: use DELETE method
  res <- affjax $ defaultRequest { url = backendPrefix <> "/api/delete_wallet/" <> _address addr, method = Left POST }
  either throwError pure $ decodeResult res


Minor edit

Minor edit

module App.Update
  ( foldp
  , init
  , AppEffects
  , State
  ) where

import Prelude

import App.Events (Event(..))
import Control.Monad.Aff (Aff, delay)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Random (RANDOM)
import Data.Array (fromFoldable, concat)
import Data.Helpers (generateSequence, convertToColors, checkUserInput)
import Data.Int (toNumber)
import Data.List (List(..), range, index, snoc, length)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Sounds (SOUND, play)
import Data.Time.Duration (Milliseconds(..))
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (ALERT)
import DOM.HTML.Window (alert)
import Pux (EffModel, noEffects, onlyEffects)

type AppEffects =
  ( random :: RANDOM
  , console :: CONSOLE
  , dom :: DOM
  , sound :: SOUND
  , alert :: ALERT
  )

type State =
  { sequence :: List String
  , userInput :: List String
  , currentColor :: String
  , count :: Int
  , strict :: Boolean
  }

init :: State
init =
  { sequence: Nil
  , userInput: Nil
  , currentColor: ""
  , count : 0
  , strict: false
  }

generatePlaySequence :: forall e. Int -> List String -> Array (Aff e (Maybe Event))
generatePlaySequence count sequence =
  range 0 (count - 1) #
  map (\v ->
    [ do
        delay $ Milliseconds ((toNumber v + 1.0) * 1000.0)
        let color = fromMaybe "" $ index sequence v
        pure $ Just $ AnimateColor color color
    ]
  ) #
  fromFoldable #
  concat

foldp :: Event -> State -> EffModel State Event AppEffects
foldp Start state =
  if state.count > 0 then
    noEffects $ state
  else
    { state: state { count = state.count + 1 }
    , effects:
        [ do
            result <- liftEff generateSequence
            let colors = convertToColors result
            pure $ Just $ NewSequence colors
        ]
    }

foldp (NewSequence list) state =
  { state: state { sequence = list }
  , effects: [ pure $ Just $ PlaySequence ]
  }

foldp (UserClick color) state =
  let
    nextUserInput = snoc state.userInput color
    checksPass = checkUserInput state.sequence nextUserInput
  in
    if state.count < 1 then
      noEffects state
    else if checksPass && length nextUserInput == 20 then
      { state: init
      , effects:
        [ do
            wind <- liftEff window
            liftEff $ alert "You just won the game, yay! Let's do it again" wind
            pure Nothing
        , pure $ Just $ Start
        ]
      }
    else if checksPass && length nextUserInput == state.count then
      { state: state { userInput = Nil, count = state.count + 1 }
      , effects:
        [ pure $ Just $ AnimateColor color color
        , pure $ Just $ PlaySequence
        ]
      }
    else if checksPass then
      { state: state { userInput = nextUserInput }
      , effects:
        [ pure $ Just $ AnimateColor color color
        ]
      }
    else if not checksPass && state.strict then
      { state: state { userInput = Nil, count = 1 }
      , effects:
        [ pure $ Just $ AnimateColor color "error"
        , pure $ Just $ PlaySequence
        ]
      }
    else
      { state: state { userInput = Nil }
      , effects:
        [ pure $ Just $ AnimateColor color "error"
        , pure $ Just $ PlaySequence
        ]
      }

foldp ResetColor state = noEffects $ state { currentColor = "" }

foldp (AnimateColor color sound) state =
  { state: state { currentColor = color },
    effects:
      [ liftEff $ play sound *> pure Nothing
      , do
        delay $ Milliseconds 300.0
        pure $ Just $ ResetColor
      ]
  }

foldp PlaySequence state =
  onlyEffects state $ generatePlaySequence state.count state.sequence

foldp (Strict e) state = noEffects $ state { strict = not state.strict }

foldp Reset state =
  { state: init
  , effects: [ pure $ Just $ Start ]
  }

module App.Update
  ( foldp
  , init
  , AppEffects
  , State
  ) where

import Prelude

import App.Events (Event(..))
import Control.Monad.Aff (Aff, delay)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Random (RANDOM)
import Data.Array (fromFoldable, concat)
import Data.Helpers (generateSequence, convertToColors, checkUserInput)
import Data.Int (toNumber)
import Data.List (List(..), range, index, snoc, length)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Sounds (SOUND, play)
import Data.Time.Duration (Milliseconds(..))
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (ALERT)
import DOM.HTML.Window (alert)
import Pux (EffModel, noEffects, onlyEffects)

type AppEffects =
  ( random :: RANDOM
  , console :: CONSOLE
  , dom :: DOM
  , sound :: SOUND
  , alert :: ALERT
  )

type State =
  { sequence :: List String
  , userInput :: List String
  , currentColor :: String
  , count :: Int
  , strict :: Boolean
  }

init :: State
init =
  { sequence: Nil
  , userInput: Nil
  , currentColor: ""
  , count : 0
  , strict: false
  }

generatePlaySequence :: forall e. Int -> List String -> Array (Aff e (Maybe Event))
generatePlaySequence count sequence =
  range 0 (count - 1) #
  map (\v ->
    [ do
        delay $ Milliseconds ((toNumber v + 1.0) * 1000.0)
        let color = fromMaybe "" $ index sequence v
        pure $ Just $ AnimateColor color color
    ]
  ) #
  fromFoldable #
  concat

foldp :: Event -> State -> EffModel State Event AppEffects
foldp Start state =
  if state.count > 20 then
    noEffects $ state
  else
    { state: state { count = state.count + 1 }
    , effects:
        [ do
            result <- liftEff generateSequence
            let colors = convertToColors result
            pure $ Just $ NewSequence colors
        ]
    }

foldp (NewSequence list) state =
  { state: state { sequence = list }
  , effects: [ pure $ Just $ PlaySequence ]
  }

foldp (UserClick color) state =
  let
    nextUserInput = snoc state.userInput color
    checksPass = checkUserInput state.sequence nextUserInput
  in
    if state.count < 1 then
      noEffects state
    else if checksPass && length nextUserInput == 20 then
      { state: init
      , effects:
        [ do
            wind <- liftEff window
            liftEff $ alert "You just won the game, yay! Let's do it again" wind
            pure Nothing
        , pure $ Just $ Start
        ]
      }
    else if checksPass && length nextUserInput == state.count then
      { state: state { userInput = Nil, count = state.count + 1 }
      , effects:
        [ pure $ Just $ AnimateColor color color
        , pure $ Just $ PlaySequence
        ]
      }
    else if checksPass then
      { state: state { userInput = nextUserInput }
      , effects:
        [ pure $ Just $ AnimateColor color color
        ]
      }
    else if not checksPass && state.strict then
      { state: state { userInput = Nil, count = 1 }
      , effects:
        [ pure $ Just $ AnimateColor color "error"
        , pure $ Just $ PlaySequence
        ]
      }
    else
      { state: state { userInput = Nil }
      , effects:
        [ pure $ Just $ AnimateColor color "error"
        , pure $ Just $ PlaySequence
        ]
      }

foldp ResetColor state = noEffects $ state { currentColor = "" }

foldp (AnimateColor color sound) state =
  { state: state { currentColor = color },
    effects:
      [ liftEff $ play sound *> pure Nothing
      , do
        delay $ Milliseconds 300.0
        pure $ Just $ ResetColor
      ]
  }

foldp PlaySequence state =
  onlyEffects state $ generatePlaySequence state.count state.sequence

foldp (Strict e) state = noEffects $ state { strict = not state.strict }

foldp Reset state =
  { state: init
  , effects: [ pure $ Just $ Start ]
  }