Add type annotations

Add type annotations

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===

module Docopt.Spec.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), isJust, maybe, maybe')
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList)
import Data.Traversable (traverse)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Monoid (mempty)
import qualified Data.Array as A

import Docopt (Argument(..), Application(..), Branch(..), OptionArgument(..)
              , Value(..))
import qualified Docopt.Spec.Parser.Desc  as D
import qualified Docopt.Spec.Parser.Usage as U

data SolveError = SolveError
instance showSolveError :: Show SolveError where
  show _ = "SolveError"

solveArg :: U.Argument -> List D.Desc -> Either SolveError (List Argument)
solveArg (U.Command s) _       = singleton <$> return (Command s)
solveArg (U.Positional s r) _  = singleton <$> return (Positional s r)
solveArg o@(U.Option n a r) ds = singleton <$> do
  -- XXX: Is `head` the right thing to do here? What if there are more
  -- matches? That would indicate ambigiutiy and needs to be treated, possibly
  -- with an error?
  return $ maybe' (\_ -> Option Nothing (Just n) (toArg a) r)
                  id
                  (head $ catMaybes $ convert <$> ds)

  where
    toArg:: Maybe String -> Maybe OptionArgument
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String -> Maybe D.Argument -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg _ _ = Nothing

    convert :: D.Desc -> Maybe Argument
    convert (D.OptionDesc (D.Option { name=D.Long n', arg=a' }))
      | n' == n
      = return $ Option Nothing (Just n) (resolveArg a a') r
    convert (D.OptionDesc (D.Option { name=D.Full f n', arg=a' }))
      | n' == n
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ = Nothing

solveArg o@(U.OptionStack f fs a r) ds = do
  -- TODO
  -- Match f and then each f in fs up with a descrption, if any, returning
  -- an Docopt.Option for each.
  traverse match (f:toList fs)
  where
    match f = do
      return $ maybe' (\_ -> Option (Just f) Nothing (toArg a) r)
                      id
                      (head $ catMaybes $ convert f <$> ds)

    toArg:: Maybe String -> Maybe OptionArgument
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String -> Maybe D.Argument -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)

    convert :: Char -> D.Desc -> Maybe Argument
    convert f (D.OptionDesc (D.Option { name=D.Flag f', arg=a' }))
      | f == f'
      = return $ Option (Just f) Nothing (resolveArg a a') r
    convert f (D.OptionDesc (D.Option { name=D.Full f' n, arg=a' }))
      | f == f'
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ _ = Nothing

solveArg (U.Group o bs r) ds  = singleton <$> do
  flip (Group o) r <$> do
    foldM go empty bs
      where go :: List Branch -> U.Branch -> Either SolveError (List Branch)
            go a b = do
              br <- solveBranch b ds
              return (br:a)

solveBranch :: U.Branch -> List D.Desc -> Either SolveError Branch
solveBranch as ds = Branch <<< concat <$> (foldM step Nil as)
  where
    step :: List (List Argument)
          -> U.Argument
          -> Either SolveError (List (List Argument))
    step ass a = do
      xs <- solveArg a ds
      return $ ass ++ (singleton xs)

solveUsage :: U.Usage -> List D.Desc -> Either SolveError Application
solveUsage (U.Usage _ bs) ds = Application <$> (foldM step Nil bs)
  where
    step :: List Branch -> U.Branch -> Either SolveError (List Branch)
    step bs b = do
      x <- solveBranch b ds
      return $ bs ++ (singleton x)

solve :: (List U.Usage)
      -> (List D.Desc)
      -> Either SolveError (List Application)
solve us ds = foldM step Nil us
  where
    step :: List Application -> U.Usage -> Either SolveError (List Application)
    step as u = do
      x <- solveUsage u ds
      return $ as ++ (singleton x)

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===

module Docopt.Spec.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), isJust, maybe, maybe')
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList)
import Data.Traversable (traverse)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Monoid (mempty)
import qualified Data.Array as A

import Docopt (Argument(..), Application(..), Branch(..), OptionArgument(..)
              , Value(..))
import qualified Docopt.Spec.Parser.Desc  as D
import qualified Docopt.Spec.Parser.Usage as U

data SolveError = SolveError
instance showSolveError :: Show SolveError where
  show _ = "SolveError"

solveArg :: U.Argument -> List D.Desc -> Either SolveError (List Argument)
solveArg (U.Command s) _       = singleton <$> return (Command s)
solveArg (U.Positional s r) _  = singleton <$> return (Positional s r)
solveArg o@(U.Option n a r) ds = singleton <$> do
  -- XXX: Is `head` the right thing to do here? What if there are more
  -- matches? That would indicate ambigiutiy and needs to be treated, possibly
  -- with an error?
  return $ maybe' (\_ -> Option Nothing (Just n) (toArg a) r)
                  id
                  (head $ catMaybes $ convert <$> ds)

  where
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String
               -> Maybe D.Argument
               -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg _ _ = Nothing

    convert :: D.Desc -> Maybe Argument
    convert (D.OptionDesc (D.Option { name=D.Long n', arg=a' }))
      | n' == n
      = return $ Option Nothing (Just n) (resolveArg a a') r
    convert (D.OptionDesc (D.Option { name=D.Full f n', arg=a' }))
      | n' == n
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ = Nothing

solveArg o@(U.OptionStack f fs a r) ds = do
  -- TODO
  -- Match f and then each f in fs up with a descrption, if any, returning
  -- an Docopt.Option for each.
  traverse match (f:toList fs)
  where
    match f = do
      return $ maybe' (\_ -> Option (Just f) Nothing (toArg a) r)
                      id
                      (head $ catMaybes $ convert f <$> ds)

    toArg a = a >>= \an -> return $ OptionArgument an Nothing
    resolveArg :: Maybe String
               -> Maybe D.Argument
               -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)

    convert :: Char -> D.Desc -> Maybe Argument
    convert f (D.OptionDesc (D.Option { name=D.Flag f', arg=a' }))
      | f == f'
      = return $ Option (Just f) Nothing (resolveArg a a') r
    convert f (D.OptionDesc (D.Option { name=D.Full f' n, arg=a' }))
      | f == f'
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ _ = Nothing

solveArg (U.Group o bs r) ds  = singleton <$> do
  flip (Group o) r <$> do
    foldM go empty bs
      where go :: List Branch -> U.Branch -> Either SolveError (List Branch)
            go a b = do
              br <- solveBranch b ds
              return (br:a)

solveBranch :: U.Branch -> List D.Desc -> Either SolveError Branch
solveBranch as ds = Branch <<< concat <$> (foldM step Nil as)
  where
    step :: List (List Argument)
          -> U.Argument
          -> Either SolveError (List (List Argument))
    step ass a = do
      xs <- solveArg a ds
      return $ ass ++ (singleton xs)

solveUsage :: U.Usage -> List D.Desc -> Either SolveError Application
solveUsage (U.Usage _ bs) ds = Application <$> (foldM step Nil bs)
  where
    step :: List Branch -> U.Branch -> Either SolveError (List Branch)
    step bs b = do
      x <- solveBranch b ds
      return $ bs ++ (singleton x)

solve :: (List U.Usage)
      -> (List D.Desc)
      -> Either SolveError (List Application)
solve us ds = foldM step Nil us
  where
    step :: List Application -> U.Usage -> Either SolveError (List Application)
    step as u = do
      x <- solveUsage u ds
      return $ as ++ (singleton x)


Test file now generates Javascript

Test file now generates Javascript

module Main where

import Debug.Trace

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

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

import Language.PureScript.Declarations
import Language.PureScript.Supply
import Language.PureScript.Sugar
import Language.PureScript.TypeChecker
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Environment
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS
import Language.PureScript.Supply
import Language.PureScript.Names
import Language.PureScript.Pretty.JS

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

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

main = do
  trace "Lexing source file"
  case P.lex example of
    Left err -> trace err
    Right tokens -> do
      trace $ "Tokens: " ++ show tokens
      trace "Parsing module"
      case P.runTokenParser (P.parseModule <* P.eof) tokens of
        Left err -> trace err
        Right mod -> do
          trace $ "Module: " ++ show mod
          trace "Desugaring module"
          case evalSupplyT 0 (desugar [mod]) of
            Left err -> print err
            Right [mod'@(Module mn ds exps)] -> do
              trace $ "Desugared: " ++ show mod'
              trace "Type checking and elaborating terms"
              case runCheck defaultOptions (typeCheckModule mn ds) of
                Left err -> print err
                Right (Tuple ds' env) -> do
                  trace $ "Elaborated: "++ show ds'
                  trace "Generating code"
                  case runIdentity (evalSupplyT 0 (moduleToJs CommonJS defaultOptions (Module mn ds' exps) env)) of
                    jss -> do
                      trace $ "Generated JS: "
                      trace $ prettyPrintJS jss

typeCheckModule :: ModuleName -> [Declaration] -> Check [Declaration]
typeCheckModule mn ds = do
  modify (\(CheckState st) -> CheckState (st { currentModule = Just mn }))
  typeCheckAll Nothing mn ds

module Main where

import Debug.Trace

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

import Control.Apply
import Control.Monad.Identity

import Language.PureScript.Declarations
import Language.PureScript.Supply
import Language.PureScript.Sugar
import Language.PureScript.TypeChecker
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Environment
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS
import Language.PureScript.Supply

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

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

main = do
  trace "Lexing source file"
  case P.lex example of
    Left err -> trace err
    Right tokens -> do
      trace $ "Tokens: " ++ show tokens
      trace "Parsing module"
      case P.runTokenParser (P.parseModule <* P.eof) tokens of
        Left err -> trace err
        Right mod -> do
          trace $ "Module: " ++ show mod
          trace "Desugaring module"
          case evalSupplyT 0 (desugar [mod]) of
            Left err -> print err
            Right [mod'@(Module mn ds exps)] -> do
              trace $ "Desugared: " ++ show mod'
              trace "Type checking and elaborating terms"
              case runCheck defaultOptions (typeCheckAll Nothing mn ds) of
                Left err -> print err
                Right (Tuple ds' env) -> do
                  trace $ "Elaborated: "++ show ds'
                  trace "Generating code"
                  case runIdentity (evalSupplyT 0 (moduleToJs CommonJS defaultOptions (Module mn ds' exps) env)) of
                    jss -> trace $ "Generated JS: " ++ show jss


Fix compress checkbox state in download card

Resolves #1242

{-
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.DownloadOptions.Component (comp) where

import SlamData.Prelude

import Data.Lens as Lens
import Data.Lens ((.~), (^?), _Left, _Right, (%~))

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

import SlamData.Download.Model as DL
import SlamData.Download.Render as DLR
import SlamData.Monad (Slam)
import SlamData.Render.CSS as RC
import SlamData.Workspace.Card.CardType (CardType(DownloadOptions))
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Common.Render (renderLowLOD)
import SlamData.Workspace.Card.DownloadOptions.Component.Query (QueryP, Query(..))
import SlamData.Workspace.Card.DownloadOptions.Component.State (State, _compress, _options, _source, initialState, _levelOfDetails)
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type HTML = H.ComponentHTML QueryP
type DSL = H.ComponentDSL State QueryP Slam

comp ∷ CC.CardComponent
comp = CC.makeCardComponent
  { cardType: DownloadOptions
  , component: H.component {render, eval}
  , initialState: initialState
  , _State: CC._DownloadOptionsState
  , _Query: CC.makeQueryPrism CC._DownloadOptionsQuery
  }

render ∷ State → HTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD (CT.lightCardGlyph CT.DownloadOptions) left state.levelOfDetails
    ]

renderHighLOD ∷ State → HTML
renderHighLOD state =
  case state.source of
    Nothing →
      HH.div
        [ HP.classes
            $ [ B.alert, B.alertDanger ]
            ⊕ hideClasses
        ]
        [ HH.text "The current input cannot be downloaded" ]
    Just _ →
      HH.div
        [ HP.classes
            $ [ RC.downloadCardEditor
              , HH.className "card-input-maximum-lod"
              ]
            ⊕ hideClasses
        ]
        [ renderDownloadTypeSelector state
        , renderDownloadConfiguration state
        ]
  where
  hideClasses = guard (state.levelOfDetails ≠ High) $> B.hidden

renderDownloadConfiguration ∷ State → HTML
renderDownloadConfiguration state =
  HH.div
    [ HP.classes [ RC.downloadConfiguration ] ]
    $ [ either optionsCSV optionsJSON state.options ]
    ⊕ [ compress state ]

optionsCSV ∷ DL.CSVOptions → HTML
optionsCSV = DLR.optionsCSV (\lens v → right ∘ (ModifyCSVOpts (lens .~ v)))

optionsJSON ∷ DL.JSONOptions → HTML
optionsJSON = DLR.optionsJSON (\lens v → right ∘ (ModifyJSONOpts (lens .~ v)))

compress ∷ State → HTML
compress state =
  HH.div
    [ HP.classes [ B.formGroup ] ]
    [ HH.label_
        [ HH.span_ [ HH.text "Compress" ]
        , HH.input
            [ HP.inputType HP.InputCheckbox
            , HP.checked compressed
            , HP.enabled $ isJust state.source
            , HE.onValueChange (HE.input_ (right ∘ ToggleCompress))
            ]
        ]
    ]
  where
  compressed ∷ Boolean
  compressed = isJust state.source && state.compress

renderDownloadTypeSelector ∷ State → HTML
renderDownloadTypeSelector state =
  HH.div
    [ HP.classes [ RC.downloadTypeSelector ] ]
    [ HH.img
        [ HP.src "img/csv.svg"
        , HP.classes (guard (isLeft state.options) $> B.active)
        , HP.title "Comma separated values"
        , HE.onClick (HE.input_ (right ∘ SetOutput DL.CSV))
        ]
    , HH.img
        [ HP.src "img/json.svg"
        , HP.classes (guard (isRight state.options) $> B.active)
        , HP.title "JSON"
        , HE.onClick (HE.input_ (right ∘ SetOutput DL.JSON))
        ]
    ]

eval ∷ QueryP ~> DSL
eval = coproduct cardEval downloadOptsEval

cardEval ∷ CC.CardEvalQuery ~> DSL
cardEval = case _ of
  CC.EvalCard info output next → do
    H.modify $ _source .~ info.input ^? Lens._Just ∘ Port._Resource
    pure next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    map (k ∘ Card.DownloadOptions) H.get
  CC.Load card next → do
    case card of
      Card.DownloadOptions st → H.set st
      _ → pure unit
    pure next
  CC.SetDimensions dims next → do
    H.modify
      $ _levelOfDetails
      .~ if dims.width < 504.0 ∨ dims.height < 192.0
           then Low
           else High
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

downloadOptsEval ∷ Query ~> DSL
downloadOptsEval q = do
  n ← case q of
    SetOutput ty next → do
      options ← H.gets _.options
      case ty, options of
        DL.CSV, (Right _) → H.modify _{options = Left DL.initialCSVOptions}
        DL.JSON, (Left _) → H.modify _{options = Right DL.initialJSONOptions}
        _, _ → pure unit
      pure next
    ModifyCSVOpts fn next →
      H.modify (_options ∘ _Left %~ fn) $> next
    ModifyJSONOpts fn next →
      H.modify (_options ∘ _Right %~ fn) $> next
    ToggleCompress next →
      H.modify (_compress %~ not) $> next
  CC.raiseUpdatedC' CC.EvalModelUpdate
  pure n

{-
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.DownloadOptions.Component (comp) where

import SlamData.Prelude

import Data.Lens as Lens
import Data.Lens ((.~), (^?), _Left, _Right, (%~))

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

import SlamData.Download.Model as DL
import SlamData.Download.Render as DLR
import SlamData.Monad (Slam)
import SlamData.Render.CSS as RC
import SlamData.Workspace.Card.CardType (CardType(DownloadOptions))
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Common.Render (renderLowLOD)
import SlamData.Workspace.Card.DownloadOptions.Component.Query (QueryP, Query(..))
import SlamData.Workspace.Card.DownloadOptions.Component.State (State, _compress, _options, _source, initialState, _levelOfDetails)
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type HTML = H.ComponentHTML QueryP
type DSL = H.ComponentDSL State QueryP Slam

comp ∷ CC.CardComponent
comp = CC.makeCardComponent
  { cardType: DownloadOptions
  , component: H.component {render, eval}
  , initialState: initialState
  , _State: CC._DownloadOptionsState
  , _Query: CC.makeQueryPrism CC._DownloadOptionsQuery
  }

render ∷ State → HTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD (CT.lightCardGlyph CT.DownloadOptions) left state.levelOfDetails
    ]

renderHighLOD ∷ State → HTML
renderHighLOD state =
  case state.source of
    Nothing →
      HH.div
        [ HP.classes
            $ [ B.alert, B.alertDanger ]
            ⊕ hideClasses
        ]
        [ HH.text "The current input cannot be downloaded" ]
    Just _ →
      HH.div
        [ HP.classes
            $ [ RC.downloadCardEditor
              , HH.className "card-input-maximum-lod"
              ]
            ⊕ hideClasses
        ]
        [ renderDownloadTypeSelector state
        , renderDownloadConfiguration state
        ]
  where
  hideClasses = guard (state.levelOfDetails ≠ High) $> B.hidden

renderDownloadConfiguration ∷ State → HTML
renderDownloadConfiguration state =
  HH.div
    [ HP.classes [ RC.downloadConfiguration ] ]
    $ [ either optionsCSV optionsJSON state.options ]
    ⊕ [ compress state ]

optionsCSV ∷ DL.CSVOptions → HTML
optionsCSV = DLR.optionsCSV (\lens v → right ∘ (ModifyCSVOpts (lens .~ v)))

optionsJSON ∷ DL.JSONOptions → HTML
optionsJSON = DLR.optionsJSON (\lens v → right ∘ (ModifyJSONOpts (lens .~ v)))

compress ∷ State → HTML
compress state =
  HH.div
    [ HP.classes [ B.formGroup ] ]
    [ HH.label_
        [ HH.span_ [ HH.text "Compress" ]
        , HH.input
            [ HP.inputType HP.InputCheckbox
            , HP.checked compressed
            , HP.enabled $ isJust state.source
            , HE.onValueChange (HE.input_ (right ∘ ToggleCompress))
            ]
        ]
    ]
  where
  compressed ∷ Boolean
  compressed = isJust state.source || state.compress

renderDownloadTypeSelector ∷ State → HTML
renderDownloadTypeSelector state =
  HH.div
    [ HP.classes [ RC.downloadTypeSelector ] ]
    [ HH.img
        [ HP.src "img/csv.svg"
        , HP.classes (guard (isLeft state.options) $> B.active)
        , HP.title "Comma separated values"
        , HE.onClick (HE.input_ (right ∘ SetOutput DL.CSV))
        ]
    , HH.img
        [ HP.src "img/json.svg"
        , HP.classes (guard (isRight state.options) $> B.active)
        , HP.title "JSON"
        , HE.onClick (HE.input_ (right ∘ SetOutput DL.JSON))
        ]
    ]

eval ∷ QueryP ~> DSL
eval = coproduct cardEval downloadOptsEval

cardEval ∷ CC.CardEvalQuery ~> DSL
cardEval = case _ of
  CC.EvalCard info output next → do
    H.modify $ _source .~ info.input ^? Lens._Just ∘ Port._Resource
    pure next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    map (k ∘ Card.DownloadOptions) H.get
  CC.Load card next → do
    case card of
      Card.DownloadOptions st → H.set st
      _ → pure unit
    pure next
  CC.SetDimensions dims next → do
    H.modify
      $ _levelOfDetails
      .~ if dims.width < 504.0 ∨ dims.height < 192.0
           then Low
           else High
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

downloadOptsEval ∷ Query ~> DSL
downloadOptsEval q = do
  n ← case q of
    SetOutput ty next → do
      options ← H.gets _.options
      case ty, options of
        DL.CSV, (Right _) → H.modify _{options = Left DL.initialCSVOptions}
        DL.JSON, (Left _) → H.modify _{options = Right DL.initialJSONOptions}
        _, _ → pure unit
      pure next
    ModifyCSVOpts fn next →
      H.modify (_options ∘ _Left %~ fn) $> next
    ModifyJSONOpts fn next →
      H.modify (_options ∘ _Right %~ fn) $> next
    ToggleCompress next →
      H.modify (_compress %~ not) $> next
  CC.raiseUpdatedC' CC.EvalModelUpdate
  pure n


Add test for #63

Add test for #63

module Test.Data.StrMap where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)

import Data.Foldable (foldl)
import Data.Function (on)
import Data.List (List(..), groupBy, sortBy, singleton, fromFoldable, zipWith)
import Data.Maybe (Maybe(..))
import Data.StrMap as M
import Data.Tuple (Tuple(..), fst)

import Partial.Unsafe (unsafePartial)

import Test.QuickCheck ((<?>), quickCheck, quickCheck')
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)

newtype TestStrMap v = TestStrMap (M.StrMap v)

instance arbTestStrMap :: (Arbitrary v) => Arbitrary (TestStrMap v) where
  arbitrary = TestStrMap <<< M.fromList <$> arbitrary

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")"
  show (Delete k) = "Delete (" <> show k <> ")"

instance arbInstruction :: (Arbitrary v) => Arbitrary (Instruction String v) where
  arbitrary = do
    b <- arbitrary
    k <- arbitrary
    case b of
      true -> do
        v <- arbitrary
        pure (Insert k v)
      false -> do
        pure (Delete k)

runInstructions :: forall v. List (Instruction String v) -> M.StrMap v -> M.StrMap v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

number :: Int -> Int
number n = n

strMapTests :: forall eff. Eff (console :: CONSOLE, random :: RANDOM, err :: EXCEPTION | eff) Unit
strMapTests = do
  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup k (M.insert k v M.empty) == Just (number v)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete k (M.insert k (number v) M.empty))
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty)) == Just v1
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty)) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty))) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.StrMap Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup k (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.StrMap Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " <> show instrs <> "\nk:\n  " <> show k <> "\nv:\n  " <> show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toList (M.singleton k v :: M.StrMap Int) == singleton (Tuple k v)

  log "fromFoldable [] = empty"
  quickCheck (M.fromFoldable [] == (M.empty :: M.StrMap Unit)
    <?> "was not empty")

  log "fromFoldable & key collision"
  do
    let nums = M.fromFoldable [Tuple "0" "zero", Tuple "1" "what", Tuple "1" "one"]
    quickCheck (M.lookup "0" nums == Just "zero" <?> "invalid lookup - 0")
    quickCheck (M.lookup "1" nums == Just "one"  <?> "invalid lookup - 1")
    quickCheck (M.lookup "2" nums == Nothing     <?> "invalid lookup - 2")

  log "fromFoldableWith const [] = empty"
  quickCheck (M.fromFoldableWith const [] == (M.empty :: M.StrMap Unit)
    <?> "was not empty")

  log "fromFoldableWith (+) & key collision"
  do
    let nums = M.fromFoldableWith (+) [Tuple "0" 1, Tuple "1" 1, Tuple "1" 1]
    quickCheck (M.lookup "0" nums == Just 1  <?> "invalid lookup - 0")
    quickCheck (M.lookup "1" nums == Just 2  <?> "invalid lookup - 1")
    quickCheck (M.lookup "2" nums == Nothing <?> "invalid lookup - 2")

  log "fromFoldable . fromList = id"
  quickCheck $ \arr -> let f x = M.toList (M.fromList x)
                       in f (f arr) == f (arr :: List (Tuple String Int)) <?> show arr

  log "fromList . fromFoldable = id"
  quickCheck $ \(TestStrMap m) ->
    let f m1 = M.fromList (M.toList m1) in
    M.toList (f m) == M.toList (m :: M.StrMap Int) <?> show m

  log "fromListWith const = fromList"
  quickCheck $ \arr -> M.fromListWith const arr ==
                       M.fromList (arr :: List (Tuple String Int)) <?> show arr

  log "fromListWith (<>) = fromList . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs
        f = M.fromList <<< map (foldl1 combine) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromListWith (<>) arr == f (arr :: List (Tuple String String)) <?> show arr

  log "Lookup from union"
  quickCheck $ \(TestStrMap m1) (TestStrMap m2) k ->
    M.lookup k (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestStrMap m1) (TestStrMap m2) ->
    (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.StrMap Int)) <?> (show (M.size (m1 `M.union` m2)) <> " != " <> show (M.size ((m1 `M.union` m2) `M.union` m2)))

  log "fromFoldable = zip keys values"
  quickCheck $ \(TestStrMap m) -> M.toList m == zipWith Tuple (fromFoldable $ M.keys m) (M.values m :: List Int)

  log "Bug #63: accidental observable mutation in foldMap"
  quickCheck \(TestStrMap m) ->
    let lhs = go m
        rhs = go m
    in lhs == rhs <?> ("lhs: " <> show lhs <> ", rhs: " <> show rhs)
    where
    go :: M.StrMap (Array Ordering) -> Array Ordering
    go = M.foldMap \_ v -> v


Prototype: Do some basic canvas stuff

Prototype: Do some basic canvas stuff

module Main where

import Prelude ((+), (-), ($), bind, const, discard, pure, show, unit, Unit)

import Control.Monad.Eff (Eff)

import Data.Maybe (Maybe(Just))

import Graphics.Canvas (CANVAS, getCanvasElementById, getContext2D, setFillStyle, fillPath, rect)

import Partial.Unsafe (unsafePartial)

import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)

import Text.Smolder.HTML (button, div, span)
import Text.Smolder.Markup (text, (#!))

data Event = Increment | Decrement

type State = Int

-- | Return a new state (and effects) from each event
foldp :: forall fx. Event -> State -> EffModel State Event fx
foldp Increment n = { state: n + 1, effects: [] }
foldp Decrement n = { state: n - 1, effects: [] }

-- | Return markup from the state
view :: State -> HTML Event
view count =
  div do
    button #! onClick (const Increment) $ text "Increment"
    span $ text (show count)
    button #! onClick (const Decrement) $ text "Decrement"

-- | Start and render the app
main :: forall fx. Eff (canvas :: CANVAS | CoreEffects fx) Unit
main = unsafePartial do
  app <- start
    { initialState: 0
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input

  Just canvas <- getCanvasElementById "canvas"
  ctx         <- getContext2D canvas
  _           <- setFillStyle "#0000FF" ctx
  _           <- fillPath ctx $ rect ctx { x: 250.0, y: 250.0, w: 100.0, h: 100.0 }

  pure unit

module Main where

import Prelude ((+), (-), ($), bind, const, discard, show, Unit)
import Control.Monad.Eff (Eff)
import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, span)
import Text.Smolder.Markup (text, (#!))

data Event = Increment | Decrement

type State = Int

-- | Return a new state (and effects) from each event
foldp :: forall fx. Event -> State -> EffModel State Event fx
foldp Increment n = { state: n + 1, effects: [] }
foldp Decrement n = { state: n - 1, effects: [] }

-- | Return markup from the state
view :: State -> HTML Event
view count =
  div do
    button #! onClick (const Increment) $ text "Increment"
    span $ text (show count)
    button #! onClick (const Decrement) $ text "Decrement"

-- | Start and render the app
main :: forall fx. Eff (CoreEffects fx) Unit
main = do
  app <- start
    { initialState: 0
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input


Fix clickGlyphs etc.

Fix clickGlyphs etc.

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, delay, forkAff, launchAff)
import Control.Monad.Aff.AVar (makeVar, peekVar, putVar, takeVar, tryPeekVar)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State.Trans (StateT(..), evalStateT, execStateT, put)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (Writer, execWriter, tell)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Identity (Identity(..))
import Data.Int (round, toNumber)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(Just, Nothing), fromJust, isNothing)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence_, traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import FRP (FRP)
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, path, stroke)
import Genetics.Browser.GlyphF (GlyphF(..))
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), bpToPixels, pixelsToBp)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Point = { x :: Number
             , y :: Number }

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

glyphify :: Number
         -> View
         -> Feature Bp Number
         -> Glyph Unit
glyphify h v (Feature chr min max score) = do
  let height = 10.0
      y = h - (score + height)
      x = bpToPixels v.scale (min - v.min)
  stroke "black"
  fill "red"
  circle { x, y } 3.0

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchToCanvas :: Number -> (View -> Fetch _) -> View -> Context2D -> Aff _ Unit
fetchToCanvas h f v ctx = do
  features <- f v
  let gs = traverse_ (glyphify h v) features
  liftEff $ renderGlyph ctx gs

glyphifyFeatures :: Number
                 -> Array (Feature Bp Number)
                 -> View
                 -> (Array (Tuple (Feature Bp Number) (Glyph Unit)))
glyphifyFeatures h fs v = gs
  where gs = map (\f -> Tuple f (glyphify h v f)) fs

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

type View = { min :: Bp
            , max :: Bp
            , scale :: BpPerPixel
            }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange Bp Bp
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

modScale :: View
         -> (BpPerPixel -> BpPerPixel)
         -> View
modScale v f = { scale, min: mid - d, max: mid + d }
  where bpsWide = v.max - v.min
        pixelsWide = bpToPixels v.scale bpsWide
        mid = v.min + ((v.max - v.min) * Bp 0.5)
        scale = f v.scale
        bpsWide' = pixelsToBp scale pixelsWide
        d = bpsWide' * Bp 0.5

viewBehavior :: Event UpdateView
             -> View
             -> Event View
viewBehavior ev v = FRP.fold f ev v
  where f :: UpdateView -> View -> View
        f (ScrollBp x) v' = v' { min = v'.min + x
                               , max = v'.max + x }

        f (ScrollPixels x) v' = v' { min = v'.min - (pixelsToBp v'.scale x)
                                   , max = v'.max - (pixelsToBp v'.scale x) }

        f (SetRange min' max') v' = v' { min = min'
                                       , max = max' }

        f (ModScale g) v' = modScale v' g

        f (SetScale s) v' = modScale v' (const s)

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

foreign import setViewUI :: forall eff. String -> Eff eff Unit

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

widthToView :: Number
            -> { min :: Bp, max :: Bp }
            -> View
widthToView w { min, max } = { min, max, scale }
  where scale = BpPerPixel $ (unwrap (max - min)) / w

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

newtype GlyphBounds = GlyphBounds (Point -> Boolean)

derive instance newtypeGlyphBounds :: Newtype GlyphBounds _

instance semigroupGlyphBounds :: Semigroup GlyphBounds where
  append (GlyphBounds a) (GlyphBounds b) = GlyphBounds (a || b)

instance monoidGlyphBounds :: Monoid GlyphBounds where
  mempty = GlyphBounds $ const false

glyphBoundsNat :: GlyphF ~> Writer GlyphBounds
glyphBoundsNat (Circle p r a) = do
  tell $ GlyphBounds \p' -> let x' = p'.x - p.x
                                y' = p'.y - p.y
                            in Math.sqrt ((x' * x') + (y' * y')) < r
  pure a
glyphBoundsNat (Line _ _ a) = pure a
glyphBoundsNat (Rect p1 p2 a) = do
  tell $ GlyphBounds \p' -> (p'.x > p1.x && p'.x < p2.x) &&
                            (p'.y > p1.y && p'.y < p2.y)
  pure a
glyphBoundsNat (Stroke _ a) = pure a
glyphBoundsNat (Fill _ a) = pure a
glyphBoundsNat (Path _ a) = pure a

glyphBounds :: forall a. Glyph a -> GlyphBounds
glyphBounds = execWriter <<< foldFree glyphBoundsNat

-- Filters a collection of glyphs annotated with some functor,
-- returning glyphs that cover the given point on the canvas
clickAnnGlyphs :: forall f g a.
                  Filterable f
               => Functor g
               => Eq (g Boolean)
               => f (g (Glyph a))
               -> Point
               -> f (g (Glyph a))
clickAnnGlyphs gs p =
    filter (\x -> map pred x == map (const true) x) gs
  where pred = \g -> unwrap (glyphBounds g) p

-- For collections of unannotated glyphs
clickGlyphs :: forall f a.
               Filterable f
            => f (Glyph a)
            -> Point
            -> f (Glyph a)
clickGlyphs fs p = unwrap <$> clickAnnGlyphs (Identity <$> fs) p

browser :: Aff _ Unit
browser = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  browserState <- makeVar

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      v = widthToView w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch "./gwas.json"

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls
      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = viewBehavior updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    -- fetch
    _ <- launchAff do
      fgs <- (\f' -> glyphifyFeatures h f' v') <$> f v'
      putVar browserState { featsAndGlyphs: fgs
                          , view: v' }
      liftEff do
        clearCanvas canvas
        traverse_ (renderGlyph ctx <<< snd) fgs

    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- thread rendering view
  -- _ <- forkAff $ forever do
    -- render when the view & features have been updated
    -- state <- peekVar browserState
    -- liftEff do
    --   clearCanvas canvas
    --   traverse_ (renderGlyph ctx <<< snd) state.featsAndGlyphs
      -- renderFeatures h state.glyphs state.view ctx

  _ <- liftEff $ unsafeCoerceEff $
       FRP.subscribe (canvasEvent "click" canvas) \p -> launchAff do
         state <- tryPeekVar browserState
         liftEff $ log $ "clicked: (" <> show p.x <> ", " <> show p.y <> ")"
         case state of
           Nothing -> liftEff $ log "no state!"
           Just s' -> do
             liftEff $ log "state!"
             let gs' :: _
                 gs' = clickAnnGlyphs s'.featsAndGlyphs p

             traverse_ (liftEff <<< log <<< showGlyph <<< snd) gs'

  -- render first frame
  fetchToCanvas h f v ctx

main :: Eff _ _
main = launchAff browser

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, delay, forkAff, launchAff)
import Control.Monad.Aff.AVar (makeVar, peekVar, putVar, takeVar, tryPeekVar)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State.Trans (StateT(..), evalStateT, execStateT, put)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (Writer, execWriter, tell)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Either (Either(..))
import Data.Eq (class Eq1, eq1)
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Identity (Identity(..))
import Data.Int (round, toNumber)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(Just, Nothing), fromJust, isNothing)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence_, traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import FRP (FRP)
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, path, stroke)
import Genetics.Browser.GlyphF (GlyphF(..))
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), bpToPixels, pixelsToBp)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Point = { x :: Number
             , y :: Number }

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

glyphify :: Number
         -> View
         -> Feature Bp Number
         -> Glyph Unit
glyphify h v (Feature chr min max score) = do
  let height = 10.0
      y = h - (score + height)
      x = bpToPixels v.scale (min - v.min)
  stroke "black"
  fill "red"
  circle { x, y } 3.0

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchToCanvas :: Number -> (View -> Fetch _) -> View -> Context2D -> Aff _ Unit
fetchToCanvas h f v ctx = do
  features <- f v
  let gs = traverse_ (glyphify h v) features
  liftEff $ renderGlyph ctx gs

glyphifyFeatures :: Number
                 -> Array (Feature Bp Number)
                 -> View
                 -> (Array (Tuple (Feature Bp Number) (Glyph Unit)))
glyphifyFeatures h fs v = gs
  where gs = map (\f -> Tuple f (glyphify h v f)) fs

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

type View = { min :: Bp
            , max :: Bp
            , scale :: BpPerPixel
            }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange Bp Bp
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

modScale :: View
         -> (BpPerPixel -> BpPerPixel)
         -> View
modScale v f = { scale, min: mid - d, max: mid + d }
  where bpsWide = v.max - v.min
        pixelsWide = bpToPixels v.scale bpsWide
        mid = v.min + ((v.max - v.min) * Bp 0.5)
        scale = f v.scale
        bpsWide' = pixelsToBp scale pixelsWide
        d = bpsWide' * Bp 0.5

viewBehavior :: Event UpdateView
             -> View
             -> Event View
viewBehavior ev v = FRP.fold f ev v
  where f :: UpdateView -> View -> View
        f (ScrollBp x) v' = v' { min = v'.min + x
                               , max = v'.max + x }

        f (ScrollPixels x) v' = v' { min = v'.min - (pixelsToBp v'.scale x)
                                   , max = v'.max - (pixelsToBp v'.scale x) }

        f (SetRange min' max') v' = v' { min = min'
                                       , max = max' }

        f (ModScale g) v' = modScale v' g

        f (SetScale s) v' = modScale v' (const s)

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

foreign import setViewUI :: forall eff. String -> Eff eff Unit

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

widthToView :: Number
            -> { min :: Bp, max :: Bp }
            -> View
widthToView w { min, max } = { min, max, scale }
  where scale = BpPerPixel $ (unwrap (max - min)) / w

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

newtype GlyphBounds = GlyphBounds (Point -> Boolean)

derive instance newtypeGlyphBounds :: Newtype GlyphBounds _

instance semigroupGlyphBounds :: Semigroup GlyphBounds where
  append (GlyphBounds a) (GlyphBounds b) = GlyphBounds (a || b)

instance monoidGlyphBounds :: Monoid GlyphBounds where
  mempty = GlyphBounds $ const false

glyphBoundsNat :: GlyphF ~> Writer GlyphBounds
glyphBoundsNat (Circle p r a) = do
  tell $ GlyphBounds \p' -> let x' = p'.x - p.x
                                y' = p'.y - p.y
                            in Math.sqrt ((x' * x') + (y' * y')) < r
  pure a
glyphBoundsNat (Line _ _ a) = pure a
glyphBoundsNat (Rect p1 p2 a) = do
  tell $ GlyphBounds \p' -> (p'.x > p1.x && p'.x < p2.x) &&
                            (p'.y > p1.y && p'.y < p2.y)
  pure a
glyphBoundsNat (Stroke _ a) = pure a
glyphBoundsNat (Fill _ a) = pure a
glyphBoundsNat (Path _ a) = pure a

glyphBounds :: forall a. Glyph a -> GlyphBounds
glyphBounds = execWriter <<< foldFree glyphBoundsNat

-- Filters a collection of glyphs annotated with some functor,
-- returning glyphs that cover the given point on the canvas
clickAnnGlyphs :: forall f g a.
                  Filterable f
               => Functor g
               => Eq1 g
               => f (g (Glyph a))
               -> Point
               -> f (g (Glyph a))
clickAnnGlyphs gs p =
    filter (\x -> map pred x `eq1` map (const true) x) gs
  where pred = \g -> unwrap (glyphBounds g) p

-- For collections of unannotated glyphs
clickGlyphs :: forall f a.
               Filterable f
            => f (Glyph a)
            -> Point
            -> f (Glyph a)
clickGlyphs fs p = unwrap $ clickAnnGlyphs (Identity fs) p

browser :: Aff _ Unit
browser = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  browserState <- makeVar

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      v = widthToView w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch "./gwas.json"

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls
      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = viewBehavior updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    -- fetch
    _ <- launchAff do
      fgs <- (\f' -> glyphifyFeatures h f' v') <$> f v'
      putVar browserState { featsAndGlyphs: fgs
                          , view: v' }
      liftEff do
        clearCanvas canvas
        traverse_ (renderGlyph ctx <<< snd) fgs

    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- thread rendering view
  -- _ <- forkAff $ forever do
    -- render when the view & features have been updated
    -- state <- peekVar browserState
    -- liftEff do
    --   clearCanvas canvas
    --   traverse_ (renderGlyph ctx <<< snd) state.featsAndGlyphs
      -- renderFeatures h state.glyphs state.view ctx

  _ <- liftEff $ unsafeCoerceEff $
       FRP.subscribe (canvasEvent "click" canvas) \p -> launchAff do
         state <- tryPeekVar browserState
         liftEff $ log $ "clicked: (" <> show p.x <> ", " <> show p.y <> ")"
         case state of
           Nothing -> liftEff $ log "no state!"
           Just s' -> do
             liftEff $ log "state!"
             let gs' :: _
                 gs' = clickAnnGlyphs s'.featsAndGlyphs p

             traverse_ (liftEff <<< log <<< showGlyph <<< snd) gs'

  -- render first frame
  fetchToCanvas h f v ctx

main :: Eff _ _
main = launchAff browser


remove extra space

remove extra space

module Data.Foldable where

import Prelude
import Control.Apply
import Data.Either
import Data.Eq
import Data.Maybe
import Data.Monoid
import Data.Monoid.First
import Data.Tuple

class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. (Monoid m) => (a -> m) -> f a -> m

instance foldableArray :: Foldable [] where
  foldr f z xs = foldrArray f z xs

  foldl f z xs = foldlArray f z xs

  foldMap f xs = foldr (\x acc -> f x <> acc) mempty xs

instance foldableEither :: Foldable (Either a) where
  foldr _ z (Left _)  = z
  foldr f z (Right x) = x `f` z

  foldl _ z (Left _)  = z
  foldl f z (Right x) = z `f` x

  foldMap f (Left _)  = mempty
  foldMap f (Right x) = f x

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z

  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x

  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableRef :: Foldable Ref where
  foldr f z (Ref x) = x `f` z

  foldl f z (Ref x) = z `f` x

  foldMap f (Ref x) = f x

instance foldableTuple :: Foldable (Tuple a) where
  foldr f z (Tuple _ x) = x `f` z

  foldl f z (Tuple _ x) = z `f` x

  foldMap f (Tuple _ x) = f x

fold :: forall f m. (Foldable f, Monoid m) => f m -> m
fold = foldMap id

traverse_ :: forall a b f m. (Applicative m, Foldable f) => (a -> m b) -> f a -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

for_ :: forall a b f m. (Applicative m, Foldable f) => f a -> (a -> m b) -> m Unit
for_ = flip traverse_

sequence_ :: forall a f m. (Applicative m, Foldable f) => f (m a) -> m Unit
sequence_ = traverse_ id

mconcat :: forall f m. (Foldable f, Monoid m) => f m -> m
mconcat = foldl (<>) mempty

intercalate :: forall f m. (Foldable f, Monoid m) => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init = true } x = { init: false, acc: x }
  go { acc = acc } x   = { init: false, acc: acc <> sep <> x }

and :: forall f. (Foldable f) => f Boolean -> Boolean
and = foldl (&&) true

or :: forall f. (Foldable f) => f Boolean -> Boolean
or = foldl (||) false

any :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean
any p = or <<< foldMap (\x -> [p x])

all :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean
all p = and <<< foldMap (\x -> [p x])

sum :: forall f. (Foldable f) => f Number -> Number
sum = foldl (+) 0

product :: forall f. (Foldable f) => f Number -> Number
product = foldl (*) 1

elem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean
elem = any <<< (==)

notElem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean
notElem x = not <<< elem x

find :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Maybe a
find p f = case foldMap (\x -> if p x then [x] else []) f of
  (x:_) -> Just x
  []    -> Nothing

lookup :: forall a b f. (Eq a, Foldable f) => a -> f (Tuple a b) -> Maybe b
lookup a f = runFirst $ foldMap (\(Tuple a' b) -> First (if a == a' then Just b else Nothing)) f

foreign import foldrArray
  "function foldrArray(f) {\
  \  return function(z) {\
  \    return function(xs) {\
  \      var acc = z;\
  \      for (var i = xs.length - 1; i >= 0; --i) {\
  \        acc = f(xs[i])(acc);\
  \      }\
  \      return acc;\
  \    }\
  \  }\
  \}" :: forall a b. (a -> b -> b) -> b -> [a] -> b

foreign import foldlArray
  "function foldlArray(f) {\
  \  return function(z) {\
  \    return function(xs) {\
  \      var acc = z;\
  \      for (var i = 0, len = xs.length; i < len; ++i) {\
  \        acc = f(acc)(xs[i]);\
  \      }\
  \      return acc;\
  \    }\
  \  }\
  \}" :: forall a b. (b -> a -> b) -> b -> [a] -> b


code style

code style

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

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

-- | 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 -> dsl -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff)))
  -> ReactClass props
  -> ReactClass props
withStore store dispatch cls =
  withContext cls { redox: {store, dispatch store} }

type RedoxContext state dsl eff =
  { redox ::
    { store :: Store state
    , dispatch :: dsl -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))
    }
  }

type RedoxStoreContext state = { redox :: { store :: Store state } }

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

-- | 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 dsl eff)
-- | ```
connect'
  :: forall state state' props props' eff
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' _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
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      state <- Redox.getState store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      sid <- Redox.subscribe store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      msid <- R.readState this >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe store sid

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

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

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

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

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

-- | 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 -> dsl -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff)))
  -> ReactClass props
  -> ReactClass props
withStore store dispatch cls =
  withContext cls { redox: {store, dispatch store} }

type RedoxContext state dsl eff =
  { redox ::
    { store :: Store state
    , dispatch :: dsl -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))
    }
  }

type RedoxStoreContext state = { redox :: { store :: Store state } }

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

-- | 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 dsl eff)
-- | ```
connect'
  :: forall state state' props props' eff
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' lns cnstrProps 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
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      state <- Redox.getState store
      pure { state: view lns state, sid: Nothing }

    componentWillMount this = do
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      sid <- Redox.subscribe store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      store <- readContext (Proxy :: Proxy (RedoxStoreContext state)) this >>= pure <<< _.redox.store
      msid <- R.readState this >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe store sid

    renderFn this = do
      props' <- R.getProps this
      state <- R.readState this >>= pure <<< _.state
      pure $ R.createElement cls (cnstrProps state props') []

connect
  :: forall state state' props props'
   . Lens' state state'
  -> (state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect lns cnstProps cls = accessContext $ R.createClass $ connect' lns cnstProps cls

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