Fix Api.Query for new version of retry combinator

Sadly, the old compiled version of this module was cached by gulp, and
so the type errors in here did not manifest during a local build.

Take it from me: before submitting a PR, run `rm -rf output; gulp` to be
sure.

module Api.Query (query, port, sample, SQL(), fields, count, all, templated) where

import Prelude
import Api.Common (RetryEffects(), getResponse, succeeded, retryGet, slamjax)
import Config (queryUrl, dataUrl)
import Control.Apply (lift2)
import Control.Bind ((<=<), (>=>))
import Control.Monad.Aff (Aff())
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (JArray(), Json(), JObject(), jsonEmptyObject, isArray, isObject, foldJson, toArray, toObject, toNumber, fromObject)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (concat, nub, filter, head)
import Utils (encodeURIComponent)
import Data.Either (Either(..), either)
import Data.Either.Unsafe (fromRight)
import Data.Foldable (foldl)
import Data.List (uncons, fromList)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.String (split, replace)
import Data.StrMap (StrMap(), keys, toList, empty, lookup)
import Data.Tuple (Tuple(..))
import Model.Notebook.Port (VarMapValue())
import Model.Path (AnyPath())
import Model.Resource (Resource(), resourcePath, isFile, _name)
import Network.HTTP.Affjax (Affjax(), AJAX(), affjax, defaultRequest)
import Network.HTTP.Method (Method(..))
import Network.HTTP.RequestHeader (RequestHeader(..))
import Optic.Core
import qualified Data.Int as I

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query :: forall e. Resource -> SQL -> Aff (RetryEffects (ajax :: AJAX | e)) JArray
query res sql =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ retryGet uri)
  where
  msg = "error in query"
  uri = mkURI res sql

count :: forall e. Resource -> Aff (RetryEffects (ajax :: AJAX | e)) Int
count res = do
  fromMaybe 0 <<< readTotal <$> query res sql
  where
  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

  readTotal :: JArray -> Maybe Int
  readTotal = I.fromNumber <=< toNumber <=< lookup "total" <=< toObject <=< head

port :: forall e. Resource -> Resource -> SQL ->
        StrMap VarMapValue ->
        Aff (RetryEffects (ajax :: AJAX | e)) JObject
port res dest sql vars =
  if not (isFile dest)
  then pure empty
  else do
    result <- slamjax $ defaultRequest
            { method = POST
            , headers = [RequestHeader "Destination" $ resourcePath dest]
            , url = queryUrl <> resourcePath res <> queryVars
            , content = Just (templated res sql)
            }

    either (throwError <<< error) pure $ content result.response
  where
  swap :: forall a b. Either a b -> Either b a
  swap (Right a) = Left a
  swap (Left a) = Right a

  -- TODO: This should be somewhere better.
  queryVars :: String
  queryVars = maybe "" makeQueryVars <<< uncons $ toList vars

  -- TODO: Need to encode query component.
  pair :: Tuple String VarMapValue -> String
  pair (Tuple a b) = a <> "=" <> b

  makeQueryVars { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) ("?" <> pair h) t

  content :: String -> Either String JObject
  content input = do
    json <- jsonParser input >>= decodeJson
    swap $ json .? "error"
    pure json

sample' :: forall e. Resource -> Maybe Int -> Maybe Int -> Aff (RetryEffects (ajax :: AJAX | e)) JArray
sample' res mbOffset mbLimit =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ retryGet uri)
  where
  msg = "error getting resource sample"
  uri = dataUrl <> resourcePath res <>
        (maybe "" (("?offset=" <>) <<< show) mbOffset) <>
        (maybe "" (("&limit=" <>) <<< show ) mbLimit)

sample :: forall e. Resource -> Int -> Int -> Aff (RetryEffects (ajax :: AJAX | e)) JArray
sample res offset limit = sample' res (Just offset) (Just limit)

all :: forall e. Resource -> Aff (RetryEffects (ajax :: AJAX | e)) JArray
all res = sample' res Nothing Nothing

fields :: forall e. Resource -> Aff (RetryEffects (ajax :: AJAX | e)) (Array String)
fields res = do
  jarr <- sample res 0 100
  case jarr of
    [] -> throwError $ error "empty file"
    _ -> pure $ nub $ concat (getFields <$> jarr)

mkURI :: Resource -> SQL -> String
mkURI res sql =
  queryUrl <> resourcePath res <> "?q=" <> encodeURIComponent (templated res sql)

templated :: Resource -> SQL -> SQL
templated res = replace "{{path}}" ("\"" <> resourcePath res <> "\"")

extractJArray :: String -> JArray
extractJArray =
  (foldl folder []) <<< (jsonParser <$>) <<< (split "\n")
  where
  folder :: JArray -> Either _ Json -> JArray
  folder agg (Right j) = agg ++ [j]
  folder agg _ = agg

getFields :: Json -> Array String
getFields json =
  filter (/= "") $ nub $ getFields' [] json

getFields' :: Array String -> Json -> Array String
getFields' [] json = getFields' [""] json
getFields' acc json =
  if isObject json
  then maybe acc (goObj acc) $ toObject json
  else if isArray json
       then maybe acc (goArr acc) $ toArray json
       else acc

goArr :: Array String -> JArray -> Array String
goArr acc arr =
  concat $ (getFields' ((<> "[*]") <$> acc) <$> arr)

goObj :: Array String -> JObject -> Array String
goObj acc obj = concat $ (goTuple acc <$> (fromList $ toList obj))

goTuple :: Array String -> Tuple String Json -> Array String
goTuple acc (Tuple key json) = getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json

module Api.Query (query, port, sample, SQL(), fields, count, all, templated) where

import Prelude
import Api.Common (getResponse, succeeded, retryGet, slamjax)
import Config (queryUrl, dataUrl)
import Control.Apply (lift2)
import Control.Bind ((<=<), (>=>))
import Control.Monad.Aff (Aff())
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (JArray(), Json(), JObject(), jsonEmptyObject, isArray, isObject, foldJson, toArray, toObject, toNumber, fromObject)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (concat, nub, filter, head)
import Utils (encodeURIComponent)
import Data.Either (Either(..), either)
import Data.Either.Unsafe (fromRight)
import Data.Foldable (foldl)
import Data.List (uncons, fromList)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.String (split, replace)
import Data.StrMap (StrMap(), keys, toList, empty, lookup)
import Data.Tuple (Tuple(..))
import Model.Notebook.Port (VarMapValue())
import Model.Path (AnyPath())
import Model.Resource (Resource(), resourcePath, isFile, _name)
import Network.HTTP.Affjax (Affjax(), AJAX(), affjax, defaultRequest)
import Network.HTTP.Method (Method(..))
import Network.HTTP.RequestHeader (RequestHeader(..))
import Optic.Core
import qualified Data.Int as I

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query :: forall e. Resource -> SQL -> Aff (ajax :: AJAX, avar :: AVAR | e) JArray
query res sql =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ retryGet uri)
  where
  msg = "error in query"
  uri = mkURI res sql

count :: forall e. Resource -> Aff (ajax :: AJAX, avar :: AVAR | e) Int
count res = do
  fromMaybe 0 <<< readTotal <$> query res sql
  where
  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

  readTotal :: JArray -> Maybe Int
  readTotal = I.fromNumber <=< toNumber <=< lookup "total" <=< toObject <=< head

port :: forall e. Resource -> Resource -> SQL ->
        StrMap VarMapValue ->
        Aff (ajax :: AJAX, avar :: AVAR | e) JObject
port res dest sql vars =
  if not (isFile dest)
  then pure empty
  else do
    result <- slamjax $ defaultRequest
            { method = POST
            , headers = [RequestHeader "Destination" $ resourcePath dest]
            , url = queryUrl <> resourcePath res <> queryVars
            , content = Just (templated res sql)
            }

    either (throwError <<< error) pure $ content result.response
  where
  swap :: forall a b. Either a b -> Either b a
  swap (Right a) = Left a
  swap (Left a) = Right a

  -- TODO: This should be somewhere better.
  queryVars :: String
  queryVars = maybe "" makeQueryVars <<< uncons $ toList vars

  -- TODO: Need to encode query component.
  pair :: Tuple String VarMapValue -> String
  pair (Tuple a b) = a <> "=" <> b

  makeQueryVars { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) ("?" <> pair h) t

  content :: String -> Either String JObject
  content input = do
    json <- jsonParser input >>= decodeJson
    swap $ json .? "error"
    pure json

sample' :: forall e. Resource -> Maybe Int -> Maybe Int -> Aff (ajax :: AJAX, avar :: AVAR | e) JArray
sample' res mbOffset mbLimit =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ retryGet uri)
  where
  msg = "error getting resource sample"
  uri = dataUrl <> resourcePath res <>
        (maybe "" (("?offset=" <>) <<< show) mbOffset) <>
        (maybe "" (("&limit=" <>) <<< show ) mbLimit)

sample :: forall e. Resource -> Int -> Int -> Aff (ajax :: AJAX, avar :: AVAR | e) JArray
sample res offset limit = sample' res (Just offset) (Just limit)

all :: forall e. Resource -> Aff (ajax :: AJAX, avar :: AVAR | e) JArray
all res = sample' res Nothing Nothing

fields :: forall e. Resource -> Aff (ajax :: AJAX, avar :: AVAR | e) (Array String)
fields res = do
  jarr <- sample res 0 100
  case jarr of
    [] -> throwError $ error "empty file"
    _ -> pure $ nub $ concat (getFields <$> jarr)

mkURI :: Resource -> SQL -> String
mkURI res sql =
  queryUrl <> resourcePath res <> "?q=" <> encodeURIComponent (templated res sql)

templated :: Resource -> SQL -> SQL
templated res = replace "{{path}}" ("\"" <> resourcePath res <> "\"")

extractJArray :: String -> JArray
extractJArray =
  (foldl folder []) <<< (jsonParser <$>) <<< (split "\n")
  where
  folder :: JArray -> Either _ Json -> JArray
  folder agg (Right j) = agg ++ [j]
  folder agg _ = agg

getFields :: Json -> Array String
getFields json =
  filter (/= "") $ nub $ getFields' [] json

getFields' :: Array String -> Json -> Array String
getFields' [] json = getFields' [""] json
getFields' acc json =
  if isObject json
  then maybe acc (goObj acc) $ toObject json
  else if isArray json
       then maybe acc (goArr acc) $ toArray json
       else acc

goArr :: Array String -> JArray -> Array String
goArr acc arr =
  concat $ (getFields' ((<> "[*]") <$> acc) <$> arr)

goObj :: Array String -> JObject -> Array String
goObj acc obj = concat $ (goTuple acc <$> (fromList $ toList obj))

goTuple :: Array String -> Tuple String Json -> Array String
goTuple acc (Tuple key json) = getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json


Tests for forbidden push callback.

Tests for forbidden push callback.

don't know yet why it does not work in test code. might need to throw
exception.

module Test.Authorization where

import Prelude (Unit, bind, ($), pure)

import Control.Monad.Aff (forkAff,later', launchAff, attempt)
import Control.Monad.Aff.Par (Par(..), runPar)
import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Control.Alt ((<|>))
import Data.Either (either)
import Data.Maybe (Maybe(Just))
import Data.Foreign (toForeign)
import Web.Firebase.Types as FBT
import Web.Firebase (EventType(..),once, pushE, push)
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase.Monad.Aff (onceValue, on, firebaseErrToString)

authorizationSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff, err :: EXCEPTION, avar :: AVAR | eff ) Unit
authorizationSpec forbiddenRef = do
    describe "Understanding AVar and Par" do
      it "can write to a var" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar true)
        actual <- takeVar respVar
        actual `shouldEqual` true
      it "can race two vars manually" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar "fast")
        handleSlow <- forkAff (later' 200 $ putVar respVar "slow")
        actual <- takeVar respVar
        actual `shouldEqual` "fast"
      it "can race two vars with an alternative" do
        let fast = (later' 100 $ pure "fast")
            slow = (later' 200 $ pure "slow")
        actual <- runPar (Par fast <|> Par slow)
        actual `shouldEqual` "fast"
    describe "Authorization" do
      describe "Writing" do
        it "pushE() on forbidden location calls error callback" do
          respVar <- makeVar
          handle  <- liftEff $ pushE (toForeign {some: "object"}) (\err -> launchAff $ putVar respVar (firebaseErrToString err)) forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED"
        it "push() on forbidden location calls error callback" do
          respVar <- makeVar
          handle  <- liftEff $ push (toForeign {some: "object"}) (Just (Just (\err -> launchAff $ putVar respVar (firebaseErrToString err)))) forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED"
      describe "once() on forbidden location" do
        it "with Eff calls an error callback" do
          respVar <- makeVar
          handle  <- liftEff $ once ChildAdded (\snap -> launchAff $ putVar respVar "unexpected sucess") (\_ -> launchAff $ putVar respVar "child forbidden") forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "child forbidden"
        it "with Aff throws an error" do
           e <- attempt $ onceValue forbiddenRef  -- catch error thrown and assert
           either (\err -> (message err) `shouldEqual` "permission_denied: Client doesn't have permission to access the desired data.\n | firebase code: | \n PERMISSION_DENIED") (\_ -> "expected an error to be thrown" `shouldEqual` "but was not") e
      describe "on() at forbidden location" do
        it "ChildAdded with Aff throws an error" do
          expectError $ on ChildAdded forbiddenRef
        it "ChildRemoved with Aff throws an error" do
          expectError $ on ChildRemoved forbiddenRef
        it "ChildChanged with Aff throws an error" do
          expectError $ on ChildChanged forbiddenRef
        it "ChildMoved with Aff throws an error" do
          expectError $ on ChildMoved forbiddenRef

{-   describe "Firebase API breaks its documentation" do
       it "once() throws an exeption when no error callback provided and an error occurs" do
          -- I prefer handling errors, but this is the firebase api...
          handle <- liftEff $ once ChildAdded (\_ -> pure unit) Nothing forbiddenRef
          "shoul get here" `shouldEqual` "should get here"
-}

module Test.Authorization where

import Prelude (Unit, bind, ($), pure)

import Control.Monad.Aff (forkAff,later', launchAff, attempt)
import Control.Monad.Aff.Par (Par(..), runPar)
import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Control.Alt ((<|>))
import Data.Either (either)
import Web.Firebase.Types as FBT
import Web.Firebase (EventType(..),once)
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase.Monad.Aff (onceValue, on)

authorizationSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff, err :: EXCEPTION, avar :: AVAR | eff ) Unit
authorizationSpec forbiddenRef = do
    describe "Understanding AVar and Par" do
      it "can write to a var" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar true)
        actual <- takeVar respVar
        actual `shouldEqual` true
      it "can race two vars manually" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar "fast")
        handleSlow <- forkAff (later' 200 $ putVar respVar "slow")
        actual <- takeVar respVar
        actual `shouldEqual` "fast"
      it "can race two vars with an alternative" do
        let fast = (later' 100 $ pure "fast")
            slow = (later' 200 $ pure "slow")
        actual <- runPar (Par fast <|> Par slow)
        actual `shouldEqual` "fast"
    describe "Authorization" do
      describe "once() on forbidden location" do
        it "with Eff calls an error callback" do
          respVar <- makeVar
          handle  <- liftEff $ once ChildAdded (\snap -> launchAff $ putVar respVar "unexpected sucess") (\_ -> launchAff $ putVar respVar "child forbidden") forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "child forbidden"
        it "with Aff throws an error" do
           e <- attempt $ onceValue forbiddenRef  -- catch error thrown and assert
           either (\err -> (message err) `shouldEqual` "permission_denied: Client doesn't have permission to access the desired data.\n | firebase code: | \n PERMISSION_DENIED") (\_ -> "expected an error to be thrown" `shouldEqual` "but was not") e
      describe "on() at forbidden location" do
        it "ChildAdded with Aff throws an error" do
          expectError $ on ChildAdded forbiddenRef
        it "ChildRemoved with Aff throws an error" do
          expectError $ on ChildRemoved forbiddenRef
        it "ChildChanged with Aff throws an error" do
          expectError $ on ChildChanged forbiddenRef
        it "ChildMoved with Aff throws an error" do
          expectError $ on ChildMoved forbiddenRef

{-   describe "Firebase API breaks its documentation" do
       it "once() throws an exeption when no error callback provided and an error occurs" do
          -- I prefer handling errors, but this is the firebase api...
          handle <- liftEff $ once ChildAdded (\_ -> pure unit) Nothing forbiddenRef
          "shoul get here" `shouldEqual` "should get here"
-}


Fix Ace example to not use a parent component

module AceComponent (AceEffects, AceQuery(..), AceOutput(..), aceComponent) where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)

import Data.Maybe (Maybe(..))

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import Ace as Ace
import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Types (ACE, Editor)

-- | The state for the ace component - we only need a reference to the editor,
-- | as Ace editor has its own internal state that we can query instead of
-- | replicating it within Halogen.
type AceState = { editor :: Maybe Editor }

-- | A basic query algebra for the Ace component.
data AceQuery a
  = Initialize a
  | Finalize a
  | ChangeText String a
  | HandleChange (H.SubscribeStatus -> a)

data AceOutput = TextChanged String

-- | Effects embedding the Ace editor requires.
type AceEffects eff = (ace :: ACE, avar :: AVAR | eff)

-- | The Ace component definition.
aceComponent :: forall eff. H.Component HH.HTML AceQuery Unit AceOutput (Aff (AceEffects eff))
aceComponent =
  H.lifecycleComponent
    { initialState: const initialState
    , render
    , eval
    , initializer: Just (H.action Initialize)
    , finalizer: Just (H.action Finalize)
    , receiver: const Nothing
    }
  where

  initialState :: AceState
  initialState = { editor: Nothing }

  -- As we're embedding a 3rd party component we only need to create a
  -- placeholder div here and attach the ref property which will let us reference
  -- the element in eval.
  render :: AceState -> H.ComponentHTML AceQuery
  render = const $ HH.div [ HP.ref (H.RefLabel "ace") ] []

  -- The query algebra for the component handles the initialization of the Ace
  -- editor as well as responding to the `ChangeText` action that allows us to
  -- alter the editor's state.
  eval :: AceQuery ~> H.ComponentDSL AceState AceQuery AceOutput (Aff (AceEffects eff))
  eval = case _ of
    Initialize next -> do
      H.getHTMLElementRef (H.RefLabel "ace") >>= case _ of
        Nothing -> pure unit
        Just el' -> do
          editor <- H.liftEff $ Ace.editNode el' Ace.ace
          session <- H.liftEff $ Editor.getSession editor
          H.modify (_ { editor = Just editor })
          H.subscribe $ H.eventSource_ (Session.onChange session) (H.request HandleChange)
      pure next
    Finalize next -> do
      -- Release the reference to the editor and do any other cleanup that a
      -- real world component might need.
      H.modify (_ { editor = Nothing })
      pure next
    ChangeText text next -> do
      maybeEditor <- H.gets _.editor
      case maybeEditor of
        Nothing -> pure unit
        Just editor -> do
          current <- H.liftEff $ Editor.getValue editor
          when (text /= current) do
            void $ H.liftEff $ Editor.setValue text Nothing editor
      H.raise $ TextChanged text
      pure next
    HandleChange reply -> do
      maybeEditor <- H.gets _.editor
      case maybeEditor of
        Nothing -> pure unit
        Just editor -> do
          text <- H.liftEff (Editor.getValue editor)
          H.raise $ TextChanged text
      pure (reply H.Listening)

module AceComponent (AceEffects, AceQuery(..), AceOutput(..), aceComponent) where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)

import Data.Maybe (Maybe(..))
import Data.Const (Const)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import Ace as Ace
import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Types (ACE, Editor)

-- | The state for the ace component - we only need a reference to the editor,
-- | as Ace editor has its own internal state that we can query instead of
-- | replicating it within Halogen.
type AceState = { editor :: Maybe Editor }

-- | A basic query algebra for the Ace component.
data AceQuery a
  = Initialize a
  | Finalize a
  | ChangeText String a
  | HandleChange (H.SubscribeStatus -> a)

data AceOutput = TextChanged String

-- | Effects embedding the Ace editor requires.
type AceEffects eff = (ace :: ACE, avar :: AVAR | eff)

-- | The Ace component definition.
aceComponent :: forall eff. H.Component HH.HTML AceQuery Unit AceOutput (Aff (AceEffects eff))
aceComponent =
  H.lifecycleParentComponent
    { initialState: const initialState
    , render
    , eval
    , initializer: Just (H.action Initialize)
    , finalizer: Just (H.action Finalize)
    , receiver: const Nothing
    }
  where

  initialState :: AceState
  initialState =
    { editor: Nothing }

  -- As we're embedding a 3rd party component we only need to create a
  -- placeholder div here and attach the ref property which will let us reference
  -- the element in eval.
  render :: AceState -> H.ParentHTML AceQuery (Const Void) Unit (Aff (AceEffects eff))
  render = const $ HH.div [ HP.ref (H.RefLabel "ace") ] []

  -- The query algebra for the component handles the initialization of the Ace
  -- editor as well as responding to the `ChangeText` action that allows us to
  -- alter the editor's state.
  eval :: AceQuery ~> H.ParentDSL AceState AceQuery (Const Void) Unit AceOutput (Aff (AceEffects eff))
  eval (Initialize next) = do
    H.getHTMLElementRef (H.RefLabel "ace") >>= case _ of
      Nothing -> pure unit
      Just el' -> do
        editor <- H.liftEff $ Ace.editNode el' Ace.ace
        session <- H.liftEff $ Editor.getSession editor
        H.modify (_ { editor = Just editor })
        H.subscribe $ H.eventSource_ (Session.onChange session) (H.request HandleChange)
    pure next
  eval (Finalize next) = do
    -- Release the reference to the editor and do any other cleanup that a real
    -- world component might need.
    H.modify (_ { editor = Nothing })
    pure next
  eval (ChangeText text next) = do
    maybeEditor <- H.gets _.editor
    case maybeEditor of
      Nothing -> pure unit
      Just editor -> do
        current <- H.liftEff $ Editor.getValue editor
        when (text /= current) do
          void $ H.liftEff $ Editor.setValue text Nothing editor
    H.raise $ TextChanged text
    pure next
  eval (HandleChange reply) = do
    maybeEditor <- H.gets _.editor
    case maybeEditor of
      Nothing -> pure unit
      Just editor -> do
        text <- H.liftEff (Editor.getValue editor)
        H.raise $ TextChanged text
    pure (reply H.Listening)


Factor out adminApp and anonymous app creation

module Test.Authorization where

import Data.Either (either)
import Effect.Aff (Aff, attempt)
import Effect.Exception (message)
import Foreign (unsafeToForeign)
import Node.Encoding (Encoding(UTF8))
import Node.FS.Aff (readTextFile)
import Prelude (Unit, bind, discard, ($), (=<<))
import Test.Spec (Spec, before, describe, it)
import Test.Spec.Assertions (expectError, shouldEqual, fail)
import Web.Firebase (EventType(ChildMoved, ChildChanged, ChildRemoved, ChildAdded))
import Web.Firebase.Aff (child, database, on, onceValue, push, rootRefFor, set) as DBA
import Web.Firebase.Testing (DatabaseName(..), initializeAdminApp, initializeAnonymousTestApp, loadDatabaseRules)
import Web.Firebase.Types (DatabaseImpl)
import Web.Firebase.Types as FBT

authorizationSpec :: FBT.Firebase -> Spec Unit
authorizationSpec _ = (before $ setForbiddenEntry')  do
    describe "Authorization"    do
      describe "Writing" do
        it "with Aff push on forbidden location throws an error" $ \forbidden -> do
          let newValue = {success: "push Aff"}
          expectError $ DBA.push (unsafeToForeign newValue) forbidden
      describe "once() on forbidden location" do
        it "with Aff throws an error" $ \forbidden -> do
           e <- attempt $ DBA.onceValue forbidden  -- catch error thrown and assert
           either (\err -> (message err) `shouldEqual` "permission_denied at /forbidden: Client doesn't have permission to access the desired data.\n | firebase code: | \n PERMISSION_DENIED") (\_ -> "expected an error to be thrown" `shouldEqual` "but was not") e
      describe "on() at forbidden location" do
        it "ChildAdded with Aff throws an error" $ \forbidden -> do
          expectError $ DBA.on ChildAdded forbidden
        it "ChildRemoved with Aff throws an error" $ \forbidden ->   do
          expectError $ DBA.on ChildRemoved forbidden
        it "ChildChanged with Aff throws an error" $ \forbidden -> do
          expectError $ DBA.on ChildChanged forbidden
        it "ChildMoved with Aff throws an error" $ \forbidden -> do
          expectError $ DBA.on ChildMoved forbidden
      it "set() with Aff at forbidden location throws an error" $ \forbidden ->  do
        let newValue = {success: "set Aff"}
        e <- attempt $ DBA.set (unsafeToForeign newValue) forbidden
        either (\err -> (message err) `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED")
               (\_ -> fail "expected an error to be thrown but was not")
               e

setForbiddenEntry' :: Aff DatabaseImpl
setForbiddenEntry' = do
  let dbName = (DatabaseName "AuthorizationApp")
  let forbiddenKey = "forbidden"
  arrange dbName forbiddenKey
  DBA.child forbiddenKey =<< appRoot =<< initializeAnonymousTestApp dbName
  where
    arrange dbName forbiddenKey = do
      root <- appRoot =<< initializeAdminApp dbName
      fbRules <- readTextFile UTF8 "./test/rules.json"
      let rules = {databaseName: dbName,
                   rules: fbRules }
      forbidden <- DBA.child forbiddenKey root
      pathRoot <- DBA.child "firstchild" forbidden
      DBA.set (unsafeToForeign "something") pathRoot
      loadDatabaseRules rules

appRoot::FBT.FirebaseAppImpl -> Aff DatabaseImpl
appRoot app = DBA.rootRefFor =<< DBA.database app

module Test.Authorization where

import Data.Either (either)
import Effect.Aff (Aff, attempt)
import Effect.Exception (message)
import Foreign (unsafeToForeign)
import Node.Encoding (Encoding(UTF8))
import Node.FS.Aff (readTextFile)
import Prelude (Unit, bind, discard, pure, ($), (=<<))
import Test.Spec (Spec, before, describe, it)
import Test.Spec.Assertions (expectError, shouldEqual, fail)
import Web.Firebase (EventType(ChildMoved, ChildChanged, ChildRemoved, ChildAdded))
import Web.Firebase.Aff (child, database, on, onceValue, push, rootRefFor, set) as DBA
import Web.Firebase.Testing (DatabaseName(..), initializeAdminApp, initializeAnonymousTestApp, loadDatabaseRules)
import Web.Firebase.Types (DatabaseImpl)
import Web.Firebase.Types as FBT

authorizationSpec :: FBT.Firebase -> Spec Unit
authorizationSpec _ = (before $ setForbiddenEntry')  do
    describe "Authorization"    do
      describe "Writing" do
        it "with Aff push on forbidden location throws an error" $ \forbidden -> do
          let newValue = {success: "push Aff"}
          expectError $ DBA.push (unsafeToForeign newValue) forbidden
      describe "once() on forbidden location" do
        it "with Aff throws an error" $ \forbidden -> do
           e <- attempt $ DBA.onceValue forbidden  -- catch error thrown and assert
           either (\err -> (message err) `shouldEqual` "permission_denied at /forbidden: Client doesn't have permission to access the desired data.\n | firebase code: | \n PERMISSION_DENIED") (\_ -> "expected an error to be thrown" `shouldEqual` "but was not") e
      describe "on() at forbidden location" do
        it "ChildAdded with Aff throws an error" $ \forbidden -> do
          expectError $ DBA.on ChildAdded forbidden
        it "ChildRemoved with Aff throws an error" $ \forbidden ->   do
          expectError $ DBA.on ChildRemoved forbidden
        it "ChildChanged with Aff throws an error" $ \forbidden -> do
          expectError $ DBA.on ChildChanged forbidden
        it "ChildMoved with Aff throws an error" $ \forbidden -> do
          expectError $ DBA.on ChildMoved forbidden
      it "set() with Aff at forbidden location throws an error" $ \forbidden ->  do
        let newValue = {success: "set Aff"}
        e <- attempt $ DBA.set (unsafeToForeign newValue) forbidden
        either (\err -> (message err) `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED")
               (\_ -> fail "expected an error to be thrown but was not")
               e

setForbiddenEntry :: DatabaseImpl -> Aff DatabaseImpl
setForbiddenEntry root = do
  forbidden <- DBA.child "forbidden" root
  pathRoot <- DBA.child "firstchild" forbidden
  DBA.set (unsafeToForeign "something") pathRoot
  pure forbidden

setForbiddenEntry' :: Aff DatabaseImpl
setForbiddenEntry' = do
  let dbName = (DatabaseName "AuthorizationApp")
  app <- initializeAdminApp dbName
  db <- DBA.database app
  root <- DBA.rootRefFor db
  fbRules <- readTextFile UTF8 "./test/rules.json"
  let rules = {databaseName: dbName,
               rules: fbRules }
  forbidden <- DBA.child "forbidden" root
  pathRoot <- DBA.child "firstchild" forbidden
  DBA.set (unsafeToForeign "something") pathRoot
  loadDatabaseRules rules
  anonRoot <- DBA.rootRefFor =<< DBA.database =<< initializeAnonymousTestApp dbName
  forbidden' <- DBA.child "forbidden" anonRoot
  pure forbidden'


Avoid duplication in defined types

Avoid duplication in defined types

module Mustache where

import Data.StrMap
import Prelude

type Template = String

type Tag = String

foreign import name :: String

foreign import version :: String

foreign import tags :: Array String

foreign import parse :: Template -> Array Tag -> Array (Array String)

foreign import render :: Template -> StrMap String -> StrMap String

foreign import escape :: String -> String

module Mustache where

import Data.StrMap
import Prelude

type MustacheTemplate = String

type MustacheTag = String

foreign import name :: String

foreign import version :: String

foreign import tags :: Array String

foreign import parse :: MustacheTemplate -> Array MustacheTag -> Array (Array String)

foreign import render :: MustacheTemplate -> StrMap String -> StrMap String

foreign import escape :: String -> String


Be explicit about what we import

Be explicit about what we import

module Mustache where

import Control.Monad.Eff (Eff())
import Data.StrMap (StrMap())
import Prelude (Show, Unit())

type Template = String

type Tag = String

type View = StrMap String

type Partials = StrMap String

foreign import data MustacheEffect :: !

foreign import name :: String

foreign import version :: String

foreign import tags :: Array Tag

foreign import parse :: forall e. Template -> Array Tag -> Eff (mustache :: MustacheEffect | e) (Array (Array String))

foreign import render :: forall e. Template -> View -> Partials -> Eff (mustache :: MustacheEffect | e) String

foreign import escape :: String -> String

foreign import clearCache :: forall e. Eff (mustache :: MustacheEffect | e) Unit

module Mustache where

import Control.Monad.Eff (Eff())
import Data.StrMap
import Prelude

type Template = String

type Tag = String

type View = StrMap String

type Partials = StrMap String

foreign import data MustacheEffect :: !

foreign import name :: String

foreign import version :: String

foreign import tags :: Array Tag

foreign import parse :: forall e. Template -> Array Tag -> Eff (mustache :: MustacheEffect | e) (Array (Array String))

foreign import render :: forall e. Template -> View -> Partials -> Eff (mustache :: MustacheEffect | e) String

foreign import escape :: String -> String

foreign import clearCache :: forall e. Eff (mustache :: MustacheEffect | e) Unit


[WIP] New CoreFn format

[WIP] New CoreFn format

module PureSwift.CodeGen
 ( moduleToSwift
 ) where

import Prelude

import CoreFn.Expr (Bind(..), Expr(Abs, Accessor, App, Case, Constructor, ObjectUpdate, Let, Var))
import CoreFn.Expr (Expr(Literal)) as CoreFn
import CoreFn.Ident (Ident(..)) as CoreFn
import CoreFn.Literal (Literal(..)) as CoreFn
import CoreFn.Module (Module(..))
import CoreFn.Names (ModuleName(..), Qualified(..))
import Data.Array (intercalate)
import Data.Bifunctor (bimap)
import Data.Either (either)
import Data.Foldable (elem, foldr)
import Data.Int (decimal, toStringAs)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))
import PureSwift.AST (AccessMod(..), Attribute(..), Decl(..), DeclMod(..), Exp(..), FunctionTypeArg(..), Ident(..), Lit(..), Statement(..), Type(..))

moduleToSwift :: Module Unit -> Decl
moduleToSwift (Module mod) = TopLevel statements
  where
  decls :: List Decl
  decls = foldr (append <<< declToSwift) Nil (List.fromFoldable mod.moduleDecls)

  extension :: Decl
  extension = Extension (AccessModifier Public : Nil) (moduleNameToSwift mod.moduleName) decls

  statements :: List Statement
  statements = ( Declaration extension : Nil )

  moduleNameToSwift :: ModuleName -> Ident
  moduleNameToSwift (ModuleName mn) = Ident $ intercalate "." (unwrap <$> mn)

  declToSwift :: Bind Unit -> List Decl
  declToSwift (NonRec a i e) = List.singleton $ bindingToSwift (Tuple (Tuple a i) e)
  declToSwift (Rec bs) = bindingToSwift <$> List.fromFoldable bs

  removeAttributes :: FunctionTypeArg -> FunctionTypeArg
  removeAttributes (FunctionTypeArg e i _ t) = FunctionTypeArg e i Nil t

  removeBothArgLabels :: FunctionTypeArg -> FunctionTypeArg
  removeBothArgLabels (FunctionTypeArg _ _ as t) = FunctionTypeArg Nothing Nothing as t

  removeAllReturnTypeArgLabels :: FunctionTypeArg -> FunctionTypeArg
  removeAllReturnTypeArgLabels (FunctionTypeArg as e i r) = FunctionTypeArg as e i (removeAllArgLabels r)

  removeAllArgLabels :: Type -> Type
  removeAllArgLabels = case _ of
    (FunctionType as t) ->
      FunctionType (removeBothArgLabels <<< removeAllReturnTypeArgLabels <$> as) (removeAllArgLabels t)
    typ -> typ

  expToType' :: (Type -> Type) -> Exp -> Maybe Type
  expToType' f = case _ of
    (Closure as r _) -> Just $ f $ FunctionType as r
    (Literal l) -> litToType l
    _ -> Nothing

  expToType :: Exp -> Maybe Type
  expToType = expToType' id

  litToType :: Lit -> Maybe Type
  litToType = case _ of
    IntLit _ -> Just IntType
    FloatLit _ -> Just FloatType
    CharLit _ -> Just CharType
    StringLit _ -> Just StringType
    BooleanLit _ -> Just BoolType
    _ -> Nothing

  bindingToSwift :: Tuple (Tuple Unit CoreFn.Ident) (CoreFn.Expr Unit) -> Decl
  bindingToSwift (Tuple (Tuple _ ident) expr) =
    Constant (accessMod : Static : Nil) (identToSwift ident) (expToType' removeAllArgLabels exp) exp
    where
    accessMod :: DeclMod
    accessMod = AccessModifier $ if isExported ident then Public else Internal

    isExported :: CoreFn.Ident -> Boolean
    isExported i = elem i mod.moduleExports

    exp :: Exp
    exp = exprToSwift expr

  identToSwift :: CoreFn.Ident -> Ident
  identToSwift (CoreFn.Ident ident) = Ident ident
  identToSwift (CoreFn.GenIdent s i) = Ident $ fromMaybe "" s <> toStringAs decimal i
  identToSwift CoreFn.UnusedIdent = Ident "/* FIXME */"

  exprToSwift :: CoreFn.Expr Unit -> Exp
  exprToSwift (CoreFn.Literal _ l) = Literal $ literalToSwift l
  exprToSwift (Constructor _ tn cn fs) = ?x
  exprToSwift (Accessor _ s e) = ?x
  exprToSwift (ObjectUpdate _ e ts) = ?x
  exprToSwift (Abs _ i e) = Closure args returnType ss
    where
    exp :: Exp
    exp = exprToSwift e

    atts :: List Attribute
    atts = case exp of
      Closure _ _ _ -> Escaping : Nil
      _ -> Nil

    returnType :: Type
    returnType = fromMaybe AnyType $ expToType exp

    args :: List FunctionTypeArg
    args =
      ( FunctionTypeArg (Just $ Ident "_") (Just $ identToSwift i) atts returnType
      : Nil
      )

    ss :: List Statement
    ss =
      ( Return (Just exp)
      : Nil
      )
  exprToSwift (App _ e1 e2) = FunctionCall (exprToSwift e1) (exprToSwift e2 : Nil)
  exprToSwift (Var _ q) = qualifiedToSwift q
  exprToSwift (Case _ es cs) = ?x
  exprToSwift (Let _ bs e) = ?x

  literalToSwift :: CoreFn.Literal (Expr Unit) -> Lit
  literalToSwift (CoreFn.NumericLiteral x) = either IntLit FloatLit x
  literalToSwift (CoreFn.StringLiteral x) = StringLit x
  literalToSwift (CoreFn.CharLiteral x) = CharLit x
  literalToSwift (CoreFn.BooleanLiteral x) = BooleanLit x
  literalToSwift (CoreFn.ArrayLiteral xs) = ArrayLit $ exprToSwift <$> List.fromFoldable xs
  literalToSwift (CoreFn.ObjectLiteral xs) = DictLit $ Map.fromFoldable $ map (bimap (Literal <<< StringLit) exprToSwift) xs

  qualifiedToSwift (Qualified q i) =
    case q of
      Just m -> ExplicitMember (Identifier $ moduleNameToSwift m) ident
      Nothing -> Identifier ident
    where
      ident = identToSwift i

module PureSwift.CodeGen
 ( moduleToSwift
 ) where

import Prelude

import CoreFn.Expr (Bind(..), Expr(Abs, Var, App))
import CoreFn.Expr (Expr(Literal)) as CoreFn
import CoreFn.Ident (Ident(..)) as CoreFn
import CoreFn.Literal (Literal(..)) as CoreFn
import CoreFn.Module (Module(..))
import CoreFn.Names (ModuleName(..), Qualified(..))
import Data.Array (intercalate)
import Data.Bifunctor (bimap)
import Data.Either (either)
import Data.Foldable (elem, foldr)
import Data.Int (decimal, toStringAs)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))
import PureSwift.AST (AccessMod(..), Attribute(..), Decl(..), DeclMod(..), Exp(..), FunctionTypeArg(..), Ident(..), Lit(..), Statement(..), Type(..))

moduleToSwift :: Module Unit -> Decl
moduleToSwift (Module mod) = TopLevel statements
  where
  decls :: List Decl
  decls = foldr (append <<< declToSwift) Nil (List.fromFoldable mod.moduleDecls)

  extension :: Decl
  extension = Extension (AccessModifier Public : Nil) (moduleNameToSwift mod.moduleName) decls

  statements :: List Statement
  statements = ( Declaration extension : Nil )

  moduleNameToSwift :: ModuleName -> Ident
  moduleNameToSwift (ModuleName mn) = Ident $ intercalate "." (unwrap <$> mn)

  declToSwift :: Bind Unit -> List Decl
  declToSwift (NonRec a i e) = List.singleton $ bindingToSwift (Tuple (Tuple a i) e)
  declToSwift (Rec bs) = bindingToSwift <$> List.fromFoldable bs

  removeAttributes :: FunctionTypeArg -> FunctionTypeArg
  removeAttributes (FunctionTypeArg e i _ t) = FunctionTypeArg e i Nil t

  removeBothArgLabels :: FunctionTypeArg -> FunctionTypeArg
  removeBothArgLabels (FunctionTypeArg _ _ as t) = FunctionTypeArg Nothing Nothing as t

  removeAllReturnTypeArgLabels :: FunctionTypeArg -> FunctionTypeArg
  removeAllReturnTypeArgLabels (FunctionTypeArg as e i r) = FunctionTypeArg as e i (removeAllArgLabels r)

  removeAllArgLabels :: Type -> Type
  removeAllArgLabels = case _ of
    (FunctionType as t) ->
      FunctionType (removeBothArgLabels <<< removeAllReturnTypeArgLabels <$> as) (removeAllArgLabels t)
    typ -> typ

  expToType' :: (Type -> Type) -> Exp -> Maybe Type
  expToType' f = case _ of
    (Closure as r _) -> Just $ f $ FunctionType as r
    (Literal l) -> litToType l
    _ -> Nothing

  expToType :: Exp -> Maybe Type
  expToType = expToType' id

  litToType :: Lit -> Maybe Type
  litToType = case _ of
    IntLit _ -> Just IntType
    FloatLit _ -> Just FloatType
    CharLit _ -> Just CharType
    StringLit _ -> Just StringType
    BooleanLit _ -> Just BoolType
    _ -> Nothing

  bindingToSwift :: Tuple (Tuple Unit CoreFn.Ident) (CoreFn.Expr Unit) -> Decl
  bindingToSwift (Tuple (Tuple _ ident) expr) =
    Constant (accessMod : Static : Nil) (identToSwift ident) (expToType' removeAllArgLabels exp) exp
    where
    accessMod :: DeclMod
    accessMod = AccessModifier $ if isExported ident then Public else Internal

    isExported :: CoreFn.Ident -> Boolean
    isExported i = elem i mod.moduleExports

    exp :: Exp
    exp = exprToSwift expr

  identToSwift :: CoreFn.Ident -> Ident
  identToSwift (CoreFn.Ident ident) = Ident ident
  identToSwift (CoreFn.GenIdent s i) = Ident $ fromMaybe "" s <> toStringAs decimal i
  identToSwift CoreFn.UnusedIdent = Ident "/* FIXME */"

  exprToSwift :: CoreFn.Expr Unit -> Exp
  exprToSwift (CoreFn.Literal _ l) = Literal $ literalToSwift l
  exprToSwift (App _ e1 e2) = FunctionCall (exprToSwift e1) (exprToSwift e2 : Nil)
  exprToSwift (Var _ q) = qualifiedToSwift q
  exprToSwift (Abs _ i e) = Closure args returnType ss
    where
    exp :: Exp
    exp = exprToSwift e

    atts :: List Attribute
    atts = case exp of
      Closure _ _ _ -> Escaping : Nil
      _ -> Nil

    returnType :: Type
    returnType = fromMaybe AnyType $ expToType exp

    args :: List FunctionTypeArg
    args =
      ( FunctionTypeArg (Just $ Ident "_") (Just $ identToSwift i) atts returnType
      : Nil
      )

    ss :: List Statement
    ss =
      ( Return (Just exp)
      : Nil
      )

  literalToSwift :: CoreFn.Literal (Expr Unit) -> Lit
  literalToSwift (CoreFn.NumericLiteral x) = either IntLit FloatLit x
  literalToSwift (CoreFn.StringLiteral x) = StringLit x
  literalToSwift (CoreFn.CharLiteral x) = CharLit x
  literalToSwift (CoreFn.BooleanLiteral x) = BooleanLit x
  literalToSwift (CoreFn.ArrayLiteral xs) = ArrayLit $ exprToSwift <$> List.fromFoldable xs
  literalToSwift (CoreFn.ObjectLiteral xs) = DictLit $ Map.fromFoldable $ map (bimap (Literal <<< StringLit) exprToSwift) xs

  qualifiedToSwift (Qualified q i) =
    case q of
      Just m -> ExplicitMember (Identifier $ moduleNameToSwift m) ident
      Nothing -> Identifier ident
    where
      ident = identToSwift i


Dismiss add card guide when card added

Dismiss add card guide when card added

{-
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.Next.Component
 ( nextCardComponent
 , module SlamData.Workspace.Card.Next.Component.State
 , module SlamData.Workspace.Card.Next.Component.Query
 ) where

import SlamData.Prelude

import Data.Lens ((.~))
import Data.String as Str

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

import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Guide as Guide
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.Component.Query (QueryP, Query(..), _AddCardType, _PresentReason)
import SlamData.Workspace.Card.Next.Component.State (State)
import SlamData.Workspace.Card.Next.Component.State as State
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.InsertableCardType as ICT

import Utils.LocalStorage as LocalStorage

type NextHTML = H.ComponentHTML QueryP
type NextDSL = H.ComponentDSL State QueryP Slam

nextCardComponent ∷ CC.CardComponent
nextCardComponent = CC.makeCardComponent
  { cardType: CT.NextAction
  , component: H.lifecycleComponent { initializer: Just $ right $ H.action $ Init, finalizer: Nothing, render, eval}
  , initialState: State.initialState
  , _State: CC._NextState
  , _Query: CC.makeQueryPrism CC._NextQuery
  }

render ∷ State → NextHTML
render state =
  HH.div_
    $ (guard (not state.presentAddCardGuide) $>
      HH.form_
        [ HH.div_
            [ HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input (\s → right ∘ UpdateFilter s))
                , ARIA.label "Filter next actions"
                , HP.placeholder "Filter actions"
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ (right ∘ UpdateFilter ""))
                ]
                [ glyph B.glyphiconRemove ]
            ]
        ])
    ⊕ (guard state.presentAddCardGuide $>
        Guide.render
          (HH.className "sd-add-card-guide")
          (right ∘ DismissAddCardGuide)
          addCardGuideTextEmptyDeck)
    ⊕ [ HH.ul_ $ map nextButton CT.insertableCardTypes ]
  where

  filterString ∷ String
  filterString = Str.toLower state.filterString

  cardTitle ∷ CT.CardType → String
  cardTitle cty = "Insert " ⊕ CT.cardName cty ⊕ " card"

  nextButton ∷ CT.CardType → NextHTML
  nextButton cty =
    HH.li_
      [ HH.button attrs
          [ CT.lightCardGlyph cty
          , HH.p_ [ HH.text (CT.cardName cty) ]
          ]
      ]
    where
    enabled = Str.contains filterString (Str.toLower $ CT.cardName cty)
    attrs =
      [ HP.title $ cardTitle cty
      , HP.disabled $ not enabled
      , ARIA.label $ cardTitle cty
      ] ⊕ (guard (not $ takesInput state.input cty)
             $> HP.classes [ HH.className "sd-button-warning" ])
        ⊕ (guard enabled
             $> HE.onClick (HE.input_ (right ∘ addCardOrPresentReason state.input cty)))

  cardGuideText =
    "Cards retreive, process and present data, forms, charts and more."
      ⊕ " Every card creates an output which can be passed to another."
      ⊕ " By stacking cards into decks you can find valuable insights"
      ⊕ " and do amazing things."
  addCardGuideTextEmptyDeck = "To get this deck started press one of these buttons to add a card."
  addCardGuideTextNonEmptyDeck = "To do more with this deck press one of these buttons to add a card."

eval ∷ QueryP ~> NextDSL
eval = coproduct cardEval nextEval

cardEval ∷ CC.CardEvalQuery ~> NextDSL
cardEval = case _ of
  CC.EvalCard value output next →
    H.modify (State._input .~ value.input) $> next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    pure $ k Card.NextAction
  CC.Load _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

takesInput ∷ Maybe Port.Port → CT.CardType → Boolean
takesInput input =
  maybe false (ICT.takesInput $ ICT.fromMaybePort input) ∘ ICT.fromCardType

possibleToGetTo ∷ Maybe Port.Port → CT.CardType → Boolean
possibleToGetTo input =
  maybe false (ICT.possibleToGetTo $ ICT.fromMaybePort input) ∘ ICT.fromCardType

addCardOrPresentReason ∷ ∀ a. Maybe Port.Port → CT.CardType → a -> Query a
addCardOrPresentReason input cardType a =
  if takesInput input cardType
     then AddCard cardType a
     else PresentReason input cardType a

dismissedAddCardGuideKey ∷ String
dismissedAddCardGuideKey = "dismissedAddCardGuide"

getDismissedAddCardGuideBefore ∷ NextDSL Boolean
getDismissedAddCardGuideBefore =
  H.liftH
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAddCardGuideKey

storeDismissedAddCardGuide ∷ NextDSL Unit
storeDismissedAddCardGuide =
  H.liftH $ LocalStorage.setLocalStorage dismissedAddCardGuideKey true

dismissAddCardGuide ∷ NextDSL Unit
dismissAddCardGuide =
  H.modify (State._presentAddCardGuide .~ false) *> storeDismissedAddCardGuide

nextEval ∷ Query ~> NextDSL
nextEval (AddCard _ next) = dismissAddCardGuide $> next
nextEval (PresentReason io card next) = pure next
nextEval (UpdateFilter str next) = H.modify (State._filterString .~ str) $> next
nextEval (DismissAddCardGuide next) = dismissAddCardGuide $> next
nextEval (Init next) = do
  H.modify ∘ (State._presentAddCardGuide .~ _) ∘ not =<< getDismissedAddCardGuideBefore
  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.Next.Component
 ( nextCardComponent
 , module SlamData.Workspace.Card.Next.Component.State
 , module SlamData.Workspace.Card.Next.Component.Query
 ) where

import SlamData.Prelude

import Data.Lens ((.~))
import Data.String as Str

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

import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Guide as Guide
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.Component.Query (QueryP, Query(..), _AddCardType, _PresentReason)
import SlamData.Workspace.Card.Next.Component.State (State)
import SlamData.Workspace.Card.Next.Component.State as State
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.InsertableCardType as ICT

import Utils.LocalStorage as LocalStorage

type NextHTML = H.ComponentHTML QueryP
type NextDSL = H.ComponentDSL State QueryP Slam

nextCardComponent ∷ CC.CardComponent
nextCardComponent = CC.makeCardComponent
  { cardType: CT.NextAction
  , component: H.lifecycleComponent { initializer: Just $ right $ H.action $ Init, finalizer: Nothing, render, eval}
  , initialState: State.initialState
  , _State: CC._NextState
  , _Query: CC.makeQueryPrism CC._NextQuery
  }

render ∷ State → NextHTML
render state =
  HH.div_
    $ (guard (not state.presentAddCardGuide) $>
      HH.form_
        [ HH.div_
            [ HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input (\s → right ∘ UpdateFilter s))
                , ARIA.label "Filter next actions"
                , HP.placeholder "Filter actions"
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ (right ∘ UpdateFilter ""))
                ]
                [ glyph B.glyphiconRemove ]
            ]
        ])
    ⊕ (guard state.presentAddCardGuide $>
        Guide.render
          (HH.className "sd-add-card-guide")
          (right ∘ DismissAddCardGuide)
          addCardGuideTextEmptyDeck)
    ⊕ [ HH.ul_ $ map nextButton CT.insertableCardTypes ]
  where

  filterString ∷ String
  filterString = Str.toLower state.filterString

  cardTitle ∷ CT.CardType → String
  cardTitle cty = "Insert " ⊕ CT.cardName cty ⊕ " card"

  nextButton ∷ CT.CardType → NextHTML
  nextButton cty =
    HH.li_
      [ HH.button attrs
          [ CT.lightCardGlyph cty
          , HH.p_ [ HH.text (CT.cardName cty) ]
          ]
      ]
    where
    enabled = Str.contains filterString (Str.toLower $ CT.cardName cty)
    attrs =
      [ HP.title $ cardTitle cty
      , HP.disabled $ not enabled
      , ARIA.label $ cardTitle cty
      ] ⊕ (guard (not $ takesInput state.input cty)
             $> HP.classes [ HH.className "sd-button-warning" ])
        ⊕ (guard enabled
             $> HE.onClick (HE.input_ (right ∘ addCardOrPresentReason state.input cty)))

  cardGuideText =
    "Cards retreive, process and present data, forms, charts and more."
      ⊕ " Every card creates an output which can be passed to another."
      ⊕ " By stacking cards into decks you can find valuable insights"
      ⊕ " and do amazing things."
  addCardGuideTextEmptyDeck = "To get this deck started press one of these buttons to add a card."
  addCardGuideTextNonEmptyDeck = "To do more with this deck press one of these buttons to add a card."

eval ∷ QueryP ~> NextDSL
eval = coproduct cardEval nextEval

cardEval ∷ CC.CardEvalQuery ~> NextDSL
cardEval = case _ of
  CC.EvalCard value output next →
    H.modify (State._input .~ value.input) $> next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    pure $ k Card.NextAction
  CC.Load _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

takesInput ∷ Maybe Port.Port → CT.CardType → Boolean
takesInput input =
  maybe false (ICT.takesInput $ ICT.fromMaybePort input) ∘ ICT.fromCardType

possibleToGetTo ∷ Maybe Port.Port → CT.CardType → Boolean
possibleToGetTo input =
  maybe false (ICT.possibleToGetTo $ ICT.fromMaybePort input) ∘ ICT.fromCardType

addCardOrPresentReason ∷ ∀ a. Maybe Port.Port → CT.CardType → a -> Query a
addCardOrPresentReason input cardType a =
  if takesInput input cardType
     then AddCard cardType a
     else PresentReason input cardType a

dismissedAddCardGuideKey ∷ String
dismissedAddCardGuideKey = "dismissedAddCardGuide"

getDismissedAddCardGuideBefore ∷ NextDSL Boolean
getDismissedAddCardGuideBefore =
  H.liftH
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAddCardGuideKey

storeDismissedAddCardGuide ∷ NextDSL Unit
storeDismissedAddCardGuide =
  H.liftH $ LocalStorage.setLocalStorage dismissedAddCardGuideKey true

nextEval ∷ Query ~> NextDSL
nextEval (AddCard _ next) = pure next
nextEval (PresentReason io card next) = pure next
nextEval (UpdateFilter str next) =
  H.modify (State._filterString .~ str) $> next
nextEval (DismissAddCardGuide next) =
  H.modify (State._presentAddCardGuide .~ false) *> storeDismissedAddCardGuide $> next
nextEval (Init next) = do
  H.modify ∘ (State._presentAddCardGuide .~ _) ∘ not =<< getDismissedAddCardGuideBefore
  pure next


Another exampleg

Another exampleg

module Main where

example1 :: String
example1 = do
  "Do"
  " notation"
  " for"
  " Semigroup"
  where
  (>>=) x f = x <> f unit

(*>) :: forall f a b. (Apply f) => f a -> f b -> f b
(*>) fa fb = const id <$> fa <*> fb

newtype Const a b = Const a

runConst :: forall a b. Const a b -> a
runConst (Const a) = a

instance functorConst :: Functor (Const a) where
  (<$>) _ (Const a) = Const a

instance applyConst :: (Semigroup a) => Apply (Const a) where
  (<*>) (Const a1) (Const a2) = Const (a1 <> a2)

example2 :: Const String Unit
example2 = do
  Const "Do"
  Const " notation"
  Const " for"
  Const " Apply"
  where
  (>>=) x f = x *> f unit

main = do
  Debug.Trace.trace example1
  Debug.Trace.trace $ runConst example2

module Main where

example :: String
example = do
  "Do"
  " notation"
  " for"
  " monoids"
  where
  (>>=) x f = x <> f unit

main = Debug.Trace.trace example


[CSE-105] Fix pagination render

[CSE-105] Fix pagination render

module Explorer.View.Common (
    placeholderView
    , txHeaderView
    , txBodyView
    , emptyTxBodyView
    , emptyTxHeaderView
    , getMaxPaginationNumber
    , mkTxHeaderViewProps
    , class TxHeaderViewPropsFactory
    , mkTxBodyViewProps
    , class TxBodyViewPropsFactory
    , currencyCSSClass
    , paginationView
    , txPaginationView
    , EmptyViewProps
    , mkEmptyViewProps
    , txEmptyContentView
    , noData
    , logoView
    , clickableLogoView
    , langView
    ) where

import Prelude
import Data.Int (ceil, fromString, toNumber)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language(..), readLanguage, translate)
import Explorer.I18n.Lenses (common, cDateFormat, tx, txEmpty) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (initialState)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), State)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkCoin)
import Explorer.Util.Time (prettyDate)
import Explorer.View.Lenses (txbAmount, txbInputs, txbOutputs, txhAmount, txhHash, txhTimeIssued)
import Exporer.View.Types (TxBodyViewProps(..), TxHeaderViewProps(..))
import Pos.Explorer.Web.ClientTypes (CCoin(..), CAddress(..), CTxBrief(..), CTxEntry(..), CTxSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId, getCoin, ctbId, ctbInputs, ctbOutputs, ctbOutputSum, ctbTimeIssued, cteId, cteTimeIssued, ctsBlockTimeIssued, ctsId, ctsInputs, ctsOutputs, ctsTotalOutput)
import Pux.Html (Html, text, div, p, span, input, option, select) as P
import Pux.Html.Attributes (className, href, value, disabled, type_, min, max, defaultValue) as P
import Pux.Html.Events (onChange, onFocus, FormEvent, MouseEvent, Target, onClick) as P
import Pux.Router (link) as P

-- -----------------
-- tx header
-- -----------------

-- | Factory to create TxHeaderViewProps by a given type
class TxHeaderViewPropsFactory a where
    mkTxHeaderViewProps :: a -> TxHeaderViewProps

-- | Creates a TxHeaderViewProps by a given CTxEntry
instance cTxEntryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxEntry where
    mkTxHeaderViewProps (CTxEntry entry) = TxHeaderViewProps
        { txhHash: entry ^. cteId
        , txhTimeIssued: Just $ entry ^. cteTimeIssued
        , txhAmount: entry . cteAmount
        }

-- | Creates a TxHeaderViewProps by a given CTxBrief
instance cTxBriefTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxBrief where
    mkTxHeaderViewProps (CTxBrief txBrief) = TxHeaderViewProps
        { txhHash: txBrief ^. ctbId
        , txhTimeIssued: Just $ txBrief ^. ctbTimeIssued
        , txhAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxHeaderViewProps by a given CTxSummary
instance cTxSummaryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxSummary where
    mkTxHeaderViewProps (CTxSummary txSummary) = TxHeaderViewProps
        { txhHash: txSummary ^. ctsId
        , txhTimeIssued: txSummary ^. ctsBlockTimeIssued
        , txhAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxHeaderViewProps by a given EmptyViewProps
instance emtpyTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory EmptyViewProps where
    mkTxHeaderViewProps _ = TxHeaderViewProps
        { txhHash: mkCTxId noData
        , txhTimeIssued: Nothing
        , txhAmount: mkCoin 0
        }

txHeaderView :: Language -> TxHeaderViewProps -> P.Html Action
txHeaderView lang (TxHeaderViewProps props) =
    P.div
          [ P.className "transaction-header"]
          [ P.link (toUrl <<< Tx $ props ^. txhHash)
              [ P.className "hash" ]
              [ P.text $ props ^. (txhHash <<< _CTxId <<< _CHash) ]
          , P.div
              [ P.className "date"]
              [ P.text $ case props ^. txhTimeIssued of
                              Just time ->
                                  let format = translate (I18nL.common <<< I18nL.cDateFormat) lang
                                  in fromMaybe noData $ prettyDate format time
                              Nothing -> noData
              ]
          , txAmountView $ props ^. txhAmount
          ]

emptyTxHeaderView :: P.Html Action
emptyTxHeaderView =
    P.div
        [ P.className "transaction-header"]
        [ ]

txAmountView :: CCoin -> P.Html Action
txAmountView (CCoin coin) =
    P.div
        [ P.className "amount-container" ]
        [ P.div
            [ P.className "amount bg-ada" ]
            [ P.text $ coin ^. getCoin]
        ]
-- -----------------
-- tx body
-- -----------------

-- | Factory to create TxBodyViewProps by a given type
class TxBodyViewPropsFactory a where
    mkTxBodyViewProps :: a -> TxBodyViewProps

-- | Creates a TxBodyViewProps by a given CTxSummary
instance cTxSummaryTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxSummary where
    mkTxBodyViewProps (CTxSummary txSummary) = TxBodyViewProps
        { txbInputs: txSummary ^. ctsInputs
        , txbOutputs: txSummary ^. ctsOutputs
        , txbAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxBodyViewProps by a given CTxBrief
instance cTxBriefTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxBrief where
    mkTxBodyViewProps (CTxBrief txBrief) = TxBodyViewProps
        { txbInputs: txBrief ^. ctbInputs
        , txbOutputs: txBrief ^. ctbOutputs
        , txbAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxBodyViewProps by a given EmptyViewProps
instance emptyTxBodyViewPropsFactory :: TxBodyViewPropsFactory EmptyViewProps where
    mkTxBodyViewProps _ = TxBodyViewProps
        { txbInputs: []
        , txbOutputs: []
        , txbAmount: mkCoin 0
        }

txBodyView :: TxBodyViewProps -> P.Html Action
txBodyView (TxBodyViewProps props) =
    P.div
        [ P.className "transaction-body" ]
        [ P.div
            [ P.className "from-hash-container" ]
            <<< map txFromView $ props ^. txbInputs
        , P.div
            [ P.className "to-hash-container bg-transaction-arrow" ]
            <<< map txToView $ props ^. txbOutputs
        , P.div
              [ P.className "amounts-container" ]
              <<< map txBodyAmountView $ props ^. txbOutputs
        , txAmountView $ props ^. txbAmount
        ]

emptyTxBodyView :: P.Html Action
emptyTxBodyView =
    P.div
        [ P.className "transaction-body" ]
        []

txFromView :: Tuple CAddress CCoin -> P.Html Action
txFromView (Tuple (CAddress cAddress) _) =
    P.link (toUrl <<< Address $ mkCAddress cAddress)
        [ P.className "from-hash" ]
        [ P.text cAddress ]

txToView :: Tuple CAddress CCoin -> P.Html Action
txToView (Tuple (CAddress cAddress) _) =
    P.link (toUrl <<< Address $ mkCAddress cAddress)
          [ P.className "to-hash"]
          [ P.text cAddress ]

txBodyAmountView :: Tuple CAddress CCoin -> P.Html Action
txBodyAmountView (Tuple _ (CCoin coin)) =
    P.div
        [ P.className "amount-wrapper" ]
        [ P.span
            [ P.className "plain-amount bg-ada-dark" ]
            [ P.text $ coin ^. getCoin ]
        ]

-- -----------------
-- pagination
-- -----------------

type PaginationViewProps =
    { label :: String
    , currentPage :: Int
    , maxPage :: Int
    , changePageAction :: (Int -> Action)
    , onFocusAction :: (P.Target -> Action)
    }

txPaginationView :: PaginationViewProps -> P.Html Action
txPaginationView props =
    P.div
        [ P.className "transaction-pagination"]
        [ paginationView props ]

paginationView :: PaginationViewProps -> P.Html Action
paginationView props =
    P.div
        [ P.className "pagination" ]
        [ P.div
            [ P.className "pagination__wrapper" ]
            [ P.div
                [ P.className $ "btn-page" <> disablePrevBtnClazz
                , P.onClick prevClickHandler ]
                [ P.div
                    [ P.className "icon bg-triangle-left" ]
                    []
                ]
            , P.input
                [ P.className "page-number"
                , P.value <<< show $ props.currentPage
                , P.disabled $ props.maxPage == minPage
                , P.min $ show minPage
                , P.max $ show props.maxPage
                , P.onChange changeHandler
                , P.onFocus $ props.onFocusAction <<< _.target
                ]
                []
            , P.p
                [ P.className "label" ]
                [ P.text props.label ]
            , P.input
                [ P.className "page-number"
                , P.disabled true
                , P.type_ "search"
                , P.value $ show props.maxPage
                ]
                []
            , P.div
                [ P.className $ "btn-page" <> disableNextBtnClazz
                  , P.onClick nextClickHandler ]
                [ P.div
                    [ P.className "icon bg-triangle-right" ]
                    []
                ]
            ]
        ]
        where
          minPage = 1
          disablePrevBtnClazz = if props.currentPage == minPage then " disabled" else ""
          disableNextBtnClazz = if props.currentPage == props.maxPage then " disabled" else ""
          nextClickHandler :: P.MouseEvent -> Action
          nextClickHandler _ =
              if props.currentPage < props.maxPage then
              props.changePageAction $ props.currentPage + 1
              else
              NoOp

          prevClickHandler :: P.MouseEvent -> Action
          prevClickHandler _ =
              if props.currentPage > minPage then
              props.changePageAction $ props.currentPage - 1
              else
              NoOp

          changeHandler :: P.FormEvent -> Action
          changeHandler ev =
              let value = fromMaybe props.currentPage <<< fromString <<< _.value $ _.target ev in
              if value >= minPage && value <= props.maxPage
              then props.changePageAction value
              else NoOp

getMaxPaginationNumber :: Int -> Int -> Int
getMaxPaginationNumber quantity max =
    ceil (toNumber quantity / toNumber max)

-- -----------------
-- txs empty view
-- -----------------

txEmptyContentView :: Language -> P.Html Action
txEmptyContentView lang = P.div
                        [ P.className "tx-empty__container" ]
                        [ P.text $ translate (I18nL.tx <<< I18nL.txEmpty) lang ]

-- -----------------
-- logo
-- -----------------

logoView' :: Maybe Route -> P.Html Action
logoView' mRoute =
    let logoContentTag = case mRoute of
                              Just route -> P.link (toUrl route)
                              Nothing -> P.div
    in
    P.div
        [ P.className "logo__container"]
        [ P.div
            [ P.className "logo__wrapper"]
            [ logoContentTag
                [ P.className "logo__img bg-logo"
                , P.href "/"]
                []
            ]
        ]

logoView :: P.Html Action
logoView = logoView' Nothing

clickableLogoView :: Route -> P.Html Action
clickableLogoView = logoView' <<< Just

-- -----------------
-- lang
-- -----------------

-- currency

langItems :: Array Language
langItems =
    [ English
    , Japanese
    , German
    ]

langView :: State -> P.Html Action
langView state =
  P.select
      [ P.className "lang__select bg-arrow-up"
      , P.defaultValue <<< show $ state ^. lang
      , P.onChange $ SetLanguage <<< fromMaybe (_.lang initialState) <<< readLanguage <<< _.value <<< _.target]
      $ map (langItemView state) langItems

langItemView :: State -> Language -> P.Html Action
langItemView state lang =
  P.option
    [ P.value $ show lang
    ]
    [ P.text $ show lang ]

-- -----------------
-- helper
-- -----------------

newtype EmptyViewProps = EmptyViewProps {}

mkEmptyViewProps :: EmptyViewProps
mkEmptyViewProps = EmptyViewProps {}

noData :: String
noData = "--"

currencyCSSClass :: Maybe CCurrency -> String
currencyCSSClass mCurrency =
  case mCurrency of
      Just ADA -> " currency ada bg-ada-dark"
      Just USD -> " currency usd bg-usd-dark"
      _ -> ""

-- TODO (jk) Remove placeholderView if all views are implemented
placeholderView :: String -> P.Html Action
placeholderView label =
    P.div
        [ P.className "explorer-dashboard__content" ]
        [ P.text label ]

module Explorer.View.Common (
    placeholderView
    , txHeaderView
    , txBodyView
    , emptyTxBodyView
    , emptyTxHeaderView
    , getMaxPaginationNumber
    , mkTxHeaderViewProps
    , class TxHeaderViewPropsFactory
    , mkTxBodyViewProps
    , class TxBodyViewPropsFactory
    , currencyCSSClass
    , paginationView
    , txPaginationView
    , EmptyViewProps
    , mkEmptyViewProps
    , txEmptyContentView
    , noData
    , logoView
    , clickableLogoView
    , langView
    ) where

import Prelude
import Data.Int (ceil, fromString, toNumber)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language(..), readLanguage, translate)
import Explorer.I18n.Lenses (common, cDateFormat, tx, txEmpty) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (initialState)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), State)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkCoin)
import Explorer.Util.Time (prettyDate)
import Explorer.View.Lenses (txbAmount, txbInputs, txbOutputs, txhAmount, txhHash, txhTimeIssued)
import Exporer.View.Types (TxBodyViewProps(..), TxHeaderViewProps(..))
import Pos.Explorer.Web.ClientTypes (CCoin(..), CAddress(..), CTxBrief(..), CTxEntry(..), CTxSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId, getCoin, ctbId, ctbInputs, ctbOutputs, ctbOutputSum, ctbTimeIssued, cteId, cteTimeIssued, ctsBlockTimeIssued, ctsId, ctsInputs, ctsOutputs, ctsTotalOutput)
import Pux.Html (Html, text, div, p, span, input, option, select) as P
import Pux.Html.Attributes (className, href, value, disabled, type_, min, max, defaultValue) as P
import Pux.Html.Events (onChange, onFocus, FormEvent, MouseEvent, Target, onClick) as P
import Pux.Router (link) as P

-- -----------------
-- tx header
-- -----------------

-- | Factory to create TxHeaderViewProps by a given type
class TxHeaderViewPropsFactory a where
    mkTxHeaderViewProps :: a -> TxHeaderViewProps

-- | Creates a TxHeaderViewProps by a given CTxEntry
instance cTxEntryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxEntry where
    mkTxHeaderViewProps (CTxEntry entry) = TxHeaderViewProps
        { txhHash: entry ^. cteId
        , txhTimeIssued: Just $ entry ^. cteTimeIssued
        , txhAmount: entry . cteAmount
        }

-- | Creates a TxHeaderViewProps by a given CTxBrief
instance cTxBriefTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxBrief where
    mkTxHeaderViewProps (CTxBrief txBrief) = TxHeaderViewProps
        { txhHash: txBrief ^. ctbId
        , txhTimeIssued: Just $ txBrief ^. ctbTimeIssued
        , txhAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxHeaderViewProps by a given CTxSummary
instance cTxSummaryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxSummary where
    mkTxHeaderViewProps (CTxSummary txSummary) = TxHeaderViewProps
        { txhHash: txSummary ^. ctsId
        , txhTimeIssued: txSummary ^. ctsBlockTimeIssued
        , txhAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxHeaderViewProps by a given EmptyViewProps
instance emtpyTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory EmptyViewProps where
    mkTxHeaderViewProps _ = TxHeaderViewProps
        { txhHash: mkCTxId noData
        , txhTimeIssued: Nothing
        , txhAmount: mkCoin 0
        }

txHeaderView :: Language -> TxHeaderViewProps -> P.Html Action
txHeaderView lang (TxHeaderViewProps props) =
    P.div
          [ P.className "transaction-header"]
          [ P.link (toUrl <<< Tx $ props ^. txhHash)
              [ P.className "hash" ]
              [ P.text $ props ^. (txhHash <<< _CTxId <<< _CHash) ]
          , P.div
              [ P.className "date"]
              [ P.text $ case props ^. txhTimeIssued of
                              Just time ->
                                  let format = translate (I18nL.common <<< I18nL.cDateFormat) lang
                                  in fromMaybe noData $ prettyDate format time
                              Nothing -> noData
              ]
          , txAmountView $ props ^. txhAmount
          ]

emptyTxHeaderView :: P.Html Action
emptyTxHeaderView =
    P.div
        [ P.className "transaction-header"]
        [ ]

txAmountView :: CCoin -> P.Html Action
txAmountView (CCoin coin) =
    P.div
        [ P.className "amount-container" ]
        [ P.div
            [ P.className "amount bg-ada" ]
            [ P.text $ coin ^. getCoin]
        ]
-- -----------------
-- tx body
-- -----------------

-- | Factory to create TxBodyViewProps by a given type
class TxBodyViewPropsFactory a where
    mkTxBodyViewProps :: a -> TxBodyViewProps

-- | Creates a TxBodyViewProps by a given CTxSummary
instance cTxSummaryTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxSummary where
    mkTxBodyViewProps (CTxSummary txSummary) = TxBodyViewProps
        { txbInputs: txSummary ^. ctsInputs
        , txbOutputs: txSummary ^. ctsOutputs
        , txbAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxBodyViewProps by a given CTxBrief
instance cTxBriefTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxBrief where
    mkTxBodyViewProps (CTxBrief txBrief) = TxBodyViewProps
        { txbInputs: txBrief ^. ctbInputs
        , txbOutputs: txBrief ^. ctbOutputs
        , txbAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxBodyViewProps by a given EmptyViewProps
instance emptyTxBodyViewPropsFactory :: TxBodyViewPropsFactory EmptyViewProps where
    mkTxBodyViewProps _ = TxBodyViewProps
        { txbInputs: []
        , txbOutputs: []
        , txbAmount: mkCoin 0
        }

txBodyView :: TxBodyViewProps -> P.Html Action
txBodyView (TxBodyViewProps props) =
    P.div
        [ P.className "transaction-body" ]
        [ P.div
            [ P.className "from-hash-container" ]
            <<< map txFromView $ props ^. txbInputs
        , P.div
            [ P.className "to-hash-container bg-transaction-arrow" ]
            <<< map txToView $ props ^. txbOutputs
        , P.div
              [ P.className "amounts-container" ]
              <<< map txBodyAmountView $ props ^. txbOutputs
        , txAmountView $ props ^. txbAmount
        ]

emptyTxBodyView :: P.Html Action
emptyTxBodyView =
    P.div
        [ P.className "transaction-body" ]
        []

txFromView :: Tuple CAddress CCoin -> P.Html Action
txFromView (Tuple (CAddress cAddress) _) =
    P.link (toUrl <<< Address $ mkCAddress cAddress)
        [ P.className "from-hash" ]
        [ P.text cAddress ]

txToView :: Tuple CAddress CCoin -> P.Html Action
txToView (Tuple (CAddress cAddress) _) =
    P.link (toUrl <<< Address $ mkCAddress cAddress)
          [ P.className "to-hash"]
          [ P.text cAddress ]

txBodyAmountView :: Tuple CAddress CCoin -> P.Html Action
txBodyAmountView (Tuple _ (CCoin coin)) =
    P.div
        [ P.className "amount-wrapper" ]
        [ P.span
            [ P.className "plain-amount bg-ada-dark" ]
            [ P.text $ coin ^. getCoin ]
        ]

-- -----------------
-- pagination
-- -----------------

type PaginationViewProps =
    { label :: String
    , currentPage :: Int
    , maxPage :: Int
    , changePageAction :: (Int -> Action)
    , onFocusAction :: (P.Target -> Action)
    }

txPaginationView :: PaginationViewProps -> P.Html Action
txPaginationView props =
    P.div
        [ P.className "transaction-pagination"]
        [ paginationView props ]

paginationView :: PaginationViewProps -> P.Html Action
paginationView props =
    P.div
        [ P.className "pagination" ]
        [ P.div
            [ P.className "pagination__wrapper" ]
            [ P.div
                [ P.className $ "btn-page" <> disablePrevBtnClazz
                , P.onClick prevClickHandler ]
                [ P.div
                    [ P.className "icon bg-triangle-left" ]
                    []
                ]
            , P.input
                [ P.className "page-number"
                , P.value <<< show $ props.currentPage
                , P.disabled $ props.maxPage == minPage
                , P.min $ show minPage
                , P.max $ show props.maxPage
                , P.onChange changeHandler
                , P.onFocus $ props.onFocusAction <<< _.target
                ]
                []
            , P.p
                [ P.className "label" ]
                [ P.text props.label ]
            , P.input
                [ P.className "page-number"
                , P.disabled true
                , P.type_ "number"
                , P.value $ show props.maxPage
                ]
                []
            , P.div
                [ P.className $ "btn-page" <> disableNextBtnClazz
                  , P.onClick nextClickHandler ]
                [ P.div
                    [ P.className "icon bg-triangle-right" ]
                    []
                ]
            ]
        ]
        where
          minPage = 1
          disablePrevBtnClazz = if props.currentPage == minPage then " disabled" else ""
          disableNextBtnClazz = if props.currentPage == props.maxPage then " disabled" else ""
          nextClickHandler :: P.MouseEvent -> Action
          nextClickHandler _ =
              if props.currentPage < props.maxPage then
              props.changePageAction $ props.currentPage + 1
              else
              NoOp

          prevClickHandler :: P.MouseEvent -> Action
          prevClickHandler _ =
              if props.currentPage > minPage then
              props.changePageAction $ props.currentPage - 1
              else
              NoOp

          changeHandler :: P.FormEvent -> Action
          changeHandler ev =
              let value = fromMaybe props.currentPage <<< fromString <<< _.value $ _.target ev in
              if value >= minPage && value <= props.maxPage
              then props.changePageAction value
              else NoOp

getMaxPaginationNumber :: Int -> Int -> Int
getMaxPaginationNumber quantity max =
    ceil (toNumber quantity / toNumber max)

-- -----------------
-- txs empty view
-- -----------------

txEmptyContentView :: Language -> P.Html Action
txEmptyContentView lang = P.div
                        [ P.className "tx-empty__container" ]
                        [ P.text $ translate (I18nL.tx <<< I18nL.txEmpty) lang ]

-- -----------------
-- logo
-- -----------------

logoView' :: Maybe Route -> P.Html Action
logoView' mRoute =
    let logoContentTag = case mRoute of
                              Just route -> P.link (toUrl route)
                              Nothing -> P.div
    in
    P.div
        [ P.className "logo__container"]
        [ P.div
            [ P.className "logo__wrapper"]
            [ logoContentTag
                [ P.className "logo__img bg-logo"
                , P.href "/"]
                []
            ]
        ]

logoView :: P.Html Action
logoView = logoView' Nothing

clickableLogoView :: Route -> P.Html Action
clickableLogoView = logoView' <<< Just

-- -----------------
-- lang
-- -----------------

-- currency

langItems :: Array Language
langItems =
    [ English
    , Japanese
    , German
    ]

langView :: State -> P.Html Action
langView state =
  P.select
      [ P.className "lang__select bg-arrow-up"
      , P.defaultValue <<< show $ state ^. lang
      , P.onChange $ SetLanguage <<< fromMaybe (_.lang initialState) <<< readLanguage <<< _.value <<< _.target]
      $ map (langItemView state) langItems

langItemView :: State -> Language -> P.Html Action
langItemView state lang =
  P.option
    [ P.value $ show lang
    ]
    [ P.text $ show lang ]

-- -----------------
-- helper
-- -----------------

newtype EmptyViewProps = EmptyViewProps {}

mkEmptyViewProps :: EmptyViewProps
mkEmptyViewProps = EmptyViewProps {}

noData :: String
noData = "--"

currencyCSSClass :: Maybe CCurrency -> String
currencyCSSClass mCurrency =
  case mCurrency of
      Just ADA -> " currency ada bg-ada-dark"
      Just USD -> " currency usd bg-usd-dark"
      _ -> ""

-- TODO (jk) Remove placeholderView if all views are implemented
placeholderView :: String -> P.Html Action
placeholderView label =
    P.div
        [ P.className "explorer-dashboard__content" ]
        [ P.text label ]


Update some names and comments

Update some names and comments

module Halogen.Query.EventSource
  ( EventSource(..)
  , unEventSource
  , interpret
  , hoist
  , eventSource
  , eventSource'
  , eventSource_
  , eventSource_'
  , catMaybes
  , produce
  , produce'
  , produceAff
  , produceAff'
  ) where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Aff (Aff, runAff, forkAff, attempt)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Free.Trans as FT
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.Trans.Class (lift)

import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Maybe (Maybe)

newtype EventSource f m = EventSource (m { producer :: CR.Producer (f Boolean) m Unit, done :: m Unit })

unEventSource :: forall f m. EventSource f m -> m { producer :: CR.Producer (f Boolean) m Unit, done :: m Unit }
unEventSource (EventSource e) = e

interpret :: forall f g m. Functor m => (f ~> g) -> EventSource f m -> EventSource g m
interpret nat (EventSource es) =
  EventSource $
    map
      (\e -> { producer: FT.interpret (lmap nat) e.producer, done: e.done })
      es

hoist :: forall f m n. Functor n => (m ~> n) -> EventSource f m -> EventSource f n
hoist nat (EventSource es) =
  EventSource $
    map
      (\e -> { producer: FT.hoistFreeT nat e.producer, done: nat e.done })
      (nat es)

-- | Creates an `EventSource` for a callback that accepts one argument.
-- |
-- | - The first argument is the function that attaches the listener.
-- | - The second argument is a handler that optionally produces a value in `f`.
eventSource
  :: forall f m a eff
   . MonadAff (avar :: AVAR | eff) m
  => ((a -> Eff (avar :: AVAR | eff) Unit) -> Eff (avar :: AVAR | eff) Unit)
  -> (a -> Maybe (f Boolean))
  -> EventSource f m
eventSource attach handler =
  EventSource
    let producer = produce \emit -> attach (emit <<< Left <<< handler)
    in pure { producer: FT.hoistFreeT liftAff $ catMaybes producer, done: pure unit }

-- | Similar to `eventSource` but allows the attachment function to return an
-- | action to perform when the handler is detached.
eventSource'
  :: forall f m a eff
   . MonadAff (avar :: AVAR | eff) m
  => ((a -> Eff (avar :: AVAR | eff) Unit) -> Eff (avar :: AVAR | eff) (Eff (avar :: AVAR | eff) Unit))
  -> (a -> Maybe (f Boolean))
  -> EventSource f m
eventSource' attach handler = do
  EventSource do
    { producer, cancel } <- liftAff $ produce' \emit -> attach (emit <<< Left <<< handler)
    pure
      { producer: FT.hoistFreeT liftAff $ catMaybes producer
      , done: liftAff $ void $ cancel unit
      }

-- | Creates an `EventSource` for a callback that accepts no arguments.
-- |
-- | - The first argument is the function that attaches the listener.
-- | - The second argument is the query to raise whenever the listener is
-- |   triggered.
eventSource_
  :: forall f m eff
   . MonadAff (avar :: AVAR | eff) m
  => (Eff (avar :: AVAR | eff) Unit -> Eff (avar :: AVAR | eff) Unit)
  -> f Boolean
  -> EventSource f m
eventSource_ attach query =
  EventSource
    let producer = produce \emit -> attach $ emit (Left query)
    in pure { producer: FT.hoistFreeT liftAff producer, done: pure unit }

-- | Similar to `eventSource_` but allows the attachment function to return an
-- | action to perform when the handler is detached.
eventSource_'
  :: forall f m eff
   . MonadAff (avar :: AVAR | eff) m
  => (Eff (avar :: AVAR | eff) Unit -> Eff (avar :: AVAR | eff) (Eff (avar :: AVAR | eff) Unit))
  -> f Boolean
  -> EventSource f m
eventSource_' attach query =
  EventSource do
    { producer, cancel } <- liftAff $ produce' \emit -> attach $ emit (Left query)
    pure
      { producer: FT.hoistFreeT liftAff producer
      , done: liftAff $ void $ cancel unit
      }

-- | Takes a producer of `Maybe`s and filters out the `Nothings`. Useful for
-- | constructing `EventSource`s for producers that don't need to handle every
-- | event.
catMaybes
  :: forall m a r
   . MonadRec m
  => CR.Producer (Maybe a) m r
  -> CR.Producer a m r
catMaybes =
  tailRecM $ FT.resume >>> lift >=> case _ of
    Left r -> pure $ Done r
    Right (CR.Emit ma next) -> for_ ma CR.emit $> Loop next

produce
  :: forall a r eff
   . ((Either a r -> Eff (avar :: AVAR | eff) Unit) -> Eff (avar :: AVAR | eff) Unit)
  -> CR.Producer a (Aff (avar :: AVAR | eff)) r
produce recv = produceAff (\send ->
  liftEff (recv (void <<< runAff (const (pure unit)) pure <<< send)))

produce'
  :: forall a r eff
   . ((Either a r -> Eff (avar :: AVAR | eff) Unit) -> Eff (avar :: AVAR | eff) (Eff (avar :: AVAR | eff) Unit))
  -> Aff (avar :: AVAR | eff) { producer :: CR.Producer a (Aff (avar :: AVAR | eff)) r, cancel :: r -> Aff (avar :: AVAR | eff) Boolean }
produce' recv =
  produceAff' \send -> do
    x <- liftEff $ recv (void <<< runAff (const (pure unit)) pure <<< send)
    pure (liftEff x)

produceAff
  :: forall a r eff m
   . MonadAff (avar :: AVAR | eff) m
  => ((Either a r -> Aff (avar :: AVAR | eff) Unit) -> Aff (avar :: AVAR | eff) Unit)
  -> CR.Producer a m r
produceAff recv = do
  v <- lift $ liftAff AV.makeVar
  lift $ liftAff $ forkAff $ recv $ AV.putVar v
  CR.producer $ liftAff $ AV.takeVar v

produceAff'
  :: forall a r eff
   . ((Either a r -> Aff (avar :: AVAR | eff) Unit) -> Aff (avar :: AVAR | eff) (Aff (avar :: AVAR | eff) Unit))
  -> Aff (avar :: AVAR | eff) { producer :: CR.Producer a (Aff (avar :: AVAR | eff)) r, cancel :: r -> Aff (avar :: AVAR | eff) Boolean }
produceAff' recv = do
  inputVar <- AV.makeVar
  finalizeVar <- AV.makeVar
  let
    producer = do
      lift $ AV.putVar finalizeVar =<< recv (AV.putVar inputVar)
      CR.producer (AV.takeVar inputVar)
    cancel r =
      attempt (AV.takeVar finalizeVar) >>= case _ of
        Left _ -> pure false
        Right finalizer -> do
          AV.killVar finalizeVar (Exn.error "finalized")
          finalizer
          pure true
  pure { producer, cancel }

module Halogen.Query.EventSource
  ( EventSource(..)
  , unEventSource
  , interpret
  , hoist
  , eventSource
  , eventSource'
  , eventSource_
  , eventSource_'
  , catMaybes
  , produce
  , produce'
  , produceAff
  , produceAff'
  ) where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Aff (Aff, runAff, forkAff, attempt)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Free.Trans as FT
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.Trans.Class (lift)

import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Maybe (Maybe)

newtype EventSource f m = EventSource (m { producer :: CR.Producer (f Boolean) m Unit, done :: m Unit })

unEventSource :: forall f m. EventSource f m -> m { producer :: CR.Producer (f Boolean) m Unit, done :: m Unit }
unEventSource (EventSource e) = e

interpret :: forall f g m. Functor m => (f ~> g) -> EventSource f m -> EventSource g m
interpret nat (EventSource es) =
  EventSource $
    map
      (\e -> { producer: FT.interpret (lmap nat) e.producer, done: e.done })
      es

hoist :: forall f m n. Functor n => (m ~> n) -> EventSource f m -> EventSource f n
hoist nat (EventSource es) =
  EventSource $
    map
      (\e -> { producer: FT.hoistFreeT nat e.producer, done: nat e.done })
      (nat es)

-- | Creates an `EventSource` for an event listener that accepts one argument.
-- |
-- | - The first argument is the function that attaches the event listener.
-- | - The second argument is a handler that optionally produces a value in `f`.
eventSource
  :: forall f m a eff
   . MonadAff (avar :: AVAR | eff) m
  => ((a -> Eff (avar :: AVAR | eff) Unit) -> Eff (avar :: AVAR | eff) Unit)
  -> (a -> Maybe (f Boolean))
  -> EventSource f m
eventSource attach handle =
  EventSource
    let producer = produce \emit -> attach (emit <<< Left <<< handle)
    in pure { producer: FT.hoistFreeT liftAff $ catMaybes producer, done: pure unit }

-- | Similar to `eventSource` but allows the attachment function to return an
-- | action to perform when the handler is detached.
eventSource'
  :: forall f m a eff
   . MonadAff (avar :: AVAR | eff) m
  => ((a -> Eff (avar :: AVAR | eff) Unit) -> Eff (avar :: AVAR | eff) (Eff (avar :: AVAR | eff) Unit))
  -> (a -> Maybe (f Boolean))
  -> EventSource f m
eventSource' attach handle = do
  EventSource do
    { producer, cancel } <- liftAff $ produce' (\emit -> attach (emit <<< Left <<< handle))
    pure
      { producer: FT.hoistFreeT liftAff $ catMaybes producer
      , done: liftAff $ void $ cancel unit
      }

-- | Creates an `EventSource` for an event listener that accepts no arguments.
-- |
-- | - The first argument is the function that attaches the event listener.
-- | - The second argument is a handler that optionally produces a value in `f`.
eventSource_
  :: forall f m eff
   . MonadAff (avar :: AVAR | eff) m
  => (Eff (avar :: AVAR | eff) Unit -> Eff (avar :: AVAR | eff) Unit)
  -> f Boolean
  -> EventSource f m
eventSource_ attach handle =
  EventSource
    let producer = produce \emit -> attach $ emit (Left handle)
    in pure { producer: FT.hoistFreeT liftAff producer, done: pure unit }

-- | Similar to `eventSource_` but allows the attachment function to return an
-- | action to perform when the handler is detached.
eventSource_'
  :: forall f m eff
   . MonadAff (avar :: AVAR | eff) m
  => (Eff (avar :: AVAR | eff) Unit -> Eff (avar :: AVAR | eff) (Eff (avar :: AVAR | eff) Unit))
  -> f Boolean
  -> EventSource f m
eventSource_' attach handle =
  EventSource do
    { producer, cancel } <- liftAff $ produce' \emit -> attach $ emit (Left handle)
    pure
      { producer: FT.hoistFreeT liftAff producer
      , done: liftAff $ void $ cancel unit
      }

-- | Takes a producer of `Maybe`s and filters out the `Nothings`. Useful for
-- | constructing `EventSource`s for producers that don't need to handle every
-- | event.
catMaybes
  :: forall m a r
   . MonadRec m
  => CR.Producer (Maybe a) m r
  -> CR.Producer a m r
catMaybes =
  tailRecM $ FT.resume >>> lift >=> case _ of
    Left r -> pure $ Done r
    Right (CR.Emit ma next) -> for_ ma CR.emit $> Loop next

produce
  :: forall a r eff
   . ((Either a r -> Eff (avar :: AVAR | eff) Unit) -> Eff (avar :: AVAR | eff) Unit)
  -> CR.Producer a (Aff (avar :: AVAR | eff)) r
produce recv = produceAff (\send ->
  liftEff (recv (void <<< runAff (const (pure unit)) pure <<< send)))

produce'
  :: forall a r eff
   . ((Either a r -> Eff (avar :: AVAR | eff) Unit) -> Eff (avar :: AVAR | eff) (Eff (avar :: AVAR | eff) Unit))
  -> Aff (avar :: AVAR | eff) { producer :: CR.Producer a (Aff (avar :: AVAR | eff)) r, cancel :: r -> Aff (avar :: AVAR | eff) Boolean }
produce' recv =
  produceAff' \send -> do
    x <- liftEff $ recv (void <<< runAff (const (pure unit)) pure <<< send)
    pure (liftEff x)

produceAff
  :: forall a r eff m
   . MonadAff (avar :: AVAR | eff) m
  => ((Either a r -> Aff (avar :: AVAR | eff) Unit) -> Aff (avar :: AVAR | eff) Unit)
  -> CR.Producer a m r
produceAff recv = do
  v <- lift $ liftAff AV.makeVar
  lift $ liftAff $ forkAff $ recv $ AV.putVar v
  CR.producer $ liftAff $ AV.takeVar v

produceAff'
  :: forall a r eff
   . ((Either a r -> Aff (avar :: AVAR | eff) Unit) -> Aff (avar :: AVAR | eff) (Aff (avar :: AVAR | eff) Unit))
  -> Aff (avar :: AVAR | eff) { producer :: CR.Producer a (Aff (avar :: AVAR | eff)) r, cancel :: r -> Aff (avar :: AVAR | eff) Boolean }
produceAff' recv = do
  inputVar <- AV.makeVar
  finalizeVar <- AV.makeVar
  let
    producer = do
      lift $ AV.putVar finalizeVar =<< recv (AV.putVar inputVar)
      CR.producer (AV.takeVar inputVar)
    cancel r =
      attempt (AV.takeVar finalizeVar) >>= case _ of
        Left _ -> pure false
        Right finalizer -> do
          AV.killVar finalizeVar (Exn.error "finalized")
          finalizer
          pure true
  pure { producer, cancel }


Workaround completion at end of file bug. Fix #79

module IdePurescript.VSCode.Text where

import Prelude

import Data.Array (findIndex, last, length, null, reverse, slice, zip)
import Data.Maybe (Maybe(..))
import Data.String (Pattern(..), joinWith, split)
import Data.Tuple (uncurry)
import LanguageServer.Types (DocumentUri, Position(..), Range(..), TextDocumentEdit(..), TextDocumentIdentifier(..), TextEdit(..), WorkspaceEdit, workspaceEdit)

makeWorkspaceEdit :: DocumentUri -> Number -> Range -> String -> WorkspaceEdit
makeWorkspaceEdit uri version range newText = workspaceEdit [ edit ]
  where
      textEdit = TextEdit { range, newText }
      docid = TextDocumentIdentifier { uri, version }
      edit = TextDocumentEdit { textDocument: docid, edits: [ textEdit ] }

-- | Make a full-text workspace edit via a minimal diff under the assumption that at most one change is required
-- | In particular the scenario of inserting text in the middle AC -> ABC becomes an edit of B only.
makeMinimalWorkspaceEdit :: DocumentUri -> Number -> String -> String -> Maybe WorkspaceEdit
makeMinimalWorkspaceEdit uri version oldText newText =
  let newLines = split (Pattern "\n") newText
      oldLines = case split (Pattern "\n") oldText of
        -- Add imports adds a newline to the end of the file always, giving bad diffs
        xs | last xs /= Just "" && last newLines == Just "" -> xs <> [""]
        xs -> xs

      range text l1 l2 = Range
        { start: Position { line: l1, character: 0 },
          end: Position { line: length text - l2 + 1, character: 0 }
        }
      lines text l1 l2 = slice l1 (length text - l2 + 1) text

      firstDiff = findIndex (uncurry (/=)) (zip oldLines newLines)
      lastDiff = findIndex (uncurry (/=)) (zip (reverse oldLines) (reverse newLines))

      e a b = Just $ makeWorkspaceEdit uri version a b
      oldLen = length oldLines
      newLen = length newLines

  in case firstDiff, lastDiff of
      Just n, Just m
        | oldLen - m >= n && newLen - m >= n
          -> e (range oldLines n m) (joinWith "\n" (lines newLines n m) <> if null newLines then "" else "\n")
      Nothing, Nothing
        | oldLen == newLen -> Nothing
      _, _ -> e (range oldLines 0 0) newText

module IdePurescript.VSCode.Text where

import Prelude
import Data.Array (findIndex, length, null, reverse, slice, zip)
import Data.Maybe (Maybe(..))
import Data.String (Pattern(..), joinWith, split)
import Data.Tuple (uncurry)
import LanguageServer.Types (DocumentUri, Position(..), Range(..), TextDocumentEdit(..), TextDocumentIdentifier(..), TextEdit(..), WorkspaceEdit, workspaceEdit)

makeWorkspaceEdit :: DocumentUri -> Number -> Range -> String -> WorkspaceEdit
makeWorkspaceEdit uri version range newText = workspaceEdit [ edit ]
  where
      textEdit = TextEdit { range, newText }
      docid = TextDocumentIdentifier { uri, version }
      edit = TextDocumentEdit { textDocument: docid, edits: [ textEdit ] }

-- | Make a full-text workspace edit via a minimal diff under the assumption that at most one change is required
-- | In particular the scenario of inserting text in the middle AC -> ABC becomes an edit of B only.
makeMinimalWorkspaceEdit :: DocumentUri -> Number -> String -> String -> Maybe WorkspaceEdit
makeMinimalWorkspaceEdit uri version oldText newText =
  let oldLines = split (Pattern "\n") oldText
      newLines = split (Pattern "\n") newText

      range text l1 l2 = Range
        { start: Position { line: l1, character: 0 },
          end: Position { line: length text - l2 + 1, character: 0 }
        }
      lines text l1 l2 = slice l1 (length text - l2 + 1) text

      firstDiff = findIndex (uncurry (/=)) (zip oldLines newLines)
      lastDiff = findIndex (uncurry (/=)) (zip (reverse oldLines) (reverse newLines))

      e a b = Just $ makeWorkspaceEdit uri version a b
      oldLen = length oldLines
      newLen = length newLines
  in case firstDiff, lastDiff of
      Just n, Just m
        | oldLen - m >= n && newLen - m >= n
          -> e (range oldLines n m) (joinWith "\n" (lines newLines n m) <> if null newLines then "" else "\n")
      Nothing, Nothing
        | oldLen == newLen -> Nothing
      _, _ -> e (range oldLines 0 0) newText