Correct the usage of CreateStore

Correct the usage of CreateStore

module Redux.Mini
  ( Action
  , CreateStore
  , Dispatch
  , Middleware
  , Reducer
  , ReduxReducer
  , Store
  , STORE
  , applyMiddleware
  , applyReducer
  , combineReducers
  , connect
  , createAction
  , createReducer
  , createStore
  , provider
  , reduxCreateStore
  ) where

import Prelude
import Control.Monad.Eff (kind Effect, Eff)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn3)
import Data.Maybe (Maybe(Just))
import Data.Nullable (toMaybe, Nullable)
import React (ReactClass)

foreign import data Store :: Type
foreign import data STORE :: Effect

-- Types
-- -----

-- | An Action has a "type" for Redux compatibility, and a "pureType" to hold
-- | the actual underlying algebraic data type.
newtype Action action = Action { type :: String, pureType :: action }

-- | A function that dispatches actions
type Dispatch action eff = Action action  -- ^ The action to be dispatched
  -> Eff (store :: STORE | eff) (Action action)  -- ^ The resulting effect

-- | A simple PureScript reducer
type Reducer action state = action -> state -> state

-- | A reducer wrapped for use with Redux
newtype ReduxReducer action state =
  ReduxReducer (Fn2 (Nullable state) (Action action) state)

type CreateStore action state enhancer =
  Fn3  -- ^ An uncurried function
    (ReduxReducer action state)  -- ^ The root reducer
    state  -- ^ The initial state
    (Array enhancer)  -- ^ An array of store enhancers
    Store  -- ^ The resulting store

type Middleware eff action =
  Fn3  -- ^ An uncurried function
    Store  -- ^ The current store instance
    (Dispatch action eff)  -- ^ The dispatch function
    (Action action)  -- ^ The action currently being dispatched
    (Eff (store :: STORE | eff) (Action action))  -- ^ The resulting effect

-- Interfaces
-- ----------

-- | Easily combine reducers using the underlying Redux utility
foreign import combineReducers :: forall reducers action state.
  Record reducers -> ReduxReducer action state

-- | The <Provider/> component from react-redux
foreign import provider :: ReactClass { store :: Store }

-- | The connect wrapper from react-redux.
-- | *NOTE*: The mergeProps and options arguments are not yet supported.
foreign import connect :: forall actions state ownerProps props.
  (state -> props)  -- ^ The mapStateToProps function
  -> actions  -- ^ The mapActionsToProps object
  -> ReactClass props  -- ^ The component being wrapped
  -> ReactClass ownerProps  -- ^ The resulting higher-order component

-- | The original Redux createStore function
foreign import reduxCreateStore :: forall action state enhancer.
  CreateStore action state enhancer

foreign import applyMiddleware :: forall eff action enhancer.
  Array (Middleware eff action) -> enhancer

-- Utilities
-- ---------

createStore :: forall action state enhancer.
  ReduxReducer action state  -- ^ The root reducer
  -> state  -- ^ The initial state
  -> Array enhancer  -- ^ An array of store enhancers
  -> Store  -- ^ The resulting store
createStore = runFn3 reduxCreateStore

-- | Construct a Redux reducer, which wraps the underlying action in an Action
-- | newtype that gives it a "type" property when used in JavaScript FFI
createReducer :: forall action state.
  Reducer action state -> state -> ReduxReducer action state
createReducer reducer initialState = ReduxReducer <<< mkFn2 $
  \state (Action action) ->
    case (toMaybe state) of
      (Just s) -> applyReducer reducer action.pureType s
      otherwise -> initialState

-- | Construct a pure Redux action
createAction :: forall action. action -> Action action
createAction action = Action
  { type: typeToString action, pureType: action }

-- | Apply the given action and current state to a PureScript reducer
foreign import applyReducer :: forall action state.
  Reducer action state -> action -> state -> state

-- | Transform the action's type to a string for Redux
foreign import typeToString :: forall action. action -> String

module Redux.Mini
  ( Action
  , CreateStore
  , Dispatch
  , Middleware
  , Reducer
  , ReduxReducer
  , Store
  , STORE
  , applyMiddleware
  , applyReducer
  , combineReducers
  , connect
  , createAction
  , createReducer
  , createStore
  , provider
  , reduxCreateStore
  ) where

import Prelude
import Control.Monad.Eff (kind Effect, Eff)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn3)
import Data.Maybe (Maybe(Just))
import Data.Nullable (toMaybe, Nullable)
import React (ReactClass)

foreign import data Store :: Type
foreign import data STORE :: Effect

-- Types
-- -----

-- | An Action has a "type" for Redux compatibility, and a "pureType" to hold
-- | the actual underlying algebraic data type.
newtype Action action = Action { type :: String, pureType :: action }

-- | A function that dispatches actions
type Dispatch action eff = Action action  -- ^ The action to be dispatched
  -> Eff (store :: STORE | eff) (Action action)  -- ^ The resulting effect

-- | A simple PureScript reducer
type Reducer action state = action -> state -> state

-- | A reducer wrapped for use with Redux
newtype ReduxReducer action state =
  ReduxReducer (Fn2 (Nullable state) (Action action) state)

type CreateStore action state enhancer =
  Fn3  -- ^ An uncurried function
    (ReduxReducer action state)  -- ^ The root reducer
    state  -- ^ The initial state
    (Array enhancer)  -- ^ An array of store enhancers
    Store  -- ^ The resulting store

type Middleware eff action =
  Fn3  -- ^ An uncurried function
    Store  -- ^ The current store instance
    (Dispatch action eff)  -- ^ The dispatch function
    (Action action)  -- ^ The action currently being dispatched
    (Eff (store :: STORE | eff) (Action action))  -- ^ The resulting effect

-- Interfaces
-- ----------

-- | Easily combine reducers using the underlying Redux utility
foreign import combineReducers :: forall reducers action state.
  Record reducers -> ReduxReducer action state

-- | The <Provider/> component from react-redux
foreign import provider :: ReactClass { store :: Store }

-- | The connect wrapper from react-redux.
-- | *NOTE*: The mergeProps and options arguments are not yet supported.
foreign import connect :: forall actions state ownerProps props.
  (state -> props)  -- ^ The mapStateToProps function
  -> actions  -- ^ The mapActionsToProps object
  -> ReactClass props  -- ^ The component being wrapped
  -> ReactClass ownerProps  -- ^ The resulting higher-order component

-- | The original Redux createStore function
foreign import reduxCreateStore :: forall eff action state enhancer.
  CreateStore eff action state enhancer

foreign import applyMiddleware :: forall eff action enhancer.
  Array (Middleware eff action) -> enhancer

-- Utilities
-- ---------

createStore :: forall action state enhancer.
  ReduxReducer action state  -- ^ The root reducer
  -> state  -- ^ The initial state
  -> Array enhancer  -- ^ An array of store enhancers
  -> Store  -- ^ The resulting store
createStore = runFn3 reduxCreateStore

-- | Construct a Redux reducer, which wraps the underlying action in an Action
-- | newtype that gives it a "type" property when used in JavaScript FFI
createReducer :: forall action state.
  Reducer action state -> state -> ReduxReducer action state
createReducer reducer initialState = ReduxReducer <<< mkFn2 $
  \state (Action action) ->
    case (toMaybe state) of
      (Just s) -> applyReducer reducer action.pureType s
      otherwise -> initialState

-- | Construct a pure Redux action
createAction :: forall action. action -> Action action
createAction action = Action
  { type: typeToString action, pureType: action }

-- | Apply the given action and current state to a PureScript reducer
foreign import applyReducer :: forall action state.
  Reducer action state -> action -> state -> state

-- | Transform the action's type to a string for Redux
foreign import typeToString :: forall action. action -> String


Work towards proper generator tests

Work towards proper generator tests

module Test.Spec.GeneratorSpec (generatorSpec) where

import Prelude
import Debug.Trace
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Control.Monad.Aff (liftEff')
import Control.Monad.State (State(), evalState)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.List (List(..), toList, length)
import qualified Data.Array as A

import Docopt
import Docopt.Parser.Usage (Usage(..))
import qualified Docopt.Parser.Usage as Usage
import qualified Docopt.Parser.Options as Options
import qualified Docopt.Textwrap as Textwrap
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Scanner as Scanner
import Docopt.Generate (lexArgv, mkBranchParser, runCliParser)
import Docopt.Parser.Base (debug)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)

-- short hand to create a Command
co :: String -> Argument
co = Command

-- short hand to create a Positional argument
po :: String -> Boolean -> Argument
po = Positional

-- short hand to create an Option argument
opt :: Flag
      -> Name
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
opt f name = Option (Just f) (Just name)

sopt :: Flag
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
sopt f = Option (Just f) Nothing

lopt :: Name
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
lopt name = Option Nothing (Just name)

-- short hand to create a group
gr :: Boolean -> (Array (Array Argument)) -> IsRepeatable -> Argument
gr b xs = Group b (toList $ br <$> xs)

-- short hand to create a optional group
gro :: (Array (Array Argument)) -> IsRepeatable -> Argument
gro = gr true

-- short hand to create a required group
grr :: (Array (Array Argument)) -> IsRepeatable -> Argument
grr = gr false

-- short hand to create a whole branch
br :: (Array Argument) -> Branch
br xs = Branch (toList xs)

oa :: String -> Maybe Value -> Maybe OptionArgument
oa n v = Just $ OptionArgument n v

oa_ :: String -> Maybe OptionArgument
oa_ n = Just $ OptionArgument n Nothing

generatorSpec = describe "generator" do

  -- XXX: Move this
  describe "cli lexer" do
    it "should lex cli input..." do
      vliftEff do
        res <- runEitherEff do
          lexArgv (toList [
            "-foo"
          , "-bazQUX"
          , "-baz=QUX"
          , "bar"
          , "--foobar=QUX"
          ])
        traceShowA res

  describe "generator" do
    it "should have some tests..." do

      let branch =
            [ co "foo"
            , opt 'f' "foo" (oa_ "foz") true
            , opt 'b' "bar" (oa_ "baz") true ]
      let input =
            [ "foo"
            , "-f", "fox"
            , "--bar", "baxxer"
            , "-b", "bax"
            ]
      let expected = [unit, unit, unit, unit]

      vliftEff do
        validate branch input expected

    where
      validate :: forall eff. Array Argument
                            -> Array String
                            -> Array Unit
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        res <- runEitherEff do
          toks <- lexArgv (toList argv)
          flip runCliParser (mkBranchParser (br args)) toks
        assertEqual (length res) (A.length expected)

module Test.Spec.GeneratorSpec (generatorSpec) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (liftEff')
import Control.Monad.State (State(), evalState)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.List (List(..), toList)

import Docopt
import Docopt.Parser.Usage (Usage(..))
import qualified Docopt.Parser.Usage as Usage
import qualified Docopt.Parser.Options as Options
import qualified Docopt.Textwrap as Textwrap
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Scanner as Scanner
import Docopt.Generate (lexArgv, mkBranchParser, runCliParser)
import Docopt.Parser.Base (debug)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)

-- short hand to create a Command
co :: String -> Argument
co = Command

-- short hand to create a Positional argument
po :: String -> Boolean -> Argument
po = Positional

-- short hand to create an Option argument
opt :: (Maybe Flag)
    -> (Maybe Name)
    -> (Maybe OptionArgument)
    -> IsRepeatable
    -> Argument
opt = Option

-- short hand to create a group
gr :: Boolean -> (Array (Array Argument)) -> IsRepeatable -> Argument
gr b xs = Group b (toList $ br <$> xs)

-- short hand to create a optional group
gro :: (Array (Array Argument)) -> IsRepeatable -> Argument
gro = gr true

-- short hand to create a required group
grr :: (Array (Array Argument)) -> IsRepeatable -> Argument
grr = gr false

-- short hand to create a whole branch
br :: (Array Argument) -> Branch
br xs = Branch (toList xs)

generatorSpec = describe "generator" do

  -- XXX: Move this
  describe "cli lexer" do
    it "should lex cli input..." do
      vliftEff do
        res <- runEitherEff do
          lexArgv (toList [
            "-foo"
          , "-bazQUX"
          , "-baz=QUX"
          , "bar"
          , "--foobar=QUX"
          ])
        traceShowA res

  describe "generator" do
    it "should have some tests..." do
      let branch = br [
            co "foo"
          , opt (Just 'f') (Just "foo") (Just $ OptionArgument "foz" Nothing) true
          , opt (Just 'b') (Just "bar") (Just $ OptionArgument "baz" Nothing) true
          ]
          parser = mkBranchParser branch
      vliftEff do
        res <- runEitherEff do
          toks <- lexArgv (toList [
            "foo"
          , "-f",    "fox"
          , "--bar", "baxxer"
          , "-b",    "bax"
          ])
          flip runCliParser parser toks
        traceShowA res


Pass canvas offset along to determine more accurately whether the mouse is over a square

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Types

defaultWidth    = 8
defaultHeight   = 8
layerCount      = 3
renderSize      = 60.0
renderWidth     = (toNumber defaultWidth) * renderSize
renderHeight    = (toNumber defaultHeight) * renderSize
renderDimension = { width: renderWidth, height: renderHeight }

colorSquareOne  = "#d18b47"
colorSquareTwo  = "#ffce9e"
colorPlayerOne  = "red"
colorPlayerTwo  = "white"

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          color = if ((even x) && (odd y)) || ((even y) && (odd x))
                  then colorSquareOne
                  else colorSquareTwo
          hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          piece = if hasPlayerOne
                  then Just { color: colorPlayerOne, king: false }
                  else
                    if hasPlayerTwo
                    then Just { color: colorPlayerTwo, king: false }
                    else Nothing
      return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Int -> Int -> Int -> State
createState width height layers = { grid: (createGrid width height layers), currentPlayer: 1 }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Tuple Number Number -> Square -> Number -> Number -> Boolean
isOnSquare (Tuple ox oy) square x y =
  (square.rx + ox) < x && x < (square.rx + ox) + renderSize &&
  (square.ry + oy) < y && y < (square.ry + oy) + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e. Tuple Number Number -> Context2D -> Maybe DOMEvent -> Unit -> Square -> Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare offset ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare offset square (toNumber ux) (toNumber uy) of
              true -> do
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

render :: forall s e. Tuple Number Number -> Context2D -> STRef s State -> Maybe DOMEvent -> Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render offset ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare offset ctx event) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize - 0.5,
                     h: (toNumber state.grid.height) * renderSize - 0.5 }
  return unit

renderPage offset st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render offset ctx st event
      return unit
    _ -> return unit
  return unit

main = do
  st <- newSTRef (createState defaultWidth defaultHeight layerCount)
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      addMouseEventListener MouseMoveEvent (\e -> renderPage offset st (Just e)) canvas
      renderPage offset st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Types

defaultWidth    = 8
defaultHeight   = 8
layerCount      = 3
renderSize      = 60.0
renderWidth     = (toNumber defaultWidth) * renderSize
renderHeight    = (toNumber defaultHeight) * renderSize
renderDimension = { width: renderWidth, height: renderHeight }

colorSquareOne  = "#d18b47"
colorSquareTwo  = "#ffce9e"
colorPlayerOne  = "red"
colorPlayerTwo  = "white"

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          color = if ((even x) && (odd y)) || ((even y) && (odd x))
                  then colorSquareOne
                  else colorSquareTwo
          hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          piece = if hasPlayerOne
                  then Just { color: colorPlayerOne, king: false }
                  else
                    if hasPlayerTwo
                    then Just { color: colorPlayerTwo, king: false }
                    else Nothing
      return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Int -> Int -> Int -> State
createState width height layers = { grid: (createGrid width height layers), currentPlayer: 1 }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  square.rx < x && x < square.rx + renderSize &&
  square.ry < y && y < square.ry + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e. Context2D -> Maybe DOMEvent -> Unit -> Square -> Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare square (toNumber ux) (toNumber uy) of
              true -> do
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

render :: forall s e. Context2D -> STRef s State -> Maybe DOMEvent -> Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize - 0.5,
                     h: (toNumber state.grid.height) * renderSize - 0.5 }
  return unit

renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main = do
  st <- newSTRef (createState defaultWidth defaultHeight layerCount)
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


fix page reloading and save button behaviour

module Components.BooksDirectory (booksDirectory) where

import Common.Data.BooksDirectoryInfo (BooksDirectoryInfo(BooksDirectoryInfo), booksDirectoryInfoId, defaultBooksDirectoryInfo)
import Common.OneDriveApi (ItemReference(..), OneDriveItem(..), getOneDriveItem)
import Common.React (maybeProps, mapProps)
import Components.AjaxLoader.AjaxLoader as AjaxLoader
import Components.ChooseDirectoryModal as ChooseDirectoryModal
import Components.OneDriveFileTree as FileTree
import Components.Wrappers.Button as Button
import Components.Wrappers.ControlLabel as ControlLabel
import Components.Wrappers.FormControl as FormControl
import Components.Wrappers.FormGroup as FormGroup
import Control.Coroutine (cotransform)
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Maybe.Trans (runMaybeT)
import Control.Monad.Trans (lift)
import Control.Error.Util (hoistMaybe)
import Data.Foldable (fold)
import Data.Lens (LensP, over, lens, PrismP, prism', set, _Just, (^.))
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.String as S
import Data.Tuple (Tuple(..))
import Libs.PouchDB (POUCHDB, PouchDB, PouchDBAff)
import Libs.PouchDB.Json (tryGetJson, putJson)
import Network.HTTP.Affjax (AJAX)
import Prelude
import React (ReactElement, ReactClass, createElement, createClass, transformState, getProps) as R
import React.DOM (text, form) as R
import React.DOM.Props (action) as RP
import Thermite as T

type Props =
  { onedriveToken :: String
  , db :: Maybe PouchDB
  }

type State =
  { booksDir :: Maybe DirectoryInfo
  , readDir :: Maybe DirectoryInfo
  , stateLoaded :: Boolean
  , booksModal :: ChooseDirectoryModal.State
  , readModal :: ChooseDirectoryModal.State
  }

booksDir :: LensP State (Maybe DirectoryInfo)
booksDir =
  lens _.booksDir (_ { booksDir = _ })

readDir :: LensP State (Maybe DirectoryInfo)
readDir =
  lens _.readDir (_ { readDir = _ })

stateLoaded :: LensP State Boolean
stateLoaded =
  lens _.stateLoaded (_ { stateLoaded = _ })

booksModal :: LensP State ChooseDirectoryModal.State
booksModal =
  lens _.booksModal (_ { booksModal = _ })

readModal :: LensP State ChooseDirectoryModal.State
readModal =
  lens _.readModal (_ { readModal = _ })

type DirectoryInfo =
  { itemId :: Maybe String
  , path :: String
  }

itemId_ :: LensP DirectoryInfo (Maybe String)
itemId_ =
  lens _.itemId (_ { itemId = _ })

defaultState :: State
defaultState =
  { stateLoaded: false
  , booksDir: Nothing
  , readDir: Nothing
  , booksModal: ChooseDirectoryModal.defaultState
  , readModal: ChooseDirectoryModal.defaultState
  }

data Action
  = BooksModalAction ChooseDirectoryModal.Action
  | ReadModalAction ChooseDirectoryModal.Action
  | Save

booksModalAction :: PrismP Action ChooseDirectoryModal.Action
booksModalAction =
  prism' BooksModalAction getModal
  where
    getModal (BooksModalAction x) = Just x
    getModal _ = Nothing

readModalAction :: PrismP Action ChooseDirectoryModal.Action
readModalAction =
  prism' ReadModalAction getModel
  where
    getModel (ReadModalAction x) = Just x
    getModel _ = Nothing

spec :: forall eff. T.Spec (ajax :: AJAX, pouchdb :: POUCHDB, err :: EXCEPTION | eff) State Props Action
spec =
  fold
  [ T.withState $ \st ->
                    if not st.stateLoaded
                    then
                      AjaxLoader.spec
                    else
                      wrapForm $ booksDirectoryGroup <> readDirectoryGroup <> saveButton
  , T.simpleSpec performAction T.defaultRender
  , mapProps tryGetChooseDirectoryModalProps $ maybeProps $ T.focus booksModal booksModalAction ChooseDirectoryModal.spec
  , mapProps tryGetChooseDirectoryModalProps $ maybeProps $ T.focus readModal readModalAction ChooseDirectoryModal.spec
  ]
  where
    booksDirectoryGroup =
      wrapFormGroup (Just "booksDirectory") $ T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ s _ =
          [ ControlLabel.controlLabel {} [ R.text "Books directory" ]
          , renderDirectoryInfo "Books directory placeholder" s.booksDir
          , Button.button { bsStyle: "link", onClick: dispatch (BooksModalAction ChooseDirectoryModal.ShowModal) } [ R.text "Choose directory" ]
          ]

    readDirectoryGroup =
      wrapFormGroup (Just "readDirectory") $ T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ s _ =
          [ ControlLabel.controlLabel {} [ R.text "Read directory" ]
          , renderDirectoryInfo "Read directory placeholder" s.readDir
          , Button.button { bsStyle: "link", onClick: dispatch (ReadModalAction ChooseDirectoryModal.ShowModal) } [ R.text "Choose directory" ]
          ]

    saveButton =
      T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ _ _ =
          [ Button.button { type: "submit", onClick: dispatch Save } [ R.text "Save" ] ]

    performAction Save props state =
      void $ runMaybeT $ do
        db <- hoistMaybe props.db
        let
          booksItemId =
            state ^. (booksDir <<< _Just <<< itemId_)
          readItemId =
            state ^. (readDir <<< _Just <<< itemId_)
        lift $ lift $ updateBooksDirectoryIfNeeded db booksItemId readItemId
    performAction (BooksModalAction (ChooseDirectoryModal.FileTreeAction action)) props _ =
      case FileTree.unwrapChildAction action of
        Tuple itemId FileTree.SelectDirectory ->
          updateItemId props booksDir itemId
        _ ->
          pure unit
    performAction (ReadModalAction (ChooseDirectoryModal.FileTreeAction action)) props _ =
      case FileTree.unwrapChildAction action of
        Tuple itemId FileTree.SelectDirectory ->
          updateItemId props readDir itemId
        _ ->
          pure unit
    performAction _ _ _ =
      pure unit

    updateItemId props dirSetter itemId = do
      void $ cotransform $ set dirSetter Nothing <<< set stateLoaded false
      dir <- lift $ getDirectoryInfo props.onedriveToken itemId
      void $ cotransform $ set dirSetter (Just dir) <<< set stateLoaded true

    tryGetChooseDirectoryModalProps p = do
      db <- p.db
      pure { onedriveToken: p.onedriveToken
           , db
           }

    renderDirectoryInfo placeholder maybeDirInfo =
      FormControl.formControlStatic {} [ R.text (maybe placeholder _.path maybeDirInfo) ]

wrapForm :: forall eff state props action. T.Spec eff state props action -> T.Spec eff state props action
wrapForm =
  over T._render wrapRender
  where
    wrapRender origRender dispatch p s c =
      [ R.form
        [ RP.action "#" ]
        (origRender dispatch p s c)
      ]

wrapFormGroup :: forall eff state props action. Maybe String -> T.Spec eff state props action -> T.Spec eff state props action
wrapFormGroup controlId =
  over T._render wrapRender
  where
    wrapRender origRender dispatch p s c =
      let
        fg =
          maybe (FormGroup.formGroup {}) (\c -> FormGroup.formGroup { controlId: c }) controlId
      in
        [ fg $ origRender dispatch p s c ]

reactClass :: R.ReactClass Props
reactClass =
  R.createClass reactSpec.spec { componentDidMount = componentDidMount }
  where
    reactSpec =
      T.createReactSpec spec defaultState

    componentDidMount this = void $ launchAff $ do
      props <- liftEff $ R.getProps this
      void $ runMaybeT $ do
        db <- hoistMaybe props.db
        BooksDirectoryInfo info <- lift $ getBooksDirectoryInfo db
        dir1 <- lift $ getDirectoryInfo props.onedriveToken info.booksItemId
        dir2 <- lift $ getDirectoryInfo props.onedriveToken info.readItemId
        liftEff $ R.transformState this (_ { booksDir = Just dir1, readDir = Just dir2, stateLoaded = true })

booksDirectory :: Props -> R.ReactElement
booksDirectory props =
  R.createElement reactClass props []

getDirectoryInfo :: forall e. String -> Maybe String -> Aff (ajax :: AJAX | e) DirectoryInfo
getDirectoryInfo token itemId = do
  item <- getItem <$> getOneDriveItem token itemId
  let parentPath = fromMaybe "" (getPath <$> item.parentReference)
  pure { itemId
       , path : parentPath <> "/" <> item.name
       }
  where
    getItem (OneDriveItem item) = item
    getPath (ItemReference reference) =
      let
        idx = S.indexOf ":" reference.path
      in
       maybe reference.path (\i -> S.drop (i + 1) reference.path) idx

getBooksDirectoryInfo :: forall e. PouchDB -> PouchDBAff e BooksDirectoryInfo
getBooksDirectoryInfo db =
  fromMaybe defaultBooksDirectoryInfo <$> tryGetJson db booksDirectoryInfoId

updateBooksDirectoryIfNeeded :: forall e. PouchDB -> Maybe String -> Maybe String -> PouchDBAff e Unit
updateBooksDirectoryIfNeeded db booksItemId readItemId = do
  BooksDirectoryInfo current <- getBooksDirectoryInfo db
  when (current.booksItemId /= booksItemId || current.readItemId /= readItemId) $
    putJson db $ BooksDirectoryInfo current { booksItemId = booksItemId
                                            , readItemId = readItemId
                                            }

module Components.BooksDirectory (booksDirectory) where

import Common.Data.BooksDirectoryInfo (BooksDirectoryInfo(BooksDirectoryInfo), booksDirectoryInfoId, defaultBooksDirectoryInfo)
import Common.OneDriveApi (ItemReference(..), OneDriveItem(..), getOneDriveItem)
import Common.React (maybeProps, mapProps)
import Components.AjaxLoader.AjaxLoader as AjaxLoader
import Components.ChooseDirectoryModal as ChooseDirectoryModal
import Components.OneDriveFileTree as FileTree
import Components.Wrappers.Button as Button
import Components.Wrappers.ControlLabel as ControlLabel
import Components.Wrappers.FormControl as FormControl
import Components.Wrappers.FormGroup as FormGroup
import Control.Coroutine (cotransform)
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Maybe.Trans (runMaybeT)
import Control.Monad.Trans (lift)
import Control.Error.Util (hoistMaybe)
import Data.Foldable (fold)
import Data.Lens (LensP, over, lens, PrismP, prism', set, _Just, (^.))
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.String as S
import Data.Tuple (Tuple(..))
import Libs.PouchDB (POUCHDB, PouchDB, PouchDBAff)
import Libs.PouchDB.Json (tryGetJson, putJson)
import Network.HTTP.Affjax (AJAX)
import Prelude
import React (ReactElement, ReactClass, createElement, createClass, transformState, getProps) as R
import React.DOM (text, form) as R
import Thermite as T

type Props =
  { onedriveToken :: String
  , db :: Maybe PouchDB
  }

type State =
  { booksDir :: Maybe DirectoryInfo
  , readDir :: Maybe DirectoryInfo
  , stateLoaded :: Boolean
  , booksModal :: ChooseDirectoryModal.State
  , readModal :: ChooseDirectoryModal.State
  }

booksDir :: LensP State (Maybe DirectoryInfo)
booksDir =
  lens _.booksDir (_ { booksDir = _ })

readDir :: LensP State (Maybe DirectoryInfo)
readDir =
  lens _.readDir (_ { readDir = _ })

stateLoaded :: LensP State Boolean
stateLoaded =
  lens _.stateLoaded (_ { stateLoaded = _ })

booksModal :: LensP State ChooseDirectoryModal.State
booksModal =
  lens _.booksModal (_ { booksModal = _ })

readModal :: LensP State ChooseDirectoryModal.State
readModal =
  lens _.readModal (_ { readModal = _ })

type DirectoryInfo =
  { itemId :: Maybe String
  , path :: String
  }

itemId_ :: LensP DirectoryInfo (Maybe String)
itemId_ =
  lens _.itemId (_ { itemId = _ })

defaultState :: State
defaultState =
  { stateLoaded: false
  , booksDir: Nothing
  , readDir: Nothing
  , booksModal: ChooseDirectoryModal.defaultState
  , readModal: ChooseDirectoryModal.defaultState
  }

data Action
  = BooksModalAction ChooseDirectoryModal.Action
  | ReadModalAction ChooseDirectoryModal.Action
  | Save

booksModalAction :: PrismP Action ChooseDirectoryModal.Action
booksModalAction =
  prism' BooksModalAction getModal
  where
    getModal (BooksModalAction x) = Just x
    getModal _ = Nothing

readModalAction :: PrismP Action ChooseDirectoryModal.Action
readModalAction =
  prism' ReadModalAction getModel
  where
    getModel (ReadModalAction x) = Just x
    getModel _ = Nothing

spec :: forall eff. T.Spec (ajax :: AJAX, pouchdb :: POUCHDB, err :: EXCEPTION | eff) State Props Action
spec =
  fold
  [ T.withState $ \st ->
                    if not st.stateLoaded
                    then
                      AjaxLoader.spec
                    else
                      wrapForm $ booksDirectoryGroup <> readDirectoryGroup <> saveButton
  , T.simpleSpec performAction T.defaultRender
  , mapProps tryGetChooseDirectoryModalProps $ maybeProps $ T.focus booksModal booksModalAction ChooseDirectoryModal.spec
  , mapProps tryGetChooseDirectoryModalProps $ maybeProps $ T.focus readModal readModalAction ChooseDirectoryModal.spec
  ]
  where
    booksDirectoryGroup =
      wrapFormGroup (Just "booksDirectory") $ T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ s _ =
          [ ControlLabel.controlLabel {} [ R.text "Books directory" ]
          , renderDirectoryInfo "Books directory placeholder" s.booksDir
          , Button.button { bsStyle: "link", onClick: dispatch (BooksModalAction ChooseDirectoryModal.ShowModal) } [ R.text "Choose directory" ]
          ]

    readDirectoryGroup =
      wrapFormGroup (Just "readDirectory") $ T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ s _ =
          [ ControlLabel.controlLabel {} [ R.text "Read directory" ]
          , renderDirectoryInfo "Read directory placeholder" s.readDir
          , Button.button { bsStyle: "link", onClick: dispatch (ReadModalAction ChooseDirectoryModal.ShowModal) } [ R.text "Choose directory" ]
          ]

    saveButton =
      T.simpleSpec T.defaultPerformAction render
      where
        render dispatch _ _ _ =
          [ Button.button { type: "submit", onClick: dispatch Save } [ R.text "Save" ] ]

    performAction Save props state =
      void $ runMaybeT $ do
        db <- hoistMaybe props.db
        let
          booksItemId =
            state ^. (booksDir <<< _Just <<< itemId_)
          readItemId =
            state ^. (readDir <<< _Just <<< itemId_)
        lift $ lift $ updateBooksDirectoryIfNeeded db booksItemId readItemId
    performAction (BooksModalAction (ChooseDirectoryModal.FileTreeAction action)) props _ =
      case FileTree.unwrapChildAction action of
        Tuple itemId FileTree.SelectDirectory ->
          updateItemId props booksDir itemId
        _ ->
          pure unit
    performAction (ReadModalAction (ChooseDirectoryModal.FileTreeAction action)) props _ =
      case FileTree.unwrapChildAction action of
        Tuple itemId FileTree.SelectDirectory ->
          updateItemId props readDir itemId
        _ ->
          pure unit
    performAction _ _ _ =
      pure unit

    updateItemId props dirSetter itemId = do
      void $ cotransform $ set dirSetter Nothing <<< set stateLoaded false
      dir <- lift $ getDirectoryInfo props.onedriveToken itemId
      void $ cotransform $ set dirSetter (Just dir) <<< set stateLoaded true

    tryGetChooseDirectoryModalProps p = do
      db <- p.db
      pure { onedriveToken: p.onedriveToken
           , db
           }

    renderDirectoryInfo placeholder maybeDirInfo =
      FormControl.formControlStatic {} [ R.text (maybe placeholder _.path maybeDirInfo) ]

wrapForm :: forall eff state props action. T.Spec eff state props action -> T.Spec eff state props action
wrapForm =
  over T._render wrapRender
  where
    wrapRender origRender dispatch p s c =
      [ R.form
        [ ]
        (origRender dispatch p s c)
      ]

wrapFormGroup :: forall eff state props action. Maybe String -> T.Spec eff state props action -> T.Spec eff state props action
wrapFormGroup controlId =
  over T._render wrapRender
  where
    wrapRender origRender dispatch p s c =
      let
        fg =
          maybe (FormGroup.formGroup {}) (\c -> FormGroup.formGroup { controlId: c }) controlId
      in
        [ fg $ origRender dispatch p s c ]

reactClass :: R.ReactClass Props
reactClass =
  R.createClass reactSpec.spec { componentDidMount = componentDidMount }
  where
    reactSpec =
      T.createReactSpec spec defaultState

    componentDidMount this = void $ launchAff $ do
      props <- liftEff $ R.getProps this
      void $ runMaybeT $ do
        db <- hoistMaybe props.db
        BooksDirectoryInfo info <- lift $ getBooksDirectoryInfo db
        dir1 <- lift $ getDirectoryInfo props.onedriveToken info.booksItemId
        dir2 <- lift $ getDirectoryInfo props.onedriveToken info.readItemId
        liftEff $ R.transformState this (_ { booksDir = Just dir1, readDir = Just dir2, stateLoaded = true })

booksDirectory :: Props -> R.ReactElement
booksDirectory props =
  R.createElement reactClass props []

getDirectoryInfo :: forall e. String -> Maybe String -> Aff (ajax :: AJAX | e) DirectoryInfo
getDirectoryInfo token itemId = do
  item <- getItem <$> getOneDriveItem token itemId
  let parentPath = fromMaybe "" (getPath <$> item.parentReference)
  pure { itemId
       , path : parentPath <> "/" <> item.name
       }
  where
    getItem (OneDriveItem item) = item
    getPath (ItemReference reference) =
      let
        idx = S.indexOf ":" reference.path
      in
       maybe reference.path (\i -> S.drop (i + 1) reference.path) idx

getBooksDirectoryInfo :: forall e. PouchDB -> PouchDBAff e BooksDirectoryInfo
getBooksDirectoryInfo db =
  fromMaybe defaultBooksDirectoryInfo <$> tryGetJson db booksDirectoryInfoId

updateBooksDirectoryIfNeeded :: forall e. PouchDB -> Maybe String -> Maybe String -> PouchDBAff e Unit
updateBooksDirectoryIfNeeded db booksItemId readItemId = do
  BooksDirectoryInfo current <- getBooksDirectoryInfo db
  when (current.booksItemId /= booksItemId || current.readItemId /= readItemId) $
    putJson db $ BooksDirectoryInfo current { booksItemId = booksItemId
                                            , readItemId = readItemId
                                            }


Add glue for drawing pipeline

Add glue for drawing pipeline

module Genetics.Browser.TruTrack where

import Prelude

import Color (Color)
import Control.Monad.Aff (Aff, launchAff)
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.Error.Class (class MonadError, throwError)
import Control.Monad.Reader (class MonadReader, Reader, ReaderT(..), ask, runReader, runReaderT)
import Control.MonadPlus (guard)
import Data.Array ((:))
import Data.Array as Array
import Data.Distributive (distribute)
import Data.Either (Either, Either(..))
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, for_, length, maximum, minimum, sum)
import Data.List (List(..), mapMaybe)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isJust)
import Data.Monoid (mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap)
import Data.NonEmpty (foldl1, fromNonEmpty)
import Data.NonEmpty as NE
import Data.Ord.Max (Max(..))
import Data.Record as Record
import Data.Record.Unsafe (unsafeSet)
import Data.Symbol (SProxy(..))
import Data.Traversable (class Traversable, scanl, traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Data.Unfoldable (unfoldr)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, Pos, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat, readInt)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Graphics.Drawing (Drawing, circle, fillColor, filled, outlineColor, outlined, translate)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Text.Parsing.CSV as CSV
import Text.Parsing.Parser as CSV
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type ChrFrames r a = ChrCtx (frame :: Frame a | r)

chrIdsEq :: forall a b.
            Map ChrId a
         -> Map ChrId b
         -> Boolean
chrIdsEq a b = (Map.keys a) == (Map.keys b)

chrIdsSub :: forall a b.
             Map ChrId a
          -> Map ChrId b
          -> Boolean
chrIdsSub a b = setA `Map.isSubmap` setB
  where setA = map (const unit) a
        setB = map (const unit) b

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.
type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx

        let r = 1.0
            x = (unwrap $ f.pos / size) - r
            y = (f.score - min / max - min) - r
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill
        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

                  , point :: a -> Normalized Point
                  }

-- A single Frame that contains all data that is required to draw it
type ReadyFrame r a = { width :: Pixels
                      , padding :: Pixels
                      , height :: Pixels
                      , frame :: Frame (Array a) | r}

drawFrame :: forall a r.
             PureRenderer a
          -> ReadyFrame r a
          -> Drawing
drawFrame r {width, padding, height, frame} = foldMap draw' frame.contents
  where draw' a = case r a of
          Nothing -> mempty
          Just {drawing, point} ->
            let {x,y} = nPointToFrame (width - padding * 2.0) height $ point
            in translate (x + padding) y drawing

-- Draw a collection of ReadyFrames, lined up one after another
drawFrames :: forall a r.
              Array (ReadyFrame r a)
           -> PureRenderer a
           -> Drawing
drawFrames frames r = fold drawings
  where os = framesOffsets frames
        drawings = Array.zipWith (\o -> translate o 0.0) os
                     $ map (drawFrame r) frames

renderFrames :: forall f a r.
                Foldable f
             => Filterable f
             => f ChrId
             -> Map ChrId (ReadyFrame r a)
             -> PureRenderer a
             -> Context2D
             -> Eff _ Unit
renderFrames ids chrFs r ctx = Drawing.render ctx drawing
  where drawing = drawFrames fs r
        fs = Array.fromFoldable $ filterMap (\chrId -> Map.lookup chrId chrFs) ids

framesOffsets :: forall f r.
                 Traversable f
              => f { width :: Pixels | r }
              -> f Pixels
framesOffsets fs = scanl (\o {width} -> width + o) 0.0 fs

addOffsets :: forall k r.
              Ord k
           => Map k { width :: Pixels | r }
           -> Map k { width :: Pixels, offset :: Pixels | r }
addOffsets fs = zipMapsWith (unsafeSet "offset") os fs
  where os = framesOffsets fs

-- We simply throw away existing width, offset, height data if it exists
fitFrames :: forall f a r.
             Foldable f
          => Pixels
          -> f { size :: Bp | r }
          -> f { width :: Pixels
               , offset :: Pixels | r }
fitFrames totalWidth fs = unsafeCoerce unit
  where totalSize = alaF Additive foldMap _.size fs
        w size = unwrap $ size / totalSize

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

createFrames :: forall r a.
                RowLacks "frame" (size :: Bp | r)
             => Pixels
             -> Pixels
             -> Map ChrId {size :: Bp | r}
             -> Map ChrId a
             -> Map ChrId { size :: Bp, frame :: Frame a | r }
createFrames totalWidth padding sizes as = zipMapsWith zippy sizes as
  where ts = totalSize sizes
        mkWidth size = (unwrap $ size / ts) * totalWidth
        mkFrame' {size} a = { padding, width: mkWidth size, contents: a }
        zippy r a = insertFrame (mkFrame' r a) r

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

groupToChrs :: forall r.
               List { chrId :: ChrId | r }
            -> Map ChrId (List { chrId :: ChrId | r })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ singleton x
        add x (Just xs) = Just $ Cons x xs

chrFrames :: forall a.
             Pixels
          -> Pixels
          -> Map ChrId a
          -> Map ChrId { size :: Bp
                       , frame :: { padding :: Pixels
                                  , width :: Pixels
                                  , contents :: a
                                  }
                       }
chrFrames w p as = createFrames w p chrCtx' as
  where chrCtx' = Map.filterKeys (\k -> k `Map.member` as) mouseChrCtx

addHeight :: forall a r.
             Pixels
          -> Map ChrId { size :: Bp
                       , frame :: { padding :: Pixels
                                  , width :: Pixels
                                  , contents :: a
                                  }
                       | r
                       }
          -> Map ChrId { size :: Bp
                       , frame :: (ReadyFrame a)
                       | r }
addHeight h fs = map f fs
  where f entry = entry { frame = Record.insert (SProxy :: SProxy "height") h entry.frame }
  csv <- _.response <$> Affjax.get url
  let parsed :: _
      parsed = CSV.runParser csv CSV.defaultParsers.fileHeaded
      parseEntry :: Map String String -> Maybe _
      parseEntry m = do
        chrId <- ChrId <$> Map.lookup "chr" m
        pos <- Bp <<< readFloat <$> Map.lookup "ps" m
        score <- readFloat <$> Map.lookup "af" m
        pure { chrId, pos, score }

  case parsed of
    Left err -> throwError $ error "error parsing csv"
    Right p  -> pure $ mapMaybe parseEntry p

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs

module Genetics.Browser.TruTrack where

import Prelude

import Color (Color)
import Control.Monad.Aff (Aff, launchAff)
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.Error.Class (class MonadError, throwError)
import Control.Monad.Reader (class MonadReader, Reader, ReaderT(..), ask, runReader, runReaderT)
import Control.MonadPlus (guard)
import Data.Array ((:))
import Data.Array as Array
import Data.Distributive (distribute)
import Data.Either (Either, Either(..))
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, for_, length, maximum, minimum, sum)
import Data.List (List(..), mapMaybe)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isJust)
import Data.Monoid (mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap)
import Data.NonEmpty (foldl1, fromNonEmpty)
import Data.NonEmpty as NE
import Data.Ord.Max (Max(..))
import Data.Record as Record
import Data.Record.Unsafe (unsafeSet)
import Data.Symbol (SProxy(..))
import Data.Traversable (class Traversable, scanl, traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Data.Unfoldable (unfoldr)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, Pos, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat, readInt)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Graphics.Drawing (Drawing, circle, fillColor, filled, outlineColor, outlined, translate)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Text.Parsing.CSV as CSV
import Text.Parsing.Parser as CSV
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type ChrFrames r a = ChrCtx (frame :: Frame a | r)

chrIdsEq :: forall a b.
            Map ChrId a
         -> Map ChrId b
         -> Boolean
chrIdsEq a b = (Map.keys a) == (Map.keys b)

chrIdsSub :: forall a b.
             Map ChrId a
          -> Map ChrId b
          -> Boolean
chrIdsSub a b = setA `Map.isSubmap` setB
  where setA = map (const unit) a
        setB = map (const unit) b

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

newtype Normalized a = Normalized a

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.
type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx

        let r = 1.0
            x = (unwrap $ f.pos / size) - r
            y = (f.score - min / max - min) - r
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill
        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

                  , point :: a -> Normalized Point
                  }

-- A single Frame that contains all data that is required to draw it
type ReadyFrame r a = { width :: Pixels
                      , padding :: Pixels
                      , height :: Pixels
                      , frame :: Frame (Array a) | r}

drawFrame :: forall a r.
             PureRenderer a
          -> ReadyFrame r a
          -> Drawing
drawFrame r {width, padding, height, frame} = foldMap draw' frame.contents
  where draw' a = case r a of
          Nothing -> mempty
          Just {drawing, point} ->
            let {x,y} = nPointToFrame (width - padding * 2.0) height $ point
            in translate (x + padding) y drawing

-- Draw a collection of ReadyFrames, lined up one after another
drawFrames :: forall a r.
              Array (ReadyFrame r a)
           -> PureRenderer a
           -> Drawing
drawFrames frames r = fold drawings
  where os = framesOffsets frames
        drawings = Array.zipWith (\o -> translate o 0.0) os
                     $ map (drawFrame r) frames

renderFrames :: forall f a r.
                Foldable f
             => Filterable f
             => f ChrId
             -> Map ChrId (ReadyFrame r a)
             -> PureRenderer a
             -> Context2D
             -> Eff _ Unit
renderFrames ids chrFs r ctx = Drawing.render ctx drawing
  where drawing = drawFrames fs r
        fs = Array.fromFoldable $ filterMap (\chrId -> Map.lookup chrId chrFs) ids

framesOffsets :: forall f r.
                 Traversable f
              => f { width :: Pixels | r }
              -> f Pixels
framesOffsets fs = scanl (\o {width} -> width + o) 0.0 fs

addOffsets :: forall k r.
              Ord k
           => Map k { width :: Pixels | r }
           -> Map k { width :: Pixels, offset :: Pixels | r }
addOffsets fs = zipMapsWith (unsafeSet "offset") os fs
  where os = framesOffsets fs

-- We simply throw away existing width, offset, height data if it exists
fitFrames :: forall f a r.
             Foldable f
          => Pixels
          -> f { size :: Bp | r }
          -> f { width :: Pixels
               , offset :: Pixels | r }
fitFrames totalWidth fs = unsafeCoerce unit
  where totalSize = alaF Additive foldMap _.size fs
        w size = unwrap $ size / totalSize

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

mkFrame :: forall r a.
            RowLacks "frame" (size :: Bp | r)
         => Pixels
         -> (Bp -> Pixels)
         -> {size :: Bp | r}
         -> a
         -> {size :: Bp, frame :: Frame a | r}
mkFrame padding getWidth chr a = chr'
  where chr' :: {size :: Bp, frame :: Frame a | r}
        chr' = insertFrame frame chr
        frame :: Frame a
        frame = { padding, width: getWidth chr.size, contents: a }

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

chrSubrange :: forall a r.
               Range r
            -> Map ChrId a
            -> Map ChrId a
chrSubrange {lHand, rHand} = Map.submap (Just lHand.chrId) (Just rHand.chrId)

fetchGemma :: String
           -> Aff _ (List { chrId :: ChrId, pos :: Bp, score :: Number })
fetchGemma url = do
  liftEff $ log "fetching gwas"
  csv <- _.response <$> Affjax.get url
  let parsed :: _
      parsed = CSV.runParser csv CSV.defaultParsers.fileHeaded
      parseEntry :: Map String String -> Maybe _
      parseEntry m = do
        chrId <- ChrId <$> Map.lookup "chr" m
        pos <- Bp <<< readFloat <$> Map.lookup "ps" m
        score <- readFloat <$> Map.lookup "af" m
        pure { chrId, pos, score }

  case parsed of
    Left err -> throwError $ error "error parsing csv"
    Right p  -> pure $ mapMaybe parseEntry p

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs


Start implementing solver

Start implementing solver

-- | 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)
import Data.List (List(..), filter, head, foldM, concat, (:))
import Data.Traversable (traverse)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Monoid (mempty)

import Docopt (Argument(..), Application(..), Branch(..))
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"

findOptionDesc :: List D.Desc -> U.Argument -> Maybe D.Desc
findOptionDesc _ (U.Command _)      = Nothing
findOptionDesc _ (U.Positional _ _) = Nothing
findOptionDesc _ (U.Option n _ _)   = head $ filter matches ds
  where matches (D.Option _ (Just (D.LongOption n' _)) _) | (n == n') = true
        matches _                                                     = false
findOptionDesc ds arg = head $ filter matches ds
  where matches d = false

solveArg :: U.Argument -> List D.Desc -> Either SolveError Argument
solveArg (U.Command s) _       = return (Command s)
solveArg (U.Positional s r) _  = return (Positional s r)
solveArg o@(U.Option s a r) ds = do
  let ref = findOptionDesc ds o
  Left SolveError

solveArg (U.Group o bs r) ds  = 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 b ds = Left SolveError

solveUsage :: U.Usage -> List D.Desc -> Either SolveError Application
solveUsage u ds = Left SolveError

solve :: (List U.Usage)
      -> (List D.Desc)
      -> Either SolveError (List Application)
solve us ds = Left SolveError

-- | 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)
import Data.List (List(..), filter, head, foldM)
import Data.Traversable (traverse)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Monoid (mempty)

import Docopt (Argument(..), Application(..), Branch(..))
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"

-- | Given a Argument and an Option, unify them into a single Docopt
--   specification Argument.
unify :: U.Argument -> D.Desc -> Argument
unify (U.Option _ _ _) (D.Option _ _ _)
  -- XXX: Actually write this:
  = Option (Just 'f') Nothing Nothing true

solve :: (List U.Usage)
      -> (List D.Desc)
      -> Either SolveError (List Application)
solve us os = do
  Left SolveError


Leave note for later

Leave note for later

module Docopt.Parser.Usage where

import Prelude
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Data.List (List(..), many, some, (:), toList)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.Either
import Data.Maybe
import Docopt.Parser.Base
import Docopt.Parser.Common
import Docopt.Parser.Lexer

type OptionAlias    = String
type OptionArgument = String
type IsOptional     = Boolean
type IsRepeatable   = Boolean

data UsageNode
  = Command     String
  | Positional  String
                IsRepeatable
  | Option      (Maybe String)
                (Maybe Char)
                (Maybe OptionArgument)
                IsRepeatable
  | Group       IsOptional
                (List UsageNode)
                IsRepeatable

instance showUsageNode :: Show UsageNode where
  show (Command n) =
    "Command " ++ n
  show (Positional n b) =
    "Positional " ++ n ++ " " ++ show b
  show (Option n a arg b) =
    "Option " ++ show n ++ " " ++ show a ++ " " ++ show arg ++ " " ++ show b
  show (Group n b o) =
    "Group " ++ show n ++ " " ++ show b ++ " " ++ show o

-- | Parse the usage section
parseUsage :: TokenParser Unit
parseUsage = do
  P.Position { column: col } <- getPosition
  program <- parseProgram
  elems <- mark do
    -- XXX: This needs more thought
    P.manyTill
      (indented *> parseElem)
      (parseProgram)
  debug elems
  debug program

  where
    parseProgram :: TokenParser String
    parseProgram = name

    parseElem :: TokenParser UsageNode
    parseElem = defer \_ ->
          (indented *> parsePositional)
      <|> (indented *> parseCommand)
      <|> (indented *> parseGroup)

    parsePositional :: TokenParser UsageNode
    parsePositional = Positional
      <$> (angleName <|> shoutName)
      <*> parseRepetition

    parseCommand :: TokenParser UsageNode
    parseCommand = Command <$> name

    parseGroup :: TokenParser UsageNode
    parseGroup = defer \_ ->
          parseReqGroup
      <|> parseOptGroup

    parseOptGroup :: TokenParser UsageNode
    parseOptGroup = defer \_ -> Group
      <$> (indented *> pure true)
      <*> (indented *> P.between lsquare rsquare (some parseElem))
      <*> (indented *> parseRepetition)

    parseReqGroup :: TokenParser UsageNode
    parseReqGroup = defer \_ -> Group
      <$> (indented *> pure false)
      <*> (indented *> P.between lparen rparen (some parseElem))
      <*> (indented *> parseRepetition)

    parseRepetition :: TokenParser Boolean
    parseRepetition = (P.try tripleDot *> pure true) <|> pure false

module Docopt.Parser.Usage where

import Prelude
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Data.List (List(..), many, some, (:), toList)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.Either
import Data.Maybe
import Docopt.Parser.Base
import Docopt.Parser.Common
import Docopt.Parser.Lexer

type OptionAlias    = String
type OptionArgument = String
type IsOptional     = Boolean
type IsRepeatable   = Boolean

data UsageNode
  = Command     String
  | Positional  String
                IsRepeatable
  | Option      (Maybe String)
                (Maybe Char)
                (Maybe OptionArgument)
                IsRepeatable
  | Group       IsOptional
                (List UsageNode)
                IsRepeatable

instance showUsageNode :: Show UsageNode where
  show (Command n) =
    "Command " ++ n
  show (Positional n b) =
    "Positional " ++ n ++ " " ++ show b
  show (Option n a arg b) =
    "Option " ++ show n ++ " " ++ show a ++ " " ++ show arg ++ " " ++ show b
  show (Group n b o) =
    "Group " ++ show n ++ " " ++ show b ++ " " ++ show o

-- | Parse the usage section
parseUsage :: TokenParser Unit
parseUsage = do
  P.Position { column: col } <- getPosition
  program <- parseProgram
  elems <- mark do
    P.manyTill
      (indented *> parseElem)
      (parseProgram)
  debug elems
  debug program

  where
    parseProgram :: TokenParser String
    parseProgram = name

    parseElem :: TokenParser UsageNode
    parseElem = defer \_ ->
          (indented *> parsePositional)
      <|> (indented *> parseCommand)
      <|> (indented *> parseGroup)

    parsePositional :: TokenParser UsageNode
    parsePositional = Positional
      <$> (angleName <|> shoutName)
      <*> parseRepetition

    parseCommand :: TokenParser UsageNode
    parseCommand = Command <$> name

    parseGroup :: TokenParser UsageNode
    parseGroup = defer \_ ->
          parseReqGroup
      <|> parseOptGroup

    parseOptGroup :: TokenParser UsageNode
    parseOptGroup = defer \_ -> Group
      <$> (indented *> pure true)
      <*> (indented *> P.between lsquare rsquare (some parseElem))
      <*> (indented *> parseRepetition)

    parseReqGroup :: TokenParser UsageNode
    parseReqGroup = defer \_ -> Group
      <$> (indented *> pure false)
      <*> (indented *> P.between lparen rparen (some parseElem))
      <*> (indented *> parseRepetition)

    parseRepetition :: TokenParser Boolean
    parseRepetition = (P.try tripleDot *> pure true) <|> pure false


Data.Record -> Record

Data.Record -> Record

module Test.QuickCheck.Arbitrary
  ( class Arbitrary
  , arbitrary
  , class Coarbitrary
  , coarbitrary
  , genericArbitrary
  , genericCoarbitrary
  , class ArbitraryGenericSum
  , arbitraryGenericSum
  , class ArbitraryRowList
  , arbitraryRecord
  ) where

import Prelude

import Control.Monad.Gen.Class (chooseBool)
import Control.Monad.Gen.Common as MGC
import Control.Monad.ST as ST
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Array.ST (pushSTArray, unsafeFreeze, unsafeThaw)
import Data.Char (toCharCode, fromCharCode)
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Generic.Rep (class Generic, to, from, NoArguments(..), Sum(..), Product(..), Constructor(..), Argument(..))
import Data.Identity (Identity(..))
import Data.Int (toNumber)
import Data.Lazy (Lazy, defer, force)
import Data.List (List)
import Data.List.NonEmpty (NonEmptyList(..))
import Data.Maybe (Maybe(..), fromJust)
import Data.Newtype (wrap)
import Data.NonEmpty (NonEmpty(..), (:|))
import Record as Record
import Data.String (charCodeAt, fromCharArray, split)
import Data.String.NonEmpty (NonEmptyString)
import Data.String.NonEmpty as NES
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)
import Prim.Row as Row
import Prim.RowList as RL
import Test.QuickCheck.Gen (Gen, arrayOf, chooseInt, elements, listOf, oneOf, perturbGen, repeatable, sized, uniform)
import Type.Data.RowList (RLProxy(..))

-- | The `Arbitrary` class represents those types whose values can be
-- | _randomly-generated_.
-- |
-- | `arbitrary` uses the `Gen` monad to express a random generator for
-- | the type `t`. Combinators in the `Test.QuickCheck.Gen`
-- | module can be used to construct random generators.
class Arbitrary t where
  arbitrary :: Gen t

-- | The `Coarbitrary` class represents types which appear on the left of
-- | an `Arbitrary` function arrow.
-- |
-- | To construct an `Arbitrary` instance for the type `a -> b`, we need to
-- | use the input of type `a` to _perturb_ a random generator for `b`. This
-- | is the role of the `coarbitrary` function.
-- |
-- | `Coarbitrary` instances can be written using the `perturbGen` function.
class Coarbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = chooseBool

instance coarbBoolean :: Coarbitrary Boolean where
  coarbitrary true = perturbGen 1.0
  coarbitrary false = perturbGen 2.0

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: Coarbitrary Number where
  coarbitrary = perturbGen

instance arbInt :: Arbitrary Int where
  arbitrary = chooseInt (-1000000) 1000000

instance coarbInt :: Coarbitrary Int where
  coarbitrary = perturbGen <<< toNumber

instance arbString :: Arbitrary String where
  arbitrary = fromCharArray <$> arbitrary

instance coarbString :: Coarbitrary String where
  coarbitrary s = coarbitrary $ (charCodeAt zero <$> split (wrap "") s)

instance arbNonEmptyString :: Arbitrary NonEmptyString where
  arbitrary = NES.cons <$> arbitrary <*> arbitrary

instance coarbNonEmptyString :: Coarbitrary NonEmptyString where
  coarbitrary = coarbitrary <<< NES.toString

instance arbChar :: Arbitrary Char where
  arbitrary = fromCharCode <$> chooseInt 0 65536

instance coarbChar :: Coarbitrary Char where
  coarbitrary c = coarbitrary $ toCharCode c

instance arbUnit :: Arbitrary Unit where
  arbitrary = pure unit

instance coarbUnit :: Coarbitrary Unit where
  coarbitrary _ = perturbGen 1.0

instance arbOrdering :: Arbitrary Ordering where
  arbitrary = elements $ LT :| [EQ, GT]

instance coarbOrdering :: Coarbitrary Ordering where
  coarbitrary LT = perturbGen 1.0
  coarbitrary EQ = perturbGen 2.0
  coarbitrary GT = perturbGen 3.0

instance arbArray :: Arbitrary a => Arbitrary (Array a) where
  arbitrary = arrayOf arbitrary

instance coarbArray :: Coarbitrary a => Coarbitrary (Array a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbNonEmptyArray :: Arbitrary a => Arbitrary (NonEmptyArray a) where
  arbitrary = do
     x <- arbitrary
     xs <- arbitrary
     pure $ unsafePartial fromJust $ NEA.fromArray $ ST.run do
        mxs <- unsafeThaw xs
        _ <- pushSTArray mxs x
        unsafeFreeze mxs

instance coarbNonEmptyArray :: Coarbitrary a => Coarbitrary (NonEmptyArray a) where
  coarbitrary = coarbitrary <<< NEA.toArray

instance arbFunction :: (Coarbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

instance coarbFunction :: (Arbitrary a, Coarbitrary b) => Coarbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f (xs :: Array a)) gen

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = Tuple <$> arbitrary <*> arbitrary

instance coarbTuple :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Tuple a b) where
  coarbitrary (Tuple a b) = coarbitrary a >>> coarbitrary b

instance arbMaybe :: Arbitrary a => Arbitrary (Maybe a) where
  arbitrary = MGC.genMaybe arbitrary

instance coarbMaybe :: Coarbitrary a => Coarbitrary (Maybe a) where
  coarbitrary Nothing = perturbGen 1.0
  coarbitrary (Just a) = coarbitrary a

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = MGC.genEither arbitrary arbitrary

instance coarbEither :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Either a b) where
  coarbitrary (Left a)  = coarbitrary a
  coarbitrary (Right b) = coarbitrary b

instance arbitraryList :: Arbitrary a => Arbitrary (List a) where
  arbitrary = sized \n -> chooseInt zero n >>= flip listOf arbitrary

instance coarbList :: Coarbitrary a => Coarbitrary (List a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbitraryIdentity :: Arbitrary a => Arbitrary (Identity a) where
  arbitrary = Identity <$> arbitrary

instance coarbIdentity :: Coarbitrary a => Coarbitrary (Identity a) where
  coarbitrary (Identity a) = coarbitrary a

instance arbitraryLazy :: Arbitrary a => Arbitrary (Lazy a) where
  arbitrary = arbitrary >>= pure <<< defer <<< const

instance coarbLazy :: Coarbitrary a => Coarbitrary (Lazy a) where
  coarbitrary a = coarbitrary (force a)

instance arbNonEmpty :: (Arbitrary (f a), Arbitrary a) => Arbitrary (NonEmpty f a) where
  arbitrary = NonEmpty <$> arbitrary <*> arbitrary

instance coarbNonEmpty :: (Coarbitrary (f a), Coarbitrary a) => Coarbitrary (NonEmpty f a) where
  coarbitrary (NonEmpty head tail) = coarbitrary head >>> coarbitrary tail

instance arbNonEmptyList :: Arbitrary a => Arbitrary (NonEmptyList a) where
  arbitrary = NonEmptyList <$> arbitrary

instance coarbNonEmptyList :: Coarbitrary a => Coarbitrary (NonEmptyList a) where
  coarbitrary (NonEmptyList nel) = coarbitrary nel

instance arbitraryNoArguments :: Arbitrary NoArguments where
  arbitrary = pure NoArguments

instance coarbitraryNoArguments :: Coarbitrary NoArguments where
  coarbitrary NoArguments = identity

-- | To be able to evenly distribute over chains of Sum types we build up
-- | a collection of generators and choose between.  Each right component
-- | of a Sum is either a Constructor or another Sum.
class ArbitraryGenericSum t where
  arbitraryGenericSum :: Array (Gen t)

instance arbGenSumSum :: (Arbitrary l, ArbitraryGenericSum r) => ArbitraryGenericSum (Sum l r) where
  arbitraryGenericSum = [Inl <$> arbitrary] <> (map Inr <$> arbitraryGenericSum)

instance arbGenSumConstructor :: Arbitrary a => ArbitraryGenericSum (Constructor s a) where
  arbitraryGenericSum = [arbitrary]

instance arbitrarySum :: (Arbitrary l, ArbitraryGenericSum r) => Arbitrary (Sum l r) where
  arbitrary = oneOf $ (Inl <$> arbitrary) :| (map Inr <$> arbitraryGenericSum)

instance coarbitrarySum :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Sum l r) where
  coarbitrary (Inl l) = coarbitrary l
  coarbitrary (Inr r) = coarbitrary r

instance arbitraryProduct :: (Arbitrary l, Arbitrary r) => Arbitrary (Product l r) where
  arbitrary = Product <$> arbitrary <*> arbitrary

instance coarbitraryProduct :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Product l r) where
  coarbitrary (Product a b) = coarbitrary a >>> coarbitrary b

instance arbitraryConstructor :: Arbitrary a => Arbitrary (Constructor s a) where
  arbitrary = Constructor <$> arbitrary

instance coarbitraryConstructor :: Coarbitrary a => Coarbitrary (Constructor s a) where
  coarbitrary (Constructor a) = coarbitrary a

instance arbitraryArgument :: Arbitrary a => Arbitrary (Argument a) where
  arbitrary = Argument <$> arbitrary

instance coarbitraryArgument :: Coarbitrary a => Coarbitrary (Argument a) where
  coarbitrary (Argument a) = coarbitrary a

-- | A `Generic` implementation of the `arbitrary` member from the `Arbitrary` type class.
genericArbitrary :: forall a rep. Generic a rep => Arbitrary rep => Gen a
genericArbitrary = to <$> (arbitrary :: Gen rep)

-- | A `Generic` implementation of the `coarbitrary` member from the `Coarbitrary` type class.
genericCoarbitrary :: forall a rep. Generic a rep => Coarbitrary rep => a -> Gen a -> Gen a
genericCoarbitrary x g = to <$> coarbitrary (from x) (from <$> g)

-- | A helper typeclass to implement `Arbitrary` for records.
class ArbitraryRowList list row | list -> row where
  arbitraryRecord :: RLProxy list -> Gen (Record row)

instance arbitraryRowListNil :: ArbitraryRowList RL.Nil () where
  arbitraryRecord _ = pure {}

instance arbitraryRowListCons ::
  ( Arbitrary a
  , ArbitraryRowList listRest rowRest
  , Row.Lacks key rowRest
  , Row.Cons key a rowRest rowFull
  , RL.RowToList rowFull (RL.Cons key a listRest)
  , IsSymbol key
  ) => ArbitraryRowList (RL.Cons key a listRest) rowFull where
  arbitraryRecord _ = do
     value <- arbitrary
     previous <- arbitraryRecord (RLProxy :: RLProxy listRest)
     pure $ Record.insert (SProxy :: SProxy key) value previous

instance arbitraryRecordInstance ::
  ( RL.RowToList row list
  , ArbitraryRowList list row
  ) => Arbitrary (Record row) where
  arbitrary = arbitraryRecord (RLProxy :: RLProxy list)

module Test.QuickCheck.Arbitrary
  ( class Arbitrary
  , arbitrary
  , class Coarbitrary
  , coarbitrary
  , genericArbitrary
  , genericCoarbitrary
  , class ArbitraryGenericSum
  , arbitraryGenericSum
  , class ArbitraryRowList
  , arbitraryRecord
  ) where

import Prelude

import Control.Monad.Gen.Class (chooseBool)
import Control.Monad.Gen.Common as MGC
import Control.Monad.ST as ST
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Array.ST (pushSTArray, unsafeFreeze, unsafeThaw)
import Data.Char (toCharCode, fromCharCode)
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Generic.Rep (class Generic, to, from, NoArguments(..), Sum(..), Product(..), Constructor(..), Argument(..))
import Data.Identity (Identity(..))
import Data.Int (toNumber)
import Data.Lazy (Lazy, defer, force)
import Data.List (List)
import Data.List.NonEmpty (NonEmptyList(..))
import Data.Maybe (Maybe(..), fromJust)
import Data.Newtype (wrap)
import Data.NonEmpty (NonEmpty(..), (:|))
import Data.Record as Record
import Data.String (charCodeAt, fromCharArray, split)
import Data.String.NonEmpty (NonEmptyString)
import Data.String.NonEmpty as NES
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)
import Prim.Row as Row
import Prim.RowList as RL
import Test.QuickCheck.Gen (Gen, arrayOf, chooseInt, elements, listOf, oneOf, perturbGen, repeatable, sized, uniform)
import Type.Data.RowList (RLProxy(..))

-- | The `Arbitrary` class represents those types whose values can be
-- | _randomly-generated_.
-- |
-- | `arbitrary` uses the `Gen` monad to express a random generator for
-- | the type `t`. Combinators in the `Test.QuickCheck.Gen`
-- | module can be used to construct random generators.
class Arbitrary t where
  arbitrary :: Gen t

-- | The `Coarbitrary` class represents types which appear on the left of
-- | an `Arbitrary` function arrow.
-- |
-- | To construct an `Arbitrary` instance for the type `a -> b`, we need to
-- | use the input of type `a` to _perturb_ a random generator for `b`. This
-- | is the role of the `coarbitrary` function.
-- |
-- | `Coarbitrary` instances can be written using the `perturbGen` function.
class Coarbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = chooseBool

instance coarbBoolean :: Coarbitrary Boolean where
  coarbitrary true = perturbGen 1.0
  coarbitrary false = perturbGen 2.0

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: Coarbitrary Number where
  coarbitrary = perturbGen

instance arbInt :: Arbitrary Int where
  arbitrary = chooseInt (-1000000) 1000000

instance coarbInt :: Coarbitrary Int where
  coarbitrary = perturbGen <<< toNumber

instance arbString :: Arbitrary String where
  arbitrary = fromCharArray <$> arbitrary

instance coarbString :: Coarbitrary String where
  coarbitrary s = coarbitrary $ (charCodeAt zero <$> split (wrap "") s)

instance arbNonEmptyString :: Arbitrary NonEmptyString where
  arbitrary = NES.cons <$> arbitrary <*> arbitrary

instance coarbNonEmptyString :: Coarbitrary NonEmptyString where
  coarbitrary = coarbitrary <<< NES.toString

instance arbChar :: Arbitrary Char where
  arbitrary = fromCharCode <$> chooseInt 0 65536

instance coarbChar :: Coarbitrary Char where
  coarbitrary c = coarbitrary $ toCharCode c

instance arbUnit :: Arbitrary Unit where
  arbitrary = pure unit

instance coarbUnit :: Coarbitrary Unit where
  coarbitrary _ = perturbGen 1.0

instance arbOrdering :: Arbitrary Ordering where
  arbitrary = elements $ LT :| [EQ, GT]

instance coarbOrdering :: Coarbitrary Ordering where
  coarbitrary LT = perturbGen 1.0
  coarbitrary EQ = perturbGen 2.0
  coarbitrary GT = perturbGen 3.0

instance arbArray :: Arbitrary a => Arbitrary (Array a) where
  arbitrary = arrayOf arbitrary

instance coarbArray :: Coarbitrary a => Coarbitrary (Array a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbNonEmptyArray :: Arbitrary a => Arbitrary (NonEmptyArray a) where
  arbitrary = do
     x <- arbitrary
     xs <- arbitrary
     pure $ unsafePartial fromJust $ NEA.fromArray $ ST.run do
        mxs <- unsafeThaw xs
        _ <- pushSTArray mxs x
        unsafeFreeze mxs

instance coarbNonEmptyArray :: Coarbitrary a => Coarbitrary (NonEmptyArray a) where
  coarbitrary = coarbitrary <<< NEA.toArray

instance arbFunction :: (Coarbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

instance coarbFunction :: (Arbitrary a, Coarbitrary b) => Coarbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f (xs :: Array a)) gen

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = Tuple <$> arbitrary <*> arbitrary

instance coarbTuple :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Tuple a b) where
  coarbitrary (Tuple a b) = coarbitrary a >>> coarbitrary b

instance arbMaybe :: Arbitrary a => Arbitrary (Maybe a) where
  arbitrary = MGC.genMaybe arbitrary

instance coarbMaybe :: Coarbitrary a => Coarbitrary (Maybe a) where
  coarbitrary Nothing = perturbGen 1.0
  coarbitrary (Just a) = coarbitrary a

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = MGC.genEither arbitrary arbitrary

instance coarbEither :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Either a b) where
  coarbitrary (Left a)  = coarbitrary a
  coarbitrary (Right b) = coarbitrary b

instance arbitraryList :: Arbitrary a => Arbitrary (List a) where
  arbitrary = sized \n -> chooseInt zero n >>= flip listOf arbitrary

instance coarbList :: Coarbitrary a => Coarbitrary (List a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbitraryIdentity :: Arbitrary a => Arbitrary (Identity a) where
  arbitrary = Identity <$> arbitrary

instance coarbIdentity :: Coarbitrary a => Coarbitrary (Identity a) where
  coarbitrary (Identity a) = coarbitrary a

instance arbitraryLazy :: Arbitrary a => Arbitrary (Lazy a) where
  arbitrary = arbitrary >>= pure <<< defer <<< const

instance coarbLazy :: Coarbitrary a => Coarbitrary (Lazy a) where
  coarbitrary a = coarbitrary (force a)

instance arbNonEmpty :: (Arbitrary (f a), Arbitrary a) => Arbitrary (NonEmpty f a) where
  arbitrary = NonEmpty <$> arbitrary <*> arbitrary

instance coarbNonEmpty :: (Coarbitrary (f a), Coarbitrary a) => Coarbitrary (NonEmpty f a) where
  coarbitrary (NonEmpty head tail) = coarbitrary head >>> coarbitrary tail

instance arbNonEmptyList :: Arbitrary a => Arbitrary (NonEmptyList a) where
  arbitrary = NonEmptyList <$> arbitrary

instance coarbNonEmptyList :: Coarbitrary a => Coarbitrary (NonEmptyList a) where
  coarbitrary (NonEmptyList nel) = coarbitrary nel

instance arbitraryNoArguments :: Arbitrary NoArguments where
  arbitrary = pure NoArguments

instance coarbitraryNoArguments :: Coarbitrary NoArguments where
  coarbitrary NoArguments = identity

-- | To be able to evenly distribute over chains of Sum types we build up
-- | a collection of generators and choose between.  Each right component
-- | of a Sum is either a Constructor or another Sum.
class ArbitraryGenericSum t where
  arbitraryGenericSum :: Array (Gen t)

instance arbGenSumSum :: (Arbitrary l, ArbitraryGenericSum r) => ArbitraryGenericSum (Sum l r) where
  arbitraryGenericSum = [Inl <$> arbitrary] <> (map Inr <$> arbitraryGenericSum)

instance arbGenSumConstructor :: Arbitrary a => ArbitraryGenericSum (Constructor s a) where
  arbitraryGenericSum = [arbitrary]

instance arbitrarySum :: (Arbitrary l, ArbitraryGenericSum r) => Arbitrary (Sum l r) where
  arbitrary = oneOf $ (Inl <$> arbitrary) :| (map Inr <$> arbitraryGenericSum)

instance coarbitrarySum :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Sum l r) where
  coarbitrary (Inl l) = coarbitrary l
  coarbitrary (Inr r) = coarbitrary r

instance arbitraryProduct :: (Arbitrary l, Arbitrary r) => Arbitrary (Product l r) where
  arbitrary = Product <$> arbitrary <*> arbitrary

instance coarbitraryProduct :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Product l r) where
  coarbitrary (Product a b) = coarbitrary a >>> coarbitrary b

instance arbitraryConstructor :: Arbitrary a => Arbitrary (Constructor s a) where
  arbitrary = Constructor <$> arbitrary

instance coarbitraryConstructor :: Coarbitrary a => Coarbitrary (Constructor s a) where
  coarbitrary (Constructor a) = coarbitrary a

instance arbitraryArgument :: Arbitrary a => Arbitrary (Argument a) where
  arbitrary = Argument <$> arbitrary

instance coarbitraryArgument :: Coarbitrary a => Coarbitrary (Argument a) where
  coarbitrary (Argument a) = coarbitrary a

-- | A `Generic` implementation of the `arbitrary` member from the `Arbitrary` type class.
genericArbitrary :: forall a rep. Generic a rep => Arbitrary rep => Gen a
genericArbitrary = to <$> (arbitrary :: Gen rep)

-- | A `Generic` implementation of the `coarbitrary` member from the `Coarbitrary` type class.
genericCoarbitrary :: forall a rep. Generic a rep => Coarbitrary rep => a -> Gen a -> Gen a
genericCoarbitrary x g = to <$> coarbitrary (from x) (from <$> g)

-- | A helper typeclass to implement `Arbitrary` for records.
class ArbitraryRowList list row | list -> row where
  arbitraryRecord :: RLProxy list -> Gen (Record row)

instance arbitraryRowListNil :: ArbitraryRowList RL.Nil () where
  arbitraryRecord _ = pure {}

instance arbitraryRowListCons ::
  ( Arbitrary a
  , ArbitraryRowList listRest rowRest
  , Row.Lacks key rowRest
  , Row.Cons key a rowRest rowFull
  , RL.RowToList rowFull (RL.Cons key a listRest)
  , IsSymbol key
  ) => ArbitraryRowList (RL.Cons key a listRest) rowFull where
  arbitraryRecord _ = do
     value <- arbitrary
     previous <- arbitraryRecord (RLProxy :: RLProxy listRest)
     pure $ Record.insert (SProxy :: SProxy key) value previous

instance arbitraryRecordInstance ::
  ( RL.RowToList row list
  , ArbitraryRowList list row
  ) => Arbitrary (Record row) where
  arbitrary = arbitraryRecord (RLProxy :: RLProxy list)