Don't use UTC methods in Locale

Don't use UTC methods in Locale

module Data.Date.Locale
  ( Locale()
  , dateTime
  , date
  , year
  , month
  , dayOfMonth
  , dayOfWeek
  , hourOfDay
  , minuteOfHour
  , secondOfMinute
  , millisecondOfSecond
  ) where

import Control.Monad.Eff (Eff())
import Data.Date
import Data.Enum (fromEnum, toEnum)
import Data.Function (Fn2(), runFn2, Fn7(), runFn7)
import Data.Int (Int())
import Data.Maybe (Maybe())
import Data.Maybe.Unsafe (fromJust)
import Data.Time

-- | The effect of reading the current system locale/timezone.
foreign import data Locale :: !

-- | Attempts to create a `Date` from date and time components based on the
-- | current machine’s locale. `Nothing` is returned if the resulting date is
-- | invalid.
dateTime :: forall e. Year -> Month -> DayOfMonth
         -> HourOfDay -> MinuteOfHour -> SecondOfMinute -> MillisecondOfSecond
         -> Eff (locale :: Locale | e) (Maybe Date)
dateTime y mo d h mi s ms =
  fromJSDate <$> runFn7 jsDateFromValues y (fromEnum mo) d h mi s ms

-- | Attempts to create a `Date` from date components based on the current
-- | machine’s locale. `Nothing` is returned if the resulting date is invalid.
date :: forall e. Year -> Month -> DayOfMonth -> Eff (locale :: Locale | e) (Maybe Date)
date y m d = dateTime y m d (HourOfDay zero) (MinuteOfHour zero) (SecondOfMinute zero) (MillisecondOfSecond zero)

-- | Gets the year component for a date based on the current machine’s locale.
year :: forall e. Date -> Eff (locale :: Locale | e) Year
year d = runFn2 dateMethod "getFullYear" d

-- | Gets the month component for a date based on the current machine’s locale.
month :: forall e. Date -> Eff (locale :: Locale | e) Month
month d = fromJust <<< toEnum <$> runFn2 dateMethod "getMonth" d

-- | Gets the day-of-month value for a date based on the current machine’s
-- | locale.
dayOfMonth :: forall e. Date -> Eff (locale :: Locale | e) DayOfMonth
dayOfMonth d = runFn2 dateMethod "getDate" d

-- | Gets the day-of-week value for a date based on the current machine’s
-- | locale.
dayOfWeek :: forall e. Date -> Eff (locale :: Locale | e) DayOfWeek
dayOfWeek d = fromJust <<< toEnum <$> runFn2 dateMethod "getDay" d

-- | Gets the hour-of-day value for a date based on the current machine’s
-- | locale.
hourOfDay :: forall e. Date -> Eff (locale :: Locale | e) HourOfDay
hourOfDay d = runFn2 dateMethod "getHours" d

-- | Gets the minute-of-hour value for a date based on the current machine’s
-- | locale.
minuteOfHour :: forall e. Date -> Eff (locale :: Locale | e) MinuteOfHour
minuteOfHour d = runFn2 dateMethod "getMinutes" d

-- | Get the second-of-minute value for a date based on the current machine’s
-- | locale.
secondOfMinute :: forall e. Date -> Eff (locale :: Locale | e) SecondOfMinute
secondOfMinute d = runFn2 dateMethod "getSeconds" d

-- | Get the millisecond-of-second value for a date based on the current
-- | machine’s locale.
millisecondOfSecond :: forall e. Date -> Eff (locale :: Locale | e) MillisecondOfSecond
millisecondOfSecond d = runFn2 dateMethod "getMilliseconds" d

foreign import dateMethod
  """
  function dateMethod(method, date) {
    return function () {
      return date[method]();
    };
  }
  """ :: forall e a. Fn2 String Date (Eff (locale :: Locale | e) a)

foreign import jsDateFromValues
  """
  function jsDateFromValues(y, mo, d, h, mi, s, ms) {
    return function () {
      return new Date(y, mo, d, h, mi, s, ms);
    };
  }
  """ :: forall e. Fn7 Year Number DayOfMonth HourOfDay MinuteOfHour SecondOfMinute MillisecondOfSecond (Eff (locale :: Locale | e) JSDate)

module Data.Date.Locale
  ( Locale()
  , dateTime
  , date
  , year
  , month
  , dayOfMonth
  , dayOfWeek
  , hourOfDay
  , minuteOfHour
  , secondOfMinute
  , millisecondOfSecond
  ) where

import Control.Monad.Eff (Eff())
import Data.Date
import Data.Enum (fromEnum, toEnum)
import Data.Function (Fn2(), runFn2, Fn7(), runFn7)
import Data.Int (Int())
import Data.Maybe (Maybe())
import Data.Maybe.Unsafe (fromJust)
import Data.Time

-- | The effect of reading the current system locale/timezone.
foreign import data Locale :: !

-- | Attempts to create a `Date` from date and time components based on the
-- | current machine’s locale. `Nothing` is returned if the resulting date is
-- | invalid.
dateTime :: forall e. Year -> Month -> DayOfMonth
         -> HourOfDay -> MinuteOfHour -> SecondOfMinute -> MillisecondOfSecond
         -> Eff (locale :: Locale | e) (Maybe Date)
dateTime y mo d h mi s ms =
  fromJSDate <$> runFn7 jsDateFromValues y (fromEnum mo) d h mi s ms

-- | Attempts to create a `Date` from date components based on the current
-- | machine’s locale. `Nothing` is returned if the resulting date is invalid.
date :: forall e. Year -> Month -> DayOfMonth -> Eff (locale :: Locale | e) (Maybe Date)
date y m d = dateTime y m d (HourOfDay zero) (MinuteOfHour zero) (SecondOfMinute zero) (MillisecondOfSecond zero)

-- | Gets the year component for a date based on the current machine’s locale.
year :: forall e. Date -> Eff (locale :: Locale | e) Year
year d = runFn2 dateMethod "getUTCFullYear" d

-- | Gets the month component for a date based on the current machine’s locale.
month :: forall e. Date -> Eff (locale :: Locale | e) Month
month d = fromJust <<< toEnum <$> runFn2 dateMethod "getUTCMonth" d

-- | Gets the day-of-month value for a date based on the current machine’s
-- | locale.
dayOfMonth :: forall e. Date -> Eff (locale :: Locale | e) DayOfMonth
dayOfMonth d = runFn2 dateMethod "getUTCDate" d

-- | Gets the day-of-week value for a date based on the current machine’s
-- | locale.
dayOfWeek :: forall e. Date -> Eff (locale :: Locale | e) DayOfWeek
dayOfWeek d = fromJust <<< toEnum <$> runFn2 dateMethod "getUTCDay" d

-- | Gets the hour-of-day value for a date based on the current machine’s
-- | locale.
hourOfDay :: forall e. Date -> Eff (locale :: Locale | e) HourOfDay
hourOfDay d = runFn2 dateMethod "getUTCHours" d

-- | Gets the minute-of-hour value for a date based on the current machine’s
-- | locale.
minuteOfHour :: forall e. Date -> Eff (locale :: Locale | e) MinuteOfHour
minuteOfHour d = runFn2 dateMethod "getUTCMinutes" d

-- | Get the second-of-minute value for a date based on the current machine’s
-- | locale.
secondOfMinute :: forall e. Date -> Eff (locale :: Locale | e) SecondOfMinute
secondOfMinute d = runFn2 dateMethod "getUTCSeconds" d

-- | Get the millisecond-of-second value for a date based on the current
-- | machine’s locale.
millisecondOfSecond :: forall e. Date -> Eff (locale :: Locale | e) MillisecondOfSecond
millisecondOfSecond d = runFn2 dateMethod "getUTCMilliseconds" d

foreign import dateMethod
  """
  function dateMethod(method, date) {
    return function () {
      return date[method]();
    };
  }
  """ :: forall e a. Fn2 String Date (Eff (locale :: Locale | e) a)

foreign import jsDateFromValues
  """
  function jsDateFromValues(y, mo, d, h, mi, s, ms) {
    return function () {
      return new Date(y, mo, d, h, mi, s, ms);
    };
  }
  """ :: forall e. Fn7 Year Number DayOfMonth HourOfDay MinuteOfHour SecondOfMinute MillisecondOfSecond (Eff (locale :: Locale | e) JSDate)


Little whitespace cleanup

Little whitespace cleanup

-- | High level declarative interface for servant-subscriber.
module Servant.Subscriber (
  Subscriber
  , makeSubscriber
  , deploy
  , getConnection
  , module Exports )where

import Prelude

import Servant.Subscriber.Subscriptions as Subs
import Control.Monad.Eff.Ref (newRef, writeRef, readRef, Ref)
import Data.Monoid (mempty)
import Servant.Subscriber.Connection (SubscriberEff, Connection, Config, realize, subscribeAll, unsubscribeAll, makeConnection)
import Servant.Subscriber.Connection (Config) as Exports
import Servant.Subscriber.Internal (ToUserType, SubscriberEff) as Exports
import Servant.Subscriber.Subscriptions (Subscriptions, diffSubscriptions)
import Servant.Subscriber.Subscriptions (Subscriptions, makeSubscriptions) as Exports

newtype Subscriber eff a = Subscriber (SubscriberImpl eff a)

type SubscriberImpl eff a = {
    connection :: Connection eff a
  , old :: Ref (Subscriptions a)
  }

makeSubscriber :: forall eff a. Config eff a -> SubscriberEff eff (Subscriber eff a)
makeSubscriber c = do
  conn <- makeConnection c
  old' <- newRef mempty
  pure $ Subscriber {
    connection : conn
  , old : old'
  }

-- | Get access to the low-level Connection.
getConnection :: forall eff a. Subscriber eff a -> Connection eff a
getConnection (Subscriber impl) = impl.connection

-- | Deploy a given set of Subscriptions.
--
--   This function takes care of unsubscribing subscriptions which are no longer present adds any new ones, updates
--   already existing ones and also calls realize for actually sending Subscribe/Unsubscribe commands to the server.
deploy :: forall eff a. Subscriptions a -> Subscriber eff a -> SubscriberEff eff Unit
deploy subs (Subscriber impl)= do
  old' <- readRef impl.old
  let
    forUnsubscribe = map (_.req) <<< Subs.toList $ diffSubscriptions old' subs
  unsubscribeAll forUnsubscribe impl.connection
  subscribeAll (Subs.toList subs) impl.connection
  realize impl.connection
  writeRef impl.old subs


Add Java explanation comment

Add Java explanation comment

Original commit c3b25cc36741d59c5590ad79e37f9b44ed7eace6

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, 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_ \_ topLevelType -> do
        topLevelTypeRendered <- renderType false topLevelType
        line $ "//     " <> topLevelTypeRendered <> " data = Converter.FromJsonString(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
            fromJsonPrefix <- getDecoderHelperPrefix topLevelName
            line $ "public static " <> topLevelTypeRendered <> " " <> fromJsonPrefix <> "FromJsonString(String json) throws IOException {"
            indent do
                line "ObjectMapper mapper = new ObjectMapper();"
                renderedForClass <- renderTypeWithoutGenerics false topLevelType
                line $ "return mapper.readValue(json, " <> renderedForClass <> ".class);"
            line "}"
            blank
            line $ "public static String " <> fromJsonPrefix <> "ToJsonString(" <> topLevelTypeRendered <> " obj) throws JsonProcessingException {"
            indent do
                line "ObjectMapper mapper = new ObjectMapper();"
                line "return mapper.writeValueAsString(obj);"
            line "}"
    line "}"
    where
        getDecoderHelperPrefix :: String -> Doc String
        getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

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

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, 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

renderFileHeader :: String -> Array String -> Doc Unit
renderFileHeader fileName imports = do
    line $ "// " <> fileName <> ".java"
    blank
    line "package io.quicktype;"
    blank
    for_ imports \package -> do
        line $ "import " <> package <> ";"
    blank

renderConverter :: Doc Unit
renderConverter = do
    renderFileHeader "Converter" ["java.util.Map", "java.io.IOException", "com.fasterxml.jackson.databind.ObjectMapper", "com.fasterxml.jackson.core.JsonProcessingException"]
    line "public class Converter {"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderType false topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelName
            line $ "public static " <> topLevelTypeRendered <> " " <> fromJsonPrefix <> "FromJsonString(String json) throws IOException {"
            indent do
                line "ObjectMapper mapper = new ObjectMapper();"
                renderedForClass <- renderTypeWithoutGenerics false topLevelType
                line $ "return mapper.readValue(json, " <> renderedForClass <> ".class);"
            line "}"
            blank
            line $ "public static String " <> fromJsonPrefix <> "ToJsonString(" <> topLevelTypeRendered <> " obj) throws JsonProcessingException {"
            indent do
                line "ObjectMapper mapper = new ObjectMapper();"
                line "return mapper.writeValueAsString(obj);"
            line "}"
    line "}"
    where
        getDecoderHelperPrefix :: String -> Doc String
        getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

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


Add more detailed explanation of ref expansion

-- | Transform a `ExpandedOptionsLayout` into a `SolvedLayout`
-- |
-- | This transform expands `[...-options]` reference tags into real options.
-- | This transform must be careful not to expand options that are already
-- | present in the same "free" grouping. We define a "free" grouping of such
-- | elements whose position does not matter.
-- |
-- | Since `[...-options]` reference tags strictly evaluate to "free" elements,
-- | that is short- and long options (practically speaking), the position of
-- | insertion does *NOT* matter, that is it must not necessarily occur in place
-- | of the actual tag, as long as it is within the same grouping.
-- |
-- | The method of performing this transform is roughly as follows, where
-- | `<* E...  *>` denotes an "free" chunk of elements `E` and
-- | `<! E...  !>` denotes an "fixed" chunk of elements `E`:
-- |
-- | Each top-level branch is solved independently. Given the following
-- | help text:
-- |
-- |    usage: prog foo -a [-b (-d -e)] [options] [-f] bar
-- |       or: prog foo bar --qux
-- |    options:
-- |      -d
-- |      -z
-- |
-- | We proceed as follows (for each top-level):
-- |
-- | 1. flatten the entire top-level and annotate each element w/ it's index:
-- |
-- |        prog foo -a [-b (-d -e)] [options] [-f] bar
-- |
-- |    becomes:
-- |
-- |        prog (1:foo) (2:-a) (3:-b) (4:-d) (5:-e) (6:[options]) (7:-f) (8:bar)
-- |
-- | 2. we chunk the output, such that "free" elements appear next to one
-- |    another:
-- |
-- |        prog <!(1:foo)!> <*(2:-a) (3:-b) (4:-d) (5:-e) (6:[options])
-- |             (7:-f)*> <!(8:bar)!>
-- |
-- | 3. we then expand any `[options]` elements into it's surrounding. We must
-- |    make sure not to expand an option into it's surrounding that is already
-- |    present. since the options section defined an `-d` (see above), but it
-- |    is already present in the surrounding area, we only expand `-z`
-- |
-- |        prog <!(1:foo)!> <*(2:-a) (3:-b) (4:-d) (5:-e) (6:[options: -z])
-- |             (7:-f)*> <!(8:bar)!>
-- |
-- | 4. finally, we apply expansion to the actual tree, using the indices as
-- |    lookups into the tree structure:
-- |
-- |        prog foo -a [-b (-d -e)] ([-z]) [-f] bar

module Neodoc.Solve.ExpandReferences where

import Prelude

import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Traversable (traverse, for)
import Data.NonEmpty (NonEmpty, (:|))
import Data.NonEmpty.Extra as NonEmpty
import Data.Map as Map
import Data.List (List(..), (:), fromFoldable, length, catMaybes, concat, filter)
import Data.Tuple (Tuple, fst, snd)
import Data.Tuple.Nested ((/\))
import Data.Foldable (any)
import Control.Monad.State
import Control.Monad.State as State
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Comonad (extract)

import Neodoc.Spec
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.Data.EmptyableLayout
import Neodoc.Data.Description
import Neodoc.Data.Chunk
import Neodoc.Data.Layout
import Neodoc.Data.Indexed
import Neodoc.Data.Indexed as Indexed
import Neodoc.ArgKey.Class
import Neodoc.Solve.Error
import Neodoc.Solve.ExpandOptions
import Neodoc.Evaluate.Annotate

import Partial.Unsafe (unsafePartial)

type IndexedLayout a = Layout (IndexedLayoutArg a)
type IndexedLayoutArg a = Indexed a

expandReferences
  :: Spec ExpandedOptionsLayout
  -> Either SolveError (Spec SolvedLayout)
expandReferences (Spec { program, layouts, descriptions }) =
  let -- expand the references per top-level branch, then remove any branches
      -- that yieleded `Nothing`.
      layouts' = (catMaybes <$> _)
          $ fromFoldable
          $ (expandReferencesInBranch <$> _) <$> layouts
      layouts'' = case layouts' of
                    Nil    -> Nil :| Nil -- create empty top-level branch
                    x : xs ->   x :| xs
   in pure (Spec { program, layouts: layouts'', descriptions })

  where
  expandReferencesInBranch
    :: NonEmpty List ExpandedOptionsLayout
    -> Maybe _
  expandReferencesInBranch branch =
    let -- 1. assign an index from left to right, to each layout element
        indexedBranch = indexBranch branch

        -- 2. flatten the branch, removing any recursion
        flatBranch = flattenBranch indexedBranch

        -- 3. chunk the flat branch into fixed/free args
        chunks = chunkBranch flatBranch

        -- 4. for each chunk, find out the args that a reference tag needs to
        --    resolve to. References are resolved left to right.
        --    (XXX: should they be aware of each other, so not to expand
        --          duplicates if they are adjacent? this would mean we'd need
        --          to run this in e.g. the State monad)
        indexToArgs = Indexed.toMap $ concat
                        $ fromFoldable $ expandChunk descriptions <$> chunks

        -- 6. expand the reference tags using the `index => [ arg ]` mapping.
        --    note that since branches could now be empty, we must be use a
        --    a slightly different intermediate structure that allows for empty
        --    lists.
        --    (XXX: it might be worth exploring if `Layout a` can be generalised
        --          to work on data structures other than `List a`s)
        expand = case _ of
          (EmptyableGroup o r xs) -> EmptyableGroup o r $ (expand <$> _) <$> xs
          (EmptyableElem (Indexed _ (SolvedArg x))) -> EmptyableElem x
          (EmptyableElem (Indexed ix (ReferenceArg n))) ->
            EmptyableGroup false false $ maybe Nil (_:Nil) do
              args <- Map.lookup ix indexToArgs
              pure $ args <#> \arg ->
                EmptyableGroup true false ((EmptyableElem arg:Nil):Nil)

     in toStrictBranch $ toEmptyableBranch indexedBranch <#> expand

expandChunk
  :: List Description
  -> Chunk _
  -> List (Indexed (List SolvedLayoutArg))
expandChunk _ (Fixed _) = Nil
expandChunk descriptions (Free xs) =
  let partitioned = partition xs
      surrounding = toArgKey <$> mlefts partitioned
      references = mrights partitioned
      isSurroundedBy k = any (_ == k) surrounding

   in references <#> \(Indexed ix n) ->
      let
        -- XXX: currently, references *always* refer to all descriptions
        --      this is work to be done, tracked in issue #57.
        descriptions' = descriptions

        -- 5. for each description associated with each reference,
        --    expand only those descriptions that are not already
        --    present in the same chunk. We determine presence based
        --    on all known `ArgKey`s of the argument.
        args = catMaybes $ descriptions' <#> case _ of
            (OptionDescription aliases@(a:|_) r mA _ _) ->
              if not $ any (isSurroundedBy <<< toArgKey) aliases
                then Just (Option a mA r)
                else Nothing
            _ -> Nothing
       in Indexed ix args

partition
  :: ∀ a b
   . List (Indexed ExpandedOptionsLayoutArg)
  -> List (Either SolvedLayoutArg (Indexed String))
partition xs = xs <#> case _ of
  Indexed _  (SolvedArg a)    -> Left a
  Indexed ix (ReferenceArg n) -> Right $ Indexed ix n

-- Chunk a branch
--   E(foo) G(-a -b -c) E(-x) => [Fixed([E(foo)]), Free([G(-a -b -c), E(-x)])]
chunkBranch
  :: NonEmpty     List (Indexed ExpandedOptionsLayoutArg)
  -> List (Chunk (List (Indexed ExpandedOptionsLayoutArg)))
chunkBranch = fromFoldable >>> chunk case _ of
  Indexed _ (ReferenceArg _) -> true
  Indexed _ (SolvedArg    a) -> Solved.isFreeLayout (Elem a)

-- Assign a numerical index to each element in a layout on the given branch,
-- as if the branch was completely flat, from left to right, i.e.:
--
--      -a (-b | -c)
--
-- would become:
--
--      (1:-a) ((2:-b) | (3:-c))
--
indexBranch
  :: ∀ a
   . NonEmpty List (Layout a)
  -> NonEmpty List (IndexedLayout a)
indexBranch branch = flip evalState 0 $ for branch indexLayout
  where
  indexLayout (Group o r xs) = Group o r <$> do
    for xs (traverse indexLayout)
  indexLayout (Elem x) = do
    i <- State.get
    State.put (i + 1)
    pure (Elem (Indexed i x))

-- Flatten a branch into a single list of elements, i.e.:
--
--      -a (-b | -c)
--
-- would become:
--
--      -a -b -c
--
flattenBranch
  :: ∀ a
   . NonEmpty List (Layout a)
  -> NonEmpty List a
flattenBranch branch = NonEmpty.concat $ flattenLayout <$> branch
  where
  flattenLayout (Elem x) = x :| Nil
  flattenLayout (Group _ _ branches)
    = NonEmpty.concat $ NonEmpty.concat $ (flattenLayout <$> _) <$> branches

-- | Transform a `ExpandedOptionsLayout` into a `SolvedLayout`
-- |
-- | This transform expands `[...-options]` reference tags into real options.
-- | This transform must be careful not to expand options that are already
-- | present in the same "free" grouping. We define a "free" grouping of such
-- | elements whose position does not matter.
-- |
-- | Since `[...-options]` reference tags strictly evaluate to "free" elements,
-- | that is short- and long options (practically speaking), the position of
-- | insertion does *NOT* matter, that is it must not necessarily occur in place
-- | of the actual tag, as long as it is within the same grouping.
-- |
-- | The method of performing this transform is roughly as follows, where
-- | `<* E...  *>` denotes an "free" chunk of elements `E` and
-- | `<! E...  !>` denotes an "fixed" chunk of elements `E`:
-- |
-- | Each top-level branch is solved independently. Given the following
-- | help text:
-- |
-- |    usage: prog foo -a [-b (-d -e)] [options] [-f] bar
-- |    options:
-- |      -d
-- |
-- | We divide it as follows:
-- |
-- | <! foo !> <* -a [-b (-d -e)] [options] *> <! bar !>
-- |
-- | This division is *NOT* recursively applied in one go, however groups are
-- | traversed to check if they are "free", which is true if and only if all
-- | it's elements are "free". Expansion occurs "bottom up", meaning, the most
-- | deeply nested `[...-options]` are expanded first.

module Neodoc.Solve.ExpandReferences where

import Prelude

import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Traversable (traverse, for)
import Data.NonEmpty (NonEmpty, (:|))
import Data.NonEmpty.Extra as NonEmpty
import Data.Map as Map
import Data.List (List(..), (:), fromFoldable, length, catMaybes, concat, filter)
import Data.Tuple (Tuple, fst, snd)
import Data.Tuple.Nested ((/\))
import Data.Foldable (any)
import Control.Monad.State
import Control.Monad.State as State
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Comonad (extract)

import Neodoc.Spec
import Neodoc.Data.SolvedLayout
import Neodoc.Data.SolvedLayout as Solved
import Neodoc.Data.EmptyableLayout
import Neodoc.Data.Description
import Neodoc.Data.Chunk
import Neodoc.Data.Layout
import Neodoc.Data.Indexed
import Neodoc.Data.Indexed as Indexed
import Neodoc.ArgKey.Class
import Neodoc.Solve.Error
import Neodoc.Solve.ExpandOptions
import Neodoc.Evaluate.Annotate

import Partial.Unsafe (unsafePartial)

type IndexedLayout a = Layout (IndexedLayoutArg a)
type IndexedLayoutArg a = Indexed a

expandReferences
  :: Spec ExpandedOptionsLayout
  -> Either SolveError (Spec SolvedLayout)
expandReferences (Spec { program, layouts, descriptions }) =
  let -- expand the references per top-level branch, then remove any branches
      -- that yieleded `Nothing`.
      layouts' = (catMaybes <$> _)
          $ fromFoldable
          $ (expandReferencesInBranch <$> _) <$> layouts
      layouts'' = case layouts' of
                    Nil    -> Nil :| Nil -- create empty top-level branch
                    x : xs ->   x :| xs
   in pure (Spec { program, layouts: layouts'', descriptions })

  where
  expandReferencesInBranch
    :: NonEmpty List ExpandedOptionsLayout
    -> Maybe _
  expandReferencesInBranch branch =
    let -- 1. assign an index from left to right, to each layout element
        indexedBranch = indexBranch branch

        -- 2. flatten the branch, removing any recursion
        flatBranch = flattenBranch indexedBranch

        -- 3. chunk the flat branch into fixed/free args
        chunks = chunkBranch flatBranch

        -- 4. for each chunk, find out the args that a reference tag needs to
        --    resolve to. References are resolved left to right.
        --    (XXX: should they be aware of each other, so not to expand
        --          duplicates if they are adjacent? this would mean we'd need
        --          to run this in e.g. the State monad)
        indexToArgs = Indexed.toMap $ concat
                        $ fromFoldable $ expandChunk descriptions <$> chunks

        -- 6. expand the reference tags using the `index => [ arg ]` mapping.
        --    note that since branches could now be empty, we must be use a
        --    a slightly different intermediate structure that allows for empty
        --    lists.
        --    (XXX: it might be worth exploring if `Layout a` can be generalised
        --          to work on data structures other than `List a`s)
        expand = case _ of
          (EmptyableGroup o r xs) -> EmptyableGroup o r $ (expand <$> _) <$> xs
          (EmptyableElem (Indexed _ (SolvedArg x))) -> EmptyableElem x
          (EmptyableElem (Indexed ix (ReferenceArg n))) ->
            EmptyableGroup false false $ maybe Nil (_:Nil) do
              args <- Map.lookup ix indexToArgs
              pure $ args <#> \arg ->
                EmptyableGroup true false ((EmptyableElem arg:Nil):Nil)

     in toStrictBranch $ toEmptyableBranch indexedBranch <#> expand

expandChunk
  :: List Description
  -> Chunk _
  -> List (Indexed (List SolvedLayoutArg))
expandChunk _ (Fixed _) = Nil
expandChunk descriptions (Free xs) =
  let partitioned = partition xs
      surrounding = toArgKey <$> mlefts partitioned
      references = mrights partitioned
      isSurroundedBy k = any (_ == k) surrounding

   in references <#> \(Indexed ix n) ->
      let
        -- XXX: currently, references *always* refer to all descriptions
        --      this is work to be done, tracked in issue #57.
        descriptions' = descriptions

        -- 5. for each description associated with each reference,
        --    expand only those descriptions that are not already
        --    present in the same chunk. We determine presence based
        --    on all known `ArgKey`s of the argument.
        args = catMaybes $ descriptions' <#> case _ of
            (OptionDescription aliases@(a:|_) r mA _ _) ->
              if not $ any (isSurroundedBy <<< toArgKey) aliases
                then Just (Option a mA r)
                else Nothing
            _ -> Nothing
       in Indexed ix args

partition
  :: ∀ a b
   . List (Indexed ExpandedOptionsLayoutArg)
  -> List (Either SolvedLayoutArg (Indexed String))
partition xs = xs <#> case _ of
  Indexed _  (SolvedArg a)    -> Left a
  Indexed ix (ReferenceArg n) -> Right $ Indexed ix n

-- Chunk a branch
--   E(foo) G(-a -b -c) E(-x) => [Fixed([E(foo)]), Free([G(-a -b -c), E(-x)])]
chunkBranch
  :: NonEmpty     List (Indexed ExpandedOptionsLayoutArg)
  -> List (Chunk (List (Indexed ExpandedOptionsLayoutArg)))
chunkBranch = fromFoldable >>> chunk case _ of
  Indexed _ (ReferenceArg _) -> true
  Indexed _ (SolvedArg    a) -> Solved.isFreeLayout (Elem a)

-- Assign a numerical index to each element in a layout on the given branch,
-- as if the branch was completely flat, from left to right, i.e.:
--
--      -a (-b | -c)
--
-- would become:
--
--      (1:-a) ((2:-b) | (3:-c))
--
indexBranch
  :: ∀ a
   . NonEmpty List (Layout a)
  -> NonEmpty List (IndexedLayout a)
indexBranch branch = flip evalState 0 $ for branch indexLayout
  where
  indexLayout (Group o r xs) = Group o r <$> do
    for xs (traverse indexLayout)
  indexLayout (Elem x) = do
    i <- State.get
    State.put (i + 1)
    pure (Elem (Indexed i x))

-- Flatten a branch into a single list of elements, i.e.:
--
--      -a (-b | -c)
--
-- would become:
--
--      -a -b -c
--
flattenBranch
  :: ∀ a
   . NonEmpty List (Layout a)
  -> NonEmpty List a
flattenBranch branch = NonEmpty.concat $ flattenLayout <$> branch
  where
  flattenLayout (Elem x) = x :| Nil
  flattenLayout (Group _ _ branches)
    = NonEmpty.concat $ NonEmpty.concat $ (flattenLayout <$> _) <$> branches


use proper string generator

use proper string generator

module Data.Argonaut.Gen where

import Prelude

import Control.Lazy (class Lazy, defer)
import Control.Monad.Gen (class MonadGen)
import Control.Monad.Gen as Gen
import Control.Monad.Rec.Class (class MonadRec)
import Data.Argonaut.Core as J
import Data.Array as A
import Data.NonEmpty ((:|))
import Data.String.Gen (genUnicodeString)
import Foreign.Object as Obj

genJson :: forall m. MonadGen m => MonadRec m => Lazy (m J.Json) => m J.Json
genJson = Gen.resize (min 5) $ Gen.sized genJson'
  where
  genJson' :: Int -> m J.Json
  genJson' size
    | size > 1 = Gen.resize (_ - 1) (Gen.choose genJArray genJObject)
    | otherwise = genLeaf

  genLeaf :: m J.Json
  genLeaf = Gen.oneOf $ pure J.jsonNull :| [genJBoolean, genJNumber, genJString]

  genJArray :: m J.Json
  genJArray = J.fromArray <$> Gen.unfoldable (defer \_ -> genJson)

  genJObject :: m J.Json
  genJObject = A.foldM extendJObj J.jsonEmptyObject =<< Gen.unfoldable genUnicodeString

  extendJObj :: J.Json -> String -> m J.Json
  extendJObj obj k = do
    v <- genJson
    pure $
      J.caseJsonObject
        (J.jsonSingletonObject k v)
        (J.fromObject <<< Obj.insert k v)
        obj

  genJBoolean :: m J.Json
  genJBoolean = J.fromBoolean <$> Gen.chooseBool

  genJNumber :: m J.Json
  genJNumber = J.fromNumber <$> Gen.chooseFloat (-1000000.0) 1000000.0

  genJString :: m J.Json
  genJString = J.fromString <$> genUnicodeString

module Data.Argonaut.Gen where

import Prelude

import Control.Lazy (class Lazy, defer)
import Control.Monad.Gen (class MonadGen)
import Control.Monad.Gen as Gen
import Control.Monad.Rec.Class (class MonadRec)
import Data.Argonaut.Core as J
import Data.Array as A
import Data.Char as C
import Data.NonEmpty ((:|))
import Data.String as S
import Foreign.Object as Obj

genJson :: forall m. MonadGen m => MonadRec m => Lazy (m J.Json) => m J.Json
genJson = Gen.resize (min 5) $ Gen.sized genJson'
  where
  genJson' :: Int -> m J.Json
  genJson' size
    | size > 1 = Gen.resize (_ - 1) (Gen.choose genJArray genJObject)
    | otherwise = genLeaf

  genLeaf :: m J.Json
  genLeaf = Gen.oneOf $ pure J.jsonNull :| [genJBoolean, genJNumber, genJString]

  genJArray :: m J.Json
  genJArray = J.fromArray <$> Gen.unfoldable (defer \_ -> genJson)

  genJObject :: m J.Json
  genJObject = A.foldM extendJObj J.jsonEmptyObject =<< Gen.unfoldable genString

  extendJObj :: J.Json -> String -> m J.Json
  extendJObj obj k = do
    v <- genJson
    pure $
      J.caseJsonObject
        (J.jsonSingletonObject k v)
        (J.fromObject <<< Obj.insert k v)
        obj

  genJBoolean :: m J.Json
  genJBoolean = J.fromBoolean <$> Gen.chooseBool

  genJNumber :: m J.Json
  genJNumber = J.fromNumber <$> Gen.chooseFloat (-1000000.0) 1000000.0

  genJString :: m J.Json
  genJString = J.fromString <$> genString

  genString :: m String
  genString = S.fromCharArray <$> Gen.unfoldable genChar

  genChar :: m Char
  genChar = C.fromCharCode <$> Gen.chooseInt 0 65535


Use `f` rather than `g` for query in `ComponentSlot`

module Halogen.Component
  ( Component
  , ComponentSpec'
  , ComponentSpec
  , component'
  , component
  , unComponent
  , hoist
  , ComponentSlot'
  , ComponentSlot
  , mkComponentSlot
  , mkComponentSlot'
  , unComponentSlot
  , hoistSlot
  ) where

import Prelude

import Data.Bifunctor (class Bifunctor, lmap)
import Data.Foldable (traverse_)
import Data.Maybe (Maybe)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Tuple (Tuple)
import Halogen.Data.Slot (Slot, SlotStorage)
import Halogen.Data.Slot as Slot
import Halogen.Query.HalogenM (HalogenM')
import Halogen.Query.HalogenM as HM
import Halogen.Query.HalogenQ (HalogenQ(..))
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)

-- | The "public" type for a component, with details of the component internals
-- | existentially hidden.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `f` is the query algebra
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
data Component (h :: Type -> Type -> Type) (f :: Type -> Type) i o (m :: Type -> Type)

-- | Exposes the inner details of a component to a function to produce a new
-- | result. The inner details will not be allowed to be revealed in the result
-- | of the function - the compiler will complain about an escaped skolem.
unComponent
  :: forall h f i o m r
   . (forall s act ps. ComponentSpec' h s f act ps i o m -> r)
  -> Component h f i o m
  -> r
unComponent = unsafeCoerce

type ComponentSpec' h s f act ps i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h ps m act) act
  , eval :: HalogenQ f act i ~> HalogenM' s act ps o m
  }

-- | The spec for a component.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra for the component itself
-- | - `ps` is the set of slots for addressing child components
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type ComponentSpec h s f ps i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h ps m (f Unit)) (f Unit)
  , eval :: f ~> HalogenM' s (f Unit) ps o m
  , receiver :: i -> Maybe (f Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

specToSpec
  :: forall h s f ps i o m
   . ComponentSpec h s f ps i o m
  -> ComponentSpec' h s f (f Unit) ps i o m
specToSpec spec =
  { initialState: spec.initialState
  , render: spec.render
  , eval: case _ of
      Initialize a -> traverse_ spec.eval spec.initializer $> a
      Finalize a -> traverse_ spec.eval spec.finalizer $> a
      Receive i a -> traverse_ spec.eval (spec.receiver i) $> a
      Handle fa a -> spec.eval fa $> a
      Request fa -> spec.eval fa
  }

component'
  :: forall h s f g ps i o m
   . ComponentSpec' h s f g ps i o m
  -> Component h f i o m
component' = unsafeCoerce

-- | Builds a component that allows for children.
component
  :: forall h s f ps i o m
   . ComponentSpec h s f ps i o m
  -> Component h f i o m
component = component' <<< specToSpec

-- | Changes the component's `m` type. A use case for this would be to interpret
-- | some `Free` monad as `Aff` so the component can be used with `runUI`.
hoist
  :: forall h f i o m m'
   . Bifunctor h
  => Functor m'
  => (m ~> m')
  -> Component h f i o m
  -> Component h f i o m'
hoist nat = unComponent \c ->
  component'
    { initialState: c.initialState
    , render: lmap (hoistSlot nat) <<< c.render
    , eval: HM.hoist nat <<< c.eval
    }

--------------------------------------------------------------------------------

type ComponentSlot' h f i o ps m a =
  { get :: forall slot. SlotStorage ps slot -> Maybe (slot f o)
  , pop :: forall slot. SlotStorage ps slot -> Maybe (Tuple (slot f o) (SlotStorage ps slot))
  , set :: forall slot. slot f o -> SlotStorage ps slot -> SlotStorage ps slot
  , component :: Component h f i o m
  , input :: forall act. HalogenQ f act i Unit
  , output :: o -> Maybe a
  }

data ComponentSlot (h :: Type -> Type -> Type) (ps :: # Type) (m :: Type -> Type) a

instance functorComponentSlot :: Functor (ComponentSlot h ps m) where
  map f = unComponentSlot \slot -> mkComponentSlot' $ slot { output = map f <$> slot.output }

mkComponentSlot
  :: forall h sym px ps f i o p m a
   . Row.Cons sym (Slot f o p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> Component h f i o m
  -> i
  -> (o -> Maybe a)
  -> ComponentSlot h ps m a
mkComponentSlot sym p comp input output =
  mkComponentSlot' { get, pop, set, component: comp, input: Receive input unit, output }
  where
  get :: forall slot. SlotStorage ps slot -> Maybe (slot f o)
  get = Slot.lookup sym p

  pop :: forall slot. SlotStorage ps slot -> Maybe (Tuple (slot f o) (SlotStorage ps slot))
  pop = Slot.pop sym p

  set :: forall slot. slot f o -> SlotStorage ps slot -> SlotStorage ps slot
  set = Slot.insert sym p

mkComponentSlot'
  :: forall h f i o ps m a
   . ComponentSlot' h f i o ps m a
  -> ComponentSlot h ps m a
mkComponentSlot' = unsafeCoerce

unComponentSlot
  :: forall h ps m a r
   . (forall f i o. ComponentSlot' h f i o ps m a -> r)
  -> ComponentSlot h ps m a
  -> r
unComponentSlot = unsafeCoerce

hoistSlot
  :: forall h m m' ps a
   . Bifunctor h
  => Functor m'
  => (m ~> m')
  -> ComponentSlot h ps m a
  -> ComponentSlot h ps m' a
hoistSlot nat = unComponentSlot \slot ->
  mkComponentSlot' $ slot { component = hoist nat slot.component }

module Halogen.Component
  ( Component
  , ComponentSpec'
  , ComponentSpec
  , component'
  , component
  , unComponent
  , hoist
  , ComponentSlot'
  , ComponentSlot
  , mkComponentSlot
  , mkComponentSlot'
  , unComponentSlot
  , hoistSlot
  ) where

import Prelude

import Data.Bifunctor (class Bifunctor, lmap)
import Data.Foldable (traverse_)
import Data.Maybe (Maybe)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Tuple (Tuple)
import Halogen.Data.Slot (Slot, SlotStorage)
import Halogen.Data.Slot as Slot
import Halogen.Query.HalogenM (HalogenM')
import Halogen.Query.HalogenM as HM
import Halogen.Query.HalogenQ (HalogenQ(..))
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)

-- | The "public" type for a component, with details of the component internals
-- | existentially hidden.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `f` is the query algebra
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
data Component (h :: Type -> Type -> Type) (f :: Type -> Type) i o (m :: Type -> Type)

-- | Exposes the inner details of a component to a function to produce a new
-- | result. The inner details will not be allowed to be revealed in the result
-- | of the function - the compiler will complain about an escaped skolem.
unComponent
  :: forall h f i o m r
   . (forall s act ps. ComponentSpec' h s f act ps i o m -> r)
  -> Component h f i o m
  -> r
unComponent = unsafeCoerce

type ComponentSpec' h s f act ps i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h ps m act) act
  , eval :: HalogenQ f act i ~> HalogenM' s act ps o m
  }

-- | The spec for a component.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra for the component itself
-- | - `ps` is the set of slots for addressing child components
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type ComponentSpec h s f ps i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h ps m (f Unit)) (f Unit)
  , eval :: f ~> HalogenM' s (f Unit) ps o m
  , receiver :: i -> Maybe (f Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

specToSpec
  :: forall h s f ps i o m
   . ComponentSpec h s f ps i o m
  -> ComponentSpec' h s f (f Unit) ps i o m
specToSpec spec =
  { initialState: spec.initialState
  , render: spec.render
  , eval: case _ of
      Initialize a -> traverse_ spec.eval spec.initializer $> a
      Finalize a -> traverse_ spec.eval spec.finalizer $> a
      Receive i a -> traverse_ spec.eval (spec.receiver i) $> a
      Handle fa a -> spec.eval fa $> a
      Request fa -> spec.eval fa
  }

component'
  :: forall h s f g ps i o m
   . ComponentSpec' h s f g ps i o m
  -> Component h f i o m
component' = unsafeCoerce

-- | Builds a component that allows for children.
component
  :: forall h s f ps i o m
   . ComponentSpec h s f ps i o m
  -> Component h f i o m
component = component' <<< specToSpec

-- | Changes the component's `m` type. A use case for this would be to interpret
-- | some `Free` monad as `Aff` so the component can be used with `runUI`.
hoist
  :: forall h f i o m m'
   . Bifunctor h
  => Functor m'
  => (m ~> m')
  -> Component h f i o m
  -> Component h f i o m'
hoist nat = unComponent \c ->
  component'
    { initialState: c.initialState
    , render: lmap (hoistSlot nat) <<< c.render
    , eval: HM.hoist nat <<< c.eval
    }

--------------------------------------------------------------------------------

type ComponentSlot' h g i o ps m a =
  { get :: forall slot. SlotStorage ps slot -> Maybe (slot g o)
  , pop :: forall slot. SlotStorage ps slot -> Maybe (Tuple (slot g o) (SlotStorage ps slot))
  , set :: forall slot. slot g o -> SlotStorage ps slot -> SlotStorage ps slot
  , component :: Component h g i o m
  , input :: forall f act. HalogenQ f act i Unit
  , output :: o -> Maybe a
  }

data ComponentSlot (h :: Type -> Type -> Type) (ps :: # Type) (m :: Type -> Type) a

instance functorComponentSlot :: Functor (ComponentSlot h ps m) where
  map f = unComponentSlot \slot -> mkComponentSlot' $ slot { output = map f <$> slot.output }

mkComponentSlot
  :: forall h sym px ps g i o p m a
   . Row.Cons sym (Slot g o p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> Component h g i o m
  -> i
  -> (o -> Maybe a)
  -> ComponentSlot h ps m a
mkComponentSlot sym p comp input output =
  mkComponentSlot' { get, pop, set, component: comp, input: Receive input unit, output }
  where
  get :: forall slot. SlotStorage ps slot -> Maybe (slot g o)
  get = Slot.lookup sym p

  pop :: forall slot. SlotStorage ps slot -> Maybe (Tuple (slot g o) (SlotStorage ps slot))
  pop = Slot.pop sym p

  set :: forall slot. slot g o -> SlotStorage ps slot -> SlotStorage ps slot
  set = Slot.insert sym p

mkComponentSlot'
  :: forall h g i o ps m a
   . ComponentSlot' h g i o ps m a
  -> ComponentSlot h ps m a
mkComponentSlot' = unsafeCoerce

unComponentSlot
  :: forall h ps m a r
   . (forall g i o. ComponentSlot' h g i o ps m a -> r)
  -> ComponentSlot h ps m a
  -> r
unComponentSlot = unsafeCoerce

hoistSlot
  :: forall h m m' ps a
   . Bifunctor h
  => Functor m'
  => (m ~> m')
  -> ComponentSlot h ps m a
  -> ComponentSlot h ps m' a
hoistSlot nat = unComponentSlot \slot ->
  mkComponentSlot' $ slot { component = hoist nat slot.component }


[CSE-172] Fix travis build

[CSE-172] Fix travis build

* it seems that few sources are lost while merging before

-- | Detail page of a `genesis block` https://cardanodocs.com/technical/blocks/#genesis-block

module Explorer.View.GenesisBlock
    ( genesisBlockView
    , maxAddressInfoRows
    )
    where

import Prelude

import Data.Array (null)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cGenesis, cAddress, cAddresses, cAddressIsRedeemed, cAll, cOf, common, cLoading, cNo, cSummary, cYes, gblAddressesError, gblAddressesNotFound, gblAddressRedeemAmount, gblAddressIsRedeemed, gblAddressIsNotRedeemed, gblNotFound, gblNumberRedeemedAddresses, gblNumberAddressesToRedeem, gblNumberRedeemedAmount, gblNumberAmountToRedeem, genesisBlock) as I18nL
import Explorer.Lenses.State (currentCGenesisAddressInfos, currentCGenesisSummary, gblAddressInfosPageNumber, gblAddressInfosPagination, gblAddressInfosPaginationEditable, gblLoadingAddressInfosPagination, gblAddressInfosMaxPageNumber, genesisBlockViewState, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CGenesisAddressInfos, GenesisBlockPagination(..), PageNumber(..), State)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, paginationView)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.ClientTypes (CGenesisAddressInfo(..), CGenesisSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, cgaiCardanoAddress, cgaiGenesisAmount, cgaiIsRedeemed, cgsAmountRedeemed, cgsAmountRemaining, cgsNumRedeemed, cgsNumRemaining)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Text.Smolder.HTML (a, div, h3, li, p, span, ul) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup ((!), (#!))
import Text.Smolder.Markup (text) as S

genesisBlockView :: State -> P.HTML Action
genesisBlockView state =
    let lang' = state ^. lang
    in
    S.div ! S.className "explorer-genesis"$ do
        S.div ! S.className "explorer-genesis__wrapper"
              $ S.div ! S.className "explorer-genesis__container" $ do
                    S.h3  ! S.className "headline"
                        $ S.text (translate (I18nL.common <<< I18nL.cGenesis) lang')
                    case state ^. currentCGenesisSummary of
                        NotAsked  -> emptyView ""
                        Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                        Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblNotFound) lang'
                        Success summary -> summaryView summary state

        S.div ! S.className "explorer-genesis__wrapper" $ do
            S.div ! S.className "explorer-genesis__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cAddresses) lang')
                case state ^. currentCGenesisAddressInfos of
                    NotAsked  -> emptyView ""
                    Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                    Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesError) lang'
                    Success infos -> addressInfosView infos state

emptyView :: String -> P.HTML Action
emptyView message =
    S.div ! S.className "summary-empty__container"
          $ S.text message

type SummaryRowItem =
    { key :: String
    , label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: State -> CGenesisSummary -> SummaryItems
mkSummaryItems state (CGenesisSummary summary) =
    let lang' = state ^. lang in
    [ { key: "0"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAddresses) lang'
      , amount: show $ summary ^. cgsNumRedeemed
      , mCurrency: Nothing
      }
    , { key: "2"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberAddressesToRedeem) lang'
      , amount: show $ summary ^. cgsNumRemaining
      , mCurrency: Nothing
      }
    , { key: "3"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAmount) lang'
      , amount: formatADA (summary ^. cgsAmountRedeemed) lang'
      , mCurrency: Just ADA
      }
    , { key: "4"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberAmountToRedeem) lang'
      , amount: formatADA (summary ^. cgsAmountRemaining) lang'
      , mCurrency: Just ADA
      }

    ]

summaryRow :: SummaryRowItem -> P.HTML Action
summaryRow item =
    S.div
        ! S.className "row row__summary"
        ! P.key item.key
        $ do
            S.div ! S.className "column column__label"
                  $ S.text item.label
            S.div ! S.className "column column__amount"
                  $ S.span  ! S.className (currencyCSSClass item.mCurrency)
                            $ S.text item.amount

summaryView :: CGenesisSummary -> State -> P.HTML Action
summaryView summary state =
    S.div ! S.className "summary-wrapper" $ do
        S.div ! S.className "summary-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cSummary) $ state ^. lang)
            S.div $ for_ (mkSummaryItems state summary) summaryRow

type AddressInfosHeaderProps =
    { label :: String
    , clazz :: String
    }

mkAddressInfosHeaderProps :: Language -> Array AddressInfosHeaderProps
mkAddressInfosHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cAddress) lang
      , clazz: "hash"
      }
    , { label: translate (I18nL.genesisBlock <<< I18nL.gblAddressRedeemAmount) lang
      , clazz: "amount"
      }
    , { label: translate (I18nL.common <<< I18nL.cAddressIsRedeemed) lang
      , clazz: "redeemed"
      }
    ]

addressInfosFilterView :: State -> P.HTML Action
addressInfosFilterView state =
    let pagination = state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
        lang' = state ^. lang
    in
    S.ul ! S.className "address-infos__filter-nav"
          $ do
          addressInfosFilterItemView
              (translate (I18nL.common <<< I18nL.cAll) lang')
              GBPaginateAllAddresses
              pagination
          addressInfosFilterItemView
              (translate (I18nL.genesisBlock <<< I18nL.gblAddressIsRedeemed) lang')
              GBPaginateRedeemedAddresses
              pagination
          addressInfosFilterItemView
              (translate (I18nL.genesisBlock <<< I18nL.gblAddressIsNotRedeemed) lang')
              GBPaginateNonRedeemedAddresses
              pagination

addressInfosFilterItemView :: String -> GenesisBlockPagination -> GenesisBlockPagination -> P.HTML Action
addressInfosFilterItemView label pagination currentPagination =
    S.li  ! S.className ("address-infos__filter-nav--item"
                            <> if (currentPagination == pagination)
                                  then " selected"
                                  else ""
                        )
          #! P.onClick (const $ GenesisBlockFilterAddressInfos pagination)
          $ S.text label

addressInfosHeaderView :: Language -> P.HTML Action
addressInfosHeaderView lang =
    S.div ! S.className "address-infos__header"
          $ for_ (mkAddressInfosHeaderProps lang) addressInfosHeaderItemView

addressInfosHeaderItemView :: AddressInfosHeaderProps -> P.HTML Action
addressInfosHeaderItemView props =
    S.div ! S.className props.clazz
          $ S.text props.label

addressInfosBodyView :: Language -> CGenesisAddressInfo -> P.HTML Action
addressInfosBodyView lang (CGenesisAddressInfo info) =
    let addrLink = toUrl $ Address (info ^. cgaiCardanoAddress) in
    S.div ! S.className "address-infos__body--row"
          $ do
          -- hash
          S.a ! S.className "address-infos__body--column hash"
              ! S.href addrLink
              #! P.onClick (Navigate addrLink)
              $ S.text (info ^. (cgaiCardanoAddress <<< _CAddress))
          -- amount
          S.div ! S.className "address-infos__body--column amount"
                $ S.span ! S.className (currencyCSSClass $ Just ADA)
                          $ S.text (formatADA (info ^. cgaiGenesisAmount) lang)
          -- is redeemed
          S.div ! S.className "address-infos__body--column redeemed"
                $ S.text (if (info ^. cgaiIsRedeemed)
                              then translate (I18nL.common <<< I18nL.cYes) lang
                              else translate (I18nL.common <<< I18nL.cNo) lang)

maxAddressInfoRows :: Int
maxAddressInfoRows = 5

addressInfosView :: CGenesisAddressInfos -> State -> P.HTML Action
addressInfosView infos state = do
    S.div
        ! S.className "address-infos__wrapper"
        $ do
            addressInfosFilterView state
            addressInfosHeaderView lang'
            S.div ! S.className "address-infos__body--wrapper"
                  $ do
                  if null infos
                      then emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesNotFound) lang'
                      else for_ infos (addressInfosBodyView lang')
                  S.div ! S.className ("address-infos__body--cover" <>  if isLoading then " show" else "")
                        $ S.p ! S.className "address-infos__body--cover-label"
                              $ S.text (translate (I18nL.common <<< I18nL.cLoading) lang')
    S.div
        ! S.className "address-infos__footer"
        $  paginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                            , currentPage: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPageNumber)
                            , minPage: PageNumber minPagination
                            , maxPage: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosMaxPageNumber)
                            , changePageAction: GenesisBlockPaginateAddresses
                            , editable: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPaginationEditable)
                            , editableAction: GenesisBlockEditAddressesPageNumber
                            , invalidPageAction: GenesisBlockInvalidAddressesPageNumber
                            , disabled: isLoading
                            }
    where
        lang' = state ^. lang
        isLoading = state ^. (viewStates <<< genesisBlockViewState <<< gblLoadingAddressInfosPagination)

-- | Detail page of a `genesis block` https://cardanodocs.com/technical/blocks/#genesis-block

module Explorer.View.GenesisBlock
    ( genesisBlockView
    , maxAddressInfoRows
    )
    where

import Prelude

import Data.Array (null)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cGenesis, cAddress, cAddresses, cAll, cOf, common, cLoading, cNo, cSummary, cYes, gblAddressesError, gblAddressesNotFound, gblAddressRedeemAmount, gblAddressIsRedeemed, gblAddressIsNotRedeemed, gblNotFound, gblNumberRedeemedAddresses, gblNumberAddressesToRedeem, gblNumberRedeemedAmount, gblNumberAmountToRedeem, genesisBlock, cAddressIsRedeemed) as I18nL
import Explorer.Lenses.State (currentCGenesisAddressInfos, currentCGenesisSummary, gblAddressInfosPageNumber, gblAddressInfosPagination, gblAddressInfosPaginationEditable, gblLoadingAddressInfosPagination, gblAddressInfosMaxPageNumber, genesisBlockViewState, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CGenesisAddressInfos, GenesisBlockPagination(..), PageNumber(..), State)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, paginationView)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.ClientTypes (CGenesisAddressInfo(..), CGenesisSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, cgaiCardanoAddress, cgaiGenesisAmount, cgaiIsRedeemed, cgsAmountRedeemed, cgsAmountRemaining, cgsNumRedeemed, cgsNumRemaining)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Text.Smolder.HTML (a, div, h3, li, p, span, ul) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup ((!), (#!))
import Text.Smolder.Markup (text) as S

genesisBlockView :: State -> P.HTML Action
genesisBlockView state =
    let lang' = state ^. lang
    in
    S.div ! S.className "explorer-genesis"$ do
        S.div ! S.className "explorer-genesis__wrapper"
              $ S.div ! S.className "explorer-genesis__container" $ do
                    S.h3  ! S.className "headline"
                        $ S.text (translate (I18nL.common <<< I18nL.cGenesis) lang')
                    case state ^. currentCGenesisSummary of
                        NotAsked  -> emptyView ""
                        Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                        Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblNotFound) lang'
                        Success summary -> summaryView summary state

        S.div ! S.className "explorer-genesis__wrapper" $ do
            S.div ! S.className "explorer-genesis__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cAddresses) lang')
                case state ^. currentCGenesisAddressInfos of
                    NotAsked  -> emptyView ""
                    Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                    Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesError) lang'
                    Success infos -> addressInfosView infos state

emptyView :: String -> P.HTML Action
emptyView message =
    S.div ! S.className "summary-empty__container"
          $ S.text message

type SummaryRowItem =
    { key :: String
    , label :: String
    , amount :: String
    , mCurrency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: State -> CGenesisSummary -> SummaryItems
mkSummaryItems state (CGenesisSummary summary) =
    let lang' = state ^. lang in
    [ { id: "0"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAddresses) lang'
      , amount: show $ summary ^. cgsNumRedeemed
      , mCurrency: Nothing
      }
    , { id: "2"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberAddressesToRedeem) lang'
      , amount: show $ summary ^. cgsNumRemaining
      , mCurrency: Nothing
      }
    , { id: "3"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAmount) lang'
      , amount: formatADA (summary ^. cgsAmountRedeemed) lang'
      , mCurrency: Just ADA
      }
    , { id: "4"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberAmountToRedeem) lang'
      , amount: formatADA (summary ^. cgsAmountRemaining) lang'
      , mCurrency: Just ADA
      }

    ]

summaryRow :: SummaryRowItem -> P.HTML Action
summaryRow item =
    S.div
        ! S.className "row row__summary"
        ! P.key item.key
        $ do
            S.div ! S.className "column column__label"
                  $ S.text item.label
            S.div ! S.className "column column__amount"
                  $ S.span  ! S.className (currencyCSSClass item.mCurrency)
                            $ S.text item.amount

summaryView :: CGenesisSummary -> State -> P.HTML Action
summaryView summary state =
    S.div ! S.className "summary-wrapper" $ do
        S.div ! S.className "summary-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cSummary) $ state ^. lang)
            S.div $ for_ (mkSummaryItems state summary) summaryRow

type AddressInfosHeaderProps =
    { label :: String
    , clazz :: String
    }

mkAddressInfosHeaderProps :: Language -> Array AddressInfosHeaderProps
mkAddressInfosHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cAddress) lang
      , clazz: "hash"
      }
    , { label: translate (I18nL.genesisBlock <<< I18nL.gblAddressRedeemAmount) lang
      , clazz: "amount"
      }
    , { label: translate (I18nL.common <<< I18nL.cAddressIsRedeemed) lang
      , clazz: "redeemed"
      }
    ]

addressInfosFilterView :: State -> P.HTML Action
addressInfosFilterView state =
    let pagination = state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
        lang' = state ^. lang
    in
    S.ul ! S.className "address-infos__filter-nav"
          $ do
          addressInfosFilterItemView
              (translate (I18nL.common <<< I18nL.cAll) lang')
              GBPaginateAllAddresses
              pagination
          addressInfosFilterItemView
              (translate (I18nL.genesisBlock <<< I18nL.gblAddressIsRedeemed) lang')
              GBPaginateRedeemedAddresses
              pagination
          addressInfosFilterItemView
              (translate (I18nL.genesisBlock <<< I18nL.gblAddressIsNotRedeemed) lang')
              GBPaginateNonRedeemedAddresses
              pagination

addressInfosFilterItemView :: String -> GenesisBlockPagination -> GenesisBlockPagination -> P.HTML Action
addressInfosFilterItemView label pagination currentPagination =
    S.li  ! S.className ("address-infos__filter-nav--item"
                            <> if (currentPagination == pagination)
                                  then " selected"
                                  else ""
                        )
          #! P.onClick (const $ GenesisBlockFilterAddressInfos pagination)
          $ S.text label

addressInfosHeaderView :: Language -> P.HTML Action
addressInfosHeaderView lang =
    S.div ! S.className "address-infos__header"
          $ for_ (mkAddressInfosHeaderProps lang) addressInfosHeaderItemView

addressInfosHeaderItemView :: AddressInfosHeaderProps -> P.HTML Action
addressInfosHeaderItemView props =
    S.div ! S.className props.clazz
          $ S.text props.label

addressInfosBodyView :: Language -> CGenesisAddressInfo -> P.HTML Action
addressInfosBodyView lang (CGenesisAddressInfo info) =
    let addrLink = toUrl $ Address (info ^. cgaiCardanoAddress) in
    S.div ! S.className "address-infos__body--row"
          $ do
          -- hash
          S.a ! S.className "address-infos__body--column hash"
              ! S.href addrLink
              #! P.onClick (Navigate addrLink)
              $ S.text (info ^. (cgaiCardanoAddress <<< _CAddress))
          -- amount
          S.div ! S.className "address-infos__body--column amount"
                $ S.span ! S.className (currencyCSSClass $ Just ADA)
                          $ S.text (formatADA (info ^. cgaiGenesisAmount) lang)
          -- is redeemed
          S.div ! S.className "address-infos__body--column redeemed"
                $ S.text (if (info ^. cgaiIsRedeemed)
                              then translate (I18nL.common <<< I18nL.cYes) lang
                              else translate (I18nL.common <<< I18nL.cNo) lang)

maxAddressInfoRows :: Int
maxAddressInfoRows = 5

addressInfosView :: CGenesisAddressInfos -> State -> P.HTML Action
addressInfosView infos state = do
    S.div
        ! S.className "address-infos__wrapper"
        $ do
            addressInfosFilterView state
            addressInfosHeaderView lang'
            S.div ! S.className "address-infos__body--wrapper"
                  $ do
                  if null infos
                      then emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesNotFound) lang'
                      else for_ infos (addressInfosBodyView lang')
                  S.div ! S.className ("address-infos__body--cover" <>  if isLoading then " show" else "")
                        $ S.p ! S.className "address-infos__body--cover-label"
                              $ S.text (translate (I18nL.common <<< I18nL.cLoading) lang')
    S.div
        ! S.className "address-infos__footer"
        $  paginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                            , currentPage: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPageNumber)
                            , minPage: PageNumber minPagination
                            , maxPage: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosMaxPageNumber)
                            , changePageAction: GenesisBlockPaginateAddresses
                            , editable: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPaginationEditable)
                            , editableAction: GenesisBlockEditAddressesPageNumber
                            , invalidPageAction: GenesisBlockInvalidAddressesPageNumber
                            , disabled: isLoading
                            }
    where
        lang' = state ^. lang
        isLoading = state ^. (viewStates <<< genesisBlockViewState <<< gblLoadingAddressInfosPagination)


Drop the constrains

Drop the constrains

module Example.Interpret.Main where

import Prelude

import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.Trans.Class (lift)
import Data.Maybe (Maybe(..), fromMaybe)
import Effect (Effect)
import Effect.Aff (Aff)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.VDom.Driver (runUI)
import Network.HTTP.Affjax as AX
import Network.HTTP.Affjax.Response as AXResponse

type Config = { githubToken :: Maybe String }

type State = { userData :: Maybe String }

data Action = FetchData

ui :: forall f i o. H.Component HH.HTML f i o (ReaderT Config Aff)
ui =
  H.mkComponent
    { initialState: const initialState
    , render
    , eval: H.mkEval (H.defaultEval { handleAction = handleAction })
    }
  where

  initialState :: State
  initialState = { userData: Nothing }

  render :: forall m. State -> H.ComponentHTML Action () m
  render state =
    HH.div_
      [ HH.h1_
          [ HH.text "Fetch user data" ]
      , HH.button
          [ HE.onClick \_ -> Just FetchData ]
          [ HH.text "Fetch" ]
      , HH.p_
          [ HH.text (fromMaybe "No user data" state.userData) ]
      ]

searchUser :: String -> ReaderT Config Aff String
searchUser q = do
  { githubToken } <- ask
  { response } <- case githubToken of
    Nothing ->
      lift (AX.get AXResponse.string ("https://api.github.com/users/" <> q))
    Just token ->
      lift (AX.get AXResponse.string ("https://api.github.com/users/" <> q <> "?access_token=" <> token))
  pure response

handleAction :: forall o. Action -> H.HalogenM State Action () o (ReaderT Config Aff) Unit
handleAction = case _ of
  FetchData -> do
    userData <- lift (searchUser "kRITZCREEK")
    H.put { userData: Just userData }

ui' :: forall f i o. H.Component HH.HTML f i o Aff
ui' = H.hoist (\app -> runReaderT app { githubToken: Nothing }) ui

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  runUI ui' unit body

module Example.Interpret.Main where

import Prelude

import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.Trans.Class (lift)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (class Newtype)
import Effect (Effect)
import Effect.Aff (Aff)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.VDom.Driver (runUI)
import Network.HTTP.Affjax as AX
import Network.HTTP.Affjax.Response as AXResponse

type Env = { githubToken :: Maybe String }

newtype App a = App (ReaderT Env Aff a)
derive instance newtypeApp ∷ Newtype (App a) _
derive newtype instance functorApp ∷ Functor App
derive newtype instance applyApp ∷ Apply App
derive newtype instance applicativeApp ∷ Applicative App
derive newtype instance bindApp ∷ Bind App
derive newtype instance monadApp ∷ Monad App

runApp :: forall a. Env -> App a -> Aff a
runApp env (App app) = runReaderT app env

class Monad m <= GithubAPI m where
  searchUser ∷ String → m String

instance githubAPI ∷ GithubAPI App where
  searchUser q = App do
    { githubToken } <- ask
    { response } <- case githubToken of
      Nothing ->
        lift $ AX.get AXResponse.string ("https://api.github.com/users/" <> q)
      Just token ->
        lift $ AX.get AXResponse.string ("https://api.github.com/users/" <> q <> "?access_token=" <> token)
    pure response

type State = { userData :: Maybe String }

data Action = FetchData

ui :: forall f i o m. GithubAPI m => H.Component HH.HTML f i o m
ui =
  H.mkComponent
    { initialState: const initialState
    , render
    , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
    }
  where

  initialState :: State
  initialState = { userData: Nothing }

  render :: State -> H.ComponentHTML Action () m
  render state =
    HH.div_
      [ HH.h1_
          [ HH.text "Fetch user data" ]
      , HH.button
          [ HE.onClick \_ -> Just FetchData ]
          [ HH.text "Fetch" ]
      , HH.p_
          [ HH.text (fromMaybe "No user data" state.userData) ]
      ]

handleAction :: forall o m. GithubAPI m => Action -> H.HalogenM State Action () o m Unit
handleAction = case _ of
  FetchData -> do
    userData <- lift $ searchUser "kRITZCREEK"
    H.put { userData: Just userData }

ui' :: forall f i o. H.Component HH.HTML f i o Aff
ui' = H.hoist (runApp { githubToken: Nothing }) ui

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  runUI ui' unit body