_connect: access context in the child component

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Free (Free)
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Data.Lens (Lens', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox (ReadRedox, SubscribeRedox, ReadWriteSubscribeRedox, Store, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl eff = Free dsl (state -> state) -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' eff
   . (ReactThis props' (ConnectState state')
      -> Eff (context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff) (RedoxContext state dsl eff))
  -> Lens' state state'
  -> ((DispatchFn state dsl eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = R.transformState this (_ { state = view _lns state })

    getInitialState this = do
      ctx <- addReactDisallowedEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- addReactEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      ctx <- addReactReadOnlyEff $ ctxEff this
      msid <- (R.readState this) >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    renderFn this = do
      props' <- R.getProps this
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- unsafeCoerceEff $ R.readState this >>= pure <<< _.state
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') []

    addReactEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadWrite, refs :: R.ReactRefs (() :: # Effect) | e ) a
    addReactEff = unsafeCoerceEff

    addReactDisallowedEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.Disallowed, refs :: R.ReactRefs R.Disallowed | e ) a
    addReactDisallowedEff = unsafeCoerceEff

    addReactReadOnlyEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadOnly, refs :: R.ReactRefs R.ReadOnly | e) a
    addReactReadOnlyEff = unsafeCoerceEff

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' eff
   . Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = readContext (Proxy :: Proxy (RedoxContext state dsl eff)) this

connect
  :: forall state state' dsl props props' eff'
   . Lens' state state'
  -> (DispatchFn state dsl eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' eff
   . Store state
  -> DispatchFn state dsl eff
  -> Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl props state eff
   . ReactThis props state
  -> Free dsl (state -> state)
  -> Eff (ReadWriteSubscribeRedox (context :: CONTEXT | eff)) (Canceler (ReadWriteSubscribeRedox (context :: CONTEXT | eff)))
dispatch this dsl = do
  _dispatch <- readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (context :: CONTEXT | eff) }) ) this >>= pure <<< _.redox.dispatch
  _dispatch dsl

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Free (Free)
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Data.Lens (Lens', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox (ReadRedox, SubscribeRedox, ReadWriteSubscribeRedox, Store, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl eff = Free dsl (state -> state) -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' eff
   . (ReactThis props' (ConnectState state')
      -> Eff (context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff) (RedoxContext state dsl eff))
  -> Lens' state state'
  -> ((DispatchFn state dsl eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    }
  where

    update this state = R.transformState this (_ { state = view _lns state })

    getInitialState this = do
      ctx <- addReactDisallowedEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- addReactEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      ctx <- addReactReadOnlyEff $ ctxEff this
      msid <- (R.readState this) >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    renderFn this = do
      props' <- R.getProps this
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- unsafeCoerceEff $ R.readState this >>= pure <<< _.state
      pure $ R.createElement cls (_iso ctx.dispatch state props') []

    addReactEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadWrite, refs :: R.ReactRefs (() :: # Effect) | e ) a
    addReactEff = unsafeCoerceEff

    addReactDisallowedEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.Disallowed, refs :: R.ReactRefs R.Disallowed | e ) a
    addReactDisallowedEff = unsafeCoerceEff

    addReactReadOnlyEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadOnly, refs :: R.ReactRefs R.ReadOnly | e) a
    addReactReadOnlyEff = unsafeCoerceEff

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' eff
   . Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = readContext (Proxy :: Proxy (RedoxContext state dsl eff)) this

connect
  :: forall state state' dsl props props' eff'
   . Lens' state state'
  -> (DispatchFn state dsl eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' eff
   . Store state
  -> DispatchFn state dsl eff
  -> Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connectStore store dispatch _lns _iso cls = _connect (const $ pure {store, dispatch}) _lns _iso cls

dispatch
  :: forall dsl props state eff
   . ReactThis props state
  -> Free dsl (state -> state)
  -> Eff (ReadWriteSubscribeRedox (context :: CONTEXT | eff)) (Canceler (ReadWriteSubscribeRedox (context :: CONTEXT | eff)))
dispatch this dsl = do
  _dispatch <- readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (context :: CONTEXT | eff) }) ) this >>= pure <<< _.redox.dispatch
  _dispatch dsl


Add roles declarations to forbid unsafe coercions (#32)

module Ace.Config
  ( ConfigOption
  , set
  , packaged
  , workerPath
  , modePath
  , themePath
  , basePath
  , suffix
  ) where

import Ace.Types
import Effect (Effect)
import Data.Function.Uncurried (Fn2, runFn2)

newtype ConfigOption :: Type -> Type
newtype ConfigOption a = ConfigOption String

type role ConfigOption representational

foreign import setImpl :: forall a. Fn2 (ConfigOption a) a (Effect Ace)

set :: forall a. ConfigOption a -> a -> Effect Ace
set key value = runFn2 setImpl key value

packaged :: ConfigOption Boolean
packaged = ConfigOption "packaged"

workerPath :: ConfigOption String
workerPath = ConfigOption "workerPath"

modePath :: ConfigOption String
modePath = ConfigOption "modePath"

themePath :: ConfigOption String
themePath = ConfigOption "themePath"

basePath :: ConfigOption String
basePath = ConfigOption "basePath"

suffix :: ConfigOption String
suffix = ConfigOption "suffix"

module Ace.Config
  ( ConfigOption
  , set
  , packaged
  , workerPath
  , modePath
  , themePath
  , basePath
  , suffix
  ) where

import Ace.Types
import Effect (Effect)
import Data.Function.Uncurried (Fn2, runFn2)

newtype ConfigOption :: Type -> Type
newtype ConfigOption a = ConfigOption String

foreign import setImpl :: forall a. Fn2 (ConfigOption a) a (Effect Ace)

set :: forall a. ConfigOption a -> a -> Effect Ace
set key value = runFn2 setImpl key value

packaged :: ConfigOption Boolean
packaged = ConfigOption "packaged"

workerPath :: ConfigOption String
workerPath = ConfigOption "workerPath"

modePath :: ConfigOption String
modePath = ConfigOption "modePath"

themePath :: ConfigOption String
themePath = ConfigOption "themePath"

basePath :: ConfigOption String
basePath = ConfigOption "basePath"

suffix :: ConfigOption String
suffix = ConfigOption "suffix"


cleanup test sources

cleanup test sources

module Test.Main where

import Prelude (..)
import Data.Maybe (..)
import Control.Monad.Eff (..)
import Control.Monad.Eff.Exception (..)
import Control.Monad.Eff.Console (..)
import Control.Monad.Eff.Ractive (..)
import Control.Monad.Eff.Random (..)
import Test.QuickCheck (..)

foreign import data DOMNode :: *
foreign import data DOMEff  :: !

type DOMEnvEff a = forall e. Eff (domEff :: DOMEff | e) a

foreign import setupDOM :: Maybe String -> DOMEnvEff Unit

main :: forall eff. Eff (domEff :: DOMEff, ractiveM :: RactiveM, console :: CONSOLE, err :: EXCEPTION, random :: RANDOM | eff) Unit
main = do
       setupDOM Nothing
       let appSettings = Data {
                  template : "
Testing Template
",
                  el : "#app",
                  "data" : {
                          uiLibrary : "RactiveJS",
                  partials : {},
                          language  : "PureScript",
                          logoUrl   : "./content/img/ps-logo.png",
                          message   : "Click the PureScript Logo!",
                          consoleMessages: "no messages",
                          canRandomize : true,
                          numbers: []
                      }
                  }
       ract <- ractive appSettings
       set "message" "HELLO WORLD!" ract
       m <- (get "message" ract)

       quickCheck \n -> n + 1 == 1 + n -- not completed yet...

module Test.Main where

import Prelude (..)
import Data.Maybe (..)
import Control.Monad.Eff (..)
import Control.Monad.Eff.Exception (..)
import Control.Monad.Eff.Console (..)
import Control.Monad.Eff.Ractive (..)
import Control.Monad.Eff.Random (..)
import Test.QuickCheck (..)

foreign import data DOMNode :: *
foreign import data DOMEff  :: !

type DOMEnvEff a = forall e. Eff (domEff :: DOMEff | e) a

foreign import setupDOM :: Maybe String -> DOMEnvEff Unit

main :: forall eff. Eff (domEff :: DOMEff, ractiveM :: RactiveM, console :: CONSOLE, err :: EXCEPTION, random :: RANDOM | eff) Unit
main = do
       setupDOM Nothing
       let appSettings = Data {
                  template : "
Testing Template
",
                  el : "#app",
                  "data" : {
                          uiLibrary : "RactiveJS",
                  partials : {},
                          language  : "PureScript",
                          logoUrl   : "./content/img/ps-logo.png",
                          message   : "Click the PureScript Logo!",
                          consoleMessages: "no messages",
                          canRandomize : true,
                          numbers: []
                      }
                  }
       ract <- ractive appSettings
       set "message" "HELLO WORLD!" ract
       m <- (get "message" ract)

       quickCheck \n -> n + 1 == 1 + n
       -- quickCheck v
       --quickCheck \n -> n + 1 == 1 + n

       --log "all tests completed"


Use winner reason message

Use winner reason message

module App.Game where

import Prelude (const, show, (<>), ($), (<$>), (<*>), pure, bind, negate, (+))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, randomInt)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Tuple (snd, fst, Tuple(Tuple))
import Data.Tuple.Nested ((/\))
import Data.String (toLower)
import Pux (EffModel, noEffects)
import Pux.Html (Html, text, button, div, hr)
import Pux.Html.Attributes (className)
import Pux.Html.Events (onClick)

data GameChoice
  = Rock
  | Paper
  | Scissors
  | Lizard
  | Spock

data GameResult
  = PlayerWins String
  | ComputerWins String
  | Tie

data Action
  = PlayerMove GameChoice
  | ComputerMove GameChoice
  | UpdateScore
  | Reset

type State =
  { playerChoice :: (Maybe GameChoice)
  , computerChoice :: (Maybe GameChoice)
  , gameResult :: Tuple Int String
  , score :: Int
  }

init :: State
init =
  { playerChoice: Nothing
  , computerChoice: Nothing
  , gameResult: Tuple 0 "choose..!"
  , score: 0
  }

update :: forall e. Action -> State -> EffModel State Action (random :: RANDOM | e)
update Reset state = noEffects init
update UpdateScore state = noEffects $ updateScore state
update (PlayerMove choice) state =
  { state: state { playerChoice = Just choice }
  , effects: [ do
      computerChoice <- liftEff getRandomChoice
      pure $ ComputerMove computerChoice
    ]
  }
update (ComputerMove choice) state =
  { state: state { computerChoice = Just choice }
  , effects: [ pure $ UpdateScore ]
  }

updateScore :: State -> State
updateScore state =
  let newState = setGameResult state
  in newState { score = newState.score + fst newState.gameResult }

setGameResult :: State -> State
setGameResult state =
  case determineWinner <$> state.playerChoice <*> state.computerChoice of
    Just (PlayerWins reason) -> state { gameResult = 1 /\ ("Player wins!  " <> reason <> "!") }
    Just (ComputerWins reason) -> state { gameResult = -1 /\ ("Computer wins!  " <> reason <> "!") }
    Just Tie -> state { gameResult = 0 /\ "It's a tie!" }
    _ -> state
  where
    determineWinner player computer =
      let
        didPlayerWin = didLeftWin player computer
        didComputerWin = didLeftWin computer player
      in
        if fst didPlayerWin
          then PlayerWins (snd didPlayerWin)
          else if fst (didLeftWin computer player)
            then ComputerWins (snd didComputerWin)
            else Tie

    didLeftWin left right =
      case left, right of
        Rock, Scissors -> true /\ "Rock crushes Scissors"
        Rock, Lizard -> true /\ "Rock smashes Lizard"
        Paper, Rock -> true /\ "Paper covers Rock"
        Paper, Spock -> true /\ "Paper disproves Spock"
        Scissors, Paper -> true /\ "Scissors cuts Paper"
        Scissors, Lizard -> true /\ "Scissors decapitates Lizard"
        Lizard, Paper -> true /\ "Lizard eats Paper"
        Lizard, Spock -> true /\ "Lizard poisons Spock"
        Spock, Rock -> true /\ "Spock vaporizes Rock"
        Spock, Scissors -> true /\ "Spock disassembles Scissors"
        _, _ -> false /\ "loss"

getRandomChoice :: forall e. Eff (random :: RANDOM | e) GameChoice
getRandomChoice = do
  i <- randomInt 1 5
  pure case i of
    1 -> Rock
    2 -> Paper
    3 -> Scissors
    4 -> Lizard
    _ -> Spock

printMaybeChoice :: Maybe GameChoice -> String
printMaybeChoice Nothing = "-- choosing --"
printMaybeChoice (Just choice) = printChoice choice
  where
    printChoice Rock = "Rock"
    printChoice Paper = "Paper"
    printChoice Scissors = "Scissors"
    printChoice Lizard = "Lizard"
    printChoice Spock = "Spock"

view :: State -> Html Action
view state =
  div
    []
    [ choiceButton Rock "rock" "Rock"
    , choiceButton Paper "paper" "Paper"
    , choiceButton Scissors "scissors" "Scissors"
    , choiceButton Lizard "lizard" "Lizard"
    , choiceButton Spock "spock" "Spock"
    , divider
    , showChoice state.playerChoice
    , showChoice state.computerChoice
    , showGameResult state.gameResult
    , showPlayerScore state.score
    , divider
    , resetButton
    ]
  where
    choiceButton gameChoice choiceClass choiceText =
      button
        [ onClick (const $ PlayerMove gameChoice), className ("choice " <> choiceClass) ]
        [ text choiceText ]

    resetButton = button [ onClick (const Reset), className "reset" ] [ text "Reset!" ]

    showChoice gameChoice = div [ className ("card " <> toLower (printMaybeChoice gameChoice)) ] []

    showGameResult gameResult = div [] [ text $ "Game result: " <> snd gameResult ]

    showPlayerScore playerScore = div [] [ text $ "Score: " <> show playerScore ]

    divider = hr [] []

module App.Game where

import Prelude (const, show, (<>), ($), (<$>), (<*>), pure, bind, negate, (+))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, randomInt)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Tuple (snd, fst, Tuple(Tuple))
import Data.Tuple.Nested ((/\))
import Data.String (toLower)
import Pux (EffModel, noEffects)
import Pux.Html (Html, text, button, div, hr)
import Pux.Html.Attributes (className)
import Pux.Html.Events (onClick)

data GameChoice
  = Rock
  | Paper
  | Scissors
  | Lizard
  | Spock

data GameResult
  = PlayerWins
  | ComputerWins
  | Tie

data Action
  = PlayerMove GameChoice
  | ComputerMove GameChoice
  | UpdateScore
  | Reset

type State =
  { playerChoice :: (Maybe GameChoice)
  , computerChoice :: (Maybe GameChoice)
  , gameResult :: Tuple Int String
  , score :: Int
  }

init :: State
init =
  { playerChoice: Nothing
  , computerChoice: Nothing
  , gameResult: Tuple 0 "choose..!"
  , score: 0
  }

update :: forall e. Action -> State -> EffModel State Action (random :: RANDOM | e)
update Reset state = noEffects init
update UpdateScore state = noEffects $ updateScore state
update (PlayerMove choice) state =
  { state: state { playerChoice = Just choice }
  , effects: [ do
      computerChoice <- liftEff getRandomChoice
      pure $ ComputerMove computerChoice
    ]
  }
update (ComputerMove choice) state =
  { state: state { computerChoice = Just choice }
  , effects: [ pure $ UpdateScore ]
  }

updateScore :: State -> State
updateScore state =
  let newState = setGameResult state
  in newState { score = newState.score + fst newState.gameResult }

setGameResult :: State -> State
setGameResult state =
  case determineWinner <$> state.playerChoice <*> state.computerChoice of
    Just PlayerWins -> state { gameResult = 1 /\ "Player wins!" }
    Just ComputerWins -> state { gameResult = -1 /\ "Computer wins!" }
    Just Tie -> state { gameResult = 0 /\ "Tie!" }
    _ -> state
  where
    determineWinner player computer =
      if fst (didLeftWin player computer)
        then PlayerWins
        else if fst (didLeftWin computer player)
          then ComputerWins
          else Tie
    didLeftWin left right =
      case left, right of
        Rock, Scissors -> true /\ "Rock crushes Scissors"
        Rock, Lizard -> true /\ "Rock smashes Lizard"
        Paper, Rock -> true /\ "Paper covers Rock"
        Paper, Spock -> true /\ "Paper disproves Spock"
        Scissors, Paper -> true /\ "Scissors cuts Paper"
        Scissors, Lizard -> true /\ "Scissors decapitates Lizard"
        Lizard, Paper -> true /\ "Lizard eats Paper"
        Lizard, Spock -> true /\ "Lizard poisons Spock"
        Spock, Rock -> true /\ "Spock vaporizes Rock"
        Spock, Scissors -> true /\ "Spock disassembles Scissors"
        _, _ -> false /\ "loss"

getRandomChoice :: forall e. Eff (random :: RANDOM | e) GameChoice
getRandomChoice = do
  i <- randomInt 1 5
  pure case i of
    1 -> Rock
    2 -> Paper
    3 -> Scissors
    4 -> Lizard
    _ -> Spock

printMaybeChoice :: Maybe GameChoice -> String
printMaybeChoice Nothing = "-- choosing --"
printMaybeChoice (Just choice) = printChoice choice
  where
    printChoice Rock = "Rock"
    printChoice Paper = "Paper"
    printChoice Scissors = "Scissors"
    printChoice Lizard = "Lizard"
    printChoice Spock = "Spock"

view :: State -> Html Action
view state =
  div
    []
    [ choiceButton Rock "rock" "Rock"
    , choiceButton Paper "paper" "Paper"
    , choiceButton Scissors "scissors" "Scissors"
    , choiceButton Lizard "lizard" "Lizard"
    , choiceButton Spock "spock" "Spock"
    , divider
    , showChoice state.playerChoice
    , showChoice state.computerChoice
    , div [] [ text $ "Game result: " <> snd state.gameResult ]
    , div [] [ text $ "Score: " <> show state.score ]
    , divider
    , resetButton
    ]
  where
    choiceButton gameChoice choiceClass choiceText =
      button
        [ onClick (const $ PlayerMove gameChoice), className ("choice " <> choiceClass) ]
        [ text choiceText ]

    resetButton = button [ onClick (const Reset), className "reset" ] [ text "Reset!" ]

    showChoice gameChoice = div [ className ("card " <> toLower (printMaybeChoice gameChoice)) ] []

    divider = hr [] []


Explicit exports

Explicit exports

Original commit b4827151c348a06cc65c65bcff4334c99d2221bf

module Main
    ( renderFromJson
    , renderFromJsonSchema
    , renderFromJsonString
    , renderers
    ) where

import IR
import IRGraph
import Prelude
import Transformations

import Environment (Environment(..))
import Environment as Env

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

type Pipeline a = Doc.Renderer -> a -> Either Error String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Pipeline Json
renderFromJson renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

renderFromJsonSchema :: Pipeline Json
renderFromJsonSchema renderer json = do
    schema <- J.decodeJson json
    graph <- makeTypeFromSchema "TopLevel" schema
    graph
        # regatherClassNames
        # Doc.runRenderer renderer
        # pure

pipelines :: Environment -> Array (Pipeline Json)
pipelines Development = [renderFromJsonSchema, renderFromJson]
pipelines Production = [renderFromJson]

firstSuccess :: forall a. Array (Pipeline a) -> Pipeline a
firstSuccess pipes renderer json = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline renderer json

relax :: Pipeline Json -> Pipeline String
relax pipeline renderer jsonString = do
    obj <- J.jsonParser jsonString
    pipeline renderer obj

renderFromJsonString :: Pipeline String
renderFromJsonString = relax $ firstSuccess (pipelines Env.current)

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import Environment (Environment(..))
import Environment as Env

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

type Pipeline a = Doc.Renderer -> a -> Either Error String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Pipeline Json
renderFromJson renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer
    # Right

renderFromJsonSchema :: Pipeline Json
renderFromJsonSchema renderer json = do
    schema <- J.decodeJson json
    graph <- makeTypeFromSchema "TopLevel" schema
    graph
        # regatherClassNames
        # Doc.runRenderer renderer
        # pure

pipelines :: Environment -> Array (Pipeline Json)
pipelines Development = [renderFromJsonSchema, renderFromJson]
pipelines Production = [renderFromJson]

firstSuccess :: forall a. Array (Pipeline a) -> Pipeline a
firstSuccess pipes renderer json = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline renderer json

relax :: Pipeline Json -> Pipeline String
relax pipeline renderer jsonString = do
    obj <- J.jsonParser jsonString
    pipeline renderer obj

renderFromJsonString :: Pipeline String
renderFromJsonString = relax $ firstSuccess (pipelines Env.current)


axes analysis is rewritten

axes analysis is rewritten

{-
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.BuildChart.Axis where

import SlamData.Prelude

import Data.Argonaut (JCursor(..), JObject, JArray, Json, insideOut, (:=), (.?), (~>), jsonEmptyObject)
import Data.Array as A
import Data.Foldable as F
import Data.List (List(..))
import Data.List as L
import Data.Map as M

import SlamData.Workspace.Card.BuildChart.Semantics as Sem

import Test.StrongCheck.Arbitrary (arbitrary)
import Test.StrongCheck.Gen as Gen
import Test.Property.ArbJson (runArbJCursor)

data AxisType
  = Measure
  | Category
  | Time
  | Date
  | DateTime

compatible ∷ AxisType → Sem.Semantics → Boolean
compatible Measure = case _ of
  Sem.Value _ → true
  Sem.Bool _ → true
  Sem.Percent _ → true
  Sem.Money _ _ → true
  _ → false
compatible Category = case _ of
  Sem.Category _ → true
  _ → false
compatible Time = case _ of
  Sem.Time _ → true
  _ → false
compatible Date = case _ of
  Sem.Date _ → true
  _ → false
compatible DateTime = case _ of
  Sem.DateTime _ → true
  _ → false

printWithAxisType ∷ AxisType → Sem.Semantics → Maybe String
printWithAxisType atype sem
  | compatible atype sem = pure $ Sem.printSemantics sem
  | otherwise = Nothing

-- | Note that this function is used on stuff that has been already
-- | aggregated and analyzed, i.e. you take JArray, analyze it, extract axes
-- | and then you need to sort those axes
compareWithAxisType ∷ AxisType → String → String → Ordering
compareWithAxisType atype a b =
  let
    mbASem = Sem.analyzeString a
    mbBSem = Sem.analyzeString b

  in case atype of
    Measure →
      compare (mbASem >>= Sem.semanticsToNumber) (mbBSem >>= Sem.semanticsToNumber)
    Category →
      compare a b
    Time →
      compare (mbASem >>= Sem.semanticsToTime) (mbBSem >>= Sem.semanticsToTime)
    Date →
      compare (mbASem >>= Sem.semanticsToDate) (mbBSem >>= Sem.semanticsToDate)
    DateTime →
      compare (mbASem >>= Sem.semanticsToDateTime) (mbBSem >>= Sem.semanticsToDateTime)

type AxesTypeAnnotated a =
  { value ∷ a
  , time ∷ a
  , category ∷ a
  , date ∷ a
  , datetime ∷ a
  }

type Axes = AxesTypeAnnotated (Array JCursor)

axesType ∷ JCursor → Axes → AxesType
axesType c axes
  | F.elem c axes.value = Measurre
  | F.elem c axes.time = Time
  | F.elem c axes.date = Date
  | F.elem c axes.datetime = DateTime
  | otherwise = Category

genAxes ∷ Gen.Gen Axes
genAxes = do
  value ← map (map runArbJCursor) arbitrary
  time ← map (map runArbJCursor) arbitrary
  category ← map (map runArbJCursor) arbitrary
  date ← map (map runArbJCursor) arbitrary
  datetime ← map (map runArbJCursor) arbitrary
  pure {value, time, category, date, datetime}

encodeAxes ∷ Axes → Json
encodeAxes axes =
  "value" := axes.value
  ~> "time" := axes.time
  ~> "category" := axes.category
  ~> "date" := axes.date
  ~> "datetime" := axes.datetime
  ~> jsonEmptyObject

decodeAxes ∷ JObject → String ⊹ Axes
decodeAxes js = do
  value ← js .? "value"
  category ← js .? "category"
  time ← js .? "time"
  date ← ((js .? "date") <|> pure [])
  datetime ← ((js .? "datetime") <|> pure [])
  pure {value, category, time, date, datetime}

initialAxes ∷ Axes
initialAxes =
  { value: []
  , time: []
  , category: []
  , date: []
  , datetime: []
  }

eqAxes ∷ Axes → Axes → Boolean
eqAxes r1 r2 =
  F.and
    [ r1.category ≡ r2.category
    , r1.time ≡ r2.time
    , r1.value ≡ r2.value
    , r1.date ≡ r2.date
    , r1.datetime ≡ r2.datetime
    ]

buildAxes ∷ JArray → Axes
buildAxes rs =
  rs
    # Sem.jarrayToSemantics
    # checkPairs
    # map checkSemantics
    # M.toList
    # foldl foldFn initialAxes
  where
  foldFn ∷ Axes → JCursor × Maybe AxisType → Axes
  foldFn acc (_ × Nothing) = acc
  foldFn acc (cursor × (Just axesType)) = case axesType of
    Measure → acc { value = A.cons cursor acc.value }
    Category → acc { category = A.cons cursor acc.category }
    Time → acc { time = A.cons cursor acc.time }
    Date → acc { date = A.cons cursor acc.date }
    DateTime → acc { datetime = A.cons cursor acc.datetime }

checkSemantics ∷ List (Maybe Sem.Semantics) → Maybe AxisType
checkSemantics lst =
  result
  where
  result
    | semiLen < counts.value = Just Measure
    | semiLen < counts.category = Just Category
    | semiLen < counts.time = Just Time
    | semiLen < counts.datetime = Just DateTime
    | semiLen < counts.date = Just Date
    | otherwise = Nothing

  semiLen ∷ Int
  semiLen = L.length lst / 2

  counts ∷ AxesTypeAnnotated Int
  counts = foldl foldFn init lst

  init ∷ AxesTypeAnnotated Int
  init =
    { category: 0
    , time: 0
    , value: 0
    , date: 0
    , datetime: 0
    }

  foldFn ∷ AxesTypeAnnotated Int → Maybe Sem.Semantics → AxesTypeAnnotated Int
  foldFn acc Nothing = acc
  foldFn acc (Just a)
    | Sem.isUsedAsNothing a =
        acc
    | compatible Measure a =
        acc { value = acc.value + 1 }
    | compatible Category a =
        acc { category = acc.category + 1 }
    | compatible Time a =
        acc { time = acc.time + 1 }
    | compatible Date a =
        acc { date = acc.date +  1 }
    | compatible DateTime a =
        acc { datetime = acc.datetime + 1 }
    | otherwise =
        acc

checkPairs ∷ ∀ a. M.Map JCursor a → M.Map JCursor a
checkPairs m = case ks of
  Nil → m
  Cons _ Nil → m
  _ → foldl check m ks
  where
  ks ∷ List JCursor
  ks = M.keys m

  check ∷ M.Map JCursor a → JCursor → M.Map JCursor a
  check m cursor
    | F.any (dependsOn cursor) ks = m
    | otherwise = M.delete cursor m

dependsOn ∷ JCursor → JCursor → Boolean
dependsOn a b = a ≠ b ∧
  dependsOn' (insideOut a) (insideOut b)
  where
  dependsOn' JCursorTop JCursorTop = true
  dependsOn' JCursorTop _ = true
  dependsOn' _ JCursorTop = true
  dependsOn' (JField _ c) (JField _ c') = dependsOn' c c'
  dependsOn' (JIndex _ c) (JIndex _ c') = dependsOn' c c'
  dependsOn' _ _ = false

{-
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.BuildChart.Axis where

import SlamData.Prelude

import Data.Argonaut (JCursor(..), JObject, JArray, Json, insideOut, (:=), (.?), (~>), jsonEmptyObject)
import Data.Array as A
import Data.Foldable as F
import Data.List (List(..))
import Data.List as L
import Data.Map as M

import SlamData.Workspace.Card.BuildChart.Semantics as Sem

import Test.StrongCheck.Arbitrary (arbitrary)
import Test.StrongCheck.Gen as Gen
import Test.Property.ArbJson (runArbJCursor)

data AxisType
  = Measure
  | Category
  | Time
  | Date
  | DateTime

compatible ∷ AxisType → Sem.Semantics → Boolean
compatible Measure = case _ of
  Sem.Value _ → true
  Sem.Bool _ → true
  Sem.Percent _ → true
  Sem.Money _ _ → true
  _ → false
compatible Category = case _ of
  Sem.Category _ → true
  _ → false
compatible Time = case _ of
  Sem.Time _ → true
  _ → false
compatible Date = case _ of
  Sem.Date _ → true
  _ → false
compatible DateTime = case _ of
  Sem.DateTime _ → true
  _ → false

printWithAxisType ∷ AxisType → Sem.Semantics → Maybe String
printWithAxisType atype sem
  | compatible atype sem = pure $ Sem.printSemantics sem
  | otherwise = Nothing

-- | Note that this function is used on stuff that has been already
-- | aggregated and analyzed, i.e. you take JArray, analyze it, extract axes
-- | and then you need to sort those axes
compareWithAxisType ∷ AxisType → String → String → Ordering
compareWithAxisType atype a b =
  let
    mbASem = Sem.analyzeString a
    mbBSem = Sem.analyzeString b

  in case atype of
    Measure →
      compare (mbASem >>= Sem.semanticsToNumber) (mbBSem >>= Sem.semanticsToNumber)
    Category →
      compare a b
    Time →
      compare (mbASem >>= Sem.semanticsToTime) (mbBSem >>= Sem.semanticsToTime)
    Date →
      compare (mbASem >>= Sem.semanticsToDate) (mbBSem >>= Sem.semanticsToDate)
    DateTime →
      compare (mbASem >>= Sem.semanticsToDateTime) (mbBSem >>= Sem.semanticsToDateTime)

type AxesTypeAnnotated a =
  { value ∷ a
  , time ∷ a
  , category ∷ a
  , date ∷ a
  , datetime ∷ a
  }

type Axes = AxesTypeAnnotated (Array JCursor)

genAxes ∷ Gen.Gen Axes
genAxes = do
  value ← map (map runArbJCursor) arbitrary
  time ← map (map runArbJCursor) arbitrary
  category ← map (map runArbJCursor) arbitrary
  date ← map (map runArbJCursor) arbitrary
  datetime ← map (map runArbJCursor) arbitrary
  pure {value, time, category, date, datetime}

encodeAxes ∷ Axes → Json
encodeAxes axes =
  "value" := axes.value
  ~> "time" := axes.time
  ~> "category" := axes.category
  ~> "date" := axes.date
  ~> "datetime" := axes.datetime
  ~> jsonEmptyObject

decodeAxes ∷ JObject → String ⊹ Axes
decodeAxes js = do
  value ← js .? "value"
  category ← js .? "category"
  time ← js .? "time"
  date ← ((js .? "date") <|> pure [])
  datetime ← ((js .? "datetime") <|> pure [])
  pure {value, category, time, date, datetime}

initialAxes ∷ Axes
initialAxes =
  { value: []
  , time: []
  , category: []
  , date: []
  , datetime: []
  }

eqAxes ∷ Axes → Axes → Boolean
eqAxes r1 r2 =
  F.and
    [ r1.category ≡ r2.category
    , r1.time ≡ r2.time
    , r1.value ≡ r2.value
    , r1.date ≡ r2.date
    , r1.datetime ≡ r2.datetime
    ]

buildAxes ∷ JArray → Axes
buildAxes rs =
  rs
    # Sem.jarrayToSemantics
    # checkPairs
    # map checkSemantics
    # M.toList
    # foldl foldFn initialAxes
  where
  foldFn ∷ Axes → JCursor × Maybe AxisType → Axes
  foldFn acc (_ × Nothing) = acc
  foldFn acc (cursor × (Just axesType)) = case axesType of
    Measure → acc { value = A.cons cursor acc.value }
    Category → acc { category = A.cons cursor acc.category }
    Time → acc { time = A.cons cursor acc.time }
    Date → acc { date = A.cons cursor acc.date }
    DateTime → acc { datetime = A.cons cursor acc.datetime }

checkSemantics ∷ List (Maybe Sem.Semantics) → Maybe AxisType
checkSemantics lst =
  result
  where
  result
    | semiLen < counts.value = Just Measure
    | semiLen < counts.category = Just Category
    | semiLen < counts.time = Just Time
    | semiLen < counts.datetime = Just DateTime
    | semiLen < counts.date = Just Date
    | otherwise = Nothing

  semiLen ∷ Int
  semiLen = L.length lst / 2

  counts ∷ AxesTypeAnnotated Int
  counts = foldl foldFn init lst

  init ∷ AxesTypeAnnotated Int
  init =
    { category: 0
    , time: 0
    , value: 0
    , date: 0
    , datetime: 0
    }

  foldFn ∷ AxesTypeAnnotated Int → Maybe Sem.Semantics → AxesTypeAnnotated Int
  foldFn acc Nothing = acc
  foldFn acc (Just a)
    | Sem.isUsedAsNothing a =
        acc
    | compatible Measure a =
        acc { value = acc.value + 1 }
    | compatible Category a =
        acc { category = acc.category + 1 }
    | compatible Time a =
        acc { time = acc.time + 1 }
    | compatible Date a =
        acc { date = acc.date +  1 }
    | compatible DateTime a =
        acc { datetime = acc.datetime + 1 }
    | otherwise =
        acc

checkPairs ∷ ∀ a. M.Map JCursor a → M.Map JCursor a
checkPairs m = case ks of
  Nil → m
  Cons _ Nil → m
  _ → foldl check m ks
  where
  ks ∷ List JCursor
  ks = M.keys m

  check ∷ M.Map JCursor a → JCursor → M.Map JCursor a
  check m cursor
    | F.any (dependsOn cursor) ks = m
    | otherwise = M.delete cursor m

dependsOn ∷ JCursor → JCursor → Boolean
dependsOn a b = a ≠ b ∧
  dependsOn' (insideOut a) (insideOut b)
  where
  dependsOn' JCursorTop JCursorTop = true
  dependsOn' JCursorTop _ = true
  dependsOn' _ JCursorTop = true
  dependsOn' (JField _ c) (JField _ c') = dependsOn' c c'
  dependsOn' (JIndex _ c) (JIndex _ c') = dependsOn' c c'
  dependsOn' _ _ = false


Update preview table error messages

Update preview table error messages

No point telling the user to go back to fix, as they won’t be able to -
in theory none of these errors should ever occur anyway.

{-
Copyright 2017 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.Error.Component
  ( errorCardComponent
  , module SlamData.Workspace.Card.Error.Component.Query
  , module SlamData.Workspace.Card.Error.Component.State
  ) where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Path.Pathy as Path
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Quasar.Advanced.QuasarAF as QA
import SlamData.GlobalError as GE
import SlamData.Monad (Slam)
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.AccessType (AccessType(..))
import SlamData.Workspace.Card.CardType.FormInputType as FIT
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Error (CardError(..), cardToGlobalError)
import SlamData.Workspace.Card.Error.Component.Query (Query(..))
import SlamData.Workspace.Card.Error.Component.State (State, initialState)
import Utils (prettyJson)

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

errorCardComponent ∷ H.Component HH.HTML Query CardError Void Slam
errorCardComponent =
  H.lifecycleComponent
    { initialState: initialState
    , render
    , eval
    -- TODO: check whether the card needs to be able to respond to input changes
    -- it may be unnecessary, as I think the error card disappears between runs -gb
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render st =
  HH.div
    [ HP.class_ (H.ClassName "sd-error-container") ]
    [ prettyPrintCardError st st.error ]

errorTitle ∷ Array HTML → HTML
errorTitle title =
  HH.h1_
    [ I.warningSm
    , HH.span_ title
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    { accessType } ← Wiring.expose
    H.modify (_ { accessType = accessType })
    pure next
  ToggleExpanded b next → do
    H.modify (_ { expanded = b })
    pure next

printQErrorWithDetails ∷ QA.QError → HTML
printQErrorWithDetails = case _ of
  err → HH.text (QA.printQError err)

printQErrorDetails ∷ QA.QError → HTML
printQErrorDetails = case _ of
  QA.ErrorMessage { raw } → printQErrorRaw raw
  err → HH.text (QA.printQError err)

printQErrorRaw ∷ J.JObject → HTML
printQErrorRaw raw = HH.pre_ [ HH.text (prettyJson (J.fromObject raw)) ]

prettyPrintCardError ∷ State → CardError → HTML
prettyPrintCardError state ce = case cardToGlobalError ce of
  Just ge →
    HH.div_
      [ errorTitle [ HH.text (GE.print ge) ] ]
  Nothing → case ce of
    QuasarError qError →
      HH.div_
        [ errorTitle [ HH.text "An error occurred." ]
        , printQErrorWithDetails qError
        ]
    StringlyTypedError err →
      HH.div_
        [ errorTitle [ HH.text err ] ]
    CacheCardError cce → cacheErrorMessage state cce
    QueryCardError qce → queryErrorMessage state qce
    MarkdownCardError mde → markdownErrorMessage state mde
    DownloadOptionsCardError dloe → downloadOptionsErrorMessage state dloe
    OpenCardError oce → openErrorMessage state oce
    TableCardError tce → tableErrorMessage state tce
    FormInputStaticCardError fise → formInputStaticErrorMessage state fise
    FormInputLabeledCardError file → formInputLabeledErrorMessage state file

collapsible ∷ String → HTML → Boolean → HTML
collapsible title content expanded =
  HH.div
    [ HP.classes [ H.ClassName "sd-collapsible-error" ] ]
    $ join
      [ pure $
          HH.button
            [ HE.onClick $ HE.input_ (ToggleExpanded (not expanded)) ]
            [ if expanded then I.chevronDownSm else I.chevronRightSm
            , HH.span_ [ HH.text title ]
            ]
      , guard expanded $>
          HH.div
            [ HP.class_ (H.ClassName "sd-collapsible-error-content") ]
            [ content ]
      ]

queryErrorMessage ∷ State → CE.QueryError → HTML
queryErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the query card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.QueryCompileError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occurred during query compilation." ]
          , renderMore qErr
          ]
    CE.QueryRetrieveResultError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occurred when retrieving the query result." ]
          , renderMore qErr
          ]
  renderMore = case _ of
    QA.ErrorMessage {title, message, raw} →
      pure $ HH.div_
        $ join
          [ foldMap (\t -> pure $ HH.p_ [ HH.text t ]) title
          , pure $ HH.p_ [ HH.text message ]
          , guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorRaw raw) expanded
          ]
    err' →
      guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorDetails err') expanded

cacheErrorMessage ∷ State → CE.CacheError → HTML
cacheErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the cache card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.CacheInvalidFilepath fp →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "There is a problem in the configuration of the cache card." ]
          , pure $ HH.p_
              [ HH.text "The provided path "
              , HH.code_ [ HH.text fp ]
              , HH.text " is not a valid location to store the cache result."
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.CacheQuasarError qe →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_ [ HH.text "The Quasar analytics engine returned an error while verifying the cache result." ]
          , guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorDetails qe) expanded
          ]
    CE.CacheErrorSavingFile fp →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_
              [ HH.text "The file "
              , HH.code_ [ HH.text (Path.printPath fp) ]
              , HH.text " could not be written to."
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and provide an alternative path to fix this error." ]
          ]
    CE.CacheResourceNotModified →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_ [ HH.text "Caching can only be applied to queries that perform at least one transformation on an existing data set." ]
          -- TODO: only show this solution when there are no following cards?
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and delete it to fix this error." ]
          ]

markdownErrorMessage ∷ State → CE.MarkdownError → HTML
markdownErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Markdown card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  -- TODO: explain which field for all these cases? -gb
  renderDetails = case _ of
    CE.MarkdownParseError {markdown, error} →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Parsing the provided Markdown failed." ]
          , pure $ HH.p_
              [ HH.text "We encountered the following parse error: "
              , HH.code_ [ HH.text error ]
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownSqlParseError {sql, error} →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Parsing SQL embedded inside Markdown failed." ]
          , pure $ renderParseError error sql
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownNoTextBoxResults →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A text box field did not return any results." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidTimeValue { time, error } →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An invalid time value was provided." ]
          , pure $ renderParseError error time
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidDateValue { date, error } →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An invalid date value was provided." ]
          , pure $ renderParseError error date
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidDateTimeValue { datetime, error } →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An invalid timestamp value was provided." ]
          , pure $ renderParseError error datetime
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownTypeError t1 t2 →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A type mismatch occurred when populating a field in the Markdown card." ]
          , pure $ HH.p_
              [ HH.text "We encountered the following type:"
              , HH.br_
              , HH.code_ [ HH.text t1 ]
              , HH.text " where we expected:"
              , HH.br_
              , HH.code_ [ HH.text t2 ]
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    where
      renderParseError error value =
        HH.p_
          [ HH.text "We encountered the following error:"
          , HH.br_
          , HH.code_ [ HH.text error ]
          , HH.text " when trying to parse:"
          , HH.br_
          , HH.code_ [ HH.text value ]
          ]

downloadOptionsErrorMessage ∷ State → CE.DownloadOptionsError → HTML
downloadOptionsErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Download Options card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.DownloadOptionsFilenameRequired →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "No filename was provided in the Download Options card." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.DownloadOptionsFilenameInvalid fn →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "The filename provided in the Download Options card is invalid." ]
          , pure $ HH.p_
              [ HH.code_ [ HH.text fn ], HH.text " is not a valid filepath." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

openErrorMessage ∷ State → CE.OpenError → HTML
openErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Open card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.OpenFileNotFound fp →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A file that was selected in the Open card could not be found." ]
          , pure $ HH.p_
              [ HH.code_ [ HH.text fp ], HH.text " does not exist." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and make a new selection to fix this error." ]
          ]
    CE.OpenNoResourceSelected →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "No resource was selected in the Open card." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select either a file or a variable to fix this error." ]
          ]
    CE.OpenNoFileSelected →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "The resource selected in the Open card is of an invalid type" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select a file or variable to fix this error." ]
          ]

tableErrorMessage ∷ State → CE.TableError → HTML
tableErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Preview Table card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.TableMissingResourceInputError →
      HH.div_
        [ errorTitle [ HH.text "The preview table card requires data as an input." ] ]
    CE.TableCountQuasarError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A error occured when counting the preview data." ]
          , pure $ printQErrorWithDetails qErr
          ]
    CE.TableSampleQuasarError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A error occured during sampling of the preview data." ]
          , pure $ printQErrorWithDetails qErr
          ]

formInputStaticErrorMessage ∷ State → CE.FormInputStaticError → HTML
formInputStaticErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Forminput static card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.FIStaticNoAxis →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput static card." ]
          , pure $ HH.p_
              [ HH.text "No axis was selected" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FIStaticMissingAxis axis →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput static card." ]
          , pure $ HH.p_
              [ HH.text "The selected axis was not present in the data." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

formInputLabeledErrorMessage ∷ State → CE.FormInputLabeledError → HTML
formInputLabeledErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Forminput labeled card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.FILabeledNoAxisError →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "No axis was selected" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FILabeledEmptyResourceError →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "The selected resource was empty." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FILabeledTooManyEntries { formInputType, maximum, entryCount } →
      let
        errorText =
          "The " <> FIT.printFormInputType formInputType
          <> " form input can't take more than "
          <> show (FIT.maximumCountOfEntries formInputType)
          <> "entries, but there were: "
          <> show entryCount
          <> ". Please use 'limit' or 'group by'"
      in
        HH.div_
          $ join
            [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
            , pure $ HH.p_
                [ HH.text errorText ]
            , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
            ]
    CE.FILabeledTooManySelected { formInputType, maximum, selectedCount } →
      let
        errorText =
          "The " <> FIT.printFormInputType formInputType
          <> " form input can't have more than "
          <> show (FIT.maximumCountOfSelectedValues formInputType)
          <> " selected values, but there were: "
          <> show selectedCount
          <> ". Please, use another axis"
      in
        HH.div_
          $ join
            [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
            , pure $ HH.p_
                [ HH.text errorText ]
            , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
            ]
    -- TODO: Use the label argument for a better error message
    CE.FILabeledNonUniqueLabelError label →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "Labels must be unique. Please, use other axis." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]

{-
Copyright 2017 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.Error.Component
  ( errorCardComponent
  , module SlamData.Workspace.Card.Error.Component.Query
  , module SlamData.Workspace.Card.Error.Component.State
  ) where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Path.Pathy as Path
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Quasar.Advanced.QuasarAF as QA
import SlamData.GlobalError as GE
import SlamData.Monad (Slam)
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.AccessType (AccessType(..))
import SlamData.Workspace.Card.CardType.FormInputType as FIT
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Error (CardError(..), cardToGlobalError)
import SlamData.Workspace.Card.Error.Component.Query (Query(..))
import SlamData.Workspace.Card.Error.Component.State (State, initialState)
import Utils (prettyJson)

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

errorCardComponent ∷ H.Component HH.HTML Query CardError Void Slam
errorCardComponent =
  H.lifecycleComponent
    { initialState: initialState
    , render
    , eval
    -- TODO: check whether the card needs to be able to respond to input changes
    -- it may be unnecessary, as I think the error card disappears between runs -gb
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render st =
  HH.div
    [ HP.class_ (H.ClassName "sd-error-container") ]
    [ prettyPrintCardError st st.error ]

errorTitle ∷ Array HTML → HTML
errorTitle title =
  HH.h1_
    [ I.warningSm
    , HH.span_ title
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    { accessType } ← Wiring.expose
    H.modify (_ { accessType = accessType })
    pure next
  ToggleExpanded b next → do
    H.modify (_ { expanded = b })
    pure next

printQErrorWithDetails ∷ QA.QError → HTML
printQErrorWithDetails = case _ of
  err → HH.text (QA.printQError err)

printQErrorDetails ∷ QA.QError → HTML
printQErrorDetails = case _ of
  QA.ErrorMessage { raw } → printQErrorRaw raw
  err → HH.text (QA.printQError err)

printQErrorRaw ∷ J.JObject → HTML
printQErrorRaw raw = HH.pre_ [ HH.text (prettyJson (J.fromObject raw)) ]

prettyPrintCardError ∷ State → CardError → HTML
prettyPrintCardError state ce = case cardToGlobalError ce of
  Just ge →
    HH.div_
      [ errorTitle [ HH.text (GE.print ge) ] ]
  Nothing → case ce of
    QuasarError qError →
      HH.div_
        [ errorTitle [ HH.text "An error occurred." ]
        , printQErrorWithDetails qError
        ]
    StringlyTypedError err →
      HH.div_
        [ errorTitle [ HH.text err ] ]
    CacheCardError cce → cacheErrorMessage state cce
    QueryCardError qce → queryErrorMessage state qce
    MarkdownCardError mde → markdownErrorMessage state mde
    DownloadOptionsCardError dloe → downloadOptionsErrorMessage state dloe
    OpenCardError oce → openErrorMessage state oce
    TableCardError tce → tableErrorMessage state tce
    FormInputStaticCardError fise → formInputStaticErrorMessage state fise
    FormInputLabeledCardError file → formInputLabeledErrorMessage state file

collapsible ∷ String → HTML → Boolean → HTML
collapsible title content expanded =
  HH.div
    [ HP.classes [ H.ClassName "sd-collapsible-error" ] ]
    $ join
      [ pure $
          HH.button
            [ HE.onClick $ HE.input_ (ToggleExpanded (not expanded)) ]
            [ if expanded then I.chevronDownSm else I.chevronRightSm
            , HH.span_ [ HH.text title ]
            ]
      , guard expanded $>
          HH.div
            [ HP.class_ (H.ClassName "sd-collapsible-error-content") ]
            [ content ]
      ]

queryErrorMessage ∷ State → CE.QueryError → HTML
queryErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the query card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.QueryCompileError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occurred during query compilation." ]
          , renderMore qErr
          ]
    CE.QueryRetrieveResultError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occurred when retrieving the query result." ]
          , renderMore qErr
          ]
  renderMore = case _ of
    QA.ErrorMessage {title, message, raw} →
      pure $ HH.div_
        $ join
          [ foldMap (\t -> pure $ HH.p_ [ HH.text t ]) title
          , pure $ HH.p_ [ HH.text message ]
          , guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorRaw raw) expanded
          ]
    err' →
      guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorDetails err') expanded

cacheErrorMessage ∷ State → CE.CacheError → HTML
cacheErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the cache card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.CacheInvalidFilepath fp →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "There is a problem in the configuration of the cache card." ]
          , pure $ HH.p_
              [ HH.text "The provided path "
              , HH.code_ [ HH.text fp ]
              , HH.text " is not a valid location to store the cache result."
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.CacheQuasarError qe →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_ [ HH.text "The Quasar analytics engine returned an error while verifying the cache result." ]
          , guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorDetails qe) expanded
          ]
    CE.CacheErrorSavingFile fp →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_
              [ HH.text "The file "
              , HH.code_ [ HH.text (Path.printPath fp) ]
              , HH.text " could not be written to."
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and provide an alternative path to fix this error." ]
          ]
    CE.CacheResourceNotModified →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_ [ HH.text "Caching can only be applied to queries that perform at least one transformation on an existing data set." ]
          -- TODO: only show this solution when there are no following cards?
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and delete it to fix this error." ]
          ]

markdownErrorMessage ∷ State → CE.MarkdownError → HTML
markdownErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Markdown card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  -- TODO: explain which field for all these cases? -gb
  renderDetails = case _ of
    CE.MarkdownParseError {markdown, error} →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Parsing the provided Markdown failed." ]
          , pure $ HH.p_
              [ HH.text "We encountered the following parse error: "
              , HH.code_ [ HH.text error ]
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownSqlParseError {sql, error} →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Parsing SQL embedded inside Markdown failed." ]
          , pure $ renderParseError error sql
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownNoTextBoxResults →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A text box field did not return any results." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidTimeValue { time, error } →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An invalid time value was provided." ]
          , pure $ renderParseError error time
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidDateValue { date, error } →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An invalid date value was provided." ]
          , pure $ renderParseError error date
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidDateTimeValue { datetime, error } →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An invalid timestamp value was provided." ]
          , pure $ renderParseError error datetime
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownTypeError t1 t2 →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A type mismatch occurred when populating a field in the Markdown card." ]
          , pure $ HH.p_
              [ HH.text "We encountered the following type:"
              , HH.br_
              , HH.code_ [ HH.text t1 ]
              , HH.text " where we expected:"
              , HH.br_
              , HH.code_ [ HH.text t2 ]
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    where
      renderParseError error value =
        HH.p_
          [ HH.text "We encountered the following error:"
          , HH.br_
          , HH.code_ [ HH.text error ]
          , HH.text " when trying to parse:"
          , HH.br_
          , HH.code_ [ HH.text value ]
          ]

downloadOptionsErrorMessage ∷ State → CE.DownloadOptionsError → HTML
downloadOptionsErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Download Options card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.DownloadOptionsFilenameRequired →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "No filename was provided in the Download Options card." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.DownloadOptionsFilenameInvalid fn →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "The filename provided in the Download Options card is invalid." ]
          , pure $ HH.p_
              [ HH.code_ [ HH.text fn ], HH.text " is not a valid filepath." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

openErrorMessage ∷ State → CE.OpenError → HTML
openErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Open card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.OpenFileNotFound fp →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A file that was selected in the Open card could not be found." ]
          , pure $ HH.p_
              [ HH.code_ [ HH.text fp ], HH.text " does not exist." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and make a new selection to fix this error." ]
          ]
    CE.OpenNoResourceSelected →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "No resource was selected in the Open card." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select either a file or a variable to fix this error." ]
          ]
    CE.OpenNoFileSelected →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "The resource selected in the Open card is of an invalid type" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select a file or variable to fix this error." ]
          ]

tableErrorMessage ∷ State → CE.TableError → HTML
tableErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Preview Table card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.TableMissingResourceInputError →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Expected a TaggedResource input." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.TableCountQuasarError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A error occured when counting the preview data." ]
          , pure $ printQErrorWithDetails qErr
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.TableSampleQuasarError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A error occured during sampling of the preview data." ]
          , pure $ printQErrorWithDetails qErr
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

formInputStaticErrorMessage ∷ State → CE.FormInputStaticError → HTML
formInputStaticErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Forminput static card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.FIStaticNoAxis →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput static card." ]
          , pure $ HH.p_
              [ HH.text "No axis was selected" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FIStaticMissingAxis axis →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput static card." ]
          , pure $ HH.p_
              [ HH.text "The selected axis was not present in the data." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

formInputLabeledErrorMessage ∷ State → CE.FormInputLabeledError → HTML
formInputLabeledErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Forminput labeled card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.FILabeledNoAxisError →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "No axis was selected" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FILabeledEmptyResourceError →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "The selected resource was empty." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FILabeledTooManyEntries { formInputType, maximum, entryCount } →
      let
        errorText =
          "The " <> FIT.printFormInputType formInputType
          <> " form input can't take more than "
          <> show (FIT.maximumCountOfEntries formInputType)
          <> "entries, but there were: "
          <> show entryCount
          <> ". Please use 'limit' or 'group by'"
      in
        HH.div_
          $ join
            [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
            , pure $ HH.p_
                [ HH.text errorText ]
            , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
            ]
    CE.FILabeledTooManySelected { formInputType, maximum, selectedCount } →
      let
        errorText =
          "The " <> FIT.printFormInputType formInputType
          <> " form input can't have more than "
          <> show (FIT.maximumCountOfSelectedValues formInputType)
          <> " selected values, but there were: "
          <> show selectedCount
          <> ". Please, use another axis"
      in
        HH.div_
          $ join
            [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
            , pure $ HH.p_
                [ HH.text errorText ]
            , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
            ]
    -- TODO: Use the label argument for a better error message
    CE.FILabeledNonUniqueLabelError label →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "Labels must be unique. Please, use other axis." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]


Explicitly list module exports

Explicitly list module exports

module DOM.HTML.Event.DragEvent.DataTransfer
  ( DataTransfer
  , files
  , types
  ) where

import DOM.File.Types (FileList)

foreign import data DataTransfer :: *

-- | Contains a list of all the local files available on the data transfer.
-- | Empty if the drag operation doesn't involve dragging files.
foreign import files :: DataTransfer -> FileList

-- | Returns an array of data formats used in the drag operation.
-- | If the drag operation included no data, then the array is empty.
foreign import types :: DataTransfer -> Array String

module DOM.HTML.Event.DragEvent.DataTransfer where

import DOM.File.Types (FileList)

foreign import data DataTransfer :: *

-- | Contains a list of all the local files available on the data transfer.
-- | Empty if the drag operation doesn't involve dragging files.
foreign import files :: DataTransfer -> FileList

-- | Returns an array of data formats used in the drag operation.
-- | If the drag operation included no data, then the array is empty.
foreign import types :: DataTransfer -> Array String


Remove superflous comments

Remove superflous comments

Let the code do the talking

module Docopt.Parser.Scanner where

import Prelude
import Debug.Trace
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.List (List(..), many, toList, fromList, (:), length, filter
                 , takeWhile, sort, head)
import qualified Data.Array as A
import Data.String (toLower, toCharArray, fromCharArray)
import qualified Data.String as Str
import Data.Maybe
import Data.Either
import Docopt.Parser.Base
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Usage as Usage
import Docopt.Textwrap (dedent)

type Docopt = { usage :: Section, options :: List Section }
type Section = String

scan :: String -> Either P.ParseError Docopt
scan = (flip P.runParser docoptScanner) <<< dedent

docoptScanner :: P.Parser String Docopt
docoptScanner = do

  P.manyTill
    P.anyChar
    ((void $ P.lookAhead sectionLabel) <|> P.eof)

  label <- sectionLabel
  guard ((toLower label) == "usage")

  -- "Fix" the section by replacing the original section header with whitespace
  -- to maintain proper offsets.
  fixColOffset <- (P.char '\n' *> pure 0)
              <|> (pure $ Str.length label + 1) -- + 1 for the colon
  usage <- fromCharArray <<< fromList <$> do
    P.manyTill
      P.anyChar
      ((void $ P.lookAhead sectionLabel) <|> P.eof)
  let fixedUsage = (fromCharArray $ A.replicate fixColOffset ' ') ++ usage

  options <- many do
    label <- sectionLabel
    guard $ endsWith ("options") (toLower label)
    fromCharArray <<< fromList <$> do
      P.manyTill
        P.anyChar
        ((void $ P.lookAhead sectionLabel) <|> P.eof)

  pure { usage: dedent fixedUsage, options: options }

  where
    sectionLabel :: P.Parser String String
    sectionLabel = do
      many space
      name <- fromCharArray <$> do
        A.many $ P.noneOf [ '\n', '\r', ':' ]
      P.char ':'
      pure name

    endsWith :: String -> String -> Boolean
    endsWith sub s = Str.drop (Str.length s - Str.length sub) s == sub

module Docopt.Parser.Scanner where

import Prelude
import Debug.Trace
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.List (List(..), many, toList, fromList, (:), length, filter
                 , takeWhile, sort, head)
import qualified Data.Array as A
import Data.String (toLower, toCharArray, fromCharArray)
import qualified Data.String as Str
import Data.Maybe
import Data.Either
import Docopt.Parser.Base
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Usage as Usage
import Docopt.Textwrap (dedent)

type Docopt = { usage :: Section, options :: List Section }
type Section = String

-- | Pre-parse the docopt string and break it into sections.
scan :: String -> Either P.ParseError Docopt
scan = (flip P.runParser docoptScanner) <<< dedent

docoptScanner :: P.Parser String Docopt
docoptScanner = do

  -- | Break the input string into sections.
  -- | A section header is defined as a line starting with a label - that is
  -- | string followed by a colon.
  P.manyTill
    P.anyChar
    ((void $ P.lookAhead sectionLabel) <|> P.eof)

  -- | Parse the usage section
  label <- sectionLabel
  guard ((toLower label) == "usage")

  -- "Fix" the section by replacing the original section header with whitespace
  -- to maintain proper offsets.
  fixColOffset <- (P.char '\n' *> pure 0)
              <|> (pure $ Str.length label + 1) -- + 1 for the colon
  usage <- fromCharArray <<< fromList <$> do
    P.manyTill
      P.anyChar
      ((void $ P.lookAhead sectionLabel) <|> P.eof)
  let fixedUsage = (fromCharArray $ A.replicate fixColOffset ' ') ++ usage

  -- | Parse any option sections
  options <- many do
    label <- sectionLabel
    guard $ endsWith ("options") (toLower label)
    fromCharArray <<< fromList <$> do
      P.manyTill
        P.anyChar
        ((void $ P.lookAhead sectionLabel) <|> P.eof)

  pure { usage: dedent fixedUsage, options: options }

  where
    sectionLabel :: P.Parser String String
    sectionLabel = do
      many space
      name <- fromCharArray <$> do
        A.many $ P.noneOf [ '\n', '\r', ':' ]
      P.char ':'
      pure name

    endsWith :: String -> String -> Boolean
    endsWith sub s = Str.drop (Str.length s - Str.length sub) s == sub


Update effects-aff-ajax example

Update effects-aff-ajax example

Using a form element makes interacting with the example a bit easier
(hitting "enter" on the keyboard, for example).

module Component (State, Query(..), ui) where

import Prelude
import Control.Monad.Aff (Aff)
import Data.Maybe (Maybe(..))
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Network.HTTP.Affjax as AX

type State =
  { loading :: Boolean
  , username :: String
  , result :: Maybe String
  }

data Query a
  = SetUsername String a
  | MakeRequest a

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (ajax :: AX.AJAX | eff))
ui =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = { loading: false, username: "", result: Nothing }

  render :: State -> H.ComponentHTML Query
  render st =
    HH.form_ $
      [ HH.h1_ [ HH.text "Lookup GitHub user" ]
      , HH.label_
          [ HH.div_ [ HH.text "Enter username:" ]
          , HH.input
              [ HP.value st.username
              , HE.onValueInput (HE.input SetUsername)
              ]
          ]
      , HH.button
          [ HP.disabled st.loading
          , HE.onClick (HE.input_ MakeRequest)
          ]
          [ HH.text "Fetch info" ]
      , HH.p_
          [ HH.text (if st.loading then "Working..." else "") ]
      , HH.div_
          case st.result of
            Nothing -> []
            Just res ->
              [ HH.h2_
                  [ HH.text "Response:" ]
              , HH.pre_
                  [ HH.code_ [ HH.text res ] ]
              ]
      ]

  eval :: Query ~> H.ComponentDSL State Query Void (Aff (ajax :: AX.AJAX | eff))
  eval = case _ of
    SetUsername username next -> do
      H.modify (_ { username = username, result = Nothing :: Maybe String })
      pure next
    MakeRequest next -> do
      username <- H.gets _.username
      H.modify (_ { loading = true })
      response <- H.liftAff $ AX.get ("https://api.github.com/users/" <> username)
      H.modify (_ { loading = false, result = Just response.response })
      pure next

module Component (State, Query(..), ui) where

import Prelude
import Control.Monad.Aff (Aff)
import Data.Maybe (Maybe(..))
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Network.HTTP.Affjax as AX

type State =
  { loading :: Boolean
  , username :: String
  , result :: Maybe String
  }

data Query a
  = SetUsername String a
  | MakeRequest a

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (ajax :: AX.AJAX | eff))
ui =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = { loading: false, username: "", result: Nothing }

  render :: State -> H.ComponentHTML Query
  render st =
    HH.div_ $
      [ HH.h1_ [ HH.text "Lookup GitHub user" ]
      , HH.label_
          [ HH.div_ [ HH.text "Enter username:" ]
          , HH.input
              [ HP.value st.username
              , HE.onValueInput (HE.input SetUsername)
              ]
          ]
      , HH.button
          [ HP.disabled st.loading
          , HE.onClick (HE.input_ MakeRequest)
          ]
          [ HH.text "Fetch info" ]
      , HH.p_
          [ HH.text (if st.loading then "Working..." else "") ]
      , HH.div_
          case st.result of
            Nothing -> []
            Just res ->
              [ HH.h2_
                  [ HH.text "Response:" ]
              , HH.pre_
                  [ HH.code_ [ HH.text res ] ]
              ]
      ]

  eval :: Query ~> H.ComponentDSL State Query Void (Aff (ajax :: AX.AJAX | eff))
  eval = case _ of
    SetUsername username next -> do
      H.modify (_ { username = username, result = Nothing :: Maybe String })
      pure next
    MakeRequest next -> do
      username <- H.gets _.username
      H.modify (_ { loading = true })
      response <- H.liftAff $ AX.get ("https://api.github.com/users/" <> username)
      H.modify (_ { loading = false, result = Just response.response })
      pure next