Make Java nicer

Make Java nicer

Original commit 5edd81e88b8eabacfdbb6701c3aca797dc5b2e87

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

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

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

javaNameStyle :: String -> String
javaNameStyle = legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter true

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

renderUnion :: IRUnionRep -> Doc String
renderUnion = renderUnionWithTypeRenderer renderType

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

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

forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> 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 ptype javaName fieldName rendered

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

getDecoderHelperPrefix :: String -> Doc String
getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

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

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 \pname ptype javaName fieldName rendered -> do
            line $ "private " <> rendered <> " " <> fieldName <> ";"
        forEachProperty_ properties propertyNames \pname ptype 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 "}"

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


Fix ordering of backside dismissal (#1707)

{-
Copyright 2016 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.Workspace.Deck.Component
  ( component
  , module SlamData.Workspace.Deck.Component.Query
  , module DCS
  , module SlamData.Workspace.Deck.DeckPath
  ) where

import SlamData.Prelude

import Control.Monad.Aff as Aff
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff.Exception as Exception
import Control.UI.Browser as Browser
import Data.Array as Array
import Data.Lens ((.~), _Left, _Just, is)
import Data.List ((:))
import Data.List as L
import Data.Set as Set
import Data.Time.Duration (Milliseconds(..))
import DOM.HTML.HTMLElement (getBoundingClientRect)
import Halogen as H
import Halogen.Component.Utils (sendAfter, busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import SlamData.ActionList.Component as ActionList
import SlamData.ActionList.Filter.Component as ActionFilter
import SlamData.Config as Config
import SlamData.FileSystem.Routing (parentURL)
import SlamData.GlobalError as GE
import SlamData.LocalStorage.Class as LS
import SlamData.LocalStorage.Keys as LSK
import SlamData.Quasar as Api
import SlamData.Wiring (DeckMessage(..))
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId (CardId)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component.Query as CQ
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.Component as Next
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Class (navigateToDeck)
import SlamData.Workspace.Deck.BackSide as Back
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML, DeckDSL)
import SlamData.Workspace.Deck.Common as Common
import SlamData.Workspace.Deck.Component.ChildSlot (cpCard, cpBackSide, cpNext)
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (Query(..), Message(..))
import SlamData.Workspace.Deck.Component.Render as DCR
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId)
import SlamData.Workspace.Deck.DeckPath (deckPath')
import SlamData.Workspace.Deck.Gripper.Def as GD
import SlamData.Workspace.Deck.Slider as Slider
import SlamData.Workspace.Dialog.Component as Dialog
import SlamData.Workspace.Eval.Card as EC
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse as ET
import SlamData.Workspace.Guide as Guide
import SlamData.Workspace.Routing (mkWorkspaceURL)
import Utils as Utils
import Utils.DOM as DOM

component ∷ DeckOptions → DeckComponent
component opts =
  H.lifecycleParentComponent
    { render: render opts
    , eval: eval opts
    , initialState: const DCS.initialState
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ DeckOptions → DCS.State → DeckHTML
render opts st =
  case st.loadError of
    Just error →
      HH.div
        [ HP.class_ $ HH.ClassName "sd-workspace-error" ]
        [ DCR.renderError error ]
    _ → DCR.renderDeck opts component st

eval ∷ DeckOptions → Query ~> DeckDSL
eval opts = case _ of
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (\msg → HandleMessage msg H.Listening) bus.decks
    H.subscribe $ busEventSource (\msg → HandleHintDismissalMessage msg H.Listening) bus.hintDismissals
    when (L.null opts.displayCursor) do
      H.subscribe $ busEventSource (\msg → HandleError msg H.Listening) bus.globalError
    H.modify
      ∘ (DCS._focusDeckHintDismissed .~ _)
      =<< (Utils.rightBool <$> LS.retrieve LSK.dismissedFocusDeckHintKey)
    H.modify
      ∘ (DCS._focusDeckFrameHintDismissed .~ _)
      =<< (Utils.rightBool <$> LS.retrieve LSK.dismissedFocusDeckFrameHintKey)
    updateCardSize
    loadDeck opts
    pure next
  PresentAccessNextActionCardHint next → do
    st ← H.get
    dismissedBefore ← getDismissedAccessNextActionCardHintBefore
    when
      (not dismissedBefore && isNothing st.initialSliderX && st.focused)
      (H.modify (DCS._presentAccessNextActionCardHint .~ true))
    pure next
  HideAccessNextActionCardHint next →
    dismissAccessNextActionCardHint $> next
  Publish next → do
    { path } ← H.lift Wiring.expose
    let deckPath = deckPath' path opts.deckId
    H.liftEff ∘ Browser.newTab $ mkWorkspaceURL deckPath (WA.Load AT.ReadOnly)
    pure next
  FlipDeck next → do
    displayMode ← H.gets _.displayMode
    if DCS.isFrontSide displayMode
      then switchToFlipside opts
      else switchToFrontside
    pure next
  UpdateCardSize next → do
    updateCardSize
    pure next
  ZoomIn next → do
    navigateToDeck (opts.deckId L.: opts.cursor)
    pure next
  ZoomOut next → do
    { path } ← H.lift Wiring.expose
    if L.null opts.cursor
      then void $ H.liftEff $ Browser.setHref $ parentURL $ Left path
      else navigateToDeck opts.cursor
    pure next
  StartSliding gDef mouseEvent next → do
    H.getHTMLElementRef Common.sizerRef >>= traverse_ \el → do
      width ← getBoundingClientWidth el
      Slider.startSliding mouseEvent gDef width
      preloadCard gDef
    pure next
  StopSlidingAndSnap mouseEvent next → do
    st ← H.get
    Slider.stopSlidingAndSnap mouseEvent
    updateActiveState opts
    whenM nextActionCardIsActive dismissAccessNextActionCardHint
    pure next
  UpdateSliderPosition mouseEvent next →
    Slider.updateSliderPosition mouseEvent $> next
  StopSliderTransition next → do
    H.modify $ DCS._sliderTransition .~ false
    pure next
  Focus ev next → do
    st ← H.get
    H.liftEff $ DOM.stopPropagation ev
    when (not st.focused) do
      H.modify (DCS._focused .~ true)
      Wiring.focusDeck opts.deckId
    when
      (Common.willBePresentedWithChildFrameWhenFocused opts st)
      dismissFocusDeckHint
    nextActionCardIsActive' ← nextActionCardIsActive
    when
      (not nextActionCardIsActive' && not st.presentAccessNextActionCardHint)
      presentAccessNextActionCardHintAfterDelay
    pure next
  Defocus ev next → do
    st ← H.get
    H.modify (DCS._presentAccessNextActionCardHint .~ false)
    H.liftEff $ DOM.stopPropagation ev
    isFrame ← H.liftEff $ DOM.nodeEq (DOM.target ev) (DOM.currentTarget ev)
    when (st.focused && not (L.null opts.displayCursor)) do
      when isFrame do
        for_ (L.last opts.cursor) \rootId → Wiring.focusDeck rootId
    when
      (Common.willBePresentedWithChildFrameWhenFocused opts st)
      dismissFocusDeckFrameHint
    pure next
  DismissedCardGuide next → do
    when (L.null opts.displayCursor) $ void do
      queryNextAction (Next.PresentAddCardHint unit)
    pure next
  GetActiveCard k → do
    active ← H.gets DCS.activeCard
    pure (k (Utils.hush ∘ map _.cardId =<< active))
  HandleEval msg next →
    handleEval opts msg $> next
  HandleMessage msg next → do
    st ← H.get
    case msg of
      DeckFocused focusedDeckId → do
        when (opts.deckId ≡ focusedDeckId && not st.focused) do
          H.modify (DCS._focused .~ true)
        when (opts.deckId ≠ focusedDeckId && st.focused) $
          H.modify
            $ (DCS._focused .~ false)
            ∘ (DCS._presentAccessNextActionCardHint .~ false)
        whenM (not <$> nextActionCardIsActive) presentAccessNextActionCardHintAfterDelay
      SwitchToFront opts' → do
        when (opts'.deckId ≡ opts.deckId && opts'.cursor ≡ opts.cursor)
          switchToFrontside
      SwitchToFlip opts' → do
        when (opts'.deckId ≡ opts.deckId && opts'.cursor ≡ opts.cursor) $
          switchToFlipside opts
    pure next
  HandleHintDismissalMessage msg next → do
    case msg of
      Wiring.DeckFrameFocusHintDismissed →
        H.modify (DCS._focusDeckFrameHintDismissed .~ true)
      Wiring.DeckFocusHintDismissed →
        H.modify (DCS._focusDeckHintDismissed .~ true)
    pure next
  HandleError ge next → do
    Wiring.showDialog $ Dialog.Error opts $ GE.print ge
    pure next
  HandleNextAction msg next → handleNextAction opts msg $> next
  HandleBackFilter msg next → handleBackSideFilter msg $> next
  HandleBackAction msg next → handleBackSide opts msg $> next
  HandleGrab ev next → H.raise (GrabbedDeck ev) $> next
  DismissFocusDeckHint next → do
    dismissFocusDeckHint
    pure next
  DismissFocusDeckFrameHint next → do
    dismissFocusDeckFrameHint
    pure next
  where
  getBoundingClientWidth =
    H.liftEff ∘ map _.width ∘ getBoundingClientRect

nextActionCardIsActive ∷ DeckDSL Boolean
nextActionCardIsActive = do
  st ← H.get
  pure $ DCS.activeCard st # is (_Just ∘ _Left ∘ DCS._NextActionCard)

dismissFocusDeckHint ∷ DeckDSL Unit
dismissFocusDeckHint = do
  wiring ← H.lift Wiring.expose
  H.liftAff $ Bus.write Wiring.DeckFocusHintDismissed wiring.bus.hintDismissals
  H.modify (DCS._focusDeckHintDismissed .~ true)
  LS.persist LSK.dismissedFocusDeckHintKey true

dismissFocusDeckFrameHint ∷ DeckDSL Unit
dismissFocusDeckFrameHint = do
  wiring ← H.lift Wiring.expose
  H.liftAff $ Bus.write Wiring.DeckFrameFocusHintDismissed wiring.bus.hintDismissals
  H.modify (DCS._focusDeckFrameHintDismissed .~ true)
  LS.persist LSK.dismissedFocusDeckFrameHintKey true

-- If an ActionList has the style display: none; then calculating its dimensions
-- will give 0, 0. (This is Mapped to Nothing.)
--
-- If we recalculate after flipping then there may be a momentary flash
-- (observed).
--
-- Sending the dimensions of the next action list to the flip side action list
-- prevents this.
--
-- If there is no next action card this can't be done so just flip and
-- recalculate.
switchToFlipside ∷ DeckOptions → DeckDSL Unit
switchToFlipside opts = do
  updateBackSide opts
  presentFlipGuideFirstTime
  _ ← queryNextActionList $ H.action $ ActionList.CalculateBoundingRect
  nextBoundingRect ← queryNextActionList $ H.request ActionList.GetBoundingRect
  case nextBoundingRect of
    Just (Just dimensions) → do
      _ ← queryBacksideActionList $ H.action $ ActionList.SetBoundingRect dimensions
      H.modify (_ { displayMode = DCS.FlipSide })
    _ → do
      H.modify (_ { displayMode = DCS.FlipSide })
      void $ queryBacksideActionList $ H.action $ ActionList.CalculateBoundingRect

switchToFrontside ∷ DeckDSL Unit
switchToFrontside = do
  _ ← queryBacksideActionList $ H.action $ ActionList.CalculateBoundingRect
  flipSideBoundingRect ← queryBacksideActionList $ H.request ActionList.GetBoundingRect
  case flipSideBoundingRect of
    Just (Just dimensions) → do
      _ ← queryNextActionList $ H.action $ ActionList.SetBoundingRect dimensions
      H.modify (_ { displayMode = DCS.FrontSide })
    _ → do
      H.modify (_ { displayMode = DCS.FrontSide })
      void $ queryNextActionList $ H.action $ ActionList.CalculateBoundingRect

handleBackSide ∷ DeckOptions → ActionList.Message Back.BackAction → DeckDSL Unit
handleBackSide opts = case _ of
  ActionList.Selected action → do
    { path } ← H.lift Wiring.expose
    st ← H.get
    case action of
      Back.Trash → do
        let
          active = DCS.activeCard st
          activeIx = DCS.activeCardIndex st
        switchToFrontside
        for_ (join $ Utils.hush <$> active) \{ cardId } → do
          when (activeIx > 0) do
            H.modify _ { activeCardIndex = Just (activeIx - 1) }
            updateActiveState opts
          H.lift $ P.removeCard opts.deckId cardId
      Back.Rename → do
        Wiring.showDialog $ Dialog.Rename opts st.name
      Back.Share → do
        getDeckTree opts.deckId >>= traverse_
          (Wiring.showDialog ∘ Dialog.Share opts ∘ ET.getSharingInput path)
      Back.Unshare → do
        getDeckTree opts.deckId >>= traverse_
          (Wiring.showDialog ∘ Dialog.Unshare opts ∘ ET.getSharingInput path)
      Back.Embed → do
        _ ← H.lift P.saveWorkspace
        getDeckTree opts.deckId >>= traverse_ \tree →
          Wiring.showDialog $ Dialog.Embed
            opts
            (ET.getSharingInput path tree)
            (ET.getVarMaps tree)
      Back.Publish → do
        _ ← H.lift P.saveWorkspace
        getDeckTree opts.deckId >>= traverse_ \tree →
          Wiring.showDialog $ Dialog.Publish
            opts
            (ET.getSharingInput path tree)
            (ET.getVarMaps tree)
      Back.DeleteDeck →
        if Array.length st.displayCards <= 1
          then H.lift $ Common.deleteDeck opts
          else Wiring.showDialog (Dialog.DeleteDeck opts)
      Back.Mirror → do
        let mirrorCard = (Utils.hush =<< DCS.activeCard st) <|> DCS.findLastRealCard st
        deck ← H.lift $ P.getDeck opts.deckId
        case deck >>= _.parent, mirrorCard <#> _.cardId of
          Just parentId, Just cardId | not (L.null opts.displayCursor) → do
            switchToFrontside
            void $ H.lift $ P.mirrorDeck parentId cardId opts.deckId
          _, Just cardId → do
            parentId ← H.lift $ P.wrapAndMirrorDeck cardId opts.deckId
            navigateToDeck (parentId L.: opts.cursor)
          _, _ → pure unit
      Back.WrapChoice CT.Draftboard → wrapDeck Card.singletonDraftboard
      Back.WrapChoice CT.Tabs → wrapDeck Card.singletonTabs
      Back.WrapChoice _ → pure unit
      Back.Wrap → pure unit
      Back.Unwrap → do
        deck ← H.lift $ P.getDeck opts.deckId
        for_ (_.parent <$> deck) case _ of
          Just cardId | not (L.null opts.displayCursor) → do
            void $ H.lift $ P.collapseDeck opts.deckId cardId
          _ → do
            childId ← H.lift $ P.unwrapDeck opts.deckId
            navigateToDeck (childId L.: opts.cursor)
  where
  wrapDeck ∷ (DeckId → Card.AnyCardModel) → DeckDSL Unit
  wrapDeck wrapper = do
    switchToFrontside
    parentId ← H.lift $ P.wrapDeck opts.deckId (wrapper opts.deckId)
    when (L.null opts.displayCursor) do
      navigateToDeck (parentId L.: opts.cursor)

handleBackSideFilter ∷ ActionFilter.Message → DeckDSL Unit
handleBackSideFilter = case _ of
  ActionFilter.FilterChanged str →
    void $ queryBacksideActionList $ H.action $ ActionList.UpdateFilter str

queryBacksideActionList ∷ ∀ a. ActionList.Query Back.BackAction a → DeckDSL (Maybe a)
queryBacksideActionList =
  H.query' cpBackSide unit

queryNextActionList ∷ ∀ a. ActionList.Query Next.NextAction a → DeckDSL (Maybe a)
queryNextActionList =
  H.query' cpNext unit ∘ Next.ToActionList

queryCardEval ∷ ∀ a. CardId → CQ.CardQuery a → DeckDSL (Maybe a)
queryCardEval cid =
  H.query' cpCard cid

queryNextAction ∷ ∀ a. Next.Query a → DeckDSL (Maybe a)
queryNextAction =
  H.query' cpNext unit

updateActiveState ∷ DeckOptions → DeckDSL Unit
updateActiveState opts = do
  st ← H.get
  { cache } ← H.lift Wiring.expose
  for_ st.activeCardIndex \cardIndex →
    H.lift $ Cache.put opts.deckId { cardIndex } cache.activeState

updateBackSide ∷ DeckOptions → DeckDSL Unit
updateBackSide { deckId, displayCursor } = do
  st ← H.get
  let
    ty = join (Utils.hush <$> DCS.activeCard st)
    tys = Array.mapMaybe Utils.hush st.displayCards
  void ∘ H.query' cpBackSide unit ∘ H.action ∘ ActionList.UpdateActions
    =<< getUpdatedBackActions { deckId, displayCursor } ty tys

getUpdatedBackActions
  ∷ Back.BackSideOptions
  → Maybe DCS.CardDef
  → Array DCS.CardDef
  → DeckDSL (Array (ActionList.Action Back.BackAction))
getUpdatedBackActions opts activeCard cards = do
  uw ← fromMaybe false <$> traverse (calculateUnwrappable opts) activeCard
  isAdvanced ← isRight <$> Api.retrieveAuthProviders
  pure $ Back.toActionListAction uw activeCard cards <$> Back.allBackActions isAdvanced

calculateUnwrappable ∷ Back.BackSideOptions → DCS.CardDef → DeckDSL Boolean
calculateUnwrappable { displayCursor, deckId } { cardId } =
  fromMaybe false <$> runMaybeT do
    deck ← MaybeT $ H.lift (P.getDeck deckId)
    card ← MaybeT $ H.lift (P.getCard cardId)
    let
      cardLen = Array.length deck.model.cards
      deckIds = Card.childDeckIds card.model
      mirrorLen = Set.size card.decks
    pure case card.model, displayCursor, deckIds of
      Card.Draftboard _, L.Nil    , _ : L.Nil → cardLen ≡ 1
      Card.Draftboard _, _ : L.Nil, _ → cardLen ≡ 1 && mirrorLen ≡ 1
      _, _, _ → false

getDismissedAccessNextActionCardHintBefore ∷ DeckDSL Boolean
getDismissedAccessNextActionCardHintBefore =
  H.lift
    $ either (const $ false) id
    <$> LS.retrieve LSK.dismissedAccessNextActionCardHintKey

presentAccessNextActionCardHintAfterDelay ∷ DeckDSL Unit
presentAccessNextActionCardHintAfterDelay = void do
  H.modify (DCS._presentAccessNextActionCardHint .~ false)
  H.gets _.presentAccessNextActionCardHintCanceler >>= traverse_ cancel
  sendAfter Config.addCardGuideDelay PresentAccessNextActionCardHint
    >>= H.modify ∘ (DCS._presentAccessNextActionCardHintCanceler .~ _) ∘ Just
  where
  cancel =
    H.liftAff ∘ flip Aff.cancel (Exception.error "Cancelled")

dismissAccessNextActionCardHint ∷ DeckDSL Unit
dismissAccessNextActionCardHint = do
  H.modify (DCS._presentAccessNextActionCardHint .~ false)
  LS.persist LSK.dismissedAccessNextActionCardHintKey true

handleNextAction ∷ DeckOptions → Next.Message → DeckDSL Unit
handleNextAction opts = case _ of
  Next.AddCard cardType → do
    void $ H.lift $ P.addCard opts.deckId cardType
    updateBackSide opts
    whenM (not <$> nextActionCardIsActive) presentAccessNextActionCardHintAfterDelay
  Next.PresentReason input cardType → do
    presentReason opts input cardType

presentReason ∷ DeckOptions → Port.Port → CT.CardType → DeckDSL Unit
presentReason opts input cardType =
  Wiring.showDialog dialog
  where
  insertableCardType = ICT.fromCardType cardType
  ioType = ICT.fromPort input
  reason = ICT.reason ioType cardType
  cardPaths = ICT.cardPathsBetween ioType insertableCardType
  dialog = Dialog.Reason opts cardType reason cardPaths

loadDeck ∷ DeckOptions → DeckDSL Unit
loadDeck opts = mbLoadError =<< runMaybeT do
  deck ← MaybeT $ H.lift $ P.getDeck opts.deckId
  cardDefs ← MaybeT $ getCardDefs deck.model.cards
  lift $ H.subscribe $ busEventSource (\msg → HandleEval msg H.Listening) deck.bus
  lift case deck.status of
    ED.NeedsEval cardId → do
      let displayCards = [ Left DCS.PendingCard ]
      H.modify $ DCS.fromModel { name: deck.model.name, displayCards }
      H.lift $ P.queueEval (Milliseconds 13.0) (opts.deckId L.: opts.cursor × cardId)
    ED.PendingEval cardId → do
      st ← H.get
      active ← activeCardIndex
      let displayCards = map Right cardDefs <> [ Left DCS.PendingCard ]
      H.modify
        $ (DCS._pendingCardIndex .~ DCS.cardIndexFromId cardId st)
        ∘ (DCS._activeCardIndex .~ active)
        ∘ DCS.fromModel { name: deck.model.name, displayCards }
      updateActiveState opts
    ED.Completed (port × _) → do
      active ← activeCardIndex
      H.modify
        $ (DCS.updateCompletedCards cardDefs port)
        ∘ (DCS._activeCardIndex .~ active)
        ∘ (DCS._pendingCardIndex .~ Nothing)
        ∘ DCS.fromModel { name: deck.model.name, displayCards: [] }
      updateActiveState opts
  where
  activeCardIndex = do
    { cache } ← H.lift Wiring.expose
    map _.cardIndex <$> H.lift (Cache.get opts.deckId cache.activeState)

  mbLoadError = case _ of
    Nothing → H.modify _ { loadError = Just "Unable to load deck due to an inconsistent model" }
    Just a  → pure a

handleEval ∷ DeckOptions → ED.EvalMessage → DeckDSL Unit
handleEval opts = case _ of
  ED.Pending cardId → do
    st ← H.get
    H.modify
      $ (DCS._pendingCardIndex .~ DCS.cardIndexFromId cardId st)
      ∘ (DCS.addMetaCard DCS.PendingCard)
  ED.Complete cardIds output@(port × _) → do
    getCardDefs cardIds >>= case _ of
      Nothing →
        H.modify _ { loadError = Just "Deck references non-existent cards" }
      Just cardDefs → do
        _ ← queryNextAction $ H.action $ Next.UpdateInput port
        H.modify (DCS.updateCompletedCards cardDefs port)
        updateActiveState opts
  ED.NameChange name → H.modify _ { name = name }
  ED.CardComplete cardId → do
    H.modify \st →
      let
        ix = DCS.cardIndexFromId cardId st
        lastIx = DCS.findLastCardIndex st
        pendingCardIndex = case ix, lastIx of
          Nothing, _ → st.pendingCardIndex
          _, Nothing → st.pendingCardIndex
          Just ix', Just lastIx'
            | lastIx' > ix' → Just $ ix' + one
            | otherwise → Nothing
      in st # DCS._pendingCardIndex .~ pendingCardIndex

  _ → pure unit

getCardDefs ∷ Array CardId → DeckDSL (Maybe (Array DCS.CardDef))
getCardDefs cardIds =
  sequence <$> for cardIds \cardId →
    map (mkCardDef cardId) <$> H.lift (P.getCard cardId)

mkCardDef ∷ CardId → EC.Cell → DCS.CardDef
mkCardDef cardId cell = { cardId, cardType: Card.modelCardType cell.model }

getDeckTree ∷ DeckId → DeckDSL (Maybe (ET.TraverseDeck ED.Cell EC.Cell))
getDeckTree deckId = do
  wiring ← H.lift Wiring.expose
  decks ← H.lift $ Cache.snapshot wiring.eval.decks
  cards ← H.lift $ Cache.snapshot wiring.eval.cards
  pure (ET.unfoldEvalTree decks cards deckId)

preloadCard ∷ GD.GripperDef → DeckDSL Unit
preloadCard gDef = do
  st ← H.get
  let
    ix = case gDef of
      GD.Previous true → (_ - 1) <$> st.activeCardIndex
      GD.Next true → (_ + 1) <$> st.activeCardIndex
      _ → Nothing
  for_ (ix >>= flip DCS.cardIdFromIndex st) \cardId → do
    void $ queryCardEval cardId $ H.action CQ.PreloadCard

updateCardSize ∷ DeckDSL Unit
updateCardSize =
  H.getHTMLElementRef Common.sizerRef >>= traverse_ \el → void do
    { width, height } ← H.liftEff $ getBoundingClientRect el
    H.modify $ DCS._responsiveSize .~ breakpoint width
    _ ← queryNextActionList $ H.action ActionList.CalculateBoundingRect
    _ ← queryBacksideActionList $ H.action ActionList.CalculateBoundingRect
    H.queryAll' cpCard $ H.action CQ.UpdateDimensions
  where
  breakpoint w
    | w < 240.0 = DCS.XSmall
    | w < 320.0 = DCS.Small
    | w < 420.0 = DCS.Medium
    | w < 540.0 = DCS.Large
    | w < 720.0 = DCS.XLarge
    | otherwise = DCS.XXLarge

presentFlipGuideFirstTime ∷ DeckDSL Unit
presentFlipGuideFirstTime = do
  whenM shouldPresentFlipGuide do
    { bus } ← H.lift Wiring.expose
    H.liftAff $ Bus.write Guide.FlipGuide bus.stepByStep

shouldPresentFlipGuide ∷ DeckDSL Boolean
shouldPresentFlipGuide =
  H.lift
    $ either (const true) not
    <$> LS.retrieve LSK.dismissedFlipGuideKey

{-
Copyright 2016 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.Workspace.Deck.Component
  ( component
  , module SlamData.Workspace.Deck.Component.Query
  , module DCS
  , module SlamData.Workspace.Deck.DeckPath
  ) where

import SlamData.Prelude

import Control.Monad.Aff as Aff
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff.Exception as Exception
import Control.UI.Browser as Browser
import Data.Array as Array
import Data.Lens ((.~), _Left, _Just, is)
import Data.List ((:))
import Data.List as L
import Data.Set as Set
import Data.Time.Duration (Milliseconds(..))
import DOM.HTML.HTMLElement (getBoundingClientRect)
import Halogen as H
import Halogen.Component.Utils (sendAfter, busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import SlamData.ActionList.Component as ActionList
import SlamData.ActionList.Filter.Component as ActionFilter
import SlamData.Config as Config
import SlamData.FileSystem.Routing (parentURL)
import SlamData.GlobalError as GE
import SlamData.LocalStorage.Class as LS
import SlamData.LocalStorage.Keys as LSK
import SlamData.Quasar as Api
import SlamData.Wiring (DeckMessage(..))
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId (CardId)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component.Query as CQ
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.Component as Next
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Class (navigateToDeck)
import SlamData.Workspace.Deck.BackSide as Back
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML, DeckDSL)
import SlamData.Workspace.Deck.Common as Common
import SlamData.Workspace.Deck.Component.ChildSlot (cpCard, cpBackSide, cpNext)
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (Query(..), Message(..))
import SlamData.Workspace.Deck.Component.Render as DCR
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId)
import SlamData.Workspace.Deck.DeckPath (deckPath')
import SlamData.Workspace.Deck.Gripper.Def as GD
import SlamData.Workspace.Deck.Slider as Slider
import SlamData.Workspace.Dialog.Component as Dialog
import SlamData.Workspace.Eval.Card as EC
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse as ET
import SlamData.Workspace.Guide as Guide
import SlamData.Workspace.Routing (mkWorkspaceURL)
import Utils as Utils
import Utils.DOM as DOM

component ∷ DeckOptions → DeckComponent
component opts =
  H.lifecycleParentComponent
    { render: render opts
    , eval: eval opts
    , initialState: const DCS.initialState
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ DeckOptions → DCS.State → DeckHTML
render opts st =
  case st.loadError of
    Just error →
      HH.div
        [ HP.class_ $ HH.ClassName "sd-workspace-error" ]
        [ DCR.renderError error ]
    _ → DCR.renderDeck opts component st

eval ∷ DeckOptions → Query ~> DeckDSL
eval opts = case _ of
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (\msg → HandleMessage msg H.Listening) bus.decks
    H.subscribe $ busEventSource (\msg → HandleHintDismissalMessage msg H.Listening) bus.hintDismissals
    when (L.null opts.displayCursor) do
      H.subscribe $ busEventSource (\msg → HandleError msg H.Listening) bus.globalError
    H.modify
      ∘ (DCS._focusDeckHintDismissed .~ _)
      =<< (Utils.rightBool <$> LS.retrieve LSK.dismissedFocusDeckHintKey)
    H.modify
      ∘ (DCS._focusDeckFrameHintDismissed .~ _)
      =<< (Utils.rightBool <$> LS.retrieve LSK.dismissedFocusDeckFrameHintKey)
    updateCardSize
    loadDeck opts
    pure next
  PresentAccessNextActionCardHint next → do
    st ← H.get
    dismissedBefore ← getDismissedAccessNextActionCardHintBefore
    when
      (not dismissedBefore && isNothing st.initialSliderX && st.focused)
      (H.modify (DCS._presentAccessNextActionCardHint .~ true))
    pure next
  HideAccessNextActionCardHint next →
    dismissAccessNextActionCardHint $> next
  Publish next → do
    { path } ← H.lift Wiring.expose
    let deckPath = deckPath' path opts.deckId
    H.liftEff ∘ Browser.newTab $ mkWorkspaceURL deckPath (WA.Load AT.ReadOnly)
    pure next
  FlipDeck next → do
    displayMode ← H.gets _.displayMode
    if DCS.isFrontSide displayMode
      then switchToFlipside opts
      else switchToFrontside
    pure next
  UpdateCardSize next → do
    updateCardSize
    pure next
  ZoomIn next → do
    navigateToDeck (opts.deckId L.: opts.cursor)
    pure next
  ZoomOut next → do
    { path } ← H.lift Wiring.expose
    if L.null opts.cursor
      then void $ H.liftEff $ Browser.setHref $ parentURL $ Left path
      else navigateToDeck opts.cursor
    pure next
  StartSliding gDef mouseEvent next → do
    H.getHTMLElementRef Common.sizerRef >>= traverse_ \el → do
      width ← getBoundingClientWidth el
      Slider.startSliding mouseEvent gDef width
      preloadCard gDef
    pure next
  StopSlidingAndSnap mouseEvent next → do
    st ← H.get
    Slider.stopSlidingAndSnap mouseEvent
    updateActiveState opts
    whenM nextActionCardIsActive dismissAccessNextActionCardHint
    pure next
  UpdateSliderPosition mouseEvent next →
    Slider.updateSliderPosition mouseEvent $> next
  StopSliderTransition next → do
    H.modify $ DCS._sliderTransition .~ false
    pure next
  Focus ev next → do
    st ← H.get
    H.liftEff $ DOM.stopPropagation ev
    when (not st.focused) do
      H.modify (DCS._focused .~ true)
      Wiring.focusDeck opts.deckId
    when
      (Common.willBePresentedWithChildFrameWhenFocused opts st)
      dismissFocusDeckHint
    nextActionCardIsActive' ← nextActionCardIsActive
    when
      (not nextActionCardIsActive' && not st.presentAccessNextActionCardHint)
      presentAccessNextActionCardHintAfterDelay
    pure next
  Defocus ev next → do
    st ← H.get
    H.modify (DCS._presentAccessNextActionCardHint .~ false)
    H.liftEff $ DOM.stopPropagation ev
    isFrame ← H.liftEff $ DOM.nodeEq (DOM.target ev) (DOM.currentTarget ev)
    when (st.focused && not (L.null opts.displayCursor)) do
      when isFrame do
        for_ (L.last opts.cursor) \rootId → Wiring.focusDeck rootId
    when
      (Common.willBePresentedWithChildFrameWhenFocused opts st)
      dismissFocusDeckFrameHint
    pure next
  DismissedCardGuide next → do
    when (L.null opts.displayCursor) $ void do
      queryNextAction (Next.PresentAddCardHint unit)
    pure next
  GetActiveCard k → do
    active ← H.gets DCS.activeCard
    pure (k (Utils.hush ∘ map _.cardId =<< active))
  HandleEval msg next →
    handleEval opts msg $> next
  HandleMessage msg next → do
    st ← H.get
    case msg of
      DeckFocused focusedDeckId → do
        when (opts.deckId ≡ focusedDeckId && not st.focused) do
          H.modify (DCS._focused .~ true)
        when (opts.deckId ≠ focusedDeckId && st.focused) $
          H.modify
            $ (DCS._focused .~ false)
            ∘ (DCS._presentAccessNextActionCardHint .~ false)
        whenM (not <$> nextActionCardIsActive) presentAccessNextActionCardHintAfterDelay
      SwitchToFront opts' → do
        when (opts'.deckId ≡ opts.deckId && opts'.cursor ≡ opts.cursor)
          switchToFrontside
      SwitchToFlip opts' → do
        when (opts'.deckId ≡ opts.deckId && opts'.cursor ≡ opts.cursor) $
          switchToFlipside opts
    pure next
  HandleHintDismissalMessage msg next → do
    case msg of
      Wiring.DeckFrameFocusHintDismissed →
        H.modify (DCS._focusDeckFrameHintDismissed .~ true)
      Wiring.DeckFocusHintDismissed →
        H.modify (DCS._focusDeckHintDismissed .~ true)
    pure next
  HandleError ge next → do
    Wiring.showDialog $ Dialog.Error opts $ GE.print ge
    pure next
  HandleNextAction msg next → handleNextAction opts msg $> next
  HandleBackFilter msg next → handleBackSideFilter msg $> next
  HandleBackAction msg next → handleBackSide opts msg $> next
  HandleGrab ev next → H.raise (GrabbedDeck ev) $> next
  DismissFocusDeckHint next → do
    dismissFocusDeckHint
    pure next
  DismissFocusDeckFrameHint next → do
    dismissFocusDeckFrameHint
    pure next
  where
  getBoundingClientWidth =
    H.liftEff ∘ map _.width ∘ getBoundingClientRect

nextActionCardIsActive ∷ DeckDSL Boolean
nextActionCardIsActive = do
  st ← H.get
  pure $ DCS.activeCard st # is (_Just ∘ _Left ∘ DCS._NextActionCard)

dismissFocusDeckHint ∷ DeckDSL Unit
dismissFocusDeckHint = do
  wiring ← H.lift Wiring.expose
  H.liftAff $ Bus.write Wiring.DeckFocusHintDismissed wiring.bus.hintDismissals
  H.modify (DCS._focusDeckHintDismissed .~ true)
  LS.persist LSK.dismissedFocusDeckHintKey true

dismissFocusDeckFrameHint ∷ DeckDSL Unit
dismissFocusDeckFrameHint = do
  wiring ← H.lift Wiring.expose
  H.liftAff $ Bus.write Wiring.DeckFrameFocusHintDismissed wiring.bus.hintDismissals
  H.modify (DCS._focusDeckFrameHintDismissed .~ true)
  LS.persist LSK.dismissedFocusDeckFrameHintKey true

-- If an ActionList has the style display: none; then calculating its dimensions
-- will give 0, 0. (This is Mapped to Nothing.)
--
-- If we recalculate after flipping then there may be a momentary flash
-- (observed).
--
-- Sending the dimensions of the next action list to the flip side action list
-- prevents this.
--
-- If there is no next action card this can't be done so just flip and
-- recalculate.
switchToFlipside ∷ DeckOptions → DeckDSL Unit
switchToFlipside opts = do
  updateBackSide opts
  presentFlipGuideFirstTime
  _ ← queryNextActionList $ H.action $ ActionList.CalculateBoundingRect
  nextBoundingRect ← queryNextActionList $ H.request ActionList.GetBoundingRect
  case nextBoundingRect of
    Just (Just dimensions) → do
      _ ← queryBacksideActionList $ H.action $ ActionList.SetBoundingRect dimensions
      H.modify (_ { displayMode = DCS.FlipSide })
    _ → do
      H.modify (_ { displayMode = DCS.FlipSide })
      void $ queryBacksideActionList $ H.action $ ActionList.CalculateBoundingRect

switchToFrontside ∷ DeckDSL Unit
switchToFrontside = do
  _ ← queryBacksideActionList $ H.action $ ActionList.CalculateBoundingRect
  flipSideBoundingRect ← queryBacksideActionList $ H.request ActionList.GetBoundingRect
  case flipSideBoundingRect of
    Just (Just dimensions) → do
      _ ← queryNextActionList $ H.action $ ActionList.SetBoundingRect dimensions
      H.modify (_ { displayMode = DCS.FrontSide })
    _ → do
      H.modify (_ { displayMode = DCS.FrontSide })
      void $ queryNextActionList $ H.action $ ActionList.CalculateBoundingRect

handleBackSide ∷ DeckOptions → ActionList.Message Back.BackAction → DeckDSL Unit
handleBackSide opts = case _ of
  ActionList.Selected action → do
    { path } ← H.lift Wiring.expose
    st ← H.get
    case action of
      Back.Trash → do
        let
          active = DCS.activeCard st
          activeIx = DCS.activeCardIndex st
        switchToFrontside
        for_ (join $ Utils.hush <$> active) \{ cardId } → do
          when (activeIx > 0) do
            H.modify _ { activeCardIndex = Just (activeIx - 1) }
            updateActiveState opts
          H.lift $ P.removeCard opts.deckId cardId
      Back.Rename → do
        Wiring.showDialog $ Dialog.Rename opts st.name
      Back.Share → do
        getDeckTree opts.deckId >>= traverse_
          (Wiring.showDialog ∘ Dialog.Share opts ∘ ET.getSharingInput path)
      Back.Unshare → do
        getDeckTree opts.deckId >>= traverse_
          (Wiring.showDialog ∘ Dialog.Unshare opts ∘ ET.getSharingInput path)
      Back.Embed → do
        _ ← H.lift P.saveWorkspace
        getDeckTree opts.deckId >>= traverse_ \tree →
          Wiring.showDialog $ Dialog.Embed
            opts
            (ET.getSharingInput path tree)
            (ET.getVarMaps tree)
      Back.Publish → do
        _ ← H.lift P.saveWorkspace
        getDeckTree opts.deckId >>= traverse_ \tree →
          Wiring.showDialog $ Dialog.Publish
            opts
            (ET.getSharingInput path tree)
            (ET.getVarMaps tree)
      Back.DeleteDeck →
        if Array.length st.displayCards <= 1
          then H.lift $ Common.deleteDeck opts
          else Wiring.showDialog (Dialog.DeleteDeck opts)
      Back.Mirror → do
        let mirrorCard = (Utils.hush =<< DCS.activeCard st) <|> DCS.findLastRealCard st
        deck ← H.lift $ P.getDeck opts.deckId
        case deck >>= _.parent, mirrorCard <#> _.cardId of
          Just parentId, Just cardId | not (L.null opts.displayCursor) → do
            _ ← H.lift $ P.mirrorDeck parentId cardId opts.deckId
            switchToFrontside
          _, Just cardId → do
            parentId ← H.lift $ P.wrapAndMirrorDeck cardId opts.deckId
            navigateToDeck (parentId L.: opts.cursor)
          _, _ → pure unit
      Back.WrapChoice CT.Draftboard → wrapDeck Card.singletonDraftboard
      Back.WrapChoice CT.Tabs → wrapDeck Card.singletonTabs
      Back.WrapChoice _ → pure unit
      Back.Wrap → pure unit
      Back.Unwrap → do
        deck ← H.lift $ P.getDeck opts.deckId
        for_ (_.parent <$> deck) case _ of
          Just cardId | not (L.null opts.displayCursor) → do
            void $ H.lift $ P.collapseDeck opts.deckId cardId
          _ → do
            childId ← H.lift $ P.unwrapDeck opts.deckId
            navigateToDeck (childId L.: opts.cursor)
  where
  wrapDeck ∷ (DeckId → Card.AnyCardModel) → DeckDSL Unit
  wrapDeck wrapper = do
    parentId ← H.lift $ P.wrapDeck opts.deckId (wrapper opts.deckId)
    if L.null opts.displayCursor
      then navigateToDeck (parentId L.: opts.cursor)
      else switchToFrontside

handleBackSideFilter ∷ ActionFilter.Message → DeckDSL Unit
handleBackSideFilter = case _ of
  ActionFilter.FilterChanged str →
    void $ queryBacksideActionList $ H.action $ ActionList.UpdateFilter str

queryBacksideActionList ∷ ∀ a. ActionList.Query Back.BackAction a → DeckDSL (Maybe a)
queryBacksideActionList =
  H.query' cpBackSide unit

queryNextActionList ∷ ∀ a. ActionList.Query Next.NextAction a → DeckDSL (Maybe a)
queryNextActionList =
  H.query' cpNext unit ∘ Next.ToActionList

queryCardEval ∷ ∀ a. CardId → CQ.CardQuery a → DeckDSL (Maybe a)
queryCardEval cid =
  H.query' cpCard cid

queryNextAction ∷ ∀ a. Next.Query a → DeckDSL (Maybe a)
queryNextAction =
  H.query' cpNext unit

updateActiveState ∷ DeckOptions → DeckDSL Unit
updateActiveState opts = do
  st ← H.get
  { cache } ← H.lift Wiring.expose
  for_ st.activeCardIndex \cardIndex →
    H.lift $ Cache.put opts.deckId { cardIndex } cache.activeState

updateBackSide ∷ DeckOptions → DeckDSL Unit
updateBackSide { deckId, displayCursor } = do
  st ← H.get
  let
    ty = join (Utils.hush <$> DCS.activeCard st)
    tys = Array.mapMaybe Utils.hush st.displayCards
  void ∘ H.query' cpBackSide unit ∘ H.action ∘ ActionList.UpdateActions
    =<< getUpdatedBackActions { deckId, displayCursor } ty tys

getUpdatedBackActions
  ∷ Back.BackSideOptions
  → Maybe DCS.CardDef
  → Array DCS.CardDef
  → DeckDSL (Array (ActionList.Action Back.BackAction))
getUpdatedBackActions opts activeCard cards = do
  uw ← fromMaybe false <$> traverse (calculateUnwrappable opts) activeCard
  isAdvanced ← isRight <$> Api.retrieveAuthProviders
  pure $ Back.toActionListAction uw activeCard cards <$> Back.allBackActions isAdvanced

calculateUnwrappable ∷ Back.BackSideOptions → DCS.CardDef → DeckDSL Boolean
calculateUnwrappable { displayCursor, deckId } { cardId } =
  fromMaybe false <$> runMaybeT do
    deck ← MaybeT $ H.lift (P.getDeck deckId)
    card ← MaybeT $ H.lift (P.getCard cardId)
    let
      cardLen = Array.length deck.model.cards
      deckIds = Card.childDeckIds card.model
      mirrorLen = Set.size card.decks
    pure case card.model, displayCursor, deckIds of
      Card.Draftboard _, L.Nil    , _ : L.Nil → cardLen ≡ 1
      Card.Draftboard _, _ : L.Nil, _ → cardLen ≡ 1 && mirrorLen ≡ 1
      _, _, _ → false

getDismissedAccessNextActionCardHintBefore ∷ DeckDSL Boolean
getDismissedAccessNextActionCardHintBefore =
  H.lift
    $ either (const $ false) id
    <$> LS.retrieve LSK.dismissedAccessNextActionCardHintKey

presentAccessNextActionCardHintAfterDelay ∷ DeckDSL Unit
presentAccessNextActionCardHintAfterDelay = void do
  H.modify (DCS._presentAccessNextActionCardHint .~ false)
  H.gets _.presentAccessNextActionCardHintCanceler >>= traverse_ cancel
  sendAfter Config.addCardGuideDelay PresentAccessNextActionCardHint
    >>= H.modify ∘ (DCS._presentAccessNextActionCardHintCanceler .~ _) ∘ Just
  where
  cancel =
    H.liftAff ∘ flip Aff.cancel (Exception.error "Cancelled")

dismissAccessNextActionCardHint ∷ DeckDSL Unit
dismissAccessNextActionCardHint = do
  H.modify (DCS._presentAccessNextActionCardHint .~ false)
  LS.persist LSK.dismissedAccessNextActionCardHintKey true

handleNextAction ∷ DeckOptions → Next.Message → DeckDSL Unit
handleNextAction opts = case _ of
  Next.AddCard cardType → do
    void $ H.lift $ P.addCard opts.deckId cardType
    updateBackSide opts
    whenM (not <$> nextActionCardIsActive) presentAccessNextActionCardHintAfterDelay
  Next.PresentReason input cardType → do
    presentReason opts input cardType

presentReason ∷ DeckOptions → Port.Port → CT.CardType → DeckDSL Unit
presentReason opts input cardType =
  Wiring.showDialog dialog
  where
  insertableCardType = ICT.fromCardType cardType
  ioType = ICT.fromPort input
  reason = ICT.reason ioType cardType
  cardPaths = ICT.cardPathsBetween ioType insertableCardType
  dialog = Dialog.Reason opts cardType reason cardPaths

loadDeck ∷ DeckOptions → DeckDSL Unit
loadDeck opts = mbLoadError =<< runMaybeT do
  deck ← MaybeT $ H.lift $ P.getDeck opts.deckId
  cardDefs ← MaybeT $ getCardDefs deck.model.cards
  lift $ H.subscribe $ busEventSource (\msg → HandleEval msg H.Listening) deck.bus
  lift case deck.status of
    ED.NeedsEval cardId → do
      let displayCards = [ Left DCS.PendingCard ]
      H.modify $ DCS.fromModel { name: deck.model.name, displayCards }
      H.lift $ P.queueEval (Milliseconds 13.0) (opts.deckId L.: opts.cursor × cardId)
    ED.PendingEval cardId → do
      st ← H.get
      active ← activeCardIndex
      let displayCards = map Right cardDefs <> [ Left DCS.PendingCard ]
      H.modify
        $ (DCS._pendingCardIndex .~ DCS.cardIndexFromId cardId st)
        ∘ (DCS._activeCardIndex .~ active)
        ∘ DCS.fromModel { name: deck.model.name, displayCards }
      updateActiveState opts
    ED.Completed (port × _) → do
      active ← activeCardIndex
      H.modify
        $ (DCS.updateCompletedCards cardDefs port)
        ∘ (DCS._activeCardIndex .~ active)
        ∘ (DCS._pendingCardIndex .~ Nothing)
        ∘ DCS.fromModel { name: deck.model.name, displayCards: [] }
      updateActiveState opts
  where
  activeCardIndex = do
    { cache } ← H.lift Wiring.expose
    map _.cardIndex <$> H.lift (Cache.get opts.deckId cache.activeState)

  mbLoadError = case _ of
    Nothing → H.modify _ { loadError = Just "Unable to load deck due to an inconsistent model" }
    Just a  → pure a

handleEval ∷ DeckOptions → ED.EvalMessage → DeckDSL Unit
handleEval opts = case _ of
  ED.Pending cardId → do
    st ← H.get
    H.modify
      $ (DCS._pendingCardIndex .~ DCS.cardIndexFromId cardId st)
      ∘ (DCS.addMetaCard DCS.PendingCard)
  ED.Complete cardIds output@(port × _) → do
    getCardDefs cardIds >>= case _ of
      Nothing →
        H.modify _ { loadError = Just "Deck references non-existent cards" }
      Just cardDefs → do
        _ ← queryNextAction $ H.action $ Next.UpdateInput port
        H.modify (DCS.updateCompletedCards cardDefs port)
        updateActiveState opts
  ED.NameChange name → H.modify _ { name = name }
  ED.CardComplete cardId → do
    H.modify \st →
      let
        ix = DCS.cardIndexFromId cardId st
        lastIx = DCS.findLastCardIndex st
        pendingCardIndex = case ix, lastIx of
          Nothing, _ → st.pendingCardIndex
          _, Nothing → st.pendingCardIndex
          Just ix', Just lastIx'
            | lastIx' > ix' → Just $ ix' + one
            | otherwise → Nothing
      in st # DCS._pendingCardIndex .~ pendingCardIndex

  _ → pure unit

getCardDefs ∷ Array CardId → DeckDSL (Maybe (Array DCS.CardDef))
getCardDefs cardIds =
  sequence <$> for cardIds \cardId →
    map (mkCardDef cardId) <$> H.lift (P.getCard cardId)

mkCardDef ∷ CardId → EC.Cell → DCS.CardDef
mkCardDef cardId cell = { cardId, cardType: Card.modelCardType cell.model }

getDeckTree ∷ DeckId → DeckDSL (Maybe (ET.TraverseDeck ED.Cell EC.Cell))
getDeckTree deckId = do
  wiring ← H.lift Wiring.expose
  decks ← H.lift $ Cache.snapshot wiring.eval.decks
  cards ← H.lift $ Cache.snapshot wiring.eval.cards
  pure (ET.unfoldEvalTree decks cards deckId)

preloadCard ∷ GD.GripperDef → DeckDSL Unit
preloadCard gDef = do
  st ← H.get
  let
    ix = case gDef of
      GD.Previous true → (_ - 1) <$> st.activeCardIndex
      GD.Next true → (_ + 1) <$> st.activeCardIndex
      _ → Nothing
  for_ (ix >>= flip DCS.cardIdFromIndex st) \cardId → do
    void $ queryCardEval cardId $ H.action CQ.PreloadCard

updateCardSize ∷ DeckDSL Unit
updateCardSize =
  H.getHTMLElementRef Common.sizerRef >>= traverse_ \el → void do
    { width, height } ← H.liftEff $ getBoundingClientRect el
    H.modify $ DCS._responsiveSize .~ breakpoint width
    _ ← queryNextActionList $ H.action ActionList.CalculateBoundingRect
    _ ← queryBacksideActionList $ H.action ActionList.CalculateBoundingRect
    H.queryAll' cpCard $ H.action CQ.UpdateDimensions
  where
  breakpoint w
    | w < 240.0 = DCS.XSmall
    | w < 320.0 = DCS.Small
    | w < 420.0 = DCS.Medium
    | w < 540.0 = DCS.Large
    | w < 720.0 = DCS.XLarge
    | otherwise = DCS.XXLarge

presentFlipGuideFirstTime ∷ DeckDSL Unit
presentFlipGuideFirstTime = do
  whenM shouldPresentFlipGuide do
    { bus } ← H.lift Wiring.expose
    H.liftAff $ Bus.write Guide.FlipGuide bus.stepByStep

shouldPresentFlipGuide ∷ DeckDSL Boolean
shouldPresentFlipGuide =
  H.lift
    $ either (const true) not
    <$> LS.retrieve LSK.dismissedFlipGuideKey


kill primed adapter functions

kill primed adapter functions

kill `unsafeAdapt'`, `unsafeAdapt''`, `adaptAny'`, `adaptAny''`

module Data.Array.NonEmpty
  ( NonEmptyArray
  , fromArray
  , fromNonEmpty
  , toArray
  , toNonEmpty

  , fromFoldable
  , fromFoldable1
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some

  , length

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

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

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

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , mapMaybe
  , catMaybes

  , sort
  , sortBy
  , sortWith
  , slice
  , take
  , takeEnd
  , takeWhile
  , drop
  , dropEnd
  , dropWhile
  , span

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

  , (\\), difference
  , difference'
  , intersect
  , intersect'
  , intersectBy
  , intersectBy'

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Bifunctor (bimap)
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.Maybe (Maybe(..), fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1, foldMap1Default)
import Data.Semigroup.Traversable (class Traversable1, sequence1Default)
import Data.Traversable (class Traversable)
import Data.TraversableWithIndex (class TraversableWithIndex)
import Data.Tuple (Tuple)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafePartial)

newtype NonEmptyArray a = NonEmptyArray (Array a)

instance showNonEmptyArray :: Show a => Show (NonEmptyArray a) where
  show (NonEmptyArray xs) = "(NonEmptyArray " <> show xs <> ")"

derive newtype instance eqNonEmptyArray :: Eq a => Eq (NonEmptyArray a)
derive newtype instance eq1NonEmptyArray :: Eq1 NonEmptyArray

derive newtype instance ordNonEmptyArray :: Ord a => Ord (NonEmptyArray a)
derive newtype instance ord1NonEmptyArray :: Ord1 NonEmptyArray

derive newtype instance functorNonEmptyArray :: Functor NonEmptyArray
derive newtype instance functorWithIndexNonEmptyArray :: FunctorWithIndex Int NonEmptyArray

derive newtype instance foldableNonEmptyArray :: Foldable NonEmptyArray
derive newtype instance foldableWithIndexNonEmptyArray :: FoldableWithIndex Int NonEmptyArray

instance foldable1NonEmptyArray :: Foldable1 NonEmptyArray where
  foldMap1 = foldMap1Default
  fold1 = fold1Impl (<>)

derive newtype instance traversableNonEmptyArray :: Traversable NonEmptyArray
derive newtype instance traversableWithIndexNonEmptyArray :: TraversableWithIndex Int NonEmptyArray

instance traversable1NonEmptyArray :: Traversable1 NonEmptyArray where
  traverse1 = traverse1Impl apply map
  sequence1 = sequence1Default

derive newtype instance applyNonEmptyArray :: Apply NonEmptyArray

derive newtype instance applicativeNonEmptyArray :: Applicative NonEmptyArray

derive newtype instance bindNonEmptyArray :: Bind NonEmptyArray

derive newtype instance monadNonEmptyArray :: Monad NonEmptyArray

derive newtype instance altNonEmptyArray :: Alt NonEmptyArray

-- | Internal - adapt an Array transform to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt :: forall a b. (Array a -> Array b) -> NonEmptyArray a -> NonEmptyArray b
unsafeAdapt f = NonEmptyArray <<< adaptAny f

-- | Internal - adapt an Array transform to NonEmptyArray,
--   with polymorphic result.
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
adaptAny :: forall a b. (Array a -> b) -> NonEmptyArray a -> b
adaptAny f = f <<< toArray

-- | Internal - adapt Array functions returning Maybes to NonEmptyArray
adaptMaybe :: forall a b. (Array a -> Maybe b) -> NonEmptyArray a -> b
adaptMaybe f = unsafePartial $ fromJust <<< f <<< toArray

fromArray :: forall a. Array a -> Maybe (NonEmptyArray a)
fromArray xs
  | A.length xs > 0 = Just (NonEmptyArray xs)
  | otherwise       = Nothing

-- | INTERNAL
unsafeFromArray :: forall a. Array a -> NonEmptyArray a
unsafeFromArray = NonEmptyArray

fromNonEmpty :: forall a. NonEmpty Array a -> NonEmptyArray a
fromNonEmpty (x :| xs) = cons' x xs

toArray :: forall a. NonEmptyArray a -> Array a
toArray (NonEmptyArray xs) = xs

toNonEmpty :: forall a. NonEmptyArray a -> NonEmpty Array a
toNonEmpty = uncons >>> \{head: x, tail: xs} -> x :| xs

fromFoldable :: forall f a. Foldable f => f a -> Maybe (NonEmptyArray a)
fromFoldable = fromArray <<< A.fromFoldable

fromFoldable1 :: forall f a. Foldable1 f => f a -> NonEmptyArray a
fromFoldable1 = unsafeFromArray <<< A.fromFoldable

toUnfoldable :: forall f a. Unfoldable f => NonEmptyArray a -> f a
toUnfoldable = adaptAny A.toUnfoldable

singleton :: forall a. a -> NonEmptyArray a
singleton = NonEmptyArray <<< A.singleton

range :: Int -> Int -> NonEmptyArray Int
range x y = unsafeFromArray $ A.range x y

infix 8 range as ..

-- | Replicate an item at least once
replicate :: forall a. Int -> a -> NonEmptyArray a
replicate i x = NonEmptyArray $ A.replicate (max 1 i) x

some
  :: forall f a
   . Alternative f
  => Lazy (f (Array a))
  => f a -> f (NonEmptyArray a)
some = map NonEmptyArray <<< A.some

length :: forall a. NonEmptyArray a -> Int
length = adaptAny A.length

cons :: forall a. a -> NonEmptyArray a -> NonEmptyArray a
cons x = unsafeAdapt $ A.cons x

infixr 6 cons as :

cons' :: forall a. a -> Array a -> NonEmptyArray a
cons' x xs = unsafeFromArray $ A.cons x xs

snoc :: forall a. NonEmptyArray a -> a -> NonEmptyArray a
snoc xs x = unsafeFromArray $ A.snoc (toArray xs) x

snoc' :: forall a. Array a -> a -> NonEmptyArray a
snoc' xs x = unsafeFromArray $ A.snoc xs x

appendArray :: forall a. NonEmptyArray a -> Array a -> NonEmptyArray a
appendArray xs ys = unsafeFromArray $ toArray xs <> ys

insert :: forall a. Ord a => a -> NonEmptyArray a -> NonEmptyArray a
insert x = unsafeAdapt $ A.insert x

insertBy :: forall a. (a -> a -> Ordering) -> a -> NonEmptyArray a -> NonEmptyArray a
insertBy f x = unsafeAdapt $ A.insertBy f x

head :: forall a. NonEmptyArray a -> a
head = adaptMaybe A.head

last :: forall a. NonEmptyArray a -> a
last = adaptMaybe A.last

tail :: forall a. NonEmptyArray a -> Array a
tail = adaptMaybe A.tail

init :: forall a. NonEmptyArray a -> Array a
init = adaptMaybe A.init

uncons :: forall a. NonEmptyArray a -> { head :: a, tail :: Array a }
uncons = adaptMaybe A.uncons

unsnoc :: forall a. NonEmptyArray a -> { init :: Array a, last :: a }
unsnoc = adaptMaybe A.unsnoc

index :: forall a. NonEmptyArray a -> Int -> Maybe a
index = adaptAny A.index

infixl 8 index as !!

elemIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemIndex x = adaptAny $ A.elemIndex x

elemLastIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemLastIndex x = adaptAny $ A.elemLastIndex x

findIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findIndex x = adaptAny $ A.findIndex x

findLastIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findLastIndex x = adaptAny $ A.findLastIndex x

insertAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
insertAt i x = map NonEmptyArray <<< A.insertAt i x <<< toArray

deleteAt :: forall a. Int -> NonEmptyArray a -> Maybe (Array a)
deleteAt i = adaptAny $ A.deleteAt i

updateAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
updateAt i x = map NonEmptyArray <<< A.updateAt i x <<< toArray

updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> NonEmptyArray a -> NonEmptyArray a
updateAtIndices pairs = unsafeAdapt $ A.updateAtIndices pairs

modifyAt :: forall a. Int -> (a -> a) -> NonEmptyArray a -> Maybe (NonEmptyArray a)
modifyAt i f = map NonEmptyArray <<< A.modifyAt i f <<< toArray

modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> NonEmptyArray a -> NonEmptyArray a
modifyAtIndices is f = unsafeAdapt $ A.modifyAtIndices is f

alterAt :: forall a. Int -> (a -> Maybe a) -> NonEmptyArray a -> Maybe (Array a)
alterAt i f = A.alterAt i f <<< toArray

reverse :: forall a. NonEmptyArray a -> NonEmptyArray a
reverse = unsafeAdapt A.reverse

concat :: forall a. NonEmptyArray (NonEmptyArray a) -> NonEmptyArray a
concat = NonEmptyArray <<< A.concat <<< toArray <<< map toArray

concatMap :: forall a b. (a -> NonEmptyArray b) -> NonEmptyArray a -> NonEmptyArray b
concatMap = flip bind

filter :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
filter f = adaptAny $ A.filter f

partition
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { yes :: Array a, no :: Array a}
partition f = adaptAny $ A.partition f

filterA
  :: forall a f
   . Applicative f
  => (a -> f Boolean)
  -> NonEmptyArray a
  -> f (Array a)
filterA f = adaptAny $ A.filterA f

mapMaybe :: forall a b. (a -> Maybe b) -> NonEmptyArray a -> Array b
mapMaybe f = adaptAny $ A.mapMaybe f

catMaybes :: forall a. NonEmptyArray (Maybe a) -> Array a
catMaybes = adaptAny A.catMaybes

sort :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray a
sort = unsafeAdapt A.sort

sortBy :: forall a. (a -> a -> Ordering) -> NonEmptyArray a -> NonEmptyArray a
sortBy f = unsafeAdapt $ A.sortBy f

sortWith :: forall a b. Ord b => (a -> b) -> NonEmptyArray a -> NonEmptyArray a
sortWith f = unsafeAdapt $ A.sortWith f

slice :: forall a. Int -> Int -> NonEmptyArray a -> Array a
slice start end = adaptAny $ A.slice start end

take :: forall a. Int -> NonEmptyArray a -> Array a
take i = adaptAny $ A.take i

takeEnd :: forall a. Int -> NonEmptyArray a -> Array a
takeEnd i = adaptAny $ A.takeEnd i

takeWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
takeWhile f = adaptAny $ A.takeWhile f

drop :: forall a. Int -> NonEmptyArray a -> Array a
drop i = adaptAny $ A.drop i

dropEnd :: forall a. Int -> NonEmptyArray a -> Array a
dropEnd i = adaptAny $ A.dropEnd i

dropWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
dropWhile f = adaptAny $ A.dropWhile f

span
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { init :: Array a, rest :: Array a }
span f = adaptAny $ A.span f

nub :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a
nub = unsafeAdapt A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray a
nubBy f = unsafeAdapt $ A.nubBy f

union :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a -> NonEmptyArray a
union = unionBy (==)

union' :: forall a. Eq a => NonEmptyArray a -> Array a -> NonEmptyArray a
union' = unionBy' (==)

unionBy
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> NonEmptyArray a
  -> NonEmptyArray a
unionBy eq xs = unionBy' eq xs <<< toArray

unionBy'
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> Array a
  -> NonEmptyArray a
unionBy' eq xs = unsafeFromArray <<< A.unionBy eq (toArray xs)

delete :: forall a. Eq a => a -> NonEmptyArray a -> Array a
delete x = adaptAny $ A.delete x

deleteBy :: forall a. (a -> a -> Boolean) -> a -> NonEmptyArray a -> Array a
deleteBy f x = adaptAny $ A.deleteBy f x

difference :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a -> Array a
difference xs = adaptAny $ difference' xs

difference' :: forall a. Eq a => NonEmptyArray a -> Array a -> Array a
difference' xs = A.difference $ toArray xs

intersect :: forall a . Eq a => NonEmptyArray a -> NonEmptyArray a -> Array a
intersect = intersectBy eq

intersect' :: forall a . Eq a => NonEmptyArray a -> Array a -> Array a
intersect' = intersectBy' eq

intersectBy
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> NonEmptyArray a
  -> Array a
intersectBy eq xs = intersectBy' eq xs <<< toArray

intersectBy'
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> Array a
  -> Array a
intersectBy' eq xs = A.intersectBy eq (toArray xs)

infix 5 difference as \\

zipWith
  :: forall a b c
   . (a -> b -> c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> NonEmptyArray c
zipWith f xs ys = NonEmptyArray $ A.zipWith f (toArray xs) (toArray ys)

zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> m (NonEmptyArray c)
zipWithA f xs ys = NonEmptyArray <$> A.zipWithA f (toArray xs) (toArray ys)

zip :: forall a b. NonEmptyArray a -> NonEmptyArray b -> NonEmptyArray (Tuple a b)
zip xs ys = NonEmptyArray $ toArray xs `A.zip` toArray ys

unzip :: forall a b. NonEmptyArray (Tuple a b) -> Tuple (NonEmptyArray a) (NonEmptyArray b)
unzip = bimap NonEmptyArray NonEmptyArray <<< A.unzip <<< toArray

foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldM f acc = adaptAny $ A.foldM f acc

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldRecM f acc = adaptAny $ A.foldRecM f acc

unsafeIndex :: forall a. Partial => NonEmptyArray a -> Int -> a
unsafeIndex = adaptAny A.unsafeIndex

-- we use FFI here to avoid the unnecessary copy created by `tail`
foreign import fold1Impl :: forall a. (a -> a -> a) -> NonEmptyArray a -> a

foreign import traverse1Impl
  :: forall m a b
   . (forall a' b'. (m (a' -> b') -> m a' -> m b'))
  -> (forall a' b'. (a' -> b') -> m a' -> m b')
  -> (a -> m b)
  -> NonEmptyArray a
  -> m (NonEmptyArray b)

module Data.Array.NonEmpty
  ( NonEmptyArray
  , fromArray
  , fromNonEmpty
  , toArray
  , toNonEmpty

  , fromFoldable
  , fromFoldable1
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some

  , length

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

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

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

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , mapMaybe
  , catMaybes

  , sort
  , sortBy
  , sortWith
  , slice
  , take
  , takeEnd
  , takeWhile
  , drop
  , dropEnd
  , dropWhile
  , span

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

  , (\\), difference
  , difference'
  , intersect
  , intersect'
  , intersectBy
  , intersectBy'

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Bifunctor (bimap)
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.Maybe (Maybe(..), fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1, foldMap1Default)
import Data.Semigroup.Traversable (class Traversable1, sequence1Default)
import Data.Traversable (class Traversable)
import Data.TraversableWithIndex (class TraversableWithIndex)
import Data.Tuple (Tuple)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafePartial)

newtype NonEmptyArray a = NonEmptyArray (Array a)

instance showNonEmptyArray :: Show a => Show (NonEmptyArray a) where
  show (NonEmptyArray xs) = "(NonEmptyArray " <> show xs <> ")"

derive newtype instance eqNonEmptyArray :: Eq a => Eq (NonEmptyArray a)
derive newtype instance eq1NonEmptyArray :: Eq1 NonEmptyArray

derive newtype instance ordNonEmptyArray :: Ord a => Ord (NonEmptyArray a)
derive newtype instance ord1NonEmptyArray :: Ord1 NonEmptyArray

derive newtype instance functorNonEmptyArray :: Functor NonEmptyArray
derive newtype instance functorWithIndexNonEmptyArray :: FunctorWithIndex Int NonEmptyArray

derive newtype instance foldableNonEmptyArray :: Foldable NonEmptyArray
derive newtype instance foldableWithIndexNonEmptyArray :: FoldableWithIndex Int NonEmptyArray

instance foldable1NonEmptyArray :: Foldable1 NonEmptyArray where
  foldMap1 = foldMap1Default
  fold1 = fold1Impl (<>)

derive newtype instance traversableNonEmptyArray :: Traversable NonEmptyArray
derive newtype instance traversableWithIndexNonEmptyArray :: TraversableWithIndex Int NonEmptyArray

instance traversable1NonEmptyArray :: Traversable1 NonEmptyArray where
  traverse1 = traverse1Impl apply map
  sequence1 = sequence1Default

derive newtype instance applyNonEmptyArray :: Apply NonEmptyArray

derive newtype instance applicativeNonEmptyArray :: Applicative NonEmptyArray

derive newtype instance bindNonEmptyArray :: Bind NonEmptyArray

derive newtype instance monadNonEmptyArray :: Monad NonEmptyArray

derive newtype instance altNonEmptyArray :: Alt NonEmptyArray

-- | Internal - adapt an Array transform to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt :: forall a b. (Array a -> Array b) -> NonEmptyArray a -> NonEmptyArray b
unsafeAdapt f = NonEmptyArray <<< adaptAny f

-- | Internal - adapt an Array transform with argument to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt' :: forall a b c. (a -> Array b -> Array c) -> a -> NonEmptyArray b -> NonEmptyArray c
unsafeAdapt' f = unsafeAdapt <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt'' :: forall a b c d. (a -> b -> Array c -> Array d) -> a -> b -> NonEmptyArray c -> NonEmptyArray d
unsafeAdapt'' f = unsafeAdapt' <<< f

-- | Internal - adapt an Array transform to NonEmptyArray,
--   with polymorphic result.
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
adaptAny :: forall a b. (Array a -> b) -> NonEmptyArray a -> b
adaptAny f = f <<< toArray

-- | Internal - adapt an Array transform with argument to NonEmptyArray,
--   with polymorphic result.
adaptAny' :: forall a b c. (a -> Array b -> c) -> a -> NonEmptyArray b -> c
adaptAny' f = adaptAny <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray,
--   with polymorphic result.
adaptAny'' :: forall a b c d. (a -> b -> Array c -> d) -> a -> b -> NonEmptyArray c -> d
adaptAny'' f = adaptAny' <<< f

-- | Internal - adapt Array functions returning Maybes to NonEmptyArray
adaptMaybe :: forall a b. (Array a -> Maybe b) -> NonEmptyArray a -> b
adaptMaybe f = unsafePartial $ fromJust <<< f <<< toArray

fromArray :: forall a. Array a -> Maybe (NonEmptyArray a)
fromArray xs
  | A.length xs > 0 = Just (NonEmptyArray xs)
  | otherwise       = Nothing

-- | INTERNAL
unsafeFromArray :: forall a. Array a -> NonEmptyArray a
unsafeFromArray = NonEmptyArray

fromNonEmpty :: forall a. NonEmpty Array a -> NonEmptyArray a
fromNonEmpty (x :| xs) = cons' x xs

toArray :: forall a. NonEmptyArray a -> Array a
toArray (NonEmptyArray xs) = xs

toNonEmpty :: forall a. NonEmptyArray a -> NonEmpty Array a
toNonEmpty = uncons >>> \{head: x, tail: xs} -> x :| xs

fromFoldable :: forall f a. Foldable f => f a -> Maybe (NonEmptyArray a)
fromFoldable = fromArray <<< A.fromFoldable

fromFoldable1 :: forall f a. Foldable1 f => f a -> NonEmptyArray a
fromFoldable1 = unsafeFromArray <<< A.fromFoldable

toUnfoldable :: forall f a. Unfoldable f => NonEmptyArray a -> f a
toUnfoldable = adaptAny A.toUnfoldable

singleton :: forall a. a -> NonEmptyArray a
singleton = NonEmptyArray <<< A.singleton

range :: Int -> Int -> NonEmptyArray Int
range x y = unsafeFromArray $ A.range x y

infix 8 range as ..

-- | Replicate an item at least once
replicate :: forall a. Int -> a -> NonEmptyArray a
replicate i x = NonEmptyArray $ A.replicate (max 1 i) x

some
  :: forall f a
   . Alternative f
  => Lazy (f (Array a))
  => f a -> f (NonEmptyArray a)
some = map NonEmptyArray <<< A.some

length :: forall a. NonEmptyArray a -> Int
length = adaptAny A.length

cons :: forall a. a -> NonEmptyArray a -> NonEmptyArray a
cons = unsafeAdapt' A.cons

infixr 6 cons as :

cons' :: forall a. a -> Array a -> NonEmptyArray a
cons' x xs = unsafeFromArray $ A.cons x xs

snoc :: forall a. NonEmptyArray a -> a -> NonEmptyArray a
snoc xs x = unsafeFromArray $ A.snoc (toArray xs) x

snoc' :: forall a. Array a -> a -> NonEmptyArray a
snoc' xs x = unsafeFromArray $ A.snoc xs x

appendArray :: forall a. NonEmptyArray a -> Array a -> NonEmptyArray a
appendArray xs ys = unsafeFromArray $ toArray xs <> ys

insert :: forall a. Ord a => a -> NonEmptyArray a -> NonEmptyArray a
insert = unsafeAdapt' A.insert

insertBy :: forall a. (a -> a -> Ordering) -> a -> NonEmptyArray a -> NonEmptyArray a
insertBy = unsafeAdapt'' A.insertBy

head :: forall a. NonEmptyArray a -> a
head = adaptMaybe A.head

last :: forall a. NonEmptyArray a -> a
last = adaptMaybe A.last

tail :: forall a. NonEmptyArray a -> Array a
tail = adaptMaybe A.tail

init :: forall a. NonEmptyArray a -> Array a
init = adaptMaybe A.init

uncons :: forall a. NonEmptyArray a -> { head :: a, tail :: Array a }
uncons = adaptMaybe A.uncons

unsnoc :: forall a. NonEmptyArray a -> { init :: Array a, last :: a }
unsnoc = adaptMaybe A.unsnoc

index :: forall a. NonEmptyArray a -> Int -> Maybe a
index = adaptAny A.index

infixl 8 index as !!

elemIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemIndex = adaptAny' A.elemIndex

elemLastIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemLastIndex = adaptAny' A.elemLastIndex

findIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findIndex = adaptAny' A.findIndex

findLastIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findLastIndex = adaptAny' A.findLastIndex

insertAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
insertAt i x = map NonEmptyArray <<< A.insertAt i x <<< toArray

deleteAt :: forall a. Int -> NonEmptyArray a -> Maybe (Array a)
deleteAt = adaptAny' A.deleteAt

updateAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
updateAt i x = map NonEmptyArray <<< A.updateAt i x <<< toArray

updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> NonEmptyArray a -> NonEmptyArray a
updateAtIndices = unsafeAdapt' A.updateAtIndices

modifyAt :: forall a. Int -> (a -> a) -> NonEmptyArray a -> Maybe (NonEmptyArray a)
modifyAt i f = map NonEmptyArray <<< A.modifyAt i f <<< toArray

modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> NonEmptyArray a -> NonEmptyArray a
modifyAtIndices = unsafeAdapt'' A.modifyAtIndices

alterAt :: forall a. Int -> (a -> Maybe a) -> NonEmptyArray a -> Maybe (Array a)
alterAt i f = A.alterAt i f <<< toArray

reverse :: forall a. NonEmptyArray a -> NonEmptyArray a
reverse = unsafeAdapt A.reverse

concat :: forall a. NonEmptyArray (NonEmptyArray a) -> NonEmptyArray a
concat = NonEmptyArray <<< A.concat <<< toArray <<< map toArray

concatMap :: forall a b. (a -> NonEmptyArray b) -> NonEmptyArray a -> NonEmptyArray b
concatMap = flip bind

filter :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
filter = adaptAny' A.filter

partition
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { yes :: Array a, no :: Array a}
partition = adaptAny' A.partition

filterA
  :: forall a f
   . Applicative f
  => (a -> f Boolean)
  -> NonEmptyArray a
  -> f (Array a)
filterA = adaptAny' A.filterA

mapMaybe :: forall a b. (a -> Maybe b) -> NonEmptyArray a -> Array b
mapMaybe = adaptAny' A.mapMaybe

catMaybes :: forall a. NonEmptyArray (Maybe a) -> Array a
catMaybes = adaptAny A.catMaybes

sort :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray a
sort = unsafeAdapt A.sort

sortBy :: forall a. (a -> a -> Ordering) -> NonEmptyArray a -> NonEmptyArray a
sortBy = unsafeAdapt' A.sortBy

sortWith :: forall a b. Ord b => (a -> b) -> NonEmptyArray a -> NonEmptyArray a
sortWith = unsafeAdapt' A.sortWith

slice :: forall a. Int -> Int -> NonEmptyArray a -> Array a
slice = adaptAny'' A.slice

take :: forall a. Int -> NonEmptyArray a -> Array a
take = adaptAny' A.take

takeEnd :: forall a. Int -> NonEmptyArray a -> Array a
takeEnd = adaptAny' A.takeEnd

takeWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
takeWhile = adaptAny' A.takeWhile

drop :: forall a. Int -> NonEmptyArray a -> Array a
drop = adaptAny' A.drop

dropEnd :: forall a. Int -> NonEmptyArray a -> Array a
dropEnd = adaptAny' A.dropEnd

dropWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
dropWhile = adaptAny' A.dropWhile

span
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { init :: Array a, rest :: Array a }
span = adaptAny' A.span

nub :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a
nub = unsafeAdapt A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray a
nubBy = unsafeAdapt' A.nubBy

union :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a -> NonEmptyArray a
union = unionBy (==)

union' :: forall a. Eq a => NonEmptyArray a -> Array a -> NonEmptyArray a
union' = unionBy' (==)

unionBy
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> NonEmptyArray a
  -> NonEmptyArray a
unionBy eq xs = unionBy' eq xs <<< toArray

unionBy'
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> Array a
  -> NonEmptyArray a
unionBy' eq xs = unsafeFromArray <<< A.unionBy eq (toArray xs)

delete :: forall a. Eq a => a -> NonEmptyArray a -> Array a
delete = adaptAny' A.delete

deleteBy :: forall a. (a -> a -> Boolean) -> a -> NonEmptyArray a -> Array a
deleteBy = adaptAny'' A.deleteBy

difference :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a -> Array a
difference xs = adaptAny $ difference' xs

difference' :: forall a. Eq a => NonEmptyArray a -> Array a -> Array a
difference' xs = A.difference $ toArray xs

intersect :: forall a . Eq a => NonEmptyArray a -> NonEmptyArray a -> Array a
intersect = intersectBy eq

intersect' :: forall a . Eq a => NonEmptyArray a -> Array a -> Array a
intersect' = intersectBy' eq

intersectBy
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> NonEmptyArray a
  -> Array a
intersectBy eq xs = intersectBy' eq xs <<< toArray

intersectBy'
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> Array a
  -> Array a
intersectBy' eq xs = A.intersectBy eq (toArray xs)

infix 5 difference as \\

zipWith
  :: forall a b c
   . (a -> b -> c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> NonEmptyArray c
zipWith f xs ys = NonEmptyArray $ A.zipWith f (toArray xs) (toArray ys)

zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> m (NonEmptyArray c)
zipWithA f xs ys = NonEmptyArray <$> A.zipWithA f (toArray xs) (toArray ys)

zip :: forall a b. NonEmptyArray a -> NonEmptyArray b -> NonEmptyArray (Tuple a b)
zip xs ys = NonEmptyArray $ toArray xs `A.zip` toArray ys

unzip :: forall a b. NonEmptyArray (Tuple a b) -> Tuple (NonEmptyArray a) (NonEmptyArray b)
unzip = bimap NonEmptyArray NonEmptyArray <<< A.unzip <<< toArray

foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldM = adaptAny'' A.foldM

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldRecM = adaptAny'' A.foldRecM

unsafeIndex :: forall a. Partial => NonEmptyArray a -> Int -> a
unsafeIndex = adaptAny A.unsafeIndex

-- we use FFI here to avoid the unnecessary copy created by `tail`
foreign import fold1Impl :: forall a. (a -> a -> a) -> NonEmptyArray a -> a

foreign import traverse1Impl
  :: forall m a b
   . (forall a' b'. (m (a' -> b') -> m a' -> m b'))
  -> (forall a' b'. (a' -> b') -> m a' -> m b')
  -> (a -> m b)
  -> NonEmptyArray a
  -> m (NonEmptyArray b)