Minor cleanup of constants

Minor cleanup of constants

module Main (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

type Coordinate = Tuple Int Int

type Player = Int

type Piece = { color :: String }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

type State = { grid :: Grid, currentPlayer :: Player }

defaultWidth   = 8
defaultHeight  = 8
layerCount     = 3
renderSize     = 60.0
renderWidth    = (toNumber defaultWidth) * renderSize
renderHeight   = (toNumber defaultHeight) * renderSize

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 }
                else
                  if hasPlayerTwo
                  then Just { color: colorPlayerTwo }
                  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 :: Coordinate -> Grid -> Maybe Int
findPiece (Tuple x y) grid = findIndex (\e -> e.x == x && e.y == y) grid.squares

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

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece from grid)
      toIndex = fromJust (findPiece to grid)
      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
            let nx = toNumber ux
                ny = toNumber uy
            case (square.rx < nx && nx < square.rx + renderSize && square.ry < ny && ny < square.ry + renderSize) 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

onMouseMoveListener :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
onMouseMoveListener st e = renderPage st (Just e)

renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions { width: renderWidth, height: renderHeight } 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 (onMouseMoveListener st) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Main (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

type Coordinate = Tuple Int Int

type Player = Int

type Piece = { color :: String }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

type State = { grid :: Grid, currentPlayer :: Player }

renderSize = 60.0
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 }
                else
                  if hasPlayerTwo
                  then Just { color: colorPlayerTwo }
                  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 :: Coordinate -> Grid -> Maybe Int
findPiece (Tuple x y) grid = findIndex (\e -> e.x == x && e.y == y) grid.squares

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

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece from grid)
      toIndex = fromJust (findPiece to grid)
      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
            let nx = toNumber ux
                ny = toNumber uy
            case (square.rx < nx && nx < square.rx + renderSize && square.ry < ny && ny < square.ry + renderSize) 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

onMouseMoveListener :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
onMouseMoveListener st e = renderPage st (Just e)

renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions { "width": 480.0, "height": 480.0 } canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main = do
  st <- newSTRef (createState 8 8 3)
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      addMouseEventListener MouseMoveEvent (onMouseMoveListener st) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


Fix getStateImpl

Fix getStateImpl

module Thermite.Internal where

import DOM

import Control.Monad.Eff

import Thermite.Types

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

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

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

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

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

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

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

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

foreign import createClassImpl """
  function createClassImpl(runAction) {
    return function(spec) {
      return React.createClass({
        getInitialState: function() {
          return spec.initialState;
        },
        performAction: function(action) {
          runAction(this)(spec.performAction(this)(action))();
        },
        render: function() {
          return spec.render(this)(this.state)(this.props);
        }
      });
    };
  }
  """ :: forall eff m state props action. (Context state props action -> m Unit -> Eff eff Unit) ->
                                          SpecRecord m state props action ->
                                          ComponentClass props eff

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

module Thermite.Internal where

import DOM

import Control.Monad.Eff

import Thermite.Types

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

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

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

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

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

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

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

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

foreign import createClassImpl """
  function createClassImpl(runAction) {
    return function(spec) {
      return React.createClass({
        getInitialState: function() {
          return spec.initialState;
        },
        performAction: function(action) {
          runAction(this)(spec.performAction(this)(action))();
        },
        render: function() {
          return spec.render(this)(this.state)(this.props);
        }
      });
    };
  }
  """ :: forall eff m state props action. (Context state props action -> m Unit -> Eff eff Unit) ->
                                          SpecRecord m state props action ->
                                          ComponentClass props eff

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


[CSE-182] Format ADA values

[CSE-182] Format ADA values

-- | Detail page of a `genesis block` https://cardanodocs.com/technical/blocks/#genesis-block

module Explorer.View.GenesisBlock
    ( genesisBlockView
    , maxAddressInfoRows
    )
    where

import Prelude

import Data.Array (length, null, slice)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cGenesis, cAddress, cAddresses, cOf, common, cLoading, cNo, cSummary, cYes, gblAddressesEmpty, gblAddressesNotFound, gblAddressRedeemAmount, gblAddressIsRedeemed, gblNotFound, gblNumberRedeemedAddresses, genesisBlock) as I18nL
import Explorer.Lenses.State (_PageNumber, currentCGenesisAddressInfos, currentCGenesisSummary, gblLoadingAddressInfosPagination, gblAddressInfosPagination, gblAddressInfosPaginationEditable, genesisBlockViewState, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CGenesisAddressInfos, PageNumber(..), State)
import Explorer.Util.String (formatADA)
import Explorer.View.Common (currencyCSSClass, getMaxPaginationNumber, paginationView)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.ClientTypes (CGenesisAddressInfo(..), CGenesisSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, _CCoin, cgaiCardanoAddress, cgaiGenesisAmount, cgaiIsRedeemed, cgsNumRedeemed, getCoin)
import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Text.Smolder.HTML (a, div, h3, p, span) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup ((!), (#!))
import Text.Smolder.Markup (text) as S

genesisBlockView :: State -> P.HTML Action
genesisBlockView state =
    let lang' = state ^. lang
    in
    S.div ! S.className "explorer-genesis"$ do
        S.div ! S.className "explorer-genesis__wrapper"
              $ S.div ! S.className "explorer-genesis__container" $ do
                    S.h3  ! S.className "headline"
                        $ S.text (translate (I18nL.common <<< I18nL.cGenesis) lang')
                    case state ^. currentCGenesisSummary of
                        NotAsked  -> emptyView ""
                        Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                        Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblNotFound) lang'
                        Success summary -> summaryView summary lang'

        S.div ! S.className "explorer-genesis__wrapper" $ do
            S.div ! S.className "explorer-genesis__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cAddresses) lang')
                case state ^. currentCGenesisAddressInfos of
                    NotAsked  -> emptyView ""
                    Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                    Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesNotFound) lang'
                    Success infos -> addressInfosView infos state

emptyView :: String -> P.HTML Action
emptyView message =
    S.div ! S.className "summary-empty__container"
          $ S.text message

type SummaryRowItem =
    { id :: String
    , label :: String
    , amount :: String
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: Language -> CGenesisSummary -> SummaryItems
mkSummaryItems lang (CGenesisSummary summary) =
    [ { id: "0"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAddresses) lang
      , amount: show $ summary ^. cgsNumRedeemed
      }
    ]

summaryRow :: SummaryRowItem -> P.HTML Action
summaryRow item =
    S.div
        ! S.className "row row__summary"
        ! P.key item.id
        $ do
            S.div ! S.className "column column__label"
                  $ S.text item.label
            S.div ! S.className "column column__amount"
                  $ S.text item.amount

summaryView :: CGenesisSummary -> Language -> P.HTML Action
summaryView summary lang =
    S.div ! S.className "summary-wrapper" $ do
        S.div ! S.className "summary-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cSummary) lang)
            S.div $ for_ (mkSummaryItems lang summary) summaryRow

type AddressInfosHeaderProps =
    { label :: String
    , clazz :: String
    }

mkAddressInfosHeaderProps :: Language -> Array AddressInfosHeaderProps
mkAddressInfosHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cAddress) lang
      , clazz: "hash"
      }
    , { label: translate (I18nL.genesisBlock <<< I18nL.gblAddressRedeemAmount) lang
      , clazz: "amount"
      }
    , { label: translate (I18nL.genesisBlock <<< I18nL.gblAddressIsRedeemed) lang
      , clazz: "redeemed"
      }
    ]

addressesHeaderView :: Language -> P.HTML Action
addressesHeaderView lang =
    S.div ! S.className "address-infos__header"
          $ for_ (mkAddressInfosHeaderProps lang) addressesHeaderItemView

addressesHeaderItemView :: AddressInfosHeaderProps -> P.HTML Action
addressesHeaderItemView props =
    S.div ! S.className props.clazz
          $ S.text props.label

addressInfosBodyView :: Language -> CGenesisAddressInfo -> P.HTML Action
addressInfosBodyView lang (CGenesisAddressInfo info) =
    let addrLink = toUrl $ Address (info ^. cgaiCardanoAddress) in
    S.div ! S.className "address-infos__body--row"
          $ do
          -- hash
          S.a ! S.className "address-infos__body--column hash"
              ! S.href addrLink
              #! P.onClick (Navigate addrLink)
              $ S.text (info ^. (cgaiCardanoAddress <<< _CAddress))
          -- amount
          S.div ! S.className "address-infos__body--column amount"
                $ S.span ! S.className (currencyCSSClass $ Just ADA)
                          $ S.text (formatADA (info ^. cgaiGenesisAmount) lang)
          -- is redeemed
          S.div ! S.className "address-infos__body--column redeemed"
                $ S.text (if (info ^. cgaiIsRedeemed)
                              then translate (I18nL.common <<< I18nL.cYes) lang
                              else translate (I18nL.common <<< I18nL.cNo) lang)

maxAddressInfoRows :: Int
maxAddressInfoRows = 5

addressInfosView :: CGenesisAddressInfos -> State -> P.HTML Action
addressInfosView infos state =
    if null infos then
        emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesEmpty) (state ^. lang)
    else
        let addressInfosPagination = state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination <<< _PageNumber)
            lang' = state ^. lang
            minInfoIndex = (addressInfosPagination - minPagination) * maxAddressInfoRows
            currentInfos = slice minInfoIndex (minInfoIndex + maxAddressInfoRows) infos
        in
        do
            S.div
                ! S.className "address-infos__wrapper"
                $ do
                    addressesHeaderView lang'
                    S.div ! S.className "address-infos__body--wrapper"
                          $ do
                          for_ currentInfos (addressInfosBodyView lang')
                          S.div ! S.className ("address-infos__body--cover"
                                      <>  if  state ^. (viewStates <<< genesisBlockViewState <<< gblLoadingAddressInfosPagination)
                                          then " show"
                                          else "")
                                $ S.p ! S.className "address-infos__body--cover-label"
                                      $ S.text (translate (I18nL.common <<< I18nL.cLoading) lang')
            S.div
                ! S.className "address-infos__footer"
                $  paginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                    , currentPage: PageNumber addressInfosPagination
                                    , minPage: PageNumber minPagination
                                    , maxPage: PageNumber $ getMaxPaginationNumber (length infos) maxAddressInfoRows
                                    , changePageAction: GenesisBlockPaginateAddresses
                                    , editable: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPaginationEditable)
                                    , editableAction: GenesisBlockEditAddressesPageNumber
                                    , invalidPageAction: GenesisBlockInvalidAddressesPageNumber
                                    , disabled: false
                                    }

-- | Detail page of a `genesis block` https://cardanodocs.com/technical/blocks/#genesis-block

module Explorer.View.GenesisBlock
    ( genesisBlockView
    , maxAddressInfoRows
    )
    where

import Prelude

import Data.Array (length, null, slice)
import Data.Foldable (for_)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (cGenesis, cAddress, cAddresses, cOf, common, cLoading, cNo, cSummary, cYes, gblAddressesEmpty, gblAddressesNotFound, gblAddressRedeemAmount, gblAddressIsRedeemed, gblNotFound, gblNumberRedeemedAddresses, genesisBlock) as I18nL
import Explorer.Lenses.State (_PageNumber, currentCGenesisAddressInfos, currentCGenesisSummary, gblLoadingAddressInfosPagination, gblAddressInfosPagination, gblAddressInfosPaginationEditable, genesisBlockViewState, lang, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), CGenesisAddressInfos, PageNumber(..), State)
import Explorer.View.Common (currencyCSSClass, getMaxPaginationNumber, paginationView)
import Network.RemoteData (RemoteData(..))
import Pos.Explorer.Web.ClientTypes (CGenesisAddressInfo(..), CGenesisSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, _CCoin, cgaiCardanoAddress, cgaiGenesisAmount, cgaiIsRedeemed, cgsNumRedeemed, getCoin)
import Pux.DOM.HTML (HTML) as P
import Pux.DOM.HTML.Attributes (key) as P
import Pux.DOM.Events (onClick) as P
import Text.Smolder.HTML (a, div, h3, p, span) as S
import Text.Smolder.HTML.Attributes (className, href) as S
import Text.Smolder.Markup ((!), (#!))
import Text.Smolder.Markup (text) as S

genesisBlockView :: State -> P.HTML Action
genesisBlockView state =
    let lang' = state ^. lang
    in
    S.div ! S.className "explorer-genesis"$ do
        S.div ! S.className "explorer-genesis__wrapper"
              $ S.div ! S.className "explorer-genesis__container" $ do
                    S.h3  ! S.className "headline"
                        $ S.text (translate (I18nL.common <<< I18nL.cGenesis) lang')
                    case state ^. currentCGenesisSummary of
                        NotAsked  -> emptyView ""
                        Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                        Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblNotFound) lang'
                        Success summary -> summaryView summary lang'

        S.div ! S.className "explorer-genesis__wrapper" $ do
            S.div ! S.className "explorer-genesis__container" $ do
                S.h3  ! S.className "headline"
                      $ S.text (translate (I18nL.common <<< I18nL.cAddresses) lang')
                case state ^. currentCGenesisAddressInfos of
                    NotAsked  -> emptyView ""
                    Loading   -> emptyView $ translate (I18nL.common <<< I18nL.cLoading) lang'
                    Failure _ -> emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesNotFound) lang'
                    Success infos -> addressInfosView infos state

emptyView :: String -> P.HTML Action
emptyView message =
    S.div ! S.className "summary-empty__container"
          $ S.text message

type SummaryRowItem =
    { id :: String
    , label :: String
    , amount :: String
    }

type SummaryItems = Array SummaryRowItem

mkSummaryItems :: Language -> CGenesisSummary -> SummaryItems
mkSummaryItems lang (CGenesisSummary summary) =
    [ { id: "0"
      , label: translate (I18nL.genesisBlock <<< I18nL.gblNumberRedeemedAddresses) lang
      , amount: show $ summary ^. cgsNumRedeemed
      }
    ]

summaryRow :: SummaryRowItem -> P.HTML Action
summaryRow item =
    S.div
        ! S.className "row row__summary"
        ! P.key item.id
        $ do
            S.div ! S.className "column column__label"
                  $ S.text item.label
            S.div ! S.className "column column__amount"
                  $ S.text item.amount

summaryView :: CGenesisSummary -> Language -> P.HTML Action
summaryView summary lang =
    S.div ! S.className "summary-wrapper" $ do
        S.div ! S.className "summary-container" $ do
            S.h3  ! S.className "subheadline"
                  $ S.text (translate (I18nL.common <<< I18nL.cSummary) lang)
            S.div $ for_ (mkSummaryItems lang summary) summaryRow

type AddressInfosHeaderProps =
    { label :: String
    , clazz :: String
    }

mkAddressInfosHeaderProps :: Language -> Array AddressInfosHeaderProps
mkAddressInfosHeaderProps lang =
    [ { label: translate (I18nL.common <<< I18nL.cAddress) lang
      , clazz: "hash"
      }
    , { label: translate (I18nL.genesisBlock <<< I18nL.gblAddressRedeemAmount) lang
      , clazz: "amount"
      }
    , { label: translate (I18nL.genesisBlock <<< I18nL.gblAddressIsRedeemed) lang
      , clazz: "redeemed"
      }
    ]

addressesHeaderView :: Language -> P.HTML Action
addressesHeaderView lang =
    S.div ! S.className "address-infos__header"
          $ for_ (mkAddressInfosHeaderProps lang) addressesHeaderItemView

addressesHeaderItemView :: AddressInfosHeaderProps -> P.HTML Action
addressesHeaderItemView props =
    S.div ! S.className props.clazz
          $ S.text props.label

addressInfosBodyView :: Language -> CGenesisAddressInfo -> P.HTML Action
addressInfosBodyView lang (CGenesisAddressInfo info) =
    let addrLink = toUrl $ Address (info ^. cgaiCardanoAddress) in
    S.div ! S.className "address-infos__body--row"
          $ do
          -- hash
          S.a ! S.className "address-infos__body--column hash"
              ! S.href addrLink
              #! P.onClick (Navigate addrLink)
              $ S.text (info ^. (cgaiCardanoAddress <<< _CAddress))
          -- amount
          S.div ! S.className "address-infos__body--column amount"
                $ S.span ! S.className (currencyCSSClass $ Just ADA)
                          $ S.text (info ^. (cgaiGenesisAmount <<< _CCoin <<< getCoin))
          -- is redeemed
          S.div ! S.className "address-infos__body--column redeemed"
                $ S.text (if (info ^. cgaiIsRedeemed)
                              then translate (I18nL.common <<< I18nL.cYes) lang
                              else translate (I18nL.common <<< I18nL.cNo) lang)

maxAddressInfoRows :: Int
maxAddressInfoRows = 5

addressInfosView :: CGenesisAddressInfos -> State -> P.HTML Action
addressInfosView infos state =
    if null infos then
        emptyView $ translate (I18nL.genesisBlock <<< I18nL.gblAddressesEmpty) (state ^. lang)
    else
        let addressInfosPagination = state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination <<< _PageNumber)
            lang' = state ^. lang
            minInfoIndex = (addressInfosPagination - minPagination) * maxAddressInfoRows
            currentInfos = slice minInfoIndex (minInfoIndex + maxAddressInfoRows) infos
        in
        do
            S.div
                ! S.className "address-infos__wrapper"
                $ do
                    addressesHeaderView lang'
                    S.div ! S.className "address-infos__body--wrapper"
                          $ do
                          for_ currentInfos (addressInfosBodyView lang')
                          S.div ! S.className ("address-infos__body--cover"
                                      <>  if  state ^. (viewStates <<< genesisBlockViewState <<< gblLoadingAddressInfosPagination)
                                          then " show"
                                          else "")
                                $ S.p ! S.className "address-infos__body--cover-label"
                                      $ S.text (translate (I18nL.common <<< I18nL.cLoading) lang')
            S.div
                ! S.className "address-infos__footer"
                $  paginationView  { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                    , currentPage: PageNumber addressInfosPagination
                                    , minPage: PageNumber minPagination
                                    , maxPage: PageNumber $ getMaxPaginationNumber (length infos) maxAddressInfoRows
                                    , changePageAction: GenesisBlockPaginateAddresses
                                    , editable: state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPaginationEditable)
                                    , editableAction: GenesisBlockEditAddressesPageNumber
                                    , invalidPageAction: GenesisBlockInvalidAddressesPageNumber
                                    , disabled: false
                                    }


GWAS renderer now assumes chr-data is sent along feature

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
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 (throwError)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((!!), (..))
import Data.Array as Array
import Data.Foldable (foldMap, for_, length)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(..), fromJust, fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap, wrap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

posPixelsX :: XPosInfo
           -> Bp
           -> Pixels
posPixelsX { scale } pos = bpToPixels scale pos

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

type Renderer eff a =
  { hPos :: a -> XPosInfo -> Pixels
  , vPos :: a -> YPosInfo -> Pixels
  , render :: a -> Context2D -> Eff eff Unit
  , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
  }

gwasRenderer :: forall a.
                {min :: Number, max :: Number}
             -> (a -> String)
             -> Renderer _ {score :: Number, pos :: Bp, chr :: a}
gwasRenderer {min, max} color = { hPos, vPos, render, hit: Nothing }
  where hPos a xInfo = posPixelsX xInfo a.pos
        nScore s = (s - min) / (max - min)
        vPos a yInfo = posPixelsY yInfo (nScore a.score)
        render a ctx = renderGlyph ctx $ do
          stroke (color a.chr)
          fill (color a.chr)
          circle { x: 0.0, y: 0.0 } 5.0

runRenderer :: forall a.
               a
            -> Renderer _ a
            -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
            -> Context2D
            -> Eff _ Unit
runRenderer a { hPos, vPos, render, hit } { xInfo, yInfo } ctx = C.withContext ctx do
  let translateX = hPos a xInfo
      translateY = vPos a yInfo
  _ <- C.translate {translateX, translateY} ctx
  render a ctx

runRendererN :: forall a.
                Renderer _ a
             -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
             -> Array a
             -> Context2D
             -> Eff _ Unit
runRendererN r p as ctx =
  for_ as (\a -> runRenderer a r p ctx)

-- TODO the `offset` should probably be in XPosInfo,
-- and be the actual pixel offset for that bit on the canvas...
-- type Frames a = { offset :: Pixels, frames :: Array (Tuple {xInfo :: XPosInfo} a) }

type Frames f a = { offset :: Pixels
                  , frames :: Array { xInfo :: XPosInfo
                                    , context :: f
                                    , contents :: a
                                    } }

frames :: forall f a.
          Pixels
       -> Pixels
       -> (a -> Bp)
       -> Array (Tuple f a)
       -> Frames f a
frames width offset f chrs = { offset
                             , frames: g <$> chrs}
  where n = length chrs
        -- TODO the scale should depend on the current size; that needs more work
        totalSize = alaF Additive foldMap (f <<< snd) chrs
        width' = width - offset * n
        g (Tuple b a) = let size = f a
                            xInfo = { size, scale: BpPerPixel (unwrap totalSize / width' ) }
                            context = b
                            contents = a
                        in { xInfo, context, contents }

-- mapFrames :: forall a b.
--              (a -> b)
--           -> Frames a
--           -> Frames b
-- mapFrames f fs = fs { frames = map f <$> fs.frames }

-- zipWithFrames :: forall a b.
--              Array (a -> b)
--           -> Frames a
--           -> Frames b
-- zipWithFrames funs fs = fs { frames = frames }
--   where frames = Array.zipWith (\fun frame -> fun <$> frame) funs fs.frames

renderFrames :: forall f a.
                YPosInfo
             -> Frames f a
             -> Renderer _ a
             -> (f -> Context2D -> Eff _ Unit)
             -> Context2D
             -> Eff _ Unit
renderFrames yInfo {offset, frames} r pre ctx = C.withContext ctx (foreachE frames f)
  where f {xInfo, context, contents} = do
            void $ C.translate {translateX: offset, translateY: 0.0} ctx
            r.render contents ctx
            let len = bpToPixels xInfo.scale xInfo.size
            void $ C.translate {translateX: len, translateY: 0.0} ctx

renderFramesN :: forall f a.
                 YPosInfo
              -> Frames f (Array a)
              -> Renderer _ a
              -> (f -> Context2D -> Eff _ Unit)
              -> Context2D
              -> Eff _ Unit
renderFramesN yInfo {offset, frames} r pre ctx = C.withContext ctx (foreachE frames f)
  where f {xInfo, context, contents} = do
            pre context ctx
            runRendererN r {xInfo, yInfo} contents ctx
            log $ "scale: " <> show (unwrap xInfo.scale)
            let len = bpToPixels xInfo.scale xInfo.size
            void $ C.translate {translateX: len+offset, translateY: 0.0} ctx

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

(         a -> (Translation, Eff _ Unit))
(Identity a -> (Translation, Eff _ Unit))

(       f a ->  g           (Eff _ Unit))
(       f a ->  Identity    (Eff _ Unit))
-}

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }
{-
renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit
-}

testFetch :: forall r.
             String
          -> Aff _ (Array { score :: Number, pos :: Bp, chr :: Int })
testFetch url = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe {score :: Number, pos :: Bp, chr :: Int }
      f j = do
            obj <- j ^? _Object
            pos <- Bp <$> obj ^? ix "min" <<< _Number
            pValue <- readFloat <$> obj ^? ix "pValue" <<< _String
            let score = (-1.0) * (Math.log pValue / Math.log 10.0)
                chr = 11
            pure {pos, score, chr}

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

testRender :: forall a.
              Renderer _ a
           -> Array a
           -> Aff _ Unit
testRender r as = do
  liftEff $ log "running"
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

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

  let size = Bp 122030190.0
      n = 10
      scale = BpPerPixel (unwrap size / (w / 10.0))
      xInfo = { size, scale }
      height = h
      offset = 0.0
      yInfo = { height, offset }
      colors = ["yellow", "orange", "red", "purple", "blue"]

      fs :: Frames _ (Array _)
      fs = frames w 20.0 (const size) $ Array.zip (1..5) (Array.replicate 5 as)

      pre :: Int -> Context2D -> Eff _ Unit
      pre i ctx = do
        let color = fromMaybe "black" (colors !! i `mod` 5)
        void $ C.setStrokeStyle color ctx
        void $ C.setFillStyle color ctx

  liftEff $ renderFramesN yInfo fs r pre ctx

main = launchAff $ do
  dat <- testFetch "./gwas.json"
  let min = 0.0
      max = 50.0
  testRender (gwasRenderer {min, max}) dat

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

-- runTrack :: forall a r.
--             View
--          -> Track _ _ a
--          -> Aff _ Unit
-- runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

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

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  -- pure unit

{-

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

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

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

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

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
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 (throwError)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((!!), (..))
import Data.Array as Array
import Data.Foldable (foldMap, for_, length)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(..), fromJust, fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap, wrap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

posPixelsX :: XPosInfo
           -> Bp
           -> Pixels
posPixelsX { scale } pos = bpToPixels scale pos

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

type Renderer eff a =
  { hPos :: a -> XPosInfo -> Pixels
  , vPos :: a -> YPosInfo -> Pixels
  , render :: a -> Context2D -> Eff eff Unit
  , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
  }

gwasRenderer :: {min :: Number, max :: Number}
             -> Renderer _ {score :: Number, pos :: Bp}
gwasRenderer {min, max} = { hPos, vPos, render, hit: Nothing }
  where hPos a xInfo = posPixelsX xInfo a.pos
        nScore s = (s - min) / (max - min)
        vPos a yInfo = posPixelsY yInfo (nScore a.score)
        render _ ctx = renderGlyph ctx $ circle { x: 0.0, y: 0.0 } 5.0

-- profunctors/arrows could come in here
-- or polymorphic records, maybe? would have to be (Tuple r1 a) -> (Tuple r2 a) tho
strokeRenderer :: forall a.
                  Renderer _ a
               -> Renderer _ (Tuple String a)
strokeRenderer r = {hPos, vPos, render, hit}
  where hPos (Tuple _ a) = r.hPos a
        vPos (Tuple _ a) = r.vPos a
        hit = Nothing -- TODO fix this
        render (Tuple col a) ctx = C.withContext ctx do
          _ <- C.setStrokeStyle col ctx
          r.render a ctx

fillRenderer :: forall a.
                Renderer _ a
             -> Renderer _ (Tuple String a)
fillRenderer r = {hPos, vPos, render, hit}
  where hPos (Tuple _ a) = r.hPos a
        vPos (Tuple _ a) = r.vPos a
        hit = Nothing -- TODO fix this
        render (Tuple col a) ctx = C.withContext ctx do
          _ <- C.setFillStyle col ctx
          r.render a ctx

runRenderer :: forall a.
               a
            -> Renderer _ a
            -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
            -> Context2D
            -> Eff _ Unit
runRenderer a { hPos, vPos, render, hit } { xInfo, yInfo } ctx = C.withContext ctx do
  let translateX = hPos a xInfo
      translateY = vPos a yInfo
  _ <- C.translate {translateX, translateY} ctx
  render a ctx

runRendererN :: forall a.
                Renderer _ a
             -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
             -> Array a
             -> Context2D
             -> Eff _ Unit
runRendererN r p as ctx =
  for_ as (\a -> runRenderer a r p ctx)

-- TODO the `offset` should probably be in XPosInfo,
-- and be the actual pixel offset for that bit on the canvas...
-- type Frames a = { offset :: Pixels, frames :: Array (Tuple {xInfo :: XPosInfo} a) }

type Frames f a = { offset :: Pixels
                  , frames :: Array { xInfo :: XPosInfo
                                    , context :: f
                                    , contents :: a
                                    } }

frames :: forall f a.
          Pixels
       -> Pixels
       -> (a -> Bp)
       -> Array (Tuple f a)
       -> Frames f a
frames width offset f chrs = { offset
                             , frames: g <$> chrs}
  where n = length chrs
        -- TODO the scale should depend on the current size; that needs more work
        totalSize = alaF Additive foldMap (f <<< snd) chrs
        width' = width - offset * n
        g (Tuple b a) = let size = f a
                            xInfo = { size, scale: BpPerPixel (unwrap totalSize / width' ) }
                            context = b
                            contents = a
                        in { xInfo, context, contents }

-- mapFrames :: forall a b.
--              (a -> b)
--           -> Frames a
--           -> Frames b
-- mapFrames f fs = fs { frames = map f <$> fs.frames }

-- zipWithFrames :: forall a b.
--              Array (a -> b)
--           -> Frames a
--           -> Frames b
-- zipWithFrames funs fs = fs { frames = frames }
--   where frames = Array.zipWith (\fun frame -> fun <$> frame) funs fs.frames

renderFrames :: forall f a.
                YPosInfo
             -> Frames f a
             -> Renderer _ a
             -> (f -> Context2D -> Eff _ Unit)
             -> Context2D
             -> Eff _ Unit
renderFrames yInfo {offset, frames} r pre ctx = C.withContext ctx (foreachE frames f)
  where f {xInfo, context, contents} = do
            void $ C.translate {translateX: offset, translateY: 0.0} ctx
            r.render contents ctx
            let len = bpToPixels xInfo.scale xInfo.size
            void $ C.translate {translateX: len, translateY: 0.0} ctx

renderFramesN :: forall f a.
                 YPosInfo
              -> Frames f (Array a)
              -> Renderer _ a
              -> (f -> Context2D -> Eff _ Unit)
              -> Context2D
              -> Eff _ Unit
renderFramesN yInfo {offset, frames} r pre ctx = C.withContext ctx (foreachE frames f)
  where f {xInfo, context, contents} = do
            pre context ctx
            runRendererN r {xInfo, yInfo} contents ctx
            log $ "scale: " <> show (unwrap xInfo.scale)
            let len = bpToPixels xInfo.scale xInfo.size
            void $ C.translate {translateX: len+offset, translateY: 0.0} ctx

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

(         a -> (Translation, Eff _ Unit))
(Identity a -> (Translation, Eff _ Unit))

(       f a ->  g           (Eff _ Unit))
(       f a ->  Identity    (Eff _ Unit))
-}

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }
{-
renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit
-}

testFetch :: String
          -> Aff _ (Array { score :: Number, pos :: Bp })
testFetch url = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe {score :: Number, pos :: Bp}
      f j = do
            obj <- j ^? _Object
            pos <- Bp <$> obj ^? ix "min" <<< _Number
            pValue <- readFloat <$> obj ^? ix "pValue" <<< _String
            let score = (-1.0) * (Math.log pValue / Math.log 10.0)
            pure {pos, score}

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

testRender :: forall a.
              Renderer _ a
           -> Array a
           -> Aff _ Unit
testRender r as = do
  liftEff $ log "running"
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

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

  let size = Bp 122030190.0
      n = 10
      scale = BpPerPixel (unwrap size / (w / 10.0))
      xInfo = { size, scale }
      height = h
      offset = 0.0
      yInfo = { height, offset }
      colors = ["yellow", "orange", "red", "purple", "blue"]

      fs :: Frames _ (Array _)
      fs = frames w 20.0 (const size) $ Array.zip (1..5) (Array.replicate 5 as)

      pre :: Int -> Context2D -> Eff _ Unit
      pre i ctx = do
        let color = fromMaybe "black" (colors !! i `mod` 5)
        void $ C.setStrokeStyle color ctx
        void $ C.setFillStyle color ctx

  liftEff $ renderFramesN yInfo fs r pre ctx

main = launchAff $ do
  dat <- testFetch "./gwas.json"
  let min = 0.0
      max = 50.0
  testRender (gwasRenderer {min, max}) dat

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

-- runTrack :: forall a r.
--             View
--          -> Track _ _ a
--          -> Aff _ Unit
-- runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

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

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  -- pure unit

{-

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

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

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

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

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}


Fix RBrace parser

Fix RBrace parser

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Parser.Common
-- Copyright   :  (c) Phil Freeman 2013
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Constants, and utility functions to be used when parsing
--
-----------------------------------------------------------------------------

module Language.PureScript.Parser.Common where

import Data.Maybe
import Data.Either
import Data.Array (null)

import Control.Apply

import Control.Monad.State.Class
import Control.Monad.Error.Class

import Text.Parsing.Parser
import Text.Parsing.Parser.String
import Text.Parsing.Parser.Combinators

import Language.PureScript.Parser.Lexer
import Language.PureScript.Names

runTokenParser :: forall a. Parser [Token] a -> [Token] -> Either String a
runTokenParser p ts = case runParser ts p of
  Left (ParseError o) -> Left o.message
  Right a -> Right a

token :: forall tok a. String -> (tok -> String) -> (tok -> Maybe a) -> Parser [tok] a
token exp sh p = do
  ts <- get
  case ts of
    (t : ts') -> case p t of
      Just a -> do
        put (Consumed true)
        put ts'
        return a
      Nothing -> fail $ "Expected " ++ exp ++ ", found " ++ sh t
    _ -> fail $ "Expected " ++ exp ++ ", found EOF"

token' :: forall a. String -> (Token -> Maybe a) -> Parser [Token] a
token' exp p = token exp show p

match :: forall a. Token -> Parser [Token] {}
match tok = token' (show tok) (\tok' -> if tok == tok' then Just {} else Nothing)

lparen :: Parser [Token] {}
lparen = match LParen

rparen :: Parser [Token] {}
rparen = match RParen

parens :: forall a. Parser [Token] a -> Parser [Token] a
parens = between lparen rparen

lbrace :: Parser [Token] {}
lbrace = match LBrace

rbrace :: Parser [Token] {}
rbrace = match RBrace

braces :: forall a. Parser [Token] a -> Parser [Token] a
braces = between lbrace rbrace

langle :: Parser [Token] {}
langle = match LAngle

rangle :: Parser [Token] {}
rangle = match RAngle

angles :: forall a. Parser [Token] a -> Parser [Token] a
angles = between langle rangle

lsquare :: Parser [Token] {}
lsquare = match LSquare

rsquare :: Parser [Token] {}
rsquare = match RSquare

squares :: forall a. Parser [Token] a -> Parser [Token] a
squares = between lsquare rsquare

indent :: Parser [Token] {}
indent = match Indent

dedent :: Parser [Token] {}
dedent = match Dedent

larrow :: Parser [Token] {}
larrow = match LArrow

rarrow :: Parser [Token] {}
rarrow = match RArrow

lfatArrow :: Parser [Token] {}
lfatArrow = match LFatArrow

rfatArrow :: Parser [Token] {}
rfatArrow = match RFatArrow

colon :: Parser [Token] {}
colon = match Colon

doubleColon :: Parser [Token] {}
doubleColon = match DoubleColon

equals :: Parser [Token] {}
equals = match Equals

pipe :: Parser [Token] {}
pipe = match Pipe

tick :: Parser [Token] {}
tick = match Tick

dot :: Parser [Token] {}
dot = match Dot

comma :: Parser [Token] {}
comma = match Comma

commaSep :: forall a. Parser [Token] a -> Parser [Token] [a]
commaSep p = sepBy p comma

commaSep1 :: forall a. Parser [Token] a -> Parser [Token] [a]
commaSep1 p = sepBy1 p comma

lname :: Parser [Token] String
lname = token' "identifier" go
  where
  go (LName s) = Just s
  go _ = Nothing

lname' :: String -> Parser [Token] {}
lname' s = token' (show s) go
  where
  go (LName s') | s == s' = Just {}
  go _ = Nothing

uname :: Parser [Token] String
uname = token' "proper name" go
  where
  go (UName s) = Just s
  go _ = Nothing

uname' :: String -> Parser [Token] {}
uname' s = token' (show s) go
  where
  go (UName s') | s == s' = Just {}
  go _ = Nothing

symbol :: Parser [Token] String
symbol = token' "symbol" go
  where
  go (Symbol s) = Just s
  go _ = Nothing

symbol' :: String -> Parser [Token] {}
symbol' s = token' (show s) go
  where
  go (Symbol s') | s == s' = Just {}
  go _ = Nothing

stringLiteral :: Parser [Token] String
stringLiteral = token' "string literal" go
  where
  go (StringLiteral s) = Just s
  go _ = Nothing

natural :: Parser [Token] Number
natural = token' "natural number" go
  where
  go (Natural n) = Just n
  go _ = Nothing

integer :: Parser [Token] Number
integer = token' "integer" go
  where
  go (Integer n) = Just n
  go _ = Nothing

float :: Parser [Token] Number
float = token' "floating point" go
  where
  go (Float n) = Just n
  go _ = Nothing

hex :: Parser [Token] Number
hex = token' "hexadecimal" go
  where
  go (Hex n) = Just n
  go _ = Nothing

lineComment :: Parser [Token] String
lineComment = token' "lineComment" go
  where
  go (LineComment s) = Just s
  go _ = Nothing

blockComment :: Parser [Token] String
blockComment = token' "block comment" go
  where
  go (BlockComment s) = Just s
  go _ = Nothing

-- |
-- Parse a proper name
--
properName :: Parser [Token] ProperName
properName = ProperName <$> uname

-- |
-- Parse a module name
--
moduleName :: Parser [Token] ModuleName
moduleName = ModuleName <$> (sepBy properName dot)

notFollowedBy :: forall s a. String -> Parser s a -> Parser s {}
notFollowedBy name p = try $ (do
  c <- p
  fail ("Unexpected " ++ name)) <|> return {}

-- |
-- Parse a qualified name, i.e. M.name or just name
--
parseQualified :: forall a. Parser [Token] a -> Parser [Token] (Qualified a)
parseQualified parser = part []
  where
  part path = (do name <- try (properName <* delimiter)
                  part (updatePath path name))
              <|> (Qualified (qual path) <$> try parser)

  delimiter :: Parser [Token] {}
  delimiter = dot <* notFollowedBy "dot" dot

  updatePath :: [ProperName] -> ProperName -> [ProperName]
  updatePath path name = path ++ [name]

  qual :: [ProperName] -> Maybe ModuleName
  qual path = if null path then Nothing else Just $ ModuleName path

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Parser.Common
-- Copyright   :  (c) Phil Freeman 2013
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Constants, and utility functions to be used when parsing
--
-----------------------------------------------------------------------------

module Language.PureScript.Parser.Common where

import Data.Maybe
import Data.Either
import Data.Array (null)

import Control.Apply

import Control.Monad.State.Class
import Control.Monad.Error.Class

import Text.Parsing.Parser
import Text.Parsing.Parser.String
import Text.Parsing.Parser.Combinators

import Language.PureScript.Parser.Lexer
import Language.PureScript.Names

runTokenParser :: forall a. Parser [Token] a -> [Token] -> Either String a
runTokenParser p ts = case runParser ts p of
  Left (ParseError o) -> Left o.message
  Right a -> Right a

token :: forall tok a. String -> (tok -> String) -> (tok -> Maybe a) -> Parser [tok] a
token exp sh p = do
  ts <- get
  case ts of
    (t : ts') -> case p t of
      Just a -> do
        put (Consumed true)
        put ts'
        return a
      Nothing -> fail $ "Expected " ++ exp ++ ", found " ++ sh t
    _ -> fail $ "Expected " ++ exp ++ ", found EOF"

token' :: forall a. String -> (Token -> Maybe a) -> Parser [Token] a
token' exp p = token exp show p

match :: forall a. Token -> Parser [Token] {}
match tok = token' (show tok) (\tok' -> if tok == tok' then Just {} else Nothing)

lparen :: Parser [Token] {}
lparen = match LParen

rparen :: Parser [Token] {}
rparen = match RParen

parens :: forall a. Parser [Token] a -> Parser [Token] a
parens = between lparen rparen

lbrace :: Parser [Token] {}
lbrace = match LBrace

rbrace :: Parser [Token] {}
rbrace = match LBrace

braces :: forall a. Parser [Token] a -> Parser [Token] a
braces = between lbrace rbrace

langle :: Parser [Token] {}
langle = match LAngle

rangle :: Parser [Token] {}
rangle = match RAngle

angles :: forall a. Parser [Token] a -> Parser [Token] a
angles = between langle rangle

lsquare :: Parser [Token] {}
lsquare = match LSquare

rsquare :: Parser [Token] {}
rsquare = match RSquare

squares :: forall a. Parser [Token] a -> Parser [Token] a
squares = between lsquare rsquare

indent :: Parser [Token] {}
indent = match Indent

dedent :: Parser [Token] {}
dedent = match Dedent

larrow :: Parser [Token] {}
larrow = match LArrow

rarrow :: Parser [Token] {}
rarrow = match RArrow

lfatArrow :: Parser [Token] {}
lfatArrow = match LFatArrow

rfatArrow :: Parser [Token] {}
rfatArrow = match RFatArrow

colon :: Parser [Token] {}
colon = match Colon

doubleColon :: Parser [Token] {}
doubleColon = match DoubleColon

equals :: Parser [Token] {}
equals = match Equals

pipe :: Parser [Token] {}
pipe = match Pipe

tick :: Parser [Token] {}
tick = match Tick

dot :: Parser [Token] {}
dot = match Dot

comma :: Parser [Token] {}
comma = match Comma

commaSep :: forall a. Parser [Token] a -> Parser [Token] [a]
commaSep p = sepBy p comma

commaSep1 :: forall a. Parser [Token] a -> Parser [Token] [a]
commaSep1 p = sepBy1 p comma

lname :: Parser [Token] String
lname = token' "identifier" go
  where
  go (LName s) = Just s
  go _ = Nothing

lname' :: String -> Parser [Token] {}
lname' s = token' (show s) go
  where
  go (LName s') | s == s' = Just {}
  go _ = Nothing

uname :: Parser [Token] String
uname = token' "proper name" go
  where
  go (UName s) = Just s
  go _ = Nothing

uname' :: String -> Parser [Token] {}
uname' s = token' (show s) go
  where
  go (UName s') | s == s' = Just {}
  go _ = Nothing

symbol :: Parser [Token] String
symbol = token' "symbol" go
  where
  go (Symbol s) = Just s
  go _ = Nothing

symbol' :: String -> Parser [Token] {}
symbol' s = token' (show s) go
  where
  go (Symbol s') | s == s' = Just {}
  go _ = Nothing

stringLiteral :: Parser [Token] String
stringLiteral = token' "string literal" go
  where
  go (StringLiteral s) = Just s
  go _ = Nothing

natural :: Parser [Token] Number
natural = token' "natural number" go
  where
  go (Natural n) = Just n
  go _ = Nothing

integer :: Parser [Token] Number
integer = token' "integer" go
  where
  go (Integer n) = Just n
  go _ = Nothing

float :: Parser [Token] Number
float = token' "floating point" go
  where
  go (Float n) = Just n
  go _ = Nothing

hex :: Parser [Token] Number
hex = token' "hexadecimal" go
  where
  go (Hex n) = Just n
  go _ = Nothing

lineComment :: Parser [Token] String
lineComment = token' "lineComment" go
  where
  go (LineComment s) = Just s
  go _ = Nothing

blockComment :: Parser [Token] String
blockComment = token' "block comment" go
  where
  go (BlockComment s) = Just s
  go _ = Nothing

-- |
-- Parse a proper name
--
properName :: Parser [Token] ProperName
properName = ProperName <$> uname

-- |
-- Parse a module name
--
moduleName :: Parser [Token] ModuleName
moduleName = ModuleName <$> (sepBy properName dot)

notFollowedBy :: forall s a. String -> Parser s a -> Parser s {}
notFollowedBy name p = try $ (do
  c <- p
  fail ("Unexpected " ++ name)) <|> return {}

-- |
-- Parse a qualified name, i.e. M.name or just name
--
parseQualified :: forall a. Parser [Token] a -> Parser [Token] (Qualified a)
parseQualified parser = part []
  where
  part path = (do name <- try (properName <* delimiter)
                  part (updatePath path name))
              <|> (Qualified (qual path) <$> try parser)

  delimiter :: Parser [Token] {}
  delimiter = dot <* notFollowedBy "dot" dot

  updatePath :: [ProperName] -> ProperName -> [ProperName]
  updatePath path name = path ++ [name]

  qual :: [ProperName] -> Maybe ModuleName
  qual path = if null path then Nothing else Just $ ModuleName path