query datetimepickers when input type is _not_ supported

-- | This module defines a component for rendering SlamDown documents to HTML
module Text.Markdown.SlamDown.Halogen.Component
  ( SlamDownConfig(..)
  , defaultBrowserFeatures
  , SlamDownMessage(..)
  , slamDownComponent
  , renderSlamDown
  , evalSlamDownQuery

  , module SDS
  , module SDQ
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.MonadZero (guard)
import DOM.HTML.Indexed.StepValue (StepValue(..))
import Data.Array as A
import Data.BrowserFeatures (BrowserFeatures)
import Data.BrowserFeatures.InputType as IT
import Data.Either (Either(..), fromRight)
import Data.Either as E
import Data.Either.Nested (Either3)
import Data.Foldable as F
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct.Nested (Coproduct3)
import Data.Identity (Identity(..))
import Data.List as L
import Data.Maybe (Maybe(..))
import Data.Maybe as M
import Data.Newtype (unwrap)
import Data.Set as Set
import Data.StrMap as SM
import Data.String as S
import Data.Traversable (traverse)
import Data.Validation.Semigroup as V
import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.Datepicker.Component.Date as DatePicker
import Halogen.Datepicker.Component.DateTime as DateTimePicker
import Halogen.Datepicker.Component.Time as TimePicker
import Halogen.Datepicker.Component.Types (PickerMessage(..), setValue, value)
import Halogen.Datepicker.Format.Date as DatePickerF
import Halogen.Datepicker.Format.DateTime as DateTimePickerF
import Halogen.Datepicker.Format.Time as TimePickerF
import Halogen.HTML as HH
import Halogen.HTML.Core as HC
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Partial.Unsafe (unsafePartial)
import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Halogen.Component.Query as SDQ
import Text.Markdown.SlamDown.Halogen.Component.State as SDS
import Text.Markdown.SlamDown.Halogen.Fresh as Fresh
import Text.Markdown.SlamDown.Halogen.InputType as SDIT
import Text.Markdown.SlamDown.Parser.Inline as SDPI
import Text.Markdown.SlamDown.Pretty as SDPR
import Text.Parsing.Parser as P

data SlamDownMessage v
  = TextBoxChanged String (SD.TextBox M.Maybe)
  | CheckBoxChanged String v Boolean
  | RadioButtonChanged String v
  | DropDownChanged String (M.Maybe v)

-- | By default, no features are enabled.
defaultBrowserFeatures ∷ BrowserFeatures
defaultBrowserFeatures =
  { inputTypeSupported : const false
  }

evalSlamDownQuery
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDQ.SlamDownQuery v
  ~> DSL v m
evalSlamDownQuery config e =
  case e of
    SDQ.ChangeTextBox key tb next → do
      H.modify <<< SDS.modifyFormState $
        SM.insert key (SD.TextBox $ SD.transTextBox (Compose <<< map pure) tb)
      H.raise $ TextBoxChanged key tb
      pure next

    SDQ.ChangeRadioButton key val next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.RadioButtons (Identity _) (Identity vals)) →
              case L.elemIndex val vals of
                M.Just _ → SD.RadioButtons (pure val) (pure vals)
                M.Nothing → rb
            _ → SD.RadioButtons (pure val) (pure (L.singleton val))
      H.raise $ RadioButtonChanged key val
      pure next

    SDQ.ChangeDropDown key mval next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.DropDown _ (Identity vals)) →
              case mval of
                M.Just val →
                  if F.elem val vals
                  then SD.DropDown (M.Just $ pure val) (pure vals)
                  else rb
                M.Nothing → SD.DropDown M.Nothing (pure vals)
            _ → SD.DropDown (pure <$> mval) (pure $ M.maybe L.Nil L.singleton mval)
      H.raise $ DropDownChanged key mval
      pure next

    SDQ.ChangeCheckBox key val checked next → do
      let
        updateSel ∷ Set.Set v → Set.Set v
        updateSel =
          if checked
          then Set.insert val
          else Set.delete val

        update ∷ M.Maybe (SDS.FormFieldValue v) → SDS.FormFieldValue v
        update (M.Just cb @ (SD.CheckBoxes (Identity sel) (Identity vals))) =
          SD.CheckBoxes (pure $ sel') (pure vals)
          where
            sel' = L.fromFoldable $ Set.intersection (Set.fromFoldable vals) $ updateSel $ Set.fromFoldable sel
        update _ = SD.CheckBoxes (pure $ L.fromFoldable $ updateSel Set.empty) (pure $ L.singleton val)

      H.modify \state →
        SDS.modifyFormState
          (SM.insert key <<< update $ SDS.getFormFieldValue key state)
          state
      H.raise $ CheckBoxChanged key val checked
      pure next

    SDQ.GetFormState k → do
      SDS.SlamDownState state ← H.get
      let defaultFormState = SDS.formStateFromDocument state.document
      pure $ k $ SM.union state.formState defaultFormState

    SDQ.PopulateForm values next → do
      H.modify \(SDS.SlamDownState { document }) →
        SDS.syncState document values
      pure next

    SDQ.SetDocument doc next → do
      state ← H.get
      let newState = SDS.replaceDocument doc state
      H.put newState
      let formState = newState # \(SDS.SlamDownState s) → SDS.formStateFromDocument s.document
      SM.foldM (updatePickers config.browserFeatures) unit formState
      pure next

updatePickers :: ∀ m v a
  . BrowserFeatures
  → Unit
  → String
  → SD.FormFieldP Identity a
  → DSL v m Unit
updatePickers {inputTypeSupported} _ label = case _ of
  SD.TextBox t → case t of
    SD.DateTime _ (Compose (Just (Identity v))) | not inputTypeSupported IT.DateTimeLocal →
      void (H.query' cpDateTimePicker label $ setValue $ Just $ Right v)
    SD.Time _ (Compose (Just (Identity v))) | not inputTypeSupported IT.DateTimeLocal →
      void (H.query' cpTimePicker label $ setValue $ Just $ Right v)
    SD.Date (Compose (Just (Identity v))) | not inputTypeSupported IT.DateTimeLocal →
      void (H.query' cpDatePicker label $ setValue $ Just $ Right v)
    _ → pure unit
  _ → pure unit

type SlamDownConfig =
  { formName ∷ String
  , browserFeatures ∷ BrowserFeatures
  }

type FreshRenderer v m a = a → Fresh.Fresh (HTML v m)

type FormFieldDef a =
  { label ∷ String
  , required ∷ Boolean
  , field ∷ SD.FormField a
  }

type FormFieldBaked v m =
  { label ∷ String
  , required ∷ Boolean
  , field ∷ HTML v m
  , ident ∷ M.Maybe String
  }

-- | Render a `SlamDown` document into an HTML form.
renderSlamDown
  ∷ ∀ v m
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownState v
  → HTML v m
renderSlamDown config (SDS.SlamDownState state) =
  case state.document of
    SD.SlamDown bs →
      HH.div_
        $ Fresh.runFresh config.formName
        $ renderBlocks bs

  where
    defaultFormState ∷ SDS.SlamDownFormState v
    defaultFormState = SDS.formStateFromDocument state.document

    h_ ∷ Int → Array (HTML v m) → HTML v m
    h_ 1 = HH.h1_
    h_ 2 = HH.h2_
    h_ 3 = HH.h3_
    h_ 4 = HH.h4_
    h_ 5 = HH.h5_
    h_ _ = HH.h6_

    el_ ∷ SD.ListType → Array (HTML v m) → HTML v m
    el_ (SD.Bullet _)  = HH.ul_
    el_ (SD.Ordered _) = HH.ol_

    renderInline ∷ FreshRenderer v m (SD.Inline v)
    renderInline i =
      case i of
        SD.Str s → pure $ HH.text s
        SD.Entity s → pure $ HH.text s
        SD.Space → pure $ HH.text " "
        SD.SoftBreak → pure $ HH.text "\n"
        SD.LineBreak → pure $ HH.br_
        SD.Emph is → HH.em_ <$> traverse renderInline (A.fromFoldable is)
        SD.Strong is → HH.strong_ <$> traverse renderInline (A.fromFoldable is)
        SD.Code _ c → pure $ HH.code_ [ HH.text c ]
        SD.Link body tgt → do
          let
            href (SD.InlineLink url) = url
            href (SD.ReferenceLink tgt') = M.maybe "" ("#" <> _) tgt'
          HH.a [ HP.href $ href tgt ] <$> traverse renderInline (A.fromFoldable body)
        SD.Image body url →
          pure $ HH.img
            [ HP.src url
            , HP.alt $ F.foldMap stripInline body
            ]
        SD.FormField label required field →
          renderInlineFormField <$> bakeFormField { label, required, field }

    bakeFormField ∷ FormFieldDef v → Fresh.Fresh (FormFieldBaked v m)
    bakeFormField { label, required, field } = do
      ident ← Fresh.fresh
      let
        unquote = SD.traverseFormField (SD.getLiteral >>> map pure)
        quote = SD.transFormField (unwrap >>> SD.Literal)
        field' =
          unquote <<< ensureValidField <<< M.maybe field quote $
            SM.lookup label state.formState <|> SM.lookup label defaultFormState
      el ←
        case field' of
          M.Nothing → pure $ HH.text "Unsupported form element"
          M.Just fv → renderFormElement config state ident label fv

      let
        requiresId =
          case field' of
            M.Just (SD.CheckBoxes _ _) → false
            M.Just (SD.RadioButtons _ _) → false
            _ → true
      pure
        { label
        , required
        , field: el
        , ident: if requiresId then M.Just ident else M.Nothing
        }

    renderInlineFormField ∷ FormFieldBaked v m → HTML v m
    renderInlineFormField { field, label, required, ident } =
      HH.span
        [ HP.class_ (HH.ClassName "slamdown-field") ]
        [ HH.label
            (M.maybe [] (pure <<< HP.for) ident)
            [ HH.text (label <> if required then "*" else "") ]
        , field
        ]

    renderFormSetFormField ∷ FormFieldBaked v m → HTML v m
    renderFormSetFormField { field, label, required, ident } =
      HH.tr_
        [ HH.th_
            [ HH.label
                (M.maybe [] (pure <<< HP.for) ident)
                [ HH.text (label <> if required then "*" else "") ]
            ]
        , HH.td_
            [ field ]
        ]

    renderFormSet ∷ FreshRenderer v m (L.List (FormFieldDef v))
    renderFormSet fs =
      HH.table [ HP.class_ (HH.ClassName "slamdown-formset") ]
        <$> traverse (map renderFormSetFormField <<< bakeFormField) (A.fromFoldable fs)

    stripInline ∷ SD.Inline v → String
    stripInline i =
      case i of
        SD.Str s → s
        SD.Entity s → s
        SD.Space → " "
        SD.SoftBreak → "\n"
        SD.LineBreak → "\n"
        SD.Emph is → F.foldMap stripInline is
        SD.Strong is → F.foldMap stripInline is
        SD.Code _ c → c
        SD.Link body _ → F.foldMap stripInline body
        _ → ""

    renderBlock ∷ FreshRenderer v m (SD.Block v)
    renderBlock b =
      case b of
        SD.Paragraph is →
          HH.p_ <$> traverse renderInline (A.fromFoldable is)
        SD.Header lvl is →
          h_ lvl <$> traverse renderInline (A.fromFoldable is)
        SD.Blockquote bs →
          HH.blockquote_ <$> renderBlocks bs
        SD.Lst lt bss → do
          let
            item ∷ FreshRenderer v m (L.List (SD.Block v))
            item bs = HH.li_ <$> renderBlocks bs
          el_ lt <$> traverse item (A.fromFoldable bss)
        SD.CodeBlock _ ss →
          pure $ HH.pre_ [ HH.code_ [ HH.text (S.joinWith "\n" $ A.fromFoldable ss) ] ]
        SD.LinkReference l url →
          pure $ HH.p_
            [ HH.text (l <> ": ")
            , HH.a [ HP.id_ l, HP.href url ] [ HH.text url ]
            ]
        SD.Rule →
          pure HH.hr_

    renderBlocks ∷ L.List (SD.Block v) → Fresh.Fresh (Array (HTML v m))
    renderBlocks = go [] L.Nil
      where
      go html fs bs =
        case bs of
          L.Cons (SD.Paragraph (L.Cons (SD.FormField label required field) L.Nil)) bs' →
            go html (L.Cons { label, required, field } fs) bs'
          L.Cons b bs' → do
            bHtml ← renderBlock b
            if L.null fs
              then go (html <> pure bHtml) L.Nil bs'
              else do
                fsHtml ← renderFormSet (L.reverse fs)
                go (html <> pure fsHtml <> pure bHtml) L.Nil bs'
          L.Nil →
            if L.null fs
              then pure html
              else do
                fsHtml ← renderFormSet (L.reverse fs)
                pure (html <> pure fsHtml)

    -- | Make sure that the default value of a form field is valid, and if it is not, strip it out.
    ensureValidField ∷ SD.FormField v → SD.FormField v
    ensureValidField field =
      V.unV
        (const $ stripDefaultValue field)
        id
        (SDPI.validateFormField field)
      where
        stripDefaultValue ∷ SD.FormField v → SD.FormField v
        stripDefaultValue =
          case _ of
             SD.TextBox tb → SD.TextBox $ SD.transTextBox (\_ → Compose M.Nothing) tb
             SD.DropDown _ ls → SD.DropDown M.Nothing ls
             field' → field'

renderRadioButton
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer v m Boolean
renderRadioButton label value checked = do
  ident ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.type_ HP.InputRadio
        , HP.id_ ident
        , HP.name label
        , HP.value renderedValue
        , HE.onValueChange (HE.input_ (SDQ.ChangeRadioButton label value))
        ]
    , HH.label [ HP.for ident ] [ HH.text renderedValue ]
    ]

renderCheckBox
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer v m Boolean
renderCheckBox label value checked = do
  ident ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.type_ HP.InputCheckbox
        , HP.id_ ident
        , HP.name label
        , HP.value renderedValue
        , HE.onChecked (HE.input (SDQ.ChangeCheckBox label value))
        ]
    , HH.label [ HP.for ident ] [ HH.text renderedValue ]
    ]

renderDropDown
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ String    -- id
  → String    -- label
  → L.List v  -- choices
  → M.Maybe v -- value
  → HTML v m
renderDropDown ident label ls sel =
  HH.select
    [ HP.id_ ident
    , HP.name label
    , HE.onSelectedIndexChange (HE.input (SDQ.ChangeDropDown label <<< L.index ls))
    ]
    $ A.fromFoldable $ M.maybe option option' sel <$> ls
  where
    option ∷ v → HTML v m
    option value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.value renderedValue ] [ HH.text renderedValue ]

    option' ∷ v → v → HTML v m
    option' sel' value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.selected (value == sel'), HP.value renderedValue ] [ HH.text renderedValue ]

data PickerType
  = DatePicker
  | TimePicker SD.TimePrecision
  | DateTimePicker SD.TimePrecision

textBoxToPicker ∷ ∀ f
  . BrowserFeatures
  → SD.TextBox f
  → Maybe PickerType
textBoxToPicker features tb = do
  guard (not features.inputTypeSupported $ SDIT.textBoxToInputType tb)
  case tb of
    SD.Date _ → Just DatePicker
    SD.Time p _ → Just $ TimePicker p
    SD.DateTime p _ → Just $ DateTimePicker p
    _ → Nothing

dateFormatString :: String
dateFormatString = "YYYY-MMMM-DD"

timeFormatString :: SD.TimePrecision → String
timeFormatString SD.Minutes = "HH:mm"
timeFormatString SD.Seconds = "HH:mm:ss"

datePickerFormat :: DatePickerF.Format
datePickerFormat = unsafePartial fromRight
  $ DatePickerF.fromString dateFormatString

timePickerFormat :: SD.TimePrecision → TimePickerF.Format
timePickerFormat p = unsafePartial fromRight
  $ TimePickerF.fromString
  $ timeFormatString p

dateTimePickerFormat :: SD.TimePrecision → DateTimePickerF.Format
dateTimePickerFormat p = unsafePartial fromRight
  $ DateTimePickerF.fromString
  $ dateFormatString <> " " <> timeFormatString p

renderFormElement
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownStateR v
  → String -- element id
  → String -- label
  → FreshRenderer v m (SDS.FormFieldValue v)
renderFormElement config st ident label field =
  case field of
    SD.TextBox tb →
      pure case textBoxToPicker config.browserFeatures tb of
        Nothing → renderTextInput tb
        Just pickerType → renderPicker pickerType
    SD.RadioButtons (Identity sel) (Identity ls) → do
      let
        renderRadioButton' val = renderRadioButton label val $ sel == val
        options = A.fromFoldable $ if sel `F.elem` ls then ls else L.Cons sel ls
      radios ← traverse renderRadioButton' options
      pure $ HH.ul [ HP.class_ (HH.ClassName "slamdown-radios") ] radios
    SD.CheckBoxes (Identity sel) (Identity ls) → do
      let
        sel' = Set.fromFoldable sel
        renderCheckBox' val = renderCheckBox label val (Set.member val sel')
      checkBoxes ← traverse renderCheckBox' ls
      pure $ HH.ul [ HP.class_ (HH.ClassName "slamdown-checkboxes") ] $ A.fromFoldable checkBoxes
    SD.DropDown msel (Identity ls) →
      pure $
        case msel of
          M.Nothing → renderDropDown ident label ls M.Nothing
          M.Just (Identity sel) →
            let options = if sel `F.elem` ls then ls else L.Cons sel ls
            in renderDropDown ident label options $ M.Just sel

  where
    renderPicker
      ∷ PickerType
      → HTML v m
    renderPicker = case _ of
      DatePicker →
        HH.slot' cpDatePicker label (DatePicker.picker datePickerFormat) unit $ HE.input $
          \(NotifyChange n) → SDQ.ChangeTextBox label $ SD.Date $ value n
      TimePicker p →
        HH.slot' cpTimePicker label (TimePicker.picker $ timePickerFormat p) unit $ HE.input $
          \(NotifyChange n) → SDQ.ChangeTextBox label $ SD.Time SD.Minutes $ value n
      DateTimePicker p →
        HH.slot' cpDateTimePicker label (DateTimePicker.picker $ dateTimePickerFormat p) unit $ HE.input $
          \(NotifyChange n) → SDQ.ChangeTextBox label $ SD.DateTime SD.Minutes $ value n

    renderTextInput
      ∷ SD.TextBox (Compose M.Maybe Identity)
      → HTML v m
    renderTextInput tb =
      HH.input $
        [ HP.type_ compatibleInputType
        , HP.id_ ident
        , HP.name label
        , HE.onValueInput (HE.input (SDQ.ChangeTextBox label <<< parseInput))
        ]
        <> typeSettings
        <> M.maybe [] (\x → [HP.value x]) renderedValue
      where
        renderedValue =
          SDPR.prettyPrintTextBoxValue <$>
            SD.traverseTextBox unwrap tb

        parser ∷ P.Parser String (SD.TextBox Identity)
        parser = SDPI.parseTextBox (\_ → true) (map pure) tb

        parseInput ∷ String → SD.TextBox M.Maybe
        parseInput str =
          case P.runParser str parser of
            E.Right tb' → SD.transTextBox (unwrap >>> pure) tb'
            E.Left err → SD.transTextBox (\_ → M.Nothing) tb

        typeSettings :: forall r i. Array (HP.IProp (step ∷ StepValue | r) i)
        typeSettings = case compatibleInputType, tb of
          HP.InputTime, SD.Time SD.Seconds _ → [ step (Step 1.0) ]
          HP.InputDatetimeLocal, SD.DateTime SD.Seconds _ → [ step (Step 1.0) ]
          _, _ → []

        compatibleInputType =
          SDIT.inputTypeToHalogenInputType $
            SDIT.availableInputType config.browserFeatures tb

step ∷ ∀ r i. StepValue → HP.IProp (step ∷ StepValue | r) i
step = HP.prop (HC.PropName "step")

type ChildQuery = Coproduct3 DatePicker.Query TimePicker.Query DateTimePicker.Query
type Slot = Either3 String String String

cpDatePicker ∷ CP.ChildPath DatePicker.Query ChildQuery String Slot
cpDatePicker = CP.cp1

cpTimePicker ∷ CP.ChildPath TimePicker.Query ChildQuery String Slot
cpTimePicker = CP.cp2

cpDateTimePicker ∷ CP.ChildPath DateTimePicker.Query ChildQuery String Slot
cpDateTimePicker = CP.cp3

type HTML v m = H.ParentHTML (SDQ.SlamDownQuery v) ChildQuery Slot m
type DSL v m = H.ParentDSL (SDS.SlamDownState v) (SDQ.SlamDownQuery v) ChildQuery Slot (SlamDownMessage v) m

-- | Bundles up the SlamDown renderer and state machine into a Halogen component.
slamDownComponent
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → H.Component HH.HTML (SDQ.SlamDownQuery v) Unit (SlamDownMessage v) m
slamDownComponent config =
  H.parentComponent
    { render: renderSlamDown config
    , eval: evalSlamDownQuery config
    , initialState: const SDS.emptySlamDownState
    , receiver: const M.Nothing
    }

-- | This module defines a component for rendering SlamDown documents to HTML
module Text.Markdown.SlamDown.Halogen.Component
  ( SlamDownConfig(..)
  , defaultBrowserFeatures
  , SlamDownMessage(..)
  , slamDownComponent
  , renderSlamDown
  , evalSlamDownQuery

  , module SDS
  , module SDQ
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.MonadZero (guard)
import DOM.HTML.Indexed.StepValue (StepValue(..))
import Data.Array as A
import Data.BrowserFeatures (BrowserFeatures)
import Data.BrowserFeatures.InputType as IT
import Data.Either (Either(..), fromRight)
import Data.Either as E
import Data.Either.Nested (Either3)
import Data.Foldable as F
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct.Nested (Coproduct3)
import Data.Identity (Identity(..))
import Data.List as L
import Data.Maybe (Maybe(..))
import Data.Maybe as M
import Data.Newtype (unwrap)
import Data.Set as Set
import Data.StrMap as SM
import Data.String as S
import Data.Traversable (traverse)
import Data.Validation.Semigroup as V
import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.Datepicker.Component.Date as DatePicker
import Halogen.Datepicker.Component.DateTime as DateTimePicker
import Halogen.Datepicker.Component.Time as TimePicker
import Halogen.Datepicker.Component.Types (PickerMessage(..), setValue, value)
import Halogen.Datepicker.Format.Date as DatePickerF
import Halogen.Datepicker.Format.DateTime as DateTimePickerF
import Halogen.Datepicker.Format.Time as TimePickerF
import Halogen.HTML as HH
import Halogen.HTML.Core as HC
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Partial.Unsafe (unsafePartial)
import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Halogen.Component.Query as SDQ
import Text.Markdown.SlamDown.Halogen.Component.State as SDS
import Text.Markdown.SlamDown.Halogen.Fresh as Fresh
import Text.Markdown.SlamDown.Halogen.InputType as SDIT
import Text.Markdown.SlamDown.Parser.Inline as SDPI
import Text.Markdown.SlamDown.Pretty as SDPR
import Text.Parsing.Parser as P

data SlamDownMessage v
  = TextBoxChanged String (SD.TextBox M.Maybe)
  | CheckBoxChanged String v Boolean
  | RadioButtonChanged String v
  | DropDownChanged String (M.Maybe v)

-- | By default, no features are enabled.
defaultBrowserFeatures ∷ BrowserFeatures
defaultBrowserFeatures =
  { inputTypeSupported : const false
  }

evalSlamDownQuery
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDQ.SlamDownQuery v
  ~> DSL v m
evalSlamDownQuery config e =
  case e of
    SDQ.ChangeTextBox key tb next → do
      H.modify <<< SDS.modifyFormState $
        SM.insert key (SD.TextBox $ SD.transTextBox (Compose <<< map pure) tb)
      H.raise $ TextBoxChanged key tb
      pure next

    SDQ.ChangeRadioButton key val next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.RadioButtons (Identity _) (Identity vals)) →
              case L.elemIndex val vals of
                M.Just _ → SD.RadioButtons (pure val) (pure vals)
                M.Nothing → rb
            _ → SD.RadioButtons (pure val) (pure (L.singleton val))
      H.raise $ RadioButtonChanged key val
      pure next

    SDQ.ChangeDropDown key mval next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.DropDown _ (Identity vals)) →
              case mval of
                M.Just val →
                  if F.elem val vals
                  then SD.DropDown (M.Just $ pure val) (pure vals)
                  else rb
                M.Nothing → SD.DropDown M.Nothing (pure vals)
            _ → SD.DropDown (pure <$> mval) (pure $ M.maybe L.Nil L.singleton mval)
      H.raise $ DropDownChanged key mval
      pure next

    SDQ.ChangeCheckBox key val checked next → do
      let
        updateSel ∷ Set.Set v → Set.Set v
        updateSel =
          if checked
          then Set.insert val
          else Set.delete val

        update ∷ M.Maybe (SDS.FormFieldValue v) → SDS.FormFieldValue v
        update (M.Just cb @ (SD.CheckBoxes (Identity sel) (Identity vals))) =
          SD.CheckBoxes (pure $ sel') (pure vals)
          where
            sel' = L.fromFoldable $ Set.intersection (Set.fromFoldable vals) $ updateSel $ Set.fromFoldable sel
        update _ = SD.CheckBoxes (pure $ L.fromFoldable $ updateSel Set.empty) (pure $ L.singleton val)

      H.modify \state →
        SDS.modifyFormState
          (SM.insert key <<< update $ SDS.getFormFieldValue key state)
          state
      H.raise $ CheckBoxChanged key val checked
      pure next

    SDQ.GetFormState k → do
      SDS.SlamDownState state ← H.get
      let defaultFormState = SDS.formStateFromDocument state.document
      pure $ k $ SM.union state.formState defaultFormState

    SDQ.PopulateForm values next → do
      H.modify \(SDS.SlamDownState { document }) →
        SDS.syncState document values
      pure next

    SDQ.SetDocument doc next → do
      state ← H.get
      let newState = SDS.replaceDocument doc state
      H.put newState
      let formState = newState # \(SDS.SlamDownState s) → SDS.formStateFromDocument s.document
      SM.foldM (updatePickers config.browserFeatures) unit formState
      pure next

updatePickers :: ∀ m v a
  . BrowserFeatures
  → Unit
  → String
  → SD.FormFieldP Identity a
  → DSL v m Unit
updatePickers {inputTypeSupported} _ label = case _ of
  SD.TextBox t → case t of
    SD.DateTime _ (Compose (Just (Identity v))) | inputTypeSupported IT.DateTimeLocal →
      void (H.query' cpDateTimePicker label $ setValue $ Just $ Right v)
    SD.Time _ (Compose (Just (Identity v))) | inputTypeSupported IT.DateTimeLocal →
      void (H.query' cpTimePicker label $ setValue $ Just $ Right v)
    SD.Date (Compose (Just (Identity v))) | inputTypeSupported IT.DateTimeLocal →
      void (H.query' cpDatePicker label $ setValue $ Just $ Right v)
    _ → pure unit
  _ → pure unit

type SlamDownConfig =
  { formName ∷ String
  , browserFeatures ∷ BrowserFeatures
  }

type FreshRenderer v m a = a → Fresh.Fresh (HTML v m)

type FormFieldDef a =
  { label ∷ String
  , required ∷ Boolean
  , field ∷ SD.FormField a
  }

type FormFieldBaked v m =
  { label ∷ String
  , required ∷ Boolean
  , field ∷ HTML v m
  , ident ∷ M.Maybe String
  }

-- | Render a `SlamDown` document into an HTML form.
renderSlamDown
  ∷ ∀ v m
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownState v
  → HTML v m
renderSlamDown config (SDS.SlamDownState state) =
  case state.document of
    SD.SlamDown bs →
      HH.div_
        $ Fresh.runFresh config.formName
        $ renderBlocks bs

  where
    defaultFormState ∷ SDS.SlamDownFormState v
    defaultFormState = SDS.formStateFromDocument state.document

    h_ ∷ Int → Array (HTML v m) → HTML v m
    h_ 1 = HH.h1_
    h_ 2 = HH.h2_
    h_ 3 = HH.h3_
    h_ 4 = HH.h4_
    h_ 5 = HH.h5_
    h_ _ = HH.h6_

    el_ ∷ SD.ListType → Array (HTML v m) → HTML v m
    el_ (SD.Bullet _)  = HH.ul_
    el_ (SD.Ordered _) = HH.ol_

    renderInline ∷ FreshRenderer v m (SD.Inline v)
    renderInline i =
      case i of
        SD.Str s → pure $ HH.text s
        SD.Entity s → pure $ HH.text s
        SD.Space → pure $ HH.text " "
        SD.SoftBreak → pure $ HH.text "\n"
        SD.LineBreak → pure $ HH.br_
        SD.Emph is → HH.em_ <$> traverse renderInline (A.fromFoldable is)
        SD.Strong is → HH.strong_ <$> traverse renderInline (A.fromFoldable is)
        SD.Code _ c → pure $ HH.code_ [ HH.text c ]
        SD.Link body tgt → do
          let
            href (SD.InlineLink url) = url
            href (SD.ReferenceLink tgt') = M.maybe "" ("#" <> _) tgt'
          HH.a [ HP.href $ href tgt ] <$> traverse renderInline (A.fromFoldable body)
        SD.Image body url →
          pure $ HH.img
            [ HP.src url
            , HP.alt $ F.foldMap stripInline body
            ]
        SD.FormField label required field →
          renderInlineFormField <$> bakeFormField { label, required, field }

    bakeFormField ∷ FormFieldDef v → Fresh.Fresh (FormFieldBaked v m)
    bakeFormField { label, required, field } = do
      ident ← Fresh.fresh
      let
        unquote = SD.traverseFormField (SD.getLiteral >>> map pure)
        quote = SD.transFormField (unwrap >>> SD.Literal)
        field' =
          unquote <<< ensureValidField <<< M.maybe field quote $
            SM.lookup label state.formState <|> SM.lookup label defaultFormState
      el ←
        case field' of
          M.Nothing → pure $ HH.text "Unsupported form element"
          M.Just fv → renderFormElement config state ident label fv

      let
        requiresId =
          case field' of
            M.Just (SD.CheckBoxes _ _) → false
            M.Just (SD.RadioButtons _ _) → false
            _ → true
      pure
        { label
        , required
        , field: el
        , ident: if requiresId then M.Just ident else M.Nothing
        }

    renderInlineFormField ∷ FormFieldBaked v m → HTML v m
    renderInlineFormField { field, label, required, ident } =
      HH.span
        [ HP.class_ (HH.ClassName "slamdown-field") ]
        [ HH.label
            (M.maybe [] (pure <<< HP.for) ident)
            [ HH.text (label <> if required then "*" else "") ]
        , field
        ]

    renderFormSetFormField ∷ FormFieldBaked v m → HTML v m
    renderFormSetFormField { field, label, required, ident } =
      HH.tr_
        [ HH.th_
            [ HH.label
                (M.maybe [] (pure <<< HP.for) ident)
                [ HH.text (label <> if required then "*" else "") ]
            ]
        , HH.td_
            [ field ]
        ]

    renderFormSet ∷ FreshRenderer v m (L.List (FormFieldDef v))
    renderFormSet fs =
      HH.table [ HP.class_ (HH.ClassName "slamdown-formset") ]
        <$> traverse (map renderFormSetFormField <<< bakeFormField) (A.fromFoldable fs)

    stripInline ∷ SD.Inline v → String
    stripInline i =
      case i of
        SD.Str s → s
        SD.Entity s → s
        SD.Space → " "
        SD.SoftBreak → "\n"
        SD.LineBreak → "\n"
        SD.Emph is → F.foldMap stripInline is
        SD.Strong is → F.foldMap stripInline is
        SD.Code _ c → c
        SD.Link body _ → F.foldMap stripInline body
        _ → ""

    renderBlock ∷ FreshRenderer v m (SD.Block v)
    renderBlock b =
      case b of
        SD.Paragraph is →
          HH.p_ <$> traverse renderInline (A.fromFoldable is)
        SD.Header lvl is →
          h_ lvl <$> traverse renderInline (A.fromFoldable is)
        SD.Blockquote bs →
          HH.blockquote_ <$> renderBlocks bs
        SD.Lst lt bss → do
          let
            item ∷ FreshRenderer v m (L.List (SD.Block v))
            item bs = HH.li_ <$> renderBlocks bs
          el_ lt <$> traverse item (A.fromFoldable bss)
        SD.CodeBlock _ ss →
          pure $ HH.pre_ [ HH.code_ [ HH.text (S.joinWith "\n" $ A.fromFoldable ss) ] ]
        SD.LinkReference l url →
          pure $ HH.p_
            [ HH.text (l <> ": ")
            , HH.a [ HP.id_ l, HP.href url ] [ HH.text url ]
            ]
        SD.Rule →
          pure HH.hr_

    renderBlocks ∷ L.List (SD.Block v) → Fresh.Fresh (Array (HTML v m))
    renderBlocks = go [] L.Nil
      where
      go html fs bs =
        case bs of
          L.Cons (SD.Paragraph (L.Cons (SD.FormField label required field) L.Nil)) bs' →
            go html (L.Cons { label, required, field } fs) bs'
          L.Cons b bs' → do
            bHtml ← renderBlock b
            if L.null fs
              then go (html <> pure bHtml) L.Nil bs'
              else do
                fsHtml ← renderFormSet (L.reverse fs)
                go (html <> pure fsHtml <> pure bHtml) L.Nil bs'
          L.Nil →
            if L.null fs
              then pure html
              else do
                fsHtml ← renderFormSet (L.reverse fs)
                pure (html <> pure fsHtml)

    -- | Make sure that the default value of a form field is valid, and if it is not, strip it out.
    ensureValidField ∷ SD.FormField v → SD.FormField v
    ensureValidField field =
      V.unV
        (const $ stripDefaultValue field)
        id
        (SDPI.validateFormField field)
      where
        stripDefaultValue ∷ SD.FormField v → SD.FormField v
        stripDefaultValue =
          case _ of
             SD.TextBox tb → SD.TextBox $ SD.transTextBox (\_ → Compose M.Nothing) tb
             SD.DropDown _ ls → SD.DropDown M.Nothing ls
             field' → field'

renderRadioButton
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer v m Boolean
renderRadioButton label value checked = do
  ident ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.type_ HP.InputRadio
        , HP.id_ ident
        , HP.name label
        , HP.value renderedValue
        , HE.onValueChange (HE.input_ (SDQ.ChangeRadioButton label value))
        ]
    , HH.label [ HP.for ident ] [ HH.text renderedValue ]
    ]

renderCheckBox
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer v m Boolean
renderCheckBox label value checked = do
  ident ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.type_ HP.InputCheckbox
        , HP.id_ ident
        , HP.name label
        , HP.value renderedValue
        , HE.onChecked (HE.input (SDQ.ChangeCheckBox label value))
        ]
    , HH.label [ HP.for ident ] [ HH.text renderedValue ]
    ]

renderDropDown
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ String    -- id
  → String    -- label
  → L.List v  -- choices
  → M.Maybe v -- value
  → HTML v m
renderDropDown ident label ls sel =
  HH.select
    [ HP.id_ ident
    , HP.name label
    , HE.onSelectedIndexChange (HE.input (SDQ.ChangeDropDown label <<< L.index ls))
    ]
    $ A.fromFoldable $ M.maybe option option' sel <$> ls
  where
    option ∷ v → HTML v m
    option value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.value renderedValue ] [ HH.text renderedValue ]

    option' ∷ v → v → HTML v m
    option' sel' value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.selected (value == sel'), HP.value renderedValue ] [ HH.text renderedValue ]

data PickerType
  = DatePicker
  | TimePicker SD.TimePrecision
  | DateTimePicker SD.TimePrecision

textBoxToPicker ∷ ∀ f
  . BrowserFeatures
  → SD.TextBox f
  → Maybe PickerType
textBoxToPicker features tb = do
  guard (not features.inputTypeSupported $ SDIT.textBoxToInputType tb)
  case tb of
    SD.Date _ → Just DatePicker
    SD.Time p _ → Just $ TimePicker p
    SD.DateTime p _ → Just $ DateTimePicker p
    _ → Nothing

dateFormatString :: String
dateFormatString = "YYYY-MMMM-DD"

timeFormatString :: SD.TimePrecision → String
timeFormatString SD.Minutes = "HH:mm"
timeFormatString SD.Seconds = "HH:mm:ss"

datePickerFormat :: DatePickerF.Format
datePickerFormat = unsafePartial fromRight
  $ DatePickerF.fromString dateFormatString

timePickerFormat :: SD.TimePrecision → TimePickerF.Format
timePickerFormat p = unsafePartial fromRight
  $ TimePickerF.fromString
  $ timeFormatString p

dateTimePickerFormat :: SD.TimePrecision → DateTimePickerF.Format
dateTimePickerFormat p = unsafePartial fromRight
  $ DateTimePickerF.fromString
  $ dateFormatString <> " " <> timeFormatString p

renderFormElement
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownStateR v
  → String -- element id
  → String -- label
  → FreshRenderer v m (SDS.FormFieldValue v)
renderFormElement config st ident label field =
  case field of
    SD.TextBox tb →
      pure case textBoxToPicker config.browserFeatures tb of
        Nothing → renderTextInput tb
        Just pickerType → renderPicker pickerType
    SD.RadioButtons (Identity sel) (Identity ls) → do
      let
        renderRadioButton' val = renderRadioButton label val $ sel == val
        options = A.fromFoldable $ if sel `F.elem` ls then ls else L.Cons sel ls
      radios ← traverse renderRadioButton' options
      pure $ HH.ul [ HP.class_ (HH.ClassName "slamdown-radios") ] radios
    SD.CheckBoxes (Identity sel) (Identity ls) → do
      let
        sel' = Set.fromFoldable sel
        renderCheckBox' val = renderCheckBox label val (Set.member val sel')
      checkBoxes ← traverse renderCheckBox' ls
      pure $ HH.ul [ HP.class_ (HH.ClassName "slamdown-checkboxes") ] $ A.fromFoldable checkBoxes
    SD.DropDown msel (Identity ls) →
      pure $
        case msel of
          M.Nothing → renderDropDown ident label ls M.Nothing
          M.Just (Identity sel) →
            let options = if sel `F.elem` ls then ls else L.Cons sel ls
            in renderDropDown ident label options $ M.Just sel

  where
    renderPicker
      ∷ PickerType
      → HTML v m
    renderPicker = case _ of
      DatePicker →
        HH.slot' cpDatePicker label (DatePicker.picker datePickerFormat) unit $ HE.input $
          \(NotifyChange n) → SDQ.ChangeTextBox label $ SD.Date $ value n
      TimePicker p →
        HH.slot' cpTimePicker label (TimePicker.picker $ timePickerFormat p) unit $ HE.input $
          \(NotifyChange n) → SDQ.ChangeTextBox label $ SD.Time SD.Minutes $ value n
      DateTimePicker p →
        HH.slot' cpDateTimePicker label (DateTimePicker.picker $ dateTimePickerFormat p) unit $ HE.input $
          \(NotifyChange n) → SDQ.ChangeTextBox label $ SD.DateTime SD.Minutes $ value n

    renderTextInput
      ∷ SD.TextBox (Compose M.Maybe Identity)
      → HTML v m
    renderTextInput tb =
      HH.input $
        [ HP.type_ compatibleInputType
        , HP.id_ ident
        , HP.name label
        , HE.onValueInput (HE.input (SDQ.ChangeTextBox label <<< parseInput))
        ]
        <> typeSettings
        <> M.maybe [] (\x → [HP.value x]) renderedValue
      where
        renderedValue =
          SDPR.prettyPrintTextBoxValue <$>
            SD.traverseTextBox unwrap tb

        parser ∷ P.Parser String (SD.TextBox Identity)
        parser = SDPI.parseTextBox (\_ → true) (map pure) tb

        parseInput ∷ String → SD.TextBox M.Maybe
        parseInput str =
          case P.runParser str parser of
            E.Right tb' → SD.transTextBox (unwrap >>> pure) tb'
            E.Left err → SD.transTextBox (\_ → M.Nothing) tb

        typeSettings :: forall r i. Array (HP.IProp (step ∷ StepValue | r) i)
        typeSettings = case compatibleInputType, tb of
          HP.InputTime, SD.Time SD.Seconds _ → [ step (Step 1.0) ]
          HP.InputDatetimeLocal, SD.DateTime SD.Seconds _ → [ step (Step 1.0) ]
          _, _ → []

        compatibleInputType =
          SDIT.inputTypeToHalogenInputType $
            SDIT.availableInputType config.browserFeatures tb

step ∷ ∀ r i. StepValue → HP.IProp (step ∷ StepValue | r) i
step = HP.prop (HC.PropName "step")

type ChildQuery = Coproduct3 DatePicker.Query TimePicker.Query DateTimePicker.Query
type Slot = Either3 String String String

cpDatePicker ∷ CP.ChildPath DatePicker.Query ChildQuery String Slot
cpDatePicker = CP.cp1

cpTimePicker ∷ CP.ChildPath TimePicker.Query ChildQuery String Slot
cpTimePicker = CP.cp2

cpDateTimePicker ∷ CP.ChildPath DateTimePicker.Query ChildQuery String Slot
cpDateTimePicker = CP.cp3

type HTML v m = H.ParentHTML (SDQ.SlamDownQuery v) ChildQuery Slot m
type DSL v m = H.ParentDSL (SDS.SlamDownState v) (SDQ.SlamDownQuery v) ChildQuery Slot (SlamDownMessage v) m

-- | Bundles up the SlamDown renderer and state machine into a Halogen component.
slamDownComponent
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → H.Component HH.HTML (SDQ.SlamDownQuery v) Unit (SlamDownMessage v) m
slamDownComponent config =
  H.parentComponent
    { render: renderSlamDown config
    , eval: evalSlamDownQuery config
    , initialState: const SDS.emptySlamDownState
    , receiver: const M.Nothing
    }


use the const function

use the const function

module Views.Channel where

import Data.Array

import qualified Thermite.Events as T
import qualified Thermite.Html as H
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Html.Elements as E
import qualified Thermite.Types as T

import Models.Action
import Models.Channel

channelView :: T.Context Models.State.State Unit Models.Action.Action -> Channel -> Thermite.Types.Html Models.Action.Action
channelView ctx channel@{ name: name } =
	E.li [ A.className "channel" ]
		[ E.span
			[ A.className "channel-name"
			, T.onClick ctx (const $ SelectChannel channel)
			]
			[ H.text name ]
		]

channelsView :: T.Context Models.State.State Unit Models.Action.Action -> [Channel] -> Thermite.Types.Html Models.Action.Action
channelsView ctx channels =
	E.div [ A.className "channels" ]
		[ E.h2' [ H.text "Channels" ]
		, E.ul [ A.className "channels-list" ] ((channelView ctx) <$> channels)
		]

module Views.Channel where

import Data.Array

import qualified Thermite.Events as T
import qualified Thermite.Html as H
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Html.Elements as E
import qualified Thermite.Types as T

import Models.Action
import Models.Channel

channelView :: T.Context Models.State.State Unit Models.Action.Action -> Channel -> Thermite.Types.Html Models.Action.Action
channelView ctx channel@{ name: name } =
	E.li [ A.className "channel" ]
		[ E.span
			[ A.className "channel-name"
			, T.onClick ctx \_ -> SelectChannel channel
			]
			[ H.text name ]
		]

channelsView :: T.Context Models.State.State Unit Models.Action.Action -> [Channel] -> Thermite.Types.Html Models.Action.Action
channelsView ctx channels =
	E.div [ A.className "channels" ]
		[ E.h2' [ H.text "Channels" ]
		, E.ul [ A.className "channels-list" ] ((channelView ctx) <$> channels)
		]


Get rename dropdown working

Get rename dropdown working

{-
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.FileSystem.Dialog.Rename.Component where

import SlamData.Prelude

import Control.UI.Browser (reload)

import Data.Array (elemIndex, singleton, sort, nub)
import Data.Lens ((^.), (%~), (.~), (?~), lens, Lens')
import Data.Path.Pathy (printPath, parseAbsDir, sandbox, rootDir, (</>))
import Data.String as S

import DOM.Event.Event as DEE

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Config as Config
import SlamData.Dialog.Render (modalDialog, modalHeader, modalBody, modalFooter)
import SlamData.FileSystem.Dialog.Component.Message (Message(..))
import SlamData.FileSystem.Listing.Item.Component.CSS as ItemCSS
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.Monad (Slam)
import SlamData.Quasar.FS as API
import SlamData.Render.Common (formGroup)
import SlamData.Render.CSS as Rc

import Utils.Path (DirPath, dropWorkspaceExt)
import Utils.DOM as DOM

type State =
  { showList ∷ Boolean
  , initial ∷ R.Resource
  , name ∷ String
  , dirs ∷ Array R.Resource
  , dir ∷ DirPath
  , typedDir ∷ String
  , siblings ∷ Array R.Resource
  , error ∷ Maybe String
  }

initialState ∷ R.Resource → State
initialState resource =
  { showList: false
  , initial: resource
  , name: if R.isWorkspace resource
          then dropWorkspaceExt $ R.resourceName resource
          else R.resourceName resource
  , dir: R.resourceDir resource
  , typedDir: printPath $ R.resourceDir resource
  , siblings: mempty
  , dirs: singleton R.root
  , error: Nothing
  }

_showList ∷ Lens' State Boolean
_showList = lens _.showList (_ { showList = _ })

_initial ∷ Lens' State R.Resource
_initial = lens _.initial (_ { initial = _ })

_name ∷ Lens' State String
_name = lens _.name (_ { name = _ })

_typedDir ∷ Lens' State String
_typedDir = lens _.typedDir (_ { typedDir = _ })

_dirs ∷ Lens' State (Array R.Resource)
_dirs = lens _.dirs (_ { dirs = _ })

_dir ∷ Lens' State DirPath
_dir = lens _.dir (_ { dir = _ })

_siblings ∷ Lens' State (Array R.Resource)
_siblings = lens _.siblings (_ { siblings = _ })

_error ∷ Lens' State (Maybe String)
_error = lens _.error (_ { error = _ })

renameSlam ∷ State → R.Resource
renameSlam r =
  let initial = r.initial
      name = r.name
      nameWithExt = if R.isWorkspace initial
                    then name <> "." <> Config.workspaceExtension
                    else name
  in initial # (R._name .~ nameWithExt)
           <<< (R._root .~ r.dir)

validate ∷ State → State
validate r
  | r.initial == renameSlam r = r # _error .~ Nothing
  | otherwise = r # _error .~ either Just (const Nothing) do
    let name = r.name
    when (name == "")
      $ throwError "Please enter a name for the file"

    when (isJust $ S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension) name)
      $ throwError $ "Please choose an alternative name, ."
      <> Config.workspaceExtension
      <> " is a reserved extension"

    when (isJust $ S.indexOf (S.Pattern "/") name)
      $ throwError "Please entera valid name for the file"

    let nameWithExt = if R.isWorkspace (r.initial)
                      then name <> "." <> Config.workspaceExtension
                      else name
    when (isJust $ elemIndex nameWithExt (map (_ ^. R._name) (r.siblings)))
      $ throwError "An item with this name already exists in the target folder"

data Query a
  = RaiseDismiss a
  | SetShowList Boolean a
  | ToggleShowList a
  | Submit a
  | NameTyped String a
  | DirTyped String a
  | DirClicked R.Resource a
  | SetSiblings (Array R.Resource) a
  | AddDirs (Array R.Resource) a
  | PreventDefault DOM.Event a
  | StopPropagation DOM.Event (Query a)
  | Init a

type DSL = H.ComponentDSL State Query Message Slam
type HTML = H.ComponentHTML Query

component ∷ H.Component HH.HTML Query R.Resource Message Slam
component =
  H.lifecycleComponent
    { initialState
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render dialog =
  modalDialog
  [ modalHeader "Move/rename"
  , modalBody
    $ HH.form
        [ HP.classes [ Rc.renameDialogForm ]
        , HE.onSubmit $ HE.input PreventDefault
        , HE.onClick \e → Just $ StopPropagation (DOM.toEvent e) $ H.action $ SetShowList false
        ]
        [ nameInput
        , dirDropdownField
        , dirDropdownList
        , errorMessage
        ]
  , modalFooter
      [ HH.button
          [ HP.classes [ B.btn ]
          , HE.onClick (HE.input_ RaiseDismiss)
          ]
          [ HH.text "Cancel" ]
      , HH.button
          [ HP.classes [ B.btn, B.btnPrimary ]
          , HP.disabled $ isJust $ dialog.error
          , HE.onClick (HE.input_ Submit)
          ]
          [ HH.text "Rename" ]
      ]
  ]
  where
  nameInput ∷ HTML
  nameInput =
    formGroup [ HH.input [ HP.classes [ B.formControl ]
                        , HP.value (dialog.name)
                        , HP.placeholder "New name"
                        , HE.onValueInput (HE.input NameTyped)
                        ]
              ]

  dirDropdownField ∷ HTML
  dirDropdownField =
    HH.div
      [ HP.classes [ B.inputGroup, HH.ClassName "file-list-field" ] ]
      [ HH.input
          [ HP.classes [ B.formControl ]
          , HP.placeholder "New directory"
          , HE.onValueInput (HE.input DirTyped)
          , HP.value $ dialog ^. _typedDir
          ]
      , HH.span
          [ HP.classes [ B.inputGroupBtn ] ]
          [ HH.button
              [ HP.classes [ B.btn, B.btnDefault ]
              , HE.onClick \e →
                   Just $ StopPropagation (DOM.toEvent e) $ H.action $ ToggleShowList
              , ARIA.label "Select a destination folder"
              , HP.title "Select a destination folder"
              ]
              [ HH.span [ HP.classes [ B.caret ] ] [ ] ]
          ]
      ]
  dirDropdownList ∷ HTML
  dirDropdownList =
    HH.ul
      ([ HP.classes  [ B.listGroup, Rc.fileListGroup ] ]
       <> if dialog.showList then [] else [ ARIA.hidden "true" ])
    $ renameItem <$> dialog.dirs

  errorMessage ∷ HTML
  errorMessage =
    HH.div
      ([ HP.classes $ [ B.alert, B.alertDanger ] ]
       <> if isJust dialog.error then [] else [ ARIA.hidden "true" ])
      $ maybe [ ] (pure <<< HH.text) (dialog.error)

  renameItem ∷ R.Resource → HTML
  renameItem res =
    HH.button [ HP.classes ([ B.listGroupItem ]
                          <> (if R.isHidden res
                              then [ ItemCSS.itemHidden ]
                              else [ ]))
             , HE.onClick (HE.input_ (DirClicked res))
             ]
    [ HH.text (R.resourcePath res) ]

eval ∷ Query ~> DSL
eval (RaiseDismiss next) = do
  H.raise Dismiss
  pure next
eval (PreventDefault e next) = do
  H.liftEff $ DEE.preventDefault e
  pure next
eval (StopPropagation e q) = do
  H.liftEff $ DEE.stopPropagation e
  eval q
eval (SetShowList bool next) = do
  H.modify (_showList .~ bool)
  H.modify validate
  pure next
eval (ToggleShowList next) = do
  H.modify (_showList %~ not)
  H.modify validate
  pure next
eval (Submit next) = do
  dirStr <- endingInSlash <$> H.gets _.typedDir
  maybe presentDirNotExistError moveIfDirAccessible (parsedDir dirStr)
  pure next
  where
  parsedDir =
    map (rootDir </> _) ∘ sandbox rootDir <=< parseAbsDir

  presentSourceMissingError =
    H.modify $ _error .~ Just "The file you are trying to move is unavailable, please refresh."

  presentDirNotExistError =
    H.modify $ _error .~ Just "Target directory does not exist."

  presentError e =
    case GE.fromQError e of
      Left msg → H.modify $ _error .~ Just msg
      Right ge → GE.raiseGlobalError ge

  moveIfDirAccessible dir =
    maybe (move dir) presentError =<< API.dirNotAccessible dir

  move dir = do
    H.modify $ (_dir .~ dir) <<< (_showList .~ false)
    state ← H.get
    let src = state.initial
        tgt = R.getPath $ renameSlam state
    result ← H.lift $ API.move src tgt
    case result of
      Left e ->
        case GE.fromQError e of
          Left msg -> H.modify (_error ?~ msg)
          Right ge -> GE.raiseGlobalError ge
      Right x ->
        maybe
          presentSourceMissingError
          (const $ H.modify (_error .~ Nothing) *> H.liftEff reload)
          x
    pure unit

  lastChar s = S.drop (S.length s - 1) s

  endingInSlash s = if lastChar s == "/" then s else s <> "/"

eval (NameTyped str next) = do
  H.modify (_name .~ str)
  H.modify validate
  pure next
eval (DirTyped str next) = do
  H.modify $ _typedDir .~ str
  pure next
eval (DirClicked res next) = do
  dirItemClicked res
  pure next
eval (SetSiblings ss next) = do
  H.modify (_siblings .~ ss)
  pure next
eval (AddDirs ds next) = do
  H.modify (_dirs %~ append ds >>> nub >>> sort)
  pure next
eval (Init next) = do
  state <- H.get
  dirItemClicked $ R.parent $ state.initial
  pure next

dirItemClicked ∷ R.Resource → DSL Unit
dirItemClicked res = do
  case R.getPath res of
    Right _ → pure unit
    Left dir → do
      siblings ← API.children dir
      H.modify
        $ (_dir .~ dir)
        <<< (_showList .~ false)
        <<< (_siblings .~ either (const []) id siblings)
        <<< (_typedDir .~ printPath dir)

{-
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.FileSystem.Dialog.Rename.Component where

import SlamData.Prelude

import Control.UI.Browser (reload)

import Data.Array (elemIndex, singleton, sort, nub)
import Data.Lens ((^.), (%~), (.~), (?~), lens, Lens')
import Data.Path.Pathy (printPath, parseAbsDir, sandbox, rootDir, (</>))
import Data.String as S

import DOM.Event.Types (Event, mouseEventToEvent)
import DOM.Event.Event as DEE

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Config as Config
import SlamData.Dialog.Render (modalDialog, modalHeader, modalBody, modalFooter)
import SlamData.FileSystem.Dialog.Component.Message (Message(..))
import SlamData.FileSystem.Listing.Item.Component.CSS as ItemCSS
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.Monad (Slam)
import SlamData.Quasar.FS as API
import SlamData.Render.Common (formGroup)
import SlamData.Render.CSS as Rc

import Utils.Path (DirPath, dropWorkspaceExt)

type State =
  { showList ∷ Boolean
  , initial ∷ R.Resource
  , name ∷ String
  , dirs ∷ Array R.Resource
  , dir ∷ DirPath
  , typedDir ∷ String
  , siblings ∷ Array R.Resource
  , error ∷ Maybe String
  }

initialState ∷ R.Resource → State
initialState resource =
  { showList: false
  , initial: resource
  , name: if R.isWorkspace resource
          then dropWorkspaceExt $ R.resourceName resource
          else R.resourceName resource
  , dir: R.resourceDir resource
  , typedDir: printPath $ R.resourceDir resource
  , siblings: mempty
  , dirs: singleton R.root
  , error: Nothing
  }

_showList ∷ Lens' State Boolean
_showList = lens _.showList (_ { showList = _ })

_initial ∷ Lens' State R.Resource
_initial = lens _.initial (_ { initial = _ })

_name ∷ Lens' State String
_name = lens _.name (_ { name = _ })

_typedDir ∷ Lens' State String
_typedDir = lens _.typedDir (_ { typedDir = _ })

_dirs ∷ Lens' State (Array R.Resource)
_dirs = lens _.dirs (_ { dirs = _ })

_dir ∷ Lens' State DirPath
_dir = lens _.dir (_ { dir = _ })

_siblings ∷ Lens' State (Array R.Resource)
_siblings = lens _.siblings (_ { siblings = _ })

_error ∷ Lens' State (Maybe String)
_error = lens _.error (_ { error = _ })

renameSlam ∷ State → R.Resource
renameSlam r =
  let initial = r.initial
      name = r.name
      nameWithExt = if R.isWorkspace initial
                    then name <> "." <> Config.workspaceExtension
                    else name
  in initial # (R._name .~ nameWithExt)
           <<< (R._root .~ r.dir)

validate ∷ State → State
validate r
  | r.initial == renameSlam r = r # _error .~ Nothing
  | otherwise = r # _error .~ either Just (const Nothing) do
    let name = r.name
    when (name == "")
      $ throwError "Please enter a name for the file"

    when (isJust $ S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension) name)
      $ throwError $ "Please choose an alternative name, ."
      <> Config.workspaceExtension
      <> " is a reserved extension"

    when (isJust $ S.indexOf (S.Pattern "/") name)
      $ throwError "Please entera valid name for the file"

    let nameWithExt = if R.isWorkspace (r.initial)
                      then name <> "." <> Config.workspaceExtension
                      else name
    when (isJust $ elemIndex nameWithExt (map (_ ^. R._name) (r.siblings)))
      $ throwError "An item with this name already exists in the target folder"

data Query a
  = RaiseDismiss a
  | SetShowList Boolean a
  | ToggleShowList a
  | Submit a
  | NameTyped String a
  | DirTyped String a
  | DirClicked R.Resource a
  | SetSiblings (Array R.Resource) a
  | AddDirs (Array R.Resource) a
  | PreventDefault Event a
  | StopPropagation Event (Query a)
  | Init a

type DSL = H.ComponentDSL State Query Message Slam
type HTML = H.ComponentHTML Query

component ∷ H.Component HH.HTML Query R.Resource Message Slam
component =
  H.lifecycleComponent
    { initialState
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render dialog =
  modalDialog
  [ modalHeader "Move/rename"
  , modalBody
    $ HH.form
        [ HP.classes [ Rc.renameDialogForm ]
        , HE.onSubmit $ HE.input PreventDefault
        , HE.onClick \e → Just $ StopPropagation (mouseEventToEvent e) $ H.action $ SetShowList false
        ]
        [ nameInput
        , dirDropdownField
        , dirDropdownList
        , errorMessage
        ]
  , modalFooter
      [ HH.button
          [ HP.classes [ B.btn ]
          , HE.onClick (HE.input_ RaiseDismiss)
          ]
          [ HH.text "Cancel" ]
      , HH.button
          [ HP.classes [ B.btn, B.btnPrimary ]
          , HP.disabled $ isJust $ dialog.error
          , HE.onClick (HE.input_ Submit)
          ]
          [ HH.text "Rename" ]
      ]
  ]
  where
  nameInput ∷ HTML
  nameInput =
    formGroup [ HH.input [ HP.classes [ B.formControl ]
                        , HP.value (dialog.name)
                        , HP.placeholder "New name"
                        , HE.onValueInput (HE.input NameTyped)
                        ]
              ]

  dirDropdownField ∷ HTML
  dirDropdownField =
    HH.div
      [ HP.classes [ B.inputGroup, HH.ClassName "file-list-field" ] ]
      [ HH.input
          [ HP.classes [ B.formControl ]
          , HP.placeholder "New directory"
          , HE.onValueInput (HE.input DirTyped)
          , HP.value $ dialog ^. _typedDir
          ]
      , HH.span
          [ HP.classes [ B.inputGroupBtn ] ]
          [ HH.button
              [ HP.classes [ B.btn, B.btnDefault ]
              -- TODO:
              -- , HE.onClick \e →
              --      Just $ StopPropagation (mouseEventToEvent e) $ action $ ToggleShowList
              , ARIA.label "Select a destination folder"
              , HP.title "Select a destination folder"
              ]
              [ HH.span [ HP.classes [ B.caret ] ] [ ] ]
          ]
      ]
  dirDropdownList ∷ HTML
  dirDropdownList =
    HH.ul
      ([ HP.classes  [ B.listGroup, Rc.fileListGroup ] ]
       <> if dialog.showList then [] else [ ARIA.hidden "true" ])
    $ renameItem <$> dialog.dirs

  errorMessage ∷ HTML
  errorMessage =
    HH.div
      ([ HP.classes $ [ B.alert, B.alertDanger ] ]
       <> if isJust dialog.error then [] else [ ARIA.hidden "true" ])
      $ maybe [ ] (pure <<< HH.text) (dialog.error)

  renameItem ∷ R.Resource → HTML
  renameItem res =
    HH.button [ HP.classes ([ B.listGroupItem ]
                          <> (if R.isHidden res
                              then [ ItemCSS.itemHidden ]
                              else [ ]))
             , HE.onClick (HE.input_ (DirClicked res))
             ]
    [ HH.text (R.resourcePath res) ]

eval ∷ Query ~> DSL
eval (RaiseDismiss next) = do
  H.raise Dismiss
  pure next
eval (PreventDefault e next) = do
  H.liftEff $ DEE.preventDefault e
  pure next
eval (StopPropagation e q) = do
  H.liftEff $ DEE.stopPropagation e
  eval q
eval (SetShowList bool next) = do
  H.modify (_showList .~ bool)
  H.modify validate
  pure next
eval (ToggleShowList next) = do
  H.modify (_showList %~ not)
  H.modify validate
  pure next
eval (Submit next) = do
  dirStr <- endingInSlash <$> H.gets _.typedDir
  maybe presentDirNotExistError moveIfDirAccessible (parsedDir dirStr)
  pure next
  where
  parsedDir =
    map (rootDir </> _) ∘ sandbox rootDir <=< parseAbsDir

  presentSourceMissingError =
    H.modify $ _error .~ Just "The file you are trying to move is unavailable, please refresh."

  presentDirNotExistError =
    H.modify $ _error .~ Just "Target directory does not exist."

  presentError e =
    case GE.fromQError e of
      Left msg → H.modify $ _error .~ Just msg
      Right ge → GE.raiseGlobalError ge

  moveIfDirAccessible dir =
    maybe (move dir) presentError =<< API.dirNotAccessible dir

  move dir = do
    H.modify $ (_dir .~ dir) <<< (_showList .~ false)
    state ← H.get
    let src = state.initial
        tgt = R.getPath $ renameSlam state
    result ← H.lift $ API.move src tgt
    case result of
      Left e ->
        case GE.fromQError e of
          Left msg -> H.modify (_error ?~ msg)
          Right ge -> GE.raiseGlobalError ge
      Right x ->
        maybe
          presentSourceMissingError
          (const $ H.modify (_error .~ Nothing) *> H.liftEff reload)
          x
    pure unit

  lastChar s = S.drop (S.length s - 1) s

  endingInSlash s = if lastChar s == "/" then s else s <> "/"

eval (NameTyped str next) = do
  H.modify (_name .~ str)
  H.modify validate
  pure next
eval (DirTyped str next) = do
  H.modify $ _typedDir .~ str
  pure next
eval (DirClicked res next) = do
  dirItemClicked res
  pure next
eval (SetSiblings ss next) = do
  H.modify (_siblings .~ ss)
  pure next
eval (AddDirs ds next) = do
  H.modify (_dirs %~ append ds >>> nub >>> sort)
  pure next
eval (Init next) = do
  state <- H.get
  dirItemClicked $ R.parent $ state.initial
  pure next

dirItemClicked ∷ R.Resource → DSL Unit
dirItemClicked res = do
  case R.getPath res of
    Right _ → pure unit
    Left dir → do
      siblings ← API.children dir
      H.modify
        $ (_dir .~ dir)
        <<< (_showList .~ false)
        <<< (_siblings .~ either (const []) id siblings)
        <<< (_typedDir .~ printPath dir)


funnel legacy fix

funnel legacy fix

module SlamData.Workspace.Card.BuildChart.Legacy where

import SlamData.Prelude

import Data.Argonaut ((:=), (~>), (.?))
import Data.Argonaut as J
import Data.Array as A
import Data.Lens (view)
import Data.Int as Int

import SlamData.Common.Sort (Sort(..))
import SlamData.Common.Align (Align(..))
import SlamData.Workspace.Card.BuildChart.ColorScheme (parseColorScheme)

import SlamData.Form.Select as S
import SlamData.Workspace.Card.CardType.ChartType (ChartType(..), printChartType)
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.Pie.Model (PieR)
import SlamData.Workspace.Card.BuildChart.Bar.Model (BarR)
import SlamData.Workspace.Card.BuildChart.Line.Model (LineR)
import SlamData.Workspace.Card.BuildChart.Area.Model (AreaR)
import SlamData.Workspace.Card.BuildChart.Scatter.Model (ScatterR)
import SlamData.Workspace.Card.BuildChart.Radar.Model (RadarR)
import SlamData.Workspace.Card.BuildChart.Funnel.Model (FunnelR)
import SlamData.Workspace.Card.BuildChart.Heatmap.Model (HeatmapR)
import SlamData.Workspace.Card.BuildChart.Boxplot.Model (BoxplotR)

type ChartConfiguration =
  { series ∷ Array (S.Select J.JCursor)
  , dimensions ∷ Array (S.Select J.JCursor)
  , measures ∷ Array (S.Select J.JCursor)
  , aggregations ∷ Array (S.Select (Maybe Ag.Aggregation))
  }

decodeCC ∷ J.Json →  Either String ChartConfiguration
decodeCC = J.decodeJson >=> \obj → do
  { series: _, dimensions: _, measures: _, aggregations: _}
    <$> obj .? "series"
    <*> obj .? "dimensions"
    <*> obj .? "measures"
    <*> ((obj .? "aggregations") <|> ((obj .? "aggregations") <#> map (map Just)))

type BuildOptions =
  { chartType ∷ ChartType
  , axisLabelAngle ∷ Int
  , axisLabelFontSize ∷ Int
  , areaStacked ∷ Boolean
  , smooth ∷ Boolean
  , bubbleMinSize ∷ Number
  , bubbleMaxSize ∷ Number
  , funnelOrder ∷ String
  , funnelAlign ∷ String
  , minColorVal ∷ Number
  , maxColorVal ∷ Number
  , colorScheme ∷ String
  , colorReversed ∷ Boolean
  }

decodeBO ∷ J.Json → Either String BuildOptions
decodeBO = J.decodeJson >=> \obj →
  { chartType: _, axisLabelAngle: _, axisLabelFontSize: _
  , areaStacked: _, smooth: _, bubbleMinSize:_, bubbleMaxSize: _
  , funnelOrder: _, funnelAlign: _, minColorVal: _, maxColorVal: _
  , colorScheme: _, colorReversed: _ }
    <$> (obj .? "chartType")
    <*> (obj .? "axisLabelAngle")
    <*> (obj .? "axisLabelFontSize")
    <*> ((obj .? "areaStacked") <|> (pure false))
    <*> ((obj .? "smooth") <|> (pure false))
    <*> ((obj .? "bubbleMinSize") <|> (pure 1.0))
    <*> ((obj .? "bubbleMaxSize") <|> (pure 50.0))
    <*> ((obj .? "funnelOrder") <|> (pure "descending"))
    <*> ((obj .? "funnelAlign") <|> (pure "center"))
    <*> ((obj .? "minColorVal") <|> (pure 0.0))
    <*> ((obj .? "maxColorVal") <|> (pure 1.0))
    <*> ((obj .? "colorScheme") <|> (pure "diverging: red-blue"))
    <*> ((obj .? "colorReversed") <|> (pure false))

decode
  ∷ ∀ a
  . { pie ∷ Maybe PieR → a
    , line ∷ Maybe LineR → a
    , bar ∷ Maybe BarR → a
    , area ∷ Maybe AreaR → a
    , scatter ∷ Maybe ScatterR → a
    , radar ∷ Maybe RadarR → a
    , funnel ∷ Maybe FunnelR → a
    , heatmap ∷ Maybe HeatmapR → a
    , boxplot ∷ Maybe BoxplotR → a
    }
  → J.Json
  → String ⊹ a
decode cturs js = do
  obj ← J.decodeJson js
  bo ← (obj .? "options") >>= decodeBO
  cc ← (obj .? "chartConfig") >>= decodeCC
  case bo.chartType of
    Pie → decodePie cc
    Line → decodeLine cc bo
    Bar → decodeBar cc bo
    Area → decodeArea cc bo
    Scatter → decodeScatter cc bo
    Radar → decodeRadar cc bo
    Funnel → decodeFunnel cc bo
    Heatmap → decodeHeatmap cc bo
    Boxplot → decodeBoxplot cc bo
    chty → throwError $ printChartType chty ⊕ " should be decoded already"
  where
  decodePie ∷ ChartConfiguration → String ⊹ a
  decodePie cc = pure $ cturs.pie
    let
      category =
        cc.series A.!! 0 >>= view S._value
      donut =
        cc.series A.!! 1 >>= view S._value
      parallel =
        cc.series A.!! 2 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value

      pieR =
        { category: _
        , value: _
        , valueAggregation: _
        , donut
        , parallel
        }
        <$> category
        <*> value
        <*> valueAggregation

    in
      pieR

  decodeLine ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeLine cc bo = pure $ cturs.line
    let
      dimension =
        cc.dimensions A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      secondValue =
        cc.measures A.!! 1 >>= view S._value
      secondValueAggregation =
        join $ cc.aggregations A.!! 1 >>= view S._value

      size = Nothing
      sizeAggregation = Nothing
      minSize = 2.0
      maxSize = 20.0
      axisLabelAngle = Int.toNumber bo.axisLabelAngle
      axisLabelFontSize = bo.axisLabelFontSize

      lineR =
        { dimension: _
        , value: _
        , valueAggregation: _
        , secondValue
        , secondValueAggregation
        , size
        , sizeAggregation
        , minSize
        , maxSize
        , axisLabelAngle
        , axisLabelFontSize
        , series
        }
        <$> dimension
        <*> value
        <*> valueAggregation
    in
      lineR

  decodeBar ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeBar cc bo = pure $ cturs.bar
    let
      category =
        cc.series A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      stack =
        cc.series A.!! 2 >>= view S._value
      parallel =
        cc.series A.!! 1 >>= view S._value
      axisLabelAngle =
        Int.toNumber bo.axisLabelAngle
      axisLabelFontSize =
        bo.axisLabelFontSize

      barR =
        { category: _
        , value: _
        , valueAggregation: _
        , stack
        , parallel
        , axisLabelAngle
        , axisLabelFontSize
        }
        <$> category
        <*> value
        <*> valueAggregation
    in
      barR

  decodeArea ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeArea cc bo = pure $ cturs.area
    let
      dimension =
        cc.dimensions A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      isStacked =
        bo.areaStacked
      isSmooth =
        bo.smooth
      axisLabelAngle =
        Int.toNumber bo.axisLabelAngle
      axisLabelFontSize =
        bo.axisLabelFontSize

      areaR =
        { dimension: _
        , value: _
        , valueAggregation: _
        , series
        , isStacked
        , isSmooth
        , axisLabelAngle
        , axisLabelFontSize
        }
        <$> dimension
        <*> value
        <*> valueAggregation
    in
      areaR

  decodeScatter ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeScatter cc bo = pure $ cturs.scatter
    let
      abscissa =
        cc.measures A.!! 0 >>= view S._value
      ordinate =
        cc.measures A.!! 1 >>= view S._value
      size =
        cc.measures A.!! 2 >>= view S._value
      abscissaAggregation =
        fromMaybe Nothing $ cc.aggregations A.!! 0 >>= view S._value
      ordinateAggregation =
        fromMaybe Nothing $ cc.aggregations A.!! 1 >>= view S._value
      sizeAggregation =
        cc.aggregations A.!! 2 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      minSize =
        bo.bubbleMinSize
      maxSize =
        bo.bubbleMaxSize
      scatterR =
        { abscissa: _
        , ordinate: _
        , size
        , abscissaAggregation
        , ordinateAggregation
        , sizeAggregation
        , series
        , minSize
        , maxSize
        }
        <$> abscissa
        <*> ordinate
    in
      scatterR

  decodeRadar ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeRadar cc bo = pure $ cturs.radar
    let
      category =
        cc.dimensions A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      multiple =
        cc.series A.!! 0 >>= view S._value
      parallel =
        cc.series A.!! 1 >>= view S._value

      radarR =
        { category: _
        , value: _
        , valueAggregation: _
        , multiple
        , parallel
        }
        <$> category
        <*> value
        <*> valueAggregation
    in
      radarR

  decodeFunnel ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeFunnel cc bo = pure $ cturs.funnel
    let
      category =
        cc.dimensions A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      order = case bo.funnelOrder of
        "ascending" → Asc
        _ → Desc
      align = case bo.funnelAlign of
        "left" → LeftAlign
        "right" → RightAlign
        _ → CenterAlign

      funnelR =
        { category: _
        , value: _
        , valueAggregation: _
        , order
        , align
        , series
        }
        <$> category
        <*> value
        <*> valueAggregation
    in
      funnelR

  decodeHeatmap ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeHeatmap cc bo = pure $ cturs.heatmap
    let
      abscissa =
        cc.dimensions A.!! 0 >>= view S._value
      ordinate =
        cc.dimensions A.!! 1 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      colorScheme =
        either (const Nothing) Just $ parseColorScheme bo.colorScheme
      isColorSchemeReversed =
        bo.colorReversed
      minValue =
        bo.minColorVal
      maxValue =
        bo.maxColorVal

      heatMapR =
        { abscissa: _
        , ordinate: _
        , value: _
        , valueAggregation: _
        , series
        , colorScheme: _
        , isColorSchemeReversed
        , minValue
        , maxValue
        }
        <$> abscissa
        <*> ordinate
        <*> value
        <*> valueAggregation
        <*> colorScheme
    in
      heatMapR

  decodeBoxplot ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeBoxplot cc bo = pure $ cturs.boxplot
    let
      dimension =
        cc.dimensions A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      parallel =
        cc.series A.!! 0 >>= view S._value

      boxplotR =
        { dimension: _
        , value: _
        , series
        , parallel
        }
        <$> dimension
        <*> value
    in
      boxplotR

module SlamData.Workspace.Card.BuildChart.Legacy where

import SlamData.Prelude

import Data.Argonaut ((:=), (~>), (.?))
import Data.Argonaut as J
import Data.Array as A
import Data.Lens (view)
import Data.Int as Int

import SlamData.Common.Sort (Sort(..))
import SlamData.Common.Align (Align(..))
import SlamData.Workspace.Card.BuildChart.ColorScheme (parseColorScheme)

import SlamData.Form.Select as S
import SlamData.Workspace.Card.CardType.ChartType (ChartType(..), printChartType)
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.Pie.Model (PieR)
import SlamData.Workspace.Card.BuildChart.Bar.Model (BarR)
import SlamData.Workspace.Card.BuildChart.Line.Model (LineR)
import SlamData.Workspace.Card.BuildChart.Area.Model (AreaR)
import SlamData.Workspace.Card.BuildChart.Scatter.Model (ScatterR)
import SlamData.Workspace.Card.BuildChart.Radar.Model (RadarR)
import SlamData.Workspace.Card.BuildChart.Funnel.Model (FunnelR)
import SlamData.Workspace.Card.BuildChart.Heatmap.Model (HeatmapR)
import SlamData.Workspace.Card.BuildChart.Boxplot.Model (BoxplotR)

type ChartConfiguration =
  { series ∷ Array (S.Select J.JCursor)
  , dimensions ∷ Array (S.Select J.JCursor)
  , measures ∷ Array (S.Select J.JCursor)
  , aggregations ∷ Array (S.Select (Maybe Ag.Aggregation))
  }

decodeCC ∷ J.Json →  Either String ChartConfiguration
decodeCC = J.decodeJson >=> \obj → do
  { series: _, dimensions: _, measures: _, aggregations: _}
    <$> obj .? "series"
    <*> obj .? "dimensions"
    <*> obj .? "measures"
    <*> ((obj .? "aggregations") <|> ((obj .? "aggregations") <#> map (map Just)))

type BuildOptions =
  { chartType ∷ ChartType
  , axisLabelAngle ∷ Int
  , axisLabelFontSize ∷ Int
  , areaStacked ∷ Boolean
  , smooth ∷ Boolean
  , bubbleMinSize ∷ Number
  , bubbleMaxSize ∷ Number
  , funnelOrder ∷ String
  , funnelAlign ∷ String
  , minColorVal ∷ Number
  , maxColorVal ∷ Number
  , colorScheme ∷ String
  , colorReversed ∷ Boolean
  }

decodeBO ∷ J.Json → Either String BuildOptions
decodeBO = J.decodeJson >=> \obj →
  { chartType: _, axisLabelAngle: _, axisLabelFontSize: _
  , areaStacked: _, smooth: _, bubbleMinSize:_, bubbleMaxSize: _
  , funnelOrder: _, funnelAlign: _, minColorVal: _, maxColorVal: _
  , colorScheme: _, colorReversed: _ }
    <$> (obj .? "chartType")
    <*> (obj .? "axisLabelAngle")
    <*> (obj .? "axisLabelFontSize")
    <*> ((obj .? "areaStacked") <|> (pure false))
    <*> ((obj .? "smooth") <|> (pure false))
    <*> ((obj .? "bubbleMinSize") <|> (pure 1.0))
    <*> ((obj .? "bubbleMaxSize") <|> (pure 50.0))
    <*> ((obj .? "funnelOrder") <|> (pure "descending"))
    <*> ((obj .? "funnelAlign") <|> (pure "center"))
    <*> ((obj .? "minColorVal") <|> (pure 0.0))
    <*> ((obj .? "maxColorVal") <|> (pure 1.0))
    <*> ((obj .? "colorScheme") <|> (pure "diverging: red-blue"))
    <*> ((obj .? "colorReversed") <|> (pure false))

decode
  ∷ ∀ a
  . { pie ∷ Maybe PieR → a
    , line ∷ Maybe LineR → a
    , bar ∷ Maybe BarR → a
    , area ∷ Maybe AreaR → a
    , scatter ∷ Maybe ScatterR → a
    , radar ∷ Maybe RadarR → a
    , funnel ∷ Maybe FunnelR → a
    , heatmap ∷ Maybe HeatmapR → a
    , boxplot ∷ Maybe BoxplotR → a
    }
  → J.Json
  → String ⊹ a
decode cturs js = do
  obj ← J.decodeJson js
  bo ← (obj .? "options") >>= decodeBO
  cc ← (obj .? "chartConfig") >>= decodeCC
  case bo.chartType of
    Pie → decodePie cc
    Line → decodeLine cc bo
    Bar → decodeBar cc bo
    Area → decodeArea cc bo
    Scatter → decodeScatter cc bo
    Radar → decodeRadar cc bo
    Funnel → decodeFunnel cc bo
    Heatmap → decodeHeatmap cc bo
    Boxplot → decodeBoxplot cc bo
    chty → throwError $ printChartType chty ⊕ " should be decoded already"
  where
  decodePie ∷ ChartConfiguration → String ⊹ a
  decodePie cc = pure $ cturs.pie
    let
      category =
        cc.series A.!! 0 >>= view S._value
      donut =
        cc.series A.!! 1 >>= view S._value
      parallel =
        cc.series A.!! 2 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value

      pieR =
        { category: _
        , value: _
        , valueAggregation: _
        , donut
        , parallel
        }
        <$> category
        <*> value
        <*> valueAggregation

    in
      pieR

  decodeLine ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeLine cc bo = pure $ cturs.line
    let
      dimension =
        cc.dimensions A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      secondValue =
        cc.measures A.!! 1 >>= view S._value
      secondValueAggregation =
        join $ cc.aggregations A.!! 1 >>= view S._value

      size = Nothing
      sizeAggregation = Nothing
      minSize = 2.0
      maxSize = 20.0
      axisLabelAngle = Int.toNumber bo.axisLabelAngle
      axisLabelFontSize = bo.axisLabelFontSize

      lineR =
        { dimension: _
        , value: _
        , valueAggregation: _
        , secondValue
        , secondValueAggregation
        , size
        , sizeAggregation
        , minSize
        , maxSize
        , axisLabelAngle
        , axisLabelFontSize
        , series
        }
        <$> dimension
        <*> value
        <*> valueAggregation
    in
      lineR

  decodeBar ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeBar cc bo = pure $ cturs.bar
    let
      category =
        cc.series A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      stack =
        cc.series A.!! 2 >>= view S._value
      parallel =
        cc.series A.!! 1 >>= view S._value
      axisLabelAngle =
        Int.toNumber bo.axisLabelAngle
      axisLabelFontSize =
        bo.axisLabelFontSize

      barR =
        { category: _
        , value: _
        , valueAggregation: _
        , stack
        , parallel
        , axisLabelAngle
        , axisLabelFontSize
        }
        <$> category
        <*> value
        <*> valueAggregation
    in
      barR

  decodeArea ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeArea cc bo = pure $ cturs.area
    let
      dimension =
        cc.dimensions A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      isStacked =
        bo.areaStacked
      isSmooth =
        bo.smooth
      axisLabelAngle =
        Int.toNumber bo.axisLabelAngle
      axisLabelFontSize =
        bo.axisLabelFontSize

      areaR =
        { dimension: _
        , value: _
        , valueAggregation: _
        , series
        , isStacked
        , isSmooth
        , axisLabelAngle
        , axisLabelFontSize
        }
        <$> dimension
        <*> value
        <*> valueAggregation
    in
      areaR

  decodeScatter ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeScatter cc bo = pure $ cturs.scatter
    let
      abscissa =
        cc.measures A.!! 0 >>= view S._value
      ordinate =
        cc.measures A.!! 1 >>= view S._value
      size =
        cc.measures A.!! 2 >>= view S._value
      abscissaAggregation =
        fromMaybe Nothing $ cc.aggregations A.!! 0 >>= view S._value
      ordinateAggregation =
        fromMaybe Nothing $ cc.aggregations A.!! 1 >>= view S._value
      sizeAggregation =
        cc.aggregations A.!! 2 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      minSize =
        bo.bubbleMinSize
      maxSize =
        bo.bubbleMaxSize
      scatterR =
        { abscissa: _
        , ordinate: _
        , size
        , abscissaAggregation
        , ordinateAggregation
        , sizeAggregation
        , series
        , minSize
        , maxSize
        }
        <$> abscissa
        <*> ordinate
    in
      scatterR

  decodeRadar ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeRadar cc bo = pure $ cturs.radar
    let
      category =
        cc.dimensions A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      multiple =
        cc.series A.!! 0 >>= view S._value
      parallel =
        cc.series A.!! 1 >>= view S._value

      radarR =
        { category: _
        , value: _
        , valueAggregation: _
        , multiple
        , parallel
        }
        <$> category
        <*> value
        <*> valueAggregation
    in
      radarR

  decodeFunnel ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeFunnel cc bo = pure $ cturs.funnel
    let
      category =
        cc.dimensions A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      order = case bo.funnelOrder of
        "ascending" → Just Asc
        "desceding" → Just Desc
        _ → Nothing
      align = case bo.funnelAlign of
        "left" → Just LeftAlign
        "right" → Just RightAlign
        "center" → Just CenterAlign
        _ → Nothing

      funnelR =
        { category: _
        , value: _
        , valueAggregation: _
        , order: _
        , align: _
        , series
        }
        <$> category
        <*> value
        <*> valueAggregation
        <*> order
        <*> align
    in
      funnelR

  decodeHeatmap ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeHeatmap cc bo = pure $ cturs.heatmap
    let
      abscissa =
        cc.dimensions A.!! 0 >>= view S._value
      ordinate =
        cc.dimensions A.!! 1 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      valueAggregation =
        join $ cc.aggregations A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      colorScheme =
        either (const Nothing) Just $ parseColorScheme bo.colorScheme
      isColorSchemeReversed =
        bo.colorReversed
      minValue =
        bo.minColorVal
      maxValue =
        bo.maxColorVal

      heatMapR =
        { abscissa: _
        , ordinate: _
        , value: _
        , valueAggregation: _
        , series
        , colorScheme: _
        , isColorSchemeReversed
        , minValue
        , maxValue
        }
        <$> abscissa
        <*> ordinate
        <*> value
        <*> valueAggregation
        <*> colorScheme
    in
      heatMapR

  decodeBoxplot ∷ ChartConfiguration → BuildOptions → String ⊹ a
  decodeBoxplot cc bo = pure $ cturs.boxplot
    let
      dimension =
        cc.dimensions A.!! 0 >>= view S._value
      value =
        cc.measures A.!! 0 >>= view S._value
      series =
        cc.series A.!! 0 >>= view S._value
      parallel =
        cc.series A.!! 0 >>= view S._value

      boxplotR =
        { dimension: _
        , value: _
        , series
        , parallel
        }
        <$> dimension
        <*> value
    in
      boxplotR