radio|checkbox|dropdown ordered

radio|checkbox|dropdown ordered

{-
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.FormInput.LabeledRenderer.Component where

import SlamData.Prelude

import Data.Argonaut (JCursor(..))
import Data.Array as Arr
import Data.List as List
import Data.Map as Map
import Data.Set as Set
import Data.Time.Duration (Milliseconds(..))

import DOM.Classy.Event as DOM
import DOM.Event.Types (Event)

import Halogen as H
import Halogen.Component.Utils (sendAfter)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.CardType.FormInputType (FormInputType(..))
import SlamData.Workspace.Card.FormInput.LabeledRenderer.Model as M
import SlamData.Workspace.Card.Port (SetupLabeledFormInputPort)
import SlamData.Workspace.Card.Setups.Semantics as Sem

type State =
  { formInputType ∷ FormInputType
  , selected ∷ Set.Set Sem.Semantics
  , valueLabelMap ∷ Map.Map Sem.Semantics (Maybe String)
  , label ∷ Maybe String
  , cursor ∷ JCursor
  }

initialState ∷ State
initialState =
  { formInputType: Dropdown
  , selected: Set.empty
  , valueLabelMap: Map.empty
  , label: Nothing
  , cursor: JCursorTop
  }

optionList ∷ State → Array (Sem.Semantics × Maybe String)
optionList state =
  Arr.sortBy sortFn $ Map.toUnfoldable state.valueLabelMap
  where
  sortFn (a × al) (b × bl) =
    compare al bl
    ⊕ compare (Sem.printSemantics a) (Sem.printSemantics b)

data Query a
  = Setup SetupLabeledFormInputPort a
  | ItemSelected Sem.Semantics a
  | SetSelected (Set.Set Sem.Semantics) a
  | Load M.Model a
  | Save (M.Model → a)
  | PreventDefault Event a
  | RaiseUpdated a

data Message = Updated

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

comp ∷ H.Component HH.HTML Query Unit Message Slam
comp =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.form
    [ HE.onSubmit (HE.input PreventDefault) ]
    $ foldMap (\n → [ HH.h3_ [ HH.text n ] ]) state.label
    ⊕ case state.formInputType of
      Dropdown → renderDropdown state
      Checkbox → renderCheckbox state
      Radio → renderRadio state
      _ → [ ]

renderDropdown ∷ State → Array HTML
renderDropdown state =
  [ HH.select
      [ HP.classes [ B.formControl ]
      , HE.onSelectedIndexChange \ix →
          H.action ∘ ItemSelected ∘ fst <$> Arr.index options ix
      ]
      $ map renderOption options
  ]
  where
  options = optionList state

  renderOption ∷ Sem.Semantics × Maybe String → HTML
  renderOption (sem × label) =
    HH.option
      [ HP.selected $ Set.member sem state.selected ]
      [ HH.text $ fromMaybe (Sem.printSemantics sem) label ]

renderCheckbox ∷ State → Array HTML
renderCheckbox state =
  [ HH.form
     [ HE.onSubmit (HE.input PreventDefault) ]
     $ map renderOneInput options
  ]
  where
  options = optionList state

  renderOneInput ∷ Sem.Semantics × Maybe String → HTML
  renderOneInput (sem × label) =
    HH.div
      [ HP.classes [ B.checkbox ] ]
      [ HH.label_
        [ HH.input
            [ HP.type_ HP.InputCheckbox
            , HP.checked $ Set.member sem state.selected
            , HE.onValueChange (HE.input_ $ ItemSelected sem)
            ]
        , HH.text $ fromMaybe (Sem.printSemantics sem) label
        ]
      ]

renderRadio ∷ State → Array HTML
renderRadio state =
  [ HH.form
     [ HE.onSubmit (HE.input PreventDefault) ]
     $ map renderOneInput options
  ]
  where
  options = optionList state

  renderOneInput ∷ Sem.Semantics × Maybe String → HTML
  renderOneInput (sem × label) =
    HH.div
      [ HP.classes [ B.radio ]  ]
      [ HH.label_
          [ HH.input
            [ HP.type_ HP.InputRadio
            , HP.checked $ Set.member sem state.selected
            , HE.onValueChange (HE.input_ $ ItemSelected sem)
            ]
          , HH.text $ fromMaybe (Sem.printSemantics sem) label
          ]
      ]

eval ∷ Query ~> DSL
eval = case _ of
  Setup conf next → do
    st ← H.get
    let
      selectedFromConf
        -- If this is checkbox and selected values field is empty then
        -- there is no sense in setting default value (and it's actually empty :) )
        | Set.isEmpty conf.selectedValues ∧ conf.formInputType ≠ Checkbox =
            foldMap Set.singleton $ List.head $ Map.keys conf.valueLabelMap
        | otherwise =
            conf.selectedValues
      selected
        -- When cursor is changed we use default selection from input
        | st.cursor ≠ conf.cursor =
            selectedFromConf
        -- Same if user didn't interact with form input
        | Set.isEmpty st.selected =
            selectedFromConf
        -- If port is the same and user already selected something we preserve selected values
        | otherwise =
            st.selected

    H.modify _
      { formInputType = conf.formInputType
      , selected = selected
      , valueLabelMap = conf.valueLabelMap
      , label = if conf.name ≡ "" then Nothing else Just conf.name
      , cursor = conf.cursor
      }

    when (st.cursor ≠ conf.cursor)
      $ void $ sendAfter (Milliseconds 200.0) RaiseUpdated
    pure next
  ItemSelected sem next → do
    st ← H.get
    case st.formInputType of
      Checkbox → do
        let
          selected =
            if Set.member sem st.selected
              then Set.delete sem st.selected
              else Set.insert sem st.selected
        H.modify _{ selected = selected }
      _ → H.modify _{ selected = Set.singleton sem }
    H.raise Updated
    pure next
  SetSelected set next → do
    st ← H.get
    let
      selected = case st.formInputType of
        Checkbox → set
        _ → Set.fromFoldable $ List.head $ List.fromFoldable set
    when (selected ≠ st.selected)
      $ H.modify _{ selected = selected }
    pure next
  Load m next → do
    H.modify _
      { formInputType = m.formInputType
      , selected = m.selected
      , cursor = m.cursor
      }
    pure next
  Save continue → do
    st ← H.get
    pure
      $ continue
        { formInputType: st.formInputType
        , selected: st.selected
        , cursor: st.cursor
        }
  PreventDefault ev next → do
    H.liftEff $ DOM.preventDefault ev
    pure next
  RaiseUpdated next → do
    H.raise Updated
    pure next

{-
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.FormInput.LabeledRenderer.Component where

import SlamData.Prelude

import Data.Argonaut (JCursor(..))
import Data.Array as Arr
import Data.List as List
import Data.Map as Map
import Data.Set as Set
import Data.Time.Duration (Milliseconds(..))

import DOM.Classy.Event as DOM
import DOM.Event.Types (Event)

import Halogen as H
import Halogen.Component.Utils (sendAfter)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.CardType.FormInputType (FormInputType(..))
import SlamData.Workspace.Card.FormInput.LabeledRenderer.Model as M
import SlamData.Workspace.Card.Port (SetupLabeledFormInputPort)
import SlamData.Workspace.Card.Setups.Semantics as Sem

type State =
  { formInputType ∷ FormInputType
  , selected ∷ Set.Set Sem.Semantics
  , valueLabelMap ∷ Map.Map Sem.Semantics (Maybe String)
  , label ∷ Maybe String
  , cursor ∷ JCursor
  }

initialState ∷ State
initialState =
  { formInputType: Dropdown
  , selected: Set.empty
  , valueLabelMap: Map.empty
  , label: Nothing
  , cursor: JCursorTop
  }

data Query a
  = Setup SetupLabeledFormInputPort a
  | ItemSelected Sem.Semantics a
  | SetSelected (Set.Set Sem.Semantics) a
  | Load M.Model a
  | Save (M.Model → a)
  | PreventDefault Event a
  | RaiseUpdated a

data Message = Updated

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

comp ∷ H.Component HH.HTML Query Unit Message Slam
comp =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.form
    [ HE.onSubmit (HE.input PreventDefault) ]
    $ foldMap (\n → [ HH.h3_ [ HH.text n ] ]) state.label
    ⊕ case state.formInputType of
      Dropdown → renderDropdown state
      Checkbox → renderCheckbox state
      Radio → renderRadio state
      _ → [ ]

renderDropdown ∷ State → Array HTML
renderDropdown state =
  [ HH.select
      [ HP.classes [ B.formControl ]
      , HE.onSelectedIndexChange \ix →
          H.action ∘ ItemSelected ∘ fst <$> Arr.index optionList ix
      ]
      $ map renderOption optionList
  ]
  where
  optionList ∷ Array (Sem.Semantics × Maybe String)
  optionList = Map.toUnfoldable state.valueLabelMap

  renderOption ∷ Sem.Semantics × Maybe String → HTML
  renderOption (sem × label) =
    HH.option
      [ HP.selected $ Set.member sem state.selected ]
      [ HH.text $ fromMaybe (Sem.printSemantics sem) label ]

renderCheckbox ∷ State → Array HTML
renderCheckbox state =
  [ HH.form
     [ HE.onSubmit (HE.input PreventDefault) ]
     $ map renderOneInput optionList
  ]
  where
  optionList ∷ Array (Sem.Semantics × Maybe String)
  optionList = Map.toUnfoldable state.valueLabelMap

  renderOneInput ∷ Sem.Semantics × Maybe String → HTML
  renderOneInput (sem × label) =
    HH.div
      [ HP.classes [ B.checkbox ] ]
      [ HH.label_
        [ HH.input
            [ HP.type_ HP.InputCheckbox
            , HP.checked $ Set.member sem state.selected
            , HE.onValueChange (HE.input_ $ ItemSelected sem)
            ]
        , HH.text $ fromMaybe (Sem.printSemantics sem) label
        ]
      ]

renderRadio ∷ State → Array HTML
renderRadio state =
  [ HH.form
     [ HE.onSubmit (HE.input PreventDefault) ]
     $ map renderOneInput optionList
  ]
  where
  optionList ∷ Array (Sem.Semantics × Maybe String)
  optionList = Map.toUnfoldable state.valueLabelMap

  renderOneInput ∷ Sem.Semantics × Maybe String → HTML
  renderOneInput (sem × label) =
    HH.div
      [ HP.classes [ B.radio ]  ]
      [ HH.label_
          [ HH.input
            [ HP.type_ HP.InputRadio
            , HP.checked $ Set.member sem state.selected
            , HE.onValueChange (HE.input_ $ ItemSelected sem)
            ]
          , HH.text $ fromMaybe (Sem.printSemantics sem) label
          ]
      ]

eval ∷ Query ~> DSL
eval = case _ of
  Setup conf next → do
    st ← H.get
    let
      selectedFromConf
        -- If this is checkbox and selected values field is empty then
        -- there is no sense in setting default value (and it's actually empty :) )
        | Set.isEmpty conf.selectedValues ∧ conf.formInputType ≠ Checkbox =
            foldMap Set.singleton $ List.head $ Map.keys conf.valueLabelMap
        | otherwise =
            conf.selectedValues
      selected
        -- When cursor is changed we use default selection from input
        | st.cursor ≠ conf.cursor =
            selectedFromConf
        -- Same if user didn't interact with form input
        | Set.isEmpty st.selected =
            selectedFromConf
        -- If port is the same and user already selected something we preserve selected values
        | otherwise =
            st.selected

    H.modify _
      { formInputType = conf.formInputType
      , selected = selected
      , valueLabelMap = conf.valueLabelMap
      , label = if conf.name ≡ "" then Nothing else Just conf.name
      , cursor = conf.cursor
      }

    when (st.cursor ≠ conf.cursor)
      $ void $ sendAfter (Milliseconds 200.0) RaiseUpdated
    pure next
  ItemSelected sem next → do
    st ← H.get
    case st.formInputType of
      Checkbox → do
        let
          selected =
            if Set.member sem st.selected
              then Set.delete sem st.selected
              else Set.insert sem st.selected
        H.modify _{ selected = selected }
      _ → H.modify _{ selected = Set.singleton sem }
    H.raise Updated
    pure next
  SetSelected set next → do
    st ← H.get
    let
      selected = case st.formInputType of
        Checkbox → set
        _ → Set.fromFoldable $ List.head $ List.fromFoldable set
    when (selected ≠ st.selected)
      $ H.modify _{ selected = selected }
    pure next
  Load m next → do
    H.modify _
      { formInputType = m.formInputType
      , selected = m.selected
      , cursor = m.cursor
      }
    pure next
  Save continue → do
    st ← H.get
    pure
      $ continue
        { formInputType: st.formInputType
        , selected: st.selected
        , cursor: st.cursor
        }
  PreventDefault ev next → do
    H.liftEff $ DOM.preventDefault ev
    pure next
  RaiseUpdated next → do
    H.raise Updated
    pure next


Move TrackSink validation to Either String, check to see that no two event names overlap

module Genetics.Browser.Events.TrackSink where
       -- ( TrackSink
       -- , emptyTrackSink
       -- , mkTrackSink
       -- , appendTrackSinks
       -- , applyTrackSink
       -- , forkTrackSink
       -- ) where

import Prelude

import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff, Canceler, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Except (throwError)
import Control.Monad.Rec.Class (forever)
import Control.MonadPlus (guard)
import Data.Argonaut (Json)
import Data.Either (Either)
import Data.Foldable (any, foldMap, foldr, length)
import Data.List (List)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, unwrap)
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Tuple (Tuple(..))
import Genetics.Browser.Events.Types (Event)

type SinkConfig a = { eventName :: String
                    , eventFun :: Json -> a
                    }

newtype TrackSink a = TrackSink (StrMap (Json -> a))
-- TODO TrackSink i o = TrackSink (StrMap (i -> o))
-- and we get a profunctor which might be nice; could do the same on the SinkConfig

derive instance functorTrackSink :: Functor TrackSink
derive instance newtypeTrackSink :: Newtype (TrackSink a) _

instance semigroupTrackSink :: Semigroup (TrackSink a) where
  append (TrackSink s1) (TrackSink s2) = TrackSink (StrMap.union s1 s2)

instance monoidTrackSink :: Monoid (TrackSink a) where
  mempty = TrackSink StrMap.empty

makeTrackSink :: SinkConfig ~> TrackSink
makeTrackSink sc = TrackSink $ StrMap.singleton sc.eventName sc.eventFun

makeTrackSinks :: ∀ a.
                  Array (SinkConfig a)
               -> Either String (TrackSink a)
makeTrackSinks scs = do
  let count :: StrMap Int
      count = StrMap.fromFoldableWith (+) $ map (\c -> Tuple c.eventName 1) scs
      overlapping = StrMap.filter (_ > 1) count

  when (not StrMap.isEmpty overlapping)
    let error = foldMap (append "\n" <<< show) $ StrMap.keys overlapping
    in throwError $ "Overlapping tracksinks!\n" <> error

  pure $ foldMap makeTrackSink scs

runTrackSink :: ∀ a. TrackSink a -> Event -> Maybe a
runTrackSink (TrackSink sink) event = do
  f <- StrMap.lookup event.name sink
  pure $ f event.evData

forkTrackSink :: ∀ env eff.
                 TrackSink (env -> Eff eff Unit)
              -> env
              -> BusRW Event
              -> Aff (avar :: AVAR | eff) (Canceler (avar :: AVAR | eff))
forkTrackSink sink env bus = forkAff $ forever do
  event <- Bus.read bus
  let effect :: Maybe (env -> Eff (avar :: AVAR | eff) Unit)
      effect = (map unsafeCoerceEff) <$> runTrackSink sink event

  case effect of
    Nothing -> pure unit
    Just f  -> liftEff $ f env

module Genetics.Browser.Events.TrackSink where
       -- ( TrackSink
       -- , emptyTrackSink
       -- , mkTrackSink
       -- , appendTrackSinks
       -- , applyTrackSink
       -- , forkTrackSink
       -- ) where

import Prelude

import Control.Monad.Aff (Aff, Canceler, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Rec.Class (forever)
import Control.MonadPlus (guard)
import Data.Argonaut (Json)
import Data.Foldable (foldMap, length)
import Data.List (List)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, unwrap)
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Genetics.Browser.Events.Types (Event)

type SinkConfig a = { eventName :: String
                    , eventFun :: Json -> a
                    }

newtype TrackSink a = TrackSink (StrMap (Json -> a))

derive instance functorTrackSink :: Functor TrackSink
derive instance newtypeTrackSink :: Newtype (TrackSink a) _

instance semigroupTrackSink :: Semigroup (TrackSink a) where
  append (TrackSink s1) (TrackSink s2) = TrackSink (StrMap.union s1 s2)

instance monoidTrackSink :: Monoid (TrackSink a) where
  mempty = TrackSink StrMap.empty

makeTrackSink :: SinkConfig ~> TrackSink
makeTrackSink sc = TrackSink $ StrMap.singleton sc.eventName sc.eventFun

makeTrackSinks :: ∀ a.
                  Array (SinkConfig a)
               -> Maybe (TrackSink a)
makeTrackSinks scs = do
  let sinks = foldMap makeTrackSink scs
  -- basic check to make sure there are no overlapping configs,
  -- since they'd be removed by StrMap.union
  guard $ length scs == (StrMap.size $ unwrap sinks)
  pure $ sinks

runSink :: ∀ a. TrackSink a -> Event -> Maybe a
runSink (TrackSink sink) event = do
  f <- StrMap.lookup event.name sink
  pure $ f event.evData

forkTrackSink :: ∀ env eff.
                 TrackSink (env -> Eff eff Unit)
              -> env
              -> BusRW Event
              -> Aff (avar :: AVAR | eff) (Canceler (avar :: AVAR | eff))
forkTrackSink sink env bus = forkAff $ forever do
  event <- Bus.read bus
  let effect :: Maybe (env -> Eff (avar :: AVAR | eff) Unit)
      effect = (map unsafeCoerceEff) <$> runSink sink event

  case effect of
    Nothing -> pure unit
    Just f  -> liftEff $ f env


Fix test

Fix test

module Main where

import Debug.Trace

import Data.Maybe
import Data.Tuple
import Data.Either

import Control.Apply
import Control.Monad.Identity
import Control.Monad.State.Class

import Language.PureScript
import Language.PureScript.Declarations
import Language.PureScript.Options

import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

example =
  "module Test where\n\
  \\n\
  \  foo :: Number -> Number\n\
  \  foo 0 = 1\n\
  \  foo 1 = 0\n\
  \  foo n = n"

main = do
  trace "Lexing source file"
  case P.lex example of
    Left err -> trace err
    Right tokens -> do
      trace $ "Tokens: " ++ show tokens
      trace "Parsing module"
      case P.runTokenParser (P.parseModule <* P.eof) tokens of
        Left err -> trace err
        Right mod -> do
          trace $ "Module: " ++ show mod
          trace "Compiling module"
          case compile options [mod] of
            Left err -> print err
            Right tup3 -> do
              trace $ "Compiled: " ++ show tup3

options :: Options
options = Options { noPrelude: true
                  , noTco: false
                  , performRuntimeTypeChecks: false
                  , noMagicDo: false
                  , main: Nothing
                  , noOptimizations: false
                  , browserNamespace: Just "PS"
                  , modules: []
                  , codeGenModules: []
                  , verboseErrors: true
                  }

module Main where

import Debug.Trace

import Data.Maybe
import Data.Tuple
import Data.Either

import Control.Apply
import Control.Monad.Identity
import Control.Monad.State.Class

import Language.PureScript
import Language.PureScript.Declarations
import Language.PureScript.Options

import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

example =
  "module Test where\n\
  \\n\
  \  foo :: Number -> Number\n\
  \  foo 0 = 1\n\
  \  foo 1 = 0\n\
  \  foo n = n"

main = do
  trace "Lexing source file"
  case P.lex example of
    Left err -> trace err
    Right tokens -> do
      trace $ "Tokens: " ++ show tokens
      trace "Parsing module"
      case P.runTokenParser (P.parseModule <* P.eof) tokens of
        Left err -> trace err
        Right mod -> do
          trace $ "Module: " ++ show mod
          trace "Compiling module"
          case compile defaultOptions [mod] of
            Left err -> print err
            Right tup3 -> do
              trace $ "Compiled: " ++ show tup3


Fix warnings in example

Fix warnings in example

module Examples.FormParser where

import Prelude
import Text.Smolder.HTML.Attributes as A
import Control.IxMonad ((:>>=), (:*>))
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Either (Either(Right, Left))
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(Nothing, Just))
import Data.MediaType.Common (textHTML)
import Data.String (length)
import Hyper.Form (parseForm, required)
import Hyper.Node.Server (defaultOptionsWithLogging, runServer)
import Hyper.Request (getRequestData)
import Hyper.Response (closeHeaders, contentType, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusMethodNotAllowed, statusOK)
import Node.HTTP (HTTP)
import Text.Smolder.HTML (button, form, input, label, p)
import Text.Smolder.Markup (text, (!))
import Text.Smolder.Renderer.String (render)

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR | e) Unit
main =
  let
    -- A view function that renders the name form.
    renderNameForm err = do
      form ! A.method "post" $ do
        formattedError
        formElements
      where
        formElements = do
          label ! A.for "firstName" $ text "Your Name:"
          p (input ! A.name "firstName" ! A.id "firstName")
          p (button (text "Send"))

        formattedError =
          case err of
            Just s -> p ! A.style "color: red;" $ text s
            Nothing -> pure unit

    htmlWithStatus status x =
      writeStatus status
      :*> contentType textHTML
      :*> closeHeaders
      :*> respond (render x)

    handlePost =
      parseForm :>>=
      case _ of
        Left err -> do
          liftEff (log err)
          :*> htmlWithStatus
              statusBadRequest
              (p (text "Bad request, invalid form."))
        Right form ->
          case required "firstName" form of
            Right name
              | length name > 0 ->
                htmlWithStatus
                statusOK
                (p (text ("Hi " <> name <> "!")))
              | otherwise ->
                htmlWithStatus
                statusBadRequest
                (renderNameForm (Just "Name cannot be empty."))
            Left err ->
              htmlWithStatus
              statusBadRequest
              (renderNameForm (Just err))

    -- Our (rather primitive) router.
    router =
      _.method <$> getRequestData :>>=
      case _ of
        Left GET ->
          htmlWithStatus
          statusOK
          (renderNameForm Nothing)
        Left POST ->
          handlePost
        method ->
          htmlWithStatus
          statusMethodNotAllowed
          (text ("Method not supported: " <> show method))

  -- Let's run it.
  in runServer defaultOptionsWithLogging {} router

module Examples.FormParser where

import Prelude
import Text.Smolder.HTML.Attributes as A
import Control.IxMonad ((:>>=), (:*>))
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Either (Either(Right, Left))
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(Nothing, Just))
import Data.MediaType.Common (textHTML)
import Data.String (length)
import Hyper.Form (parseForm, required)
import Hyper.Middleware.Class (getConn)
import Hyper.Node.Server (defaultOptionsWithLogging, runServer)
import Hyper.Request (getRequestData)
import Hyper.Response (closeHeaders, contentType, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusMethodNotAllowed, statusOK)
import Node.HTTP (HTTP)
import Text.Smolder.HTML (button, form, input, label, p)
import Text.Smolder.Markup (text, (!))
import Text.Smolder.Renderer.String (render)

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR | e) Unit
main =
  let
    -- A view function that renders the name form.
    renderNameForm err = do
      form ! A.method "post" $ do
        formattedError
        formElements
      where
        formElements = do
          label ! A.for "firstName" $ text "Your Name:"
          p (input ! A.name "firstName" ! A.id "firstName")
          p (button (text "Send"))

        formattedError =
          case err of
            Just s -> p ! A.style "color: red;" $ text s
            Nothing -> pure unit

    htmlWithStatus status x =
      writeStatus status
      :*> contentType textHTML
      :*> closeHeaders
      :*> respond (render x)

    handlePost =
      parseForm :>>=
      case _ of
        Left err -> do
          liftEff (log err)
          :*> htmlWithStatus
              statusBadRequest
              (p (text "Bad request, invalid form."))
        Right form ->
          case required "firstName" form of
            Right name
              | length name > 0 ->
                htmlWithStatus
                statusOK
                (p (text ("Hi " <> name <> "!")))
              | otherwise ->
                htmlWithStatus
                statusBadRequest
                (renderNameForm (Just "Name cannot be empty."))
            Left err ->
              htmlWithStatus
              statusBadRequest
              (renderNameForm (Just err))

    -- Our (rather primitive) router.
    router =
      getRequestData :>>= \{ method } →
      case method of
        Left GET ->
          htmlWithStatus
          statusOK
          (renderNameForm Nothing)
        Left POST ->
          handlePost
        method ->
          htmlWithStatus
          statusMethodNotAllowed
          (text ("Method not supported: " <> show method))

  -- Let's run it.
  in runServer defaultOptionsWithLogging {} router


Add polling and outputDirectory purs ide server options

Fix #9

module IdePurescript.PscIdeServer
  ( startServer
  , startServer'
  , stopServer
  , ServerStartResult(..)
  , ServerEff
  , Port
  , QuitCallback
  , ErrorLevel(..)
  , Notify(..)
  ) where

import Prelude

import Control.Monad.Aff (Aff, attempt, liftEff')
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Array (length, head)
import Data.Either (either)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.String (Pattern(Pattern), split, toLower)
import Data.Traversable (traverse, traverse_)
import Global (readInt)
import IdePurescript.Exec (getPathVar, findBins)
import IdePurescript.PscIde (cwd) as PscIde
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, stderr, stdout)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.Path (normalize)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, platform)
import Node.Stream (onDataString)
import PscIde (NET)
import PscIde.Server (Executable(Executable), LogLevel, defaultServerArgs, getSavedPort, pickFreshPort, savePort)
import PscIde.Server as S

type Port = Int

data ServerStartResult =
    CorrectPath Port
  | WrongPath Port String
  | Started Port ChildProcess
  | Closed
  | StartError String

type ServerEff eff = (cp :: CHILD_PROCESS, process :: PROCESS, net :: NET, avar :: AVAR, fs :: FS, exception :: EXCEPTION, random :: RANDOM, buffer :: BUFFER | eff)

type QuitCallback eff = (Aff (net :: NET, cp :: CHILD_PROCESS, fs :: FS | eff) Unit)

data ErrorLevel = Success | Info | Warning | Error
type Notify eff = ErrorLevel -> String -> Eff eff Unit

data Version = Version Int Int Int

parseVersion :: String -> Maybe Version
parseVersion s =
  case traverse fromNumber $ readInt 10 <$> split (Pattern ".") s of
    Just [a, b, c] -> Just $ Version a b c
    _ -> Nothing

instance eqVersion :: Eq Version where
  eq (Version a b c) (Version a' b' c') = a == a' && b == b' && c == c'

instance ordVersion :: Ord Version where
  compare (Version a b c) (Version a' b' c') = compare [a,b,c] [a',b',c']

instance showVersion :: Show Version where
  show (Version a b c) = show a <> "." <> show b <> "." <> show c

type ServerSettings =
  { exe :: String
  , combinedExe :: Boolean
  , glob :: Array String
  , logLevel :: Maybe LogLevel
  , editorMode :: Boolean
  , polling :: Boolean
  , outputDirectory :: Maybe String
  }

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
-- | Will notify as to what is happening, choose to supply globs appropriately
startServer' :: forall eff eff'.
  ServerSettings
  -> String
  -> Boolean
  -> Notify (ServerEff eff)
  -> Notify (ServerEff eff)
  -> Aff (ServerEff eff) { quit :: QuitCallback eff', port :: Maybe Int }
startServer' settings@({ exe: server, glob }) path addNpmBin cb logCb = do
  pathVar <- liftEff $ getPathVar addNpmBin path
  serverBins <- findBins pathVar server
  case head serverBins of
    Nothing -> do
      liftEff $ cb Info $ "Couldn't find IDE server, check PATH. Looked for: "
        <> server <> " in PATH: " <> either id id pathVar
      pure { quit: pure unit, port: Nothing }
    Just (Executable bin version) -> do
      liftEff $ logCb Info $ "Resolved IDE server paths (npm-bin: " <> show addNpmBin <> ") from PATH of " <> either id id pathVar <> " (1st is used):"
      traverse_ (\(Executable x vv) ->
        liftEff $ logCb Info $ x <> ": " <> fromMaybe "ERROR" vv) serverBins
      liftEff $ when (length serverBins > 1) $ cb Warning $ "Found multiple IDE server executables; using " <> bin
      res <- startServer logCb (settings { exe = bin }) path
      let noRes = { quit: pure unit, port: Nothing }
      liftEff $ case res of
        CorrectPath usedPort -> { quit: pure unit, port: Just usedPort } <$ cb Info ("Found existing IDE server with correct path on port " <> show usedPort)
        WrongPath usedPort wrongPath -> do
          cb Error $ "Found existing IDE server on port '" <> show usedPort <> "' with wrong path: '" <> wrongPath
            <> "'. Correct, kill or configure a different port, and restart."
          pure noRes
        Started usedPort cp -> do
          cb Success $ "Started IDE server (port " <> show usedPort <> ")"
          wireOutput cp logCb
          pure
            { quit: stopServer usedPort path cp
            , port: Just usedPort
            }
        Closed -> noRes <$ cb Info "IDE server exited with success code"
        StartError err -> noRes <$ (cb Error $ "Could not start IDE server process. Check the configured port number is valid.\n" <> err)
  where
    wireOutput :: ChildProcess -> Notify (ServerEff eff) -> Eff (ServerEff eff) Unit
    wireOutput cp log = do
      onDataString (stderr cp) UTF8 (log Warning)
      onDataString (stdout cp) UTF8 (log Info)

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
startServer :: forall eff. Notify (ServerEff eff) -> ServerSettings -> String -> Aff (ServerEff eff) ServerStartResult
startServer logCb { exe, combinedExe, glob, logLevel, editorMode, polling, outputDirectory } rootPath = do
  port <- liftEff $ getSavedPort rootPath
  case port of
    Just p -> do
      workingDir <- attempt $ PscIde.cwd p
      liftEff $ logCb Info $ "Found existing port from file: " <> show p <> (either (const "") (", cwd: " <> _) workingDir)
      either (const launchServer) (gotPath p) workingDir
    Nothing -> launchServer

  where
  launchServer = do
    newPort <- liftEff pickFreshPort
    liftEff $ do
      logCb Info $ "Starting IDE server on port " <> show newPort <> " with cwd " <> rootPath
      savePort newPort rootPath
    r newPort <$> S.startServer (defaultServerArgs
      { exe = exe
      , combinedExe = combinedExe
      , cwd = Just rootPath
      , port = Just newPort
      , source = glob
      , logLevel = logLevel
      , editorMode = editorMode
      , polling = polling
      , outputDirectory = outputDirectory
      })
    where
      r newPort (S.Started cp) = Started newPort cp
      r _ (S.Closed) = Closed
      r _ (S.StartError s) = StartError s

  gotPath port workingDir =
    liftEff $ if normalizePath workingDir == normalizePath rootPath then
        do
          logCb Info $ "Found IDE server on port " <> show port <> " with correct path: " <> workingDir
          pure $ CorrectPath port
      else
        do
          logCb Info $ "Found IDE server on port " <> show port <> " with wrong path: " <> normalizePath workingDir <> " instead of " <> normalizePath rootPath
          pure $ WrongPath port workingDir

  normalizePath = (if platform == Just Win32 then toLower else id) <<< normalize

-- | Stop a psc-ide server. Currently implemented by asking it nicely, but potentially by killing it if that doesn't work...
stopServer :: forall eff. Int -> String -> ChildProcess -> Aff (cp :: CHILD_PROCESS, net :: NET, fs :: FS | eff) Unit
stopServer port rootPath cp = do
  oldPort <- liftEff $ S.getSavedPort rootPath
  _ <- liftEff' $ when (oldPort == Just port) $ S.deleteSavedPort rootPath
  S.stopServer port

module IdePurescript.PscIdeServer
  ( startServer
  , startServer'
  , stopServer
  , ServerStartResult(..)
  , ServerEff
  , Port
  , QuitCallback
  , ErrorLevel(..)
  , Notify(..)
  ) where

import Prelude

import Control.Monad.Aff (Aff, attempt, liftEff')
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Array (length, head)
import Data.Either (either)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.String (Pattern(Pattern), split, toLower)
import Data.Traversable (traverse, traverse_)
import Global (readInt)
import IdePurescript.Exec (getPathVar, findBins)
import IdePurescript.PscIde (cwd) as PscIde
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, stderr, stdout)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.Path (normalize)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, platform)
import Node.Stream (onDataString)
import PscIde (NET)
import PscIde.Server (Executable(Executable), LogLevel, defaultServerArgs, getSavedPort, pickFreshPort, savePort)
import PscIde.Server as S

type Port = Int

data ServerStartResult =
    CorrectPath Port
  | WrongPath Port String
  | Started Port ChildProcess
  | Closed
  | StartError String

type ServerEff eff = (cp :: CHILD_PROCESS, process :: PROCESS, net :: NET, avar :: AVAR, fs :: FS, exception :: EXCEPTION, random :: RANDOM, buffer :: BUFFER | eff)

type QuitCallback eff = (Aff (net :: NET, cp :: CHILD_PROCESS, fs :: FS | eff) Unit)

data ErrorLevel = Success | Info | Warning | Error
type Notify eff = ErrorLevel -> String -> Eff eff Unit

data Version = Version Int Int Int

parseVersion :: String -> Maybe Version
parseVersion s =
  case traverse fromNumber $ readInt 10 <$> split (Pattern ".") s of
    Just [a, b, c] -> Just $ Version a b c
    _ -> Nothing

instance eqVersion :: Eq Version where
  eq (Version a b c) (Version a' b' c') = a == a' && b == b' && c == c'

instance ordVersion :: Ord Version where
  compare (Version a b c) (Version a' b' c') = compare [a,b,c] [a',b',c']

instance showVersion :: Show Version where
  show (Version a b c) = show a <> "." <> show b <> "." <> show c

type ServerSettings =
  { exe :: String
  , combinedExe :: Boolean
  , glob :: Array String
  , logLevel :: Maybe LogLevel
  , editorMode :: Boolean
  }

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
-- | Will notify as to what is happening, choose to supply globs appropriately
startServer' :: forall eff eff'.
  ServerSettings
  -> String
  -> Boolean
  -> Notify (ServerEff eff)
  -> Notify (ServerEff eff)
  -> Aff (ServerEff eff) { quit :: QuitCallback eff', port :: Maybe Int }
startServer' settings@({ exe: server, glob }) path addNpmBin cb logCb = do
  pathVar <- liftEff $ getPathVar addNpmBin path
  serverBins <- findBins pathVar server
  case head serverBins of
    Nothing -> do
      liftEff $ cb Info $ "Couldn't find IDE server, check PATH. Looked for: "
        <> server <> " in PATH: " <> either id id pathVar
      pure { quit: pure unit, port: Nothing }
    Just (Executable bin version) -> do
      liftEff $ logCb Info $ "Resolved IDE server paths (npm-bin: " <> show addNpmBin <> ") from PATH of " <> either id id pathVar <> " (1st is used):"
      traverse_ (\(Executable x vv) ->
        liftEff $ logCb Info $ x <> ": " <> fromMaybe "ERROR" vv) serverBins
      liftEff $ when (length serverBins > 1) $ cb Warning $ "Found multiple IDE server executables; using " <> bin
      res <- startServer logCb (settings { exe = bin }) path
      let noRes = { quit: pure unit, port: Nothing }
      liftEff $ case res of
        CorrectPath usedPort -> { quit: pure unit, port: Just usedPort } <$ cb Info ("Found existing IDE server with correct path on port " <> show usedPort)
        WrongPath usedPort wrongPath -> do
          cb Error $ "Found existing IDE server on port '" <> show usedPort <> "' with wrong path: '" <> wrongPath
            <> "'. Correct, kill or configure a different port, and restart."
          pure noRes
        Started usedPort cp -> do
          cb Success $ "Started IDE server (port " <> show usedPort <> ")"
          wireOutput cp logCb
          pure
            { quit: stopServer usedPort path cp
            , port: Just usedPort
            }
        Closed -> noRes <$ cb Info "IDE server exited with success code"
        StartError err -> noRes <$ (cb Error $ "Could not start IDE server process. Check the configured port number is valid.\n" <> err)
  where
    wireOutput :: ChildProcess -> Notify (ServerEff eff) -> Eff (ServerEff eff) Unit
    wireOutput cp log = do
      onDataString (stderr cp) UTF8 (log Warning)
      onDataString (stdout cp) UTF8 (log Info)

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
startServer :: forall eff. Notify (ServerEff eff) -> ServerSettings -> String -> Aff (ServerEff eff) ServerStartResult
startServer logCb { exe, combinedExe, glob, logLevel, editorMode } rootPath = do
  port <- liftEff $ getSavedPort rootPath
  case port of
    Just p -> do
      workingDir <- attempt $ PscIde.cwd p
      liftEff $ logCb Info $ "Found existing port from file: " <> show p <> (either (const "") (", cwd: " <> _) workingDir)
      either (const launchServer) (gotPath p) workingDir
    Nothing -> launchServer

  where
  launchServer = do
    newPort <- liftEff pickFreshPort
    liftEff $ do
      logCb Info $ "Starting IDE server on port " <> show newPort <> " with cwd " <> rootPath
      savePort newPort rootPath
    r newPort <$> S.startServer (defaultServerArgs { exe = exe, combinedExe = combinedExe, cwd = Just rootPath, port = Just newPort, source = glob , logLevel = logLevel, editorMode = editorMode })
    where
      r newPort (S.Started cp) = Started newPort cp
      r _ (S.Closed) = Closed
      r _ (S.StartError s) = StartError s

  gotPath port workingDir =
    liftEff $ if normalizePath workingDir == normalizePath rootPath then
        do
          logCb Info $ "Found IDE server on port " <> show port <> " with correct path: " <> workingDir
          pure $ CorrectPath port
      else
        do
          logCb Info $ "Found IDE server on port " <> show port <> " with wrong path: " <> normalizePath workingDir <> " instead of " <> normalizePath rootPath
          pure $ WrongPath port workingDir

  normalizePath = (if platform == Just Win32 then toLower else id) <<< normalize

-- | Stop a psc-ide server. Currently implemented by asking it nicely, but potentially by killing it if that doesn't work...
stopServer :: forall eff. Int -> String -> ChildProcess -> Aff (cp :: CHILD_PROCESS, net :: NET, fs :: FS | eff) Unit
stopServer port rootPath cp = do
  oldPort <- liftEff $ S.getSavedPort rootPath
  _ <- liftEff' $ when (oldPort == Just port) $ S.deleteSavedPort rootPath
  S.stopServer port


Fix type error spotted by latest compiler

-- | This module defines a type class for reading foreign values.

module Data.Foreign.Class
  ( IsForeign
  , read
  , readJSON
  , readWith
  , readProp
  ) where

import Prelude

import Data.Array (range, zipWith, length)
import Data.Either (Either(..), either)
import Data.Foreign
import Data.Foreign.Index
import Data.Foreign.Null
import Data.Foreign.NullOrUndefined
import Data.Foreign.Undefined
import Data.Int ()
import Data.Traversable (sequence)

-- | A type class instance for this class can be written for a type if it
-- | is possible to attempt to _safely_ coerce a `Foreign` value to that
-- | type.
-- |
-- | Instances are provided for standard data structures, and the `F` monad
-- | can be used to construct instances for new data structures.
class IsForeign a where
  read :: Foreign -> F a

instance foreignIsForeign :: IsForeign Foreign where
  read f = return f

instance stringIsForeign :: IsForeign String where
  read = readString

instance charIsForeign :: IsForeign Char where
  read = readChar

instance booleanIsForeign :: IsForeign Boolean where
  read = readBoolean

instance numberIsForeign :: IsForeign Number where
  read = readNumber

instance intIsForeign :: IsForeign Int where
  read = readInt

instance arrayIsForeign :: (IsForeign a) => IsForeign (Array a) where
  read value = readArray value >>= readElements
    where
    readElements :: forall a. (IsForeign a) => Array Foreign -> F (Array a)
    readElements arr = sequence (zipWith readElement (range zero (length arr)) arr)

    readElement :: forall a. (IsForeign a) => Int -> Foreign -> F a
    readElement i value = readWith (ErrorAtIndex i) value

instance nullIsForeign :: (IsForeign a) => IsForeign (Null a) where
  read = readNull read

instance undefinedIsForeign :: (IsForeign a) => IsForeign (Undefined a) where
  read = readUndefined read

instance nullOrUndefinedIsForeign :: (IsForeign a) => IsForeign (NullOrUndefined a) where
  read = readNullOrUndefined read

-- | Attempt to read a data structure from a JSON string
readJSON :: forall a. (IsForeign a) => String -> F a
readJSON json = parseJSON json >>= read

-- | Attempt to read a foreign value, handling errors using the specified function
readWith :: forall a e. (IsForeign a) => (ForeignError -> e) -> Foreign -> Either e a
readWith f value = either (Left <<< f) Right (read value)

-- | Attempt to read a property of a foreign value at the specified index
readProp :: forall a i. (IsForeign a, Index i) => i -> Foreign -> F a
readProp prop value = value ! prop >>= readWith (errorAt prop)

-- | This module defines a type class for reading foreign values.

module Data.Foreign.Class
  ( IsForeign
  , read
  , readJSON
  , readWith
  , readProp
  ) where

import Prelude

import Data.Array (range, zipWith, length)
import Data.Either (Either(..), either)
import Data.Foreign
import Data.Foreign.Index
import Data.Foreign.Null
import Data.Foreign.NullOrUndefined
import Data.Foreign.Undefined
import Data.Int ()
import Data.Traversable (sequence)

-- | A type class instance for this class can be written for a type if it
-- | is possible to attempt to _safely_ coerce a `Foreign` value to that
-- | type.
-- |
-- | Instances are provided for standard data structures, and the `F` monad
-- | can be used to construct instances for new data structures.
class IsForeign a where
  read :: Foreign -> F a

instance foreignIsForeign :: IsForeign Foreign where
  read f = return f

instance stringIsForeign :: IsForeign String where
  read = readString

instance charIsForeign :: IsForeign Char where
  read = readChar

instance booleanIsForeign :: IsForeign Boolean where
  read = readBoolean

instance numberIsForeign :: IsForeign Number where
  read = readNumber

instance intIsForeign :: IsForeign Int where
  read = readInt

instance arrayIsForeign :: (IsForeign a) => IsForeign (Array a) where
  read value = readArray value >>= readElements
    where
    readElements :: forall a. (IsForeign a) => Array Foreign -> F (Array a)
    readElements arr = sequence (zipWith readElement (range zero (length arr)) arr)

    readElement :: forall a. (IsForeign a) => Int -> Foreign -> F (Array a)
    readElement i value = readWith (ErrorAtIndex i) value

instance nullIsForeign :: (IsForeign a) => IsForeign (Null a) where
  read = readNull read

instance undefinedIsForeign :: (IsForeign a) => IsForeign (Undefined a) where
  read = readUndefined read

instance nullOrUndefinedIsForeign :: (IsForeign a) => IsForeign (NullOrUndefined a) where
  read = readNullOrUndefined read

-- | Attempt to read a data structure from a JSON string
readJSON :: forall a. (IsForeign a) => String -> F a
readJSON json = parseJSON json >>= read

-- | Attempt to read a foreign value, handling errors using the specified function
readWith :: forall a e. (IsForeign a) => (ForeignError -> e) -> Foreign -> Either e a
readWith f value = either (Left <<< f) Right (read value)

-- | Attempt to read a property of a foreign value at the specified index
readProp :: forall a i. (IsForeign a, Index i) => i -> Foreign -> F a
readProp prop value = value ! prop >>= readWith (errorAt prop)


Add documentation comments

Add documentation comments

module Database.PostgreSQL
( POSTGRESQL
, PoolConfiguration
, Pool
, Connection
, Query(..)
, class ToSQLRow
, class FromSQLRow
, class ToSQLValue
, class FromSQLValue
, toSQLRow
, fromSQLRow
, toSQLValue
, fromSQLValue
, newPool
, withConnection
, withTransaction
, execute
, query
) where

import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (runExcept)
import Data.Either (Either(..))
import Data.Foreign (Foreign, readArray, readChar, readString, toForeign)
import Data.List (List)
import Data.List as List
import Data.Maybe (fromJust, Maybe(..))
import Data.Newtype (class Newtype)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Data.Tuple.Nested ((/\), tuple1, tuple2, tuple3, tuple4, tuple5)
import Partial.Unsafe (unsafePartial)
import Prelude

foreign import data POSTGRESQL :: !

-- | PostgreSQL connection pool configuration.
type PoolConfiguration =
    { user              :: String
    , password          :: String
    , host              :: String
    , port              :: Int
    , database          :: String
    , max               :: Int
    , idleTimeoutMillis :: Int
    }

-- | PostgreSQL connection pool.
foreign import data Pool :: *

-- | PostgreSQL connection.
foreign import data Connection :: *

-- | PostgreSQL query with parameter (`$1`, `$2`, …) and return types.
newtype Query i o = Query String

derive instance newtypeQuery :: Newtype (Query i o) _

-- | Convert things to SQL rows.
class ToSQLRow a where
    toSQLRow :: a -> Array Foreign

-- | Convert things from SQL rows.
class FromSQLRow a where
    fromSQLRow :: Array Foreign -> Maybe a

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Maybe a

instance toSQLRowUnit :: ToSQLRow Unit where
    toSQLRow _ = []

instance toSQLRowTuple1 :: (ToSQLValue a) => ToSQLRow (Tuple a Unit) where
    toSQLRow (a /\ _) = [toSQLValue a]

instance toSQLRowTuple2 :: (ToSQLValue a, ToSQLValue b) => ToSQLRow (Tuple a (Tuple b Unit)) where
    toSQLRow (a /\ b /\ _) = [toSQLValue a, toSQLValue b]

instance toSQLRowTuple3 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c) => ToSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
    toSQLRow (a /\ b /\ c /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c]

instance toSQLRowTuple4 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c, ToSQLValue d) => ToSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
    toSQLRow (a /\ b /\ c /\ d /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c, toSQLValue d]

instance toSQLRowTuple5 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c, ToSQLValue d, ToSQLValue e) => ToSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
    toSQLRow (a /\ b /\ c /\ d /\ e /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c, toSQLValue d, toSQLValue e]

instance fromSQLRowUnit :: FromSQLRow Unit where
    fromSQLRow [] = Just unit
    fromSQLRow _ = Nothing

instance fromSQLRowTuple1 :: (FromSQLValue a) => FromSQLRow (Tuple a Unit) where
    fromSQLRow [a] = tuple1 <$> fromSQLValue a
    fromSQLRow _ = Nothing

instance fromSQLRowTuple2 :: (FromSQLValue a, FromSQLValue b) => FromSQLRow (Tuple a (Tuple b Unit)) where
    fromSQLRow [a, b] = tuple2 <$> fromSQLValue a <*> fromSQLValue b
    fromSQLRow _ = Nothing

instance fromSQLRowTuple3 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c) => FromSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
    fromSQLRow [a, b, c] = tuple3 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c
    fromSQLRow _ = Nothing

instance fromSQLRowTuple4 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
    fromSQLRow [a, b, c, d] = tuple4 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d
    fromSQLRow _ = Nothing

instance fromSQLRowTuple5 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d, FromSQLValue e) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
    fromSQLRow [a, b, c, d, e] = tuple5 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d <*> fromSQLValue e
    fromSQLRow _ = Nothing

instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = toForeign

instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = fromRight <<< runExcept <<< readChar

instance toSQLValueString :: ToSQLValue String where
    toSQLValue = toForeign

instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = fromRight <<< runExcept <<< readString

instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

-- | Create a new connection pool.
foreign import newPool
    :: ∀ eff
     . PoolConfiguration
    -> Aff (postgreSQL :: POSTGRESQL | eff) Pool

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
foreign import withConnection
    :: ∀ eff a
     . Pool
    -> (Connection -> Aff (postgreSQL :: POSTGRESQL | eff) a)
    -> Aff (postgreSQL :: POSTGRESQL | eff) a

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns, and rolled back when the action throws. If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: ∀ eff a
     . Connection
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
withTransaction conn action =
    execute conn (Query "BEGIN TRANSACTION") unit
    *> catchError (Right <$> action) (pure <<< Left) >>= case _ of
        Right a -> execute conn (Query "COMMIT TRANSACTION") unit $> a
        Left e -> execute conn (Query "ROLLBACK TRANSACTION") unit *> throwError e

-- | Execute a PostgreSQL query and discard its results.
execute
    :: ∀ i o eff
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) Unit
execute conn (Query sql) values =
    void $ _query conn sql (toSQLRow values)

-- | Execute a PostgreSQL query and return its results.
query
    :: ∀ i o eff
     . (ToSQLRow i, FromSQLRow o)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array o)
query conn (Query sql) values =
    _query conn sql (toSQLRow values)
    <#> map (unsafePartial fromJust <<< fromSQLRow)

foreign import _query
    :: ∀ eff
     . Connection
    -> String
    -> Array Foreign
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array (Array Foreign))

fromRight :: ∀ a b. Either a b -> Maybe b
fromRight (Left _) = Nothing
fromRight (Right a) = Just a

module Database.PostgreSQL
( POSTGRESQL
, PoolConfiguration
, Pool
, Connection
, Query(..)
, class ToSQLRow
, class FromSQLRow
, class ToSQLValue
, class FromSQLValue
, toSQLRow
, fromSQLRow
, toSQLValue
, fromSQLValue
, newPool
, withConnection
, withTransaction
, execute
, query
) where

import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (runExcept)
import Data.Either (Either(..))
import Data.Foreign (Foreign, readArray, readChar, readString, toForeign)
import Data.List (List)
import Data.List as List
import Data.Maybe (fromJust, Maybe(..))
import Data.Newtype (class Newtype)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Data.Tuple.Nested ((/\), tuple1, tuple2, tuple3, tuple4, tuple5)
import Partial.Unsafe (unsafePartial)
import Prelude

foreign import data POSTGRESQL :: !

type PoolConfiguration =
    { user              :: String
    , password          :: String
    , host              :: String
    , port              :: Int
    , database          :: String
    , max               :: Int
    , idleTimeoutMillis :: Int
    }

foreign import data Pool :: *

foreign import data Connection :: *

newtype Query i o = Query String

derive instance newtypeQuery :: Newtype (Query i o) _

class ToSQLRow a where
    toSQLRow :: a -> Array Foreign

class FromSQLRow a where
    fromSQLRow :: Array Foreign -> Maybe a

class ToSQLValue a where
    toSQLValue :: a -> Foreign

class FromSQLValue a where
    fromSQLValue :: Foreign -> Maybe a

instance toSQLRowUnit :: ToSQLRow Unit where
    toSQLRow _ = []

instance toSQLRowTuple1 :: (ToSQLValue a) => ToSQLRow (Tuple a Unit) where
    toSQLRow (a /\ _) = [toSQLValue a]

instance toSQLRowTuple2 :: (ToSQLValue a, ToSQLValue b) => ToSQLRow (Tuple a (Tuple b Unit)) where
    toSQLRow (a /\ b /\ _) = [toSQLValue a, toSQLValue b]

instance toSQLRowTuple3 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c) => ToSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
    toSQLRow (a /\ b /\ c /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c]

instance toSQLRowTuple4 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c, ToSQLValue d) => ToSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
    toSQLRow (a /\ b /\ c /\ d /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c, toSQLValue d]

instance toSQLRowTuple5 :: (ToSQLValue a, ToSQLValue b, ToSQLValue c, ToSQLValue d, ToSQLValue e) => ToSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
    toSQLRow (a /\ b /\ c /\ d /\ e /\ _) = [toSQLValue a, toSQLValue b, toSQLValue c, toSQLValue d, toSQLValue e]

instance fromSQLRowUnit :: FromSQLRow Unit where
    fromSQLRow [] = Just unit
    fromSQLRow _ = Nothing

instance fromSQLRowTuple1 :: (FromSQLValue a) => FromSQLRow (Tuple a Unit) where
    fromSQLRow [a] = tuple1 <$> fromSQLValue a
    fromSQLRow _ = Nothing

instance fromSQLRowTuple2 :: (FromSQLValue a, FromSQLValue b) => FromSQLRow (Tuple a (Tuple b Unit)) where
    fromSQLRow [a, b] = tuple2 <$> fromSQLValue a <*> fromSQLValue b
    fromSQLRow _ = Nothing

instance fromSQLRowTuple3 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c) => FromSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
    fromSQLRow [a, b, c] = tuple3 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c
    fromSQLRow _ = Nothing

instance fromSQLRowTuple4 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
    fromSQLRow [a, b, c, d] = tuple4 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d
    fromSQLRow _ = Nothing

instance fromSQLRowTuple5 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d, FromSQLValue e) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
    fromSQLRow [a, b, c, d, e] = tuple5 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d <*> fromSQLValue e
    fromSQLRow _ = Nothing

instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = toForeign

instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = fromRight <<< runExcept <<< readChar

instance toSQLValueString :: ToSQLValue String where
    toSQLValue = toForeign

instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = fromRight <<< runExcept <<< readString

instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

foreign import newPool
    :: ∀ eff
     . PoolConfiguration
    -> Aff (postgreSQL :: POSTGRESQL | eff) Pool

foreign import withConnection
    :: ∀ eff a
     . Pool
    -> (Connection -> Aff (postgreSQL :: POSTGRESQL | eff) a)
    -> Aff (postgreSQL :: POSTGRESQL | eff) a

withTransaction
    :: ∀ eff a
     . Connection
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
withTransaction conn action =
    execute conn (Query "BEGIN TRANSACTION") unit
    *> catchError (Right <$> action) (pure <<< Left) >>= case _ of
        Right a -> execute conn (Query "COMMIT TRANSACTION") unit $> a
        Left e -> execute conn (Query "ROLLBACK TRANSACTION") unit *> throwError e

execute
    :: ∀ i o eff
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) Unit
execute conn (Query sql) values =
    void $ _query conn sql (toSQLRow values)

query
    :: ∀ i o eff
     . (ToSQLRow i, FromSQLRow o)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array o)
query conn (Query sql) values =
    _query conn sql (toSQLRow values)
    <#> map (unsafePartial fromJust <<< fromSQLRow)

foreign import _query
    :: ∀ eff
     . Connection
    -> String
    -> Array Foreign
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array (Array Foreign))

fromRight :: ∀ a b. Either a b -> Maybe b
fromRight (Left _) = Nothing
fromRight (Right a) = Just a


cleanup

cleanup

module Openspace.Ui.Render where

import qualified Data.Map as M
import Data.Tuple
import Data.Array
import Data.Maybe

import Control.Monad.Eff
import DOM

import Openspace.Types

sanitizeTopic :: Topic -> SanitizedTopic
sanitizeTopic (Topic t) = { topicDescription: t.topicDescription,
                            topicTyp: show t.topicTyp }

sanitizeSlot :: Slot -> SanitizedSlot
sanitizeSlot (Slot s) = { room  : show s.room
                        , block : show s.block
                        }

sanitizeTimeslot :: Timeslot -> SanitizedTimeslot
sanitizeTimeslot (Tuple s t) = Tuple (sanitizeSlot s) (sanitizeTopic t)

sanitizeAppState :: AppState -> SanitizedAppState
sanitizeAppState as = let topicNotInGrid t = (filter (\t' -> t == t')(M.values as.timeslots)) == []
                      in { topics          : sanitizeTopic    <$> filter topicNotInGrid as.topics
                         , rooms           : as.rooms
                         , blocks          : show <$> as.blocks
                         , timeslots       : sanitizeTimeslot <$> (M.toList as.timeslots)
                         }

findIn :: Room -> Block -> M.Map Slot Topic -> Maybe SanitizedTopic
findIn r b timeslots = M.lookup (Slot {block:b, room:r}) timeslots
                       <#> sanitizeTopic

makeGrid :: AppState -> [[Maybe SanitizedTopic]]
makeGrid as = (\r ->
                (\b -> findIn r b as.timeslots ) <$> as.blocks
              ) <$> as.rooms

foreign import renderMenu
  """function renderMenu(topicTypes){
    return function(){
      React.render(
        React.createElement(Menu, {topicTypes: topicTypes}),
        document.getElementById('menu')
        );
    }
  }
  """ :: forall eff. [String] -> Eff( dom::DOM | eff ) Unit

foreign import renderTopics
  """function renderTopics(topics){
    return function(){
      React.render(
        React.createElement(Topics, {topics: topics}),
        document.getElementById('topics')
        )
      }
    }
    """ :: forall eff. [SanitizedTopic] -> Eff( dom::DOM | eff ) Unit

foreign import renderGrid
  """
  function renderGrid(rooms){
    return function(blocks){
      return function(grid){
        return function(){
          React.render(
            React.createElement(Grid, {rooms: rooms, blocks: blocks, grid: grid}),
            document.getElementById('grid')
            );
          }
        }
      }
  }
  """ :: forall eff. [Room] -> [Block] -> [[Maybe SanitizedTopic]] -> Eff( dom::DOM | eff ) Unit

renderApp :: forall eff. AppState -> Eff( dom::DOM | eff ) Unit
renderApp as = do
  let as' = sanitizeAppState as
  renderTopics $ as'.topics
  renderGrid as.rooms as.blocks (makeGrid as)

module Openspace.Ui.Render where

import qualified Data.Map as M
import Data.Tuple
import Data.Array
import Data.Maybe

import Control.Monad.Eff
import DOM

import Openspace.Types

sanitizeTopic :: Topic -> SanitizedTopic
sanitizeTopic (Topic t) = t { typ = show t.typ }

sanitizeSlot :: Slot -> SanitizedSlot
sanitizeSlot (Slot s) = { room  : show s.room
                        , block : show s.block
                        }

sanitizeTimeslot :: Timeslot -> SanitizedTimeslot
sanitizeTimeslot (Tuple s t) = Tuple (sanitizeSlot s) (sanitizeTopic t)

sanitizeAppState :: AppState -> SanitizedAppState
sanitizeAppState as = let topicNotInGrid t = (filter (\t' -> t == t')(M.values as.timeslots)) == []
                      in { topics          : sanitizeTopic    <$> filter topicNotInGrid as.topics
                         , rooms           : as.rooms
                         , blocks          : show <$> as.blocks
                         , timeslots       : sanitizeTimeslot <$> (M.toList as.timeslots)
                         }

findIn :: Room -> Block -> M.Map Slot Topic -> Maybe SanitizedTopic
findIn r b timeslots = M.lookup (Slot {block:b, room:r}) timeslots
                       <#> sanitizeTopic

makeGrid :: AppState -> [[Maybe SanitizedTopic]]
makeGrid as = (\r ->
                (\b -> findIn r b as.timeslots ) <$> as.blocks
              ) <$> as.rooms

foreign import renderMenu
  """function renderMenu(topicTypes){
    return function(){
      React.render(
        React.createElement(Menu, {topicTypes: topicTypes}),
        document.getElementById('menu')
        );
    }
  }
  """ :: forall eff. [String] -> Eff( dom::DOM | eff ) Unit

foreign import renderTopics
  """function renderTopics(topics){
    return function(){
      React.render(
        React.createElement(Topics, {topics: topics}),
        document.getElementById('topics')
        )
      }
    }
    """ :: forall eff. [SanitizedTopic] -> Eff( dom::DOM | eff ) Unit

foreign import renderGrid
  """
  function renderGrid(rooms){
    return function(blocks){
      return function(grid){
        return function(){
          React.render(
            React.createElement(Grid, {rooms: rooms, blocks: blocks, grid: grid}),
            document.getElementById('grid')
            );
          }
        }
      }
  }
  """ :: forall eff. [Room] -> [Block] -> [[Maybe SanitizedTopic]] -> Eff( dom::DOM | eff ) Unit

renderApp :: forall eff. AppState -> Eff( dom::DOM | eff ) Unit
renderApp as = do
  let as' = sanitizeAppState as
  renderTopics $ as'.topics
  renderGrid as.rooms as.blocks (makeGrid as)


cleanup render tests

cleanup render tests

module Content.Render.Test (tests) where

import Prelude (Unit, ($), (<>), (<<<), discard, map)
import Data.Either(Either)
import Data.List (singleton, (:), List(..))
import Text.Markdown.SlamDown.Parser(parseMd)
import Text.Markdown.SlamDown (SlamDown, SlamDownP(..), Block(..), Inline(..), CodeBlockType(..), ListType(..), LinkTarget(..))
import Text.Smolder.HTML (div, p, pre, code, ol, ul, li, blockquote, h1, h3, a, strong, em, br, img)
import Text.Smolder.HTML.Attributes (className, href, src, alt)
import Text.Smolder.Markup (text, Markup, (!))
import Text.Smolder.Renderer.String as MR
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Test.Unit (suite, test, Test)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (equal)

import Content.Render (render)

para :: forall a. String -> Block a
para txt = Paragraph $ singleton $ Str txt

blockp :: forall a. String -> Block a
blockp = para

singletonMd :: forall a. Block a -> SlamDownP a
singletonMd = SlamDown <<< singleton

paragraphMd :: forall a. String -> SlamDownP a
paragraphMd = singletonMd <<< blockp

parsed :: Either String SlamDown
parsed = parseMd "this is true: 7 < 100 & 7 < 12"

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "Content.Render block elements" do
        test "convert paragraph" do
            let ptext = "such text!"
            let source = paragraphMd ptext
            let expected = div $ do
                             p $ text ptext
            check source expected
        test "convert multiple paragraphs" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let source = SlamDown (blockp ptext1 : blockp ptext2 : Nil)
            let expected = div $ do
                             p $ text ptext1
                             p $ text ptext2
            check source expected
        test "convert multiple text" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let ptext3 = "with addition"
            let source = SlamDown (blockp ptext1 : Paragraph  (Str ptext2 : Str ptext3 : Nil) : Nil)
            let expected = div $ do
                  p $ text ptext1
                  p $ do
                    text ptext2
                    text ptext3
            check source expected
        test "convert fenced code block" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock (Fenced true "") lines
          let expected = div $ do
                pre $ code $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert fenced code block with language" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock (Fenced true "cpp") lines
          let expected = div $ do
                pre $ code ! className "language-cpp" $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert indented code block" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock Indented lines
          let expected = div $ do
                pre $ code $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert ordered list" do
          let itext1 = "line 1"
          let itext2 = "line 2"
          let itext3 = "line 3"
          let codetext = "int x = 3.302"
          let items1 = blockp itext1 : CodeBlock Indented (singleton codetext) : Nil
          let items2 = blockp itext2 : blockp itext3 : Nil
          let source = SlamDown $ singleton $ Lst (Ordered "1.") (items1 : items2 : Nil)
          let expected = div $ do
                ol $ do
                  li $ text itext1
                  pre $ code $ text codetext
                  li $ text itext2
                  li $ text itext3
          check source expected
        test "convert unordered list" do
          let itext1 = "line 1"
          let itext2 = "line 2"
          let itext3 = "line 3"
          let codetext = "int x = 3.302"
          let items1 = blockp itext1 : CodeBlock Indented (singleton codetext) : Nil
          let items2 = blockp itext2 : blockp itext3 : Nil
          let source = SlamDown $ singleton $ Lst (Bullet "*") (items1 : items2 : Nil)
          let expected = div $ do
                ul $ do
                  li $ text itext1
                  pre $ code $ text codetext
                  li $ text itext2
                  li $ text itext3
          check source expected
        test "convert block quote" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let source = SlamDown $ singleton $ Blockquote (para ptext1 : para ptext2 : Nil)
            let expected = div $ blockquote $ do
                             p $ text ptext1
                             p $ text ptext2
            check source expected
        test "convert header" do
            let ptext1 = "Such"
            let ptext2 = " "
            let ptext3 = "Header"
            let ptext4 = "!"
            let source = SlamDown $ singleton $ Header 1 $ map Str (ptext1 : ptext2 : ptext3 : ptext4 : Nil)
            let expected = div $ h1 $ do
                             text ptext1
                             text ptext2
                             text ptext3
                             text ptext4
            check source expected
        test "convert header level" do
            let ptext1 = "Such"
            let ptext2 = " "
            let ptext3 = "Header"
            let ptext4 = "!"
            let source = SlamDown $ singleton $ Header 3 $ map Str (ptext1 : ptext2 : ptext3 : ptext4 : Nil)
            let expected = div $ h3 $ do
                             text ptext1
                             text ptext2
                             text ptext3
                             text ptext4
            check source expected
        test "convert link reference" do
            let label = "destination"
            let dest = "https://gregwiley.com"
            let source = SlamDown $ singleton $ LinkReference label dest
            let expected = div $ a ! href dest $ text label
            check source expected
    suite "Content.Render inline elements" do
        test "convert str" do
            let ptext = "such text!"
            let source = Str ptext
            let expected = text ptext
            checkInline source expected
        test "convert space" do
            let source = Space
            let expected = text " "
            checkInline source expected
        test "convert code" do
            let ptext = "such code!"
            let source = Code false ptext
            let expected = code $ text ptext
            checkInline source expected
        test "convert strong" do
            let ptext1 = "such "
            let ptext2 = "text!"
            let source = Strong $ map Str (ptext1 : ptext2 : Nil)
            let expected = strong $ do
                  text ptext1
                  text ptext2
            checkInline source expected
        test "convert emphasis" do
            let ptext1 = "such "
            let ptext2 = "text!"
            let source = Emph $ map Str (ptext1 : ptext2 : Nil)
            let expected = em $ do
                  text ptext1
                  text ptext2
            checkInline source expected
        test "convert soft break" do
            let source = SoftBreak
            let expected = text "\n"
            checkInline source expected
        test "convert line break" do
            let source = LineBreak
            let expected = br
            checkInline source expected
        test "convert entity (not what I really want to do but predicatable)" do
            let etext = " "
            let source = Entity etext
            let expected = text etext
            checkInline source expected
        test "convert link (inline only, reference not implemented)" do
            let ltext1 = "such "
            let ltext2 = "text!"
            let dest = "https://gjwiley.com"
            let source = Link (map Str (ltext1 : ltext2 : Nil)) (InlineLink dest)
            let expected = a ! href dest $ do
                  text ltext1
                  text ltext2
            checkInline source expected
        test "convert image" do
            let ltext1 = "such "
            let ltext2 = "text!"
            let loc = "https://gjwiley.com/images/fishbicycle.png"
            let source = Image (Str ltext1 : Space : Str ltext2 : Nil) loc
            let expected = img ! src loc ! alt (ltext1 <> " " <> ltext2)
            checkInline source expected

check :: forall e a. SlamDown -> Markup a -> Test (console :: CONSOLE | e)
check source expected = do
    let actual = render source
    equal (MR.render expected) (MR.render actual)

checkInline :: forall e a. Inline String -> Markup a -> Test (console :: CONSOLE | e)
checkInline source expected = do
    let embeddedSource = SlamDown $ singleton $ Paragraph $ singleton source
    let embeddedExpected = div $ p expected
    check embeddedSource embeddedExpected

module Content.Render.Test (tests) where

import Prelude (Unit, ($), (==), (<>), (<<<), discard, map)
import Data.Either(Either)
import Data.List (singleton, (:), List(..))
import Text.Markdown.SlamDown.Parser(parseMd)
import Text.Markdown.SlamDown (SlamDown, SlamDownP(..), Block(..), Inline(..), CodeBlockType(..), ListType(..), LinkTarget(..))
import Text.Smolder.HTML (div, p, pre, code, ol, ul, li, blockquote, h1, h3, a, strong, em, br, img)
import Text.Smolder.HTML.Attributes (className, href, src, alt)
import Text.Smolder.Markup (text, Markup, (!))
import Text.Smolder.Renderer.String as MR
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, logShow)
import Control.Monad.Aff.AVar (AVAR)
import Test.Unit (suite, test, Test)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (assert, equal)

import Content.Render (render)

para :: forall a. String -> Block a
para txt = Paragraph $ singleton $ Str txt

blockp :: forall a. String -> Block a
blockp = para

singletonMd :: forall a. Block a -> SlamDownP a
singletonMd = SlamDown <<< singleton

paragraphMd :: forall a. String -> SlamDownP a
paragraphMd = singletonMd <<< blockp

parsed :: Either String SlamDown
parsed = parseMd "this is true: 7 < 100 & 7 < 12"

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  logShow $ parsed
  runTest do
    suite "Content.Render block elements" do
        test "convert paragraph" do
            let ptext = "such text!"
            let source = paragraphMd ptext
            let expected = div $ do
                             p $ text ptext
            check source expected
        test "convert multiple paragraphs" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let source = SlamDown (blockp ptext1 : blockp ptext2 : Nil)
            let expected = div $ do
                             p $ text ptext1
                             p $ text ptext2
            check source expected
        test "convert multiple text" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let ptext3 = "with addition"
            let source = SlamDown (blockp ptext1 : Paragraph  (Str ptext2 : Str ptext3 : Nil) : Nil)
            let expected = div $ do
                  p $ text ptext1
                  p $ do
                    text ptext2
                    text ptext3
            check source expected
        test "convert fenced code block" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock (Fenced true "") lines
          let expected = div $ do
                pre $ code $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert fenced code block with language" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock (Fenced true "cpp") lines
          let expected = div $ do
                pre $ code ! className "language-cpp" $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert indented code block" do
          let line1 = "line 1"
          let line2 = "line 2"
          let line3 = "line 3"
          let lines = line1 : line2 : line3 : Nil
          let source = singletonMd $ CodeBlock Indented lines
          let expected = div $ do
                pre $ code $ text $
                  line1 <> "\n" <> line2 <> "\n" <> line3
          check source expected
        test "convert ordered list" do
          let itext1 = "line 1"
          let itext2 = "line 2"
          let itext3 = "line 3"
          let codetext = "int x = 3.302"
          let items1 = blockp itext1 : CodeBlock Indented (singleton codetext) : Nil
          let items2 = blockp itext2 : blockp itext3 : Nil
          let source = SlamDown $ singleton $ Lst (Ordered "1.") (items1 : items2 : Nil)
          let expected = div $ do
                ol $ do
                  li $ text itext1
                  pre $ code $ text codetext
                  li $ text itext2
                  li $ text itext3
          check source expected
        test "convert unordered list" do
          let itext1 = "line 1"
          let itext2 = "line 2"
          let itext3 = "line 3"
          let codetext = "int x = 3.302"
          let items1 = blockp itext1 : CodeBlock Indented (singleton codetext) : Nil
          let items2 = blockp itext2 : blockp itext3 : Nil
          let source = SlamDown $ singleton $ Lst (Bullet "*") (items1 : items2 : Nil)
          let expected = div $ do
                ul $ do
                  li $ text itext1
                  pre $ code $ text codetext
                  li $ text itext2
                  li $ text itext3
          check source expected
        test "convert block quote" do
            let ptext1 = "such text!"
            let ptext2 = "such more text!"
            let source = SlamDown $ singleton $ Blockquote (para ptext1 : para ptext2 : Nil)
            let expected = div $ blockquote $ do
                             p $ text ptext1
                             p $ text ptext2
            check source expected
        test "convert header" do
            let ptext1 = "Such"
            let ptext2 = " "
            let ptext3 = "Header"
            let ptext4 = "!"
            let source = SlamDown $ singleton $ Header 1 $ map Str (ptext1 : ptext2 : ptext3 : ptext4 : Nil)
            let expected = div $ h1 $ do
                             text ptext1
                             text ptext2
                             text ptext3
                             text ptext4
            check source expected
        test "convert header level" do
            let ptext1 = "Such"
            let ptext2 = " "
            let ptext3 = "Header"
            let ptext4 = "!"
            let source = SlamDown $ singleton $ Header 3 $ map Str (ptext1 : ptext2 : ptext3 : ptext4 : Nil)
            let expected = div $ h3 $ do
                             text ptext1
                             text ptext2
                             text ptext3
                             text ptext4
            check source expected
        test "convert link reference" do
            let label = "destination"
            let dest = "https://gregwiley.com"
            let source = SlamDown $ singleton $ LinkReference label dest
            let expected = div $ a ! href dest $ text label
            check source expected
    suite "Content.Render inline elements" do
        test "convert str" do
            let ptext = "such text!"
            let source = Str ptext
            let expected = text ptext
            checkInline source expected
        test "convert space" do
            let source = Space
            let expected = text " "
            checkInline source expected
        test "convert code" do
            let ptext = "such code!"
            let source = Code false ptext
            let expected = code $ text ptext
            checkInline source expected
        test "convert strong" do
            let ptext1 = "such "
            let ptext2 = "text!"
            let source = Strong $ map Str (ptext1 : ptext2 : Nil)
            let expected = strong $ do
                  text ptext1
                  text ptext2
            checkInline source expected
        test "convert emphasis" do
            let ptext1 = "such "
            let ptext2 = "text!"
            let source = Emph $ map Str (ptext1 : ptext2 : Nil)
            let expected = em $ do
                  text ptext1
                  text ptext2
            checkInline source expected
        test "convert soft break" do
            let source = SoftBreak
            let expected = text "\n"
            checkInline source expected
        test "convert line break" do
            let source = LineBreak
            let expected = br
            checkInline source expected
        test "convert entity (not what I really want to do but predicatable)" do
            let etext = " "
            let source = Entity etext
            let expected = text etext
            checkInline source expected
        test "convert link (inline only, reference not implemented)" do
            let ltext1 = "such "
            let ltext2 = "text!"
            let dest = "https://gjwiley.com"
            let source = Link (map Str (ltext1 : ltext2 : Nil)) (InlineLink dest)
            let expected = a ! href dest $ do
                  text ltext1
                  text ltext2
            checkInline source expected
        test "convert image" do
            let ltext1 = "such "
            let ltext2 = "text!"
            let loc = "https://gjwiley.com/images/fishbicycle.png"
            let source = Image (Str ltext1 : Space : Str ltext2 : Nil) loc
            let expected = img ! src loc ! alt (ltext1 <> " " <> ltext2)
            checkInline source expected

check :: forall e a. SlamDown -> Markup a -> Test (console :: CONSOLE | e)
check source expected = do
    let actual = render source
    equal (MR.render expected) (MR.render actual)

checkInline :: forall e a. Inline String -> Markup a -> Test (console :: CONSOLE | e)
checkInline source expected = do
    let embeddedSource = SlamDown $ singleton $ Paragraph $ singleton source
    let embeddedExpected = div $ p expected
    check embeddedSource embeddedExpected