Fix SD-1287 / InputRadio => InputCheckbox

https://slamdata.atlassian.net/browse/SD-1287

-- | This module defines a component for rendering SlamDown documents to HTML

module Text.Markdown.SlamDown.Html
  ( SlamDownQuery(..)
  , SlamDownFormState(..)
  , SlamDownStateR(..)
  , SlamDownState(..)
  , FormFieldValue(..)
  , emptySlamDownState
  , makeSlamDownState

  , SlamDownConfig(..)
  , defaultBrowserFeatures

  , slamDownComponent
  , renderSlamDown
  , evalSlamDownQuery
  )
  where

import Prelude

import Control.Monad.State (State(), evalState)
import Control.Monad.State.Class (get, modify)

import Data.BrowserFeatures
import Data.BrowserFeatures.InputType as IT
import Data.Foldable (foldMap, foldr)
import Data.List (List(..), mapMaybe, fromList, toList, zipWithA, zip, singleton, filter)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Monoid (mempty)
import Data.Set as S
import Data.String (joinWith)
import Data.StrMap as M
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Data.Validation as V

import Halogen (get, modify) as H
import Halogen.Component as H
import Halogen.HTML.Core as H
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P

import Test.StrongCheck as SC
import Test.StrongCheck.Gen as SC

import Text.Markdown.SlamDown
import Text.Markdown.SlamDown.Parser.Inline (validateFormField)

data FormFieldValue
  = SingleValue TextBoxType String
  | MultipleValues (S.Set String)

instance arbitraryFormFieldValue :: SC.Arbitrary FormFieldValue where
  arbitrary = do
    b <- SC.arbitrary
    if b
      then SingleValue <$> SC.arbitrary <*> SC.arbitrary
      else MultipleValues <<< S.fromList <<< toList <$> SC.arrayOf SC.arbitrary

instance showFormFieldValue :: Show FormFieldValue where
  show (SingleValue t s) = "(SingleValue " ++ show t ++ " " ++ show s ++ ")"
  show (MultipleValues ss) = "(MultipleValues " ++ show ss ++ ")"

type SlamDownFormDesc = M.StrMap FormField
type SlamDownFormState = M.StrMap FormFieldValue

type SlamDownStateR =
  { document :: SlamDown
  , formState :: SlamDownFormState
  }

-- | The state of a SlamDown form
newtype SlamDownState = SlamDownState SlamDownStateR

modifySlamDownState :: (SlamDownFormState -> SlamDownFormState) -> SlamDownState -> SlamDownState
modifySlamDownState f (SlamDownState rec) = SlamDownState (rec { formState = f rec.formState })

instance showSlamDownState :: Show SlamDownState where
  show (SlamDownState rec) = "(SlamDownState " ++ show rec.formState ++ ")"

instance arbitrarySlamDownState :: SC.Arbitrary SlamDownState where
  arbitrary = do
    document <- SC.arbitrary
    formState <- M.fromList <<< toList <$> SC.arrayOf SC.arbitrary
    pure $ SlamDownState
      { document : document
      , formState : formState
      }

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

-- | The initial empty state of the form, with an empty document.
emptySlamDownState :: SlamDownState
emptySlamDownState =
  SlamDownState
    { document : SlamDown mempty
    , formState : M.empty
    }

-- | The initial state of the form based on a document value. All fields use
-- | their default values.
makeSlamDownState :: SlamDown -> SlamDownState
makeSlamDownState doc =
  SlamDownState
    { document : doc
    , formState : formStateFromDocument doc
    }

formFieldGetDefaultValue :: FormField -> Maybe FormFieldValue
formFieldGetDefaultValue f =
  case f of
    TextBox tbt (Just (Literal value)) ->
      Just $ SingleValue tbt value
    CheckBoxes (Literal sels) (Literal vals) ->
      let chk (Tuple t v) = if t then Just v else Nothing in
      Just $ MultipleValues $ S.fromList $ chk `mapMaybe` zip sels vals
    RadioButtons (Literal value) _ ->
      Just $ SingleValue PlainText value
    DropDown _ (Just (Literal value)) ->
      Just $ SingleValue PlainText value
    _ -> Nothing

formStateFromDocument :: SlamDown -> SlamDownFormState
formStateFromDocument = M.fromList <<< everything (const mempty) phi
  where
    phi :: Inline -> List (Tuple String FormFieldValue)
    phi (FormField label _ field) =
      maybe mempty (singleton <<< Tuple label) $
        V.runV (const Nothing) Just (validateFormField field)
          >>= formFieldGetDefaultValue
    phi _ = mempty

formDescFromDocument :: SlamDown -> SlamDownFormDesc
formDescFromDocument = M.fromList <<< everything (const mempty) phi
  where
    phi :: Inline -> List (Tuple String FormField)
    phi (FormField label _ field) = singleton (Tuple label field)
    phi _ = mempty

changeDocument :: SlamDown -> SlamDownState -> SlamDownState
changeDocument doc (SlamDownState state) =
  SlamDownState
    { document : doc
    , formState : mergedFormState
    }

  where
    formDesc :: SlamDownFormDesc
    formDesc = formDescFromDocument doc

    -- | Returns the keys that are either not present in the new state, or have had their types changed.
    keysToPrune :: Array String
    keysToPrune =
      M.foldMap
        (\key oldVal ->
            case Tuple oldVal (M.lookup key formDesc) of
               Tuple (SingleValue tbt1 _) (Just (TextBox tbt2 _)) -> if tbt1 == tbt2 then [] else [key]
               Tuple _ Nothing -> [key]
               _ -> [])
        state.formState

    prunedFormState :: SlamDownFormState
    prunedFormState = foldr M.delete state.formState keysToPrune

    mergedFormState :: SlamDownFormState
    mergedFormState = prunedFormState `M.union` formStateFromDocument doc

data SlamDownQuery a
  = TextChanged TextBoxType String String a
  | CheckBoxChanged String String Boolean a
  | SetDocument SlamDown a
  | GetFormState (SlamDownFormState -> a)
  | PopulateForm SlamDownFormState a

instance functorSlamDownQuery :: Functor SlamDownQuery where
  map f e =
    case e of
      TextChanged tbt k v a -> TextChanged tbt k v $ f a
      CheckBoxChanged k v b a -> CheckBoxChanged k v b $ f a
      SetDocument doc a -> SetDocument doc $ f a
      GetFormState k -> GetFormState (f <<< k)
      PopulateForm s a -> PopulateForm s $ f a

instance arbitrarySlamDownQuery :: (SC.Arbitrary a) => SC.Arbitrary (SlamDownQuery a) where
  arbitrary = do
    b <- SC.arbitrary
    if b
      then TextChanged <$> SC.arbitrary <*> SC.arbitrary <*> SC.arbitrary <*> SC.arbitrary
      else CheckBoxChanged <$> SC.arbitrary <*> SC.arbitrary <*> SC.arbitrary <*> SC.arbitrary

evalSlamDownQuery :: forall g. H.Eval SlamDownQuery SlamDownState SlamDownQuery g
evalSlamDownQuery e =
  case e of
    TextChanged t key val next -> do
      H.modify <<< modifySlamDownState $
        M.insert key (SingleValue t val)
      pure next
    CheckBoxChanged key val checked next -> do
      let
        updateSet :: Maybe FormFieldValue -> FormFieldValue
        updateSet (Just (MultipleValues s))
          | checked = MultipleValues (S.insert val s)
          | otherwise = MultipleValues (S.delete val s)
        updateSet _
          | checked = MultipleValues (S.singleton val)
          | otherwise = MultipleValues S.empty
      H.modify <<< modifySlamDownState $
        M.alter (Just <<< updateSet) key
      pure next
    GetFormState k -> do
      SlamDownState state <- H.get
      pure $ k state.formState
    PopulateForm values next -> do
      H.modify \(SlamDownState { document }) ->
        let desc = formDescFromDocument document
            keysToPrune = filter (\newKey -> not (newKey `M.member` desc)) (toList (M.keys values))
            prunedValues = foldr M.delete values keysToPrune
        in SlamDownState { document, formState: prunedValues }
      pure next
    SetDocument doc next -> do
      H.modify $ changeDocument doc
      pure next

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

type Fresh = State Int

fresh :: String -> Fresh String
fresh formName = do
  n <- get :: Fresh Int
  modify (+ 1)
  pure (formName ++ "-" ++ show n)

runFresh :: forall a. Fresh a -> a
runFresh m = evalState m 1

type FreshRenderer p a = a -> Fresh (H.HTML p (SlamDownQuery Unit))

-- | Render a `SlamDown` document into an HTML form.
renderSlamDown :: SlamDownConfig -> H.Render SlamDownState SlamDownQuery
renderSlamDown config (SlamDownState state) =
  case state.document of
    SlamDown bs ->
      H.div_ <<< runFresh <<< traverse renderBlock $ fromList bs

  where
    h_ :: forall p a. Int -> Array (H.HTML p a) -> H.HTML p a
    h_ 1 = H.h1_
    h_ 2 = H.h2_
    h_ 3 = H.h3_
    h_ 4 = H.h4_
    h_ 5 = H.h5_
    h_ _ = H.h6_

    el_ :: forall p a. ListType -> Array (H.HTML p a) -> H.HTML p a
    el_ (Bullet _)  = H.ul_
    el_ (Ordered _) = H.ol_

    renderInline :: forall p. FreshRenderer p Inline
    renderInline i =
      case i of
        Str s -> pure $ H.text s
        Entity s -> pure $ H.text s
        Space -> pure $ H.text " "
        SoftBreak -> pure $ H.text "\n"
        LineBreak -> pure $ H.br_
        Emph is -> H.em_ <$> traverse renderInline (fromList is)
        Strong is -> H.strong_ <$> traverse renderInline (fromList is)
        Code _ c -> pure $ H.code_ [ H.text c ]
        Link body tgt -> do
          let
            href (InlineLink url) = url
            href (ReferenceLink tgt') = maybe "" ("#" ++) tgt'
          H.a [ P.href $ href tgt ] <$> traverse renderInline (fromList body)
        Image body url ->
          pure $ H.img
            [ P.src url
            , P.alt $ foldMap stripInline body
            ]
        FormField label req el -> do
          ident <- fresh config.formName
          el' <- renderFormElement config state ident label (ensureValidField el)
          let
            requiredLabel = if req then "*" else ""
            requiresId = case el of
              CheckBoxes _ _ -> false
              RadioButtons _ _ -> false
              _ -> true

          pure $ H.span
            [ P.class_ (H.className "slamdown-field") ]
            [ H.label
              (if requiresId then [ P.for ident ] else [])
              [ H.text (label ++ requiredLabel) ]
            , el'
            ]

    stripInline :: Inline -> String
    stripInline i =
      case i of
        Str s -> s
        Entity s -> s
        Space -> " "
        SoftBreak -> "\n"
        LineBreak -> "\n"
        Emph is -> foldMap stripInline is
        Strong is -> foldMap stripInline is
        Code _ c -> c
        Link body _ -> foldMap stripInline body
        _ -> ""

    renderBlock :: forall p. FreshRenderer p Block
    renderBlock b =
      case b of
        Paragraph is ->
          H.p_ <$> traverse renderInline (fromList is)
        Header lvl is ->
          h_ lvl <$> traverse renderInline (fromList is)
        Blockquote bs ->
          H.blockquote_ <$> traverse renderBlock (fromList bs)
        Lst lt bss -> do
          let
            item :: FreshRenderer p (List Block)
            item bs = H.li_ <$> traverse renderBlock (fromList bs)
          el_ lt <$> traverse item (fromList bss)
        CodeBlock _ ss ->
          pure $ H.pre_ [ H.code_ [ H.text (joinWith "\n" $ fromList ss) ] ]
        LinkReference l url ->
          pure $ H.p_
            [ H.text (l <> ": ")
            , H.a [ P.name l, P.id_ l, P.href url ] [ H.text url ]
            ]
        Rule ->
          pure H.hr_

    -- | Make sure that the default value of a form field is valid, and if it is not, strip it out.
    ensureValidField :: FormField -> FormField
    ensureValidField field =
      V.runV
        (const $ stripDefaultValue field)
        id
        (validateFormField field)
      where
        stripDefaultValue :: FormField -> FormField
        stripDefaultValue field =
          case field of
             TextBox t _ -> TextBox t Nothing
             DropDown ls _ -> DropDown ls Nothing
             _ -> field

renderRadio :: forall p. String -> String -> String -> FreshRenderer p Boolean
renderRadio formName label value checked = do
  id <- fresh formName
  pure $ H.li_
    [ H.input
        [ P.checked checked
        , P.inputType P.InputRadio
        , P.id_ id
        , P.name label
        , P.value value
        , E.onValueChange (E.input_ (TextChanged PlainText label value))
        ]
    , H.label [ P.for id ] [ H.text value ]
    ]

renderCheckBox :: forall p. String -> String -> String -> FreshRenderer p Boolean
renderCheckBox formName label value checked = do
  id <- fresh formName
  pure $ H.li_
    [ H.input
        [ P.checked checked
        , P.inputType P.InputCheckbox
        , P.id_ id
        , P.name label
        , P.value value
        , E.onChecked (E.input (CheckBoxChanged label value))
        ]
    , H.label [ P.for id ] [ H.text value ]
    ]

renderDropDown
  :: forall p
   . String
  -> String
  -> List String
  -> Maybe String
  -> H.HTML p (SlamDownQuery Unit)
renderDropDown id label ls sel =
  H.select
    [ P.id_ id
    , P.name label
    , E.onValueChange (E.input (TextChanged PlainText label))
    ]
    (fromList $ maybe option option' sel <$> ls)
  where
    option :: String -> H.HTML p (SlamDownQuery Unit)
    option value = H.option [ P.value value ] [ H.text value ]

    option' :: String -> String -> H.HTML p (SlamDownQuery Unit)
    option' sel value = H.option [ P.selected (value == sel), P.value value ] [ H.text value ]

availableInputType :: BrowserFeatures -> TextBoxType -> IT.InputType
availableInputType features tbt =
  if features.inputTypeSupported inputType
     then inputType
     else IT.Text
  where
   inputType :: IT.InputType
   inputType = textBoxTypeToInputType tbt

textBoxTypeToInputType :: TextBoxType -> IT.InputType
textBoxTypeToInputType ty =
  case ty of
    PlainText -> IT.Text
    Date -> IT.Date
    Time -> IT.Time
    DateTime -> IT.DateTimeLocal
    Numeric -> IT.Number

inputTypeToHalogenInputType :: IT.InputType -> P.InputType
inputTypeToHalogenInputType it =
  case it of
    IT.Color -> P.InputColor
    IT.Date -> P.InputDate
    IT.DateTime -> P.InputDatetime
    IT.DateTimeLocal -> P.InputDatetimeLocal
    IT.Time -> P.InputTime
    IT.Month -> P.InputMonth
    IT.Week -> P.InputWeek
    IT.Email -> P.InputEmail
    IT.Url -> P.InputUrl
    IT.Number -> P.InputNumber
    IT.Search -> P.InputSearch
    IT.Range -> P.InputRange
    IT.Text -> P.InputText

renderFormElement
  :: forall p
   . SlamDownConfig
  -> SlamDownStateR
  -> String
  -> String
  -> FreshRenderer p FormField
renderFormElement config st id label field =
  case field of
    TextBox t Nothing ->
      pure <<< renderTextInput t $ lookupTextValue label Nothing
    TextBox t (Just (Literal value)) ->
      pure <<< renderTextInput t <<< lookupTextValue label $ Just value
    RadioButtons (Literal def) (Literal ls) -> do
      let
        sel = lookupTextValue label $ Just def
        renderRadio' val = renderRadio config.formName label val $ Just val == sel
      radios <- traverse renderRadio' <<< fromList $ Cons def ls
      pure $ H.ul [ P.class_ (H.className "slamdown-radios") ] radios
    CheckBoxes (Literal bs) (Literal ls) -> do
      let bools = lookupMultipleValues label bs ls
      checkBoxes <- zipWithA (renderCheckBox config.formName label) ls bools
      pure $ H.ul [ P.class_ (H.className "slamdown-checkboxes") ] $ fromList checkBoxes
    DropDown (Literal ls) Nothing ->
      pure $ renderDropDown id label (Cons "" ls) Nothing
    DropDown (Literal ls) (Just (Literal sel)) ->
      pure $ renderDropDown id label ls (lookupTextValue label (Just sel))
    _ -> pure $ H.text "Unsupported form element"

  where
    renderTextInput :: TextBoxType -> Maybe String -> H.HTML p (SlamDownQuery Unit)
    renderTextInput t value =
      H.input
        [ P.inputType compatibleInputType
        , P.id_ id
        , P.name label
        , E.onValueInput (E.input (TextChanged t label))
        , P.value (fromMaybe "" value)
        ]
      where
        compatibleInputType =
          inputTypeToHalogenInputType $ availableInputType config.browserFeatures t

    lookupTextValue :: String -> Maybe String -> Maybe String
    lookupTextValue key def =
      case M.lookup key st.formState of
        Just (SingleValue _ val) -> Just val
        _ -> def

    lookupMultipleValues :: String -> List Boolean -> List String -> List Boolean
    lookupMultipleValues key def ls =
      case M.lookup key st.formState of
        Just (MultipleValues val) -> (`S.member` val) <$> ls
        _ -> def

-- | Bundles up the SlamDown renderer and state machine into a Halogen component.
slamDownComponent :: forall g. SlamDownConfig -> H.Component SlamDownState SlamDownQuery g
slamDownComponent config = H.component (renderSlamDown config) evalSlamDownQuery

-- | This module defines a component for rendering SlamDown documents to HTML

module Text.Markdown.SlamDown.Html
  ( SlamDownQuery(..)
  , SlamDownFormState(..)
  , SlamDownStateR(..)
  , SlamDownState(..)
  , FormFieldValue(..)
  , emptySlamDownState
  , makeSlamDownState

  , SlamDownConfig(..)
  , defaultBrowserFeatures

  , slamDownComponent
  , renderSlamDown
  , evalSlamDownQuery
  )
  where

import Prelude

import Control.Monad.State (State(), evalState)
import Control.Monad.State.Class (get, modify)

import Data.BrowserFeatures
import Data.BrowserFeatures.InputType as IT
import Data.Foldable (foldMap, foldr)
import Data.List (List(..), mapMaybe, fromList, toList, zipWithA, zip, singleton, filter)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Monoid (mempty)
import Data.Set as S
import Data.String (joinWith)
import Data.StrMap as M
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Data.Validation as V

import Halogen (get, modify) as H
import Halogen.Component as H
import Halogen.HTML.Core as H
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P

import Test.StrongCheck as SC
import Test.StrongCheck.Gen as SC

import Text.Markdown.SlamDown
import Text.Markdown.SlamDown.Parser.Inline (validateFormField)

data FormFieldValue
  = SingleValue TextBoxType String
  | MultipleValues (S.Set String)

instance arbitraryFormFieldValue :: SC.Arbitrary FormFieldValue where
  arbitrary = do
    b <- SC.arbitrary
    if b
      then SingleValue <$> SC.arbitrary <*> SC.arbitrary
      else MultipleValues <<< S.fromList <<< toList <$> SC.arrayOf SC.arbitrary

instance showFormFieldValue :: Show FormFieldValue where
  show (SingleValue t s) = "(SingleValue " ++ show t ++ " " ++ show s ++ ")"
  show (MultipleValues ss) = "(MultipleValues " ++ show ss ++ ")"

type SlamDownFormDesc = M.StrMap FormField
type SlamDownFormState = M.StrMap FormFieldValue

type SlamDownStateR =
  { document :: SlamDown
  , formState :: SlamDownFormState
  }

-- | The state of a SlamDown form
newtype SlamDownState = SlamDownState SlamDownStateR

modifySlamDownState :: (SlamDownFormState -> SlamDownFormState) -> SlamDownState -> SlamDownState
modifySlamDownState f (SlamDownState rec) = SlamDownState (rec { formState = f rec.formState })

instance showSlamDownState :: Show SlamDownState where
  show (SlamDownState rec) = "(SlamDownState " ++ show rec.formState ++ ")"

instance arbitrarySlamDownState :: SC.Arbitrary SlamDownState where
  arbitrary = do
    document <- SC.arbitrary
    formState <- M.fromList <<< toList <$> SC.arrayOf SC.arbitrary
    pure $ SlamDownState
      { document : document
      , formState : formState
      }

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

-- | The initial empty state of the form, with an empty document.
emptySlamDownState :: SlamDownState
emptySlamDownState =
  SlamDownState
    { document : SlamDown mempty
    , formState : M.empty
    }

-- | The initial state of the form based on a document value. All fields use
-- | their default values.
makeSlamDownState :: SlamDown -> SlamDownState
makeSlamDownState doc =
  SlamDownState
    { document : doc
    , formState : formStateFromDocument doc
    }

formFieldGetDefaultValue :: FormField -> Maybe FormFieldValue
formFieldGetDefaultValue f =
  case f of
    TextBox tbt (Just (Literal value)) ->
      Just $ SingleValue tbt value
    CheckBoxes (Literal sels) (Literal vals) ->
      let chk (Tuple t v) = if t then Just v else Nothing in
      Just $ MultipleValues $ S.fromList $ chk `mapMaybe` zip sels vals
    RadioButtons (Literal value) _ ->
      Just $ SingleValue PlainText value
    DropDown _ (Just (Literal value)) ->
      Just $ SingleValue PlainText value
    _ -> Nothing

formStateFromDocument :: SlamDown -> SlamDownFormState
formStateFromDocument = M.fromList <<< everything (const mempty) phi
  where
    phi :: Inline -> List (Tuple String FormFieldValue)
    phi (FormField label _ field) =
      maybe mempty (singleton <<< Tuple label) $
        V.runV (const Nothing) Just (validateFormField field)
          >>= formFieldGetDefaultValue
    phi _ = mempty

formDescFromDocument :: SlamDown -> SlamDownFormDesc
formDescFromDocument = M.fromList <<< everything (const mempty) phi
  where
    phi :: Inline -> List (Tuple String FormField)
    phi (FormField label _ field) = singleton (Tuple label field)
    phi _ = mempty

changeDocument :: SlamDown -> SlamDownState -> SlamDownState
changeDocument doc (SlamDownState state) =
  SlamDownState
    { document : doc
    , formState : mergedFormState
    }

  where
    formDesc :: SlamDownFormDesc
    formDesc = formDescFromDocument doc

    -- | Returns the keys that are either not present in the new state, or have had their types changed.
    keysToPrune :: Array String
    keysToPrune =
      M.foldMap
        (\key oldVal ->
            case Tuple oldVal (M.lookup key formDesc) of
               Tuple (SingleValue tbt1 _) (Just (TextBox tbt2 _)) -> if tbt1 == tbt2 then [] else [key]
               Tuple _ Nothing -> [key]
               _ -> [])
        state.formState

    prunedFormState :: SlamDownFormState
    prunedFormState = foldr M.delete state.formState keysToPrune

    mergedFormState :: SlamDownFormState
    mergedFormState = prunedFormState `M.union` formStateFromDocument doc

data SlamDownQuery a
  = TextChanged TextBoxType String String a
  | CheckBoxChanged String String Boolean a
  | SetDocument SlamDown a
  | GetFormState (SlamDownFormState -> a)
  | PopulateForm SlamDownFormState a

instance functorSlamDownQuery :: Functor SlamDownQuery where
  map f e =
    case e of
      TextChanged tbt k v a -> TextChanged tbt k v $ f a
      CheckBoxChanged k v b a -> CheckBoxChanged k v b $ f a
      SetDocument doc a -> SetDocument doc $ f a
      GetFormState k -> GetFormState (f <<< k)
      PopulateForm s a -> PopulateForm s $ f a

instance arbitrarySlamDownQuery :: (SC.Arbitrary a) => SC.Arbitrary (SlamDownQuery a) where
  arbitrary = do
    b <- SC.arbitrary
    if b
      then TextChanged <$> SC.arbitrary <*> SC.arbitrary <*> SC.arbitrary <*> SC.arbitrary
      else CheckBoxChanged <$> SC.arbitrary <*> SC.arbitrary <*> SC.arbitrary <*> SC.arbitrary

evalSlamDownQuery :: forall g. H.Eval SlamDownQuery SlamDownState SlamDownQuery g
evalSlamDownQuery e =
  case e of
    TextChanged t key val next -> do
      H.modify <<< modifySlamDownState $
        M.insert key (SingleValue t val)
      pure next
    CheckBoxChanged key val checked next -> do
      let
        updateSet :: Maybe FormFieldValue -> FormFieldValue
        updateSet (Just (MultipleValues s))
          | checked = MultipleValues (S.insert val s)
          | otherwise = MultipleValues (S.delete val s)
        updateSet _
          | checked = MultipleValues (S.singleton val)
          | otherwise = MultipleValues S.empty
      H.modify <<< modifySlamDownState $
        M.alter (Just <<< updateSet) key
      pure next
    GetFormState k -> do
      SlamDownState state <- H.get
      pure $ k state.formState
    PopulateForm values next -> do
      H.modify \(SlamDownState { document }) ->
        let desc = formDescFromDocument document
            keysToPrune = filter (\newKey -> not (newKey `M.member` desc)) (toList (M.keys values))
            prunedValues = foldr M.delete values keysToPrune
        in SlamDownState { document, formState: prunedValues }
      pure next
    SetDocument doc next -> do
      H.modify $ changeDocument doc
      pure next

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

type Fresh = State Int

fresh :: String -> Fresh String
fresh formName = do
  n <- get :: Fresh Int
  modify (+ 1)
  pure (formName ++ "-" ++ show n)

runFresh :: forall a. Fresh a -> a
runFresh m = evalState m 1

type FreshRenderer p a = a -> Fresh (H.HTML p (SlamDownQuery Unit))

-- | Render a `SlamDown` document into an HTML form.
renderSlamDown :: SlamDownConfig -> H.Render SlamDownState SlamDownQuery
renderSlamDown config (SlamDownState state) =
  case state.document of
    SlamDown bs ->
      H.div_ <<< runFresh <<< traverse renderBlock $ fromList bs

  where
    h_ :: forall p a. Int -> Array (H.HTML p a) -> H.HTML p a
    h_ 1 = H.h1_
    h_ 2 = H.h2_
    h_ 3 = H.h3_
    h_ 4 = H.h4_
    h_ 5 = H.h5_
    h_ _ = H.h6_

    el_ :: forall p a. ListType -> Array (H.HTML p a) -> H.HTML p a
    el_ (Bullet _)  = H.ul_
    el_ (Ordered _) = H.ol_

    renderInline :: forall p. FreshRenderer p Inline
    renderInline i =
      case i of
        Str s -> pure $ H.text s
        Entity s -> pure $ H.text s
        Space -> pure $ H.text " "
        SoftBreak -> pure $ H.text "\n"
        LineBreak -> pure $ H.br_
        Emph is -> H.em_ <$> traverse renderInline (fromList is)
        Strong is -> H.strong_ <$> traverse renderInline (fromList is)
        Code _ c -> pure $ H.code_ [ H.text c ]
        Link body tgt -> do
          let
            href (InlineLink url) = url
            href (ReferenceLink tgt') = maybe "" ("#" ++) tgt'
          H.a [ P.href $ href tgt ] <$> traverse renderInline (fromList body)
        Image body url ->
          pure $ H.img
            [ P.src url
            , P.alt $ foldMap stripInline body
            ]
        FormField label req el -> do
          ident <- fresh config.formName
          el' <- renderFormElement config state ident label (ensureValidField el)
          let
            requiredLabel = if req then "*" else ""
            requiresId = case el of
              CheckBoxes _ _ -> false
              RadioButtons _ _ -> false
              _ -> true

          pure $ H.span
            [ P.class_ (H.className "slamdown-field") ]
            [ H.label
              (if requiresId then [ P.for ident ] else [])
              [ H.text (label ++ requiredLabel) ]
            , el'
            ]

    stripInline :: Inline -> String
    stripInline i =
      case i of
        Str s -> s
        Entity s -> s
        Space -> " "
        SoftBreak -> "\n"
        LineBreak -> "\n"
        Emph is -> foldMap stripInline is
        Strong is -> foldMap stripInline is
        Code _ c -> c
        Link body _ -> foldMap stripInline body
        _ -> ""

    renderBlock :: forall p. FreshRenderer p Block
    renderBlock b =
      case b of
        Paragraph is ->
          H.p_ <$> traverse renderInline (fromList is)
        Header lvl is ->
          h_ lvl <$> traverse renderInline (fromList is)
        Blockquote bs ->
          H.blockquote_ <$> traverse renderBlock (fromList bs)
        Lst lt bss -> do
          let
            item :: FreshRenderer p (List Block)
            item bs = H.li_ <$> traverse renderBlock (fromList bs)
          el_ lt <$> traverse item (fromList bss)
        CodeBlock _ ss ->
          pure $ H.pre_ [ H.code_ [ H.text (joinWith "\n" $ fromList ss) ] ]
        LinkReference l url ->
          pure $ H.p_
            [ H.text (l <> ": ")
            , H.a [ P.name l, P.id_ l, P.href url ] [ H.text url ]
            ]
        Rule ->
          pure H.hr_

    -- | Make sure that the default value of a form field is valid, and if it is not, strip it out.
    ensureValidField :: FormField -> FormField
    ensureValidField field =
      V.runV
        (const $ stripDefaultValue field)
        id
        (validateFormField field)
      where
        stripDefaultValue :: FormField -> FormField
        stripDefaultValue field =
          case field of
             TextBox t _ -> TextBox t Nothing
             DropDown ls _ -> DropDown ls Nothing
             _ -> field

renderRadio :: forall p. String -> String -> String -> FreshRenderer p Boolean
renderRadio formName label value checked = do
  id <- fresh formName
  pure $ H.li_
    [ H.input
        [ P.checked checked
        , P.inputType P.InputRadio
        , P.id_ id
        , P.name label
        , P.value value
        , E.onValueChange (E.input_ (TextChanged PlainText label value))
        ]
    , H.label [ P.for id ] [ H.text value ]
    ]

renderCheckBox :: forall p. String -> String -> String -> FreshRenderer p Boolean
renderCheckBox formName label value checked = do
  id <- fresh formName
  pure $ H.li_
    [ H.input
        [ P.checked checked
        , P.inputType P.InputRadio
        , P.id_ id
        , P.name label
        , P.value value
        , E.onChecked (E.input (CheckBoxChanged label value))
        ]
    , H.label [ P.for id ] [ H.text value ]
    ]

renderDropDown
  :: forall p
   . String
  -> String
  -> List String
  -> Maybe String
  -> H.HTML p (SlamDownQuery Unit)
renderDropDown id label ls sel =
  H.select
    [ P.id_ id
    , P.name label
    , E.onValueChange (E.input (TextChanged PlainText label))
    ]
    (fromList $ maybe option option' sel <$> ls)
  where
    option :: String -> H.HTML p (SlamDownQuery Unit)
    option value = H.option [ P.value value ] [ H.text value ]

    option' :: String -> String -> H.HTML p (SlamDownQuery Unit)
    option' sel value = H.option [ P.selected (value == sel), P.value value ] [ H.text value ]

availableInputType :: BrowserFeatures -> TextBoxType -> IT.InputType
availableInputType features tbt =
  if features.inputTypeSupported inputType
     then inputType
     else IT.Text
  where
   inputType :: IT.InputType
   inputType = textBoxTypeToInputType tbt

textBoxTypeToInputType :: TextBoxType -> IT.InputType
textBoxTypeToInputType ty =
  case ty of
    PlainText -> IT.Text
    Date -> IT.Date
    Time -> IT.Time
    DateTime -> IT.DateTimeLocal
    Numeric -> IT.Number

inputTypeToHalogenInputType :: IT.InputType -> P.InputType
inputTypeToHalogenInputType it =
  case it of
    IT.Color -> P.InputColor
    IT.Date -> P.InputDate
    IT.DateTime -> P.InputDatetime
    IT.DateTimeLocal -> P.InputDatetimeLocal
    IT.Time -> P.InputTime
    IT.Month -> P.InputMonth
    IT.Week -> P.InputWeek
    IT.Email -> P.InputEmail
    IT.Url -> P.InputUrl
    IT.Number -> P.InputNumber
    IT.Search -> P.InputSearch
    IT.Range -> P.InputRange
    IT.Text -> P.InputText

renderFormElement
  :: forall p
   . SlamDownConfig
  -> SlamDownStateR
  -> String
  -> String
  -> FreshRenderer p FormField
renderFormElement config st id label field =
  case field of
    TextBox t Nothing ->
      pure <<< renderTextInput t $ lookupTextValue label Nothing
    TextBox t (Just (Literal value)) ->
      pure <<< renderTextInput t <<< lookupTextValue label $ Just value
    RadioButtons (Literal def) (Literal ls) -> do
      let
        sel = lookupTextValue label $ Just def
        renderRadio' val = renderRadio config.formName label val $ Just val == sel
      radios <- traverse renderRadio' <<< fromList $ Cons def ls
      pure $ H.ul [ P.class_ (H.className "slamdown-radios") ] radios
    CheckBoxes (Literal bs) (Literal ls) -> do
      let bools = lookupMultipleValues label bs ls
      checkBoxes <- zipWithA (renderCheckBox config.formName label) ls bools
      pure $ H.ul [ P.class_ (H.className "slamdown-checkboxes") ] $ fromList checkBoxes
    DropDown (Literal ls) Nothing ->
      pure $ renderDropDown id label (Cons "" ls) Nothing
    DropDown (Literal ls) (Just (Literal sel)) ->
      pure $ renderDropDown id label ls (lookupTextValue label (Just sel))
    _ -> pure $ H.text "Unsupported form element"

  where
    renderTextInput :: TextBoxType -> Maybe String -> H.HTML p (SlamDownQuery Unit)
    renderTextInput t value =
      H.input
        [ P.inputType compatibleInputType
        , P.id_ id
        , P.name label
        , E.onValueInput (E.input (TextChanged t label))
        , P.value (fromMaybe "" value)
        ]
      where
        compatibleInputType =
          inputTypeToHalogenInputType $ availableInputType config.browserFeatures t

    lookupTextValue :: String -> Maybe String -> Maybe String
    lookupTextValue key def =
      case M.lookup key st.formState of
        Just (SingleValue _ val) -> Just val
        _ -> def

    lookupMultipleValues :: String -> List Boolean -> List String -> List Boolean
    lookupMultipleValues key def ls =
      case M.lookup key st.formState of
        Just (MultipleValues val) -> (`S.member` val) <$> ls
        _ -> def

-- | Bundles up the SlamDown renderer and state machine into a Halogen component.
slamDownComponent :: forall g. SlamDownConfig -> H.Component SlamDownState SlamDownQuery g
slamDownComponent config = H.component (renderSlamDown config) evalSlamDownQuery


Make all (<|>) go in <code> tags

Make all (<|>) go in <code> tags

module Control.Alt where

infixl 3 <|>

-- | The `Alt` type class identifies an associative operation on a type.
-- | It is similar to `Semigroup`, except that it applies to types of
-- | kind (* -> *), like Array or List, rather than concrete types like
-- | String or Number.
-- |
-- | `Alt` instances are required to satisfy the following law:
-- |
-- | - Associativity: `(x <|> y) <|> z == x <|> (y <|> z)`
-- |
-- | For example, the `Array` (`[]`) type is an instance of `Alt`, where
-- | `(<|>)` is defined to be concatenation.
class (Functor f) <= Alt f where
  (<|>) :: forall a. f a -> f a -> f a

module Control.Alt where

infixl 3 <|>

-- | The `Alt` type class identifies an associative operation on a type.
-- | It is similar to `Semigroup`, except that it applies to types of
-- | kind (* -> *), like Array or List, rather than concrete types like
-- | String or Number.
-- |
-- | `Alt` instances are required to satisfy the following law:
-- |
-- | - Associativity: `(x <|> y) <|> z == x <|> (y <|> z)`
-- |
-- | For example, the `Array` (`[]`) type is an instance of `Alt`, where
-- | (<|>) is defined to be concatenation.
class (Functor f) <= Alt f where
  (<|>) :: forall a. f a -> f a -> f a


fixed contains semanthic

fixed contains semanthic

-- | Module handles outer messages to `halogen` application
-- | Mostly consists of routing functions
module Driver.File (
  outside,
  getPath,
  searchPath,
  updateSort,
  updateQ,
  updateSalt,
  setSort,
  updatePath
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Random
import Control.Monad.Eff.Exception
import Control.Apply
import Control.Alt
import Data.Monoid.First
import Data.Foldable
import Data.Traversable
import Data.Maybe
import Data.Either
import Data.Tuple
import Data.Semiring.Free
import Data.Monoid
import Data.Array (filter, reverse, (!!), drop, length, take)
import Optic.Refractor.Lens
import Optic.Core

import qualified Utils as U
import qualified Data.String as Str
import qualified Data.String.Regex as Rgx
import qualified Data.Map as M
import qualified Control.Timer as Tm
import qualified Halogen as Hl
import qualified Routing as R
import qualified Routing.Match as R
import qualified Routing.Match.Class as R
import qualified Routing.Hash.Aff as Rh
import qualified Text.SlamSearch as S
import qualified Text.SlamSearch.Types as S
import qualified Text.SlamSearch.Printer as S
import qualified Data.Minimatch as MM
import qualified Control.Monad.Aff as Aff
import qualified Control.Monad.Aff.AVar as A
import qualified Model.File as M
import qualified Model.Item as Mi
import qualified Model.Sort as Ms
import qualified Model.Path as Mp
import qualified Model.Resource as Mr
import qualified Api.Fs as Api
import qualified Network.HTTP.Affjax as Af
import EffectTypes

-- | Entry, used in `halogen` app
outside :: forall e. Hl.Driver M.Input (FileComponentEff e) ->
           Eff (FileAppEff e) Unit
outside driver = handleRoute driver

-- | Routing schema
data Routes
  = Salted Ms.Sort S.SearchQuery String
  | SortAndQ Ms.Sort S.SearchQuery
  | Sort Ms.Sort
  | Index

getSalt :: String -> Either String String
getSalt input =
  if input /= "" then Right input
  else Left "incorrect salt"

-- | Route parsing match objects
routing :: R.Match Routes
routing = salted <|> bothRoute <|> oneRoute <|> index
  where salted = Salted <$> sort <*> query <*> salt
        bothRoute = SortAndQ <$> sort <*> query
        oneRoute = Sort <$> sort
        index = pure Index
        sort = R.eitherMatch (Ms.string2sort <$> R.param "sort")
        query = R.eitherMatch (S.mkQuery <$> R.param "q")
        salt = R.eitherMatch (getSalt <$> R.param "salt")

-- | Stream of routes
handleRoute :: forall e.
               Hl.Driver M.Input (FileComponentEff e) ->
               Eff (FileAppEff e) Unit
handleRoute driver =
  Aff.launchAff $ do
    var <- A.makeVar' initialAVar
    Tuple mbOld new <- R.matchesAff routing

    case new of
      Salted sort query salt -> do
        let newPage = maybe true id $ do
              old <- mbOld
              Tuple oldQuery oldSalt <- case old of
                Salted _ oldQuery oldSalt -> pure $ Tuple oldQuery oldSalt
                _ -> Nothing
              pure $ oldQuery /= query || oldSalt == salt
        Tuple c _ <- A.takeVar var
        Aff.cancel c $ error "cancel search"
        A.putVar var initialAVar
        liftEff (driver $ M.Loading false)
        if newPage then do
          let path = Mp.cleanPath $ fromMaybe "/" $ searchPath query
          liftEff $ do
            driver $ M.Loading true
            driver $ M.SetPath path
            driver $ M.SearchSet (Mp.hidePath path $ S.strQuery query)
            driver $ M.ItemsUpdate [] sort
            driver $ M.SetSearching (isSearchQuery query)
          listPath query 0 var path
          else do
          pure unit

      Index -> do
        Rh.setHash $ setSort Ms.Asc
      Sort sort -> do
        Rh.modifyHash $ updatePath "/"
      SortAndQ sort query -> do
        rnd <- show <$> (liftEff $ randomInt 1000000 2000000)
        Rh.modifyHash $ updateSalt rnd
    where initialAVar = Tuple mempty M.empty

          listPath :: S.SearchQuery -> Number ->
                      A.AVar (Tuple (Aff.Canceler _) (M.Map Number Number)) ->
                      String -> Aff.Aff _ Unit
          listPath query deep var path = do
            A.modifyVar
              (\t -> t # _2 %~
                     M.alter (maybe (Just 1) (\x -> Just (x + 1))) deep) var

            canceler <- Aff.forkAff do
              ei <- Aff.attempt $ Api.listing path
              case ei of
                Right unfiltered -> do
                  let items = _{root = path} <$> unfiltered
                      test = filterByQuery query
                      children = filter (\x -> x.resource == Mr.Directory ||
                                               x.resource == Mr.Database) items
                  traverse_ (liftEff <<< driver <<< M.ItemAdd) $
                    filter test items
                  if isSearchQuery query then
                    traverse_ ((listPath query (deep + 1) var) <<<
                               Mi.itemPath) items
                    else pure unit

                _ -> pure unit

              A.modifyVar
                (\t -> t # _2 %~ M.update (\v -> if v > 1 then Just (v - 1)
                                                 else Nothing) deep) var

              Tuple c r <- A.takeVar var
              if (foldl (+) 0 $ M.values r) == 0 then do
                liftEff do
                  driver $ M.Loading false
                A.putVar var initialAVar
                else
                A.putVar var (Tuple c r)
            A.modifyVar (\t -> t # _1 %~ (<> canceler)) var

isSearchQuery :: S.SearchQuery -> Boolean
isSearchQuery query =
  not $ S.check unit query (\_ -> isNotSearchTerm)
  where isNotSearchTerm :: S.Term -> Boolean
        isNotSearchTerm (S.Term {predicate: p, labels: ls, include: i}) =
          case ls of
            [S.Common "path"] -> true
            _ -> false

-- | check if string satisfies predicate from `purescript-search`
check :: S.Predicate -> String -> Boolean
check p prj =
  case p of
    S.Contains (S.Text str) -> match $ "*" <> escapeGlob str <> "*"
    S.Gt (S.Text str) -> compare str > 0
    S.Gte (S.Text str) -> compare str >= 0
    S.Lt (S.Text str) -> compare str < 0
    S.Lte (S.Text str) -> compare str <= 0
    S.Ne (S.Text str) -> compare str /= 0
    S.Eq (S.Text str) -> compare str == 0
    -- since we use _minimatch_ to check `Contains` predicate
    -- `Like` predicate works exactly like `Contains` if we
    -- replace `% -> *` and `_ -> ?`
    S.Like s -> match $ like2glob s
    S.Contains (S.Range str str') ->
      let c = flip check prj in
      (c (S.Gte (S.Text str)) && c (S.Lte (S.Text str'))) ||
      (c (S.Lte (S.Text str)) && c (S.Gte (S.Text str')))
    -- filters only when it means something. S.Eq S.Range - meaningless
    -- searching by tag in this context has no meaning too
    _ -> true
  where escapeGlob str = Str.replace "*" "\\*" $ Str.replace "?" "\\?" str
        percentRgx = Rgx.regex "%" flags
        underscoreRgx = Rgx.regex "_" flags
        flags = Rgx.noFlags{global = true}
        match a = MM.minimatch (Str.toLower a) (Str.toLower prj)
        compare = Str.localeCompare prj
        like2glob str =
          Rgx.replace percentRgx "*" $ Rgx.replace underscoreRgx "?" $ str

-- | Filtering function for items and predicates
filterByTerm :: Mi.Item -> S.Term -> Boolean
filterByTerm {name: name, resource: resource}
  (S.Term {predicate: predicate, labels: labels, include: include}) =
  let res = Mr.resource2str resource
      -- checking _include_ field in predicate
      mbNot :: Boolean -> Boolean
      mbNot = if include then id else not
      check' str = mbNot $ check predicate str
  in
  case labels of
    -- no labels -> check by both fields
    [] -> check' name || check' res
    -- we've already checked _path_ when had got it from backend
    [S.Common "path"] -> true
    -- check _name_
    [(S.Common "name")] -> check' name
    -- check _type_
    [(S.Common "type")] -> check' res
    -- check _type_
    [(S.Common "resource")] -> check' res
    _ -> false

-- | Filter by full search query
filterByQuery :: S.SearchQuery -> Mi.Item -> Boolean
filterByQuery query item =
  S.check item query filterByTerm

-- | Extract path predicate from search query
searchPath :: S.SearchQuery -> Maybe String
searchPath query =
  runFirst $ foldMap fn query
  where fn term = First case term of
          S.Term {include: true,
                  predicate: S.Contains (S.Text path),
                  labels: [S.Common "path"]} -> Just path
          _ -> Nothing

----------------------------------------------------------------------
--        Setters
----------------------------------------------------------------------
sortRgx :: Rgx.Regex
sortRgx = Rgx.regex "(sort=)([^/&]*)" Rgx.noFlags

qRgx :: Rgx.Regex
qRgx = Rgx.regex "(q=)([^/&]*)" Rgx.noFlags

saltRgx :: Rgx.Regex
saltRgx = Rgx.regex "(salt=)([^/&]*)" Rgx.noFlags

updateSort :: Ms.Sort -> String -> String
updateSort sort =
  Rgx.replace sortRgx res
  where res = "$1" <> Ms.sort2string sort

updateQ :: String -> String -> String
updateQ q =
  Rgx.replace qRgx res
  where res = "$1" <> U.encodeURIComponent q

updateSalt :: String -> String -> String
updateSalt salt old =
  if attempt /= old then attempt
  else updateSalt (salt <> salt) old
  where attempt = Rgx.replace saltRgx res old
        res = "$1" <> salt

setSort :: Ms.Sort -> String
setSort sort = "?sort=" <> Ms.sort2string sort <> "&q=&salt="

-- | extract path from full hash
getPath :: String -> String
getPath hash =
  fromMaybe "" do
    matches <- Rgx.match qRgx hash
    q <- U.decodeURIComponent <$> matches !! 2
    query <- either (const Nothing) Just (S.mkQuery q)
    searchPath query

-- | set _path_ value in path-labeled predicate in route
updatePath :: String -> String -> String
updatePath str oldHash =
  let pathOld = "path:" <> getPath oldHash
      pathNew = "path:" <> escape str
      replaced = Str.replace pathOld pathNew oldHash
  in if replaced == oldHash then
       updateQ pathNew oldHash
     else
       replaced
  where upped :: String -> String
        upped input =
          let arr = reverse $ filter (/= "") $ Str.split "/" $ U.trimQuotes input in
          ("/" <>) $
          flip (<>) "/" $
          Str.joinWith "/" $
          reverse $
          case take 1 arr of
            [".."] -> drop 2 arr
            _ -> arr
        escape :: String -> String
        escape str =
          Str.replace "//" "/" $
          (\x -> if Str.indexOf " " x /= -1 then
                   "\"" <> x <> "\""
                 else x) $
          upped str

-- | Module handles outer messages to `halogen` application
-- | Mostly consists of routing functions
module Driver.File (
  outside,
  getPath,
  searchPath,
  updateSort,
  updateQ,
  updateSalt,
  setSort,
  updatePath
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Random
import Control.Monad.Eff.Exception
import Control.Apply
import Control.Alt
import Data.Monoid.First
import Data.Foldable
import Data.Traversable
import Data.Maybe
import Data.Either
import Data.Tuple
import Data.Semiring.Free
import Data.Monoid
import Data.Array (filter, reverse, (!!), drop, length, take)
import Optic.Refractor.Lens
import Optic.Core

import qualified Utils as U
import qualified Data.String as Str
import qualified Data.String.Regex as Rgx
import qualified Data.Map as M
import qualified Control.Timer as Tm
import qualified Halogen as Hl
import qualified Routing as R
import qualified Routing.Match as R
import qualified Routing.Match.Class as R
import qualified Routing.Hash.Aff as Rh
import qualified Text.SlamSearch as S
import qualified Text.SlamSearch.Types as S
import qualified Text.SlamSearch.Printer as S
import qualified Data.Minimatch as MM
import qualified Control.Monad.Aff as Aff
import qualified Control.Monad.Aff.AVar as A
import qualified Model.File as M
import qualified Model.Item as Mi
import qualified Model.Sort as Ms
import qualified Model.Path as Mp
import qualified Model.Resource as Mr
import qualified Api.Fs as Api
import qualified Network.HTTP.Affjax as Af
import EffectTypes

-- | Entry, used in `halogen` app
outside :: forall e. Hl.Driver M.Input (FileComponentEff e) ->
           Eff (FileAppEff e) Unit
outside driver = handleRoute driver

-- | Routing schema
data Routes
  = Salted Ms.Sort S.SearchQuery String
  | SortAndQ Ms.Sort S.SearchQuery
  | Sort Ms.Sort
  | Index

getSalt :: String -> Either String String
getSalt input =
  if input /= "" then Right input
  else Left "incorrect salt"

-- | Route parsing match objects
routing :: R.Match Routes
routing = salted <|> bothRoute <|> oneRoute <|> index
  where salted = Salted <$> sort <*> query <*> salt
        bothRoute = SortAndQ <$> sort <*> query
        oneRoute = Sort <$> sort
        index = pure Index
        sort = R.eitherMatch (Ms.string2sort <$> R.param "sort")
        query = R.eitherMatch (S.mkQuery <$> R.param "q")
        salt = R.eitherMatch (getSalt <$> R.param "salt")

-- | Stream of routes
handleRoute :: forall e.
               Hl.Driver M.Input (FileComponentEff e) ->
               Eff (FileAppEff e) Unit
handleRoute driver =
  Aff.launchAff $ do
    var <- A.makeVar' initialAVar
    Tuple mbOld new <- R.matchesAff routing

    case new of
      Salted sort query salt -> do
        let newPage = maybe true id $ do
              old <- mbOld
              Tuple oldQuery oldSalt <- case old of
                Salted _ oldQuery oldSalt -> pure $ Tuple oldQuery oldSalt
                _ -> Nothing
              pure $ oldQuery /= query || oldSalt == salt
        Tuple c _ <- A.takeVar var
        Aff.cancel c $ error "cancel search"
        A.putVar var initialAVar
        liftEff (driver $ M.Loading false)
        if newPage then do
          let path = Mp.cleanPath $ fromMaybe "/" $ searchPath query
          liftEff $ do
            driver $ M.Loading true
            driver $ M.SetPath path
            driver $ M.SearchSet (Mp.hidePath path $ S.strQuery query)
            driver $ M.ItemsUpdate [] sort
            driver $ M.SetSearching (isSearchQuery query)
          listPath query 0 var path
          else do
          pure unit

      Index -> do
        Rh.setHash $ setSort Ms.Asc
      Sort sort -> do
        Rh.modifyHash $ updatePath "/"
      SortAndQ sort query -> do
        rnd <- show <$> (liftEff $ randomInt 1000000 2000000)
        Rh.modifyHash $ updateSalt rnd
    where initialAVar = Tuple mempty M.empty

          listPath :: S.SearchQuery -> Number ->
                      A.AVar (Tuple (Aff.Canceler _) (M.Map Number Number)) ->
                      String -> Aff.Aff _ Unit
          listPath query deep var path = do
            A.modifyVar
              (\t -> t # _2 %~
                     M.alter (maybe (Just 1) (\x -> Just (x + 1))) deep) var

            canceler <- Aff.forkAff do
              ei <- Aff.attempt $ Api.listing path
              case ei of
                Right unfiltered -> do
                  let items = _{root = path} <$> unfiltered
                      test = filterByQuery query
                      children = filter (\x -> x.resource == Mr.Directory ||
                                               x.resource == Mr.Database) items
                  traverse_ (liftEff <<< driver <<< M.ItemAdd) $
                    filter test items
                  if isSearchQuery query then
                    traverse_ ((listPath query (deep + 1) var) <<<
                               Mi.itemPath) items
                    else pure unit

                _ -> pure unit

              A.modifyVar
                (\t -> t # _2 %~ M.update (\v -> if v > 1 then Just (v - 1)
                                                 else Nothing) deep) var

              Tuple c r <- A.takeVar var
              if (foldl (+) 0 $ M.values r) == 0 then do
                liftEff do
                  driver $ M.Loading false
                A.putVar var initialAVar
                else
                A.putVar var (Tuple c r)
            A.modifyVar (\t -> t # _1 %~ (<> canceler)) var

isSearchQuery :: S.SearchQuery -> Boolean
isSearchQuery query =
  not $ S.check unit query (\_ -> isNotSearchTerm)
  where isNotSearchTerm :: S.Term -> Boolean
        isNotSearchTerm (S.Term {predicate: p, labels: ls, include: i}) =
          case ls of
            [S.Common "path"] -> true
            _ -> false

-- | check if string satisfies predicate from `purescript-search`
check :: S.Predicate -> String -> Boolean
check p prj =
  case p of
    S.Contains (S.Text str) -> match $ "*" <> str <> "*"
    S.Gt (S.Text str) -> compare str > 0
    S.Gte (S.Text str) -> compare str >= 0
    S.Lt (S.Text str) -> compare str < 0
    S.Lte (S.Text str) -> compare str <= 0
    S.Ne (S.Text str) -> compare str /= 0
    S.Eq (S.Text str) -> compare str == 0
    -- since we use _minimatch_ to check `Contains` predicate
    -- `Like` predicate works exactly like `Contains` if we
    -- replace `% -> *` and `_ -> ?`
    S.Like s -> match $ like2glob s
    S.Contains (S.Range str str') ->
      let c = flip check prj in
      (c (S.Gte (S.Text str)) && c (S.Lte (S.Text str'))) ||
      (c (S.Lte (S.Text str)) && c (S.Gte (S.Text str')))
    -- filters only when it means something. S.Eq S.Range - meaningless
    -- searching by tag in this context has no meaning too
    _ -> true
  where percentRgx = Rgx.regex "%" flags
        underscoreRgx = Rgx.regex "_" flags
        flags = Rgx.noFlags{global = true}
        match a = MM.minimatch (Str.toLower a) (Str.toLower prj)
        compare = Str.localeCompare prj
        like2glob str =
          Rgx.replace percentRgx "*" $ Rgx.replace underscoreRgx "?" $ str

-- | Filtering function for items and predicates
filterByTerm :: Mi.Item -> S.Term -> Boolean
filterByTerm {name: name, resource: resource}
  (S.Term {predicate: predicate, labels: labels, include: include}) =
  let res = Mr.resource2str resource
      -- checking _include_ field in predicate
      mbNot :: Boolean -> Boolean
      mbNot = if include then id else not
      check' str = mbNot $ check predicate str
  in
  case labels of
    -- no labels -> check by both fields
    [] -> check' name || check' res
    -- we've already checked _path_ when had got it from backend
    [S.Common "path"] -> true
    -- check _name_
    [(S.Common "name")] -> check' name
    -- check _type_
    [(S.Common "type")] -> check' res
    -- check _type_
    [(S.Common "resource")] -> check' res
    _ -> false

-- | Filter by full search query
filterByQuery :: S.SearchQuery -> Mi.Item -> Boolean
filterByQuery query item =
  S.check item query filterByTerm

-- | Extract path predicate from search query
searchPath :: S.SearchQuery -> Maybe String
searchPath query =
  runFirst $ foldMap fn query
  where fn term = First case term of
          S.Term {include: true,
                  predicate: S.Contains (S.Text path),
                  labels: [S.Common "path"]} -> Just path
          _ -> Nothing

----------------------------------------------------------------------
--        Setters
----------------------------------------------------------------------
sortRgx :: Rgx.Regex
sortRgx = Rgx.regex "(sort=)([^/&]*)" Rgx.noFlags

qRgx :: Rgx.Regex
qRgx = Rgx.regex "(q=)([^/&]*)" Rgx.noFlags

saltRgx :: Rgx.Regex
saltRgx = Rgx.regex "(salt=)([^/&]*)" Rgx.noFlags

updateSort :: Ms.Sort -> String -> String
updateSort sort =
  Rgx.replace sortRgx res
  where res = "$1" <> Ms.sort2string sort

updateQ :: String -> String -> String
updateQ q =
  Rgx.replace qRgx res
  where res = "$1" <> U.encodeURIComponent q

updateSalt :: String -> String -> String
updateSalt salt old =
  if attempt /= old then attempt
  else updateSalt (salt <> salt) old
  where attempt = Rgx.replace saltRgx res old
        res = "$1" <> salt

setSort :: Ms.Sort -> String
setSort sort = "?sort=" <> Ms.sort2string sort <> "&q=&salt="

-- | extract path from full hash
getPath :: String -> String
getPath hash =
  fromMaybe "" do
    matches <- Rgx.match qRgx hash
    q <- U.decodeURIComponent <$> matches !! 2
    query <- either (const Nothing) Just (S.mkQuery q)
    searchPath query

-- | set _path_ value in path-labeled predicate in route
updatePath :: String -> String -> String
updatePath str oldHash =
  let pathOld = "path:" <> getPath oldHash
      pathNew = "path:" <> escape str
      replaced = Str.replace pathOld pathNew oldHash
  in if replaced == oldHash then
       updateQ pathNew oldHash
     else
       replaced
  where upped :: String -> String
        upped input =
          let arr = reverse $ filter (/= "") $ Str.split "/" $ U.trimQuotes input in
          ("/" <>) $
          flip (<>) "/" $
          Str.joinWith "/" $
          reverse $
          case take 1 arr of
            [".."] -> drop 2 arr
            _ -> arr
        escape :: String -> String
        escape str =
          Str.replace "//" "/" $
          (\x -> if Str.indexOf " " x /= -1 then
                   "\"" <> x <> "\""
                 else x) $
          upped str


Code cleanup

Code cleanup

module Routing.Bob where

import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)
import Debug.Trace (trace)
import Data.Array as Array
import Data.Array (length)
import Data.Array.Unsafe (head, tail)
import Data.List as List
import Data.List (List(..), (:))
import Data.Foldable (foldl, foldr)
import Data.Generic (class Generic, DataConstructor, fromSpine, GenericSignature(..),
                     GenericSpine(..), toSignature, toSpine)
import Data.List (fromFoldable, List)
import Data.Maybe (fromMaybe, Maybe(..))
import Data.String (split, toLower)
import Prelude (bind, const, id, map, return, show, unit, Unit, (<<<), (<>), (==), (<$>), ($), (>))
import Text.Boomerang.Combinators (cons, maph, nil)
import Text.Boomerang.HStack (HCons)
import Text.Boomerang.Prim (Boomerang)
import Text.Boomerang.String (int, lit, StringBoomerang, string)
import Type.Proxy (Proxy)

join :: forall a b c. StringBoomerang b c -> StringBoomerang a b -> StringBoomerang a c
join b1 b2 = b1 <<< lit "/" <<< b2

infixl 6 join as </>

boolean :: forall r. StringBoomerang r (HCons Boolean r)
boolean =
  boolean' <<< (string "on" <> string "off")
 where
  boolean' :: forall s. StringBoomerang (HCons String s) (HCons Boolean s)
  boolean' =
    maph prs ser
   where
    prs "on" = true
    prs _    = false

    ser true  = Just "on"
    ser false = Just "off"

arrayFromList :: forall t a tok. Boomerang tok (HCons (List a) t) (HCons (Array a) t)
arrayFromList =
  maph arrayFromFoldable (Just <<< fromFoldable)
 where
  -- very ineficient - will be replaced with next purescript-array release
  arrayFromFoldable = foldr Data.Array.cons []

type GenericRecProp = {recLabel :: String, recValue :: Unit -> GenericSpine}

intersperce :: forall tok a t. (List (Boomerang tok (HCons (List a) t) (HCons a (HCons (List a) t)))) ->
                               (forall r. Boomerang tok r r) ->
                               Boomerang tok t (HCons (List a) t)
intersperce Nil _ = nil
intersperce (Cons b t) sep =
  cons <<< b <<< foldr step nil t
 where
  step e l = sep <<< cons <<< e <<< l

signatureToSpineBoomerang :: forall r. GenericSignature -> Maybe (StringBoomerang r (HCons GenericSpine r))
signatureToSpineBoomerang s@(SigProd n cs) = do
  { head : h, tail: t} <- Array.uncons cs
  if length t == 0
    then
      fromConstructor h false
    else do
      hs <- fromConstructor h true
      Array.foldM (\r c -> (_ <> r) <$> (fromConstructor c true)) hs t
 where
  fromConstructor constructor prependWithConstructorName = do
    let values = map (_ $ unit) constructor.sigValues
    valuesSpines <- Array.foldM (\r e -> (\b -> (lazy <<< b) : r) <$> signatureToSpineBoomerang e) Nil values
    let bmg = maph (SProd constructor.sigConstructor) ser <<< arrayFromList <<< intersperce valuesSpines (lit "/")
    if prependWithConstructorName
      then do
        let cn = serializeConstructorName constructor.sigConstructor
        if length values == 0
          then return (lit cn <<< bmg)
          else return (lit cn </> bmg)
      else return bmg
   where
    lazy :: forall z y. StringBoomerang (HCons y z) (HCons (Unit -> y) z)
    lazy = maph const (Just <<< (_ $ unit))

    ser (SProd c values) =
      if c == constructor.sigConstructor
        then Just values
        else Nothing
    ser _                = Nothing

    serializeConstructorName n =
      fromMaybe n (Array.last (split "." <<< toLower $ n))

signatureToSpineBoomerang SigBoolean =
  Just (maph SBoolean ser <<< boolean)
 where
  ser (SBoolean b) = Just b
  ser _            = Nothing
signatureToSpineBoomerang SigInt =
  Just (maph SInt ser <<< int)
 where
  ser (SInt b) = Just b
  ser _        = Nothing
signatureToSpineBoomerang _ = Nothing

bob :: forall a r. (Generic a) => Proxy a -> Maybe (StringBoomerang r (HCons a r))
bob p = do
  sb <- (signatureToSpineBoomerang (toSignature p))
  return (maph prs (\v -> Just (Just v)) <<< maph fromSpine (toSpine <$> _) <<< sb)
 where
  prs (Just s) = s
  prs Nothing = unsafeThrow ("Incorrect spine generated for signature: " <> show (toSignature p))

module Routing.Bob where

import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)
import Debug.Trace (trace)
import Data.Array as Array
import Data.Array (length)
import Data.Array.Unsafe (head, tail)
import Data.List as List
import Data.Foldable (foldl, foldr)
import Data.Generic (class Generic, DataConstructor, fromSpine, GenericSignature(..),
                     GenericSpine(..), toSignature, toSpine)
import Data.List (fromFoldable, List)
import Data.Maybe (fromMaybe, Maybe(..))
import Data.String (split, toLower)
import Prelude (bind, const, id, return, show, unit, Unit, (<<<), (<>), (==), (<$>), ($))
import Text.Boomerang.Combinators (cons, maph, nil)
import Text.Boomerang.HStack (HCons)
import Text.Boomerang.Prim (Boomerang)
import Text.Boomerang.String (int, lit, StringBoomerang, string)
import Type.Proxy (Proxy)

join :: forall a b c. StringBoomerang b c -> StringBoomerang a b -> StringBoomerang a c
join b1 b2 = b1 <<< lit "/" <<< b2

infixl 6 join as </>

boolean :: forall r. StringBoomerang r (HCons Boolean r)
boolean =
  boolean' <<< (string "on" <> string "off")
 where
  boolean' :: forall s. StringBoomerang (HCons String s) (HCons Boolean s)
  boolean' =
    maph prs ser
   where
    prs "on" = true
    prs _    = false

    ser true  = Just "on"
    ser false = Just "off"

arrayFromList :: forall t a tok. Boomerang tok (HCons (List a) t) (HCons (Array a) t)
arrayFromList =
  maph arrayFromFoldable (Just <<< fromFoldable)
 where
  -- very ineficient - will be replaced with next purescript-array release
  arrayFromFoldable = foldr Data.Array.cons []

type GenericRecProp = {recLabel :: String, recValue :: Unit -> GenericSpine}

signatureToSpineBoomerang :: forall r. GenericSignature -> Maybe (StringBoomerang r (HCons GenericSpine r))
signatureToSpineBoomerang SigBoolean =
  Just (maph SBoolean ser <<< boolean)
 where
  ser (SBoolean b) = Just b
  ser _            = Nothing
signatureToSpineBoomerang SigInt =
  Just (maph SInt ser <<< int)
 where
  ser (SInt b) = Just b
  ser _        = Nothing
signatureToSpineBoomerang s@(SigProd n cs) = do
  { head : h, tail: t} <- Array.uncons cs
  if length t == 0
    then
      fromConstructor h false
    else do
      hs <- fromConstructor h true
      Array.foldM constructorStep hs t
 where
  constructorStep r c = do
    s <- (fromConstructor c true)
    return (s <> r)

  fromConstructor :: forall s. DataConstructor -> Boolean -> Maybe (StringBoomerang s (HCons GenericSpine s))
  fromConstructor constructor prependWithConstructorName = do
    av <- appendValues
    let bmg = maph (SProd constructor.sigConstructor) ser <<< arrayFromList <<< av <<< nil
    return
      if prependWithConstructorName
        then lit (serializeConstructorName constructor.sigConstructor) <<< bmg
        else bmg
   where

    appendValues = case Array.uncons constructor.sigValues of
      Just { head: h, tail: t } -> do
        h' <- valueStep h
        t' <- Array.foldM (\r e -> do
          e' <- valueStep e
          return (e' </> r)) h' t
        return
          if prependWithConstructorName
            then (lit "/" <<< t')
            else t'
      Nothing -> Just id
     where
      valueStep e =
        (\t -> cons <<< lazy <<< t) <$> signatureToSpineBoomerang (e unit)

    ser (SProd c values) =
      if c == constructor.sigConstructor
        then Just values
        else Nothing
    ser _                = Nothing

    lazy :: forall a t. StringBoomerang (HCons a t) (HCons (Unit -> a) t)
    lazy = maph const (Just <<< (_ $ unit))

  serializeConstructorName n =
    fromMaybe n (Array.last (split "." <<< toLower $ n))
signatureToSpineBoomerang _ = Nothing

bob :: forall a r. (Generic a) => Proxy a -> Maybe (StringBoomerang r (HCons a r))
bob p = do
  sb <- (signatureToSpineBoomerang (toSignature p))
  return (maph prs (\v -> Just (Just v)) <<< maph fromSpine (toSpine <$> _) <<< sb)
 where
  prs (Just s) = s
  prs Nothing = unsafeThrow ("Incorrect spine generated for signature: " <> show (toSignature p))