Remove underscore from Java fields. Fixes #123

Original commit a3929268a2df797d1ea29a4544341a0bc05816a6

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

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

renderer :: Renderer
renderer =
    { name: "Java"
    , aceMode: "java"
    , extension: "java"
    , doc: javaDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        , topLevelName: noForbidNamer javaNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (javaNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated javaNameStyle "Or")
            }
        }
    }

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

javaNameStyle :: String -> String
javaNameStyle =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter true
    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) ("Other" <> _) ["Class"] 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) { " <> 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 javaName = lookupName pname propertyNames
                let fieldName = fieldNameForJavaName javaName
                rendered <- renderType false ptype
                f pname javaName fieldName rendered

        fieldNameForJavaName :: String -> String
        fieldNameForJavaName = decapitalize >>> ("_" <> _)

renderUnionField :: IRType -> Doc { renderedType :: String, fieldName :: String }
renderUnionField t = do
    renderedType <- renderType true t
    fieldName <- decapitalize <$> javaNameStyle <$> (_ <> "_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 "}"


redo cost model

redo cost model

we are merging costs of individual ships too early

module KanColle.Expedition.New.CostModel where

import Prelude
import KanColle.Expedition.New.SType
import Data.Maybe
import Control.MonadPlus
import Data.Unfoldable

data MaxCost = MC
  { fuel :: Int
  , ammo :: Int
  }

mkMC :: Int -> Int -> MaxCost
mkMC fuel ammo = MC {fuel: fuel, ammo: ammo}

-- | `CostModel` calculates the total maximum cost
-- | given a ship type and how many ships are present.
-- | This cost model is designed for just one fleet so
-- | the input number should only be one of `[0,1,2,3,4,5,6]`.
-- | Note that for a cost model `f`, it's not guaranteed
-- | that `f stype a + f stype b` and `f stype (a+b)` give
-- | the same answer.
type CostModel = SType -> Int -> Maybe (Array MaxCost)

-- | a normal cost model assumes all ships are remodelled to
-- | their final forms. (the exceptions are like Taigei, Chitose-A and Chiyoda-A
-- | as their further remodels also change ship type.)
normalCostModel :: CostModel
normalCostModel stype = case stype of
    DD -> ddCost
    CL -> clCost
    CVLike -> cvlLikeCost
    SSLike -> ssLikeCost
    CA -> caCost
    BBV -> bbvCost
    AS -> asCost
    CT -> ctCost
    AV -> avCost
  where
    ddCost n =
      -- use Mutsuki class destroyers
      Just (replicate n (mkMC 15 15))
    clCost n
      | n <= 2 =
        -- use 2 Tenryuu class ships,
        Just (replicate n (mkMC 25 25))
      | n <= 6 = do
        -- if we need more, fill the rest with some Nagara class ships
        c <- clCost 2
        Just (c <> replicate (n-2) (mkMC 25 30))
      | otherwise = Nothing
    avCost n
      | n <= 2 =
        -- Chitose-A and Chiyoda-A
        Just (replicate n (mkMC 35 45))
      | n <= 3 = do
        -- and Mizuho Kai
        c <- avCost 2
        Just (c <> [mkMC 40 45])
      | n <= 4 = do
        -- and Akitsushima Kai
        c <- avCost 3
        Just (c <> [mkMC 60 15])
      | otherwise = Nothing
    -- Taigei
    asCost n = do
        guard (n <= 1)
        Just (replicate n (mkMC 35 10))
    -- Katori class
    ctCost n = do
        guard (n <= 2)
        Just (replicate n (mkMC 35 20))
    caCost n
      | n <= 1 =
        -- Aoba Kai
        Just (replicate n (mkMC 35 55))
      | n <= 4 = do
        -- Furutaka Kai Ni, Kako Kai Ni, Kinugasa Kai Ni
        c <- caCost 1
        Just (c <> replicate (n-1) (mkMC 35 65))
      | n <= 6 = do
        -- Takao Kai, Atago Kai
        c <- caCost 4
        Just (c <> replicate (n-4) (mkMC 40 70))
      | otherwise = Nothing
    bbvCost n
      | n <= 2 =
        -- Ise class
        Just (replicate n (mkMC 95 105))
      | n <= 4 = do
        -- Fusou class
        c <- bbvCost 2
        Just (c <> replicate (n-2) (mkMC 105 140))
      | otherwise = Nothing
    ssLikeCost n
      | n <= 1 =
        -- Maruyu Kai
        Just (replicate n (mkMC 10 10))
      | n <= 6 = do
        -- no need for SSV if we just consider:
        -- I-168, I-58, I-19, I-8 and Ro-500
        c <- ssLikeCost 1
        Just (replicate (n-1) (mkMC 10 20))
      | otherwise = Nothing
    cvlLikeCost n
      | n <= 1 =
        -- Houshou Kai
        Just (replicate n (mkMC 30 30))
      | n <= 2 = do
        -- Ryuuhou Kai
        c <- cvlLikeCost 1
        Just (c <> replicate (n-1) (mkMC 35 40))
      | n <= 4 = do
        -- Chitose-A, Chiyoda-A
        c <- cvlLikeCost 2
        Just (c <> replicate (n-2) (mkMC 35 45))
      | n <= 6 = do
        -- Shouhou Kai, Zuihou Kai
        c <- cvlLikeCost 4
        Just (c <> replicate (n-4) (mkMC 40 40))
      | otherwise = Nothing

module KanColle.Expedition.New.CostModel where

import Prelude
import KanColle.Expedition.New.SType
import Data.Maybe
import Control.MonadPlus

data MaxCost = MC
  { fuel :: Int
  , ammo :: Int
  }

instance semigroupMaxCost :: Semigroup MaxCost where
  append (MC a) (MC b) = MC {fuel: a.fuel, ammo: b.fuel}

mkMC :: Int -> Int -> MaxCost
mkMC fuel ammo = MC {fuel: fuel, ammo: ammo}

-- | multiple `MaxCost` with an integer
mcTimes :: MaxCost -> Int -> MaxCost
mcTimes _ 0 = mkMC 0 0
mcTimes (MC a) n = mkMC (a.fuel*n) (a.ammo*n)

-- | `CostModel` calculates the total maximum cost
-- | given a ship type and how many ships are present.
-- | This cost model is designed for just one fleet so
-- | the input number should only be one of `[0,1,2,3,4,5,6]`.
-- | Note that for a cost model `f`, it's not guaranteed
-- | that `f stype a + f stype b` and `f stype (a+b)` give
-- | the same answer.
type CostModel = SType -> Int -> Maybe MaxCost

-- | a normal cost model assumes all ships are remodelled to
-- | their final forms. (the exceptions are like Taigei, Chitose-A and Chiyoda-A
-- | as their further remodels also change ship type.)
normalCostModel :: CostModel
normalCostModel stype = case stype of
    DD -> ddCost
    CL -> clCost
    CVLike -> cvlLikeCost
    SSLike -> ssLikeCost
    CA -> caCost
    BBV -> bbvCost
    AS -> asCost
    CT -> ctCost
    AV -> avCost
  where
    ddCost n =
      -- use Mutsuki class destroyers
      Just (mcTimes (mkMC 15 15) n)
    clCost n
      | n <= 2 =
        -- use 2 Tenryuu class ships,
        Just (mcTimes (mkMC 25 25) n)
      | n <= 6 = do
        -- if we need more, fill the rest with some Nagara class ships
        c <- clCost 2
        Just (c <> mcTimes (mkMC 25 30) (n-2))
      | otherwise = Nothing
    avCost n
      | n <= 2 =
        -- Chitose-A and Chiyoda-A
        Just (mcTimes (mkMC 35 45) n)
      | n <= 3 = do
        -- and Mizuho Kai
        c <- avCost 2
        Just (c <> mkMC 40 45)
      | n <= 4 = do
        -- and Akitsushima Kai
        c <- avCost 3
        Just (c <> mkMC 60 15)
      | otherwise = Nothing
    -- Taigei
    asCost n = do
        guard (n <= 1)
        Just (mcTimes (mkMC 35 10) n)
    -- Katori class
    ctCost n = do
        guard (n <= 2)
        Just (mcTimes (mkMC 35 20) n)
    caCost n
      | n <= 1 =
        -- Aoba Kai
        Just (mcTimes (mkMC 35 55) n)
      | n <= 4 = do
        -- Furutaka Kai Ni, Kako Kai Ni, Kinugasa Kai Ni
        c <- caCost 1
        Just (c <> mcTimes (mkMC 35 65) (n-1))
      | n <= 6 = do
        -- Takao Kai, Atago Kai
        c <- caCost 4
        Just (c <> mcTimes (mkMC 40 70) (n-4))
      | otherwise = Nothing
    bbvCost n
      | n <= 2 =
        -- Ise class
        Just (mcTimes (mkMC 95 105) n)
      | n <= 4 = do
        -- Fusou class
        c <- bbvCost 2
        Just (c <> mcTimes (mkMC 105 140) (n-2))
      | otherwise = Nothing
    ssLikeCost n
      | n <= 1 =
        -- Maruyu Kai
        Just (mcTimes (mkMC 10 10) n)
      | n <= 6 = do
        -- no need for SSV if we just consider:
        -- I-168, I-58, I-19, I-8 and Ro-500
        c <- ssLikeCost 1
        Just (mcTimes (mkMC 10 20) (n-1))
      | otherwise = Nothing
    cvlLikeCost n
      | n <= 1 =
        -- Houshou Kai
        Just (mcTimes (mkMC 30 30) n)
      | n <= 2 = do
        -- Ryuuhou Kai
        c <- cvlLikeCost 1
        Just (c <> mcTimes (mkMC 35 40) (n-1))
      | n <= 4 = do
        -- Chitose-A, Chiyoda-A
        c <- cvlLikeCost 2
        Just (c <> mcTimes (mkMC 35 45) (n-2))
      | n <= 6 = do
        -- Shouhou Kai, Zuihou Kai
        c <- cvlLikeCost 4
        Just (c <> mcTimes (mkMC 40 40) (n-4))
      | otherwise = Nothing


Write and apply `dedent` function

Write and apply `dedent` function

o Remove common leading whitespace
o Does NOT handle edge cases such as mixed tabs & spaces or carriage
  return.
    o Enforce spaces over tabs
    o Does NOT handle windows line endings `\r\n`

module Docopt.Parser.Scanner where

import Prelude
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.List (List(..), many, toList, fromList, (:), length, filter
                 , takeWhile, sort, head)
import qualified Data.Array as A
import Data.String (toCharArray, fromCharArray)
import qualified Data.String as Str
import Data.Maybe
import Data.Either
import Docopt.Parser.Base
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Usage as Usage

data Section
  = Preamble String
  | Usage String
  | Options String

unSection :: Section -> String
unSection (Preamble s) = s
unSection (Usage    s) = s
unSection (Options  s) = s

data Docopt = Docopt String (List String)

instance showDocopt :: Show Docopt where
  show (Docopt x xs) = "Docopt " ++ show x ++ show xs

instance showSection :: Show Section where
  show (Preamble x) = "Preamble: " ++ show x
  show (Usage    x) = "Usage: "    ++ show x
  show (Options  x) = "Options: "  ++ show x

-- | Pre-parse the docopt string and break it into sections.
scanDocopt :: String -> Either P.ParseError Docopt
scanDocopt = (flip P.runParser docoptScanner) <<< dedent

dedent :: String -> String
dedent txt =
  let lines :: Array String
      lines = Str.split "\n" txt
      nonEmpty :: String -> Boolean
      nonEmpty = (/= 0) <<< Str.length <<< Str.trim
      shortestLeading :: Int
      shortestLeading = maybe 0 id (A.head $ A.sort $ countLeading
                               <$> (A.filter nonEmpty lines))
      isWhitespace :: Char -> Boolean
      isWhitespace ' '  = true
      isWhitespace '\n' = true
      isWhitespace '\t' = true
      isWhitespace _    = false
      countLeading :: String -> Int
      countLeading line = A.length $ A.takeWhile isWhitespace (toCharArray line)
   in Str.joinWith "\n" ((Str.drop shortestLeading) <$> lines)

docoptScanner :: P.Parser String Docopt
docoptScanner = do

  P.manyTill P.anyChar ((void $ P.lookAhead anySectionHeader) <|> P.eof)
  sections <- many parseSection
  usage <- case findUsages sections of
    Nil        -> P.fail "No usage section found!"
    Cons x Nil -> pure x
    _          -> P.fail "More than one usage section found!"

  return $ Docopt
    (unSection usage)
    (map unSection $ findOptions sections)

  where
    findUsages           = filter isUsage
    isUsage (Usage _)    = true
    isUsage _            = false
    findOptions          = filter isOption
    isOption (Options _) = true
    isOption _           = false

    anySectionHeader :: P.Parser String String
    anySectionHeader = usageSectionHeader <|> optionsSectionHeader

    usageSectionHeader :: P.Parser String String
    usageSectionHeader = sectionHeader "usage"

    optionsSectionHeader :: P.Parser String String
    optionsSectionHeader = sectionHeader "options"

    sectionHeader :: String -> P.Parser String String
    sectionHeader s = (do
      col <- getCol
      guard (col == 1)
      string' s <* (P.try $ P.char ':')
      ) P.<?> "section header"

    emptyLine :: P.Parser String Unit
    emptyLine = (do
      col <- getCol
      guard (col == 1)
      many space *> eol
      ) P.<?> "empty line"

    extractSectionSource :: P.Parser String String
    extractSectionSource = do
      many space *> eol
      many $ P.try emptyLine

      -- The section block extends until the first empty line is
      -- encountered OR until a new section is found OR the EOF
      -- is encountered.

      source <- fromCharArray <<< fromList <$> (P.manyTill
        P.anyChar
        (P.try $ P.lookAhead do
              emptyLine
          <|> void anySectionHeader
          <|> P.eof)) P.<?> "Section source"

      P.eof <|> (void $ P.try $ do
        emptyLine
        P.manyTill P.anyChar $ P.try do
          P.eof <|> (void $ P.lookAhead anySectionHeader))

      pure source

    parseSection :: P.Parser String Section
    parseSection = P.choice
      [ Usage   <$> (usageSectionHeader   *> extractSectionSource)
      , Options <$> (optionsSectionHeader *> extractSectionSource)
      ] P.<?> "Usage or Options section"

module Docopt.Parser.Scanner where

import Prelude
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.List (List(..), many, toList, fromList, (:), length, filter)
import qualified Data.Array as A
import Data.String (toCharArray, fromCharArray)
import qualified Data.String as Str
import Data.Either
import Docopt.Parser.Base
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Usage as Usage

data Section
  = Preamble String
  | Usage String
  | Options String

unSection :: Section -> String
unSection (Preamble s) = s
unSection (Usage    s) = s
unSection (Options  s) = s

data Docopt = Docopt String (List String)

instance showDocopt :: Show Docopt where
  show (Docopt x xs) = "Docopt " ++ show x ++ show xs

instance showSection :: Show Section where
  show (Preamble x) = "Preamble: " ++ show x
  show (Usage    x) = "Usage: "    ++ show x
  show (Options  x) = "Options: "  ++ show x

-- | Pre-parse the docopt string and break it into sections.
scanDocopt :: String -> Either P.ParseError Docopt
scanDocopt = flip P.runParser docoptScanner

docoptScanner :: P.Parser String Docopt
docoptScanner = do

  P.manyTill P.anyChar ((void $ P.lookAhead anySectionHeader) <|> P.eof)
  sections <- many parseSection
  usage <- case findUsages sections of
    Nil        -> P.fail "No usage section found!"
    Cons x Nil -> pure x
    _          -> P.fail "More than one usage section found!"

  return $ Docopt
    (unSection usage)
    (map unSection $ findOptions sections)

  where
    findUsages           = filter isUsage
    isUsage (Usage _)    = true
    isUsage _            = false
    findOptions          = filter isOption
    isOption (Options _) = true
    isOption _           = false

    anySectionHeader :: P.Parser String String
    anySectionHeader = usageSectionHeader <|> optionsSectionHeader

    usageSectionHeader :: P.Parser String String
    usageSectionHeader = sectionHeader "usage"

    optionsSectionHeader :: P.Parser String String
    optionsSectionHeader = sectionHeader "options"

    sectionHeader :: String -> P.Parser String String
    sectionHeader s = (do
      col <- getCol
      guard (col == 1)
      string' s <* (P.try $ P.char ':')
      ) P.<?> "section header"

    emptyLine :: P.Parser String Unit
    emptyLine = (do
      col <- getCol
      guard (col == 1)
      many space *> eol
      ) P.<?> "empty line"

    extractSectionSource :: P.Parser String String
    extractSectionSource = do
      many space *> eol
      many $ P.try emptyLine

      -- The section block extends until the first empty line is
      -- encountered OR until a new section is found OR the EOF
      -- is encountered.

      source <- fromCharArray <<< fromList <$> (P.manyTill
        P.anyChar
        (P.try $ P.lookAhead do
              emptyLine
          <|> void anySectionHeader
          <|> P.eof)) P.<?> "Section source"

      P.eof <|> (void $ P.try $ do
        emptyLine
        P.manyTill P.anyChar $ P.try do
          P.eof <|> (void $ P.lookAhead anySectionHeader))

      pure source

    parseSection :: P.Parser String Section
    parseSection = P.choice
      [ Usage   <$> (usageSectionHeader   *> extractSectionSource)
      , Options <$> (optionsSectionHeader *> extractSectionSource)
      ] P.<?> "Usage or Options section"


changed default names

changed default names

module Config where

uploadUrl :: String
uploadUrl = "/upload"

metadataUrl :: String
metadataUrl = "/metadata/fs/"

dataUrl :: String
dataUrl = "/data/fs/"

notebookUrl :: String
notebookUrl = "/notebook/"

searchTimeout :: Number
searchTimeout = 500

slamDataHome :: String
slamDataHome = "http://slamdata.com"

userEnabled :: Boolean
userEnabled = false

newFolderName :: String
newFolderName = "Untitled Folder"

notebookExtension :: String
notebookExtension = ".slam"

newNotebookName :: String
newNotebookName = "Untitled Notebook" <> notebookExtension

module Config where

uploadUrl :: String
uploadUrl = "/upload"

metadataUrl :: String
metadataUrl = "/metadata/fs/"

dataUrl :: String
dataUrl = "/data/fs/"

notebookUrl :: String
notebookUrl = "/notebook/"

searchTimeout :: Number
searchTimeout = 500

slamDataHome :: String
slamDataHome = "http://slamdata.com"

userEnabled :: Boolean
userEnabled = false

newNotebookName :: String
newNotebookName = "NewNotebook.nb"

newFolderName :: String
newFolderName = "NewFolder"


Expose unsafeReadTagged

Expose unsafeReadTagged

-- | This module defines types and functions for working with _foreign_
-- | data.

module Data.Foreign
  ( Foreign()
  , ForeignError(..)

  , F()

  , parseJSON

  , toForeign
  , unsafeFromForeign
  , unsafeReadTagged

  , typeOf
  , tagOf

  , isNull
  , isUndefined
  , isArray

  , readString
  , readBoolean
  , readNumber
  , readArray
  ) where

import Data.Array
import Data.Either
import Data.Function

-- | A type for _foreign data_.
-- |
-- | Foreign data is data from any external _unknown_ or _unreliable_
-- | source, for which it cannot be guaranteed that the runtime representation
-- | conforms to that of any particular type.
-- |
-- | Suitable applications of `Foreign` are
-- |
-- | - To represent responses from web services
-- | - To integrate with external JavaScript libraries.
foreign import data Foreign :: *

-- | A type for runtime type errors
data ForeignError
  = TypeMismatch String String
  | ErrorAtIndex Number ForeignError
  | ErrorAtProperty String ForeignError
  | JSONError String

instance showForeignError :: Show ForeignError where
  show (TypeMismatch exp act) = "Type mismatch: expected " ++ exp ++ ", found " ++ act
  show (ErrorAtIndex i e) = "Error at array index " ++ show i ++ ": " ++ show e
  show (ErrorAtProperty prop e) = "Error at property " ++ show prop ++ ": " ++ show e
  show (JSONError s) = "JSON error: " ++ s

instance eqForeignError :: Eq ForeignError where
  (==) (TypeMismatch a b) (TypeMismatch a' b') = a == a' && b == b'
  (==) (ErrorAtIndex i e) (ErrorAtIndex i' e') = i == i' && e == e'
  (==) (ErrorAtProperty p e) (ErrorAtProperty p' e') = p == p' && e == e'
  (==) (JSONError s) (JSONError s') = s == s'
  (==) _ _ = false
  (/=) a b = not (a == b)

-- | An error monad, used in this library to encode possible failure when
-- | dealing with foreign data.
type F = Either ForeignError

foreign import parseJSONImpl
  """
  function parseJSONImpl(left, right, str) {
    try {
      return right(JSON.parse(str));
    } catch (e) {
      return left(e.toString());
    }
  }
  """ :: forall r. Fn3 (String -> r) (Foreign -> r) String r

-- | Attempt to parse a JSON string, returning the result as foreign data.
parseJSON :: String -> F Foreign
parseJSON json = runFn3 parseJSONImpl (Left <<< JSONError) Right json

-- | Coerce any value to the a `Foreign` value.
foreign import toForeign
  """
  function toForeign(value) {
    return value;
  }
  """ :: forall a. a -> Foreign

-- | Unsafely coerce a `Foreign` value.
foreign import unsafeFromForeign
  """
  function unsafeFromForeign(value) {
    return value;
  }
  """ :: forall a. Foreign -> a

-- | Read the Javascript _type_ of a value
foreign import typeOf
  """
  function typeOf(value) {
    return typeof value;
  }
  """ :: Foreign -> String

-- | Read the Javascript _tag_ of a value.
-- |
-- | This function wraps the `Object.toString` method.
foreign import tagOf
  """
  function tagOf(value) {
    return Object.prototype.toString.call(value).slice(8, -1);
  }
  """ :: Foreign -> String

-- | Unsafely coerce a `Foreign` value when the value has a particular `tagOf`
-- | value.
unsafeReadTagged :: forall a. String -> Foreign -> F a
unsafeReadTagged tag value | tagOf value == tag = pure (unsafeFromForeign value)
unsafeReadTagged tag value = Left (TypeMismatch tag (tagOf value))

-- | Test whether a foreign value is null
foreign import isNull
  """
  function isNull(value) {
    return value === null;
  }
  """ :: Foreign -> Boolean

-- | Test whether a foreign value is undefined
foreign import isUndefined
  """
  function isUndefined(value) {
    return value === undefined;
  }
  """ :: Foreign -> Boolean

-- | Test whether a foreign value is an array
foreign import isArray
  """
  var isArray = Array.isArray || function(value) {
    return Object.prototype.toString.call(value) === '[object Array]';
  };
  """ :: Foreign -> Boolean

-- | Attempt to coerce a foreign value to a `String`.
readString :: Foreign -> F String
readString = unsafeReadTagged "String"

-- | Attempt to coerce a foreign value to a `Boolean`.
readBoolean :: Foreign -> F Boolean
readBoolean = unsafeReadTagged "Boolean"

-- | Attempt to coerce a foreign value to a `Number`.
readNumber :: Foreign -> F Number
readNumber = unsafeReadTagged "Number"

-- | Attempt to coerce a foreign value to an array.
readArray :: Foreign -> F [Foreign]
readArray value | isArray value = pure $ unsafeFromForeign value
readArray value = Left (TypeMismatch "array" (tagOf value))

-- | This module defines types and functions for working with _foreign_
-- | data.

module Data.Foreign
  ( Foreign()
  , ForeignError(..)

  , F()

  , parseJSON

  , toForeign
  , unsafeFromForeign

  , typeOf
  , tagOf

  , isNull
  , isUndefined
  , isArray

  , readString
  , readBoolean
  , readNumber
  , readArray
  ) where

import Data.Array
import Data.Either
import Data.Function

-- | A type for _foreign data_.
-- |
-- | Foreign data is data from any external _unknown_ or _unreliable_
-- | source, for which it cannot be guaranteed that the runtime representation
-- | conforms to that of any particular type.
-- |
-- | Suitable applications of `Foreign` are
-- |
-- | - To represent responses from web services
-- | - To integrate with external JavaScript libraries.
foreign import data Foreign :: *

-- | A type for runtime type errors
data ForeignError
  = TypeMismatch String String
  | ErrorAtIndex Number ForeignError
  | ErrorAtProperty String ForeignError
  | JSONError String

instance showForeignError :: Show ForeignError where
  show (TypeMismatch exp act) = "Type mismatch: expected " ++ exp ++ ", found " ++ act
  show (ErrorAtIndex i e) = "Error at array index " ++ show i ++ ": " ++ show e
  show (ErrorAtProperty prop e) = "Error at property " ++ show prop ++ ": " ++ show e
  show (JSONError s) = "JSON error: " ++ s

instance eqForeignError :: Eq ForeignError where
  (==) (TypeMismatch a b) (TypeMismatch a' b') = a == a' && b == b'
  (==) (ErrorAtIndex i e) (ErrorAtIndex i' e') = i == i' && e == e'
  (==) (ErrorAtProperty p e) (ErrorAtProperty p' e') = p == p' && e == e'
  (==) (JSONError s) (JSONError s') = s == s'
  (==) _ _ = false
  (/=) a b = not (a == b)

-- | An error monad, used in this library to encode possible failure when
-- | dealing with foreign data.
type F = Either ForeignError

foreign import parseJSONImpl
  """
  function parseJSONImpl(left, right, str) {
    try {
      return right(JSON.parse(str));
    } catch (e) {
      return left(e.toString());
    }
  }
  """ :: forall r. Fn3 (String -> r) (Foreign -> r) String r

-- | Attempt to parse a JSON string, returning the result as foreign data.
parseJSON :: String -> F Foreign
parseJSON json = runFn3 parseJSONImpl (Left <<< JSONError) Right json

-- | Coerce any value to the a `Foreign` value.
foreign import toForeign
  """
  function toForeign(value) {
    return value;
  }
  """ :: forall a. a -> Foreign

-- | Unsafely coerce a `Foreign` value.
foreign import unsafeFromForeign
  """
  function unsafeFromForeign(value) {
    return value;
  }
  """ :: forall a. Foreign -> a

-- | Read the Javascript _type_ of a value
foreign import typeOf
  """
  function typeOf(value) {
    return typeof value;
  }
  """ :: Foreign -> String

-- | Read the Javascript _tag_ of a value.
-- |
-- | This function wraps the `Object.toString` method.
foreign import tagOf
  """
  function tagOf(value) {
    return Object.prototype.toString.call(value).slice(8, -1);
  }
  """ :: Foreign -> String

-- | Unsafely coerce a `Foreign` value when the value has a particular `tagOf`
-- | value.
unsafeReadTagged :: forall a. String -> Foreign -> F a
unsafeReadTagged tag value | tagOf value == tag = pure (unsafeFromForeign value)
unsafeReadTagged tag value = Left (TypeMismatch tag (tagOf value))

-- | Test whether a foreign value is null
foreign import isNull
  """
  function isNull(value) {
    return value === null;
  }
  """ :: Foreign -> Boolean

-- | Test whether a foreign value is undefined
foreign import isUndefined
  """
  function isUndefined(value) {
    return value === undefined;
  }
  """ :: Foreign -> Boolean

-- | Test whether a foreign value is an array
foreign import isArray
  """
  var isArray = Array.isArray || function(value) {
    return Object.prototype.toString.call(value) === '[object Array]';
  };
  """ :: Foreign -> Boolean

-- | Attempt to coerce a foreign value to a `String`.
readString :: Foreign -> F String
readString = unsafeReadTagged "String"

-- | Attempt to coerce a foreign value to a `Boolean`.
readBoolean :: Foreign -> F Boolean
readBoolean = unsafeReadTagged "Boolean"

-- | Attempt to coerce a foreign value to a `Number`.
readNumber :: Foreign -> F Number
readNumber = unsafeReadTagged "Number"

-- | Attempt to coerce a foreign value to an array.
readArray :: Foreign -> F [Foreign]
readArray value | isArray value = pure $ unsafeFromForeign value
readArray value = Left (TypeMismatch "array" (tagOf value))


Clean up & comment SVG module

Clean up & comment SVG module

module Graphics.SVG
       ( SVG
       , SVGContext
       , SVGTransform
       , SVGElement
       , renderSVG
       , initialSVG
       , setStrokeStyle
       , setFillStyle
       , circle
       , line
       , path
       , rect
       , translate
       , scale
       ) where

-- TODO: This deserves to be in a separate package (and better modularized)
import Control.Monad.Eff (Eff)
import Control.Monad.State (get, put)
import Control.Monad.State.Trans (StateT)
import Control.Monad.Writer (Writer, tell)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document)
import DOM.Node.Document as Document
import DOM.Node.Element as Element
import DOM.Node.Node (appendChild)
import DOM.Node.Types (Element, elementToNode)
import Data.Array (uncons)
import Data.Foldable (class Foldable)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..))
import Data.Traversable (intercalate, traverse_)
import Data.Tuple (Tuple(..))
import Prelude

createElementSVG :: ∀ eff. String -> Eff (dom :: DOM | eff) Element
createElementSVG tag = do
  win <- window
  doc <- document win
  Document.createElementNS
    (Just "http://www.w3.org/2000/svg")
    tag
    (htmlDocumentToDocument doc)

type Attribute = Tuple String String

setAttributes :: ∀ f eff. Foldable f => f Attribute -> Element -> Eff (dom :: DOM | eff) Unit
setAttributes attrs ele = traverse_ (\ (Tuple n v) -> Element.setAttribute n v ele) attrs

-- | An SVG element is a name with attributes
data SVGElement = SVGElement String (Array Attribute)

data SVGPathOp = SVGPathMoveTo Number Number
               | SVGPathLineTo Number Number
               | SVGPathClose

derive instance eqSVGPathOp :: Eq SVGPathOp

instance showSVGPathOp :: Show SVGPathOp where
  show (SVGPathMoveTo x y) = "M " <> show x <> " " <> show y
  show (SVGPathLineTo x y) = "L " <> show x <> " " <> show y
  show SVGPathClose = "Z"

renderSVGElement :: ∀ eff.
                    SVGElement
                 -> Eff (dom :: DOM | eff) Element
renderSVGElement (SVGElement tag as) = do
  ele <- createElementSVG tag
  setAttributes as ele
  pure ele

-- | Renders some SVGElements, returning an HTML element
renderSVG :: ∀ f eff.
             Foldable f
          => f SVGElement
          -> Eff (dom :: DOM | eff) Element
renderSVG as = do
  win <- window
  doc <- document win
  root <- createElementSVG "g"
  let parent = elementToNode root
  traverse_ (\ svgEle -> do
                rendered <- renderSVGElement svgEle
                appendChild (elementToNode rendered) parent) as
  pure root

derive instance genericSVGElement :: Generic SVGElement _
derive instance eqSVGElement :: Eq SVGElement
instance showSVGElement :: Show SVGElement where
  show x = genericShow x

type SVGTransform = { translate :: { x :: Number, y :: Number }
                    , scale :: { x :: Number, y :: Number}
                    }

showTransform :: SVGTransform -> String
showTransform t = "translate(" <> show t.translate.x <> "," <> show t.translate.y <> ") " <>
                  "scale(" <> show t.scale.x <> "," <> show t.scale.y <> ")"

-- | The SVG context (incomplete)
type SVGContext = { stroke :: String
                  , fill :: String
                  , strokeWidth :: Number
                  , transform :: SVGTransform
                  }

-- | Contains the current state of the SVG context as well as the SVG document as an array of elements
type SVG a = StateT SVGContext (Writer (Array SVGElement)) a

svgToAttribs :: SVGContext -> Array Attribute
svgToAttribs svg = [ Tuple "fill" svg.fill
                   , Tuple "stroke" svg.stroke
                   , Tuple "strokeWidth" (show svg.strokeWidth <> "px")
                   , Tuple "transform" (showTransform svg.transform)
                   ]

-- | The empty/initial SVGContext
initialSVG :: SVGContext
initialSVG = { stroke: "none"
             , fill: "none"
             , strokeWidth: 1.0
             , transform: { translate: { x: 0.0, y: 0.0 }
                          , scale: { x: 1.0, y: 1.0 }
                          }
             }

setStrokeStyle :: String
               -> SVG Unit
setStrokeStyle color = do
  cur <- get
  let cur' = cur { stroke = color }
  put cur'

setFillStyle :: String
             -> SVG Unit
setFillStyle color = do
  cur <- get
  let cur' = cur { fill = color }
  put cur'

-- TODO: it feels like these functions can clean up nicely,
-- using some suitable/more restrictive abstraction, maybe.
-- there's an obvious pattern to many of them:
-- cur <- get; ~stuff~; tell [Element tag attribs]
circle :: Number
       -> Number
       -> Number
       -> SVG Unit
circle x y r = do
  cur <- get
  let circle' = [ Tuple "cx" (show x)
                , Tuple "cy" (show y)
                , Tuple "r" (show r)
                ] <> svgToAttribs cur
  tell [SVGElement "circle" circle']

line :: Number
     -> Number
     -> Number
     -> Number
     -> SVG Unit
line x1 y1 x2 y2 = path [ {x:x1, y:y1}, {x:x2, y:y2} ]

path :: Array { x :: Number, y :: Number }
     -> SVG Unit
path ps = do
  case uncons ps of
    Nothing -> pure unit
    Just { head, tail } -> do
      cur <- get
      let fst = [ SVGPathMoveTo head.x head.y
                ]
          rest = (\p -> SVGPathLineTo p.x p.y) <$> ps
          path' = intercalate " " $ show <$> fst <> rest <> [SVGPathClose]
          attribs = [ Tuple "d" path' ] <> svgToAttribs cur
      tell [SVGElement "path" attribs]

rect :: Number
     -> Number
     -> Number
     -> Number
     -> SVG Unit
rect x1 y1 x2 y2 = do
  cur <- get
  let rect' = [ Tuple "x" (show x1)
              , Tuple "y" (show y1)
              , Tuple "width" (show (x2 - x1))
              , Tuple "height" (show (y2 - y1))
              ] <> svgToAttribs cur
  tell [SVGElement "rect" rect']

translate :: Number
          -> Number
          -> SVG Unit
translate x y = do
  cur <- get
  let t = cur.transform.translate
      t' = t { x = t.x + x, y = t.y + y }
      new = cur { transform = ( cur.transform { translate = t })}
  put new

scale :: Number
      -> Number
      -> SVG Unit
scale x y = do
  cur <- get
  let s = cur.transform.scale
      s' = s { x = s.x * x, y = s.y * y }
      new = cur { transform = ( cur.transform { scale = s })}
  put new

-- TODO: This deserves to be in a separate package (and better modularized)

module Graphics.SVG where

import Control.Monad.Eff (Eff)
import Control.Monad.State (get, put)
import Control.Monad.State.Trans (StateT)
import Control.Monad.Writer (Writer, tell)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document)
import DOM.Node.Document as Document
import DOM.Node.Element as Element
import DOM.Node.Node (appendChild)
import DOM.Node.Types (Element, elementToNode)
import Data.Array (uncons)
import Data.Foldable (class Foldable)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..))
import Data.Traversable (intercalate, traverse_)
import Data.Tuple (Tuple(..))
import Prelude

createElementSVG :: ∀ eff. String -> Eff (dom :: DOM | eff) Element
createElementSVG tag = do
  win <- window
  doc <- document win
  Document.createElementNS
    (Just "http://www.w3.org/2000/svg")
    tag
    (htmlDocumentToDocument doc)

type Attribute = Tuple String String

setAttributes :: ∀ f eff. Foldable f => f Attribute -> Element -> Eff (dom :: DOM | eff) Unit
setAttributes attrs ele = traverse_ (\ (Tuple n v) -> Element.setAttribute n v ele) attrs

data SVGElement = SVGElement String (Array Attribute)

data SVGPathOp = SVGPathMoveTo Number Number
               | SVGPathLineTo Number Number
               | SVGPathClose

derive instance eqSVGPathOp :: Eq SVGPathOp

instance showSVGPathOp :: Show SVGPathOp where
  show (SVGPathMoveTo x y) = "M " <> show x <> " " <> show y
  show (SVGPathLineTo x y) = "L " <> show x <> " " <> show y
  show SVGPathClose = "Z"

renderSVGElement :: ∀ eff. SVGElement -> Eff (dom :: DOM | eff) Element
renderSVGElement (SVGElement tag as) = do
  ele <- createElementSVG tag
  setAttributes as ele
  pure ele

renderSVG :: ∀ f eff. Foldable f => f SVGElement -> Eff (dom :: DOM | eff) Element
renderSVG as = do
  win <- window
  doc <- document win
  root <- createElementSVG "g"
  let parent = elementToNode root
  traverse_ (\ svgEle -> do
                rendered <- renderSVGElement svgEle
                appendChild (elementToNode rendered) parent) as
  pure root

derive instance genericSVGElement :: Generic SVGElement _
derive instance eqSVGElement :: Eq SVGElement
instance showSVGElement :: Show SVGElement where
  show x = genericShow x

type SVGTransform = { translate :: { x :: Number, y :: Number }
                    , scale :: { x :: Number, y :: Number}
                    }

showTransform :: SVGTransform -> String
showTransform t = "translate(" <> show t.translate.x <> "," <> show t.translate.y <> ") " <>
                  "scale(" <> show t.scale.x <> "," <> show t.scale.y <> ")"

type SVGContext = { stroke :: String
                  , fill :: String
                  , strokeWidth :: Number
                  , transform :: SVGTransform
                  }

type SVG a = StateT SVGContext (Writer (Array SVGElement)) a

svgToAttribs :: SVGContext -> Array Attribute
svgToAttribs svg = [ Tuple "fill" svg.fill
                   , Tuple "stroke" svg.stroke
                   , Tuple "strokeWidth" (show svg.strokeWidth <> "px")
                   , Tuple "transform" (showTransform svg.transform)
                   ]

initialSVG :: SVGContext
initialSVG = { stroke: "none"
             , fill: "none"
             , strokeWidth: 1.0
             , transform: { translate: { x: 0.0, y: 0.0 }
                          , scale: { x: 1.0, y: 1.0 }
                          }
             }

setStrokeStyle :: String -> SVG Unit
setStrokeStyle color = do
  cur <- get
  let cur' = cur { stroke = color }
  put cur'

setFillStyle :: String ->  SVG Unit
setFillStyle color = do
  cur <- get
  let cur' = cur { fill = color }
  put cur'

-- TODO: it feels like these functions can clean up nicely,
-- using some suitable/more restrictive abstraction, maybe.
-- there's an obvious pattern to many of them:
-- cur <- get; ~stuff~; tell [Element tag attribs]
circle :: Number -> Number -> Number
       -> SVG Unit
circle x y r = do
  cur <- get
  let circle' = [ Tuple "cx" (show x)
                , Tuple "cy" (show y)
                , Tuple "r" (show r)
                ] <> svgToAttribs cur
  tell [SVGElement "circle" circle']

line ::  Number -> Number -> Number -> Number
     -> SVG Unit
line x1 y1 x2 y2 = path [ {x:x1, y:y1}, {x:x2, y:y2} ]

path :: Array { x :: Number, y :: Number }
     -> SVG Unit
path ps = do
  case uncons ps of
    Nothing -> pure unit
    Just { head, tail } -> do
      cur <- get
      let fst = [ SVGPathMoveTo head.x head.y
                ]
          rest = (\p -> SVGPathLineTo p.x p.y) <$> ps
          path' = intercalate " " $ show <$> fst <> rest <> [SVGPathClose]
          attribs = [ Tuple "d" path' ] <> svgToAttribs cur
      tell [SVGElement "path" attribs]

rect :: Number -> Number -> Number -> Number
     -> SVG Unit
rect x1 y1 x2 y2 = do
  cur <- get
  let rect' = [ Tuple "x" (show x1)
              , Tuple "y" (show y1)
              , Tuple "width" (show (x2 - x1))
              , Tuple "height" (show (y2 - y1))
              ] <> svgToAttribs cur
  tell [SVGElement "rect" rect']

translate :: Number -> Number
          -> SVG Unit
translate x y = do
  cur <- get
  let t = cur.transform.translate
      t' = t { x = t.x + x, y = t.y + y }
      new = cur { transform = ( cur.transform { translate = t })}
  put new

scale :: Number -> Number
      -> SVG Unit
scale x y = do
  cur <- get
  let s = cur.transform.scale
      s' = s { x = s.x * x, y = s.y * y }
      new = cur { transform = ( cur.transform { scale = s })}
  put new


Removed the Agenda module.

Removed the Agenda module.

module Agenda where

import Prelude (type (~>), Unit, Void, bind, const, id, pure, show, unit, ($), (*>), (+))
import Types (SpeakerQueue)

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Console (CONSOLE, logShow)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Network.HTTP.Affjax as AX
import Simple.JSON (class ReadForeign, readJSON)

newtype AgendaItem = AgendaItem
  { order             :: Int
  , title             :: String
  , content           :: String
  , speakerQueueStack :: Array SpeakerQueue
  }

derive instance ntAI :: Newtype AgendaItem _
derive newtype instance rfAI :: ReadForeign AgendaItem

type State = { current :: AgendaItem }
type Input = State

data Query a
  = Previous a
  | Next a

type AgendaEffects e = (Aff (ajax :: AX.AJAX, console :: CONSOLE | e))

component :: forall e. H.Component HH.HTML Query Input Void (AgendaEffects e)
component =
  H.component
    { initialState: id
    , render
    , eval
    , receiver: const Nothing
    }
  where

  render :: State -> H.ComponentHTML Query
  render state =
    HH.section_
      [ HH.h2_
        [ HH.button
          [ HE.onClick (HE.input_ Previous) ]
          [ HH.text "|<" ]
        , HH.text "§"
        , HH.text (show (currentItem.order + 1))
        , HH.text currentItem.title
        , HH.button
            [ HE.onClick (HE.input_ Next) ]
            [ HH.text ">|" ]
        ]
      ]
    where
      currentItem = let (AgendaItem a) = state.current
                     in a

  eval :: Query ~> H.ComponentDSL State Query Void (AgendaEffects e)
  eval =
    case _ of
      Previous next -> rpcHelper "/agenda/previous/" *> pure next
      Next     next -> rpcHelper "/agenda/next/"     *> pure next

    where
      rpcHelper :: String -> H.ComponentDSL State Query Void (AgendaEffects e) Unit
      rpcHelper url = do
        r <- H.liftAff $ AX.post url unit
        case readJSON r.response of
          Left es -> H.liftAff $ logShow es
          Right v -> H.modify (_ { current = v } )