Add linebreaks to Glyph logging

Add linebreaks to Glyph logging

module Genetics.Browser.GlyphF.Log
       ( showGlyph )
       where

import Control.Monad.Free (foldFree)
import Control.Monad.Writer (Writer, execWriter, tell)
import Data.Traversable (traverse_)
import Genetics.Browser.Glyph (Glyph)
import Genetics.Browser.GlyphF (GlyphF(..))
import Prelude

glyphLogN :: GlyphF ~> Writer String
glyphLogN (Stroke c a)   = do
  tell $ "Set stroke style to " <> c <> "\n"
  pure a
glyphLogN (Fill c a)     = do
  tell $ "Set fill style to " <> c <> "\n"
  pure a
glyphLogN (Circle p r a) = do
  tell $ "Drawing circle at (" <> show p.x <> ", " <> show p.y <>
         ") with radius " <> show r <> "." <> "\n"
  pure a
glyphLogN (Line p1 p2 a) = do
  tell $ "Drawing line from (" <> show p1.x <> ", " <> show p1.y <> ") to " <>
         "(" <> show p2.x <> ", " <> show p2.y <> ")" <> "\n"
  pure a
glyphLogN (Rect p1 p2 a) = do
  tell $ "Drawing rectangle from (" <> show p1.x <> ", " <> show p1.y <> ") to " <>
         "(" <> show p2.x <> ", " <> show p2.y <> ")" <> "\n"
  pure a
glyphLogN (Path ps a) = do
  tell $ "Drawing a path:"
  traverse_ (\p -> tell ("(" <> show p.x <> ", " <> show p.y <> ")\n")) ps
  pure a

-- | Print the process of drawing a glyph to a string
showGlyph :: ∀ a. Glyph a -> String
showGlyph = execWriter <<< foldFree glyphLogN

module Genetics.Browser.GlyphF.Log
       ( showGlyph )
       where

import Control.Monad.Free (foldFree)
import Control.Monad.Writer (Writer, execWriter, tell)
import Data.Traversable (traverse_)
import Genetics.Browser.Glyph (Glyph)
import Genetics.Browser.GlyphF (GlyphF(..))
import Prelude

glyphLogN :: GlyphF ~> Writer String
glyphLogN (Stroke c a)   = do
  tell $ "Set stroke style to " <> c
  pure a
glyphLogN (Fill c a)     = do
  tell $ "Set fill style to " <> c
  pure a
glyphLogN (Circle p r a) = do
  tell $ "Drawing circle at (" <> show p.x <> ", " <> show p.y <>
         ") with radius " <> show r <> "."
  pure a
glyphLogN (Line p1 p2 a) = do
  tell $ "Drawing line from (" <> show p1.x <> ", " <> show p1.y <> ") to " <>
         "(" <> show p2.x <> ", " <> show p2.y <> ")"
  pure a
glyphLogN (Rect p1 p2 a) = do
  tell $ "Drawing rectangle from (" <> show p1.x <> ", " <> show p1.y <> ") to " <>
         "(" <> show p2.x <> ", " <> show p2.y <> ")"
  pure a
glyphLogN (Path ps a) = do
  tell $ "Drawing a path:"
  traverse_ (\p -> tell ("(" <> show p.x <> ", " <> show p.y <> ")")) ps
  pure a

-- | Print the process of drawing a glyph to a string
showGlyph :: ∀ a. Glyph a -> String
showGlyph = execWriter <<< foldFree glyphLogN


Prefer <~ for signals

Prefer <~ for signals

module Main where
import Prelude
import Control.Monad.Eff
import Control.Monad.ST
import Control.Timer (Timer())

import Signal
import Signal.DOM

import Data.Nullable
import Data.Maybe

import DOM
import DOM.HTML as H
import DOM.HTML.Document as H
import DOM.HTML.Types as H
import DOM.HTML.Window as H
import DOM.Node.Node as H
import DOM.Node.Types as H

import VirtualDOM

main :: forall e h. Eff (st :: ST h, timer :: Timer, dom :: DOM | e) Unit
main = do
  mouse <- mousePos
  runUI $ render <~ mouse
  where
  render pos =
    svg {width: "100%", height: "100%"}
        [ circle {cx: pos.x, cy: pos.y, r: 20, fill: "lime"} []
        ]

data UIState
  = Unmounted
  | Mounted H.Node VNode

runUI :: forall e. Signal VNode -> (forall h. Eff (st :: ST h, timer :: Timer, dom :: DOM | e) Unit)
runUI ui = do
  uiStateRef <- newSTRef Unmounted
  animation <- animationFrame
  runSignal $ update uiStateRef <~ sampleOn animation ui
  where
  update uiStateRef current = void do
    uiState <- readSTRef uiStateRef
    node <- mountOrPatch uiState current
    writeSTRef uiStateRef (Mounted node current)
  mountOrPatch Unmounted current = do
    node <- createElement current
    appendToBody node
    return node
  mountOrPatch (Mounted node previous) current = do
    patch node (diff previous current)
    return node

appendToBody :: forall eff. H.Node -> Eff (dom :: DOM | eff) (Maybe H.Node)
appendToBody node = do
  maybeBody <- toMaybe <$> (H.window >>= H.document >>= H.body)
  case maybeBody of
    Just body -> Just <$> (H.htmlElementToNode body # H.appendChild node)
    _         -> return Nothing

module Main where
import Prelude
import Control.Monad.Eff
import Control.Monad.ST
import Control.Timer (Timer())

import Signal
import Signal.DOM

import Data.Nullable
import Data.Maybe

import DOM
import DOM.HTML as H
import DOM.HTML.Document as H
import DOM.HTML.Types as H
import DOM.HTML.Window as H
import DOM.Node.Node as H
import DOM.Node.Types as H

import VirtualDOM

main :: forall e h. Eff (st :: ST h, timer :: Timer, dom :: DOM | e) Unit
main = do
  mouse <- mousePos
  runUI $ render <~ mouse
  where
  render pos =
    svg {width: "100%", height: "100%"}
        [ circle {cx: pos.x, cy: pos.y, r: 20, fill: "lime"} []
        ]

data UIState
  = Unmounted
  | Mounted H.Node VNode

runUI :: forall e. Signal VNode -> (forall h. Eff (st :: ST h, timer :: Timer, dom :: DOM | e) Unit)
runUI ui = do
  uiStateRef <- newSTRef Unmounted
  animation <- animationFrame
  runSignal $ update uiStateRef <$> sampleOn animation ui
  where
  update uiStateRef current = void do
    uiState <- readSTRef uiStateRef
    node <- mountOrPatch uiState current
    writeSTRef uiStateRef (Mounted node current)
  mountOrPatch Unmounted current = do
    node <- createElement current
    appendToBody node
    return node
  mountOrPatch (Mounted node previous) current = do
    patch node (diff previous current)
    return node

appendToBody :: forall eff. H.Node -> Eff (dom :: DOM | eff) (Maybe H.Node)
appendToBody node = do
  maybeBody <- toMaybe <$> (H.window >>= H.document >>= H.body)
  case maybeBody of
    Just body -> Just <$> (H.htmlElementToNode body # H.appendChild node)
    _         -> return Nothing


Remove unused import

Remove unused import

The PureScript compiler warns about unused imports as of 0.7.6.

module Control.Monad.Eff.Random where

import Prelude

import Control.Monad.Eff (Eff())
import Data.Int (toNumber, floor)

-- | The `RANDOM` effect indicates that an Eff action may access or modify the
-- | JavaScript global random number generator, i.e. `Math.random()`.
foreign import data RANDOM :: !

-- | Returns a random number between 0 (inclusive) and 1 (exclusive). This is
-- | a direct wrapper around JavaScript's `Math.random()`.
foreign import random :: forall e. Eff (random :: RANDOM | e) Number

-- | Takes a range specified by `low` (the first argument) and `high` (the
-- | second), and returns a random integer uniformly distributed in the closed
-- | interval `[low, high]`. It is unspecified what happens if `low > high`,
-- | or if either of `low` or `high` is not an integer.
-- |
-- | For example:
-- | ``` purescript
-- | randomInt 1 10 >>= Console.print
-- | ```
-- | will print a random integer between 1 and 10.
randomInt :: forall e. Int -> Int -> Eff (random :: RANDOM | e) Int
randomInt low high = do
  n <- random
  let asNumber = (toNumber high - toNumber low + one) * n + toNumber low
  return $ floor asNumber

-- | Returns a random number between a minimum value (inclusive) and a maximum
-- | value (exclusive). It is unspecified what happens if `maximum < minimum`.
-- |
-- | For example:
-- | ``` purescript
-- | randomRange 1.0 2.0 >>= Console.print
-- | ```
-- | will print a random number between 1 and 2.
randomRange :: forall e. Number -> Number -> Eff (random :: RANDOM | e) Number
randomRange min max = do
    n <- random
    return (n * (max - min) + min)

-- | Returns a random boolean value with an equal chance of being `true` or
-- | `false`.
randomBool :: forall e. Eff (random :: RANDOM | e) Boolean
randomBool = (< 0.5) <$> random

module Control.Monad.Eff.Random where

import Prelude

import Control.Monad.Eff (Eff())
import Data.Int (fromNumber, toNumber, floor)

-- | The `RANDOM` effect indicates that an Eff action may access or modify the
-- | JavaScript global random number generator, i.e. `Math.random()`.
foreign import data RANDOM :: !

-- | Returns a random number between 0 (inclusive) and 1 (exclusive). This is
-- | a direct wrapper around JavaScript's `Math.random()`.
foreign import random :: forall e. Eff (random :: RANDOM | e) Number

-- | Takes a range specified by `low` (the first argument) and `high` (the
-- | second), and returns a random integer uniformly distributed in the closed
-- | interval `[low, high]`. It is unspecified what happens if `low > high`,
-- | or if either of `low` or `high` is not an integer.
-- |
-- | For example:
-- | ``` purescript
-- | randomInt 1 10 >>= Console.print
-- | ```
-- | will print a random integer between 1 and 10.
randomInt :: forall e. Int -> Int -> Eff (random :: RANDOM | e) Int
randomInt low high = do
  n <- random
  let asNumber = (toNumber high - toNumber low + one) * n + toNumber low
  return $ floor asNumber

-- | Returns a random number between a minimum value (inclusive) and a maximum
-- | value (exclusive). It is unspecified what happens if `maximum < minimum`.
-- |
-- | For example:
-- | ``` purescript
-- | randomRange 1.0 2.0 >>= Console.print
-- | ```
-- | will print a random number between 1 and 2.
randomRange :: forall e. Number -> Number -> Eff (random :: RANDOM | e) Number
randomRange min max = do
    n <- random
    return (n * (max - min) + min)

-- | Returns a random boolean value with an equal chance of being `true` or
-- | `false`.
randomBool :: forall e. Eff (random :: RANDOM | e) Boolean
randomBool = (< 0.5) <$> random


Use `ParserT` instead of `Parser`

Use `ParserT` instead of `Parser`

-- |
-- | This module defines commonly used Parser-combinators
-- |

module Language.Docopt.Parser.Base where

import Prelude
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (get)
import Control.Monad.Trans (lift)
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 qualified Data.String.Regex as Regex
import qualified Data.Array as A
import Data.Array ((:))
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, toCharArray, fromChar)
import Data.Maybe hiding (maybe)
import Data.Either
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.MonadPlus (guard)

debug :: forall a m. (Show a, Monad m) => a -> m Unit
debug x = traceShow x $ const $ pure unit

-- | Return the current parser position
getPosition :: forall a m. (Monad m) => P.ParserT a m P.Position
getPosition = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return { input: s, result: Right pos, consumed: false, position: pos }

sof :: forall a m. (Monad m) => P.ParserT a m Unit
sof = do
  P.Position { column, line } <- getPosition
  guard $ column == 1 && line == 1

-- | Return the current parser column
getCol :: forall a m. (Monad m) => P.ParserT a m Int
getCol = do
  P.Position { column: col } <- getPosition
  return col

-- | Return the current parser row
-- | XXX: Use either `line` or `row` - not both!
getRow :: forall a m. (Monad m) => P.ParserT a m Int
getRow = do
  P.Position { line: row } <- getPosition
  return row

-- | Return the current parser row
-- | XXX: Use either `line` or `row` - not both!
getLine = getRow

tryMaybe :: forall s m a. (Monad m) => P.ParserT s m a -> P.ParserT s m (Maybe a)
tryMaybe p = (Just <$> p) <|> (pure Nothing)

-- | Return the current parser position
getInput :: forall a m. (Monad m, Show a) => P.ParserT a m a
getInput = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return { input: s, result: Right s, consumed: false, position: pos }

traceInput :: forall a m. (Show a, Monad m) => P.ParserT a m Unit
traceInput = getInput >>= debug

regex :: forall m. (Monad m) => String -> P.ParserT String m Char
regex s = P.satisfy \c ->
  Regex.test (Regex.regex s Regex.noFlags) (toString c)

lower :: forall m. (Monad m) => P.ParserT String m Char
lower = P.satisfy \c -> c == toLower c

upper :: forall m. (Monad m) => P.ParserT String m Char
upper = P.satisfy \c -> c == toUpper c

digit :: forall m. (Monad m) => P.ParserT String m Char
digit = regex "[0-9]"

alpha :: forall m. (Monad m) => P.ParserT String m Char
alpha = regex "[a-zA-Z]"

upperAlpha :: forall m. (Monad m) => P.ParserT String m Char
upperAlpha = regex "[A-Z]"

lowerAlpha :: forall m. (Monad m) => P.ParserT String m Char
lowerAlpha = regex "[a-z]"

lowerAlphaNum :: forall m. (Monad m) => P.ParserT String m Char
lowerAlphaNum = regex "[0-9a-z]"

upperAlphaNum :: forall m. (Monad m) => P.ParserT String m Char
upperAlphaNum = regex "[0-9A-Z]"

alphaNum :: forall m. (Monad m) => P.ParserT String m Char
alphaNum = alpha <|> digit

space :: forall m. (Monad m) => P.ParserT String m Char
space = P.char ' '

eol :: forall m. (Monad m) => P.ParserT String m Unit
eol = (void $ P.string "\r\n") <|> (void $ P.char '\n')

string' :: forall m. (Monad m) => String -> P.ParserT String m String
string' s = fromCharArray <$> A.foldM step [] (toCharArray s)
  where
    step acc x = do
      (acc ++) <<< A.singleton <$> P.satisfy \c -> toLower c == toLower x

-- |
-- | This module defines commonly used Parser-combinators
-- |

module Language.Docopt.Parser.Base where

import Prelude
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (get)
import Control.Monad.Trans (lift)
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 qualified Data.String.Regex as Regex
import qualified Data.Array as A
import Data.Array ((:))
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, toCharArray, fromChar)
import Data.Maybe hiding (maybe)
import Data.Either
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.MonadPlus (guard)

debug :: forall a m. (Show a, Monad m) => a -> m Unit
debug x = traceShow x $ const $ pure unit

-- | Return the current parser position
getPosition :: forall a m. (Monad m) => P.ParserT a m P.Position
getPosition = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return { input: s, result: Right pos, consumed: false, position: pos }

sof :: forall a m. (Monad m) => P.ParserT a m Unit
sof = do
  P.Position { column, line } <- getPosition
  guard $ column == 1 && line == 1

-- | Return the current parser column
getCol :: forall a m. (Monad m) => P.ParserT a m Int
getCol = do
  P.Position { column: col } <- getPosition
  return col

-- | Return the current parser row
-- | XXX: Use either `line` or `row` - not both!
getRow :: forall a m. (Monad m) => P.ParserT a m Int
getRow = do
  P.Position { line: row } <- getPosition
  return row

-- | Return the current parser row
-- | XXX: Use either `line` or `row` - not both!
getLine = getRow

tryMaybe :: forall s m a. (Monad m) => P.ParserT s m a -> P.ParserT s m (Maybe a)
tryMaybe p = (Just <$> p) <|> (pure Nothing)

-- | Return the current parser position
getInput :: forall a m. (Monad m, Show a) => P.ParserT a m a
getInput = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return { input: s, result: Right s, consumed: false, position: pos }

traceInput :: forall a m. (Show a, Monad m) => P.ParserT a m Unit
traceInput = getInput >>= debug

regex :: String -> P.Parser String Char
regex s = P.satisfy \c ->
  Regex.test (Regex.regex s Regex.noFlags) (toString c)

lower :: P.Parser String Char
lower = P.satisfy \c -> c == toLower c

upper :: P.Parser String Char
upper = P.satisfy \c -> c == toUpper c

digit :: P.Parser String Char
digit = regex "[0-9]"

alpha :: P.Parser String Char
alpha = regex "[a-zA-Z]"

upperAlpha :: P.Parser String Char
upperAlpha = regex "[A-Z]"

lowerAlpha :: P.Parser String Char
lowerAlpha = regex "[a-z]"

lowerAlphaNum :: P.Parser String Char
lowerAlphaNum = regex "[0-9a-z]"

upperAlphaNum :: P.Parser String Char
upperAlphaNum = regex "[0-9A-Z]"

alphaNum :: P.Parser String Char
alphaNum = alpha <|> digit

space :: P.Parser String Char
space = P.char ' '

eol :: P.Parser String Unit
eol = (void $ P.string "\r\n") <|> (void $ P.char '\n')

string' :: String -> P.Parser String String
string' s = fromCharArray <$> A.foldM step [] (toCharArray s)
  where
    step acc x = do
      (acc ++) <<< A.singleton <$> P.satisfy \c -> toLower c == toLower x


Passes props to performAction instead of `this`

module Thermite.Internal where

import DOM

import Data.Maybe

import Control.Monad.Eff

import Thermite.Types

foreign import getStateImpl """
  function getStateImpl(ctx) {
    return function() {
      return ctx.state;
    };
  }
  """ :: forall eff state props action. Context state props action -> Eff eff state

foreign import setStateImpl """
  function setStateImpl(ctx) {
    return function(state) {
      return function() {
        ctx.setState(state);
      };
    };
  }
  """ :: forall eff state props action. Context state props action -> state -> Eff eff Unit

foreign import textImpl """
  function textImpl(s) {
    return s;
  }
  """ :: forall action. String -> Html action

foreign import createElementImpl """
  function createElementImpl(name) {
    return function(ps) {
      return function(children) {
        var props = {};

        for (var i = 0; i < ps.length; i++) {
          var p = ps[i];
          props[p[0]] = p[1];
        }

        return React.createElement(name, props, children);
      };
    };
  }
  """ :: forall action. String -> Props action -> [Html action] -> Html action

foreign import unsafeAttribute """
  function unsafeAttribute(attr) {
    return function(value) {
      return [attr, value];
    };
  }
  """ :: forall action attr. String -> attr -> Prop action

foreign import event """
  function event(name) {
    return function(context) {
      return function(f) {
        return [name, function(e) {
          context.performAction(f(e));
        }];
      };
    };
  }
  """ :: forall state props action event. String -> Context state props action -> (event -> action) -> Prop action

foreign import createClassImpl """
  function createClassImpl(runAction) {
    return function(maybe) {
      return function(spec) {
        return React.createClass({
          getInitialState: function() {
            return spec.initialState;
          },
          performAction: function(action) {
            runAction(this)(spec.performAction(this.props)(action))();
          },
          render: function() {
            return spec.render(this)(this.state)(this.props);
          },
          componentWillMount: function() {
            var self = this;
            maybe(function() { })(function(action) {
              return function() {
                self.performAction(action);
              };
            })(spec.componentWillMount)();
          },
          displayName: maybe(undefined)(function(a) { return a; })(spec.displayName)
        })
      };
    };
  }
  """ :: forall eff m state props action. (Context state props action -> m Unit -> Eff eff Unit) ->
                                          (forall a r. r -> (a -> r) -> Maybe a -> r) ->
                                          Spec m state props action ->
                                          ComponentClass props eff

foreign import renderImpl """
  function renderImpl(component) {
    return function(props) {
      return function() {
        React.render(React.createElement(component, props), document.body);
      };
    };
  }
  """ :: forall props eff. ComponentClass props eff -> props -> Eff (dom :: DOM | eff) Unit

module Thermite.Internal where

import DOM

import Data.Maybe

import Control.Monad.Eff

import Thermite.Types

foreign import getStateImpl """
  function getStateImpl(ctx) {
    return function() {
      return ctx.state;
    };
  }
  """ :: forall eff state props action. Context state props action -> Eff eff state

foreign import setStateImpl """
  function setStateImpl(ctx) {
    return function(state) {
      return function() {
        ctx.setState(state);
      };
    };
  }
  """ :: forall eff state props action. Context state props action -> state -> Eff eff Unit

foreign import textImpl """
  function textImpl(s) {
    return s;
  }
  """ :: forall action. String -> Html action

foreign import createElementImpl """
  function createElementImpl(name) {
    return function(ps) {
      return function(children) {
        var props = {};

        for (var i = 0; i < ps.length; i++) {
          var p = ps[i];
          props[p[0]] = p[1];
        }

        return React.createElement(name, props, children);
      };
    };
  }
  """ :: forall action. String -> Props action -> [Html action] -> Html action

foreign import unsafeAttribute """
  function unsafeAttribute(attr) {
    return function(value) {
      return [attr, value];
    };
  }
  """ :: forall action attr. String -> attr -> Prop action

foreign import event """
  function event(name) {
    return function(context) {
      return function(f) {
        return [name, function(e) {
          context.performAction(f(e));
        }];
      };
    };
  }
  """ :: forall state props action event. String -> Context state props action -> (event -> action) -> Prop action

foreign import createClassImpl """
  function createClassImpl(runAction) {
    return function(maybe) {
      return function(spec) {
        return React.createClass({
          getInitialState: function() {
            return spec.initialState;
          },
          performAction: function(action) {
            runAction(this)(spec.performAction(this)(action))();
          },
          render: function() {
            return spec.render(this)(this.state)(this.props);
          },
          componentWillMount: function() {
            var self = this;
            maybe(function() { })(function(action) {
              return function() {
                self.performAction(action);
              };
            })(spec.componentWillMount)();
          },
          displayName: maybe(undefined)(function(a) { return a; })(spec.displayName)
        })
      };
    };
  }
  """ :: forall eff m state props action. (Context state props action -> m Unit -> Eff eff Unit) ->
                                          (forall a r. r -> (a -> r) -> Maybe a -> r) ->
                                          Spec m state props action ->
                                          ComponentClass props eff

foreign import renderImpl """
  function renderImpl(component) {
    return function(props) {
      return function() {
        React.render(React.createElement(component, props), document.body);
      };
    };
  }
  """ :: forall props eff. ComponentClass props eff -> props -> Eff (dom :: DOM | eff) Unit


Add mouse scroll zooming, clean up

Add mouse scroll zooming, clean up

module Genetics.Browser.Track.UI where

import Prelude

import Color.Scheme.Clrs (red)
import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (_Left, view, (^?), (^.))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Pair (Pair(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import Debug.Trace as Debug
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, demoBrowser, demoLegend, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), ChrId(..), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordInterval, CoordSys(..), Interval, RelPoint, _BrowserSize, canvasToView, findBrowserInterval, intervalToGlobal, mkCoordSys, shiftIntervalBy, zoomIntervalBy)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

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

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

-- 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 canvasEvent :: String -> CanvasElement -> Event Point

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

type BrowserView = Interval BrowserPoint

data UpdateView =
    Scroll (Ratio BigInt)
  | Zoom (Ratio BigInt)
  | NoOp

btnScroll :: forall r.
             Ratio BigInt
          -> Event UpdateView
btnScroll x = const (ScrollView x) <$> buttonEvent "scrollLeft" <|>
              const (ScrollView (negate x)) <$> buttonEvent "scrollRight"

btnZoom :: (Ratio BigInt)
        -> Event UpdateView
btnZoom m = const (ZoomView (m )) <$> buttonEvent "zoomOut" <|>
            const (ZoomView (m * (BigInt.fromInt 9 % BigInt.fromInt 100))) <$> buttonEvent "zoomIn"

btnUpdateView :: {scroll :: BrowserPoint, zoom :: Ratio BigInt } -> Event UpdateView
btnUpdateView  {scroll, zoom } = btnScroll scroll <|>
                                 btnZoom zoom <|>
                                 (const NoOp <$> buttonEvent "redraw")

scrollView :: Ratio BigInt
           -> BrowserView
           -> BrowserView
scrollView = flip shiftIntervalBy

zoomView :: Ratio BigInt
         -> BrowserView
         -> BrowserView
zoomView = flip zoomIntervalBy

normalizeView :: BrowserView
              -> BrowserView
              -> BrowserView
normalizeView (Pair lhs rhs)
              (Pair l   r  ) = Pair (max lhs l) (min r rhs)

updateViewFold :: CoordSys ChrId BrowserPoint
               -> UpdateView
               -> BrowserView
               -> BrowserView
updateViewFold cs uv iv@(Pair l r) = case uv of
  ZoomView   r -> zoomView   r iv
  ScrollView r -> scrollView r iv
  _ -> iv

browserViewEvent :: CoordSys ChrId BrowserPoint
                 -> BrowserView
                 -> Event UpdateView
                 -> Event BrowserView
browserViewEvent cs start ev =
  Event.fold
    (\a b -> (normalizeView start) (updateViewFold cs a b)) ev start

drawingEvent :: { min :: Number, max :: Number }
             -> CoordSys ChrId BrowserPoint
             -> { width :: Pixels, height :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -> Event BrowserView
             -> Event Drawing
drawingEvent s csys box dat = let dd = drawDemo csys { min: s.min, max: s.max, sig: 0.25 } box dat
                              in map dd

browserDrawEvent :: CoordSys ChrId BrowserPoint
                 -> { width :: Pixels, height :: Pixels }
                 -> { min :: Number, max :: Number, sig :: Number }
                 -- -> { vScaleWidth :: Pixels, legendWidth :: Pixels }
                 -> { gwas  :: Map ChrId (List _)
                    , annots :: Map ChrId (List _) }
                 -> Event BrowserView
                 -> Event Drawing
browserDrawEvent csys canvasSize vscale dat
  = let dd = demoBrowser csys canvasSize vscale {vScaleWidth, legendWidth} red demoLegend dat
        vScaleWidth = 40.0
        legendWidth = 100.0
    in map dd

clickEvent :: forall r. CanvasElement -> Event Pixels
clickEvent el = (_.x) <$> canvasEvent "mousedown" el

viewClick :: forall r. { width :: Pixels | r} -> Event Pixels -> Event (Ratio BigInt)
viewClick w = map (canvasToView w)

globalClick :: Event (Interval BrowserPoint) -> Event (Ratio BigInt) -> Event BrowserPoint
globalClick vs vx = (\iv r -> intervalToGlobal iv r) <$> vs <*> vx

frameClick :: CoordSys ChrId BrowserPoint
           -> Event BrowserPoint
           -> Event (Maybe (CoordInterval _ _))
frameClick csys = map (findBrowserInterval csys)

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (CoordInterval _ _))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = (map <<< map) f $ ev
  where f {chrSize, index} = Tuple index chrSize

showView :: Interval BrowserPoint -> String
showView (Pair l r) =
  "< " <>
  BigInt.toString (unwrap l) <>
  " -- " <> BigInt.toString (unwrap r) <>
  " >"

showLP :: Interval BrowserPoint -> RelPoint -> String
showLP iv p =
  "Interval: " <>
  showView iv <>
  ";\t" <>
  show p

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)

browserDrag :: forall r.
               { width :: Number | r }
            -> Event Point
            -> Event (Ratio BigInt)
browserDrag w ev = f <$> ev
  where f :: _ -> _
        f {x} = let width = BigInt.fromInt $ Int.round w.width
                    x' = BigInt.fromInt $ Int.round x
                    p = x' % width
                in Debug.trace (show p) \_ -> p

scrollViewEvent :: Event (Ratio BigInt)
                -> Event UpdateView
scrollViewEvent = map ScrollView

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoomEvent :: CanvasElement -> Event UpdateView
scrollZoomEvent el = map (ZoomView <<< f) $ canvasWheelEvent el
  where f :: Number -> Ratio BigInt
        f dY = let d' = 10000.0
                   n = BigInt.fromInt $ Int.round $ dY * d'
                   d = BigInt.fromInt $ Int.round $ 10000.0
               in n % d

main :: Eff _ _
main = launchAff 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}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let dragCanvasEv :: _
      dragCanvasEv = canvasDrag canvas

      browserDragEv :: Event (Ratio BigInt)
      browserDragEv = map negate $ browserDrag {width: w} (filterMap (_^?_Left) dragCanvasEv)

      dregs :: _
      dregs = scrollViewEvent browserDragEv

  let cs@(CoordSys s) = coordSys

      scroll :: BrowserPoint
      scroll = wrap $ BigInt.fromInt 10000000

      zoom :: Ratio BigInt
      zoom = one % (BigInt.fromInt 1000)

  updateBrowser <- liftEff $ Event.create

  let
      begin :: Interval BrowserPoint
      -- begin = Interval (BPoint $ BigInt.fromInt 652428823) (BPoint $ BigInt.fromInt 1829028329)
      -- begin = Pair (wrap $ BigInt.fromInt 652428823) s.size
      begin = Pair zero s.size

      viewEvent :: Event _
      viewEvent = browserViewEvent cs begin $
                  $  btnUpdateView {scroll, zoom}
                 <|> dregs
                 <|> const NoOp <$> updateBrowser.event
                 <|> scrollZoomEvent canvas

      click :: Event Pixels
      click = clickEvent canvas

      vClick :: Event (Ratio BigInt)
      vClick = viewClick {width: w} click

      gClick :: Event BrowserPoint
      gClick = globalClick viewEvent vClick

      fClick :: Event (Maybe _)
      fClick = frameClick cs gClick

      cClick :: Event (Maybe _)
      cClick = chrClick cs fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEvent <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

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

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sF (Just x) = "Frame: " <> show (unsafeStringify x)
               sF Nothing = "No Frame"
               sChr x = "Chr: " <> unsafeStringify x
               -- sChr (Just x) = "Chr: " <> show chr <> "\t" <> show (unwrap bp)
               -- sChr Nothing = "No Chr"

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> "
" <> "Canvas click:" <> show ev.canvasClick <> "
"
                    <> "
" <> "View click:" <> show ev.vClick <> "
"
                    <> "
" <> "Global click:" <> show (unwrap ev.gClick) <> "
"
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- do
    res <- getDataDemo { gwas: "./gwas.json"
                       , annots: "./annots_fake.json" }
    liftEff $ updateBrowser.push unit
    pure res

  let browserSize = {width: w, height: h}
      score = {min: 0.125, max: 0.42, sig: 0.25}

  let ev' = browserDrawEvent cs browserSize score dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

  liftEff $ updateBrowser.push unit

coordSys :: _
coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
            [ Tuple (ChrId "1")   (unsafePartial $ fromJust $ BigInt.fromString "195471971")
            , Tuple (ChrId "2")   (unsafePartial $ fromJust $ BigInt.fromString "182113224")
            , Tuple (ChrId "3")   (unsafePartial $ fromJust $ BigInt.fromString "160039680")
            , Tuple (ChrId "4")   (unsafePartial $ fromJust $ BigInt.fromString "156508116")
            , Tuple (ChrId "5")   (unsafePartial $ fromJust $ BigInt.fromString "151834684")
            , Tuple (ChrId "6")   (unsafePartial $ fromJust $ BigInt.fromString "149736546")
            , Tuple (ChrId "7")   (unsafePartial $ fromJust $ BigInt.fromString "145441459")
            , Tuple (ChrId "8")   (unsafePartial $ fromJust $ BigInt.fromString "129401213")
            , Tuple (ChrId "9")   (unsafePartial $ fromJust $ BigInt.fromString "124595110")
            , Tuple (ChrId "10")  (unsafePartial $ fromJust $ BigInt.fromString "130694993")
            , Tuple (ChrId "11")  (unsafePartial $ fromJust $ BigInt.fromString "122082543")
            , Tuple (ChrId "12")  (unsafePartial $ fromJust $ BigInt.fromString "120129022")
            , Tuple (ChrId "13")  (unsafePartial $ fromJust $ BigInt.fromString "120421639")
            , Tuple (ChrId "14")  (unsafePartial $ fromJust $ BigInt.fromString "124902244")
            , Tuple (ChrId "15")  (unsafePartial $ fromJust $ BigInt.fromString "104043685")
            , Tuple (ChrId "16")  (unsafePartial $ fromJust $ BigInt.fromString "98207768")
            , Tuple (ChrId "17")  (unsafePartial $ fromJust $ BigInt.fromString "94987271")
            , Tuple (ChrId "18")  (unsafePartial $ fromJust $ BigInt.fromString "90702639")
            , Tuple (ChrId "19")  (unsafePartial $ fromJust $ BigInt.fromString "61431566")
            , Tuple (ChrId "X")   (unsafePartial $ fromJust $ BigInt.fromString "17103129")
            , Tuple (ChrId "Y")   (unsafePartial $ fromJust $ BigInt.fromString "9174469")
            ]

module Genetics.Browser.Track.UI where

import Prelude

import Color.Scheme.Clrs (red)
import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (_Left, view, (^?), (^.))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Pair (Pair(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import Debug.Trace as Debug
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, demoBrowser, demoLegend, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), ChrId(..), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordInterval, CoordSys(..), Interval, RelPoint, _BrowserSize, canvasToView, findBrowserInterval, intervalToGlobal, mkCoordSys, shiftIntervalBy)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

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

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

-- 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 canvasEvent :: String -> CanvasElement -> Event Point

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

type BrowserView = Interval BrowserPoint

data UpdateView =
    Scroll BrowserPoint
  | Zoom (Ratio BigInt)
  | ScrollView (Ratio BigInt)
  | NoOp

btnScroll :: forall r.
             BrowserPoint
          -> Event UpdateView
btnScroll x = const (Scroll x) <$> buttonEvent "scrollLeft" <|>
              const (Scroll (negate x)) <$> buttonEvent "scrollRight"

btnZoom :: (Ratio BigInt)
        -> Event UpdateView
btnZoom m = const (Zoom (m )) <$> buttonEvent "zoomOut" <|>
            const (Zoom (m * (BigInt.fromInt 9 % BigInt.fromInt 100))) <$> buttonEvent "zoomIn"

btnUpdateView :: {scroll :: BrowserPoint, zoom :: Ratio BigInt } -> Event UpdateView
btnUpdateView  {scroll, zoom } = btnScroll scroll <|>
                                 btnZoom zoom <|>
                                 (const NoOp <$> buttonEvent "redraw")

scrollView :: CoordSys ChrId BrowserPoint
           -> BrowserPoint
           -> BrowserView
           -> BrowserView
scrollView cs p v = (_ - p) <$> v

scrollViewGood :: Ratio BigInt
               -> BrowserView
               -> BrowserView
scrollViewGood rat iv = iv `shiftIntervalBy` rat

-- zoomView :: BrowserPoint
--          -> Ratio BigInt
--          -> BrowserView
--          -> BrowserView
-- zoomView (BPoint size) p iv@(Interval (BPoint l) (BPoint r)) =
--   let len = r - l
--       len' = (len * (Ratio.numerator p)) / (Ratio.denominator p)
--   in (Interval (BPoint $ max zero (l + len')) (BPoint $ min size (r - len')))

normalizeView :: BrowserView
              -> BrowserView
              -> BrowserView
normalizeView (Pair lhs rhs)
              (Pair l   r) = Pair (max lhs l) (min r rhs)

updateViewFold :: CoordSys ChrId BrowserPoint
               -> UpdateView
               -> BrowserView
               -> BrowserView
-- updateViewFold _ iv = iv
updateViewFold cs uv iv@(Pair l r) = case uv of
  Scroll p  -> scrollView cs p iv
  -- Zoom r    -> zoomView ssz.size r iv
  ScrollView x -> scrollViewGood x iv
  _ -> iv

browserViewEvent :: CoordSys ChrId BrowserPoint
                 -> BrowserView
                 -> Event UpdateView
                 -> Event BrowserView
browserViewEvent cs start ev =
  Event.fold
    (\a b -> (normalizeView start) (updateViewFold cs a b)) ev start

drawingEvent :: { min :: Number, max :: Number }
             -> CoordSys ChrId BrowserPoint
             -> { width :: Pixels, height :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -> Event BrowserView
             -> Event Drawing
drawingEvent s csys box dat = let dd = drawDemo csys { min: s.min, max: s.max, sig: 0.25 } box dat
                              in map dd

browserDrawEvent :: CoordSys ChrId BrowserPoint
                 -> { width :: Pixels, height :: Pixels }
                 -> { min :: Number, max :: Number, sig :: Number }
                 -- -> { vScaleWidth :: Pixels, legendWidth :: Pixels }
                 -> { gwas  :: Map ChrId (List _)
                    , annots :: Map ChrId (List _) }
                 -> Event BrowserView
                 -> Event Drawing
browserDrawEvent csys canvasSize vscale dat
  = let dd = demoBrowser csys canvasSize vscale {vScaleWidth, legendWidth} red demoLegend dat
        vScaleWidth = 40.0
        legendWidth = 100.0
    in map dd

clickEvent :: forall r. CanvasElement -> Event Pixels
clickEvent el = (_.x) <$> canvasEvent "mousedown" el

viewClick :: forall r. { width :: Pixels | r} -> Event Pixels -> Event (Ratio BigInt)
viewClick w = map (canvasToView w)

globalClick :: Event (Interval BrowserPoint) -> Event (Ratio BigInt) -> Event BrowserPoint
globalClick vs vx = (\iv r -> intervalToGlobal iv r) <$> vs <*> vx

frameClick :: CoordSys ChrId BrowserPoint
           -> Event BrowserPoint
           -> Event (Maybe (CoordInterval _ _))
frameClick csys = map (findBrowserInterval csys)

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (CoordInterval _ _))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = (map <<< map) f $ ev
  where f {chrSize, index} = Tuple index chrSize

showView :: Interval BrowserPoint -> String
showView (Pair l r) = "< " <> BigInt.toString (unwrap l) <> " -- " <> BigInt.toString (unwrap r) <> " >"

showLP :: Interval BrowserPoint -> RelPoint -> String
showLP iv p = "Interval: " <> showView iv <> ";\t" <> show p

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)

browserDrag :: forall r.
               { width :: Number | r }
            -> Event Point
            -> Event (Ratio BigInt)
browserDrag w ev = f <$> ev
  where f :: _ -> _
        f {x} = let width = BigInt.fromInt $ Int.round w.width
                    x' = BigInt.fromInt $ Int.round x
                    p = x' % width
                in Debug.trace (show p) \_ -> p

scrollViewEvent :: Event (Ratio BigInt)
                -> Event UpdateView
scrollViewEvent = map ScrollView

main :: Eff _ _
main = launchAff 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}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let dragCanvasEv :: _
      dragCanvasEv = canvasDrag canvas

      browserDragEv :: Event (Ratio BigInt)
      browserDragEv = map negate $ browserDrag {width: w} (filterMap (_^?_Left) dragCanvasEv)

      dregs :: _
      dregs = scrollViewEvent browserDragEv

  let cs@(CoordSys s) = coordSys

      scroll :: BrowserPoint
      scroll = wrap $ BigInt.fromInt 10000000

      zoom :: Ratio BigInt
      zoom = one % (BigInt.fromInt 1000)

  updateBrowser <- liftEff $ Event.create

  let
      begin :: Interval BrowserPoint
      -- begin = Interval (BPoint $ BigInt.fromInt 652428823) (BPoint $ BigInt.fromInt 1829028329)
      -- begin = Pair (wrap $ BigInt.fromInt 652428823) s.size
      begin = Pair zero s.size

      viewEvent :: Event _
      viewEvent = browserViewEvent cs begin
                    $ btnUpdateView {scroll, zoom} <|>
                    dregs <|>
                    (const NoOp <$> updateBrowser.event)

      click :: Event Pixels
      click = clickEvent canvas

      vClick :: Event (Ratio BigInt)
      vClick = viewClick {width: w} click

      gClick :: Event BrowserPoint
      gClick = globalClick viewEvent vClick

      fClick :: Event (Maybe _)
      fClick = frameClick cs gClick

      cClick :: Event (Maybe _)
      cClick = chrClick cs fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEvent <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

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

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sF (Just x) = "Frame: " <> show (unsafeStringify x)
               sF Nothing = "No Frame"
               sChr x = "Chr: " <> unsafeStringify x
               -- sChr (Just x) = "Chr: " <> show chr <> "\t" <> show (unwrap bp)
               -- sChr Nothing = "No Chr"

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> "
" <> "Canvas click:" <> show ev.canvasClick <> "
"
                    <> "
" <> "View click:" <> show ev.vClick <> "
"
                    <> "
" <> "Global click:" <> show (unwrap ev.gClick) <> "
"
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- do
    res <- getDataDemo { gwas: "./gwas.json"
                       , annots: "./annots_fake.json" }
    liftEff $ updateBrowser.push unit
    pure res

  let browserSize = {width: w, height: h}
      score = {min: 0.125, max: 0.42, sig: 0.25}

  let ev' = browserDrawEvent cs browserSize score dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

  liftEff $ updateBrowser.push unit

coordSys :: _
coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
            [ Tuple (ChrId "1")   (unsafePartial $ fromJust $ BigInt.fromString "195471971")
            , Tuple (ChrId "2")   (unsafePartial $ fromJust $ BigInt.fromString "182113224")
            , Tuple (ChrId "3")   (unsafePartial $ fromJust $ BigInt.fromString "160039680")
            , Tuple (ChrId "4")   (unsafePartial $ fromJust $ BigInt.fromString "156508116")
            , Tuple (ChrId "5")   (unsafePartial $ fromJust $ BigInt.fromString "151834684")
            , Tuple (ChrId "6")   (unsafePartial $ fromJust $ BigInt.fromString "149736546")
            , Tuple (ChrId "7")   (unsafePartial $ fromJust $ BigInt.fromString "145441459")
            , Tuple (ChrId "8")   (unsafePartial $ fromJust $ BigInt.fromString "129401213")
            , Tuple (ChrId "9")   (unsafePartial $ fromJust $ BigInt.fromString "124595110")
            , Tuple (ChrId "10")  (unsafePartial $ fromJust $ BigInt.fromString "130694993")
            , Tuple (ChrId "11")  (unsafePartial $ fromJust $ BigInt.fromString "122082543")
            , Tuple (ChrId "12")  (unsafePartial $ fromJust $ BigInt.fromString "120129022")
            , Tuple (ChrId "13")  (unsafePartial $ fromJust $ BigInt.fromString "120421639")
            , Tuple (ChrId "14")  (unsafePartial $ fromJust $ BigInt.fromString "124902244")
            , Tuple (ChrId "15")  (unsafePartial $ fromJust $ BigInt.fromString "104043685")
            , Tuple (ChrId "16")  (unsafePartial $ fromJust $ BigInt.fromString "98207768")
            , Tuple (ChrId "17")  (unsafePartial $ fromJust $ BigInt.fromString "94987271")
            , Tuple (ChrId "18")  (unsafePartial $ fromJust $ BigInt.fromString "90702639")
            , Tuple (ChrId "19")  (unsafePartial $ fromJust $ BigInt.fromString "61431566")
            , Tuple (ChrId "X")   (unsafePartial $ fromJust $ BigInt.fromString "17103129")
            , Tuple (ChrId "Y")   (unsafePartial $ fromJust $ BigInt.fromString "9174469")
            ]


Update Sugar module

Update Sugar module

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Sugar
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Desugaring passes
--
-----------------------------------------------------------------------------

module Language.PureScript.Sugar (desugar) where

import Data.Either
import Data.Traversable (traverse)

import Control.Bind ((>=>))
import Control.Monad
import Control.Monad.Trans

import Language.PureScript.Declarations
import Language.PureScript.Errors
import Language.PureScript.Supply

{-
import Language.PureScript.Sugar.Operators
import Language.PureScript.Sugar.TypeDeclarations
import Language.PureScript.Sugar.TypeClasses
import Language.PureScript.Sugar.Names
-}

import Language.PureScript.Sugar.CaseDeclarations
import Language.PureScript.Sugar.BindingGroups
import Language.PureScript.Sugar.DoNotation

-- |
-- The desugaring pipeline proceeds as follows:
--
--  * Introduce type synonyms for type class dictionaries
--
--  * Rebracket user-defined binary operators
--
--  * Desugar do-notation using the @Prelude.Monad@ type class
--
--  * Desugar top-level case declarations into explicit case expressions
--
--  * Desugar type declarations into value declarations with explicit type annotations
--
--  * Group mutually recursive value and data declarations into binding groups.
--
--  * Qualify any unqualified names and types
--
desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
desugar = {- map removeSignedLiterals
          >>> -}
          traverse desugarDoModule
          >=> desugarCasesModule
          {-
          >=> lift . (desugarTypeDeclarationsModule
                      >=> desugarImports
                      >=> rebracket)
          >=> desugarTypeClasses
          -}
          >=>  lift <<< createBindingGroupsModule

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Sugar
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Desugaring passes
--
-----------------------------------------------------------------------------

module Language.PureScript.Sugar (desugar) where

import Data.Either

import Control.Bind ((>=>))
import Control.Monad
import Control.Monad.Trans

import Language.PureScript.Declarations
import Language.PureScript.Errors
import Language.PureScript.Supply

{-
import Language.PureScript.Sugar.Operators
import Language.PureScript.Sugar.DoNotation
import Language.PureScript.Sugar.TypeDeclarations
import Language.PureScript.Sugar.TypeClasses
import Language.PureScript.Sugar.Names
-}

import Language.PureScript.Sugar.CaseDeclarations
import Language.PureScript.Sugar.BindingGroups

-- |
-- The desugaring pipeline proceeds as follows:
--
--  * Introduce type synonyms for type class dictionaries
--
--  * Rebracket user-defined binary operators
--
--  * Desugar do-notation using the @Prelude.Monad@ type class
--
--  * Desugar top-level case declarations into explicit case expressions
--
--  * Desugar type declarations into value declarations with explicit type annotations
--
--  * Group mutually recursive value and data declarations into binding groups.
--
--  * Qualify any unqualified names and types
--
desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
desugar = {- map removeSignedLiterals
          >>> mapM desugarDoModule
          >=> -} desugarCasesModule
          {-
          >=> lift . (desugarTypeDeclarationsModule
                      >=> desugarImports
                      >=> rebracket)
          >=> desugarTypeClasses
          -}
          >=>  lift <<< createBindingGroupsModule


Updated for changes to Control.

Updated for changes to Control.

module Text.Pretty.PatternArrows where

import Prelude
import Data.Tuple (Tuple(..), uncurry)
import Data.Array
import Data.Foldable
import Data.Maybe
import Control.Arrow
import Control.Bind
import Control.Monad.Trans
import Control.Monad.State.Trans

-- |
-- A first-order pattern match
--
-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.
--
data Pattern u a b = Pattern (a -> StateT u Maybe b)

runPattern :: forall u a b. Pattern u a b -> a -> StateT u Maybe b
runPattern (Pattern f) a = f a

instance functorPattern :: Functor (Pattern u a) where
  (<$>) f (Pattern p) = Pattern $ \a -> f <$> p a

instance semigroupoidPattern :: Semigroupoid (Pattern u) where
  (<<<) (Pattern f) (Pattern g) = Pattern $ f <=< g

instance categoryPattern :: Category (Pattern u) where
  id = Pattern $ \a -> return a

instance arrowPattern :: Arrow (Pattern u) where
  arr f = Pattern $ \a -> return $ f a
  first p = Pattern $ \(Tuple b d) -> flip Tuple d <$> runPattern p b

instance arrowZeroPattern :: ArrowZero (Pattern u) where
  azero = Pattern $ \_ -> lift Nothing

instance arrowPlusPattern :: ArrowPlus (Pattern u) where
  (<+>) p q = Pattern $ \a -> StateT $ \s ->
                case runStateT (runPattern p a) s of
                  Nothing -> runStateT (runPattern q a) s
                  Just r -> Just r

-- |
-- Run a pattern with an input and initial user state
--
-- Returns Nothing if the pattern fails to match
--
pattern :: forall u a b. Pattern u a b -> u -> a -> Maybe b
pattern p u = flip evalStateT u <<< runPattern p

-- |
-- Construct a pattern from a function
--
mkPattern :: forall u a b. (a -> Maybe b) -> Pattern u a b
mkPattern f = Pattern $ \a -> lift (f a)

-- |
-- Construct a pattern from a stateful function
--
mkPattern' :: forall u a b. (a -> StateT u Maybe b) -> Pattern u a b
mkPattern' = Pattern

fix :: forall u a r. (Pattern u a r -> Pattern u a r) -> Pattern u a r
fix f = Pattern $ \a -> runPattern (f $ fix f) a

-- |
-- Construct a pattern which recursively matches on the left-hand-side
--
chainl :: forall u a r. Pattern u a (Tuple a a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> arr (uncurry f)

-- |
-- Construct a pattern which recursively matches on the right-hand side
--
chainr :: forall u a r. Pattern u a (Tuple a a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> arr (uncurry f)

-- |
-- Construct a pattern which recursively matches on one-side of a tuple
--
wrap' :: forall u a s r. Pattern u a (Tuple s a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
wrap' g f p = fix $ \c -> g >>> (id *** (c <+> p)) >>> arr (uncurry f)

-- |
-- Construct a pattern which matches a part of a tuple
--
split' :: forall u a s t r. Pattern u a (Tuple s t) -> (s -> t -> r) -> Pattern u a r
split' s f = s >>> arr (uncurry f)

-- |
-- An operator:
--
--  [@AssocL@] A left-associative operator
--
--  [@AssocR@] A right-associative operator
--
--  [@Wrap@] A prefix-like or postfix-like operator
--
--  [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand
--
class Op op where
  assocL :: forall u a r.     Pattern u a (Tuple a a) -> (r -> r -> r) -> op u a r
  assocR :: forall u a r.     Pattern u a (Tuple a a) -> (r -> r -> r) -> op u a r
  wrap   :: forall u a s r.   Pattern u a (Tuple s a) -> (s -> r -> r) -> op u a r
  split  :: forall u a s t r. Pattern u a (Tuple s t) -> (s -> t -> r) -> op u a r

data Operator u a r = Operator (forall op. (Op op) => op u a r)

-- |
-- A table of operators
--
data OperatorTable u a r = OperatorTable [[Operator u a r]]

runOperatorTable :: forall u a r. OperatorTable u a r -> [[Operator u a r]]
runOperatorTable (OperatorTable table) = table

foldl1 :: forall a. (a -> a -> a) -> [a] -> a
foldl1 f (x:xs) = foldl f x xs

-- |
-- The target data type of the "Op" language, which modifies a Pattern
--
data PatternEndo u a r = PatternEndo (Pattern u a r -> Pattern u a r)

runPatternEndo :: forall u a r. PatternEndo u a r -> Pattern u a r -> Pattern u a r
runPatternEndo (PatternEndo f) p = f p

instance opPatternEndo :: Op PatternEndo where
  assocL pat g = PatternEndo $ chainl pat g
  assocR pat g = PatternEndo $ chainr pat g
  wrap   pat g = PatternEndo $ wrap'  pat g
  split  pat g = PatternEndo $ \_ -> split' pat g

-- |
-- Convert an operator to a PatternEndo
--
toPatternEndo :: forall u a r. Operator u a r -> Pattern u a r -> Pattern u a r
toPatternEndo (Operator op) = runPatternEndo op

-- |
-- Build a pretty printer from an operator table and an indecomposable pattern
--
buildPrettyPrinter :: forall u a r. OperatorTable u a r -> Pattern u a r -> Pattern u a r
buildPrettyPrinter table p =
  let fs = map (map toPatternEndo) $ runOperatorTable table in
  foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \f -> f p' <+> p')) p $ fs

module Text.Pretty.PatternArrows where

import Prelude
import Data.Tuple (Tuple(..), uncurry)
import Data.Array
import Data.Foldable
import Data.Maybe
import Control.Arrow
import Control.Monad
import Control.Monad.Trans
import Control.Monad.State.Trans

-- |
-- A first-order pattern match
--
-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.
--
data Pattern u a b = Pattern (a -> StateT u Maybe b)

runPattern :: forall u a b. Pattern u a b -> a -> StateT u Maybe b
runPattern (Pattern f) a = f a

instance functorPattern :: Functor (Pattern u a) where
  (<$>) f (Pattern p) = Pattern $ \a -> f <$> p a

instance semigroupoidPattern :: Semigroupoid (Pattern u) where
  (<<<) (Pattern f) (Pattern g) = Pattern $ f <=< g

instance categoryPattern :: Category (Pattern u) where
  id = Pattern $ \a -> return a

instance arrowPattern :: Arrow (Pattern u) where
  arr f = Pattern $ \a -> return $ f a
  first p = Pattern $ \(Tuple b d) -> flip Tuple d <$> runPattern p b

instance arrowZeroPattern :: ArrowZero (Pattern u) where
  azero = Pattern $ \_ -> lift Nothing

instance arrowPlusPattern :: ArrowPlus (Pattern u) where
  (<+>) p q = Pattern $ \a -> StateT $ \s ->
                case runStateT (runPattern p a) s of
                  Nothing -> runStateT (runPattern q a) s
                  Just r -> Just r

-- |
-- Run a pattern with an input and initial user state
--
-- Returns Nothing if the pattern fails to match
--
pattern :: forall u a b. Pattern u a b -> u -> a -> Maybe b
pattern p u = flip evalStateT u <<< runPattern p

-- |
-- Construct a pattern from a function
--
mkPattern :: forall u a b. (a -> Maybe b) -> Pattern u a b
mkPattern f = Pattern $ \a -> lift (f a)

-- |
-- Construct a pattern from a stateful function
--
mkPattern' :: forall u a b. (a -> StateT u Maybe b) -> Pattern u a b
mkPattern' = Pattern

fix :: forall u a r. (Pattern u a r -> Pattern u a r) -> Pattern u a r
fix f = Pattern $ \a -> runPattern (f $ fix f) a

-- |
-- Construct a pattern which recursively matches on the left-hand-side
--
chainl :: forall u a r. Pattern u a (Tuple a a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> arr (uncurry f)

-- |
-- Construct a pattern which recursively matches on the right-hand side
--
chainr :: forall u a r. Pattern u a (Tuple a a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> arr (uncurry f)

-- |
-- Construct a pattern which recursively matches on one-side of a tuple
--
wrap' :: forall u a s r. Pattern u a (Tuple s a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
wrap' g f p = fix $ \c -> g >>> (id *** (c <+> p)) >>> arr (uncurry f)

-- |
-- Construct a pattern which matches a part of a tuple
--
split' :: forall u a s t r. Pattern u a (Tuple s t) -> (s -> t -> r) -> Pattern u a r
split' s f = s >>> arr (uncurry f)

-- |
-- An operator:
--
--  [@AssocL@] A left-associative operator
--
--  [@AssocR@] A right-associative operator
--
--  [@Wrap@] A prefix-like or postfix-like operator
--
--  [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand
--
class Op op where
  assocL :: forall u a r.     Pattern u a (Tuple a a) -> (r -> r -> r) -> op u a r
  assocR :: forall u a r.     Pattern u a (Tuple a a) -> (r -> r -> r) -> op u a r
  wrap   :: forall u a s r.   Pattern u a (Tuple s a) -> (s -> r -> r) -> op u a r
  split  :: forall u a s t r. Pattern u a (Tuple s t) -> (s -> t -> r) -> op u a r

data Operator u a r = Operator (forall op. (Op op) => op u a r)

-- |
-- A table of operators
--
data OperatorTable u a r = OperatorTable [[Operator u a r]]

runOperatorTable :: forall u a r. OperatorTable u a r -> [[Operator u a r]]
runOperatorTable (OperatorTable table) = table

foldl1 :: forall a. (a -> a -> a) -> [a] -> a
foldl1 f (x:xs) = foldl f x xs

-- |
-- The target data type of the "Op" language, which modifies a Pattern
--
data PatternEndo u a r = PatternEndo (Pattern u a r -> Pattern u a r)

runPatternEndo :: forall u a r. PatternEndo u a r -> Pattern u a r -> Pattern u a r
runPatternEndo (PatternEndo f) p = f p

instance opPatternEndo :: Op PatternEndo where
  assocL pat g = PatternEndo $ chainl pat g
  assocR pat g = PatternEndo $ chainr pat g
  wrap   pat g = PatternEndo $ wrap'  pat g
  split  pat g = PatternEndo $ \_ -> split' pat g

-- |
-- Convert an operator to a PatternEndo
--
toPatternEndo :: forall u a r. Operator u a r -> Pattern u a r -> Pattern u a r
toPatternEndo (Operator op) = runPatternEndo op

-- |
-- Build a pretty printer from an operator table and an indecomposable pattern
--
buildPrettyPrinter :: forall u a r. OperatorTable u a r -> Pattern u a r -> Pattern u a r
buildPrettyPrinter table p =
  let fs = map (map toPatternEndo) $ runOperatorTable table in
  foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \f -> f p' <+> p')) p $ fs


Print unexpected output

Print unexpected output

module Test.Spec.DocoptSpec (genDocoptSpec) where

import Prelude
import Debug.Trace
import Global (readFloat, readInt)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Aff (Aff(), liftEff')
import Control.Monad.Trans (lift)
import Data.List (List(..), toList, concat, last, init)
import Text.Parsing.Parser as P
import Data.Traversable (traverse)
import Data.Bifunctor (lmap)
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Map (Map(..))
import Data.Map as Map
import Data.Tuple (Tuple(..))
import Data.Either (Either(..), either)
import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
import Data.Foldable (foldl, for_, intercalate)
import Text.Wrap (dedent)
import Control.Monad.Aff (launchAff)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Data.String (fromCharArray)

import Test.Support (vliftEff, runEitherEff, prettyPrintMap)
import Test.Support.Usage  as U
import Test.Support.Docopt as D
import Test.Support.Desc   as Desc

import Language.Docopt (runDocopt)
import Language.Docopt.Value as D

import Data.List (List(..), many, some, (:), toList, concat, singleton, length
                , fromList)
import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Parser.Base
import Node.FS (FS)
import Node.Encoding (Encoding(..))
import Node.FS.Sync as FS
import Data.Identity
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Plus (empty)
import Data.Array as A

newtype Test = Test {
  doc   :: String
, kases :: Array Kase
}

newtype Kase = Kase {
  argv :: List String
, out  :: Either String (List (Tuple String D.Value))
}

parseUniversalDocoptTests :: forall eff
  . Eff (fs :: FS, err :: EXCEPTION | eff) (List Test)
parseUniversalDocoptTests = do
  f <- FS.readTextFile UTF8 "testcases.docopt"
  runEitherEff $ P.runParser f do
    many kase <* P.eof

  where
    comment = P.char '#' *> P.manyTill P.anyChar (P.char '\n')
    skipComments = void $ many comment

    kase = do
      P.skipSpaces *> skipComments *>  P.skipSpaces
      u  <- usage
      as <- A.many application
      return $ Test {
        doc: u
      , kases: as <#> \(Tuple i o) -> Kase {
          argv: i
        , out:  o
        }
      }

    application = do
      P.skipSpaces *> skipComments *>  P.skipSpaces
      P.string "$ prog"
      P.skipSpaces
      input <- flip P.sepBy (P.char ' ') do
        many (P.char ' ')
        fromCharArray <$> do
          -- Note: Terminate on '{'. This is hacky and pragmatic,
          -- but it doesn't have to be any more than that...
          A.some $ P.noneOf [ ' ', '{', '\n', '"' ]
      P.skipSpaces *> skipComments *>  P.skipSpaces
      output <- P.choice $ P.try <$>
        [ Right <$> do
            P.between (P.char '{') (P.char '}') do
              flip P.sepBy (P.char ',') do
                P.skipSpaces
                key <- P.between (P.char '"') (P.char '"') do
                        fromCharArray <$> do
                          A.many $ P.noneOf [ '"' ]
                P.skipSpaces *> P.char ':' <* P.skipSpaces
                Tuple key <$> value
          , P.string "\"user-error\""
              *> many (P.char ' ')
              *> P.optional comment
              *> return (Left "user-error")
        ]
      P.skipSpaces *> skipComments *>  P.skipSpaces
      return $ Tuple input output

      where
        value = P.choice $ P.try <$> [
          D.BoolValue <$> do
            P.choice $ P.try <$> [
              P.string "false" *> return false
            , P.string "true"  *> return true
            ]
        , D.StringValue <$> do
            fromCharArray <$> do
              P.between (P.char '"') (P.char '"') (A.many $ P.noneOf ['"'])
        , D.ArrayValue <<< fromList <$> do
            P.between (P.char '[') (P.char ']') do
              P.skipSpaces
              flip P.sepBy (P.skipSpaces *> P.char ',' *> P.skipSpaces) do
                value

          -- XXX: THIS IS WRONG (represent 'null'):
        , P.string "null" *> return (D.StringValue "null")

        , D.NumberValue <$> do
            xs  <- fromCharArray <$> A.some digit
            P.choice [
              readFloat <$> do
                xss <- do
                  P.char '.'
                  fromCharArray <$> A.some digit
                return $ xs ++ "." ++ xss
            , return $ readInt 10 xs
            ]
        ]

    usage = do
      P.string "r\"\"\""
      fromCharArray <<< fromList <$> do
        P.manyTill P.anyChar $ P.string "\"\"\"\n"

-- Somehow, purescript needs this:
_liftEff :: forall e a. Eff e a -> Aff e a
_liftEff = liftEff

genDocoptSpec = do
  tests <- _liftEff parseUniversalDocoptTests
  return $ \_ -> describe "Docopt" do
    for_ tests \(Test { doc, kases }) -> do
      describe (doc ++ "\n") do
        for_ kases \(Kase { argv, out }) -> do
          describe (intercalate " " argv) do
            it ("\n" ++ prettyPrintOut out) do
              let result = runDocopt StrMap.empty (dedent doc) (fromList argv)
              vliftEff $ case result of
                Left e ->
                  either
                    (const $ pure unit)
                    (const $ throwException $ error $ show e)
                    out
                Right r -> do
                  either
                    (\_ -> do
                      throwException $ error $
                        "Unexpected output: \n"
                          ++ prettyPrintOut (pure $ Map.toList r)
                    )
                    (\r' ->
                      let r'' = Map.toList r
                       in if (r'' /= r')
                        then throwException $ error $
                          "Unexpected output:\n"
                            ++ prettyPrintOut (pure r'')
                        else return unit)
                    out

  where
    prettyPrintOut :: Either String (List (Tuple String D.Value)) -> String
    prettyPrintOut (Left err) = "fail with " ++ show err
    prettyPrintOut (Right xs)
      = intercalate "\n" $ xs <#> \(Tuple k v) -> k ++ " => " ++ show v

module Test.Spec.DocoptSpec (genDocoptSpec) where

import Prelude
import Debug.Trace
import Global (readFloat, readInt)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Aff (Aff(), liftEff')
import Control.Monad.Trans (lift)
import Data.List (List(..), toList, concat, last, init)
import Text.Parsing.Parser as P
import Data.Traversable (traverse)
import Data.Bifunctor (lmap)
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Map (Map(..))
import Data.Map as Map
import Data.Tuple (Tuple(..))
import Data.Either (Either(..), either)
import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
import Data.Foldable (foldl, for_, intercalate)
import Text.Wrap (dedent)
import Control.Monad.Aff (launchAff)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Data.String (fromCharArray)

import Test.Support (vliftEff, runEitherEff, prettyPrintMap)
import Test.Support.Usage  as U
import Test.Support.Docopt as D
import Test.Support.Desc   as Desc

import Language.Docopt (runDocopt)
import Language.Docopt.Value as D

import Data.List (List(..), many, some, (:), toList, concat, singleton, length
                , fromList)
import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Parser.Base
import Node.FS (FS)
import Node.Encoding (Encoding(..))
import Node.FS.Sync as FS
import Data.Identity
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Plus (empty)
import Data.Array as A

newtype Test = Test {
  doc   :: String
, kases :: Array Kase
}

newtype Kase = Kase {
  argv :: List String
, out  :: Either String (List (Tuple String D.Value))
}

parseUniversalDocoptTests :: forall eff
  . Eff (fs :: FS, err :: EXCEPTION | eff) (List Test)
parseUniversalDocoptTests = do
  f <- FS.readTextFile UTF8 "testcases.docopt"
  runEitherEff $ P.runParser f do
    many kase <* P.eof

  where
    comment = P.char '#' *> P.manyTill P.anyChar (P.char '\n')
    skipComments = void $ many comment

    kase = do
      P.skipSpaces *> skipComments *>  P.skipSpaces
      u  <- usage
      as <- A.many application
      return $ Test {
        doc: u
      , kases: as <#> \(Tuple i o) -> Kase {
          argv: i
        , out:  o
        }
      }

    application = do
      P.skipSpaces *> skipComments *>  P.skipSpaces
      P.string "$ prog"
      P.skipSpaces
      input <- flip P.sepBy (P.char ' ') do
        many (P.char ' ')
        fromCharArray <$> do
          -- Note: Terminate on '{'. This is hacky and pragmatic,
          -- but it doesn't have to be any more than that...
          A.some $ P.noneOf [ ' ', '{', '\n', '"' ]
      P.skipSpaces *> skipComments *>  P.skipSpaces
      output <- P.choice $ P.try <$>
        [ Right <$> do
            P.between (P.char '{') (P.char '}') do
              flip P.sepBy (P.char ',') do
                P.skipSpaces
                key <- P.between (P.char '"') (P.char '"') do
                        fromCharArray <$> do
                          A.many $ P.noneOf [ '"' ]
                P.skipSpaces *> P.char ':' <* P.skipSpaces
                Tuple key <$> value
          , P.string "\"user-error\""
              *> many (P.char ' ')
              *> P.optional comment
              *> return (Left "user-error")
        ]
      P.skipSpaces *> skipComments *>  P.skipSpaces
      return $ Tuple input output

      where
        value = P.choice $ P.try <$> [
          D.BoolValue <$> do
            P.choice $ P.try <$> [
              P.string "false" *> return false
            , P.string "true"  *> return true
            ]
        , D.StringValue <$> do
            fromCharArray <$> do
              P.between (P.char '"') (P.char '"') (A.many $ P.noneOf ['"'])
        , D.ArrayValue <<< fromList <$> do
            P.between (P.char '[') (P.char ']') do
              P.skipSpaces
              flip P.sepBy (P.skipSpaces *> P.char ',' *> P.skipSpaces) do
                value

          -- XXX: THIS IS WRONG (represent 'null'):
        , P.string "null" *> return (D.StringValue "null")

        , D.NumberValue <$> do
            xs  <- fromCharArray <$> A.some digit
            P.choice [
              readFloat <$> do
                xss <- do
                  P.char '.'
                  fromCharArray <$> A.some digit
                return $ xs ++ "." ++ xss
            , return $ readInt 10 xs
            ]
        ]

    usage = do
      P.string "r\"\"\""
      fromCharArray <<< fromList <$> do
        P.manyTill P.anyChar $ P.string "\"\"\"\n"

-- Somehow, purescript needs this:
_liftEff :: forall e a. Eff e a -> Aff e a
_liftEff = liftEff

genDocoptSpec = do
  tests <- _liftEff parseUniversalDocoptTests
  return $ \_ -> describe "Docopt" do
    for_ tests \(Test { doc, kases }) -> do
      describe (doc ++ "\n") do
        for_ kases \(Kase { argv, out }) -> do
          describe (intercalate " " argv) do
            it ("\n" ++ prettyPrintOut out) do
              let result = runDocopt StrMap.empty (dedent doc) (fromList argv)
              vliftEff $ case result of
                Left e ->
                  either
                    (const $ pure unit)
                    (const $ throwException $ error $ show e)
                    out
                Right r -> do
                  either
                    (throwException <<< error <<< show)
                    (\r' ->
                      let r'' = Map.toList r
                       in if (r'' /= r')
                        then throwException $ error $
                          "Unexpected output:\n"
                            ++ prettyPrintOut (pure r'')
                        else return unit)
                    out

  where
    prettyPrintOut :: Either String (List (Tuple String D.Value)) -> String
    prettyPrintOut (Left err) = "fail with " ++ show err
    prettyPrintOut (Right xs)
      = intercalate "\n" $ xs <#> \(Tuple k v) -> k ++ " => " ++ show v


Testing other ways in Purescript

Testing other ways in Purescript

module Patch where

import Data.Either
import Data.Maybe
import Prelude
import Partial.Unsafe
import Data.String.Regex

newtype Path = Path String
newtype Value = Value String

data Patch =
  Add Path Value |
  Test Path Value |
  Replace Path Value |
  Move Path Path |
  Copy Path Path |
  Remove Path

isPath :: String -> Boolean
isPath x = test y x where
  y = unsafePartial
    case regex "^(\\/[a-z0-9~\\-%^|\"\\ ]*)*$" noFlags of
      Right r -> r

isValue :: forall a. a -> Boolean
isValue x = true

parsePath :: String -> Either String Path
parsePath x =
  if isPath x /= true
    then Left ("The path '" <> x <> "' is not valid")
    else Right (Path x)

parseValue :: forall a. a -> Either String a
parseValue x =
  if isValue x /= true
     then Left ("The value is not valid")
     else Right x

createPatch :: forall a. Patch -> Either String Path -> Either String a -> Either String Patch
createPatch op x y
  | isRight x && isRight y = op x y
  | otherwise = x

add :: forall a. String -> a -> Either String Patch
add path value = createPatch Add (parsePath path) (parseValue value)

testPatch :: forall a. String -> a -> Either String Patch
testPatch path value = createPatch Test (parsePath path) (parseValue value)

replace :: forall a. String -> a -> Either String Patch
replace path value = createPatch Test (parsePath path) (parseValue value)

move :: String -> String -> Either String Patch
move fromPath toPath = createPatch Test (parsePath fromPath) (parsePath toPath)

copy :: String -> String -> Either String Patch
copy fromPath toPath = createPatch Test (parsePath fromPath) (parsePath toPath)

remove :: String -> Either String Patch
remove path = createPatch Remove (parsePath path) Right Nothing

module Patch ( add, ValuePatch ) where

import Prelude
import Data.String.Regex
import Data.Maybe
import Data.Either
import Partial.Unsafe
import Data.Array

newtype ValuePatch = ValuePatch
  {
    op :: String
  , path :: String
  , value :: String
  }

newtype MovePatch = MovePatch
  {
    op :: String
  , path :: String
  , from :: String
  }

newtype RemovePatch = RemovePatch
  {
    op :: String
  , path :: String
  }

data PatchValue = Maybe | String | Number

data Patch = ValuePatch | MovePatch | RemovePatch

contains :: forall a. a -> Array -> Boolean
contains x xs = findIndex (\y -> x == y) xs

newPatch :: forall a. String -> String -> a -> Patch
newPatch op path value
  | contains op ["add", "merge"] == true = ValuePatch op path value

isPath :: String -> Boolean
isPath x = test y x where
  y = unsafePartial
    case regex "^(\\/[a-z0-9~\\-%^|\"\\ ]*)*$" noFlags of
      Right r -> r

isValue :: forall a. Maybe a -> Boolean
isValue x = true

create :: String -> String -> Maybe -> Either String Patch
create op path value
  | isPath path /= true = Left ("The path '" <> path <> "' is not valid")
  | op /= "remove" && isValue value /= true = Left ("The value '" <> value <> "' is not valid")
  | otherwise = Right (newPatch { op, path, value })

add :: String -> String -> Either String Patch
add path value = create path (Just value)

remove path = create "remove" path Nothing

instance showValuePatch :: Show ValuePatch where
  show (ValuePatch x) =
    "{ op: " <> x.op <> ", " <>
    " path: " <> x.path <> ", " <>
    " value: " <> x.value <> " }"