Preserve indentation

Preserve indentation

Original commit 3d4e8c025c4539e7caec86f7d79703b0caffe105

module Golang
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude
import Types

import Data.Array as A
import Data.Char.Unicode (isDigit, isLetter)
import Data.Foldable (for_, intercalate)
import Data.FoldableWithIndex (allWithIndex)
import Data.Functor (map)
import Data.List (fromFoldable, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust, isNothing)
import Data.Set (Set, isEmpty, member, singleton, union)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..))
import Utils (mapM, removeElement)

-- data GoInfo = GoInfo { classNames ::  Map Int String }

type GoDoc = Doc Unit

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , render: renderGraphToGolang
    }

renderGraphToGolang :: IRGraph -> String
renderGraphToGolang graph =
    runDoc golangDoc nameForClass unionName unionPredicate nextNameToTry S.empty graph unit
    where
        unionPredicate =
            case _ of
            IRUnion ur ->
                let s = unionToSet ur
                in
                    if isNothing $ nullableFromSet s then
                        Just s
                    else
                        Nothing
            _ -> Nothing
        nameForClass (IRClassData { names }) = goNameStyle $ combineNames names
        unionName components =
            "OneOf" <> (goNameStyle $ intercalate "_" $ components)
        nextNameToTry s =
            "Other" <> s

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

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

isStartCharacter :: Char -> Boolean
isStartCharacter = isLetterCharacter

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isLetterCharacter c || isDigit c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnionToGolang :: Set IRType -> GoDoc String
renderUnionToGolang s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderTypeToGolang x
        pure if isValueType x then "*" <> rendered else rendered
    Nothing -> lookupUnionName s

renderTypeToGolang :: IRType -> GoDoc String
renderTypeToGolang = case _ of
    IRNothing -> pure "interface{}"
    IRNull -> pure "interface{}"
    IRInteger -> pure "int64"
    IRDouble -> pure "float64"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToGolang a
        pure $ "[]" <> rendered
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToGolang t
        pure $ "map[string]" <> rendered
    IRUnion types -> renderUnionToGolang $ unionToSet types

goNameStyle :: String -> String
goNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

golangDoc :: GoDoc Unit
golangDoc = do
    lines "package main"
    blank
    unions <- getUnions
    unless (unions == L.Nil) do
        indent do
            lines "import \"bytes\""
            lines "import \"errors\""
            lines "import \"encoding/json\""
            blank
    IRGraph { toplevel } <- getGraph
    renderedToplevel <- renderTypeToGolang toplevel
    lines $ "type Root " <> renderedToplevel
    blank
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        renderGolangType i cls
        blank
    unless (unions == L.Nil) do
        line $ string """
func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, pa interface{}, pc interface{}, pm interface{}, nullable 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 err
	}

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

}"""
        blank
    for_ unions \types -> do
        renderGolangUnion types
        blank

renderGolangType :: Int -> IRClassData -> GoDoc Unit
renderGolangType classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames goNameStyle ("Other" <> _) S.empty $ map (\n -> Tuple n n) $ Map.keys properties
    line $ words ["type", className, "struct {"]
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            let csPropName = lookupName pname propertyNames
            rendered <- renderTypeToGolang ptype
            lines $ csPropName <> " " <> rendered <> " `json:\"" <> (stringEscape pname) <> "\"`"
    lines "}"

unionFieldName :: IRType -> GoDoc String
unionFieldName t = do
    graph <- getGraph
    let typeName = typeNameForUnion graph t
    pure $ goNameStyle typeName

compoundPredicates :: Array (IRType -> Boolean)
compoundPredicates = [isArray, isClass, isMap]

renderGolangUnion :: Set IRType -> GoDoc Unit
renderGolangUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    line $ words ["type", name, "struct {"]
    indent do
        for_ nonNullTypes \t -> do
            typeString <- renderUnionToGolang $ S.union (S.singleton t) (S.singleton IRNull)
            field <- unionFieldName t
            lines $ field <> " " <> typeString
    lines "}"
    blank
    lines $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    primitiveArgs <- mapM primitiveMemberPtr $ L.fromFoldable [IRInteger, IRDouble, IRBool, IRString]
    compoundArgs <- mapM memberPtr $ L.fromFoldable compoundPredicates
    let args = intercalate ", " $ A.concat [A.fromFoldable primitiveArgs, A.fromFoldable compoundArgs]
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        lines $ "\treturn unmarshalUnion(data, " <> args <> ", " <> (if isJust emptyOrNull then "true" else "false") <> ")"
    lines "}"
    where
        maybeAssignNil p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    lines $ "x." <> name <> " = nil"
                Nothing -> pure unit
        memberPtr p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    pure $ "&x." <> name
                Nothing -> pure "nil"
        primitiveMemberPtr t =
            memberPtr (eq t)

module Golang
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude
import Types

import Data.Array as A
import Data.Char.Unicode (isDigit, isLetter)
import Data.Foldable (for_, intercalate)
import Data.FoldableWithIndex (allWithIndex)
import Data.Functor (map)
import Data.List (fromFoldable, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust, isNothing)
import Data.Set (Set, isEmpty, member, singleton, union)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..))
import Utils (mapM, removeElement)

-- data GoInfo = GoInfo { classNames ::  Map Int String }

type GoDoc = Doc Unit

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , render: renderGraphToGolang
    }

renderGraphToGolang :: IRGraph -> String
renderGraphToGolang graph =
    runDoc golangDoc nameForClass unionName unionPredicate nextNameToTry S.empty graph unit
    where
        unionPredicate =
            case _ of
            IRUnion ur ->
                let s = unionToSet ur
                in
                    if isNothing $ nullableFromSet s then
                        Just s
                    else
                        Nothing
            _ -> Nothing
        nameForClass (IRClassData { names }) = goNameStyle $ combineNames names
        unionName components =
            "OneOf" <> (goNameStyle $ intercalate "_" $ components)
        nextNameToTry s =
            "Other" <> s

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

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

isStartCharacter :: Char -> Boolean
isStartCharacter = isLetterCharacter

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isLetterCharacter c || isDigit c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnionToGolang :: Set IRType -> GoDoc String
renderUnionToGolang s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderTypeToGolang x
        pure if isValueType x then "*" <> rendered else rendered
    Nothing -> lookupUnionName s

renderTypeToGolang :: IRType -> GoDoc String
renderTypeToGolang = case _ of
    IRNothing -> pure "interface{}"
    IRNull -> pure "interface{}"
    IRInteger -> pure "int64"
    IRDouble -> pure "float64"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToGolang a
        pure $ "[]" <> rendered
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToGolang t
        pure $ "map[string]" <> rendered
    IRUnion types -> renderUnionToGolang $ unionToSet types

goNameStyle :: String -> String
goNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

golangDoc :: GoDoc Unit
golangDoc = do
    lines "package main"
    blank
    unions <- getUnions
    unless (unions == L.Nil) do
        indent do
            lines "import \"bytes\""
            lines "import \"errors\""
            lines "import \"encoding/json\""
            blank
    IRGraph { toplevel } <- getGraph
    renderedToplevel <- renderTypeToGolang toplevel
    lines $ "type Root " <> renderedToplevel
    blank
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        renderGolangType i cls
        blank
    unless (unions == L.Nil) do
        lines """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, pa interface{}, pc interface{}, pm interface{}, nullable 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 err
	}

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

}"""
        blank
    for_ unions \types -> do
        renderGolangUnion types
        blank

renderGolangType :: Int -> IRClassData -> GoDoc Unit
renderGolangType classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames goNameStyle ("Other" <> _) S.empty $ map (\n -> Tuple n n) $ Map.keys properties
    line $ words ["type", className, "struct {"]
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            let csPropName = lookupName pname propertyNames
            rendered <- renderTypeToGolang ptype
            lines $ csPropName <> " " <> rendered <> " `json:\"" <> (stringEscape pname) <> "\"`"
    lines "}"

unionFieldName :: IRType -> GoDoc String
unionFieldName t = do
    graph <- getGraph
    let typeName = typeNameForUnion graph t
    pure $ goNameStyle typeName

compoundPredicates :: Array (IRType -> Boolean)
compoundPredicates = [isArray, isClass, isMap]

renderGolangUnion :: Set IRType -> GoDoc Unit
renderGolangUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    line $ words ["type", name, "struct {"]
    indent do
        for_ nonNullTypes \t -> do
            typeString <- renderUnionToGolang $ S.union (S.singleton t) (S.singleton IRNull)
            field <- unionFieldName t
            lines $ field <> " " <> typeString
    lines "}"
    blank
    lines $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    primitiveArgs <- mapM primitiveMemberPtr $ L.fromFoldable [IRInteger, IRDouble, IRBool, IRString]
    compoundArgs <- mapM memberPtr $ L.fromFoldable compoundPredicates
    let args = intercalate ", " $ A.concat [A.fromFoldable primitiveArgs, A.fromFoldable compoundArgs]
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        lines $ "\treturn unmarshalUnion(data, " <> args <> ", " <> (if isJust emptyOrNull then "true" else "false") <> ")"
    lines "}"
    where
        maybeAssignNil p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    lines $ "x." <> name <> " = nil"
                Nothing -> pure unit
        memberPtr p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    pure $ "&x." <> name
                Nothing -> pure "nil"
        primitiveMemberPtr t =
            memberPtr (eq t)


Persistent mapper classes in Java. Fixes #124

Original commit 0bbd8a512f966f41dd39b8e99ec4a1a42f605300

module Language.Java
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (GeneralCategory(..), generalCategory, isSpace)
import Data.Foldable (find, for_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), isJust, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, isLetterOrLetterNumber, legalizeCharacters, startWithLetter, stringEscape)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

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

renderer :: Renderer
renderer =
    { name: "Java"
    , aceMode: "java"
    , extension: "java"
    , doc: javaDoc
    , 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

javaNameStyle :: Boolean -> String -> String
javaNameStyle upper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter upper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c =
            case generalCategory c of
            Just CurrencySymbol -> true
            Just ConnectorPunctuation -> true
            _ -> isLetterOrLetterNumber c

        isPartCharacter :: Char -> Boolean
        isPartCharacter c =
            case generalCategory c of
            Just DecimalNumber -> true
            Just SpacingCombiningMark -> true
            Just NonSpacingMark -> true
            Just Format -> true
            Just Control -> not $ isSpace c
            _ -> isStartCharacter c

javaDoc :: Doc Unit
javaDoc = do
    renderConverter
    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties
    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

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

renderType :: Boolean -> IRType -> Doc String
renderType reference = case _ of
    IRNothing -> 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
    line "package io.quicktype;"
    blank
    for_ imports \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.util.Map", "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 ["java.util.Map", "com.fasterxml.jackson.annotation.*"]
    let propertyNames = transformPropertyNames (simpleNamer $ javaNameStyle false) (\n -> "other" <>  capitalize n) forbiddenNames properties
    when (M.isEmpty properties) do
        line "@JsonAutoDetect(fieldVisibility=JsonAutoDetect.Visibility.NONE)"
    line $ "public class " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ javaName fieldName rendered -> do
            line $ "private " <> rendered <> " " <> fieldName <> ";"
        forEachProperty_ properties propertyNames \pname javaName fieldName rendered -> do
            blank
            line $ "@JsonProperty(\"" <> stringEscape pname <> "\")"
            line $ "public " <> rendered <> " get" <> javaName <> "() { return " <> fieldName <> "; }"
            line $ "public void set" <> javaName <> "(" <> rendered <> " value) { this." <> fieldName <> " = value; }"
    line "}"
    where
        forEachProperty_ :: Map String IRType -> Map String String -> (String -> String -> String -> String -> Doc Unit) -> Doc Unit
        forEachProperty_ properties propertyNames f =
            for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
                let fieldName = lookupName pname propertyNames
                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 :: Set IRType -> Doc Unit
renderNullCase types =
    when (S.member IRNull types) 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 -> Set IRType -> Doc Unit
renderPrimitiveCase tokenTypes t types =
    when (S.member t types) do
        for_ tokenTypes \tokenType ->
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleCase :: Set IRType -> Doc Unit
renderDoubleCase types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "VALUE_NUMBER_INT"
        tokenCase "VALUE_NUMBER_FLOAT"
        indent do
            deserializeType IRDouble

renderGenericCase :: (IRType -> Boolean) -> String -> Set IRType -> Doc Unit
renderGenericCase predicate tokenType types =
    case find predicate types of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    renderFileHeader unionName ["java.io.IOException", "java.util.Map", "com.fasterxml.jackson.core.*", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.databind.annotation.*"]
    line $ "@JsonDeserialize(using = " <> unionName <> ".Deserializer.class)"
    line $ "@JsonSerialize(using = " <> unionName <> ".Serializer.class)"
    line $ "public class " <> unionName <> " {"
    indent do
        for_ nonNullTypes \t -> do
            { renderedType, fieldName } <- renderUnionField t
            line $ "public " <> renderedType <> " " <> fieldName <> ";"
        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()) {"
                renderNullCase unionTypes
                renderPrimitiveCase ["VALUE_NUMBER_INT"] IRInteger unionTypes
                renderDoubleCase unionTypes
                renderPrimitiveCase ["VALUE_TRUE", "VALUE_FALSE"] IRBool unionTypes
                renderPrimitiveCase ["VALUE_STRING"] IRString unionTypes
                renderGenericCase isArray "START_ARRAY" unionTypes
                renderGenericCase isClass "START_OBJECT" unionTypes
                renderGenericCase isMap "START_OBJECT" unionTypes
                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
                for_ (A.fromFoldable nonNullTypes) \field -> do
                    { fieldName } <- renderUnionField field
                    line $ "if (obj." <> fieldName <> " != null) {"
                    indent do
                        line $ "jsonGenerator.writeObject(obj." <> fieldName <> ");"
                        line "return;"
                    line "}"
                when (isJust emptyOrNull) do
                    line "jsonGenerator.writeNull();"
                when (isNothing emptyOrNull) do
                    line $ "throw new IOException(\"" <> unionName <> " must not be null\");"
            line "}"
        line "}"
    line "}"

module Language.Java
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (GeneralCategory(..), generalCategory, isSpace)
import Data.Foldable (find, for_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), isJust, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, isLetterOrLetterNumber, legalizeCharacters, startWithLetter, stringEscape)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

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

renderer :: Renderer
renderer =
    { name: "Java"
    , aceMode: "java"
    , extension: "java"
    , doc: javaDoc
    , 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

javaNameStyle :: Boolean -> String -> String
javaNameStyle upper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter upper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c =
            case generalCategory c of
            Just CurrencySymbol -> true
            Just ConnectorPunctuation -> true
            _ -> isLetterOrLetterNumber c

        isPartCharacter :: Char -> Boolean
        isPartCharacter c =
            case generalCategory c of
            Just DecimalNumber -> true
            Just SpacingCombiningMark -> true
            Just NonSpacingMark -> true
            Just Format -> true
            Just Control -> not $ isSpace c
            _ -> isStartCharacter c

javaDoc :: Doc Unit
javaDoc = do
    renderConverter
    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties
    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

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

renderType :: Boolean -> IRType -> Doc String
renderType reference = case _ of
    IRNothing -> 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
    line "package io.quicktype;"
    blank
    for_ imports \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.util.Map", "java.io.IOException", "com.fasterxml.jackson.databind.ObjectMapper", "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
                line "ObjectMapper mapper = new ObjectMapper();"
                renderedForClass <- renderTypeWithoutGenerics false topLevelType
                line $ "return mapper.readValue(json, " <> renderedForClass <> ".class);"
            line "}"
            blank
            encoderName <- getEncoderName topLevelName
            line $ "public static String " <> encoderName <> "(" <> topLevelTypeRendered <> " obj) throws JsonProcessingException {"
            indent do
                line "ObjectMapper mapper = new ObjectMapper();"
                line "return mapper.writeValueAsString(obj);"
            line "}"
    line "}"
    where
        getDecoderName = getHelperMethodName "fromJsonString"
        getEncoderName = getHelperMethodName "toJsonString"

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

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    renderFileHeader className ["java.util.Map", "com.fasterxml.jackson.annotation.*"]
    let propertyNames = transformPropertyNames (simpleNamer $ javaNameStyle false) (\n -> "other" <>  capitalize n) forbiddenNames properties
    when (M.isEmpty properties) do
        line "@JsonAutoDetect(fieldVisibility=JsonAutoDetect.Visibility.NONE)"
    line $ "public class " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ javaName fieldName rendered -> do
            line $ "private " <> rendered <> " " <> fieldName <> ";"
        forEachProperty_ properties propertyNames \pname javaName fieldName rendered -> do
            blank
            line $ "@JsonProperty(\"" <> stringEscape pname <> "\")"
            line $ "public " <> rendered <> " get" <> javaName <> "() { return " <> fieldName <> "; }"
            line $ "public void set" <> javaName <> "(" <> rendered <> " value) { this." <> fieldName <> " = value; }"
    line "}"
    where
        forEachProperty_ :: Map String IRType -> Map String String -> (String -> String -> String -> String -> Doc Unit) -> Doc Unit
        forEachProperty_ properties propertyNames f =
            for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
                let fieldName = lookupName pname propertyNames
                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 :: Set IRType -> Doc Unit
renderNullCase types =
    when (S.member IRNull types) 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 -> Set IRType -> Doc Unit
renderPrimitiveCase tokenTypes t types =
    when (S.member t types) do
        for_ tokenTypes \tokenType ->
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleCase :: Set IRType -> Doc Unit
renderDoubleCase types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "VALUE_NUMBER_INT"
        tokenCase "VALUE_NUMBER_FLOAT"
        indent do
            deserializeType IRDouble

renderGenericCase :: (IRType -> Boolean) -> String -> Set IRType -> Doc Unit
renderGenericCase predicate tokenType types =
    case find predicate types of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    renderFileHeader unionName ["java.io.IOException", "java.util.Map", "com.fasterxml.jackson.core.*", "com.fasterxml.jackson.databind.*", "com.fasterxml.jackson.databind.annotation.*"]
    line $ "@JsonDeserialize(using = " <> unionName <> ".Deserializer.class)"
    line $ "@JsonSerialize(using = " <> unionName <> ".Serializer.class)"
    line $ "public class " <> unionName <> " {"
    indent do
        for_ nonNullTypes \t -> do
            { renderedType, fieldName } <- renderUnionField t
            line $ "public " <> renderedType <> " " <> fieldName <> ";"
        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()) {"
                renderNullCase unionTypes
                renderPrimitiveCase ["VALUE_NUMBER_INT"] IRInteger unionTypes
                renderDoubleCase unionTypes
                renderPrimitiveCase ["VALUE_TRUE", "VALUE_FALSE"] IRBool unionTypes
                renderPrimitiveCase ["VALUE_STRING"] IRString unionTypes
                renderGenericCase isArray "START_ARRAY" unionTypes
                renderGenericCase isClass "START_OBJECT" unionTypes
                renderGenericCase isMap "START_OBJECT" unionTypes
                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
                for_ (A.fromFoldable nonNullTypes) \field -> do
                    { fieldName } <- renderUnionField field
                    line $ "if (obj." <> fieldName <> " != null) {"
                    indent do
                        line $ "jsonGenerator.writeObject(obj." <> fieldName <> ");"
                        line "return;"
                    line "}"
                when (isJust emptyOrNull) do
                    line "jsonGenerator.writeNull();"
                when (isNothing emptyOrNull) do
                    line $ "throw new IOException(\"" <> unionName <> " must not be null\");"
            line "}"
        line "}"
    line "}"


Removed unrequired 'do' block

Removed unrequired 'do' block

module Flag.Core (fetch, shuffle, view, foldp, init) where

import Control.Monad.Aff (Aff, liftEff')
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (decodeJson, Json)
import Data.Array (length, replicate, sortBy, zip, head, take, uncons)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), snd)
import Flag.Types (Countries, Country(..), Event(..), State)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (h1, button, ul, li, div, img)
import Text.Smolder.HTML.Attributes (className, src, alt)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

init ∷ State
init = { countries: Nothing, correct: 0, incorrect: 0 }

shuffle ∷ ∀ e a. Array a → Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

decode ∷ ∀ r. { response ∷ Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch ∷ ∀ e. Aff (random ∷ RANDOM, ajax ∷ AJAX | e) (Maybe Countries)
fetch = get "/countries.json" >>= \xs → case decode xs of
          Left _          → pure $ Nothing
          Right countries → pure $ Just countries

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM, ajax ∷ AJAX)
foldp (Request)           state = onlyEffects state [Just <<< Receive <$> fetch]
foldp (Receive Nothing)   state = noEffects $ state { countries = Nothing }
foldp (Receive (Just xs)) state = noEffects $ state { countries = Just xs }
foldp (Respond name)      state = noEffects $ case join $ uncons <$> state.countries of
  Nothing                              → state { countries = Nothing }
  Just { head: (Country x), tail: xs } → case name == x.name of
    true  → state { countries = Just xs, correct = state.correct + 1 }
    false → state { countries = Just xs, incorrect = state.incorrect + 1 }

view ∷ State → HTML Event
view state = div ! className "flagship" $ do
  ul ! className "header" $ do
    li $ h1 $ text "Flagship"
    li $ button #! onClick (const Request) $ text "Start"
    li ! className "score correct" $ text $ show state.correct
    li ! className "score incorrect" $ text $ show state.incorrect
    li ! className "score" $ text $ show $ state.correct + state.incorrect
  <> do div ! className "prompt" $ case state.countries of
          Nothing        → button #! onClick (const Request) $ text "Start"
          Just countries → case head countries of
            Nothing              → div $ text "All done!"
            Just (Country current) → do
              img ! src ("images/flags/" <> current.flag) ! alt "Flag"
              ul ! className "countries" $ for_ (take 4 countries) $ \(Country answer) →
                li $ button #! onClick (const $ Respond answer.name) $ text answer.name

module Flag.Core (fetch, shuffle, view, foldp, init) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (decodeJson, Json)
import Data.Array (length, replicate, sortBy, zip, head, take, uncons)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), snd)
import Flag.Types (Countries, Country(..), Event(..), State)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (h1, button, ul, li, div, img)
import Text.Smolder.HTML.Attributes (className, src, alt)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

init ∷ State
init = { countries: Nothing, correct: 0, incorrect: 0 }

shuffle ∷ ∀ e a. Array a → Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

decode ∷ ∀ r. { response ∷ Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch ∷ ∀ e. Aff (random ∷ RANDOM, ajax ∷ AJAX | e) (Maybe Countries)
fetch = do
  get "/countries.json" >>= \xs → case decode xs of
    Left _          → pure $ Nothing
    Right countries → pure $ Just countries

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM, ajax ∷ AJAX)
foldp (Request)           state = onlyEffects state [Just <<< Receive <$> fetch]
foldp (Receive Nothing)   state = noEffects $ state { countries = Nothing }
foldp (Receive (Just xs)) state = noEffects $ state { countries = Just xs }
foldp (Respond name)      state = noEffects $ case join $ uncons <$> state.countries of
  Nothing                              → state { countries = Nothing }
  Just { head: (Country x), tail: xs } → case name == x.name of
    true  → state { countries = Just xs, correct = state.correct + 1 }
    false → state { countries = Just xs, incorrect = state.incorrect + 1 }

view ∷ State → HTML Event
view state = div ! className "flagship" $ do
  ul ! className "header" $ do
    li $ h1 $ text "Flagship"
    li $ button #! onClick (const Request) $ text "Start"
    li ! className "score correct" $ text $ show state.correct
    li ! className "score incorrect" $ text $ show state.incorrect
    li ! className "score" $ text $ show $ state.correct + state.incorrect
  <> do div ! className "prompt" $ case state.countries of
          Nothing        → button #! onClick (const Request) $ text "Start"
          Just countries → case head countries of
            Nothing              → div $ text "All done!"
            Just (Country current) → do
              img ! src ("images/flags/" <> current.flag) ! alt "Flag"
              ul ! className "countries" $ for_ (take 4 countries) $ \(Country answer) →
                li $ button #! onClick (const $ Respond answer.name) $ text answer.name


bugfix: correct renaming in type checker tests

module Test.TypeChecker where

import AST
import TypeChecker (Scheme(Forall), inferGroup, inferType, inferDef, emptyTypeEnv, runInfer, typeProgramn, eqScheme, normalizeTypeTree, typeTreeProgram)
import Parser (parseExpr, parseDefs)
import Test.Parser (parsedPrelude)

import Prelude (Unit, bind, map, pure, show, unit, ($), (==), (<>), (<<<))
import Control.Monad.Writer (Writer, tell)
import Data.Array (toUnfoldable) as Array
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.List (List(..), (:), singleton)
import Data.Tuple (Tuple(..))
import Text.Parsing.Parser (ParseError, parseErrorMessage)

-- | The result of the type inference procedure.
type InferResult = Either TypeError Scheme

toList :: forall a. Array a -> List a
toList = Array.toUnfoldable

tell' :: forall a. a -> Writer (List a) Unit
tell' = tell <<< singleton

-- | Construct a list of type [typCon] given the name of the type constants.
typConList :: String -> Type
typConList name = AD $ TList (TypCon name)

-- | Construct a tuple type given a list of type constant names.
typConNTuple:: List String -> Type
typConNTuple names = AD $ TTuple (map TypCon names)

-- | Construct a list of type [a] given the type variable name a.
typVarList :: TVar -> Type
typVarList tv = AD $ TList (TypVar tv)

-- | Generate an arrow type from two given type variable names.
typVarArrow :: TVar -> TVar -> Type
typVarArrow tv1 tv2 = TypVar tv1 `TypArr` TypVar tv2

-- | Report a parse error.
reportParseError :: String -> ParseError -> Writer (List String) Unit
reportParseError testName parseError = tell' $ "Parse error for test case "
  <> testName <> ": "
  <> parseErrorMessage parseError
  <> "\nNote that this is not a failing test but rather an error in the test definition."

testInferExpr :: String -> String -> InferResult -> Writer (List String) Unit
testInferExpr name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> compareSchemes name expected $ runInfer $ inferType emptyTypeEnv expression

testInferDef :: String -> String -> InferResult -> Writer (List String) Unit
testInferDef name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right (definition:_) -> compareSchemes name expected $ runInfer $ inferDef emptyTypeEnv definition
  _ -> tell' $ "Parse error for test case " <> name <> ": Expected only a single definition case"
    <> "\nNote that this is not a failing test but rather an error in the test definition."

testInferDefs :: String -> String -> InferResult -> Writer (List String) Unit
testInferDefs name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right definitions -> compareSchemes name expected $ runInfer $ inferGroup emptyTypeEnv definitions

testInferExprWithPrelude :: String -> String -> InferResult -> Writer (List String) Unit
testInferExprWithPrelude name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> compareSchemes name expected (typeProgramn parsedPrelude expression)

-- | Test type inference on expression trees. Here not only the expected type of the whole
-- | expression is checked, but also the type of every subexpression.
testInferTT :: String -> TypeTree -> TypeTree -> Writer (List String) Unit
testInferTT name untypedTree expectedTypedTree = case typeTreeProgram parsedPrelude untypedTree of
  Left typeError -> tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                            "Encountered type error: " <> prettyPrintTypeError typeError
  Right typedTree -> if expectedTypedTree == typedTree
    then pure unit
    else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                 "Expected type tree: " <> show expectedTypedTree <> "\n" <>
                 "Actual type tree: " <> show typedTree <> "\n"

-- | Test type tree normalization.
testNormalizeTT :: String -> TypeTree -> TypeTree -> Writer (List String) Unit
testNormalizeTT name tt normalizedTT = if (normalizeTypeTree tt) == normalizedTT
  then pure unit
  else tell' $ "Type tree normalization failed in test case `" <> name <> "`:\n" <>
               "Expected type tree: " <> show normalizedTT <> "\n" <>
               "Actual type tree: " <> show tt <> "\n"

compareSchemes :: String -> InferResult -> InferResult -> Writer (List String) Unit
compareSchemes name expected actual = if eqInferResult expected actual
  then pure unit
  else tell' $ "\n \n Typing fail in test case `" <> name <> "`:"
    <> "\nExpected: " <> show expected <> " - pretty printed: " <> prettyPrint expected
    <> "\nActual: " <> show actual <> " - pretty printed: " <> prettyPrint actual

eqInferResult :: InferResult -> InferResult -> Boolean
eqInferResult (Left a) (Left a') = (a == a')
eqInferResult (Right a) (Right a') = eqScheme a a'
eqInferResult _ _ = false

prettyPrint :: InferResult -> String
prettyPrint error@(Left _) = show error
prettyPrint (Right (Forall xs t)) = show xs <> " " <> prettyPrintType t

-- | Typed type tree representing `[1]`.
listOne :: TypeTree
listOne = List (Just $ typConList "Int") (Atom (Just $ TypCon "Int") (AInt 1) : Nil)

-- | Untyped type tree representing `[1]`.
untypedListOne :: TypeTree
untypedListOne = List Nothing (Atom Nothing (AInt 1) : Nil)

intType :: Type
intType = TypCon "Int"

charType :: Type
charType = TypCon "Char"

runTests :: Writer (List String) Unit
runTests = do
  testInferExpr "SectL" "(3^)" (Right $ Forall Nil $ TypArr (TypCon "Int") (TypCon "Int"))
  testInferExpr "SectR" "(^3)" (Right $ Forall Nil $ TypArr (TypCon "Int") (TypCon "Int"))
  testInferExpr "Lambda1" "\\a b c d -> a b c d"  (Right $ Forall (toList ["b", "c", "d", "e"]) (TypArr (TypArr (TypVar "b") (TypArr (TypVar "c") (TypArr (TypVar "d") (TypVar "e")))) (TypArr ( TypVar "b")  ((TypArr (TypVar "c") (TypArr (TypVar "d") (TypVar "e")))))))
  testInferExpr "Lambda2" "\\a b -> a b" (Right $ Forall ("t_3" : "t_4" : Nil) (TypArr (TypArr (TypVar "t_3") (TypVar "t_4")) (TypArr (TypVar "t_3") (TypVar "t_4"))))
  testInferExpr "List1" "[1, 2, 3, 4, 5]" (Right $ Forall (Nil) (AD (TList (TypCon "Int"))))
  testInferExpr "List2" "[1 + 2, 3 + 4]" (Right $ Forall (Nil) (AD (TList (TypCon "Int"))))
  testInferExpr "List3" "[(+), 4]" (Left ((UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))))
  testInferExpr "Empty list" "[]" (Right (Forall ("t_0" : Nil) (AD (TList (TypVar "t_0")))))
  testInferExpr "Append" "[1 + 2, 3 + 4] ++ []" (Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInferExpr "Colon" "3 : [1 + 2, 3 + 4, \"Hallo\"]" (Left ((UnificationFail (AD $ TList $ TypCon "Char") (TypCon "Int"))))
  testInferExpr "NTuple" "(1 + 2, 3)" (Right (Forall (Nil) (AD (TTuple (Cons ((TypCon "Int")) (Cons ((TypCon "Int")) (Nil)))))))
  testInferExpr "SectR colon" "(:[3])" (Right (Forall (Nil) (TypArr (TypCon "Int") (AD (TList (TypCon "Int"))))))
  testInferExpr "Lambda wildcard" "\\_ _ -> 5" (Right (Forall ("t_1" : "t_3" : Nil) (TypArr (TypVar "t_1") (TypArr (TypVar "t_3") (TypCon "Int")))))
  testInferExpr "Lambda cons binding" "\\(x:xs) -> x" (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInferExpr "Let expression" "let x = 3 in \\_ _ -> x" (Right (Forall ("t_2" : "t_4" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypCon "Int")))))
  testInferExpr "Binding tuple in let expression" "let (a, b) = (\\f -> f, \"Hello\") in a b" (Right (Forall (Nil) (AD $ TList $ TypCon "Char")))
  testInferExpr "Lambda application" "(\\f a b -> f a b) (+) 3 4" (Right (Forall (Nil) (TypCon "Int")))
  -- ((\xs -> [ x | x <- xs ]) [1]) :: [Int]
  testInferExpr "List comprehension inside lambda" "(\\xs -> [ x | x <- xs ]) [1]" (Right (Forall (Nil) (AD $ TList $ TypCon "Int")))

  testInferDef "Define app" "app f xs = app f xs" (Right (Forall ("t_2" : "t_4" : "t_5" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypVar "t_5")))))
  testInferDef "Define single map" "map f (x:xs) = f x : map f xs" (Right (Forall ("t_11" : "t_5" : Nil) (TypArr (TypArr (TypVar "t_5") (TypVar "t_11")) (TypArr (AD (TList (TypVar "t_5"))) (AD (TList (TypVar "t_11")))))))
  testInferDef "Define foldr" "foldr f ini (x:xs) = f x (foldr f ini xs)" (Right (Forall ("t_5" : "t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_5") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4"))))))
  testInferDef "Conslit binding 1" "list (x:xs:xss) = x" (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInferDef "Conslit binding 2" "list (x:xs:xss) = xs" (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInferDef "Conslit binding 3" "list (x:xs:xss) = xss" (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (AD (TList (TypVar "t_2"))))))
  testInferDef "Binding tuple 1" "fst (a, b) = a" (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple $ Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil)))) (TypVar "t_2"))))
  testInferDef "Binding tuple 2" "snd (a, b) = b" (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple (Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil))))) (TypVar "t_3"))))
  testInferDef "Binding tuple 3" "f (a, b, c) = a b c" (Right (Forall ("t_3" : "t_4" : "t_5" : Nil) (TypArr (AD (TTuple (Cons ((TypArr (TypVar "t_3") (TypArr (TypVar "t_4") (TypVar "t_5")))) (Cons ((TypVar "t_3")) (Cons ((TypVar "t_4")) (Nil)))))) (TypVar "t_5"))))
  testInferDef "Listlit binding" "list [a, b, c] = a b c" (Left ((InfiniteType "a" (TypArr (TypVar "a") (TypVar "b")))))

  testInferDefs "zipWith"
    ("zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" <>
     "zipWith _ [] _ = []\n" <>
     "zipWith _ _ [] = []")
    (Right (Forall ("t_23" : "t_33" : "t_34" : Nil) (TypArr (TypArr (TypVar "t_23") (TypArr (TypVar "t_33") (TypVar "t_34"))) (TypArr (AD (TList (TypVar "t_23"))) (TypArr (AD (TList (TypVar "t_33"))) (AD (TList (TypVar "t_34"))))))))

  testInferDefs "foldr"
    ("foldr f ini [] = ini\n" <>
     "foldr f ini (x:xs) = f x (foldr f ini xs)")
    (Right (Forall ("t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_4") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4"))))))

  testInferDefs "scanl"
    ("scanl f b []     = [b]\n" <>
     "scanl f b (x:xs) = b : scanl f (f b x) xs")
    (Right (Forall ("t_39" : "t_48" : Nil) (TypArr (TypArr (TypVar "t_48") (TypArr (TypVar "t_39") (TypVar "t_48"))) (TypArr (TypVar "t_48") (TypArr (AD (TList (TypVar "t_39"))) (AD (TList (TypVar "t_48"))))))))

  testInferExprWithPrelude "Prelude with exp" "sum (map (^2) [1, 2, 3, 4])" (Right (Forall (Nil) (TypCon "Int")))

  -- Check that \f x -> f x and all the subexpressions are typed correctly.
  testInferTT "Apply function"
    (Lambda Nothing
      ((Lit Nothing (Name "f")) : (Lit Nothing (Name "x")) : Nil)
      (App
        Nothing
        (Atom Nothing (Name "f"))
        ((Atom Nothing (Name "x")) : Nil)))
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)))

  -- Check that [1, 1 + 1, length [1]] and all the subexpressions are typed correctly.
  testInferTT "List"
    (List
      Nothing
      (
        (Atom Nothing (AInt 1)) :
        (Binary
          Nothing
          (Tuple Add Nothing)
          (Atom Nothing (AInt 1))
          (Atom Nothing (AInt 1))) :
        (App
          Nothing
          (Atom
            Nothing
            (Name "length"))
          (untypedListOne : Nil)) :
        Nil
      )
    )
    (List
      (Just (typConList "Int"))
      (
        (Atom (Just (TypCon "Int")) (AInt 1)) :
        (Binary
          (Just (TypCon "Int"))
          (Tuple Add (Just (TypCon "Int" `TypArr` (TypCon "Int" `TypArr` TypCon "Int"))))
          (Atom (Just (TypCon "Int")) (AInt 1))
          (Atom (Just (TypCon "Int")) (AInt 1))) :
        (App
          (Just (TypCon "Int"))
          (Atom
            (Just (typConList "Int" `TypArr` TypCon "Int"))
            (Name "length"))
          (listOne : Nil)) :
        Nil
      )
    )

  -- Check that (\(x:xs) -> x) [1] and all the subexpressions are typed correctly.
  testInferTT "ConsLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((ConsLit
          Nothing
          (Lit Nothing (Name "x"))
          (Lit Nothing (Name "xs"))) : Nil)
        (Atom Nothing (Name "x")))
      (untypedListOne : Nil))
    (App
      (Just $ TypCon "Int")
      (Lambda
        (Just $ typConList "Int" `TypArr` TypCon "Int")
        ((ConsLit
          (Just $ typConList "Int")
          (Lit (Just $ TypCon "Int") (Name "x"))
          (Lit (Just $ typConList "Int") (Name "xs"))) : Nil)
        (Atom (Just $ TypCon "Int") (Name "x")))
      (listOne : Nil))

  -- Check that let x = [1] in [x] :: [[Int]] and all the subexpressions are typed correctly.
  testInferTT "Let"
    (LetExpr
      Nothing
      (Tuple (Lit Nothing (Name "x")) untypedListOne : Nil)
      (List Nothing (Atom Nothing (Name "x") : Nil)))
    (LetExpr
      (Just $ AD $ TList $ typConList "Int")
      (Tuple (Lit (Just $ typConList "Int") (Name "x")) listOne : Nil)
      (List
        (Just $ AD $ TList $ typConList "Int")
        (Atom (Just $ typConList "Int") (Name "x") : Nil)))

-- lit "a"
-- intLit "a"

  -- The type (Char, Int, Int)
  let charIntTupleType = typConNTuple ("Char" : "Int" : "Int" : Nil)
  -- The type (Int, Int)
  let intTupleType = typConNTuple ("Int" : "Int" : Nil)

  -- Check that (\(a,b) -> ('1',b,a)) (1,2) :: (Char, Int, Int) and all the subexpressions are
  -- typed correctly.
  testInferTT "Tuple and NTupleLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((NTupleLit Nothing (
            Lit Nothing (Name "a") :
            Lit Nothing (Name "b") :
            Nil)) :
          Nil)
        (NTuple Nothing (
          Atom Nothing (Char "1") :
          Atom Nothing (Name "b") :
          Atom Nothing (Name "a") :
          Nil)))
      (NTuple Nothing (
          Atom Nothing (AInt 1) :
          Atom Nothing (AInt 2) :
          Nil) :
        Nil))
    (App
      (Just $ charIntTupleType)
      (Lambda
        (Just $ intTupleType `TypArr` charIntTupleType)
        ((NTupleLit (Just intTupleType) (
            Lit (Just intType) (Name "a") :
            Lit (Just intType) (Name "b") :
            Nil)) :
          Nil)
        (NTuple (Just charIntTupleType) (
          Atom (Just charType) (Char "1") :
          Atom (Just intType) (Name "b") :
          Atom (Just intType) (Name "a") :
          Nil)))
      (NTuple (Just intTupleType) (
          Atom (Just intType) (AInt 1) :
          Atom (Just intType) (AInt 2) :
          Nil) :
        Nil))

  -- Check that x :: t_42 == x :: a.
  testNormalizeTT "Atom"
    (Atom (Just $ TypVar "t_42") (Name "x"))
    (Atom (Just $ TypVar "a") (Name "x"))

  -- Check that an untyped atom stays untyped.
  testNormalizeTT "Untyped atom"
    (Atom Nothing (Name "x"))
    (Atom Nothing (Name "x"))

  -- Check that (\x -> x) :: t_2 -> t_2 == (\x -> x) :: a -> a.
  testNormalizeTT "Identity function"
    (Lambda
      (Just $ typVarArrow "t_2" "t_2")
      ((Lit (Just $ TypVar "t_2") (Name "x")) : Nil)
      (Atom (Just $ TypVar "t_2") (Name "x")))
    (Lambda
      (Just $ typVarArrow "a" "a")
      ((Lit (Just $ TypVar "a") (Name "x")) : Nil)
      (Atom (Just $ TypVar "a") (Name "x")))

  -- Check that (\f x -> f x) :: (t_4 -> t_45) -> t_4 -> t_45
  --         == (\f x -> f x) :: (a -> b) -> a -> b
  testNormalizeTT "Apply function"
    (Lambda
      (Just (typVarArrow "t_4" "t_45" `TypArr` typVarArrow "t_4" "t_45"))
      (
        (Lit (Just (typVarArrow "t_4" "t_45")) (Name "f")) :
        (Lit (Just (TypVar  "t_4")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "t_45"))
        (Atom (Just (typVarArrow "t_4" "t_45")) (Name "f"))
        ((Atom (Just (TypVar  "t_4")) (Name "x")) : Nil)))
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)))

module Test.TypeChecker where

import AST
import TypeChecker (Scheme(Forall), inferGroup, inferType, inferDef, emptyTyenv, runInfer, typeProgramn, eqScheme, normalizeTypeTree, typeTreeProgram)
import Parser (parseExpr, parseDefs)
import Test.Parser (parsedPrelude)

import Prelude (Unit, bind, map, pure, show, unit, ($), (==), (<>), (<<<))
import Control.Monad.Writer (Writer, tell)
import Data.Array (toUnfoldable) as Array
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.List (List(..), (:), singleton)
import Data.Tuple (Tuple(..))
import Text.Parsing.Parser (ParseError, parseErrorMessage)

-- | The result of the type inference procedure.
type InferResult = Either TypeError Scheme

toList :: forall a. Array a -> List a
toList = Array.toUnfoldable

tell' :: forall a. a -> Writer (List a) Unit
tell' = tell <<< singleton

-- | Construct a list of type [typCon] given the name of the type constants.
typConList :: String -> Type
typConList name = AD $ TList (TypCon name)

-- | Construct a tuple type given a list of type constant names.
typConNTuple:: List String -> Type
typConNTuple names = AD $ TTuple (map TypCon names)

-- | Construct a list of type [a] given the type variable name a.
typVarList :: TVar -> Type
typVarList tv = AD $ TList (TypVar tv)

-- | Generate an arrow type from two given type variable names.
typVarArrow :: TVar -> TVar -> Type
typVarArrow tv1 tv2 = TypVar tv1 `TypArr` TypVar tv2

-- | Report a parse error.
reportParseError :: String -> ParseError -> Writer (List String) Unit
reportParseError testName parseError = tell' $ "Parse error for test case "
  <> testName <> ": "
  <> parseErrorMessage parseError
  <> "\nNote that this is not a failing test but rather an error in the test definition."

testInferExpr :: String -> String -> InferResult -> Writer (List String) Unit
testInferExpr name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> compareSchemes name expected $ runInfer $ inferType emptyTyenv expression

testInferDef :: String -> String -> InferResult -> Writer (List String) Unit
testInferDef name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right (definition:_) -> compareSchemes name expected $ runInfer $ inferDef emptyTyenv definition
  _ -> tell' $ "Parse error for test case " <> name <> ": Expected only a single definition case"
    <> "\nNote that this is not a failing test but rather an error in the test definition."

testInferDefs :: String -> String -> InferResult -> Writer (List String) Unit
testInferDefs name definitionString expected = case parseDefs definitionString of
  Left parseError -> reportParseError name parseError
  Right definitions -> compareSchemes name expected $ runInfer $ inferGroup emptyTyenv definitions

testInferExprWithPrelude :: String -> String -> InferResult -> Writer (List String) Unit
testInferExprWithPrelude name expressionString expected = case parseExpr expressionString of
  Left parseError -> reportParseError name parseError
  Right expression -> compareSchemes name expected (typeProgramn parsedPrelude expression)

-- | Test type inference on expression trees. Here not only the expected type of the whole
-- | expression is checked, but also the type of every subexpression.
testInferTT :: String -> TypeTree -> TypeTree -> Writer (List String) Unit
testInferTT name untypedTree expectedTypedTree = case typeTreeProgram parsedPrelude untypedTree of
  Left typeError -> tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                            "Encountered type error: " <> prettyPrintTypeError typeError
  Right typedTree -> if expectedTypedTree == typedTree
    then pure unit
    else tell' $ "Type inference failed in test case `" <> name <> "`:\n" <>
                 "Expected type tree: " <> show expectedTypedTree <> "\n" <>
                 "Actual type tree: " <> show typedTree <> "\n"

-- | Test type tree normalization.
testNormalizeTT :: String -> TypeTree -> TypeTree -> Writer (List String) Unit
testNormalizeTT name tt normalizedTT = if (normalizeTypeTree tt) == normalizedTT
  then pure unit
  else tell' $ "Type tree normalization failed in test case `" <> name <> "`:\n" <>
               "Expected type tree: " <> show normalizedTT <> "\n" <>
               "Actual type tree: " <> show tt <> "\n"

compareSchemes :: String -> InferResult -> InferResult -> Writer (List String) Unit
compareSchemes name expected actual = if eqInferResult expected actual
  then pure unit
  else tell' $ "\n \n Typing fail in test case `" <> name <> "`:"
    <> "\nExpected: " <> show expected <> " - pretty printed: " <> prettyPrint expected
    <> "\nActual: " <> show actual <> " - pretty printed: " <> prettyPrint actual

eqInferResult :: InferResult -> InferResult -> Boolean
eqInferResult (Left a) (Left a') = (a == a')
eqInferResult (Right a) (Right a') = eqScheme a a'
eqInferResult _ _ = false

prettyPrint :: InferResult -> String
prettyPrint error@(Left _) = show error
prettyPrint (Right (Forall xs t)) = show xs <> " " <> prettyPrintType t

-- | Typed type tree representing `[1]`.
listOne :: TypeTree
listOne = List (Just $ typConList "Int") (Atom (Just $ TypCon "Int") (AInt 1) : Nil)

-- | Untyped type tree representing `[1]`.
untypedListOne :: TypeTree
untypedListOne = List Nothing (Atom Nothing (AInt 1) : Nil)

intType :: Type
intType = TypCon "Int"

charType :: Type
charType = TypCon "Char"

runTests :: Writer (List String) Unit
runTests = do
  testInferExpr "SectL" "(3^)" (Right $ Forall Nil $ TypArr (TypCon "Int") (TypCon "Int"))
  testInferExpr "SectR" "(^3)" (Right $ Forall Nil $ TypArr (TypCon "Int") (TypCon "Int"))
  testInferExpr "Lambda1" "\\a b c d -> a b c d"  (Right $ Forall (toList ["b", "c", "d", "e"]) (TypArr (TypArr (TypVar "b") (TypArr (TypVar "c") (TypArr (TypVar "d") (TypVar "e")))) (TypArr ( TypVar "b")  ((TypArr (TypVar "c") (TypArr (TypVar "d") (TypVar "e")))))))
  testInferExpr "Lambda2" "\\a b -> a b" (Right $ Forall ("t_3" : "t_4" : Nil) (TypArr (TypArr (TypVar "t_3") (TypVar "t_4")) (TypArr (TypVar "t_3") (TypVar "t_4"))))
  testInferExpr "List1" "[1, 2, 3, 4, 5]" (Right $ Forall (Nil) (AD (TList (TypCon "Int"))))
  testInferExpr "List2" "[1 + 2, 3 + 4]" (Right $ Forall (Nil) (AD (TList (TypCon "Int"))))
  testInferExpr "List3" "[(+), 4]" (Left ((UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))))
  testInferExpr "Empty list" "[]" (Right (Forall ("t_0" : Nil) (AD (TList (TypVar "t_0")))))
  testInferExpr "Append" "[1 + 2, 3 + 4] ++ []" (Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInferExpr "Colon" "3 : [1 + 2, 3 + 4, \"Hallo\"]" (Left ((UnificationFail (AD $ TList $ TypCon "Char") (TypCon "Int"))))
  testInferExpr "NTuple" "(1 + 2, 3)" (Right (Forall (Nil) (AD (TTuple (Cons ((TypCon "Int")) (Cons ((TypCon "Int")) (Nil)))))))
  testInferExpr "SectR colon" "(:[3])" (Right (Forall (Nil) (TypArr (TypCon "Int") (AD (TList (TypCon "Int"))))))
  testInferExpr "Lambda wildcard" "\\_ _ -> 5" (Right (Forall ("t_1" : "t_3" : Nil) (TypArr (TypVar "t_1") (TypArr (TypVar "t_3") (TypCon "Int")))))
  testInferExpr "Lambda cons binding" "\\(x:xs) -> x" (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInferExpr "Let expression" "let x = 3 in \\_ _ -> x" (Right (Forall ("t_2" : "t_4" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypCon "Int")))))
  testInferExpr "Binding tuple in let expression" "let (a, b) = (\\f -> f, \"Hello\") in a b" (Right (Forall (Nil) (AD $ TList $ TypCon "Char")))
  testInferExpr "Lambda application" "(\\f a b -> f a b) (+) 3 4" (Right (Forall (Nil) (TypCon "Int")))
  -- ((\xs -> [ x | x <- xs ]) [1]) :: [Int]
  testInferExpr "List comprehension inside lambda" "(\\xs -> [ x | x <- xs ]) [1]" (Right (Forall (Nil) (AD $ TList $ TypCon "Int")))

  testInferDef "Define app" "app f xs = app f xs" (Right (Forall ("t_2" : "t_4" : "t_5" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypVar "t_5")))))
  testInferDef "Define single map" "map f (x:xs) = f x : map f xs" (Right (Forall ("t_11" : "t_5" : Nil) (TypArr (TypArr (TypVar "t_5") (TypVar "t_11")) (TypArr (AD (TList (TypVar "t_5"))) (AD (TList (TypVar "t_11")))))))
  testInferDef "Define foldr" "foldr f ini (x:xs) = f x (foldr f ini xs)" (Right (Forall ("t_5" : "t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_5") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4"))))))
  testInferDef "Conslit binding 1" "list (x:xs:xss) = x" (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInferDef "Conslit binding 2" "list (x:xs:xss) = xs" (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInferDef "Conslit binding 3" "list (x:xs:xss) = xss" (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (AD (TList (TypVar "t_2"))))))
  testInferDef "Binding tuple 1" "fst (a, b) = a" (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple $ Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil)))) (TypVar "t_2"))))
  testInferDef "Binding tuple 2" "snd (a, b) = b" (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple (Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil))))) (TypVar "t_3"))))
  testInferDef "Binding tuple 3" "f (a, b, c) = a b c" (Right (Forall ("t_3" : "t_4" : "t_5" : Nil) (TypArr (AD (TTuple (Cons ((TypArr (TypVar "t_3") (TypArr (TypVar "t_4") (TypVar "t_5")))) (Cons ((TypVar "t_3")) (Cons ((TypVar "t_4")) (Nil)))))) (TypVar "t_5"))))
  testInferDef "Listlit binding" "list [a, b, c] = a b c" (Left ((InfiniteType "a" (TypArr (TypVar "a") (TypVar "b")))))

  testInferDefs "zipWith"
    ("zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys\n" <>
     "zipWith _ [] _ = []\n" <>
     "zipWith _ _ [] = []")
    (Right (Forall ("t_23" : "t_33" : "t_34" : Nil) (TypArr (TypArr (TypVar "t_23") (TypArr (TypVar "t_33") (TypVar "t_34"))) (TypArr (AD (TList (TypVar "t_23"))) (TypArr (AD (TList (TypVar "t_33"))) (AD (TList (TypVar "t_34"))))))))

  testInferDefs "foldr"
    ("foldr f ini [] = ini\n" <>
     "foldr f ini (x:xs) = f x (foldr f ini xs)")
    (Right (Forall ("t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_4") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4"))))))

  testInferDefs "scanl"
    ("scanl f b []     = [b]\n" <>
     "scanl f b (x:xs) = b : scanl f (f b x) xs")
    (Right (Forall ("t_39" : "t_48" : Nil) (TypArr (TypArr (TypVar "t_48") (TypArr (TypVar "t_39") (TypVar "t_48"))) (TypArr (TypVar "t_48") (TypArr (AD (TList (TypVar "t_39"))) (AD (TList (TypVar "t_48"))))))))

  testInferExprWithPrelude "Prelude with exp" "sum (map (^2) [1, 2, 3, 4])" (Right (Forall (Nil) (TypCon "Int")))

  -- Check that \f x -> f x and all the subexpressions are typed correctly.
  testInferTT "Apply function"
    (Lambda Nothing
      ((Lit Nothing (Name "f")) : (Lit Nothing (Name "x")) : Nil)
      (App
        Nothing
        (Atom Nothing (Name "f"))
        ((Atom Nothing (Name "x")) : Nil)))
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)))

  -- Check that [1, 1 + 1, length [1]] and all the subexpressions are typed correctly.
  testInferTT "List"
    (List
      Nothing
      (
        (Atom Nothing (AInt 1)) :
        (Binary
          Nothing
          (Tuple Add Nothing)
          (Atom Nothing (AInt 1))
          (Atom Nothing (AInt 1))) :
        (App
          Nothing
          (Atom
            Nothing
            (Name "length"))
          (untypedListOne : Nil)) :
        Nil
      )
    )
    (List
      (Just (typConList "Int"))
      (
        (Atom (Just (TypCon "Int")) (AInt 1)) :
        (Binary
          (Just (TypCon "Int"))
          (Tuple Add (Just (TypCon "Int" `TypArr` (TypCon "Int" `TypArr` TypCon "Int"))))
          (Atom (Just (TypCon "Int")) (AInt 1))
          (Atom (Just (TypCon "Int")) (AInt 1))) :
        (App
          (Just (TypCon "Int"))
          (Atom
            (Just (typConList "Int" `TypArr` TypCon "Int"))
            (Name "length"))
          (listOne : Nil)) :
        Nil
      )
    )

  -- Check that (\(x:xs) -> x) [1] and all the subexpressions are typed correctly.
  testInferTT "ConsLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((ConsLit
          Nothing
          (Lit Nothing (Name "x"))
          (Lit Nothing (Name "xs"))) : Nil)
        (Atom Nothing (Name "x")))
      (untypedListOne : Nil))
    (App
      (Just $ TypCon "Int")
      (Lambda
        (Just $ typConList "Int" `TypArr` TypCon "Int")
        ((ConsLit
          (Just $ typConList "Int")
          (Lit (Just $ TypCon "Int") (Name "x"))
          (Lit (Just $ typConList "Int") (Name "xs"))) : Nil)
        (Atom (Just $ TypCon "Int") (Name "x")))
      (listOne : Nil))

  -- Check that let x = [1] in [x] :: [[Int]] and all the subexpressions are typed correctly.
  testInferTT "Let"
    (LetExpr
      Nothing
      (Tuple (Lit Nothing (Name "x")) untypedListOne : Nil)
      (List Nothing (Atom Nothing (Name "x") : Nil)))
    (LetExpr
      (Just $ AD $ TList $ typConList "Int")
      (Tuple (Lit (Just $ typConList "Int") (Name "x")) listOne : Nil)
      (List
        (Just $ AD $ TList $ typConList "Int")
        (Atom (Just $ typConList "Int") (Name "x") : Nil)))

-- lit "a"
-- intLit "a"

  -- The type (Char, Int, Int)
  let charIntTupleType = typConNTuple ("Char" : "Int" : "Int" : Nil)
  -- The type (Int, Int)
  let intTupleType = typConNTuple ("Int" : "Int" : Nil)

  -- Check that (\(a,b) -> ('1',b,a)) (1,2) :: (Char, Int, Int) and all the subexpressions are
  -- typed correctly.
  testInferTT "Tuple and NTupleLit"
    (App
      Nothing
      (Lambda
        Nothing
        ((NTupleLit Nothing (
            Lit Nothing (Name "a") :
            Lit Nothing (Name "b") :
            Nil)) :
          Nil)
        (NTuple Nothing (
          Atom Nothing (Char "1") :
          Atom Nothing (Name "b") :
          Atom Nothing (Name "a") :
          Nil)))
      (NTuple Nothing (
          Atom Nothing (AInt 1) :
          Atom Nothing (AInt 2) :
          Nil) :
        Nil))
    (App
      (Just $ charIntTupleType)
      (Lambda
        (Just $ intTupleType `TypArr` charIntTupleType)
        ((NTupleLit (Just intTupleType) (
            Lit (Just intType) (Name "a") :
            Lit (Just intType) (Name "b") :
            Nil)) :
          Nil)
        (NTuple (Just charIntTupleType) (
          Atom (Just charType) (Char "1") :
          Atom (Just intType) (Name "b") :
          Atom (Just intType) (Name "a") :
          Nil)))
      (NTuple (Just intTupleType) (
          Atom (Just intType) (AInt 1) :
          Atom (Just intType) (AInt 2) :
          Nil) :
        Nil))

  -- Check that x :: t_42 == x :: a.
  testNormalizeTT "Atom"
    (Atom (Just $ TypVar "t_42") (Name "x"))
    (Atom (Just $ TypVar "a") (Name "x"))

  -- Check that an untyped atom stays untyped.
  testNormalizeTT "Untyped atom"
    (Atom Nothing (Name "x"))
    (Atom Nothing (Name "x"))

  -- Check that (\x -> x) :: t_2 -> t_2 == (\x -> x) :: a -> a.
  testNormalizeTT "Identity function"
    (Lambda
      (Just $ typVarArrow "t_2" "t_2")
      ((Lit (Just $ TypVar "t_2") (Name "x")) : Nil)
      (Atom (Just $ TypVar "t_2") (Name "x")))
    (Lambda
      (Just $ typVarArrow "a" "a")
      ((Lit (Just $ TypVar "a") (Name "x")) : Nil)
      (Atom (Just $ TypVar "a") (Name "x")))

  -- Check that (\f x -> f x) :: (t_4 -> t_45) -> t_4 -> t_45
  --         == (\f x -> f x) :: (a -> b) -> a -> b
  testNormalizeTT "Apply function"
    (Lambda
      (Just (typVarArrow "t_4" "t_45" `TypArr` typVarArrow "t_4" "t_45"))
      (
        (Lit (Just (typVarArrow "t_4" "t_45")) (Name "f")) :
        (Lit (Just (TypVar  "t_4")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "t_45"))
        (Atom (Just (typVarArrow "t_4" "t_45")) (Name "f"))
        ((Atom (Just (TypVar  "t_4")) (Name "x")) : Nil)))
    (Lambda
      (Just (typVarArrow "a" "b" `TypArr` typVarArrow "a" "b"))
      (
        (Lit (Just (typVarArrow "a" "b")) (Name "f")) :
        (Lit (Just (TypVar  "a")) (Name "x")) :
        Nil
      )
      (App
        (Just (TypVar  "b"))
        (Atom (Just (typVarArrow "a" "b")) (Name "f"))
        ((Atom (Just (TypVar  "a")) (Name "x")) : Nil)))


Fixed that pressing a really gets you to the game

module Main where

import Data.Char
import Data.String
import Data.Maybe
import Data.Tuple
import Data.Array (map, updateAt)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

data GameState = Game { level :: Level, player :: Creature, npcs :: [Creature] }
               | MainMenu
               | CharCreation

initialState :: GameState
initialState = Game { level: stringToLevel testLevel, player: pl, npcs: [testGuard] }
    where
        pl :: Creature
        pl = { pos: {x: 3, y: 3}, ctype: Player, stats: defaultStats }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt st = do
    drawGame console st
    return st

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console st@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    drawCreature state.player
    return st
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

        drawCreatureType :: Point -> CreatureType -> ConsoleEff Unit
        drawCreatureType p Player  = drawChar console "@" "FF0000" p.x p.y
        drawCreatureType p Guard   = drawChar console "G" "0000FF" p.x p.y
        drawCreatureType p Archer  = drawChar console "A" "00FF00" p.x p.y
        drawCreatureType p Peasant = drawChar console "P" "AAAAFF" p.x p.y
        drawCreatureType p _       = drawChar console "?" "FFFFFF" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console "#" "331A00" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "331A00" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press space to start" "AAAAAA" 6 12
    return MainMenu
drawGame console CharCreation = do
    clear console
    drawString console "Character Creation:" "FF0000" 2 2

    drawString console "This is a testline, press a to enter game." "FF0000" 2 20

    drawString console "a) Archer      ( +2 dex | +1 str | +2 SP ) (SP = skill point)" "336600" 3 4
    drawString console "b) Knight      ( +4 str | -1 dex | +2 SP )" "B8B8B8" 3 5
    drawString console "c) Monk        ( +2 int | +1 dex | +2 SP )" "E6AC00" 3 6
    drawString console "d) Ninja       ( +4 dex | -1 str | +2 SP )" "5C5C5C" 3 7
    drawString console "e) Peasant     ( -1 all |        | +1 SP )" "00B36B" 3 8
    drawString console "f) Rogue       ( +1 dex | +1 int | +5 SP )" "5C5C5C" 3 9
    drawString console "g) Scholar     ( +3 int | -1 str | +5 SP )" "3D00CC" 3 10
    drawString console "h) Skillmaster ( +1 int |        | +8 SP )" "00B336" 3 11
    drawString console "i) Soldier     ( +2 str | +1 dex | +2 SP )" "9E9E9E" 3 12

    --drawString console "Prefix:" "FF0000" 30 2
    --drawString console "A) Strong (+1 str)" "FF0000" 30 4
    --drawString console "B) Weak   (-1 str)" "FF0000" 30 5
    --drawString console "C) Agile  (+1 dex)" "FF0000" 30 6
    --drawString console "D) Clumsy (-1 dex)" "FF0000" 30 7
    --drawString console "E) Wise   (+1 int)" "FF0000" 30 8
    --drawString console "F) Dumb   (-1 int)" "FF0000" 30 9
    return CharCreation

updateCreatures :: GameState -> GameState
updateCreatures st@(Game state') = foldl updateCreature st (enumerate state'.npcs)
    where
        -- updateCreature is not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.
        updateCreature :: GameState -> Tuple Number Creature -> GameState
        updateCreature (Game state) (Tuple i c) = Game $ state { npcs = updateAt i (c { pos = {x: c.pos.x, y: c.pos.y + 1 }}) state.npcs }

updateWorld :: GameState -> GameState
updateWorld = updateCreatures

isValidMove :: Level -> Point -> Boolean
isValidMove level = isTileSolid <<< fromMaybe Air <<< getTile level

movePlayer :: Tuple Number Number -> GameState -> GameState
movePlayer (Tuple dx dy) (Game state) | (isValidMove (state.level) ({ x: state.player.pos.x + dx, y: state.player.pos.y + dy })) == true = Game state
movePlayer (Tuple dx dy) (Game state) | otherwise = updateWorld $ Game $ state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
    where
        clamp x min max | x < min = min
        clamp x min max | x > max = max
        clamp x min max = x

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

movementkeys :: M.Map Number (Tuple Number Number)
movementkeys = M.fromList [numpad 8 // ( 0 // -1)
                          ,numpad 2 // ( 0 //  1)
                          ,numpad 4 // (-1 //  0)
                          ,numpad 6 // ( 1 //  0)]

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console st@(Game state) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta st
        Nothing    -> return st
onKeyPress console MainMenu key     | key == 32 = return CharCreation
onKeyPress console CharCreation key | key == 65 = return initialState
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}

module Main where

import Data.Char
import Data.String
import Data.Maybe
import Data.Tuple
import Data.Array (map, updateAt)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

data GameState = Game { level :: Level, player :: Creature, npcs :: [Creature] }
               | MainMenu
               | CharCreation

initialState :: GameState
initialState = Game { level: stringToLevel testLevel, player: pl, npcs: [testGuard] }
    where
        pl :: Creature
        pl = { pos: {x: 3, y: 3}, ctype: Player, stats: defaultStats }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt st = do
    drawGame console st
    return st

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console st@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    drawCreature state.player
    return st
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

        drawCreatureType :: Point -> CreatureType -> ConsoleEff Unit
        drawCreatureType p Player  = drawChar console "@" "FF0000" p.x p.y
        drawCreatureType p Guard   = drawChar console "G" "0000FF" p.x p.y
        drawCreatureType p Archer  = drawChar console "A" "00FF00" p.x p.y
        drawCreatureType p Peasant = drawChar console "P" "AAAAFF" p.x p.y
        drawCreatureType p _       = drawChar console "?" "FFFFFF" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console "#" "331A00" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "331A00" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press space to start" "AAAAAA" 6 12
    return MainMenu
drawGame console CharCreation = do
    clear console
    drawString console "Character Creation:" "FF0000" 2 2

    drawString console "This is a testline, press a to enter game." "FF0000" 2 20

    drawString console "a) Archer      ( +2 dex | +1 str | +2 SP ) (SP = skill point)" "336600" 3 4
    drawString console "b) Knight      ( +4 str | -1 dex | +2 SP )" "B8B8B8" 3 5
    drawString console "c) Monk        ( +2 int | +1 dex | +2 SP )" "E6AC00" 3 6
    drawString console "d) Ninja       ( +4 dex | -1 str | +2 SP )" "5C5C5C" 3 7
    drawString console "e) Peasant     ( -1 all |        | +1 SP )" "00B36B" 3 8
    drawString console "f) Rogue       ( +1 dex | +1 int | +5 SP )" "5C5C5C" 3 9
    drawString console "g) Scholar     ( +3 int | -1 str | +5 SP )" "3D00CC" 3 10
    drawString console "h) Skillmaster ( +1 int |        | +8 SP )" "00B336" 3 11
    drawString console "i) Soldier     ( +2 str | +1 dex | +2 SP )" "9E9E9E" 3 12

    --drawString console "Prefix:" "FF0000" 30 2
    --drawString console "A) Strong (+1 str)" "FF0000" 30 4
    --drawString console "B) Weak   (-1 str)" "FF0000" 30 5
    --drawString console "C) Agile  (+1 dex)" "FF0000" 30 6
    --drawString console "D) Clumsy (-1 dex)" "FF0000" 30 7
    --drawString console "E) Wise   (+1 int)" "FF0000" 30 8
    --drawString console "F) Dumb   (-1 int)" "FF0000" 30 9
    return CharCreation

updateCreatures :: GameState -> GameState
updateCreatures st@(Game state') = foldl updateCreature st (enumerate state'.npcs)
    where
        -- updateCreature is not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.
        updateCreature :: GameState -> Tuple Number Creature -> GameState
        updateCreature (Game state) (Tuple i c) = Game $ state { npcs = updateAt i (c { pos = {x: c.pos.x, y: c.pos.y + 1 }}) state.npcs }

updateWorld :: GameState -> GameState
updateWorld = updateCreatures

isValidMove :: Level -> Point -> Boolean
isValidMove level = isTileSolid <<< fromMaybe Air <<< getTile level

movePlayer :: Tuple Number Number -> GameState -> GameState
movePlayer (Tuple dx dy) (Game state) | (isValidMove (state.level) ({ x: state.player.pos.x + dx, y: state.player.pos.y + dy })) == true = Game state
movePlayer (Tuple dx dy) (Game state) | otherwise = updateWorld $ Game $ state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
    where
        clamp x min max | x < min = min
        clamp x min max | x > max = max
        clamp x min max = x

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

movementkeys :: M.Map Number (Tuple Number Number)
movementkeys = M.fromList [numpad 8 // ( 0 // -1)
                          ,numpad 2 // ( 0 //  1)
                          ,numpad 4 // (-1 //  0)
                          ,numpad 6 // ( 1 //  0)]

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console st@(Game state) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta st
        Nothing    -> return st
onKeyPress console MainMenu key     | key == 32 = return CharCreation
onKeyPress console CharCreation key | key == 97 = return initialState
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}