Forbid a few names as class names

Forbid a few names as class names

Original commit 6f8ef1b4c4d31e7a2c6779d038c3682c380adf27

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude
import Types

import Data.Array (concatMap)
import Data.Char (toCharCode)
import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter, isPrint)
import Data.Foldable (find, for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, intToHex)
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)

data CSInfo = CSInfo { classNames ::  Map Int String, unionNames :: Map (Set IRType) String, unions :: List (Set IRType) }

type CSDoc = Doc CSInfo

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

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , render: renderGraphToCSharp
    }

renderGraphToCSharp :: IRGraph -> String
renderGraphToCSharp graph =
    let classes = classesInGraph graph
        classNames = transformNames nameForClass nextNameToTry (S.fromFoldable forbiddenNames) classes
        unions = L.fromFoldable $ filterTypes unionPredicate graph
        unionNames = transformNames (unionName classNames graph) nextNameToTry (S.fromFoldable $ M.values classNames) $ map (\s -> Tuple s s) unions
    in
        runDoc csharpDoc graph (CSInfo { classNames, unionNames, unions })
    where
        unionPredicate =
            case _ of
            IRUnion s ->
                if isNothing $ nullableFromSet s then
                    Just s
                else
                    Nothing
            _ -> Nothing
        nameForClass (IRClassData { names }) =
            csNameStyle $ combineNames names
        nextNameToTry s =
            "Other" <> s

unionName :: Map Int String -> IRGraph -> Set IRType -> String
unionName classNames graph s =
    "OneOf" <> (csNameStyle $ intercalate "_" $ map (typeNameForUnion classNames graph) $ L.sort $ L.fromFoldable s)

getClassNames :: CSDoc (Map Int String)
getClassNames = do
    CSInfo { classNames } <- getRendererInfo
    pure classNames

getUnions :: CSDoc (List (Set IRType))
getUnions = do
    CSInfo { unions } <- getRendererInfo
    pure unions

getUnionNames :: CSDoc (Map (Set IRType) String)
getUnionNames = do
    CSInfo { unionNames } <- getRendererInfo
    pure unionNames

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

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

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

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

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

stringify :: String -> String
stringify str =
    "\"" <> (Str.fromCharArray $ concatMap charRep $ Str.toCharArray str) <> "\""
    where
        charRep c =
            case c of
            '\\' -> ['\\', '\\']
            '\"' -> ['\\', '\"']
            '\n' -> ['\\', 'n']
            '\t' -> ['\\', 't']
            _ ->
                if isPrint c then
                    [c]
                else
                    let i = toCharCode c
                    in
                        if i <= 0xffff then
                            Str.toCharArray $ "\\u" <> intToHex 4 i
                        else
                            Str.toCharArray $ "\\U" <> intToHex 8 i

nullableFromSet :: Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

renderUnionToCSharp :: Set IRType -> CSDoc String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderTypeToCSharp x
        pure if isValueType x then rendered <> "?" else rendered
    Nothing -> lookupUnionName s

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> CSDoc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: Set IRType -> CSDoc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

renderTypeToCSharp :: IRType -> CSDoc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object"
    IRNull -> pure "object"
    IRInteger -> pure "int"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion types -> renderUnionToCSharp types

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

typeNameForUnion :: Map Int String -> IRGraph -> IRType -> String
typeNameForUnion classNames graph = case _ of
    IRNothing -> "nothing"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion classNames graph a <> "_array"
    IRClass i ->
        let IRClassData { names } = getClassFromGraph graph i
        in
            combineNames names
    IRMap t -> typeNameForUnion classNames graph t <> "_map"
    IRUnion _ -> "union"

csharpDoc :: CSDoc Unit
csharpDoc = do
    lines """// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do:
             //
             //   var data = QuickType.Converter.FromJson(jsonString);
             //
             namespace QuickType
             {"""
    blank
    indent do
        lines """using System;
                 using System.Net;
                 using System.Collections.Generic;

                 using Newtonsoft.Json;"""
        blank
        renderJsonConverter
        blank
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderCSharpClass cd className
            blank
        unions <- getUnions
        for_ unions \types -> do
            renderCSharpUnion types
            blank
    lines "}"

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

renderJsonConverter :: CSDoc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    lines $ "class Converter" <> stringIfTrue haveUnions " : JsonConverter" <> " {"
    indent do
        IRGraph { toplevel } <- getGraph
        toplevelType <- renderTypeToCSharp toplevel
        lines "// Loading helpers"
        let converterParam = stringIfTrue haveUnions ", new Converter()"
        lines
            $ "public static "
            <> toplevelType
            <> " FromJson(string json) => JsonConvert.DeserializeObject<"
            <> toplevelType
            <> ">(json"
            <> converterParam
            <> ");"

        when haveUnions do
            blank
            lines "public override bool CanConvert(Type t) {"
            indent $ lines $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            lines "}"
            blank
            lines "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer) {"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    lines $ "if (t == typeof(" <> name <> "))"
                    indent $ lines $ "return new " <> name <> "(reader, serializer);"
                lines "throw new Exception(\"Unknown type\");"
            lines "}"
            blank
            lines "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer) {"
            indent $ lines "throw new NotImplementedException();"
            lines "}"
            blank
            lines "public override bool CanWrite { get { return false; } }"
    lines "}"

tokenCase :: String -> CSDoc Unit
tokenCase tokenType =
    lines $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Set IRType -> CSDoc Unit
renderNullDeserializer types =
    when (S.member IRNull types) do
        tokenCase "Null"
        indent do
            lines "break;"

unionFieldName :: IRType -> CSDoc String
unionFieldName t = do
    classNames <- getClassNames
    graph <- getGraph
    let typeName = typeNameForUnion classNames graph t
    pure $ csNameStyle typeName

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

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

renderPrimitiveDeserializer :: String -> IRType -> Set IRType -> CSDoc Unit
renderPrimitiveDeserializer tokenType t types =
    when (S.member t types) do
        tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: Set IRType -> CSDoc Unit
renderDoubleDeserializer types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

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

renderCSharpUnion :: Set IRType -> CSDoc Unit
renderCSharpUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    graph <- getGraph
    line $ words ["struct", name, "{"]
    indent do
        for_ nonNullTypes \t -> do
            typeString <- renderTypeToCSharp $ IRUnion $ S.union (S.singleton t) (S.singleton IRNull)
            field <- unionFieldName t
            lines $ "public " <> typeString <> " " <> field <> ";"
        blank
        lines $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer) {"
        indent do
            for_ (L.fromFoldable nonNullTypes) \field -> do
                fieldName <- unionFieldName field
                lines $ fieldName <> " = null;"
            lines "switch (reader.TokenType) {"
            indent do
                renderNullDeserializer allTypes
                renderPrimitiveDeserializer "Integer" IRInteger allTypes
                renderDoubleDeserializer allTypes
                renderPrimitiveDeserializer "Boolean" IRBool allTypes
                renderPrimitiveDeserializer "String" IRString allTypes
                renderGenericDeserializer isArray "StartArray" allTypes
                renderGenericDeserializer isClass "StartObject" allTypes
                renderGenericDeserializer isMap "StartObject" allTypes
                lines $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            lines "}"
        lines "}"
    lines "}"

renderCSharpClass :: IRClassData -> String -> CSDoc Unit
renderCSharpClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames csNameStyle ("Other" <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ words ["class", className]

    lines "{"
    indent do
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            line do
                string "[JsonProperty("
                string $ stringify pname
                string ")]"
            line do
                string "public "
                rendered <- renderTypeToCSharp ptype
                string rendered
                let csPropName = lookupName pname propertyNames
                words ["", csPropName, "{ get; set; }"]
            blank
    lines "}"

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude
import Types

import Data.Array (concatMap)
import Data.Char (toCharCode)
import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter, isPrint)
import Data.Foldable (find, for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, intToHex)
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)

data CSInfo = CSInfo { classNames ::  Map Int String, unionNames :: Map (Set IRType) String, unions :: List (Set IRType) }

type CSDoc = Doc CSInfo

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , render: renderGraphToCSharp
    }

renderGraphToCSharp :: IRGraph -> String
renderGraphToCSharp graph =
    let classes = classesInGraph graph
        classNames = transformNames nameForClass nextNameToTry (S.singleton "Converter") classes
        unions = L.fromFoldable $ filterTypes unionPredicate graph
        unionNames = transformNames (unionName classNames graph) nextNameToTry (S.fromFoldable $ M.values classNames) $ map (\s -> Tuple s s) unions
    in
        runDoc csharpDoc graph (CSInfo { classNames, unionNames, unions })
    where
        unionPredicate =
            case _ of
            IRUnion s ->
                if isNothing $ nullableFromSet s then
                    Just s
                else
                    Nothing
            _ -> Nothing
        nameForClass (IRClassData { names }) =
            csNameStyle $ combineNames names
        nextNameToTry s =
            "Other" <> s

unionName :: Map Int String -> IRGraph -> Set IRType -> String
unionName classNames graph s =
    "OneOf" <> (csNameStyle $ intercalate "_" $ map (typeNameForUnion classNames graph) $ L.sort $ L.fromFoldable s)

getClassNames :: CSDoc (Map Int String)
getClassNames = do
    CSInfo { classNames } <- getRendererInfo
    pure classNames

getUnions :: CSDoc (List (Set IRType))
getUnions = do
    CSInfo { unions } <- getRendererInfo
    pure unions

getUnionNames :: CSDoc (Map (Set IRType) String)
getUnionNames = do
    CSInfo { unionNames } <- getRendererInfo
    pure unionNames

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

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

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

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

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

stringify :: String -> String
stringify str =
    "\"" <> (Str.fromCharArray $ concatMap charRep $ Str.toCharArray str) <> "\""
    where
        charRep c =
            case c of
            '\\' -> ['\\', '\\']
            '\"' -> ['\\', '\"']
            '\n' -> ['\\', 'n']
            '\t' -> ['\\', 't']
            _ ->
                if isPrint c then
                    [c]
                else
                    let i = toCharCode c
                    in
                        if i <= 0xffff then
                            Str.toCharArray $ "\\u" <> intToHex 4 i
                        else
                            Str.toCharArray $ "\\U" <> intToHex 8 i

nullableFromSet :: Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

renderUnionToCSharp :: Set IRType -> CSDoc String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderTypeToCSharp x
        pure if isValueType x then rendered <> "?" else rendered
    Nothing -> lookupUnionName s

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> CSDoc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: Set IRType -> CSDoc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

renderTypeToCSharp :: IRType -> CSDoc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object"
    IRNull -> pure "object"
    IRInteger -> pure "int"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion types -> renderUnionToCSharp types

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

typeNameForUnion :: Map Int String -> IRGraph -> IRType -> String
typeNameForUnion classNames graph = case _ of
    IRNothing -> "nothing"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion classNames graph a <> "_array"
    IRClass i ->
        let IRClassData { names } = getClassFromGraph graph i
        in
            combineNames names
    IRMap t -> typeNameForUnion classNames graph t <> "_map"
    IRUnion _ -> "union"

csharpDoc :: CSDoc Unit
csharpDoc = do
    lines """// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do:
             //
             //   var data = QuickType.Converter.FromJson(jsonString);
             //
             namespace QuickType
             {"""
    blank
    indent do
        lines """using System;
                 using System.Net;
                 using System.Collections.Generic;

                 using Newtonsoft.Json;"""
        blank
        renderJsonConverter
        blank
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderCSharpClass cd className
            blank
        unions <- getUnions
        for_ unions \types -> do
            renderCSharpUnion types
            blank
    lines "}"

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

renderJsonConverter :: CSDoc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    lines $ "class Converter" <> stringIfTrue haveUnions " : JsonConverter" <> " {"
    indent do
        IRGraph { toplevel } <- getGraph
        toplevelType <- renderTypeToCSharp toplevel
        lines "// Loading helpers"
        let converterParam = stringIfTrue haveUnions ", new Converter()"
        lines
            $ "public static "
            <> toplevelType
            <> " FromJson(string json) => JsonConvert.DeserializeObject<"
            <> toplevelType
            <> ">(json"
            <> converterParam
            <> ");"

        when haveUnions do
            blank
            lines "public override bool CanConvert(Type t) {"
            indent $ lines $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            lines "}"
            blank
            lines "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer) {"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    lines $ "if (t == typeof(" <> name <> "))"
                    indent $ lines $ "return new " <> name <> "(reader, serializer);"
                lines "throw new Exception(\"Unknown type\");"
            lines "}"
            blank
            lines "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer) {"
            indent $ lines "throw new NotImplementedException();"
            lines "}"
            blank
            lines "public override bool CanWrite { get { return false; } }"
    lines "}"

tokenCase :: String -> CSDoc Unit
tokenCase tokenType =
    lines $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Set IRType -> CSDoc Unit
renderNullDeserializer types =
    when (S.member IRNull types) do
        tokenCase "Null"
        indent do
            lines "break;"

unionFieldName :: IRType -> CSDoc String
unionFieldName t = do
    classNames <- getClassNames
    graph <- getGraph
    let typeName = typeNameForUnion classNames graph t
    pure $ csNameStyle typeName

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

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

renderPrimitiveDeserializer :: String -> IRType -> Set IRType -> CSDoc Unit
renderPrimitiveDeserializer tokenType t types =
    when (S.member t types) do
        tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: Set IRType -> CSDoc Unit
renderDoubleDeserializer types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

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

renderCSharpUnion :: Set IRType -> CSDoc Unit
renderCSharpUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    graph <- getGraph
    line $ words ["struct", name, "{"]
    indent do
        for_ nonNullTypes \t -> do
            typeString <- renderTypeToCSharp $ IRUnion $ S.union (S.singleton t) (S.singleton IRNull)
            field <- unionFieldName t
            lines $ "public " <> typeString <> " " <> field <> ";"
        blank
        lines $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer) {"
        indent do
            for_ (L.fromFoldable nonNullTypes) \field -> do
                fieldName <- unionFieldName field
                lines $ fieldName <> " = null;"
            lines "switch (reader.TokenType) {"
            indent do
                renderNullDeserializer allTypes
                renderPrimitiveDeserializer "Integer" IRInteger allTypes
                renderDoubleDeserializer allTypes
                renderPrimitiveDeserializer "Boolean" IRBool allTypes
                renderPrimitiveDeserializer "String" IRString allTypes
                renderGenericDeserializer isArray "StartArray" allTypes
                renderGenericDeserializer isClass "StartObject" allTypes
                renderGenericDeserializer isMap "StartObject" allTypes
                lines $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            lines "}"
        lines "}"
    lines "}"

renderCSharpClass :: IRClassData -> String -> CSDoc Unit
renderCSharpClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames csNameStyle ("Other" <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ words ["class", className]

    lines "{"
    indent do
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            line do
                string "[JsonProperty("
                string $ stringify pname
                string ")]"
            line do
                string "public "
                rendered <- renderTypeToCSharp ptype
                string rendered
                let csPropName = lookupName pname propertyNames
                words ["", csPropName, "{ get; set; }"]
            blank
    lines "}"


Add header

Add header

{-
Copyright 2017 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Header.Attribution where

import SlamData.Prelude
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B
import SlamData.Render.Icon as I

render ∷ ∀ p i . H.Action i → H.HTML p i
render dismiss =
  HH.div
    [ HP.classes [ HH.ClassName "sd-attributions" ] ]
    [ HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-backdrop" ]
        , HE.onMouseDown (HE.input_ dismiss)
        ]
        []
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog" ] ]
        [ HH.div_
            [ HH.h4_ [ HH.text "Attributions"]
            , HH.div
                [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
                [ attributions ]
            , HH.div
                [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
                [ HH.button
                    [ HP.classes [ B.btn ]
                    , HE.onClick (HE.input_ dismiss)
                    ]
                    [ HH.text "Done" ]
                ]
            ]
        ]
    ]

attributions ∷ ∀ p i. HH.HTML p i
attributions = HH.dl_ $ flip foldMap I.attributions \(title × names) →
  [ HH.dt_ [ HH.text title ] ] <> map (\n → HH.dd_ [ HH.text n ]) names


Remove unused Proxy import

Remove unused Proxy import

module Network.HTTP.Affjax.Response
  ( ResponseType(), responseTypeToString
  , ResponseContent()
  , Respondable, responseType, fromResponse
  ) where

import Control.Bind ((>=>))
import Data.Either (Either(..))
import Data.Foreign (Foreign(), F(), readString, parseJSON, unsafeReadTagged)
import DOM (Document())
import DOM.File (Blob())
import DOM.XHR (FormData())
import qualified Data.ArrayBuffer.Types as A

-- | Valid response types for an AJAX request. This is used to determine the
-- | `ResponseContent` type for a request. The `a` type variable is a phantom
-- | type used to associate the `ResponseType` with a particular instance of
-- | `Respondable`.
data ResponseType a
  = ArrayBufferResponse
  | BlobResponse
  | DocumentResponse
  | JSONResponse
  | StringResponse

instance eqResponseType :: Eq (ResponseType a) where
  (==) ArrayBufferResponse ArrayBufferResponse = true
  (==) BlobResponse        BlobResponse        = true
  (==) DocumentResponse    DocumentResponse    = true
  (==) JSONResponse        JSONResponse        = true
  (==) StringResponse      StringResponse      = true
  (==) _ _ = false
  (/=) x y = not (x == y)

instance showResponseType :: Show (ResponseType a) where
  show ArrayBufferResponse = "ArrayBufferResponse"
  show BlobResponse = "BlobResponse"
  show DocumentResponse = "DocumentResponse"
  show JSONResponse = "JSONResponse"
  show StringResponse = "StringResponse"

responseTypeToString :: forall a. (ResponseType a) -> String
responseTypeToString ArrayBufferResponse = "arraybuffer"
responseTypeToString BlobResponse = "blob"
responseTypeToString DocumentResponse = "document"
responseTypeToString JSONResponse = "json"
responseTypeToString StringResponse = "text"

-- | Type representing content types that be received from an XHR request
-- | (Blob, Document, JSON, String).
type ResponseContent = Foreign

class Respondable a where
  responseType :: ResponseType a
  fromResponse :: ResponseContent -> F a

instance responsableBlob :: Respondable Blob where
  responseType = BlobResponse
  fromResponse = unsafeReadTagged "Blob"

instance responsableDocument :: Respondable Document where
  responseType = DocumentResponse
  fromResponse = unsafeReadTagged "Document"

instance responsableJSON :: Respondable Foreign where
  responseType = JSONResponse
  fromResponse = Right

instance responsableString :: Respondable String where
  responseType = StringResponse
  fromResponse = readString

instance responsableUnit :: Respondable Unit where
  responseType = StringResponse
  fromResponse = const (Right unit)

module Network.HTTP.Affjax.Response
  ( ResponseType(), responseTypeToString
  , ResponseContent()
  , Respondable, responseType, fromResponse
  ) where

import Control.Bind ((>=>))
import Data.Either (Either(..))
import Data.Foreign (Foreign(), F(), readString, parseJSON, unsafeReadTagged)
import DOM (Document())
import DOM.File (Blob())
import DOM.XHR (FormData())
import Type.Proxy (Proxy())
import qualified Data.ArrayBuffer.Types as A

-- | Valid response types for an AJAX request. This is used to determine the
-- | `ResponseContent` type for a request. The `a` type variable is a phantom
-- | type used to associate the `ResponseType` with a particular instance of
-- | `Respondable`.
data ResponseType a
  = ArrayBufferResponse
  | BlobResponse
  | DocumentResponse
  | JSONResponse
  | StringResponse

instance eqResponseType :: Eq (ResponseType a) where
  (==) ArrayBufferResponse ArrayBufferResponse = true
  (==) BlobResponse        BlobResponse        = true
  (==) DocumentResponse    DocumentResponse    = true
  (==) JSONResponse        JSONResponse        = true
  (==) StringResponse      StringResponse      = true
  (==) _ _ = false
  (/=) x y = not (x == y)

instance showResponseType :: Show (ResponseType a) where
  show ArrayBufferResponse = "ArrayBufferResponse"
  show BlobResponse = "BlobResponse"
  show DocumentResponse = "DocumentResponse"
  show JSONResponse = "JSONResponse"
  show StringResponse = "StringResponse"

responseTypeToString :: forall a. (ResponseType a) -> String
responseTypeToString ArrayBufferResponse = "arraybuffer"
responseTypeToString BlobResponse = "blob"
responseTypeToString DocumentResponse = "document"
responseTypeToString JSONResponse = "json"
responseTypeToString StringResponse = "text"

-- | Type representing content types that be received from an XHR request
-- | (Blob, Document, JSON, String).
type ResponseContent = Foreign

class Respondable a where
  responseType :: ResponseType a
  fromResponse :: ResponseContent -> F a

instance responsableBlob :: Respondable Blob where
  responseType = BlobResponse
  fromResponse = unsafeReadTagged "Blob"

instance responsableDocument :: Respondable Document where
  responseType = DocumentResponse
  fromResponse = unsafeReadTagged "Document"

instance responsableJSON :: Respondable Foreign where
  responseType = JSONResponse
  fromResponse = Right

instance responsableString :: Respondable String where
  responseType = StringResponse
  fromResponse = readString

instance responsableUnit :: Respondable Unit where
  responseType = StringResponse
  fromResponse = const (Right unit)


Fix warnings about partial functions

Fix warnings about partial functions

-- | Helper functions for working with immutable Javascript arrays.
-- |
-- | _Note_: Depending on your use-case, you may prefer to use `Data.List` or
-- | `Data.Sequence` instead, which might give better performance for certain
-- | use cases. This module is useful when integrating with JavaScript libraries
-- | which use arrays, but immutable arrays are not a practical data structure
-- | for many use cases due to their poor asymptotics.
module Data.Array
  ( singleton
  , (..), range
  , replicate
  , replicateM
  , some
  , many

  , null
  , length

  , (:), cons
  , snoc
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , modifyAt
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , filterM
  , mapMaybe
  , catMaybes

  , sort
  , sortBy

  , slice
  , take
  , takeWhile
  , drop
  , dropWhile
  , span
  , group
  , group'
  , groupBy

  , nub
  , nubBy
  , union
  , unionBy
  , delete
  , deleteBy

  , (\\)
  , intersect
  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  ) where

import Prelude
import Control.Alt (Alt, (<|>))
import Control.Alternative (Alternative)
import Control.Lazy (Lazy, defer)
import Control.MonadPlus (MonadPlus)
import Control.Plus (Plus)
import Data.Foldable (foldl)
import Data.Functor.Invariant (Invariant, imapF)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Monoid (Monoid, mempty)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..))

import qualified Data.Maybe.Unsafe as U

--------------------------------------------------------------------------------
-- Array creation --------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Create an array of one element
singleton :: forall a. a -> Array a
singleton a = [a]

-- | Create an array containing a range of integers, including both endpoints.
foreign import range :: Int -> Int -> Array Int

infix 8 ..

-- | An infix synonym for `range`.
(..) :: Int -> Int -> Array Int
(..) = range

-- | Create an array with repeated instances of a value.
foreign import replicate :: forall a. Int -> a -> Array a

-- | Perform a monadic action `n` times collecting all of the results.
replicateM :: forall m a. (Monad m) => Int -> m a -> m (Array a)
replicateM n m | n < 1     = return []
               | otherwise = sequence $ replicate n m

-- | Attempt a computation multiple times, requiring at least one success.
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
some :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
some v = (:) <$> v <*> defer (\_ -> many v)

-- | Attempt a computation multiple times, returning as many successful results
-- | as possible (possibly zero).
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
many :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
many v = some v <|> pure []

--------------------------------------------------------------------------------
-- Array size ------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test whether an array is empty.
null :: forall a. Array a -> Boolean
null xs = length xs == 0

-- | Get the number of elements in an array.
foreign import length :: forall a. Array a -> Int

--------------------------------------------------------------------------------
-- Extending arrays ------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Attaches an element to the front of an array, creating a new array.
-- |
-- | ```purescript
-- | cons 1 [2, 3, 4] = [1, 2, 3, 4]
-- | ```
-- |
-- | Note, the running time of this function is `O(n)`.
foreign import cons :: forall a. a -> Array a -> Array a

infixr 6 :

-- | An infix alias for `cons`.
-- |
-- | Note, the running time of this function is `O(n)`.
(:) :: forall a. a -> Array a -> Array a
(:) = cons

-- | Append an element to the end of an array, creating a new array.
foreign import snoc :: forall a. Array a -> a -> Array a

-- | Insert an element into a sorted array.
insert :: forall a. (Ord a) => a -> Array a -> Array a
insert = insertBy compare

-- | Insert an element into a sorted array, using the specified function to
-- | determine the ordering of elements.
insertBy :: forall a. (a -> a -> Ordering) -> a -> Array a -> Array a
insertBy cmp x ys =
  let i = maybe 0 (+ 1) (findLastIndex (\y -> cmp x y == GT) ys)
  in U.fromJust (insertAt i x ys)

--------------------------------------------------------------------------------
-- Non-indexed reads -----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Get the first element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
head :: forall a. Array a -> Maybe a
head = uncons' (const Nothing) (\x _ -> Just x)

-- | Get the last element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
last :: forall a. Array a -> Maybe a
last xs = xs !! (length xs - 1)

-- | Get all but the first element of an array, creating a new array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(n)` where `n` is the length of the array
tail :: forall a. Array a -> Maybe (Array a)
tail = uncons' (const Nothing) (\_ xs -> Just xs)

-- | Get all but the last element of an array, creating a new array, or `Nothing` if the array is empty.
-- |
-- | Running time: `O(n)` where `n` is the length of the array
init :: forall a. Array a -> Maybe (Array a)
init xs | null xs = Nothing
        | otherwise = Just (slice zero (length xs - one) xs)

-- | Break an array into its first element and remaining elements.
-- |
-- | Using `uncons` provides a way of writing code that would use cons patterns
-- | in Haskell or pre-PureScript 0.7:
-- | ``` purescript
-- | f (x : xs) = something
-- | f [] = somethingElse
-- | ```
-- | Becomes:
-- | ``` purescript
-- | f arr = case uncons arr of
-- |   Just { head: x, tail: xs } -> something
-- |   Nothing -> somethingElse
-- | ```
uncons :: forall a. Array a -> Maybe { head :: a, tail :: Array a }
uncons = uncons' (const Nothing) \x xs -> Just { head: x, tail: xs }

foreign import uncons' :: forall a b. (Unit -> b)
                                   -> (a -> Array a -> b)
                                   -> Array a
                                   -> b

--------------------------------------------------------------------------------
-- Indexed operations ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | This function provides a safe way to read a value at a particular index
-- | from an array.
index :: forall a. Array a -> Int -> Maybe a
index = indexImpl Just Nothing

foreign import indexImpl :: forall a. (forall r. r -> Maybe r)
                                   -> (forall r. Maybe r)
                                   -> Array a
                                   -> Int
                                   -> Maybe a

infixl 8 !!

-- | An infix version of `index`.
(!!) :: forall a. Array a -> Int -> Maybe a
(!!) = index

-- | Find the index of the first element equal to the specified element.
elemIndex :: forall a. (Eq a) => a -> Array a -> Maybe Int
elemIndex x = findIndex (== x)

-- | Find the index of the last element equal to the specified element.
elemLastIndex :: forall a. (Eq a) => a -> Array a -> Maybe Int
elemLastIndex x = findLastIndex (== x)

-- | Find the first index for which a predicate holds.
findIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findIndex = findIndexImpl Just Nothing

foreign import findIndexImpl :: forall a. (forall b. b -> Maybe b)
                                       -> (forall b. Maybe b)
                                       -> (a -> Boolean)
                                       -> Array a
                                       -> Maybe Int

-- | Find the last index for which a predicate holds.
findLastIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findLastIndex = findLastIndexImpl Just Nothing

foreign import findLastIndexImpl :: forall a. (forall b. b -> Maybe b)
                                           -> (forall b. Maybe b)
                                           -> (a -> Boolean)
                                           -> Array a
                                           -> Maybe Int

-- | Insert an element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
insertAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
insertAt = _insertAt Just Nothing

foreign import _insertAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> a
                                   -> Array a
                                   -> Maybe (Array a)

-- | Delete the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
deleteAt :: forall a. Int -> Array a -> Maybe (Array a)
deleteAt = _deleteAt Just Nothing

foreign import _deleteAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> Array a
                                   -> Maybe (Array a)

-- | Change the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
updateAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
updateAt = _updateAt Just Nothing

foreign import _updateAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> a
                                   -> Array a
                                   -> Maybe (Array a)

-- | Apply a function to the element at the specified index, creating a new
-- | array, or returning `Nothing` if the index is out of bounds.
modifyAt :: forall a. Int -> (a -> a) -> Array a -> Maybe (Array a)
modifyAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = updateAt i (f x) xs

-- | Update or delete the element at the specified index by applying a
-- | function to the current value, returning a new array or `Nothing` if the
-- | index is out-of-bounds.
alterAt :: forall a. Int -> (a -> Maybe a) -> Array a -> Maybe (Array a)
alterAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = case f x of
    Nothing -> deleteAt i xs
    Just x' -> updateAt i x' xs

--------------------------------------------------------------------------------
-- Transformations -------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Reverse an array, creating a new array.
foreign import reverse :: forall a. Array a -> Array a

-- | Flatten an array of arrays, creating a new array.
foreign import concat :: forall a. Array (Array a) -> Array a

-- | Apply a function to each element in an array, and flatten the results
-- | into a single, new array.
concatMap :: forall a b. (a -> Array b) -> Array a -> Array b
concatMap = flip bind

-- | Filter an array, keeping the elements which satisfy a predicate function,
-- | creating a new array.
foreign import filter :: forall a. (a -> Boolean) -> Array a -> Array a

-- | Filter where the predicate returns a monadic `Boolean`.
-- |
-- | ```purescript
-- | powerSet :: forall a. [a] -> [[a]]
-- | powerSet = filterM (const [true, false])
-- | ```
filterM :: forall a m. (Monad m) => (a -> m Boolean) -> Array a -> m (Array a)
filterM p = uncons' (\_ -> pure []) \x xs -> do
    b <- p x
    xs' <- filterM p xs
    return if b
           then x : xs'
           else xs'

-- | Apply a function to each element in an array, keeping only the results
-- | which contain a value, creating a new array.
mapMaybe :: forall a b. (a -> Maybe b) -> Array a -> Array b
mapMaybe f = concatMap (maybe [] singleton <<< f)

-- | Filter an array of optional values, keeping only the elements which contain
-- | a value, creating a new array.
catMaybes :: forall a. Array (Maybe a) -> Array a
catMaybes = mapMaybe id

--------------------------------------------------------------------------------
-- Sorting ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Sort the elements of an array in increasing order, creating a new array.
sort :: forall a. (Ord a) => Array a -> Array a
sort xs = sortBy compare xs

-- | Sort the elements of an array in increasing order, where elements are compared using
-- | the specified partial ordering, creating a new array.
sortBy :: forall a. (a -> a -> Ordering) -> Array a -> Array a
sortBy comp xs = sortImpl comp' xs
  where
  comp' x y = case comp x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortImpl :: forall a. (a -> a -> Int) -> Array a -> Array a

--------------------------------------------------------------------------------
-- Subarrays -------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Extract a subarray by a start and end index.
foreign import slice :: forall a. Int -> Int -> Array a -> Array a

-- | Keep only a number of elements from the start of an array, creating a new
-- | array.
take :: forall a. Int -> Array a -> Array a
take = slice 0

-- | Calculate the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
takeWhile :: forall a. (a -> Boolean) -> Array a -> Array a
takeWhile p xs = (span p xs).init

-- | Drop a number of elements from the start of an array, creating a new array.
foreign import drop :: forall a. Int -> Array a -> Array a

-- | Remove the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
dropWhile :: forall a. (a -> Boolean) -> Array a -> Array a
dropWhile p xs = (span p xs).rest

-- | Split an array into two parts:
-- |
-- | 1. the longest initial subarray for which all element satisfy the specified
-- |    predicate
-- | 2. the remaining elements
-- |
-- | ```purescript
-- | span (\n -> n % 2 == 1) [1,3,2,4,5] == { init: [1,3], rest: [2,4,5] }
-- | ```
span :: forall a. (a -> Boolean) -> Array a -> { init :: Array a, rest :: Array a }
span p = go []
  where
  go :: Array a -> Array a -> { init :: Array a, rest :: Array a }
  go acc xs = case uncons xs of
                Just { head: x, tail: xs } | p x -> go (x : acc) xs
                _ -> { init: reverse acc, rest: xs }

-- | Group equal, consecutive elements of an array into arrays.
-- |
-- | ```purescript
-- | group [1,1,2,2,1] == [[1,1],[2,2],[1]]
-- | ```
group :: forall a. (Eq a) => Array a -> Array (Array a)
group xs = groupBy eq xs

-- | Sort and then group the elements of an array into arrays.
-- |
-- | ```purescript
-- | group' [1,1,2,2,1] == [[1,1,1],[2,2]]
-- | ```
group' :: forall a. (Ord a) => Array a -> Array (Array a)
group' = group <<< sort

-- | Group equal, consecutive elements of an array into arrays, using the
-- | specified equivalence relation to detemine equality.
groupBy :: forall a. (a -> a -> Boolean) -> Array a -> Array (Array a)
groupBy op = go []
  where
  go :: Array (Array a) -> Array a -> Array (Array a)
  go acc xs = case uncons xs of
    Just o -> let sp = span (op o.head) o.tail
              in go ((o.head : sp.init) : acc) sp.rest
    Nothing -> reverse acc

--------------------------------------------------------------------------------
-- Set-like operations ---------------------------------------------------------
--------------------------------------------------------------------------------

-- | Remove the duplicates from an array, creating a new array.
nub :: forall a. (Eq a) => Array a -> Array a
nub = nubBy eq

-- | Remove the duplicates from an array, where element equality is determined
-- | by the specified equivalence relation, creating a new array.
nubBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a
nubBy eq xs = case uncons xs of
                Just o -> o.head : nubBy eq (filter (\y -> not (o.head `eq` y)) o.tail)
                Nothing -> []

-- | Calculate the union of two lists.
-- |
-- | Running time: `O(n^2)`
union :: forall a. (Eq a) => Array a -> Array a -> Array a
union = unionBy (==)

-- | Calculate the union of two arrays, using the specified function to
-- | determine equality of elements.
unionBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs

-- | Delete the first element of an array which is equal to the specified value,
-- | creating a new array.
delete :: forall a. (Eq a) => a -> Array a -> Array a
delete = deleteBy eq

-- | Delete the first element of an array which matches the specified value,
-- | under the equivalence relation provided in the first argument, creating a
-- | new array.
deleteBy :: forall a. (a -> a -> Boolean) -> a -> Array a -> Array a
deleteBy _  _ [] = []
deleteBy eq x ys = maybe ys (\i -> U.fromJust $ deleteAt i ys) (findIndex (eq x) ys)

infix 5 \\

-- | Delete the first occurrence of each element in the second array from the
-- | first array, creating a new array.
(\\) :: forall a. (Eq a) => Array a -> Array a -> Array a
(\\) xs ys | null xs = []
           | otherwise = uncons' (const xs) (\y ys -> delete y xs \\ ys) ys

-- | Calculate the intersection of two arrays, creating a new array.
intersect :: forall a. (Eq a) => Array a -> Array a -> Array a
intersect = intersectBy eq

-- | Calculate the intersection of two arrays, using the specified equivalence
-- | relation to compare elements, creating a new array.
intersectBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
intersectBy eq xs ys = filter (\x -> isJust (findIndex (eq x) ys)) xs

--------------------------------------------------------------------------------
-- Zipping ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Apply a function to pairs of elements at the same index in two arrays,
-- | collecting the results in a new array.
-- |
-- | If one array is longer, elements will be discarded from the longer array.
-- |
-- | For example
-- |
-- | ```purescript
-- | zipWith (*) [1, 2, 3] [4, 5, 6, 7] == [4, 10, 18]
-- | ```
foreign import zipWith :: forall a b c. (a -> b -> c) -> Array a -> Array b -> Array c

-- | A generalization of `zipWith` which accumulates results in some `Applicative`
-- | functor.
zipWithA :: forall m a b c. (Applicative m) => (a -> b -> m c) -> Array a -> Array b -> m (Array c)
zipWithA f xs ys = sequence (zipWith f xs ys)

-- | Rakes two lists and returns a list of corresponding pairs.
-- | If one input list is short, excess elements of the longer list are discarded.
zip :: forall a b. Array a -> Array b -> Array (Tuple a b)
zip = zipWith Tuple

-- | Transforms a list of pairs into a list of first components and a list of
-- | second components.
unzip :: forall a b. Array (Tuple a b) -> Tuple (Array a) (Array b)
unzip = uncons' (\_ -> Tuple [] []) \(Tuple a b) ts -> case unzip ts of
  Tuple as bs -> Tuple (a : as) (b : bs)

--------------------------------------------------------------------------------
-- Folding ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Perform a fold using a monadic step function.
foldM :: forall m a b. (Monad m) => (a -> b -> m a) -> a -> Array b -> m a
foldM f a = uncons' (\_ -> return a) (\b bs -> f a b >>= \a' -> foldM f a' bs)

-- | Helper functions for working with immutable Javascript arrays.
-- |
-- | _Note_: Depending on your use-case, you may prefer to use `Data.List` or
-- | `Data.Sequence` instead, which might give better performance for certain
-- | use cases. This module is useful when integrating with JavaScript libraries
-- | which use arrays, but immutable arrays are not a practical data structure
-- | for many use cases due to their poor asymptotics.
module Data.Array
  ( singleton
  , (..), range
  , replicate
  , replicateM
  , some
  , many

  , null
  , length

  , (:), cons
  , snoc
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , modifyAt
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , filterM
  , mapMaybe
  , catMaybes

  , sort
  , sortBy

  , slice
  , take
  , takeWhile
  , drop
  , dropWhile
  , span
  , group
  , group'
  , groupBy

  , nub
  , nubBy
  , union
  , unionBy
  , delete
  , deleteBy

  , (\\)
  , intersect
  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  ) where

import Prelude
import Control.Alt (Alt, (<|>))
import Control.Alternative (Alternative)
import Control.Lazy (Lazy, defer)
import Control.MonadPlus (MonadPlus)
import Control.Plus (Plus)
import Data.Foldable (foldl)
import Data.Functor.Invariant (Invariant, imapF)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Monoid (Monoid, mempty)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..))

import qualified Data.Maybe.Unsafe as U

--------------------------------------------------------------------------------
-- Array creation --------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Create an array of one element
singleton :: forall a. a -> Array a
singleton a = [a]

-- | Create an array containing a range of integers, including both endpoints.
foreign import range :: Int -> Int -> Array Int

infix 8 ..

-- | An infix synonym for `range`.
(..) :: Int -> Int -> Array Int
(..) = range

-- | Create an array with repeated instances of a value.
foreign import replicate :: forall a. Int -> a -> Array a

-- | Perform a monadic action `n` times collecting all of the results.
replicateM :: forall m a. (Monad m) => Int -> m a -> m (Array a)
replicateM n m | n < 1     = return []
               | otherwise = sequence $ replicate n m

-- | Attempt a computation multiple times, requiring at least one success.
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
some :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
some v = (:) <$> v <*> defer (\_ -> many v)

-- | Attempt a computation multiple times, returning as many successful results
-- | as possible (possibly zero).
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
many :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
many v = some v <|> pure []

--------------------------------------------------------------------------------
-- Array size ------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test whether an array is empty.
null :: forall a. Array a -> Boolean
null xs = length xs == 0

-- | Get the number of elements in an array.
foreign import length :: forall a. Array a -> Int

--------------------------------------------------------------------------------
-- Extending arrays ------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Attaches an element to the front of an array, creating a new array.
-- |
-- | ```purescript
-- | cons 1 [2, 3, 4] = [1, 2, 3, 4]
-- | ```
-- |
-- | Note, the running time of this function is `O(n)`.
foreign import cons :: forall a. a -> Array a -> Array a

infixr 6 :

-- | An infix alias for `cons`.
-- |
-- | Note, the running time of this function is `O(n)`.
(:) :: forall a. a -> Array a -> Array a
(:) = cons

-- | Append an element to the end of an array, creating a new array.
foreign import snoc :: forall a. Array a -> a -> Array a

-- | Insert an element into a sorted array.
insert :: forall a. (Ord a) => a -> Array a -> Array a
insert = insertBy compare

-- | Insert an element into a sorted array, using the specified function to
-- | determine the ordering of elements.
insertBy :: forall a. (a -> a -> Ordering) -> a -> Array a -> Array a
insertBy cmp x ys =
  let i = maybe 0 (+ 1) (findLastIndex (\y -> cmp x y == GT) ys)
  in U.fromJust (insertAt i x ys)

--------------------------------------------------------------------------------
-- Non-indexed reads -----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Get the first element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
head :: forall a. Array a -> Maybe a
head = uncons' (const Nothing) (\x _ -> Just x)

-- | Get the last element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
last :: forall a. Array a -> Maybe a
last xs = xs !! (length xs - 1)

-- | Get all but the first element of an array, creating a new array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(n)` where `n` is the length of the array
tail :: forall a. Array a -> Maybe (Array a)
tail = uncons' (const Nothing) (\_ xs -> Just xs)

-- | Get all but the last element of an array, creating a new array, or `Nothing` if the array is empty.
-- |
-- | Running time: `O(n)` where `n` is the length of the array
init :: forall a. Array a -> Maybe (Array a)
init xs | null xs = Nothing
        | otherwise = Just (slice zero (length xs - one) xs)

-- | Break an array into its first element and remaining elements.
-- |
-- | Using `uncons` provides a way of writing code that would use cons patterns
-- | in Haskell or pre-PureScript 0.7:
-- | ``` purescript
-- | f (x : xs) = something
-- | f [] = somethingElse
-- | ```
-- | Becomes:
-- | ``` purescript
-- | f arr = case uncons arr of
-- |   Just { head: x, tail: xs } -> something
-- |   Nothing -> somethingElse
-- | ```
uncons :: forall a. Array a -> Maybe { head :: a, tail :: Array a }
uncons = uncons' (const Nothing) \x xs -> Just { head: x, tail: xs }

foreign import uncons' :: forall a b. (Unit -> b)
                                   -> (a -> Array a -> b)
                                   -> Array a
                                   -> b

--------------------------------------------------------------------------------
-- Indexed operations ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | This function provides a safe way to read a value at a particular index
-- | from an array.
index :: forall a. Array a -> Int -> Maybe a
index = indexImpl Just Nothing

foreign import indexImpl :: forall a. (forall r. r -> Maybe r)
                                   -> (forall r. Maybe r)
                                   -> Array a
                                   -> Int
                                   -> Maybe a

infixl 8 !!

-- | An infix version of `index`.
(!!) :: forall a. Array a -> Int -> Maybe a
(!!) = index

-- | Find the index of the first element equal to the specified element.
elemIndex :: forall a. (Eq a) => a -> Array a -> Maybe Int
elemIndex x = findIndex (== x)

-- | Find the index of the last element equal to the specified element.
elemLastIndex :: forall a. (Eq a) => a -> Array a -> Maybe Int
elemLastIndex x = findLastIndex (== x)

-- | Find the first index for which a predicate holds.
findIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findIndex = findIndexImpl Just Nothing

foreign import findIndexImpl :: forall a. (forall b. b -> Maybe b)
                                       -> (forall b. Maybe b)
                                       -> (a -> Boolean)
                                       -> Array a
                                       -> Maybe Int

-- | Find the last index for which a predicate holds.
findLastIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findLastIndex = findLastIndexImpl Just Nothing

foreign import findLastIndexImpl :: forall a. (forall b. b -> Maybe b)
                                           -> (forall b. Maybe b)
                                           -> (a -> Boolean)
                                           -> Array a
                                           -> Maybe Int

-- | Insert an element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
insertAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
insertAt = _insertAt Just Nothing

foreign import _insertAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> a
                                   -> Array a
                                   -> Maybe (Array a)

-- | Delete the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
deleteAt :: forall a. Int -> Array a -> Maybe (Array a)
deleteAt = _deleteAt Just Nothing

foreign import _deleteAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> Array a
                                   -> Maybe (Array a)

-- | Change the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
updateAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
updateAt = _updateAt Just Nothing

foreign import _updateAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> a
                                   -> Array a
                                   -> Maybe (Array a)

-- | Apply a function to the element at the specified index, creating a new
-- | array, or returning `Nothing` if the index is out of bounds.
modifyAt :: forall a. Int -> (a -> a) -> Array a -> Maybe (Array a)
modifyAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = updateAt i (f x) xs

-- | Update or delete the element at the specified index by applying a
-- | function to the current value, returning a new array or `Nothing` if the
-- | index is out-of-bounds.
alterAt :: forall a. Int -> (a -> Maybe a) -> Array a -> Maybe (Array a)
alterAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = case f x of
    Nothing -> deleteAt i xs
    Just x' -> updateAt i x' xs

--------------------------------------------------------------------------------
-- Transformations -------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Reverse an array, creating a new array.
foreign import reverse :: forall a. Array a -> Array a

-- | Flatten an array of arrays, creating a new array.
foreign import concat :: forall a. Array (Array a) -> Array a

-- | Apply a function to each element in an array, and flatten the results
-- | into a single, new array.
concatMap :: forall a b. (a -> Array b) -> Array a -> Array b
concatMap = flip bind

-- | Filter an array, keeping the elements which satisfy a predicate function,
-- | creating a new array.
foreign import filter :: forall a. (a -> Boolean) -> Array a -> Array a

-- | Filter where the predicate returns a monadic `Boolean`.
-- |
-- | ```purescript
-- | powerSet :: forall a. [a] -> [[a]]
-- | powerSet = filterM (const [true, false])
-- | ```
filterM :: forall a m. (Monad m) => (a -> m Boolean) -> Array a -> m (Array a)
filterM p = uncons' (\_ -> pure []) \x xs -> do
    b <- p x
    xs' <- filterM p xs
    return if b
           then x : xs'
           else xs'

-- | Apply a function to each element in an array, keeping only the results
-- | which contain a value, creating a new array.
mapMaybe :: forall a b. (a -> Maybe b) -> Array a -> Array b
mapMaybe f = concatMap (maybe [] singleton <<< f)

-- | Filter an array of optional values, keeping only the elements which contain
-- | a value, creating a new array.
catMaybes :: forall a. Array (Maybe a) -> Array a
catMaybes = mapMaybe id

--------------------------------------------------------------------------------
-- Sorting ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Sort the elements of an array in increasing order, creating a new array.
sort :: forall a. (Ord a) => Array a -> Array a
sort xs = sortBy compare xs

-- | Sort the elements of an array in increasing order, where elements are compared using
-- | the specified partial ordering, creating a new array.
sortBy :: forall a. (a -> a -> Ordering) -> Array a -> Array a
sortBy comp xs = sortImpl comp' xs
  where
  comp' x y = case comp x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortImpl :: forall a. (a -> a -> Int) -> Array a -> Array a

--------------------------------------------------------------------------------
-- Subarrays -------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Extract a subarray by a start and end index.
foreign import slice :: forall a. Int -> Int -> Array a -> Array a

-- | Keep only a number of elements from the start of an array, creating a new
-- | array.
take :: forall a. Int -> Array a -> Array a
take = slice 0

-- | Calculate the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
takeWhile :: forall a. (a -> Boolean) -> Array a -> Array a
takeWhile p xs = (span p xs).init

-- | Drop a number of elements from the start of an array, creating a new array.
foreign import drop :: forall a. Int -> Array a -> Array a

-- | Remove the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
dropWhile :: forall a. (a -> Boolean) -> Array a -> Array a
dropWhile p xs = (span p xs).rest

-- | Split an array into two parts:
-- |
-- | 1. the longest initial subarray for which all element satisfy the specified
-- |    predicate
-- | 2. the remaining elements
-- |
-- | ```purescript
-- | span (\n -> n % 2 == 1) [1,3,2,4,5] == { init: [1,3], rest: [2,4,5] }
-- | ```
span :: forall a. (a -> Boolean) -> Array a -> { init :: Array a, rest :: Array a }
span p = go []
  where
  go :: Array a -> Array a -> { init :: Array a, rest :: Array a }
  go acc xs = case uncons xs of
                Just { head: x, tail: xs } | p x -> go (x : acc) xs
                _ -> { init: reverse acc, rest: xs }

-- | Group equal, consecutive elements of an array into arrays.
-- |
-- | ```purescript
-- | group [1,1,2,2,1] == [[1,1],[2,2],[1]]
-- | ```
group :: forall a. (Eq a) => Array a -> Array (Array a)
group xs = groupBy eq xs

-- | Sort and then group the elements of an array into arrays.
-- |
-- | ```purescript
-- | group' [1,1,2,2,1] == [[1,1,1],[2,2]]
-- | ```
group' :: forall a. (Ord a) => Array a -> Array (Array a)
group' = group <<< sort

-- | Group equal, consecutive elements of an array into arrays, using the
-- | specified equivalence relation to detemine equality.
groupBy :: forall a. (a -> a -> Boolean) -> Array a -> Array (Array a)
groupBy op = go []
  where
  go :: Array (Array a) -> Array a -> Array (Array a)
  go acc []     = reverse acc
  go acc xs = case uncons xs of
                Just o -> let sp = span (op o.head) o.tail
                          in go ((o.head : sp.init) : acc) sp.rest

--------------------------------------------------------------------------------
-- Set-like operations ---------------------------------------------------------
--------------------------------------------------------------------------------

-- | Remove the duplicates from an array, creating a new array.
nub :: forall a. (Eq a) => Array a -> Array a
nub = nubBy eq

-- | Remove the duplicates from an array, where element equality is determined
-- | by the specified equivalence relation, creating a new array.
nubBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a
nubBy _ [] = []
nubBy eq xs = case uncons xs of
                Just o -> o.head : nubBy eq (filter (\y -> not (o.head `eq` y)) o.tail)

-- | Calculate the union of two lists.
-- |
-- | Running time: `O(n^2)`
union :: forall a. (Eq a) => Array a -> Array a -> Array a
union = unionBy (==)

-- | Calculate the union of two arrays, using the specified function to
-- | determine equality of elements.
unionBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs

-- | Delete the first element of an array which is equal to the specified value,
-- | creating a new array.
delete :: forall a. (Eq a) => a -> Array a -> Array a
delete = deleteBy eq

-- | Delete the first element of an array which matches the specified value,
-- | under the equivalence relation provided in the first argument, creating a
-- | new array.
deleteBy :: forall a. (a -> a -> Boolean) -> a -> Array a -> Array a
deleteBy _  _ [] = []
deleteBy eq x ys = maybe ys (\i -> U.fromJust $ deleteAt i ys) (findIndex (eq x) ys)

infix 5 \\

-- | Delete the first occurrence of each element in the second array from the
-- | first array, creating a new array.
(\\) :: forall a. (Eq a) => Array a -> Array a -> Array a
(\\) xs ys | null xs = []
           | otherwise = uncons' (const xs) (\y ys -> delete y xs \\ ys) ys

-- | Calculate the intersection of two arrays, creating a new array.
intersect :: forall a. (Eq a) => Array a -> Array a -> Array a
intersect = intersectBy eq

-- | Calculate the intersection of two arrays, using the specified equivalence
-- | relation to compare elements, creating a new array.
intersectBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
intersectBy eq xs ys = filter (\x -> isJust (findIndex (eq x) ys)) xs

--------------------------------------------------------------------------------
-- Zipping ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Apply a function to pairs of elements at the same index in two arrays,
-- | collecting the results in a new array.
-- |
-- | If one array is longer, elements will be discarded from the longer array.
-- |
-- | For example
-- |
-- | ```purescript
-- | zipWith (*) [1, 2, 3] [4, 5, 6, 7] == [4, 10, 18]
-- | ```
foreign import zipWith :: forall a b c. (a -> b -> c) -> Array a -> Array b -> Array c

-- | A generalization of `zipWith` which accumulates results in some `Applicative`
-- | functor.
zipWithA :: forall m a b c. (Applicative m) => (a -> b -> m c) -> Array a -> Array b -> m (Array c)
zipWithA f xs ys = sequence (zipWith f xs ys)

-- | Rakes two lists and returns a list of corresponding pairs.
-- | If one input list is short, excess elements of the longer list are discarded.
zip :: forall a b. Array a -> Array b -> Array (Tuple a b)
zip = zipWith Tuple

-- | Transforms a list of pairs into a list of first components and a list of
-- | second components.
unzip :: forall a b. Array (Tuple a b) -> Tuple (Array a) (Array b)
unzip = uncons' (\_ -> Tuple [] []) \(Tuple a b) ts -> case unzip ts of
  Tuple as bs -> Tuple (a : as) (b : bs)

--------------------------------------------------------------------------------
-- Folding ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Perform a fold using a monadic step function.
foldM :: forall m a b. (Monad m) => (a -> b -> m a) -> a -> Array b -> m a
foldM f a = uncons' (\_ -> return a) (\b bs -> f a b >>= \a' -> foldM f a' bs)


Fix JQuery test

Fix JQuery test


Fix initial SlamDown buttons

Fix initial SlamDown buttons

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), either)
import Data.Foldable (intercalate)
import Data.Function (on)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst)
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell)
import Model.Notebook.Port (Port(..), VarMapValue())
import Optic.Core (LensP(), (..), (<>~), (%~), (+~), (.~), (^.), (?~), lens)
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..))
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, emptySlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Number
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  (modifyAt i _{visible = visSet}) <<< (_{visible = false} <$>)

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< isCell cellId)

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $  setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)

updateState state i = state

toStrMap :: forall a. M.Map String a -> SM.StrMap a
toStrMap = SM.fromList <<< M.toList

slamDownStateMap :: LensP SlamDownState (M.Map String FormFieldValue)
slamDownStateMap = lens (\(SlamDownState m) -> m) (const SlamDownState)

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .~ VarMap m
  where
    m = maybe SM.empty ((fromFormValue <$>) <<< toStrMap) state
    fromFormValue (SingleValue s) = s
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state = cell ^? _content.._Markdown..Ma._state..slamDownStateMap

-- TODO: This should probably live in purescript-markdown
slamDownFields :: String -> [Tuple String FormField]
slamDownFields s =
  case parseMd s of
    SlamDown bs -> bs >>= block
  where
    block (Paragraph is) = is >>= inline
    block (Header _ is) = is >>= inline
    block (Blockquote bs) = bs >>= block
    block (List _ bss) = join bss >>= block
    block _ = []
    inline (Emph is) = is >>= inline
    inline (Strong is) = is >>= inline
    inline (Link is _) = is >>= inline
    inline (Image is _) = is >>= inline
    inline (FormField s _ ff) = [Tuple s ff]
    inline _ = []

-- TODO: Change Port to SlamDownState and use slamDownOutput instead.
initialSlamDownOutput :: [Tuple String FormField] -> Port
initialSlamDownOutput sf = VarMap sm
  where sm :: SM.StrMap VarMapValue
        sm = fromMaybe SM.empty <<< traverse toValue $ SM.fromList sf
        toValue :: FormField -> Maybe VarMapValue
        toValue (TextBox _ (Literal s)) = Just s
        toValue (RadioButtons (Literal s) _) = Just s
        toValue (DropDown _ (Literal s)) = Just s
        toValue (CheckBoxes _ (Literal ss)) = Nothing
        toValue _ = Nothing

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial fields = cell # _message .~ message fields
                            # _output .~ initialSlamDownOutput fields
  in maybe cell (initial <<< slamDownFields) input'

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
    <<< (_content.._Markdown..Ma._state .~ emptySlamDownState)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: [FailureMessage] -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), either)
import Data.Foldable (intercalate)
import Data.Function (on)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (fst)
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell)
import Model.Notebook.Port (Port(..), VarMapValue())
import Optic.Core (LensP(), (..), (<>~), (%~), (+~), (.~), (^.), (?~), lens)
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Inline(..), FormField(..))
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, emptySlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Number
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  (modifyAt i _{visible = visSet}) <<< (_{visible = false} <$>)

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< isCell cellId)

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $  setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)

updateState state i = state

toStrMap :: forall a. M.Map String a -> SM.StrMap a
toStrMap = SM.fromList <<< M.toList

slamDownStateMap :: LensP SlamDownState (M.Map String FormFieldValue)
slamDownStateMap = lens (\(SlamDownState m) -> m) (const SlamDownState)

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .~ VarMap m
  where
    m = maybe SM.empty ((fromFormValue <$>) <<< toStrMap) state
    fromFormValue (SingleValue s) = s
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state = cell ^? _content.._Markdown..Ma._state..slamDownStateMap

-- TODO: This should probably live in purescript-markdown
slamDownFields :: SlamDown -> [String]
slamDownFields (SlamDown bs) = bs >>= block
  where
    block (Paragraph is) = is >>= inline
    block (Header _ is) = is >>= inline
    block (Blockquote bs) = bs >>= block
    block (List _ bss) = join bss >>= block
    block _ = []
    inline (Emph is) = is >>= inline
    inline (Strong is) = is >>= inline
    inline (Link is _) = is >>= inline
    inline (Image is _) = is >>= inline
    inline (FormField s _ _) = [s]
    inline _ = []

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: "<>) <<< intercalate ", " <<< slamDownFields <<< parseMd
      changeMessage m = cell # _message .~ message m
  in maybe cell changeMessage input'

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
    <<< (_content.._Markdown..Ma._state .~ emptySlamDownState)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: [FailureMessage] -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'