Fix bug in flag counting

Fix bug in flag counting

module Language.Docopt.Trans (
  reduce
  ) where

import Prelude
import Debug.Trace
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Bifunctor (lmap)
import Data.Array as A
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Map (Map())
import Data.String (fromChar)
import Data.Monoid (mempty)
import Data.Map as Map
import Data.String as Str
import Data.Tuple (Tuple(..), fst, snd)
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Data.Function (on)
import Language.Docopt.Env (Env())
import Language.Docopt.Usage    as D
import Language.Docopt.Errors   as D
import Language.Docopt.Env      as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Option   as O
import Language.Docopt.Env      as Env
import Data.String.Ext ((^=))
import Data.List (List(..), toList, concat, singleton, groupBy, catMaybes)
import Data.List as L
import Language.Docopt.ParserGen.ValueMapping

newtype Key = Key { arg :: D.Argument }

instance showKey :: Show Key where
  show (Key { arg: (D.Option (O.Option o)) }) =
    maybe "" (\c -> fromChar c ++ ", ") o.flag
      ++ maybe "" id o.name
  show (Key { arg: (D.Positional n _) }) = n
  show (Key { arg: (D.Command n) }) = n
  show _ = "invalid" -- XXX

instance ordKey :: Ord Key where
  compare = compare `on` show -- XXX

instance eqKey :: Eq Key where
  eq (Key { arg: arg0 }) (Key { arg: arg1 }) = go arg0 arg1
    where
      go (D.Positional n _) (D.Positional n' _)
         = n ^= n'
      go (D.Option (O.Option { flag=f,  name=n  }))
         (D.Option (O.Option { flag=f', name=n' }))
         = (f == f') && (n == n')
      go (D.Command n) (D.Command n')
         = n == n'
      go a b = a == b

key :: D.Argument -> Key
key arg = Key { arg: arg }

-- | Reduce the list of (Argument, Value) mappings down to a Set of (String,
-- | Value), where `String` is the name of the argument.
-- |
-- | This reduction is "lossy" as it loses some of the rich information
-- | about the options that have been acquired. It also loses the information
-- | about the origin of the matched value as it could have been user-provded or
-- | derived from the option descriptions (default value, etc.).
-- |
-- | Despite the pitfalls, the reasons for adopting this are:
-- |
-- |   a) Compatibility with original docopt
-- |   b) Easy of use in JS-land. This step could implemented differently for
-- |      consumption in purescript (or any other language for that matter).
-- |
-- | A note on equality:
-- |    Options are considered equal if their names (or both of their aliases)
-- |    match. Modifiers such as repetitiveness or the arguments an option takes
-- |    are *NOT* considered for evaluating option equality.
-- |
reduce :: List D.Usage       -- ^ the program specification
       -> D.Env              -- ^ the environment
       -> D.Branch           -- ^ the matched specification
       -> List ValueMapping  -- ^ the parse result
       -> Map String D.Value -- ^ the output set of (arg => val)
reduce us env b vs =
  let vm = Map.fromFoldableWith resolveArg $ lmap key <$> (prepare <$> vs)
    -- XXX: The following creation of a list of usages is looking funny because
    --      originally this implementation would collect values across all
    --      usage patterns (`us`). However, the new implementation only
    --      considers the branch the user actually matched. Potentially, both
    --      approaches could be combined? The problem with going cross-usage is
    --      that arguments present in multiple usage patterns would falsy be
    --      identified as repeating.
      m  = reduceUsages (singleton $ D.Usage (singleton b)) # applyValues vm
    in expandMap m
  where

    prepare :: ValueMapping -> ValueMapping
    prepare (Tuple a v) | D.isRepeatable a = Tuple a (D.ArrayValue $ valIntoArray v)
    prepare k = k

    expandMap :: Map Key D.Value -> Map String D.Value
    expandMap m =
      Map.fromFoldable $ concat
        $ Map.toList m
            <#> \(Tuple (Key { arg: a }) v) ->
                    let v' =
                        if D.isFlag a
                          then case v of
                            D.ArrayValue xs ->
                              D.IntValue (A.length $ flip A.filter xs \x ->
                                case x of
                                      D.BoolValue b | b -> true
                                      _ -> false
                              )
                            _ -> v
                          else v
                     in flip Tuple v' <$> (toList $ toKeys a)

    applyValues :: Map Key D.Value -> List D.Argument -> Map Key D.Value
    applyValues vm as = Map.fromFoldableWith resolveArg
      $ catMaybes
      $ as <#> \a -> Tuple (key a) <$> (getValue vm a <|> getFallback a)

    resolveArg :: D.Value -> D.Value -> D.Value
    resolveArg v v' = D.ArrayValue $ valIntoArray v' ++ valIntoArray v

    valIntoArray (D.ArrayValue xs)  = xs
    valIntoArray v                  = [v]

    reduceUsages :: List D.Usage -> List D.Argument
    reduceUsages us =
      let ms = reduceBranches <<< D.runUsage <$> us
       in Map.values $ foldl (Map.unionWith resolveLCD)
                             Map.empty
                             ms
      where
        reduceBranches :: List D.Branch -> Map Key D.Argument
        reduceBranches bs =
          let ms = combine <<< (expand <$>) <<< D.runBranch <$> bs
          in foldl (Map.unionWith resolveOR)
                    Map.empty
                    ms
          where
            combine :: List (Map Key D.Argument) -> Map Key D.Argument
            combine xs = foldl (Map.unionWith resolveLCD)
                              Map.empty
                              xs

        expand :: D.Argument -> Map Key D.Argument
        expand (D.Group _ bs r) =
          reduceBranches
            $ D.Branch <<< ((flip D.setRepeatableOr r) <$>)
                       <<< D.runBranch
                       <$> bs

        expand arg = Map.singleton (key arg) arg

        resolveOR :: D.Argument -> D.Argument -> D.Argument
        resolveOR a b = D.setRepeatable a (D.isRepeatable a || D.isRepeatable b)

        resolveLCD :: D.Argument -> D.Argument -> D.Argument
        resolveLCD a b =  D.setRepeatable a true

    getValue :: Map Key D.Value -> D.Argument -> Maybe D.Value
    getValue vm a = do
      v <- Map.lookup (key a) vm
      return $ if D.isRepeatable a
                    then D.ArrayValue $ valIntoArray v
                    else v

    getFallback :: D.Argument -> Maybe D.Value
    getFallback a = getEnvValue a <|> getDefaultValue a

    getEnvValue :: D.Argument -> Maybe D.Value
    getEnvValue (D.Option (O.Option o@{ env: Just k }))
      = D.StringValue <$> Env.lookup k env
    getEnvValue _ = Nothing

    getDefaultValue :: D.Argument -> Maybe D.Value
    getDefaultValue (D.Option (O.Option o@{
        arg: Just (O.Argument { default: Just v })
      }))
      = return $
          if (D.isArrayValue v || not o.repeatable) then v
                                                    else D.ArrayValue [v]
    -- Handle option flags. Flags indicate only truthiness via their
    -- presence. Absent flags are always falsy!
    getDefaultValue (D.Option (O.Option o@{ arg: Nothing }))
      = return $ if o.repeatable then D.ArrayValue [ D.BoolValue false ]
                                 else D.BoolValue false
    getDefaultValue (D.Positional _ r)
      = if r then return $ D.ArrayValue []
             else Nothing
    getDefaultValue (D.Command _)
      = return $ D.BoolValue false
    getDefaultValue (D.EOA) = Just $ D.ArrayValue []
    getDefaultValue _ = Nothing

-- | Derive a key from an argument.
-- | This key is what the user will use to check the value of
-- | a mathed argument.
toKeys :: D.Argument -> Array String
toKeys (D.Command n)      = [n]
toKeys (D.Positional n _) = [ "<" ++ Str.toLower n ++ ">"
                            , Str.toUpper n
                            ]
toKeys (D.Group _ _ _)    = []
toKeys (D.EOA)            = ["--"]
toKeys (D.Stdin)          = ["-"]
toKeys (D.Option (O.Option o))
                          = []
                          ++ maybe [] (\c -> [ "-"  ++ fromChar c ]) o.flag
                          ++ maybe [] (\s -> [ "--" ++ s ]) o.name

module Language.Docopt.Trans (
  reduce
  ) where

import Prelude
import Debug.Trace
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Bifunctor (lmap)
import Data.Array as A
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Map (Map())
import Data.String (fromChar)
import Data.Monoid (mempty)
import Data.Map as Map
import Data.String as Str
import Data.Tuple (Tuple(..), fst, snd)
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Data.Function (on)
import Language.Docopt.Env (Env())
import Language.Docopt.Usage    as D
import Language.Docopt.Errors   as D
import Language.Docopt.Env      as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Option   as O
import Language.Docopt.Env      as Env
import Data.String.Ext ((^=))
import Data.List (List(..), toList, concat, singleton, groupBy, catMaybes)
import Data.List as L
import Language.Docopt.ParserGen.ValueMapping

newtype Key = Key { arg :: D.Argument }

instance showKey :: Show Key where
  show (Key { arg: (D.Option (O.Option o)) }) =
    maybe "" (\c -> fromChar c ++ ", ") o.flag
      ++ maybe "" id o.name
  show (Key { arg: (D.Positional n _) }) = n
  show (Key { arg: (D.Command n) }) = n
  show _ = "invalid" -- XXX

instance ordKey :: Ord Key where
  compare = compare `on` show -- XXX

instance eqKey :: Eq Key where
  eq (Key { arg: arg0 }) (Key { arg: arg1 }) = go arg0 arg1
    where
      go (D.Positional n _) (D.Positional n' _)
         = n ^= n'
      go (D.Option (O.Option { flag=f,  name=n  }))
         (D.Option (O.Option { flag=f', name=n' }))
         = (f == f') && (n == n')
      go (D.Command n) (D.Command n')
         = n == n'
      go a b = a == b

key :: D.Argument -> Key
key arg = Key { arg: arg }

-- | Reduce the list of (Argument, Value) mappings down to a Set of (String,
-- | Value), where `String` is the name of the argument.
-- |
-- | This reduction is "lossy" as it loses some of the rich information
-- | about the options that have been acquired. It also loses the information
-- | about the origin of the matched value as it could have been user-provded or
-- | derived from the option descriptions (default value, etc.).
-- |
-- | Despite the pitfalls, the reasons for adopting this are:
-- |
-- |   a) Compatibility with original docopt
-- |   b) Easy of use in JS-land. This step could implemented differently for
-- |      consumption in purescript (or any other language for that matter).
-- |
-- | A note on equality:
-- |    Options are considered equal if their names (or both of their aliases)
-- |    match. Modifiers such as repetitiveness or the arguments an option takes
-- |    are *NOT* considered for evaluating option equality.
-- |
reduce :: List D.Usage       -- ^ the program specification
       -> D.Env              -- ^ the environment
       -> D.Branch           -- ^ the matched specification
       -> List ValueMapping  -- ^ the parse result
       -> Map String D.Value -- ^ the output set of (arg => val)
reduce us env b vs =
  let vm = Map.fromFoldableWith resolveArg $ lmap key <$> (prepare <$> vs)
    -- XXX: The following creation of a list of usages is looking funny because
    --      originally this implementation would collect values across all
    --      usage patterns (`us`). However, the new implementation only
    --      considers the branch the user actually matched. Potentially, both
    --      approaches could be combined? The problem with going cross-usage is
    --      that arguments present in multiple usage patterns would falsy be
    --      identified as repeating.
      m  = reduceUsages (singleton $ D.Usage (singleton b)) # applyValues vm
    in expandMap m
  where

    prepare :: ValueMapping -> ValueMapping
    prepare (Tuple a v) | D.isRepeatable a = Tuple a (D.ArrayValue $ valIntoArray v)
    prepare k = k

    expandMap :: Map Key D.Value -> Map String D.Value
    expandMap m =
      Map.fromFoldable $ concat
        $ Map.toList m
            <#> \(Tuple (Key { arg: a }) v) ->
                    let v' =
                        if D.isFlag a
                          then case v of
                            D.ArrayValue xs ->
                              D.IntValue (A.length $ flip A.filter xs \x ->
                                case x of
                                      D.BoolValue b | b -> true
                                      _ -> false
                              )
                            _               -> D.BoolValue true
                          else v
                     in flip Tuple v' <$> (toList $ toKeys a)

    applyValues :: Map Key D.Value -> List D.Argument -> Map Key D.Value
    applyValues vm as = Map.fromFoldableWith resolveArg
      $ catMaybes
      $ as <#> \a -> Tuple (key a) <$> (getValue vm a <|> getFallback a)

    resolveArg :: D.Value -> D.Value -> D.Value
    resolveArg v v' = D.ArrayValue $ valIntoArray v' ++ valIntoArray v

    valIntoArray (D.ArrayValue xs)  = xs
    valIntoArray v                  = [v]

    reduceUsages :: List D.Usage -> List D.Argument
    reduceUsages us =
      let ms = reduceBranches <<< D.runUsage <$> us
       in Map.values $ foldl (Map.unionWith resolveLCD)
                             Map.empty
                             ms
      where
        reduceBranches :: List D.Branch -> Map Key D.Argument
        reduceBranches bs =
          let ms = combine <<< (expand <$>) <<< D.runBranch <$> bs
          in foldl (Map.unionWith resolveOR)
                    Map.empty
                    ms
          where
            combine :: List (Map Key D.Argument) -> Map Key D.Argument
            combine xs = foldl (Map.unionWith resolveLCD)
                              Map.empty
                              xs

        expand :: D.Argument -> Map Key D.Argument
        expand (D.Group _ bs r) =
          reduceBranches
            $ D.Branch <<< ((flip D.setRepeatableOr r) <$>)
                       <<< D.runBranch
                       <$> bs

        expand arg = Map.singleton (key arg) arg

        resolveOR :: D.Argument -> D.Argument -> D.Argument
        resolveOR a b = D.setRepeatable a (D.isRepeatable a || D.isRepeatable b)

        resolveLCD :: D.Argument -> D.Argument -> D.Argument
        resolveLCD a b =  D.setRepeatable a true

    getValue :: Map Key D.Value -> D.Argument -> Maybe D.Value
    getValue vm a = do
      v <- Map.lookup (key a) vm
      return $ if D.isRepeatable a
                    then D.ArrayValue $ valIntoArray v
                    else v

    getFallback :: D.Argument -> Maybe D.Value
    getFallback a = getEnvValue a <|> getDefaultValue a

    getEnvValue :: D.Argument -> Maybe D.Value
    getEnvValue (D.Option (O.Option o@{ env: Just k }))
      = D.StringValue <$> Env.lookup k env
    getEnvValue _ = Nothing

    getDefaultValue :: D.Argument -> Maybe D.Value
    getDefaultValue (D.Option (O.Option o@{
        arg: Just (O.Argument { default: Just v })
      }))
      = return $
          if (D.isArrayValue v || not o.repeatable) then v
                                                    else D.ArrayValue [v]
    -- Handle option flags. Flags indicate only truthiness via their
    -- presence. Absent flags are always falsy!
    getDefaultValue (D.Option (O.Option o@{ arg: Nothing }))
      = return $ if o.repeatable then D.ArrayValue [ D.BoolValue false ]
                                 else D.BoolValue false
    getDefaultValue (D.Positional _ r)
      = if r then return $ D.ArrayValue []
             else Nothing
    getDefaultValue (D.Command _)
      = return $ D.BoolValue false
    getDefaultValue (D.EOA) = Just $ D.ArrayValue []
    getDefaultValue _ = Nothing

-- | Derive a key from an argument.
-- | This key is what the user will use to check the value of
-- | a mathed argument.
toKeys :: D.Argument -> Array String
toKeys (D.Command n)      = [n]
toKeys (D.Positional n _) = [ "<" ++ Str.toLower n ++ ">"
                            , Str.toUpper n
                            ]
toKeys (D.Group _ _ _)    = []
toKeys (D.EOA)            = ["--"]
toKeys (D.Stdin)          = ["-"]
toKeys (D.Option (O.Option o))
                          = []
                          ++ maybe [] (\c -> [ "-"  ++ fromChar c ]) o.flag
                          ++ maybe [] (\s -> [ "--" ++ s ]) o.name


add forgotten not

add forgotten not

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

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


continue refactoring

continue refactoring

module SearchEngine where

import Data.Maybe.Unsafe (fromJust)
import Data.Map (Map(), fromList, lookup, insert, empty, values, keys)
import Control.Apply
import Data.Tuple
import Data.String (trim, split, toCharArray, fromCharArray, toLower)
import Data.Char
import Data.Array (range, length, filter, null, sort, sortBy, groupBy, drop, concatMap, concat)
import Data.Foldable (foldl)
import Data.Maybe
import Data.Function (on)
import Data.Array.Unsafe (head)

type Doc = [Line]
type Line = String
type Word = String
type LineNumber = Number
type Pos = Number
type Index = Map Word [Tuple Pos LineNumber]

data PartialTermIndex = D (Map Char (Tuple [[Char]] PartialTermIndex))

both :: forall a. (a -> Boolean) -> (a -> Boolean) -> a -> Boolean
both = lift2 (&&)

lines :: String -> [Line]
lines s = trim <$> (split "\n" s)

words :: String -> [Word]
words s = trim <$> (split " " s)

numLines :: Doc -> [Tuple Line LineNumber]
numLines doc = flip zip ns doc
    where ns = range 0 (length doc)

numWords :: Line -> [Tuple Word Pos]
numWords line = flip zip ns ws
    where ns = range 0 (length ws)
          ws = cleanWords (words line)

isUpperCaseLetter :: Char -> Boolean
isUpperCaseLetter ch = toCharCode ch >= 65 && toCharCode ch <= 90

isLowerCaseLetter :: Char -> Boolean
isLowerCaseLetter ch = toCharCode ch >= 97 && toCharCode ch <= 122

isLetter :: Char -> Boolean
isLetter ch = isUpperCaseLetter ch || isLowerCaseLetter ch

isAscii :: Char -> Boolean
isAscii ch = toCharCode ch >= 0 && toCharCode ch <= 127

cleanWords :: [Word] -> [Word]
cleanWords = (<$>) toLower <<<
             (<$>) fromCharArray <<<
             filter (not <<< null) <<<
             (<$>) (filter (both isLetter isAscii)) <<<
             (<$>) toCharArray

allNumWords :: [Tuple Line LineNumber] -> [Tuple Word (Tuple Pos LineNumber)]
allNumWords = (>>= (\(Tuple l i) -> (<$>) (\(Tuple w p) -> Tuple w (Tuple p i)) $ numWords l))

makeLists :: [Tuple Word (Tuple Pos LineNumber)] -> [Tuple Word [Tuple Pos LineNumber]]
makeLists = (<$>) (\(Tuple w (Tuple p i)) -> Tuple w [Tuple p i])

accumulate :: [Tuple Word [Tuple Pos LineNumber]] -> [Tuple Word [Tuple Pos LineNumber]]
accumulate = foldl f []
           where f [] x = [x]
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w == w2 = (Tuple w (l:ls)):xs
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w /= w2 = (Tuple w2 [l]):((Tuple w ls):xs)

createTermIndex :: Doc -> Index
createTermIndex =  fromList <<< accumulate <<< makeLists <<< sort <<< allNumWords <<< numLines

createPartialTermIndex :: [String] -> PartialTermIndex
createPartialTermIndex = createPartialTermIndex' <<< (<$>) toCharArray
  where
    createPartialTermIndex' []  = D empty
    createPartialTermIndex' ws  =
        foldl (\(D m) (Tuple k ws') -> D $ insert k (Tuple ws' (createPartialTermIndex' ((<$>) (drop 1) ws'))) m) (D empty) <<<
        (<$>) (\ws' -> Tuple (head (head ws')) ws') <<<
        groupBy ((==) `on` head) <<<
        sortBy (compare `on` head) <<<
        filter (not <<< null) $ ws

searchTermsFromPartial :: [Char] -> PartialTermIndex -> Tuple Boolean [[Char]]
searchTermsFromPartial s d = findTerms s d
  where
    flattenValues = (<$>) (s ++) <<< concatMap fst <<< values

    findTerms [] (D d') = Tuple true (flattenValues d')
    findTerms (x:xs) (D d') =
      case lookup x d' of
            Just (Tuple _ d'') -> findTerms xs d''
            Nothing -> Tuple false (flattenValues d')

createIndex :: Doc -> Tuple Index PartialTermIndex
createIndex doc = Tuple index (createPartialTermIndex (keys index))
  where index = createTermIndex doc

module SearchEngine where

import Data.Maybe.Unsafe (fromJust)
import Data.Map (Map(), fromList, lookup, insert, empty)
import Control.Apply
import Data.Tuple
import Data.String (trim, split, toCharArray, fromCharArray, toLower)
import Data.Char
import Data.Array (range, length, filter, null, sort, sortBy, groupBy, drop, concatMap, concat)
import Data.Foldable (foldl)
import Data.Maybe
import Data.Function (on)
import Data.Array.Unsafe (head)

type Doc = [Line]
type Line = String
type Word = String
type LineNumber = Number
type Pos = Number
type Index = Map Word [Tuple Pos LineNumber]

data PartialTermIndex = D (Map Char (Tuple [[Char]] PartialTermIndex))

both :: forall a. (a -> Boolean) -> (a -> Boolean) -> a -> Boolean
both = lift2 (&&)

lines :: String -> [Line]
lines s = trim <$> (split "\n" s)

words :: String -> [Word]
words s = trim <$> (split " " s)

numLines :: Doc -> [Tuple Line LineNumber]
numLines doc = flip zip ns doc
    where ns = range 0 (length doc)

numWords :: Line -> [Tuple Word Pos]
numWords line = flip zip ns ws
    where ns = range 0 (length ws)
          ws = cleanWords (words line)

isUpperCaseLetter :: Char -> Boolean
isUpperCaseLetter ch = toCharCode ch >= 65 && toCharCode ch <= 90

isLowerCaseLetter :: Char -> Boolean
isLowerCaseLetter ch = toCharCode ch >= 97 && toCharCode ch <= 122

isLetter :: Char -> Boolean
isLetter ch = isUpperCaseLetter ch || isLowerCaseLetter ch

isAscii :: Char -> Boolean
isAscii ch = toCharCode ch >= 0 && toCharCode ch <= 127

cleanWords :: [Word] -> [Word]
cleanWords = (<$>) toLower <<<
             (<$>) fromCharArray <<<
             filter (not <<< null) <<<
             (<$>) (filter (both isLetter isAscii)) <<<
             (<$>) toCharArray

allNumWords :: [Tuple Line LineNumber] -> [Tuple Word (Tuple Pos LineNumber)]
allNumWords = (>>= (\(Tuple l i) -> (<$>) (\(Tuple w p) -> Tuple w (Tuple p i)) $ numWords l))

makeLists :: [Tuple Word (Tuple Pos LineNumber)] -> [Tuple Word [Tuple Pos LineNumber]]
makeLists = (<$>) (\(Tuple w (Tuple p i)) -> Tuple w [Tuple p i])

accumulate :: [Tuple Word [Tuple Pos LineNumber]] -> [Tuple Word [Tuple Pos LineNumber]]
accumulate = foldl f []
           where f [] x = [x]
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w == w2 = (Tuple w (l:ls)):xs
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w /= w2 = (Tuple w2 [l]):((Tuple w ls):xs)

createTermIndex :: Doc -> Index
createTermIndex =  fromList <<< accumulate <<< makeLists <<< sort <<< allNumWords <<< numLines

createPartialTermIndex :: [String] -> PartialTermIndex
createPartialTermIndex = createPartialTermIndex' <<< (<$>) toCharArray
  where
    createPartialTermIndex' []  = D empty
    createPartialTermIndex' ws  =
        foldl (\(D m) (Tuple k ws') -> D $ insert k (Tuple ws' (createPartialTermIndex' ((<$>) (drop 1) ws'))) m) (D empty) <<<
        (<$>) (\ws' -> Tuple (head (head ws')) ws') <<<
        groupBy ((==) `on` head) <<<
        sortBy (compare `on` head) <<<
        filter (not <<< null) $ ws


H.get + H.modify -> H.modify \st ->

H.get + H.modify -> H.modify \st ->

{-
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.Card.Setups.Chart.Line.Component
  ( lineBuilderComponent
  ) where

import SlamData.Prelude

import Data.Lens ((^?), (.~), (?~))
import Data.List as List

import Global (readFloat, isNaN)

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

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.Model as Card
import SlamData.Render.Common (row)
import SlamData.Form.Select (_value)

import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Common.Render (renderLowLOD)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.CardType.ChartType as CHT

import SlamData.Workspace.Card.Setups.CSS as CSS
import SlamData.Workspace.Card.Setups.DimensionPicker.Component as DPC
import SlamData.Workspace.Card.Setups.DimensionPicker.JCursor (groupJCursors, flattenJCursors)
import SlamData.Workspace.Card.Setups.Inputs as BCI
import SlamData.Workspace.Card.Setups.Chart.Line.Component.ChildSlot as CS
import SlamData.Workspace.Card.Setups.Chart.Line.Component.State as ST
import SlamData.Workspace.Card.Setups.Chart.Line.Component.Query as Q
import SlamData.Workspace.Card.Setups.Chart.Line.Model as M
import SlamData.Workspace.Card.Eval.State (_Axes)

type DSL =
  H.ParentDSL ST.State CS.ChildState Q.QueryC CS.ChildQuery Slam CS.ChildSlot

type HTML =
  H.ParentHTML CS.ChildState Q.QueryC CS.ChildQuery Slam CS.ChildSlot

lineBuilderComponent ∷ CC.CardOptions → H.Component CC.CardStateP CC.CardQueryP Slam
lineBuilderComponent options = CC.makeCardComponent
  { options
  , cardType: CT.ChartOptions CHT.Line
  , component: H.parentComponent { render, eval, peek: Just (peek ∘ H.runChildF) }
  , initialState: H.parentState ST.initialState
  , _State: CC._BuildLineState
  , _Query: CC.makeQueryPrism' CC._BuildLineQuery
  }

render ∷ ST.State → HTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD (CT.cardIconDarkImg $ CT.ChartOptions CHT.Line) left state.levelOfDetails
    ]

renderHighLOD ∷ ST.State → HTML
renderHighLOD state =
  HH.div
    [ HP.classes
        $ [ CSS.chartEditor ]
        ⊕ (guard (state.levelOfDetails ≠ High) $> B.hidden)
    ]
    [ renderDimension state
    , renderValue state
    , renderSecondValue state
    , renderSeries state
    , renderSize state
    , HH.hr_
    , renderOptionalMarkers state
    , HH.hr_
    , row [ renderMinSize state, renderMaxSize state ]
    , HH.hr_
    , row [ renderAxisLabelAngle state ]
    , renderPicker state
    ]

selecting ∷ ∀ a. (a → Q.Selection BCI.SelectAction) → a → H.Action Q.QueryC
selecting f q _ = right (Q.Select (f q) unit)

renderPicker ∷ ST.State → HTML
renderPicker state = case state.picker of
  Nothing → HH.text ""
  Just { options, select } →
    HH.slot unit \_ →
      { component: DPC.picker
          { title: case select of
              Q.Dimension _   → "Choose dimension"
              Q.Value _       → "Choose measure #1"
              Q.SecondValue _ → "Choose measure #2"
              Q.Size _        → "Choose measure #3"
              Q.Series _      → "Choose series"
              _ → ""
          , label: DPC.labelNode show
          , render: DPC.renderNode show
          , values: groupJCursors (List.fromFoldable options)
          , isSelectable: DPC.isLeafPath
          }
      , initialState: H.parentState DPC.initialState
      }

renderDimension ∷ ST.State → HTML
renderDimension state =
  HH.form
    [ HP.classes [ CSS.chartConfigureForm ]
    , Cp.nonSubmit
    ]
    [ BCI.pickerInput
        (BCI.primary (Just "Dimension") (selecting Q.Dimension))
        state.dimension
    ]

renderValue ∷ ST.State → HTML
renderValue state =
  HH.form
    [ HP.classes [ CSS.withAggregation, CSS.chartConfigureForm ]
    , Cp.nonSubmit
    ]
    [ BCI.pickerWithSelect
        (BCI.secondary (Just "Measure #1") (selecting Q.Value))
        state.value
        (BCI.aggregation (Just "Measure Aggregation #1") (selecting Q.ValueAgg))
        state.valueAgg
    ]

renderSecondValue ∷ ST.State → HTML
renderSecondValue state =
  HH.form
    [ HP.classes [ CSS.withAggregation, CSS.chartConfigureForm ]
    , Cp.nonSubmit
    ]
    [ BCI.pickerWithSelect
        (BCI.secondary (Just "Measure #2") (selecting Q.SecondValue))
        state.secondValue
        (BCI.aggregation (Just "Measure Aggregation #2") (selecting Q.SecondValueAgg))
        state.secondValueAgg
    ]

renderSeries ∷ ST.State → HTML
renderSeries state =
  HH.form
    [ HP.classes [ CSS.chartConfigureForm ]
    , Cp.nonSubmit
    ]
    [ BCI.pickerInput
        (BCI.secondary (Just "Series") (selecting Q.Series))
        state.series
    ]

renderSize ∷ ST.State → HTML
renderSize state =
  HH.form
    [ HP.classes [ CSS.withAggregation, CSS.chartConfigureForm ]
    , Cp.nonSubmit
    ]
    [ BCI.pickerWithSelect
        (BCI.secondary (Just "Measure #3") (selecting Q.Size))
        state.size
        (BCI.aggregation (Just "Measure Aggregation #3") (selecting Q.SizeAgg))
        state.sizeAgg
    ]

renderAxisLabelAngle ∷ ST.State → HTML
renderAxisLabelAngle state =
  HH.form
    [ HP.classes [ B.colXs6, CSS.axisLabelParam ]
    , Cp.nonSubmit
    ]
    [ HH.label [ HP.classes [ B.controlLabel ] ] [ HH.text "Label angle" ]
    , HH.input
        [ HP.classes [ B.formControl ]
        , HP.value $ show $ state.axisLabelAngle
        , ARIA.label "Axis label angle"
        , HE.onValueChange $ HE.input (\s → right ∘ Q.SetAxisLabelAngle s)
        ]
    ]

renderOptionalMarkers ∷ ST.State → HTML
renderOptionalMarkers state =
  HH.form
    [ HP.classes [ HH.className "chart-optional-markers" ]
    , Cp.nonSubmit
    ]
    [ HH.label
        [ HP.classes [ B.controlLabel ] ]
        [ HH.text "Enable data point markers (disables Measure #3)" ]
    , HH.input
        [ HP.inputType HP.InputCheckbox
        , HP.checked state.optionalMarkers
        , ARIA.label "Enable data point markers"
        , HE.onChecked $ HE.input_ $ right ∘ Q.ToggleOptionalMarkers
        ]
    ]

renderMinSize ∷ ST.State → HTML
renderMinSize state =
  HH.form
    [ HP.classes [ B.colXs6, CSS.axisLabelParam ]
    , Cp.nonSubmit
    ]
    [ HH.label
        [ HP.classes [ B.controlLabel ] ]
        [ HH.text if state.optionalMarkers then "Size" else "Min size" ]
    , HH.input
        [ HP.classes [ B.formControl ]
        , HP.value $ show $ state.minSize
        , ARIA.label "Min size"
        , HE.onValueChange $ HE.input (\s → right ∘ Q.SetMinSymbolSize s)
        ]
    ]

renderMaxSize ∷ ST.State → HTML
renderMaxSize state =
  HH.form
    [ HP.classes [ B.colXs6, CSS.axisLabelParam ]
    , Cp.nonSubmit
    ]
    [ HH.label [ HP.classes [ B.controlLabel ] ] [ HH.text "Max size" ]
    , HH.input
        [ HP.classes [ B.formControl ]
        , HP.value $ show $ state.maxSize
        , ARIA.label "Max size"
        , HP.disabled state.optionalMarkers
        , HE.onValueChange$ HE.input (\s → right ∘ Q.SetMaxSymbolSize s)
        ]
    ]

eval ∷ Q.QueryC ~> DSL
eval = cardEval ⨁ lineBuilderEval

cardEval ∷ CC.CardEvalQuery ~> DSL
cardEval = case _ of
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k → do
    H.gets $ k ∘ Card.BuildLine ∘ M.behaviour.save
  CC.Load (Card.BuildLine model) next → do
    H.modify $ M.behaviour.load model
    pure next
  CC.Load card next →
    pure next
  CC.ReceiveInput _ _ next →
    pure next
  CC.ReceiveOutput _ _ next →
    pure next
  CC.ReceiveState evalState next → do
    for_ (evalState ^? _Axes) \axes → do
      H.modify _{axes = axes}
      H.modify M.behaviour.synchronize
    pure next
  CC.ReceiveDimensions dims next → do
    H.modify _
      { levelOfDetails =
          if dims.width < 576.0 ∨ dims.height < 416.0
            then Low
            else High
      }
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

raiseUpdate ∷ DSL Unit
raiseUpdate = do
  H.modify M.behaviour.synchronize
  CC.raiseUpdatedP' CC.EvalModelUpdate

lineBuilderEval ∷ Q.Query ~> DSL
lineBuilderEval = case _ of
  Q.SetAxisLabelAngle str next → do
    let fl = readFloat str
    unless (isNaN fl) do
      H.modify _{ axisLabelAngle = fl }
      CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Q.SetMinSymbolSize str next → do
    let fl = readFloat str
    unless (isNaN fl) do
      H.modify \st →
        st{ minSize = fl
          , maxSize = if st.maxSize > fl then st.maxSize else fl
          }
      CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Q.SetMaxSymbolSize str next → do
    let fl = readFloat str
    unless (isNaN fl) do
      H.modify \st →
        st{ maxSize = fl
           , minSize = if st.minSize < fl then st.minSize else fl
           }
      CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Q.ToggleOptionalMarkers next → do
    H.modify \st → st{ optionalMarkers = not st.optionalMarkers }
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Q.Select sel next → do
    case sel of
      Q.Dimension a →
        updatePicker ST._dimension Q.Dimension a
      Q.Value a →
        updatePicker ST._value Q.Value a
      Q.ValueAgg a →
        updateSelect ST._valueAgg a
      Q.SecondValue a →
        updatePicker ST._secondValue Q.SecondValue a
      Q.SecondValueAgg a →
        updateSelect ST._secondValueAgg a
      Q.Size a → case a of
        BCI.Open opts → do
          H.modify $ ST.showPicker Q.Size opts
        BCI.Choose v → do
          H.modify
            $ (ST._size ∘ _value .~ v)
            ∘ _{ optionalMarkers = false }
          raiseUpdate
      Q.SizeAgg a → case a of
        BCI.Open _ →
          pure unit
        BCI.Choose v → do
          H.modify
            $ (ST._sizeAgg ∘ _value .~ v)
            ∘ _{ optionalMarkers = false }
          raiseUpdate
      Q.Series a →
        updatePicker ST._series Q.Series a
    pure next
  where
  updatePicker l q = case _ of
    BCI.Open opts → H.modify (ST.showPicker q opts)
    BCI.Choose a  → H.modify (l ∘ _value .~ a) *> raiseUpdate

  updateSelect l = case _ of
    BCI.Open _    → pure unit
    BCI.Choose a  → H.modify (l ∘ _value .~ a) *> raiseUpdate

peek ∷ ∀ a. CS.ChildQuery a → DSL Unit
peek = coproduct peekPicker (const (pure unit))
  where
  peekPicker = case _ of
    DPC.Dismiss _ →
      H.modify _ { picker = Nothing }
    DPC.Confirm value _ → do
      st ← H.get
      let
        value' = flattenJCursors value
      for_ st.picker \{ select } → case select of
        Q.Dimension _ →
          H.modify (ST._dimension ∘ _value ?~ value')
        Q.Value _ →
          H.modify (ST._value ∘ _value ?~ value')
        Q.SecondValue _ →
          H.modify (ST._secondValue ∘ _value ?~ value')
        Q.Size _ → do
          H.modify
            $ (ST._size ∘ _value ?~ value')
            ∘ _{ optionalMarkers = false }
        Q.Series _ → do
          H.modify
            $ (ST._series ∘ _value ?~ value')
            ∘ _{ optionalMarkers = false }

        _ → pure unit
      H.modify _ { picker = Nothing }
      raiseUpdate

{-
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.Card.Setups.Chart.Line.Component
  ( lineBuilderComponent
  ) where

import SlamData.Prelude

import Data.Lens ((^?), (.~), (?~))
import Data.List as List

import Global (readFloat, isNaN)

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

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.Model as Card
import SlamData.Render.Common (row)
import SlamData.Form.Select (_value)

import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Common.Render (renderLowLOD)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.CardType.ChartType as CHT

import SlamData.Workspace.Card.Setups.CSS as CSS
import SlamData.Workspace.Card.Setups.DimensionPicker.Component as DPC
import SlamData.Workspace.Card.Setups.DimensionPicker.JCursor (groupJCursors, flattenJCursors)
import SlamData.Workspace.Card.Setups.Inputs as BCI
import SlamData.Workspace.Card.Setups.Chart.Line.Component.ChildSlot as CS
import SlamData.Workspace.Card.Setups.Chart.Line.Component.State as ST
import SlamData.Workspace.Card.Setups.Chart.Line.Component.Query as Q
import SlamData.Workspace.Card.Setups.Chart.Line.Model as M
import SlamData.Workspace.Card.Eval.State (_Axes)

type DSL =
  H.ParentDSL ST.State CS.ChildState Q.QueryC CS.ChildQuery Slam CS.ChildSlot

type HTML =
  H.ParentHTML CS.ChildState Q.QueryC CS.ChildQuery Slam CS.ChildSlot

lineBuilderComponent ∷ CC.CardOptions → H.Component CC.CardStateP CC.CardQueryP Slam
lineBuilderComponent options = CC.makeCardComponent
  { options
  , cardType: CT.ChartOptions CHT.Line
  , component: H.parentComponent { render, eval, peek: Just (peek ∘ H.runChildF) }
  , initialState: H.parentState ST.initialState
  , _State: CC._BuildLineState
  , _Query: CC.makeQueryPrism' CC._BuildLineQuery
  }

render ∷ ST.State → HTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD (CT.cardIconDarkImg $ CT.ChartOptions CHT.Line) left state.levelOfDetails
    ]

renderHighLOD ∷ ST.State → HTML
renderHighLOD state =
  HH.div
    [ HP.classes
        $ [ CSS.chartEditor ]
        ⊕ (guard (state.levelOfDetails ≠ High) $> B.hidden)
    ]
    [ renderDimension state
    , renderValue state
    , renderSecondValue state
    , renderSeries state
    , renderSize state
    , HH.hr_
    , renderOptionalMarkers state
    , HH.hr_
    , row [ renderMinSize state, renderMaxSize state ]
    , HH.hr_
    , row [ renderAxisLabelAngle state ]
    , renderPicker state
    ]

selecting ∷ ∀ a. (a → Q.Selection BCI.SelectAction) → a → H.Action Q.QueryC
selecting f q _ = right (Q.Select (f q) unit)

renderPicker ∷ ST.State → HTML
renderPicker state = case state.picker of
  Nothing → HH.text ""
  Just { options, select } →
    HH.slot unit \_ →
      { component: DPC.picker
          { title: case select of
              Q.Dimension _   → "Choose dimension"
              Q.Value _       → "Choose measure #1"
              Q.SecondValue _ → "Choose measure #2"
              Q.Size _        → "Choose measure #3"
              Q.Series _      → "Choose series"
              _ → ""
          , label: DPC.labelNode show
          , render: DPC.renderNode show
          , values: groupJCursors (List.fromFoldable options)
          , isSelectable: DPC.isLeafPath
          }
      , initialState: H.parentState DPC.initialState
      }

renderDimension ∷ ST.State → HTML
renderDimension state =
  HH.form
    [ HP.classes [ CSS.chartConfigureForm ]
    , Cp.nonSubmit
    ]
    [ BCI.pickerInput
        (BCI.primary (Just "Dimension") (selecting Q.Dimension))
        state.dimension
    ]

renderValue ∷ ST.State → HTML
renderValue state =
  HH.form
    [ HP.classes [ CSS.withAggregation, CSS.chartConfigureForm ]
    , Cp.nonSubmit
    ]
    [ BCI.pickerWithSelect
        (BCI.secondary (Just "Measure #1") (selecting Q.Value))
        state.value
        (BCI.aggregation (Just "Measure Aggregation #1") (selecting Q.ValueAgg))
        state.valueAgg
    ]

renderSecondValue ∷ ST.State → HTML
renderSecondValue state =
  HH.form
    [ HP.classes [ CSS.withAggregation, CSS.chartConfigureForm ]
    , Cp.nonSubmit
    ]
    [ BCI.pickerWithSelect
        (BCI.secondary (Just "Measure #2") (selecting Q.SecondValue))
        state.secondValue
        (BCI.aggregation (Just "Measure Aggregation #2") (selecting Q.SecondValueAgg))
        state.secondValueAgg
    ]

renderSeries ∷ ST.State → HTML
renderSeries state =
  HH.form
    [ HP.classes [ CSS.chartConfigureForm ]
    , Cp.nonSubmit
    ]
    [ BCI.pickerInput
        (BCI.secondary (Just "Series") (selecting Q.Series))
        state.series
    ]

renderSize ∷ ST.State → HTML
renderSize state =
  HH.form
    [ HP.classes [ CSS.withAggregation, CSS.chartConfigureForm ]
    , Cp.nonSubmit
    ]
    [ BCI.pickerWithSelect
        (BCI.secondary (Just "Measure #3") (selecting Q.Size))
        state.size
        (BCI.aggregation (Just "Measure Aggregation #3") (selecting Q.SizeAgg))
        state.sizeAgg
    ]

renderAxisLabelAngle ∷ ST.State → HTML
renderAxisLabelAngle state =
  HH.form
    [ HP.classes [ B.colXs6, CSS.axisLabelParam ]
    , Cp.nonSubmit
    ]
    [ HH.label [ HP.classes [ B.controlLabel ] ] [ HH.text "Label angle" ]
    , HH.input
        [ HP.classes [ B.formControl ]
        , HP.value $ show $ state.axisLabelAngle
        , ARIA.label "Axis label angle"
        , HE.onValueChange $ HE.input (\s → right ∘ Q.SetAxisLabelAngle s)
        ]
    ]

renderOptionalMarkers ∷ ST.State → HTML
renderOptionalMarkers state =
  HH.form
    [ HP.classes [ HH.className "chart-optional-markers" ]
    , Cp.nonSubmit
    ]
    [ HH.label
        [ HP.classes [ B.controlLabel ] ]
        [ HH.text "Enable data point markers (disables Measure #3)" ]
    , HH.input
        [ HP.inputType HP.InputCheckbox
        , HP.checked state.optionalMarkers
        , ARIA.label "Enable data point markers"
        , HE.onChecked $ HE.input_ $ right ∘ Q.ToggleOptionalMarkers
        ]
    ]

renderMinSize ∷ ST.State → HTML
renderMinSize state =
  HH.form
    [ HP.classes [ B.colXs6, CSS.axisLabelParam ]
    , Cp.nonSubmit
    ]
    [ HH.label
        [ HP.classes [ B.controlLabel ] ]
        [ HH.text if state.optionalMarkers then "Size" else "Min size" ]
    , HH.input
        [ HP.classes [ B.formControl ]
        , HP.value $ show $ state.minSize
        , ARIA.label "Min size"
        , HE.onValueChange $ HE.input (\s → right ∘ Q.SetMinSymbolSize s)
        ]
    ]

renderMaxSize ∷ ST.State → HTML
renderMaxSize state =
  HH.form
    [ HP.classes [ B.colXs6, CSS.axisLabelParam ]
    , Cp.nonSubmit
    ]
    [ HH.label [ HP.classes [ B.controlLabel ] ] [ HH.text "Max size" ]
    , HH.input
        [ HP.classes [ B.formControl ]
        , HP.value $ show $ state.maxSize
        , ARIA.label "Max size"
        , HP.disabled state.optionalMarkers
        , HE.onValueChange$ HE.input (\s → right ∘ Q.SetMaxSymbolSize s)
        ]
    ]

eval ∷ Q.QueryC ~> DSL
eval = cardEval ⨁ lineBuilderEval

cardEval ∷ CC.CardEvalQuery ~> DSL
cardEval = case _ of
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k → do
    H.gets $ k ∘ Card.BuildLine ∘ M.behaviour.save
  CC.Load (Card.BuildLine model) next → do
    H.modify $ M.behaviour.load model
    pure next
  CC.Load card next →
    pure next
  CC.ReceiveInput _ _ next →
    pure next
  CC.ReceiveOutput _ _ next →
    pure next
  CC.ReceiveState evalState next → do
    for_ (evalState ^? _Axes) \axes → do
      H.modify _{axes = axes}
      H.modify M.behaviour.synchronize
    pure next
  CC.ReceiveDimensions dims next → do
    H.modify _
      { levelOfDetails =
          if dims.width < 576.0 ∨ dims.height < 416.0
            then Low
            else High
      }
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

raiseUpdate ∷ DSL Unit
raiseUpdate = do
  H.modify M.behaviour.synchronize
  CC.raiseUpdatedP' CC.EvalModelUpdate

lineBuilderEval ∷ Q.Query ~> DSL
lineBuilderEval = case _ of
  Q.SetAxisLabelAngle str next → do
    let fl = readFloat str
    unless (isNaN fl) do
      H.modify _{ axisLabelAngle = fl }
      CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Q.SetMinSymbolSize str next → do
    st ← H.get
    let fl = readFloat str
    unless (isNaN fl) do
      H.modify _{ minSize = fl
                , maxSize = if st.maxSize > fl then st.maxSize else fl
                }
      CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Q.SetMaxSymbolSize str next → do
    st ← H.get
    let fl = readFloat str
    unless (isNaN fl) do
      H.modify _{ maxSize = fl
                , minSize = if st.minSize < fl then st.minSize else fl
                }
      CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Q.ToggleOptionalMarkers next → do
    st ← H.get
    H.modify _{ optionalMarkers = not st.optionalMarkers }
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Q.Select sel next → do
    case sel of
      Q.Dimension a →
        updatePicker ST._dimension Q.Dimension a
      Q.Value a →
        updatePicker ST._value Q.Value a
      Q.ValueAgg a →
        updateSelect ST._valueAgg a
      Q.SecondValue a →
        updatePicker ST._secondValue Q.SecondValue a
      Q.SecondValueAgg a →
        updateSelect ST._secondValueAgg a
      Q.Size a → case a of
        BCI.Open opts → do
          H.modify $ ST.showPicker Q.Size opts
        BCI.Choose v → do
          H.modify
            $ (ST._size ∘ _value .~ v)
            ∘ _{ optionalMarkers = false }
          raiseUpdate
      Q.SizeAgg a → case a of
        BCI.Open _ →
          pure unit
        BCI.Choose v → do
          H.modify
            $ (ST._sizeAgg ∘ _value .~ v)
            ∘ _{ optionalMarkers = false }
          raiseUpdate
      Q.Series a →
        updatePicker ST._series Q.Series a
    pure next
  where
  updatePicker l q = case _ of
    BCI.Open opts → H.modify (ST.showPicker q opts)
    BCI.Choose a  → H.modify (l ∘ _value .~ a) *> raiseUpdate

  updateSelect l = case _ of
    BCI.Open _    → pure unit
    BCI.Choose a  → H.modify (l ∘ _value .~ a) *> raiseUpdate

peek ∷ ∀ a. CS.ChildQuery a → DSL Unit
peek = coproduct peekPicker (const (pure unit))
  where
  peekPicker = case _ of
    DPC.Dismiss _ →
      H.modify _ { picker = Nothing }
    DPC.Confirm value _ → do
      st ← H.get
      let
        value' = flattenJCursors value
      for_ st.picker \{ select } → case select of
        Q.Dimension _ →
          H.modify (ST._dimension ∘ _value ?~ value')
        Q.Value _ →
          H.modify (ST._value ∘ _value ?~ value')
        Q.SecondValue _ →
          H.modify (ST._secondValue ∘ _value ?~ value')
        Q.Size _ → do
          H.modify
            $ (ST._size ∘ _value ?~ value')
            ∘ _{ optionalMarkers = false }
        Q.Series _ → do
          H.modify
            $ (ST._series ∘ _value ?~ value')
            ∘ _{ optionalMarkers = false }

        _ → pure unit
      H.modify _ { picker = Nothing }
      raiseUpdate


Parse methods case-insensitively

Parse methods case-insensitively

module Hyper.Method where

import Data.Eq (class Eq)
import Data.Maybe (Maybe(Nothing, Just))
import Data.Show (class Show)
import Data.String as String

data Method
  = OPTIONS
  | GET
  | HEAD
  | POST
  | PUT
  | PATCH
  | DELETE
  | TRACE
  | CONNECT

derive instance eqMethod :: Eq Method

instance showMethod :: Show Method where
  show OPTIONS = "OPTIONS"
  show GET = "GET"
  show HEAD = "HEAD"
  show POST = "POST"
  show PUT = "PUT"
  show PATCH = "PATCH"
  show DELETE = "DELETE"
  show TRACE = "TRACE"
  show CONNECT = "CONNECT"

fromString :: String -> Maybe Method
fromString s =
  case String.toUpper s of
    "OPTIONS" -> Just OPTIONS
    "GET" -> Just GET
    "HEAD" -> Just HEAD
    "POST" -> Just POST
    "PUT" -> Just PUT
    "PATCH" -> Just PATCH
    "DELETE" -> Just DELETE
    "TRACE" -> Just TRACE
    "CONNECT" -> Just CONNECT
    _ -> Nothing

module Hyper.Method where

import Data.Eq (class Eq)
import Data.Maybe (Maybe(Nothing, Just))
import Data.Show (class Show)

data Method
  = OPTIONS
  | GET
  | HEAD
  | POST
  | PUT
  | PATCH
  | DELETE
  | TRACE
  | CONNECT

derive instance eqMethod :: Eq Method

instance showMethod :: Show Method where
  show OPTIONS = "OPTIONS"
  show GET = "GET"
  show HEAD = "HEAD"
  show POST = "POST"
  show PUT = "PUT"
  show PATCH = "PATCH"
  show DELETE = "DELETE"
  show TRACE = "TRACE"
  show CONNECT = "CONNECT"

fromString :: String -> Maybe Method
fromString s =
  case s of
    "OPTIONS" -> Just OPTIONS
    "GET" -> Just GET
    "HEAD" -> Just HEAD
    "POST" -> Just POST
    "PUT" -> Just PUT
    "PATCH" -> Just PATCH
    "DELETE" -> Just DELETE
    "TRACE" -> Just TRACE
    "CONNECT" -> Just CONNECT
    _ -> Nothing