Improved logging

Improved logging

module App.StatsSocket where

import Prelude
import Signal.Channel
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Var (($=), get)
import Data.Either
import Data.Argonaut
import Data.Argonaut.Parser
import WebSocket (Connection(Connection), URL(URL), WEBSOCKET, newWebSocket, runMessage, runMessageEvent, runURL)
import DOM.Websocket.Event.Types (MessageEvent)
import App.StatsTypes

setupWs :: forall eff. Channel LBStats -> String -> Eff (ws::WEBSOCKET, err::EXCEPTION | eff) Unit
setupWs chan url = do
  Connection ws <- newWebSocket (URL url) []

  ws.onopen $= \_ -> do
    log "onopen: Connection opened"
    log <<< runURL =<< get ws.url

  ws.onmessage $= \event -> do
    let msg = event # runMessageEvent
                    >>> runMessage
    let decoded = (msg # jsonParser
                   >>= decodeLBStats) :: Either String LBStats
    case decoded of
      Left error -> log $ "unknown message received: '" <> msg <>" with error: " <> error <> "'"
      Right stats -> send chan stats

  ws.onclose $= \_ -> do
    log "onclose: Connection closed"

getLBStatsFromEvent :: MessageEvent -> Either String LBStats
getLBStatsFromEvent event =
  event # runMessageEvent
        >>> runMessage
        >>> jsonParser
        >>= decodeLBStats

module App.StatsSocket where

import Prelude
import Signal.Channel
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Var (($=), get)
import Data.Either
import Data.Argonaut
import Data.Argonaut.Parser
import WebSocket (Connection(Connection), URL(URL), WEBSOCKET, newWebSocket, runMessage, runMessageEvent, runURL)
import DOM.Websocket.Event.Types (MessageEvent)
import App.StatsTypes

setupWs :: forall eff. Channel LBStats -> String -> Eff (ws::WEBSOCKET, err::EXCEPTION | eff) Unit
setupWs chan url = do
  Connection ws <- newWebSocket (URL url) []

  ws.onopen $= \_ -> do
    log "onopen: Connection opened"
    log <<< runURL =<< get ws.url

  ws.onmessage $= \event -> do
    case getLBStatsFromEvent event of
      Left msg -> log $ "unknown message received: '" <> msg <> "'"
      Right stats -> send chan stats

  ws.onclose $= \_ -> do
    log "onclose: Connection closed"

getLBStatsFromEvent :: MessageEvent -> Either String LBStats
getLBStatsFromEvent event =
  event # runMessageEvent
        >>> runMessage
        >>> jsonParser
        >>= decodeLBStats


restore run with warning

restore run with warning

module Test.Spec.Runner
  ( run
  , runSpecT
  , runSpec
  , defaultConfig
  , Config
  , TestEvents
  , Reporter
  ) where

import Prelude

import Prim.TypeError (class Warn, Text)
import Control.Alternative ((<|>))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (execWriterT)
import Control.Parallel (parTraverse, parallel, sequential)
import Data.Array (groupBy, mapWithIndex)
import Data.Array.NonEmpty as NEA
import Data.DateTime.Instant (unInstant)
import Data.Either (Either(..), either)
import Data.Foldable (foldl)
import Data.Function (on)
import Data.Identity (Identity(..))
import Data.Int as Int
import Data.Maybe (Maybe(..))
import Data.Newtype (un)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (class Traversable, for)
import Effect (Effect)
import Effect.Aff (Aff, attempt, delay, forkAff, joinFiber, makeAff, throwError, try)
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Exception (error)
import Effect.Now (now)
import Pipes ((>->), yield)
import Pipes.Core (Pipe, Producer, (//>))
import Pipes.Core (runEffectRec) as P
import Test.Spec (Item(..), Spec, SpecT(..), SpecTree, Tree(..))
import Test.Spec.Console as Console
import Test.Spec.Result (Result(..))
import Test.Spec.Runner.Event (Event, Execution(..))
import Test.Spec.Runner.Event as Event
import Test.Spec.Speed (speedOf)
import Test.Spec.Style (styled)
import Test.Spec.Style as Style
import Test.Spec.Summary (successful)
import Test.Spec.Tree (Path, PathItem(..), countTests, discardUnfocused, isAllParallelizable)

foreign import exit :: Int -> Effect Unit

type Config =
  { slow :: Milliseconds
  , timeout :: Maybe Milliseconds
  , exit :: Boolean
  }

defaultConfig :: Config
defaultConfig =
  { slow: Milliseconds 75.0
  , timeout: Just $ Milliseconds 2000.0
  , exit: true
  }

makeTimeout
  :: Milliseconds
  -> Aff Unit
makeTimeout ms@(Milliseconds ms') = do
  delay ms
  makeAff \cb -> mempty <$ do
    cb <<< Left $ error $ "test timed out after " <> show (Int.round ms') <> "ms"

timeout
  :: Milliseconds
  -> Aff Unit
  -> Aff Unit
timeout time t = do
  sequential (parallel (try (makeTimeout time)) <|> parallel (try t))
    >>= either throwError pure

type TestWithPath r = {test :: SpecTree Aff Unit, path :: Path | r}

-- Run the given spec as `Producer` in the underlying `Aff` monad.
-- This producer has two responsibilities:
--      1) emit events for key moments in the runner's lifecycle
--      2) collect the tst output into an array of results
-- This allows downstream consumers to report about the tests even before the
-- prodocer has completed and still benefit from the array of results the way
-- the runner sees it.
_run
  :: forall m
   . Functor m
  => Config
  -> SpecT Aff Unit m Unit
  -> m TestEvents
_run config (SpecT specs) = execWriterT specs <#> discardUnfocused >>> \tests -> do
  yield (Event.Start (countTests tests))
  let indexer index test = {test, path: [PathItem {name: Nothing, index}]}
  r <- loop $ mapWithIndex indexer tests
  yield (Event.End r)
  pure r
  where
    loop :: Array (TestWithPath ()) -> TestEvents
    loop tests =
      let
        noteWithIsAllParallelizable = map \{test,path} -> { isParallelizable: isAllParallelizable test, test, path}
        groupByIsParallelizable = groupBy (\a b -> a.isParallelizable && b.isParallelizable)
      in join <$> for (groupByIsParallelizable $ noteWithIsAllParallelizable tests) \g ->
        join <$> if (NEA.head g).isParallelizable
          then mergeProducers (runGroup <$> (NEA.toArray g))
          else for (NEA.toArray g) runGroup

    runGroup :: TestWithPath (isParallelizable :: Boolean) -> TestEvents
    runGroup {test, path, isParallelizable} = case test of
      (Leaf name (Just (Item item))) -> do
        yield $ Event.Test (if isParallelizable then Parallel else Sequential) path name
        let example = item.example \a -> a unit
        start <- lift $ liftEffect now
        e <- lift $ attempt case config.timeout of
          Just t -> timeout t example
          _      -> example
        end <- liftEffect now
        let duration = Milliseconds $ on (-) (unInstant >>> un Milliseconds) end start
        let res = either Failure (const $ Success (speedOf config.slow duration) duration) e
        yield $ Event.TestEnd path name res
        pure [ Leaf name $ Just res ]
      (Leaf name Nothing) -> do
        yield $ Event.Pending path name
        pure [ Leaf name Nothing ]
      (Node (Right cleanup) xs) -> do
        let indexer index x = {test:x, path: path <> [PathItem {name: Nothing, index}]}
        loop (mapWithIndex indexer xs) <* lift (cleanup unit)
      (Node (Left name) xs) -> do
        yield $ Event.Suite (if isParallelizable then Parallel else Sequential) path name
        let indexer index x = {test:x, path: path <> [PathItem {name: Just name, index}]}
        res <- loop (mapWithIndex indexer xs)
        yield $ Event.SuiteEnd path
        pure [ Node (Left name) res ]

-- https://github.com/felixSchl/purescript-pipes/issues/16
mergeProducers :: forall t o a. Traversable t => t (Producer o Aff a) -> Producer o Aff (t a)
mergeProducers ps = do
  var <- lift AV.empty

  fib <- lift $ forkAff do
    let consumer i = lift (AV.put i var) *> pure unit
    x <- parTraverse (\p -> P.runEffectRec $ p //> consumer) ps
    AV.kill (error "finished") var
    pure x

  let
    loop = do
      res <- lift $ try (AV.take var)
      case res of
        Left err -> lift $ joinFiber fib
        Right e -> do
          yield e
          loop
  loop

type TestEvents = Producer Event Aff (Array (Tree Void Result))

type Reporter = Pipe Event Event Aff (Array (Tree Void Result))

-- | Run the spec with `config`, returning the results, which
-- | are also reported using specified Reporters, if any.
-- | If configured as such, `exit` the program upon completion
-- | with appropriate exit code.
runSpecT
  :: forall m
   . Functor m
  => Config
  -> Array Reporter
  -> SpecT Aff Unit m Unit
  -> m (Aff (Array (Tree Void Result)))
runSpecT config reporters spec = _run config spec <#> \runner -> do
  let
    drain = const (pure unit)
    events = foldl (>->) runner reporters
    reportedEvents = P.runEffectRec $ events //> drain
  if config.exit
    then try reportedEvents >>= case _ of
      Left err -> do
        liftEffect $ Console.write $ styled Style.red (show err <> "\n")
        liftEffect $ exit 1
        throwError err
      Right results -> liftEffect do
        let code = if successful results then 0 else 1
        exit code
        pure results
    else reportedEvents

-- | Run the spec with the default config
run
  :: Warn (Text "`Test.Spec.Runner.run` is Deprecated use runSpec instead")
  => Array Reporter
  -> Spec Unit
  -> Aff Unit
run reporters spec = void $ un Identity $ runSpecT defaultConfig reporters spec

-- | Run the spec with the default config
runSpec
  :: Array Reporter
  -> Spec Unit
  -> Aff Unit
runSpec reporters spec = void $ un Identity $ runSpecT defaultConfig reporters spec

module Test.Spec.Runner
  ( runSpecT
  , runSpec
  , defaultConfig
  , Config
  , TestEvents
  , Reporter
  ) where

import Prelude

import Control.Alternative ((<|>))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (execWriterT)
import Control.Parallel (parTraverse, parallel, sequential)
import Data.Array (groupBy, mapWithIndex)
import Data.Array.NonEmpty as NEA
import Data.DateTime.Instant (unInstant)
import Data.Either (Either(..), either)
import Data.Foldable (foldl)
import Data.Function (on)
import Data.Identity (Identity(..))
import Data.Int as Int
import Data.Maybe (Maybe(..))
import Data.Newtype (un)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (class Traversable, for)
import Effect (Effect)
import Effect.Aff (Aff, attempt, delay, forkAff, joinFiber, makeAff, throwError, try)
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Exception (error)
import Effect.Now (now)
import Pipes ((>->), yield)
import Pipes.Core (Pipe, Producer, (//>))
import Pipes.Core (runEffectRec) as P
import Test.Spec (Item(..), Spec, SpecT(..), SpecTree, Tree(..))
import Test.Spec.Console as Console
import Test.Spec.Result (Result(..))
import Test.Spec.Runner.Event (Event, Execution(..))
import Test.Spec.Runner.Event as Event
import Test.Spec.Speed (speedOf)
import Test.Spec.Style (styled)
import Test.Spec.Style as Style
import Test.Spec.Summary (successful)
import Test.Spec.Tree (Path, PathItem(..), countTests, discardUnfocused, isAllParallelizable)

foreign import exit :: Int -> Effect Unit

type Config =
  { slow :: Milliseconds
  , timeout :: Maybe Milliseconds
  , exit :: Boolean
  }

defaultConfig :: Config
defaultConfig =
  { slow: Milliseconds 75.0
  , timeout: Just $ Milliseconds 2000.0
  , exit: true
  }

makeTimeout
  :: Milliseconds
  -> Aff Unit
makeTimeout ms@(Milliseconds ms') = do
  delay ms
  makeAff \cb -> mempty <$ do
    cb <<< Left $ error $ "test timed out after " <> show (Int.round ms') <> "ms"

timeout
  :: Milliseconds
  -> Aff Unit
  -> Aff Unit
timeout time t = do
  sequential (parallel (try (makeTimeout time)) <|> parallel (try t))
    >>= either throwError pure

type TestWithPath r = {test :: SpecTree Aff Unit, path :: Path | r}

-- Run the given spec as `Producer` in the underlying `Aff` monad.
-- This producer has two responsibilities:
--      1) emit events for key moments in the runner's lifecycle
--      2) collect the tst output into an array of results
-- This allows downstream consumers to report about the tests even before the
-- prodocer has completed and still benefit from the array of results the way
-- the runner sees it.
_run
  :: forall m
   . Functor m
  => Config
  -> SpecT Aff Unit m Unit
  -> m TestEvents
_run config (SpecT specs) = execWriterT specs <#> discardUnfocused >>> \tests -> do
  yield (Event.Start (countTests tests))
  let indexer index test = {test, path: [PathItem {name: Nothing, index}]}
  r <- loop $ mapWithIndex indexer tests
  yield (Event.End r)
  pure r
  where
    loop :: Array (TestWithPath ()) -> TestEvents
    loop tests =
      let
        noteWithIsAllParallelizable = map \{test,path} -> { isParallelizable: isAllParallelizable test, test, path}
        groupByIsParallelizable = groupBy (\a b -> a.isParallelizable && b.isParallelizable)
      in join <$> for (groupByIsParallelizable $ noteWithIsAllParallelizable tests) \g ->
        join <$> if (NEA.head g).isParallelizable
          then mergeProducers (runGroup <$> (NEA.toArray g))
          else for (NEA.toArray g) runGroup

    runGroup :: TestWithPath (isParallelizable :: Boolean) -> TestEvents
    runGroup {test, path, isParallelizable} = case test of
      (Leaf name (Just (Item item))) -> do
        yield $ Event.Test (if isParallelizable then Parallel else Sequential) path name
        let example = item.example \a -> a unit
        start <- lift $ liftEffect now
        e <- lift $ attempt case config.timeout of
          Just t -> timeout t example
          _      -> example
        end <- liftEffect now
        let duration = Milliseconds $ on (-) (unInstant >>> un Milliseconds) end start
        let res = either Failure (const $ Success (speedOf config.slow duration) duration) e
        yield $ Event.TestEnd path name res
        pure [ Leaf name $ Just res ]
      (Leaf name Nothing) -> do
        yield $ Event.Pending path name
        pure [ Leaf name Nothing ]
      (Node (Right cleanup) xs) -> do
        let indexer index x = {test:x, path: path <> [PathItem {name: Nothing, index}]}
        loop (mapWithIndex indexer xs) <* lift (cleanup unit)
      (Node (Left name) xs) -> do
        yield $ Event.Suite (if isParallelizable then Parallel else Sequential) path name
        let indexer index x = {test:x, path: path <> [PathItem {name: Just name, index}]}
        res <- loop (mapWithIndex indexer xs)
        yield $ Event.SuiteEnd path
        pure [ Node (Left name) res ]

-- https://github.com/felixSchl/purescript-pipes/issues/16
mergeProducers :: forall t o a. Traversable t => t (Producer o Aff a) -> Producer o Aff (t a)
mergeProducers ps = do
  var <- lift AV.empty

  fib <- lift $ forkAff do
    let consumer i = lift (AV.put i var) *> pure unit
    x <- parTraverse (\p -> P.runEffectRec $ p //> consumer) ps
    AV.kill (error "finished") var
    pure x

  let
    loop = do
      res <- lift $ try (AV.take var)
      case res of
        Left err -> lift $ joinFiber fib
        Right e -> do
          yield e
          loop
  loop

type TestEvents = Producer Event Aff (Array (Tree Void Result))

type Reporter = Pipe Event Event Aff (Array (Tree Void Result))

-- | Run the spec with `config`, returning the results, which
-- | are also reported using specified Reporters, if any.
-- | If configured as such, `exit` the program upon completion
-- | with appropriate exit code.
runSpecT
  :: forall m
   . Functor m
  => Config
  -> Array Reporter
  -> SpecT Aff Unit m Unit
  -> m (Aff (Array (Tree Void Result)))
runSpecT config reporters spec = _run config spec <#> \runner -> do
  let
    drain = const (pure unit)
    events = foldl (>->) runner reporters
    reportedEvents = P.runEffectRec $ events //> drain
  if config.exit
    then try reportedEvents >>= case _ of
      Left err -> do
        liftEffect $ Console.write $ styled Style.red (show err <> "\n")
        liftEffect $ exit 1
        throwError err
      Right results -> liftEffect do
        let code = if successful results then 0 else 1
        exit code
        pure results
    else reportedEvents

-- | Run the spec with the default config
runSpec
  :: Array Reporter
  -> Spec Unit
  -> Aff Unit
runSpec reporters spec = void $ un Identity $ runSpecT defaultConfig reporters spec


Fix printing of EJSON Map values

Fix printing of EJSON Map values

{-
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.Port.VarMap
  ( VarMap
  , URLVarMap
  , VarMapValue(..)
  , renderVarMapValue
  , emptyVarMap
  , escapeIdentifier
  ) where

import SlamData.Prelude

import Data.Foldable as F
import Data.HugeNum as HN
import Data.Json.Extended as EJSON
import Data.Json.Extended.Signature.Render as EJR
import Data.String.Regex (test, replace) as Regex
import Data.String.Regex.Flags (ignoreCase, global) as Regex
import Data.String.Regex.Unsafe (unsafeRegex) as Regex
import Data.StrMap as SM

import Data.Argonaut ((.?))
import Data.Argonaut.Core (jsonSingletonObject)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Encode (class EncodeJson, encodeJson)

import Matryoshka (Algebra, cata)

import Text.Markdown.SlamDown.Syntax.Value as SDV

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

data VarMapValue
  = Literal EJSON.EJson
  | SetLiteral (Array VarMapValue)
  | QueryExpr String -- TODO: syntax of SQL^2 queries

derive instance eqVarMapValue ∷ Eq VarMapValue

derive instance ordVarMapValue ∷ Ord VarMapValue

instance showVarMapValue ∷ Show VarMapValue where
  show = renderVarMapValue

instance encodeJsonVarMapValue ∷ EncodeJson VarMapValue where
  encodeJson v =
    case v of
      Literal ejson →
        jsonSingletonObject "literal" $
          EJSON.encodeEJson ejson
      SetLiteral as →
        jsonSingletonObject "set" $
          encodeJson as
      QueryExpr str →
        jsonSingletonObject "query" $
          encodeJson str

instance decodeJsonVarMapValue :: DecodeJson VarMapValue where
  decodeJson json = do
    obj <- decodeJson json
    decodeLiteral obj
      <|> decodeSetLiteral obj
      <|> decodeQueryExpr obj

    where
      decodeLiteral =
        (_ .? "literal")
          >=> EJSON.decodeEJson
          >>> map Literal

      decodeSetLiteral =
        (_ .? "set")
          >=> decodeJson
          >>> map SetLiteral

      decodeQueryExpr  =
        (_ .? "query")
          >>> map QueryExpr

renderVarMapValue
  ∷ VarMapValue
  → String
renderVarMapValue val =
  case val of
    Literal lit → EJSON.renderEJson lit
    SetLiteral as → "(" <> F.intercalate "," (renderVarMapValue <$> as) <> ")"
    QueryExpr str → str

displayVarMapValue
  ∷ VarMapValue
  → String
displayVarMapValue val =
  case val of
    Literal lit → displayEJson lit
    SetLiteral as → "(" <> F.intercalate ", " (displayVarMapValue <$> as) <> ")"
    QueryExpr str → str

displayEJsonF ∷ Algebra EJSON.EJsonF String
displayEJsonF =
  case _ of
    EJSON.Null → "null"
    EJSON.Boolean b → if b then "true" else "false"
    EJSON.Integer i → show i
    EJSON.Decimal a → HN.toString a
    EJSON.String str → str
    EJSON.Timestamp dt → EJR.renderTimestamp dt
    EJSON.Time t → EJR.renderTime t
    EJSON.Date d → EJR.renderDate d
    EJSON.Interval str → str
    EJSON.ObjectId str → str
    EJSON.Array ds → "[" <> commaSep ds <> "]"
    EJSON.Map (EJSON.EJsonMap ds) → "{ " <> commaSep (map renderPair ds) <> " }"
  where
  commaSep ∷ Array String → String
  commaSep = F.intercalate ","
  renderPair ∷ Tuple String String → String
  renderPair (Tuple k v) = k <> ": " <> v

-- | A more readable, but forgetful renderer
displayEJson ∷ EJSON.EJson → String
displayEJson = cata displayEJsonF

instance valueVarMapValue ∷ SDV.Value VarMapValue where
  stringValue = Literal <<< EJSON.string
  renderValue = displayVarMapValue

instance arbitraryVarMapValue ∷ SC.Arbitrary VarMapValue where
  arbitrary =
    Literal <$> EJSON.arbitraryJsonEncodableEJsonOfSize 1
      <|> SetLiteral <$> Gen.arrayOf (Literal <$> EJSON.arbitraryJsonEncodableEJsonOfSize 1)
      <|> QueryExpr <$> SC.arbitrary

type VarMap = SM.StrMap VarMapValue

-- | A VarMap passed through the URL - the VarMapValues are left unparsed until
-- | they are unified with the Variables card for the deck so that values can
-- | be parsed according to their defined type.
type URLVarMap = SM.StrMap String

emptyVarMap ∷ VarMap
emptyVarMap = SM.empty

escapeIdentifier ∷ String → String
escapeIdentifier str =
  if Regex.test identifier str
    then str
    else "`" <> Regex.replace tick "\\`" str <> "`"
  where
    identifier = Regex.unsafeRegex "^[_a-z][_a-z0-9]*$" Regex.ignoreCase
    tick = Regex.unsafeRegex "`" Regex.global

{-
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.Port.VarMap
  ( VarMap
  , URLVarMap
  , VarMapValue(..)
  , renderVarMapValue
  , emptyVarMap
  , escapeIdentifier
  ) where

import SlamData.Prelude

import Data.Foldable as F
import Data.HugeNum as HN
import Data.Json.Extended as EJSON
import Data.Json.Extended.Signature.Render as EJR
import Data.String.Regex (test, replace) as Regex
import Data.String.Regex.Flags (ignoreCase, global) as Regex
import Data.String.Regex.Unsafe (unsafeRegex) as Regex
import Data.StrMap as SM

import Data.Argonaut ((.?))
import Data.Argonaut.Core (jsonSingletonObject)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Encode (class EncodeJson, encodeJson)

import Matryoshka (Algebra, cata)

import Text.Markdown.SlamDown.Syntax.Value as SDV

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

data VarMapValue
  = Literal EJSON.EJson
  | SetLiteral (Array VarMapValue)
  | QueryExpr String -- TODO: syntax of SQL^2 queries

derive instance eqVarMapValue ∷ Eq VarMapValue

derive instance ordVarMapValue ∷ Ord VarMapValue

instance showVarMapValue ∷ Show VarMapValue where
  show = renderVarMapValue

instance encodeJsonVarMapValue ∷ EncodeJson VarMapValue where
  encodeJson v =
    case v of
      Literal ejson →
        jsonSingletonObject "literal" $
          EJSON.encodeEJson ejson
      SetLiteral as →
        jsonSingletonObject "set" $
          encodeJson as
      QueryExpr str →
        jsonSingletonObject "query" $
          encodeJson str

instance decodeJsonVarMapValue :: DecodeJson VarMapValue where
  decodeJson json = do
    obj <- decodeJson json
    decodeLiteral obj
      <|> decodeSetLiteral obj
      <|> decodeQueryExpr obj

    where
      decodeLiteral =
        (_ .? "literal")
          >=> EJSON.decodeEJson
          >>> map Literal

      decodeSetLiteral =
        (_ .? "set")
          >=> decodeJson
          >>> map SetLiteral

      decodeQueryExpr  =
        (_ .? "query")
          >>> map QueryExpr

renderVarMapValue
  ∷ VarMapValue
  → String
renderVarMapValue val =
  case val of
    Literal lit → EJSON.renderEJson lit
    SetLiteral as → "(" <> F.intercalate "," (renderVarMapValue <$> as) <> ")"
    QueryExpr str → str

displayVarMapValue
  ∷ VarMapValue
  → String
displayVarMapValue val =
  case val of
    Literal lit → displayEJson lit
    SetLiteral as → "(" <> F.intercalate ", " (displayVarMapValue <$> as) <> ")"
    QueryExpr str → str

displayEJsonF ∷ Algebra EJSON.EJsonF String
displayEJsonF =
  case _ of
    EJSON.Null → "null"
    EJSON.Boolean b → if b then "true" else "false"
    EJSON.Integer i → show i
    EJSON.Decimal a → HN.toString a
    EJSON.String str → str
    EJSON.Timestamp dt → EJR.renderTimestamp dt
    EJSON.Time t → EJR.renderTime t
    EJSON.Date d → EJR.renderDate d
    EJSON.Interval str → str
    EJSON.ObjectId str → str
    EJSON.Array ds → "[" <> commaSep ds <> "]"
    EJSON.Map (EJSON.EJsonMap ds) → "(" <> commaSep (map renderPair ds) <> ")"
  where
  commaSep ∷ Array String → String
  commaSep = F.intercalate ","
  renderPair ∷ Tuple String String → String
  renderPair (Tuple k v) = k <> ": " <> v

-- | A more readable, but forgetful renderer
displayEJson ∷ EJSON.EJson → String
displayEJson = cata displayEJsonF

instance valueVarMapValue ∷ SDV.Value VarMapValue where
  stringValue = Literal <<< EJSON.string
  renderValue = displayVarMapValue

instance arbitraryVarMapValue ∷ SC.Arbitrary VarMapValue where
  arbitrary =
    Literal <$> EJSON.arbitraryJsonEncodableEJsonOfSize 1
      <|> SetLiteral <$> Gen.arrayOf (Literal <$> EJSON.arbitraryJsonEncodableEJsonOfSize 1)
      <|> QueryExpr <$> SC.arbitrary

type VarMap = SM.StrMap VarMapValue

-- | A VarMap passed through the URL - the VarMapValues are left unparsed until
-- | they are unified with the Variables card for the deck so that values can
-- | be parsed according to their defined type.
type URLVarMap = SM.StrMap String

emptyVarMap ∷ VarMap
emptyVarMap = SM.empty

escapeIdentifier ∷ String → String
escapeIdentifier str =
  if Regex.test identifier str
    then str
    else "`" <> Regex.replace tick "\\`" str <> "`"
  where
    identifier = Regex.unsafeRegex "^[_a-z][_a-z0-9]*$" Regex.ignoreCase
    tick = Regex.unsafeRegex "`" Regex.global


Connection URI hide password fix

Connection URI hide password fix

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.FileSystem.Dialog.Mount.Component.Render (render) where

import Prelude

import Control.Alt ((<|>))

import Data.Array ((..), length, singleton)
import Data.Either (either)
import Data.Foldable (all)
import Data.Functor (($>))
import Data.Lens ((^.), (.~), TraversalP())
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.String.Regex as Rx
import Data.URI (printAbsoluteURI, runParseAbsoluteURI)

import Halogen
import Halogen.CustomProps as Cp
import Halogen.HTML.Events.Handler as E
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Events.Types (Event(), KeyboardEvent()) as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.Themes.Bootstrap3 as B

import SlamData.Dialog.Render (modalDialog, modalHeader, modalBody, modalFooter)
import SlamData.FileSystem.Dialog.Mount.Component.Query
import SlamData.FileSystem.Dialog.Mount.Component.State
import SlamData.Render.Common (fadeWhen, closeButton)
import SlamData.Render.CSS as Rc

render :: State -> ComponentHTML Query
render state =
  modalDialog
  [ modalHeader "Mount"
  , modalBody
    $ H.form [ Cp.nonSubmit, P.class_ Rc.dialogMount ]
    $ (if state.new then [ fldName state ] else [ ])
    <> [ fldConnectionURI state
       , selScheme state
       , userInfo state
       , hosts state
       , fldPath state
       , props state
       , errMessage state
       ]
  , modalFooter
    [ progressSpinner state
    , btnCancel
    , btnMount state
    ]
  ]

progressSpinner :: State -> ComponentHTML Query
progressSpinner state =
  H.img
    [ P.src "img/spin.gif"
    , P.class_ $ Rc.mountProgressSpinner state.inProgress
    ]

fldName :: State -> ComponentHTML Query
fldName state =
  H.div
    [ P.classes [B.formGroup, Rc.mountName] ]
    [ label "Name" [ input state _name [] ] ]

fldConnectionURI :: State -> ComponentHTML Query
fldConnectionURI state =
  H.div
    [ P.classes [B.formGroup, Rc.mountURI] ]
    [ label "URI"
        [ H.input
            [ P.class_ B.formControl
            , P.placeholder "Paste connection URI here"
            , P.value (hidePassword' state.connectionURI)
            , Cp.mbKeyDown clearText
            , Cp.mbKeyPress handleKeyInput
            -- In Chrome, this is used to prevent multiple values being pasted in the
            -- field - once pasted, the value is selected so that the new value replaces
            -- it.
            , Cp.onPaste (E.input (_.target >>> SelectElement))
            , E.onValueInput (E.input UpdateConnectionURI)
            ]
        ]
    ]

  where

  -- Delete the entire connection URI contents when backspace or delete is used.
  clearText :: E.Event E.KeyboardEvent -> E.EventHandler (Maybe (Query Unit))
  clearText e =
    if (e.keyCode == 8.0 || e.keyCode == 46.0)
    then E.preventDefault $> Just (action $ ClearValue e.target)
    else pure Nothing

  -- Ignore key inputs aside from Ctrl+V or Meta+V. When any other keypress is
  -- detected select the current contents instead.
  handleKeyInput :: E.Event E.KeyboardEvent -> E.EventHandler (Maybe (Query Unit))
  handleKeyInput e =
    if (e.ctrlKey || e.metaKey) && e.charCode == 118.0
    then pure Nothing
    else E.preventDefault $> Just (action $ SelectElement e.target)

  hidePassword' :: String -> String
  hidePassword' s = either (const s) go $ runParseAbsoluteURI s
    where
    go uri =
      printAbsoluteURI
        $ setURIPassword (hidePassword (passwordFromURI uri)) uri

selScheme :: State -> ComponentHTML Query
selScheme state =
  H.div [ P.class_ B.formGroup ]
  [ label "Scheme"
    [ H.select [ P.class_ B.formControl ]
      [ H.option_ [ H.text "mongodb" ] ]
    ]
  ]

hosts :: State -> ComponentHTML Query
hosts state =
  let allEmpty = isEmptyHost `all` state.hosts
  in H.div [ P.classes [B.formGroup, Rc.mountHostList] ]
     $ (\ix -> host state ix (ix > 0 && allEmpty)) <$> 0 .. (length state.hosts - 1)

host :: State -> Int -> Boolean -> ComponentHTML Query
host state index enabled =
  H.div [ P.class_ Rc.mountHost ]
  [ label "Host"
    [ input' rejectNonHostname state (_hosts <<< ix index <<< _host)
      [ P.disabled enabled ]
    ]
  , label "Port"
    [ input' rejectNonPort state (_hosts <<< ix index <<< _port)
      [ P.disabled enabled ]
    ]
  ]
  where
  rejectNonHostname :: String -> String
  rejectNonHostname = Rx.replace rxNonHostname ""

  rxNonHostname :: Rx.Regex
  rxNonHostname =
    Rx.regex "[^0-9a-z\\-\\._~%]" (Rx.noFlags { ignoreCase = true, global = true })

  rejectNonPort :: String -> String
  rejectNonPort = Rx.replace rxNonPort ""

  rxNonPort :: Rx.Regex
  rxNonPort = Rx.regex "[^0-9]" (Rx.noFlags { global = true })

fldPath :: State -> ComponentHTML Query
fldPath state =
  H.div [ P.classes [ B.formGroup, Rc.mountPath ] ]
  [ label "Path" [ input state _path [] ] ]

userInfo :: State -> ComponentHTML Query
userInfo state =
  H.div [ P.classes [B.formGroup, Rc.mountUserInfo] ]
        [ fldUser state
        , fldPass state
        ]

fldUser :: State -> ComponentHTML Query
fldUser state = label "Username" [ input state _user [] ]

fldPass :: State -> ComponentHTML Query
fldPass state = label "Password" [ input state _password [ P.inputType P.InputPassword ] ]

props :: State -> ComponentHTML Query
props state =
  H.div [ P.classes [B.formGroup, Rc.mountProps] ]
  [ label "Properties" []
  , H.table [ P.classes [B.table, B.tableBordered] ]
    [ H.thead_
      [ H.tr_ [ H.th_ [ H.text "Name" ]
              , H.th_ [ H.text "Value" ]
              ]
      ]
    , H.tbody_
      [ H.tr_ [ H.td [ P.colSpan 2 ]
                [ H.div [ P.class_ Rc.mountPropsScrollbox ]
                  [ H.table_ $ (prop state) <$> 0 .. (length state.props - 1) ]
                ]
              ]
      ]
    ]
  ]

prop :: State -> Int -> ComponentHTML Query
prop state index =
  H.tr_ [ H.td_
          [ input state (_props <<< ix index <<< _name)
            [ P.classes [B.formControl, B.inputSm] ]
          ]
        , H.td_
          [ input state (_props <<< ix index <<< _value)
            [ P.classes [B.formControl, B.inputSm] ]
          ]
        ]

errMessage :: State -> ComponentHTML Query
errMessage state =
  let msg = state.message <|> state.externalValidationError
  in H.div [ P.classes ([ B.alert, B.alertDanger, B.alertDismissable ]
                        <> (fadeWhen $ isNothing msg)
                       )
           ]
     $ [ closeButton (E.input_ Dismiss) ]
     <> maybe [ ] (singleton <<< H.text) msg

btnCancel :: ComponentHTML Query
btnCancel =
  H.button [ P.classes [B.btn]
           , E.onClick (E.input_ Dismiss)
           ]
  [ H.text "Cancel" ]

btnMount :: State -> ComponentHTML Query
btnMount state =
  let text = if state.new
             then "Mount"
             else "Save changes"
      enabled = state.valid && not state.inProgress
  in H.button [ P.classes [B.btn, B.btnPrimary]
              , P.disabled (not enabled)
              , E.onClick (E.input_ Save)
              ]
     [ H.text text ]

-- | A labelled section within the form.
label :: forall i p. String -> Array (HTML p i) -> HTML p i
label text inner = H.label_ $ [ H.span_ [ H.text text ] ] ++ inner

-- | A basic text input field that uses a lens to read from and update the
-- | state.
input :: forall p. State -> TraversalP State String
                  -> Array (Cp.InputProp Query) -> HTML p Query
input state lens = input' id state lens -- can't eta reduce further here as the typechecker doesn't like it

-- | A basic text input field that uses a lens to read from and update the
-- | state, and allows for the input value to be modified.
input'
  :: forall p
   . (String -> String)
  -> State
  -> TraversalP State String
  -> Array (Cp.InputProp Query)
  -> HTML p Query
input' f state lens attrs =
  H.input ([ P.class_ B.formControl
           , E.onValueInput (E.input \val -> ModifyState (lens .~ f val))
           , P.value (state ^. lens)
           ] ++ attrs)

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.FileSystem.Dialog.Mount.Component.Render (render) where

import Prelude

import Control.Alt ((<|>))

import Data.Array ((..), length, singleton)
import Data.Either (either)
import Data.Foldable (all)
import Data.Functor (($>))
import Data.Lens ((^.), (.~), TraversalP())
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.String.Regex as Rx
import Data.URI (printAbsoluteURI, runParseAbsoluteURI)

import Halogen
import Halogen.CustomProps as Cp
import Halogen.HTML.Events.Handler as E
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Events.Types (Event(), KeyboardEvent()) as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.Themes.Bootstrap3 as B

import SlamData.Dialog.Render (modalDialog, modalHeader, modalBody, modalFooter)
import SlamData.FileSystem.Dialog.Mount.Component.Query
import SlamData.FileSystem.Dialog.Mount.Component.State
import SlamData.Render.Common (fadeWhen, closeButton)
import SlamData.Render.CSS as Rc

render :: State -> ComponentHTML Query
render state =
  modalDialog
  [ modalHeader "Mount"
  , modalBody
    $ H.form [ Cp.nonSubmit, P.class_ Rc.dialogMount ]
    $ (if state.new then [ fldName state ] else [ ])
    <> [ fldConnectionURI state
       , selScheme state
       , userInfo state
       , hosts state
       , fldPath state
       , props state
       , errMessage state
       ]
  , modalFooter
    [ progressSpinner state
    , btnCancel
    , btnMount state
    ]
  ]

progressSpinner :: State -> ComponentHTML Query
progressSpinner state =
  H.img
    [ P.src "img/spin.gif"
    , P.class_ $ Rc.mountProgressSpinner state.inProgress
    ]

fldName :: State -> ComponentHTML Query
fldName state =
  H.div
    [ P.classes [B.formGroup, Rc.mountName] ]
    [ label "Name" [ input state _name [] ] ]

fldConnectionURI :: State -> ComponentHTML Query
fldConnectionURI state =
  H.div
    [ P.classes [B.formGroup, Rc.mountURI] ]
    [ label "URI"
        [ H.input
            [ P.class_ B.formControl
            , P.placeholder "Paste connection URI here"
            , P.value (hidePassword state.connectionURI)
            , Cp.mbKeyDown clearText
            , Cp.mbKeyPress handleKeyInput
            -- In Chrome, this is used to prevent multiple values being pasted in the
            -- field - once pasted, the value is selected so that the new value replaces
            -- it.
            , Cp.onPaste (E.input (_.target >>> SelectElement))
            , E.onValueInput (E.input UpdateConnectionURI)
            ]
        ]
    ]

  where

  -- Delete the entire connection URI contents when backspace or delete is used.
  clearText :: E.Event E.KeyboardEvent -> E.EventHandler (Maybe (Query Unit))
  clearText e =
    if (e.keyCode == 8.0 || e.keyCode == 46.0)
    then E.preventDefault $> Just (action $ ClearValue e.target)
    else pure Nothing

  -- Ignore key inputs aside from Ctrl+V or Meta+V. When any other keypress is
  -- detected select the current contents instead.
  handleKeyInput :: E.Event E.KeyboardEvent -> E.EventHandler (Maybe (Query Unit))
  handleKeyInput e =
    if (e.ctrlKey || e.metaKey) && e.charCode == 118.0
    then pure Nothing
    else E.preventDefault $> Just (action $ SelectElement e.target)

  hidePassword :: String -> String
  hidePassword s = either (const s) go $ runParseAbsoluteURI s
    where
    go uri = printAbsoluteURI
             $ setURIPassword (hidePassword (passwordFromURI uri)) uri

selScheme :: State -> ComponentHTML Query
selScheme state =
  H.div [ P.class_ B.formGroup ]
  [ label "Scheme"
    [ H.select [ P.class_ B.formControl ]
      [ H.option_ [ H.text "mongodb" ] ]
    ]
  ]

hosts :: State -> ComponentHTML Query
hosts state =
  let allEmpty = isEmptyHost `all` state.hosts
  in H.div [ P.classes [B.formGroup, Rc.mountHostList] ]
     $ (\ix -> host state ix (ix > 0 && allEmpty)) <$> 0 .. (length state.hosts - 1)

host :: State -> Int -> Boolean -> ComponentHTML Query
host state index enabled =
  H.div [ P.class_ Rc.mountHost ]
  [ label "Host"
    [ input' rejectNonHostname state (_hosts <<< ix index <<< _host)
      [ P.disabled enabled ]
    ]
  , label "Port"
    [ input' rejectNonPort state (_hosts <<< ix index <<< _port)
      [ P.disabled enabled ]
    ]
  ]
  where
  rejectNonHostname :: String -> String
  rejectNonHostname = Rx.replace rxNonHostname ""

  rxNonHostname :: Rx.Regex
  rxNonHostname =
    Rx.regex "[^0-9a-z\\-\\._~%]" (Rx.noFlags { ignoreCase = true, global = true })

  rejectNonPort :: String -> String
  rejectNonPort = Rx.replace rxNonPort ""

  rxNonPort :: Rx.Regex
  rxNonPort = Rx.regex "[^0-9]" (Rx.noFlags { global = true })

fldPath :: State -> ComponentHTML Query
fldPath state =
  H.div [ P.classes [ B.formGroup, Rc.mountPath ] ]
  [ label "Path" [ input state _path [] ] ]

userInfo :: State -> ComponentHTML Query
userInfo state =
  H.div [ P.classes [B.formGroup, Rc.mountUserInfo] ]
        [ fldUser state
        , fldPass state
        ]

fldUser :: State -> ComponentHTML Query
fldUser state = label "Username" [ input state _user [] ]

fldPass :: State -> ComponentHTML Query
fldPass state = label "Password" [ input state _password [ P.inputType P.InputPassword ] ]

props :: State -> ComponentHTML Query
props state =
  H.div [ P.classes [B.formGroup, Rc.mountProps] ]
  [ label "Properties" []
  , H.table [ P.classes [B.table, B.tableBordered] ]
    [ H.thead_
      [ H.tr_ [ H.th_ [ H.text "Name" ]
              , H.th_ [ H.text "Value" ]
              ]
      ]
    , H.tbody_
      [ H.tr_ [ H.td [ P.colSpan 2 ]
                [ H.div [ P.class_ Rc.mountPropsScrollbox ]
                  [ H.table_ $ (prop state) <$> 0 .. (length state.props - 1) ]
                ]
              ]
      ]
    ]
  ]

prop :: State -> Int -> ComponentHTML Query
prop state index =
  H.tr_ [ H.td_
          [ input state (_props <<< ix index <<< _name)
            [ P.classes [B.formControl, B.inputSm] ]
          ]
        , H.td_
          [ input state (_props <<< ix index <<< _value)
            [ P.classes [B.formControl, B.inputSm] ]
          ]
        ]

errMessage :: State -> ComponentHTML Query
errMessage state =
  let msg = state.message <|> state.externalValidationError
  in H.div [ P.classes ([ B.alert, B.alertDanger, B.alertDismissable ]
                        <> (fadeWhen $ isNothing msg)
                       )
           ]
     $ [ closeButton (E.input_ Dismiss) ]
     <> maybe [ ] (singleton <<< H.text) msg

btnCancel :: ComponentHTML Query
btnCancel =
  H.button [ P.classes [B.btn]
           , E.onClick (E.input_ Dismiss)
           ]
  [ H.text "Cancel" ]

btnMount :: State -> ComponentHTML Query
btnMount state =
  let text = if state.new
             then "Mount"
             else "Save changes"
      enabled = state.valid && not state.inProgress
  in H.button [ P.classes [B.btn, B.btnPrimary]
              , P.disabled (not enabled)
              , E.onClick (E.input_ Save)
              ]
     [ H.text text ]

-- | A labelled section within the form.
label :: forall i p. String -> Array (HTML p i) -> HTML p i
label text inner = H.label_ $ [ H.span_ [ H.text text ] ] ++ inner

-- | A basic text input field that uses a lens to read from and update the
-- | state.
input :: forall p. State -> TraversalP State String
                  -> Array (Cp.InputProp Query) -> HTML p Query
input state lens = input' id state lens -- can't eta reduce further here as the typechecker doesn't like it

-- | A basic text input field that uses a lens to read from and update the
-- | state, and allows for the input value to be modified.
input'
  :: forall p
   . (String -> String)
  -> State
  -> TraversalP State String
  -> Array (Cp.InputProp Query)
  -> HTML p Query
input' f state lens attrs =
  H.input ([ P.class_ B.formControl
           , E.onValueInput (E.input \val -> ModifyState (lens .~ f val))
           , P.value (state ^. lens)
           ] ++ attrs)


Update Chapter1.purs (#36)

Update Chapter1.purs (#36)

Fix typo on Level 1.2

module Levels.Chapter1 where

import Prelude
import Data.List (List(..), reverse, snoc, filter, (:), elemIndex)
import Data.Maybe (Maybe(..), isJust)

import Helper (fromArray, (:->), (:>))
import Transformer (clearEmpty, mapReject, replaceMultiple)
import Types (Chapter, Cube(..), Difficulty(..))

contains :: forall a. (Eq a) => a -> List a -> Boolean
contains x xs = isJust $ elemIndex x xs

chapter1 :: Chapter
chapter1 = {
    name: "Chapter 1",

    transformers: fromArray [
        "mapYtoYR" :> {
            name: "map {Yellow}↦[{Red}{Yellow}]",
            function: replaceMultiple Yellow (Yellow : Red : Nil)
        },
        "mapCtoRC" :> {
            name: "map {Cyan}↦[{Cyan}{Red}]",
            function: replaceMultiple Cyan (Red : Cyan : Nil)
        },
        "rejectY" :> {
            name: "map (reject {Yellow})",
            function: mapReject Yellow
        },
        "rejectC" :> {
            name: "map (reject {Cyan})",
            function: mapReject Cyan
        },
        "filterContainsR" :> {
            name: "filter (contains {Red})",
            function: filter (contains Red) >>> clearEmpty
        },
        "stackR" :> {
            name: "map (stack {Red})",
            function: map (_ `snoc` Red)
        },
        "mapReverse" :> {
            name: "map reverse",
            function: map reverse
        }
    ],

    levels: fromArray [
        "1.1" :-> {
            name: "Mercury",
            help: Just """There are some new types of functions in this chapter. We will
                          introduce them when they are needed. Note that you can always
                          skip levels and come back later.""",
            difficulty: Easy,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red, Red], [Red, Yellow, Red], [Red, Yellow, Red], [Red, Red, Red]]
        },
        "1.2" :-> {
            name: "Venus",
            help: Just """The function `filterContainsR` removes columns without a red cube.""",
            difficulty: Medium,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red], [Red, Red]]
        },
        "1.3" :-> {
            name: "Earth",
            help: Just """You can flip each column vertically with `mapReverse`.""",
            difficulty: Easy,
            initial: [[Cyan, Cyan, Yellow], [Cyan, Red], [Cyan, Red], [Cyan, Cyan, Yellow]],
            target: [[Red, Cyan, Cyan], [Red, Cyan], [Red, Cyan], [Red, Cyan, Cyan]]
        },
        "1.4" :-> {
            name: "Mars",
            help: Just """In case you were wondering: the level names <s>have a rather deep
                          philosophical meaning</s> are chosen randomly.""",
            difficulty: Medium,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red], [Red, Red], [Red, Red], [Red, Red]]
        }
    ]
}

module Levels.Chapter1 where

import Prelude
import Data.List (List(..), reverse, snoc, filter, (:), elemIndex)
import Data.Maybe (Maybe(..), isJust)

import Helper (fromArray, (:->), (:>))
import Transformer (clearEmpty, mapReject, replaceMultiple)
import Types (Chapter, Cube(..), Difficulty(..))

contains :: forall a. (Eq a) => a -> List a -> Boolean
contains x xs = isJust $ elemIndex x xs

chapter1 :: Chapter
chapter1 = {
    name: "Chapter 1",

    transformers: fromArray [
        "mapYtoYR" :> {
            name: "map {Yellow}↦[{Red}{Yellow}]",
            function: replaceMultiple Yellow (Yellow : Red : Nil)
        },
        "mapCtoRC" :> {
            name: "map {Cyan}↦[{Cyan}{Red}]",
            function: replaceMultiple Cyan (Red : Cyan : Nil)
        },
        "rejectY" :> {
            name: "map (reject {Yellow})",
            function: mapReject Yellow
        },
        "rejectC" :> {
            name: "map (reject {Cyan})",
            function: mapReject Cyan
        },
        "filterContainsR" :> {
            name: "filter (contains {Red})",
            function: filter (contains Red) >>> clearEmpty
        },
        "stackR" :> {
            name: "map (stack {Red})",
            function: map (_ `snoc` Red)
        },
        "mapReverse" :> {
            name: "map reverse",
            function: map reverse
        }
    ],

    levels: fromArray [
        "1.1" :-> {
            name: "Mercury",
            help: Just """There are some new types of functions in this chapter. We will
                          introduce them when they are needed. Note that you can always
                          skip levels and come back later.""",
            difficulty: Easy,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red, Red], [Red, Yellow, Red], [Red, Yellow, Red], [Red, Red, Red]]
        },
        "1.2" :-> {
            name: "Venus",
            help: Just """The function `filterContainsR` removes colums without a red cube.""",
            difficulty: Medium,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red], [Red, Red]]
        },
        "1.3" :-> {
            name: "Earth",
            help: Just """You can flip each column vertically with `mapReverse`.""",
            difficulty: Easy,
            initial: [[Cyan, Cyan, Yellow], [Cyan, Red], [Cyan, Red], [Cyan, Cyan, Yellow]],
            target: [[Red, Cyan, Cyan], [Red, Cyan], [Red, Cyan], [Red, Cyan, Cyan]]
        },
        "1.4" :-> {
            name: "Mars",
            help: Just """In case you were wondering: the level names <s>have a rather deep
                          philosophical meaning</s> are chosen randomly.""",
            difficulty: Medium,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red], [Red, Red], [Red, Red], [Red, Red]]
        }
    ]
}


Added missing cases to keyboard state to vector conversion function.

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 0.0 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | Angle change is velocity multiplied by time
angleFromVelocity :: RadiansPerSecond -> Seconds -> Radians
angleFromVelocity v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 0.1

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: true, a: true, d: true, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: true, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: true}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: true}) = i3
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * angleFromVelocity angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale movementRate $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw + dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 0.0 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | Angle change is velocity multiplied by time
angleFromVelocity :: RadiansPerSecond -> Seconds -> Radians
angleFromVelocity v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 0.1

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = scale (-1.0) k3
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = scale (-1.0) i3
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * angleFromVelocity angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale movementRate $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw + dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p


Return Arrays instead of HTMLCollection, fixes https://github.com/aktowns/purescript-simple-dom/issues/25

module Data.DOM.Simple.Unsafe.Element where

import DOM
import Control.Monad.Eff

import Data.DOM.Simple.Types

foreign import unsafeGetElementById
  """
  function unsafeGetElementById(targ_id) {
    return function (src) {
      return function () {
        return src.getElementById(targ_id);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import unsafeGetElementsByClassName
  """
  function unsafeGetElementsByClassName(targ_id) {
    return function (src) {
      return function () {
        return Array.prototype.slice.call(src.getElementsByClassName(targ_id));
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeGetElementsByName
  """
  function unsafeGetElementsByName(targ_id) {
    return function (src) {
      return function () {
        return Array.prototype.slice.call(src.getElementsByName(targ_id));
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeQuerySelector
  """
  function unsafeQuerySelector(selector) {
    return function (src) {
      return function () {
        return src.querySelector(selector);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import unsafeQuerySelectorAll
  """
  function unsafeQuerySelectorAll(selector) {
    return function (src) {
      return function () {
        return src.querySelectorAll(selector);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) NodeList)

foreign import unsafeGetAttribute
  """
  function unsafeGetAttribute(name) {
    return function (src) {
      return function () {
        return src.getAttribute(name);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetAttribute
  """
  function unsafeSetAttribute(name) {
    return function (value) {
      return function (src) {
        return function () {
          src.setAttribute(name, value);
          return {};
        };
      };
    };
  }""" :: forall eff a. String -> String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeHasAttribute
  """
  function unsafeHasAttribute(name) {
    return function (src) {
      return function () {
        return src.hasAttribute(name);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Boolean)

foreign import unsafeRemoveAttribute
  """
  function unsafeRemoveAttribute(name) {
    return function (src) {
      return function () {
        src.removeAttribute(name);
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeGetStyleAttr
  """
  function unsafeGetStyleAttr(name) {
    return function (src) {
      return function () {
        return src.style[name];
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetStyleAttr
  """
  function unsafeSetStyleAttr(name) {
    return function (value) {
      return function (src) {
        return function () {
          src.style[name] = value;
          return {};
        };
      };
    };
  }""" :: forall eff a. String -> String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeChildren
  """
  function unsafeChildren(src) {
    return function () {
      return Array.prototype.slice.call(src.children);
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeAppendChild
  """
  function unsafeAppendChild(src) {
    return function (child) {
      return function () {
        return src.appendChild(child);
      };
    };
  }""" :: forall eff a. a -> HTMLElement -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeInnerHTML
  """
  function unsafeInnerHTML(src) {
    return function () {
      return src.innerHTML;
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetInnerHTML
  """
  function unsafeSetInnerHTML(value) {
    return function (src) {
      return function () {
        src.innerHTML = value;
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeTextContent
  """
  function unsafeTextContent(src) {
    return function () {
      return src.textContent;
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetTextContent
  """
  function unsafeSetTextContent(value) {
    return function (src) {
      return function () {
        src.textContent = value;
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeValue
  """
  function unsafeValue(src) {
    return function () {
      return src.value;
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetValue
  """
  function unsafeSetValue(value) {
    return function (src) {
      return function () {
        src.value = value;
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeContentWindow
  """
  function unsafeContentWindow(obj) {
    return function () {
      return obj.contentWindow;
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) HTMLWindow)

foreign import unsafeClassAdd
  """
  function unsafeClassAdd(value) {
    return function (src) {
      return function () {
        src.classList.add(value);
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeClassRemove
  """
  function unsafeClassRemove(value) {
    return function (src) {
      return function () {
        src.classList.remove(value);
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeClassToggle
  """
  function unsafeClassToggle(value) {
    return function (src) {
      return function () {
        src.classList.toggle(value);
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeClassContains
  """
  function unsafeClassContains(value) {
    return function (src) {
      return function () {
        return src.classList.contains(value);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Boolean)

foreign import unsafeClick
  """
  function unsafeClick(src) {
    return function () {
      src.click();
      return {};
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeFocus
  """
  function unsafeFocus(src) {
    return function () {
      src.focus();
      return {};
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeBlur
  """
  function unsafeBlur(src) {
    return function () {
      src.blur();
      return {};
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) Unit)

module Data.DOM.Simple.Unsafe.Element where

import DOM
import Control.Monad.Eff

import Data.DOM.Simple.Types

foreign import unsafeGetElementById
  """
  function unsafeGetElementById(targ_id) {
    return function (src) {
      return function () {
        return src.getElementById(targ_id);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import unsafeGetElementsByClassName
  """
  function unsafeGetElementsByClassName(targ_id) {
    return function (src) {
      return function () {
        return src.getElementsByClassName(targ_id);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeGetElementsByName
  """
  function unsafeGetElementsByName(targ_id) {
    return function (src) {
      return function () {
        return src.getElementsByName(targ_id);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeQuerySelector
  """
  function unsafeQuerySelector(selector) {
    return function (src) {
      return function () {
        return src.querySelector(selector);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) HTMLElement)

foreign import unsafeQuerySelectorAll
  """
  function unsafeQuerySelectorAll(selector) {
    return function (src) {
      return function () {
        return src.querySelectorAll(selector);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) NodeList)

foreign import unsafeGetAttribute
  """
  function unsafeGetAttribute(name) {
    return function (src) {
      return function () {
        return src.getAttribute(name);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetAttribute
  """
  function unsafeSetAttribute(name) {
    return function (value) {
      return function (src) {
        return function () {
          src.setAttribute(name, value);
          return {};
        };
      };
    };
  }""" :: forall eff a. String -> String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeHasAttribute
  """
  function unsafeHasAttribute(name) {
    return function (src) {
      return function () {
        return src.hasAttribute(name);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Boolean)

foreign import unsafeRemoveAttribute
  """
  function unsafeRemoveAttribute(name) {
    return function (src) {
      return function () {
        src.removeAttribute(name);
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeGetStyleAttr
  """
  function unsafeGetStyleAttr(name) {
    return function (src) {
      return function () {
        return src.style[name];
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetStyleAttr
  """
  function unsafeSetStyleAttr(name) {
    return function (value) {
      return function (src) {
        return function () {
          src.style[name] = value;
          return {};
        };
      };
    };
  }""" :: forall eff a. String -> String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeChildren
  """
  function unsafeChildren(src) {
    return function () {
      return src.children;
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) [HTMLElement])

foreign import unsafeAppendChild
  """
  function unsafeAppendChild(src) {
    return function (child) {
      return function () {
        return src.appendChild(child);
      };
    };
  }""" :: forall eff a. a -> HTMLElement -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeInnerHTML
  """
  function unsafeInnerHTML(src) {
    return function () {
      return src.innerHTML;
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetInnerHTML
  """
  function unsafeSetInnerHTML(value) {
    return function (src) {
      return function () {
        src.innerHTML = value;
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeTextContent
  """
  function unsafeTextContent(src) {
    return function () {
      return src.textContent;
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetTextContent
  """
  function unsafeSetTextContent(value) {
    return function (src) {
      return function () {
        src.textContent = value;
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeValue
  """
  function unsafeValue(src) {
    return function () {
      return src.value;
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetValue
  """
  function unsafeSetValue(value) {
    return function (src) {
      return function () {
        src.value = value;
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeContentWindow
  """
  function unsafeContentWindow(obj) {
    return function () {
      return obj.contentWindow;
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) HTMLWindow)

foreign import unsafeClassAdd
  """
  function unsafeClassAdd(value) {
    return function (src) {
      return function () {
        src.classList.add(value);
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeClassRemove
  """
  function unsafeClassRemove(value) {
    return function (src) {
      return function () {
        src.classList.remove(value);
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeClassToggle
  """
  function unsafeClassToggle(value) {
    return function (src) {
      return function () {
        src.classList.toggle(value);
        return {};
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeClassContains
  """
  function unsafeClassContains(value) {
    return function (src) {
      return function () {
        return src.classList.contains(value);
      };
    };
  }""" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Boolean)

foreign import unsafeClick
  """
  function unsafeClick(src) {
    return function () {
      src.click();
      return {};
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeFocus
  """
  function unsafeFocus(src) {
    return function () {
      src.focus();
      return {};
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeBlur
  """
  function unsafeBlur(src) {
    return function () {
      src.blur();
      return {};
    };
  }""" :: forall eff a. a -> (Eff (dom :: DOM | eff) Unit)


[CSE-174] Remove deprecated API endpoints

from front-end:
* `api/blocks/total`
* `api/blocks/last`

module Explorer.Api.Http where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Core (Json)
import Data.Either (Either(..), either)
import Data.Generic (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple)
import Explorer.Api.Helper (decodeResult)
import Explorer.Api.Types (Endpoint, EndpointError(..), RequestLimit(..), RequestOffset(..))
import Explorer.Types.State (CBlockEntries, CTxBriefs, CTxEntries, PageNumber(..), PageSize(..))
import Network.HTTP.Affjax (AJAX, AffjaxRequest, affjax, defaultRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.StatusCode (StatusCode(..))
import Pos.Core.Lenses.Types (_EpochIndex, _LocalSlotIndex, getEpochIndex, getSlotIndex)
import Pos.Core.Types (EpochIndex, LocalSlotIndex)
import Pos.Explorer.Web.ClientTypes (CAddress(..), CAddressSummary, CBlockSummary, CHash(..), CTxId, CTxSummary)
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId)

endpointPrefix :: String
endpointPrefix = "/api/"

-- result helper

decodeResponse :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResponse = decodeResult <<< _.response

request :: forall a r eff. Generic a => Requestable r => AffjaxRequest r ->
    Endpoint -> Aff (ajax :: AJAX | eff) a
request req endpoint = do
    result <- affjax $ req { url = endpointPrefix <> endpoint }
    when (isHttpError result.status) $
        throwError <<< error <<< show $ HTTPStatusError result
    either throwError pure $ decodeResponse result
    where
      isHttpError (StatusCode c) = c >= 400

get :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
get e = request defaultRequest e

post :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
post = request $ defaultRequest { method = Left POST }

-- api

-- blocks

fetchBlocksTotalPages :: forall eff. Aff (ajax::AJAX | eff) Int
fetchBlocksTotalPages = get "blocks/pages/total"

fetchPageBlocks :: forall eff. PageNumber -> PageSize -> Aff (ajax::AJAX | eff) (Tuple Int CBlockEntries)
fetchPageBlocks (PageNumber pNumber) (PageSize pSize) =
    get $ "blocks/pages/?page=" <> show pNumber <> "&pageSize=" <> show pSize

fetchBlockSummary :: forall eff. CHash -> Aff (ajax::AJAX | eff) CBlockSummary
fetchBlockSummary (CHash hash) = get $ "blocks/summary/" <> hash

fetchBlockTxs :: forall eff. CHash -> Aff (ajax::AJAX | eff) CTxBriefs
fetchBlockTxs (CHash hash) = get $ "blocks/txs/" <> hash

-- txs
fetchLatestTxs :: forall eff. RequestLimit -> RequestOffset -> Aff (ajax::AJAX | eff) CTxEntries
fetchLatestTxs (RequestLimit limit) (RequestOffset offset) =
    get $ "txs/last/?limit=" <> show limit <> "&offset=" <> show offset

fetchTxSummary :: forall eff. CTxId -> Aff (ajax::AJAX | eff) CTxSummary
fetchTxSummary id = get $ "txs/summary/" <> id ^. (_CTxId <<< _CHash)

-- addresses
fetchAddressSummary :: forall eff. CAddress -> Aff (ajax::AJAX | eff) CAddressSummary
fetchAddressSummary (CAddress address) = get $ "addresses/summary/" <> address

-- search by epoch / slot
searchEpoch :: forall eff. EpochIndex -> Maybe LocalSlotIndex -> Aff (ajax::AJAX | eff) CBlockEntries
searchEpoch epoch mSlot = get $ "search/epoch/" <> show epochIndex <> slotQuery mSlot
  where
      slotQuery Nothing = ""
      slotQuery (Just slot) = "?slot=" <> show (slot ^. (_LocalSlotIndex <<< getSlotIndex))

      epochIndex = epoch ^. (_EpochIndex <<< getEpochIndex)

module Explorer.Api.Http where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Core (Json)
import Data.Either (Either(..), either)
import Data.Generic (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple)
import Explorer.Api.Helper (decodeResult)
import Explorer.Api.Types (Endpoint, EndpointError(..), RequestLimit(..), RequestOffset(..))
import Explorer.Types.State (CBlockEntries, CTxBriefs, CTxEntries, PageNumber(..), PageSize(..))
import Network.HTTP.Affjax (AJAX, AffjaxRequest, affjax, defaultRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.StatusCode (StatusCode(..))
import Pos.Core.Lenses.Types (_EpochIndex, _LocalSlotIndex, getEpochIndex, getSlotIndex)
import Pos.Core.Types (EpochIndex, LocalSlotIndex)
import Pos.Explorer.Web.ClientTypes (CAddress(..), CAddressSummary, CBlockSummary, CHash(..), CTxId, CTxSummary)
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId)

endpointPrefix :: String
endpointPrefix = "/api/"

-- result helper

decodeResponse :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResponse = decodeResult <<< _.response

request :: forall a r eff. Generic a => Requestable r => AffjaxRequest r ->
    Endpoint -> Aff (ajax :: AJAX | eff) a
request req endpoint = do
    result <- affjax $ req { url = endpointPrefix <> endpoint }
    when (isHttpError result.status) $
        throwError <<< error <<< show $ HTTPStatusError result
    either throwError pure $ decodeResponse result
    where
      isHttpError (StatusCode c) = c >= 400

get :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
get e = request defaultRequest e

post :: forall eff a. Generic a => Endpoint -> Aff (ajax :: AJAX | eff) a
post = request $ defaultRequest { method = Left POST }

-- api

-- blocks
fetchTotalBlocks :: forall eff. Aff (ajax::AJAX | eff) Int
fetchTotalBlocks = get "blocks/total"

fetchBlocksTotalPages :: forall eff. Aff (ajax::AJAX | eff) Int
fetchBlocksTotalPages = get "blocks/pages/total"

fetchLatestBlocks :: forall eff. RequestLimit -> RequestOffset -> Aff (ajax::AJAX | eff) CBlockEntries
fetchLatestBlocks (RequestLimit limit) (RequestOffset offset) = get $ "blocks/last/?limit=" <> show limit <> "&offset=" <> show offset

fetchPageBlocks :: forall eff. PageNumber -> PageSize -> Aff (ajax::AJAX | eff) (Tuple Int CBlockEntries)
fetchPageBlocks (PageNumber pNumber) (PageSize pSize) =
    get $ "blocks/pages/?page=" <> show pNumber <> "&pageSize=" <> show pSize

fetchBlockSummary :: forall eff. CHash -> Aff (ajax::AJAX | eff) CBlockSummary
fetchBlockSummary (CHash hash) = get $ "blocks/summary/" <> hash

fetchBlockTxs :: forall eff. CHash -> Aff (ajax::AJAX | eff) CTxBriefs
fetchBlockTxs (CHash hash) = get $ "blocks/txs/" <> hash

-- txs
fetchLatestTxs :: forall eff. RequestLimit -> RequestOffset -> Aff (ajax::AJAX | eff) CTxEntries
fetchLatestTxs (RequestLimit limit) (RequestOffset offset) =
    get $ "txs/last/?limit=" <> show limit <> "&offset=" <> show offset

fetchTxSummary :: forall eff. CTxId -> Aff (ajax::AJAX | eff) CTxSummary
fetchTxSummary id = get $ "txs/summary/" <> id ^. (_CTxId <<< _CHash)

-- addresses
fetchAddressSummary :: forall eff. CAddress -> Aff (ajax::AJAX | eff) CAddressSummary
fetchAddressSummary (CAddress address) = get $ "addresses/summary/" <> address

-- search by epoch / slot
searchEpoch :: forall eff. EpochIndex -> Maybe LocalSlotIndex -> Aff (ajax::AJAX | eff) CBlockEntries
searchEpoch epoch mSlot = get $ "search/epoch/" <> show epochIndex <> slotQuery mSlot
  where
      slotQuery Nothing = ""
      slotQuery (Just slot) = "?slot=" <> show (slot ^. (_LocalSlotIndex <<< getSlotIndex))

      epochIndex = epoch ^. (_EpochIndex <<< getEpochIndex)


fixes Emitting Messages

fixes Emitting Messages

module Openspace.Ui.Stream where

import Rx.Observable
import Data.Either
import Control.Monad.Eff
import Control.Monad.ST
import DOM

import Openspace.Ui.Render
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Types
import Openspace.Engine
import Openspace.Network.Socket

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- "message" `socketObserver'` socket
  return $ actionFromForeign parseAction id <$> onReceive

dragStream :: forall eff. Eff( dom :: DOM| eff) (Observable Action)
dragStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left e -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

      dragOverTrash = const DeleteTopic <$> lookup "dragOverTrash"

      -- HTML 5 fires dragLeave before dragEnd occurs
      -- TODO: Find a cleaner solution
      dragLeave = delay 30 $ const UnassignTopic
                  <$> lookup "dragLeaveSlot" `merge` lookup "dragLeaveTrash"

      dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

      dragStart = parseTopic <<< getDetail
                  <$> lookup "dragStartTopic" `merge` lookup "dragStartGridTopic"

      dragTopic = do Right t <- dragStart
                     action <- dragOver
                     lookup "dragEndTopic" `merge` lookup "dragEndGridTopic"
                     return $ action t
  return dragTopic

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      addTopic    = (actionFromForeign parseTopic AddTopic) <<< getDetail
                    <$> lookup "addTopic"
      addRoom     = (actionFromForeign parseRoom AddRoom) <<< getDetail
                    <$> lookup "addRoom"
      removeRoom  = (actionFromForeign parseRoom DeleteRoom) <<< getDetail
                    <$> lookup "deleteRoom"
      addBlock    = (actionFromForeign parseBlock AddBlock) <<< getDetail
                    <$> lookup "addBlock"
      deleteBlock = (actionFromForeign parseBlock DeleteBlock) <<< getDetail
                    <$> lookup "deleteBlock"
      changeGrid = addRoom `merge` removeRoom `merge` addBlock `merge` deleteBlock
  dragTopic <- dragStream
  return $ addTopic `merge` dragTopic `merge` changeGrid

main = do
  -- TODO: getSocket :: Either SockErr Socket
  -- let sockEmitter = getSocket "http://localhost:3000"
  -- until Websocket support is given by the server
  let sockEmitter = EmptySocket
  -- Initial State
  appSt <- newSTRef myState1
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp
  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  subscribe ui (\a -> emitAction sockEmitter (serialize a))
  -- Evaluate Action Observables
  let actions = ui `merge` net
  subscribe actions (\a -> modifySTRef appSt (evalAction a) >>= renderApp)

module Openspace.Ui.Stream where

import Rx.Observable
import Data.Either
import Control.Monad.Eff
import Control.Monad.ST
import DOM

import Openspace.Ui.Render
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Types
import Openspace.Engine
import Openspace.Network.Socket

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- "message" `socketObserver'` socket
  return $ actionFromForeign parseAction id <$> onReceive

dragStream :: forall eff. Eff( dom :: DOM| eff) (Observable Action)
dragStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left e -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

      dragOverTrash = const DeleteTopic <$> lookup "dragOverTrash"

      -- HTML 5 fires dragLeave before dragEnd occurs
      -- TODO: Find a cleaner solution
      dragLeave = delay 30 $ const UnassignTopic
                  <$> lookup "dragLeaveSlot" `merge` lookup "dragLeaveTrash"

      dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

      dragStart = parseTopic <<< getDetail
                  <$> lookup "dragStartTopic" `merge` lookup "dragStartGridTopic"

      dragTopic = do Right t <- dragStart
                     action <- dragOver
                     lookup "dragEndTopic" `merge` lookup "dragEndGridTopic"
                     return $ action t
  return dragTopic

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      addTopic    = (actionFromForeign parseTopic AddTopic) <<< getDetail
                    <$> lookup "addTopic"
      addRoom     = (actionFromForeign parseRoom AddRoom) <<< getDetail
                    <$> lookup "addRoom"
      removeRoom  = (actionFromForeign parseRoom DeleteRoom) <<< getDetail
                    <$> lookup "deleteRoom"
      addBlock    = (actionFromForeign parseBlock AddBlock) <<< getDetail
                    <$> lookup "addBlock"
      deleteBlock = (actionFromForeign parseBlock DeleteBlock) <<< getDetail
                    <$> lookup "deleteBlock"
      changeGrid = addRoom `merge` removeRoom `merge` addBlock `merge` deleteBlock
  dragTopic <- dragStream
  return $ addTopic `merge` dragTopic `merge` changeGrid

main = do
  -- TODO: getSocket :: Either SockErr Socket
  -- let sockEmitter = getSocket "http://localhost:3000"
  -- until Websocket support is given by the server
  let sockEmitter = EmptySocket
  -- Initial State
  appSt <- newSTRef myState1
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp
  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  unwrap $ (\a -> emitAction sockEmitter (serialize a)) <$> ui
  -- Evaluate Action Observables
  let actions = ui `merge` net
  subscribe actions (\a -> modifySTRef appSt (evalAction a) >>= renderApp)