[Input.Notebook] Only perform isSQLNum logic on numeric form value

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!), elemIndex, (\\))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), isRight, either)
import Data.Foldable (intercalate, foldl, elem)
import Data.Function (on)

import Data.Maybe (Maybe(..), fromMaybe, maybe, isJust)
import Data.String (indexOf)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Model.Notebook
import Model.Resource (Resource())
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell, _dependencies, Notebook(), trash, ancestors)
import Model.Notebook.Port (Port(..), VarMapValue(), _PortResource, _VarMap)
import Optic.Core
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..), TextBoxType(..), everything)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, initSlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.String.Regex as Rx
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma
import qualified Text.Parsing.StringParser as SP
import qualified Text.Parsing.StringParser.Combinators as SP
import qualified Text.Parsing.StringParser.String as SP
import Model.Path (FilePath(), AnyPath())

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Int
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell
  | ViewCellContent Cell
  | RefreshCell Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option
  | ResizeECharts String

  | UpdatedOutput CellId Port
  | ForceSave

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  ((fromMaybe (state ^. _dropdowns)) <<<
   (modifyAt i _{visible = visSet}) <<<
   (_{visible = false} <$>))

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< depends (state ^._notebook) cellId)
        # _notebook.._cells %~ filter (not <<< isCell cellId)
        # _notebook.._dependencies %~ trash cellId

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $ setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)
        # _notebook.._cells %~ syncParents
        # _requesting <>~ [cellId]

updateState state (UpdatedOutput cid newInput) =
  state # _notebook.._cells..mapped %~ changed
  where
  changed cell = if not $ elem (cell ^. _cellId) depIds
                 then cell
                 else cell # _input .~ newInput
  depIds =
    fst <$>
    L.filter (\x -> snd x == cid) (M.toList (state ^. _notebook .. _dependencies))

updateState state (RefreshCell cell) =
  let requesting = state ^. _requesting
      cid = cell ^. _cellId
  in if elem cid requesting
     then state
     else state # _refreshing <>~ [cell ^. _cellId]

updateState state i = state

_SlamDownState :: LensP SlamDownState (SM.StrMap FormFieldValue)
_SlamDownState = lens (\(SlamDownState m) -> m) (const SlamDownState)

-- TODO: We need a much better solution to this.
syncParents :: Array Cell -> Array Cell
syncParents cells = updateCell <$> cells
  where updateCell cell = fromMaybe cell $ fromParent cell
        fromParent cell = do
          pid <- cell ^. _parent
          parent <- M.lookup pid m
          return (cell # _input .~ (parent ^. _output))
        m = M.fromList <<< L.toList $ pair <$> cells
        pair cell = Tuple (cell ^. _cellId) cell

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .. _VarMap  %~ modifyVarMap
  where
    modifyVarMap m = foldl (\m (Tuple key val) -> SM.insert key val m) m tplLst
    tplLst = maybe L.Nil SM.toList ((fromFormValue <$>) <$> state)
    fromFormValue (SingleValue PlainText s) = quoteString s
    fromFormValue (SingleValue Numeric s) = quoteStringNumeric s
    fromFormValue (SingleValue Date s) = "DATE '" ++ s ++ "'"
    fromFormValue (SingleValue Time s) = "TIME '" ++ s ++ "'"
    fromFormValue (SingleValue DateTime s) = "TIMESTAMP '" ++ processTimestamp s ++ "'"
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state :: Maybe (SM.StrMap FormFieldValue)
    state = cell ^? _content.._Markdown..Ma._state.._SlamDownState
    processTimestamp s = s ++ ":00Z"
    quoteString s = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    quoteStringNumeric s | isSQLNum s = s
                         | otherwise = quoteString s
    rxQuot = Rx.regex "'" Rx.noFlags { global = true }
    rxT = Rx.regex "T" Rx.noFlags
    isSQLNum s = isRight $ flip SP.runParser s $ do
      SP.many1 SP.anyDigit
      SP.optional $ SP.string "." *> SP.many SP.anyDigit
      SP.optional $ (SP.string "e" <|> SP.string "E")
                 *> (SP.string "-" <|> SP.string "+")
                 *> SP.many SP.anyDigit
      SP.eof

slamDownFields :: SlamDown -> Array (Tuple String FormField)
slamDownFields = everything (const []) go
  where
  go (FormField s _ ff) = [Tuple s ff]
  go _ = []

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial md =
        let fields = slamDownFields md
            updateState (SlamDownState s) = case initSlamDownState md of
              SlamDownState s' ->
                let removedKeys = SM.keys s \\ SM.keys s'
                    mergedSM = s `SM.union` s'
                    prunedSM = foldl (\f k -> SM.delete k f) mergedSM removedKeys
                in SlamDownState prunedSM
        in slamDownOutput (cell # _message .~ message fields
                                # _content .. _Markdown .. Ma._state %~ updateState)
  in maybe cell (initial <<< parseMd) input'

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: Array FailureMessage -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

depends :: Notebook -> CellId -> Cell -> Boolean
depends notebook cellId cell =
  isJust $ elemIndex cellId (ancestors (cell ^._cellId) (notebook ^._dependencies))

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!), elemIndex, (\\))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), isRight, either)
import Data.Foldable (intercalate, foldl, elem)
import Data.Function (on)

import Data.Maybe (Maybe(..), fromMaybe, maybe, isJust)
import Data.String (indexOf)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Model.Notebook
import Model.Resource (Resource())
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell, _dependencies, Notebook(), trash, ancestors)
import Model.Notebook.Port (Port(..), VarMapValue(), _PortResource, _VarMap)
import Optic.Core
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..), TextBoxType(..), everything)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, initSlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.String.Regex as Rx
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma
import qualified Text.Parsing.StringParser as SP
import qualified Text.Parsing.StringParser.Combinators as SP
import qualified Text.Parsing.StringParser.String as SP
import Model.Path (FilePath(), AnyPath())

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Int
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell
  | ViewCellContent Cell
  | RefreshCell Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option
  | ResizeECharts String

  | UpdatedOutput CellId Port
  | ForceSave

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  ((fromMaybe (state ^. _dropdowns)) <<<
   (modifyAt i _{visible = visSet}) <<<
   (_{visible = false} <$>))

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< depends (state ^._notebook) cellId)
        # _notebook.._cells %~ filter (not <<< isCell cellId)
        # _notebook.._dependencies %~ trash cellId

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $ setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)
        # _notebook.._cells %~ syncParents
        # _requesting <>~ [cellId]

updateState state (UpdatedOutput cid newInput) =
  state # _notebook.._cells..mapped %~ changed
  where
  changed cell = if not $ elem (cell ^. _cellId) depIds
                 then cell
                 else cell # _input .~ newInput
  depIds =
    fst <$>
    L.filter (\x -> snd x == cid) (M.toList (state ^. _notebook .. _dependencies))

updateState state (RefreshCell cell) =
  let requesting = state ^. _requesting
      cid = cell ^. _cellId
  in if elem cid requesting
     then state
     else state # _refreshing <>~ [cell ^. _cellId]

updateState state i = state

_SlamDownState :: LensP SlamDownState (SM.StrMap FormFieldValue)
_SlamDownState = lens (\(SlamDownState m) -> m) (const SlamDownState)

-- TODO: We need a much better solution to this.
syncParents :: Array Cell -> Array Cell
syncParents cells = updateCell <$> cells
  where updateCell cell = fromMaybe cell $ fromParent cell
        fromParent cell = do
          pid <- cell ^. _parent
          parent <- M.lookup pid m
          return (cell # _input .~ (parent ^. _output))
        m = M.fromList <<< L.toList $ pair <$> cells
        pair cell = Tuple (cell ^. _cellId) cell

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .. _VarMap  %~ modifyVarMap
  where
    modifyVarMap m = foldl (\m (Tuple key val) -> SM.insert key val m) m tplLst
    tplLst = maybe L.Nil SM.toList ((fromFormValue <$>) <$> state)
    fromFormValue (SingleValue PlainText s) = quoteString s
    fromFormValue (SingleValue Date s) = "DATE '" ++ s ++ "'"
    fromFormValue (SingleValue Time s) = "TIME '" ++ s ++ "'"
    fromFormValue (SingleValue DateTime s) = "TIMESTAMP '" ++ processTimestamp s ++ "'"
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state :: Maybe (SM.StrMap FormFieldValue)
    state = cell ^? _content.._Markdown..Ma._state.._SlamDownState
    processTimestamp s = s ++ ":00Z"
    quoteString s | isSQLNum s = s
                  | otherwise = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    rxQuot = Rx.regex "'" Rx.noFlags { global = true }
    rxT = Rx.regex "T" Rx.noFlags
    isSQLNum s = isRight $ flip SP.runParser s $ do
      SP.many1 SP.anyDigit
      SP.optional $ SP.string "." *> SP.many SP.anyDigit
      SP.optional $ (SP.string "e" <|> SP.string "E")
                 *> (SP.string "-" <|> SP.string "+")
                 *> SP.many SP.anyDigit
      SP.eof

slamDownFields :: SlamDown -> Array (Tuple String FormField)
slamDownFields = everything (const []) go
  where
  go (FormField s _ ff) = [Tuple s ff]
  go _ = []

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial md =
        let fields = slamDownFields md
            updateState (SlamDownState s) = case initSlamDownState md of
              SlamDownState s' ->
                let removedKeys = SM.keys s \\ SM.keys s'
                    mergedSM = s `SM.union` s'
                    prunedSM = foldl (\f k -> SM.delete k f) mergedSM removedKeys
                in SlamDownState prunedSM
        in slamDownOutput (cell # _message .~ message fields
                                # _content .. _Markdown .. Ma._state %~ updateState)
  in maybe cell (initial <<< parseMd) input'

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: Array FailureMessage -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

depends :: Notebook -> CellId -> Cell -> Boolean
depends notebook cellId cell =
  isJust $ elemIndex cellId (ancestors (cell ^._cellId) (notebook ^._dependencies))


Color tweaks

Color tweaks

module App.BoardView where

import App.FixedMatrix72 as FM
import Pux.CSS as C
import App.Board (Pit, PitRef, Player, Board, getStore)
import App.FixedMatrix72 (Row(B, A))
import Prelude (bind, const, show, ($), (<>), (<))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, px, rotateHue, style)
import Pux.Html as H
import Pux.Html (Html, div, hr, span, text)
import Pux.Html.Events (onClick)

class BoardView a where
  getBoard :: a -> Board
  isPlaying :: a -> Player -> Boolean
  pitState :: a -> PitRef -> PitState

data PitState = Normal | Lifted | Captured | Sowed

pitStateColor :: PitState -> Color
pitStateColor = go
  where go Normal = hsl 40.0 1.0 0.3
        go Captured = rotateHue 50.0 $ go Lifted
        go Lifted = rotateHue 100.0 $ go Normal
        go Sowed = lighten 0.3 $ go Normal

view :: forall action state. BoardView state
     => (PitRef -> action) -> state -> Html action
view f state =
  div []
  [ viewStore state A
  , viewRow A
  , viewRow B
  , viewStore state B
  ]
  where
    board = getBoard state
    viewRow player = div [css] $ rows
      where rows = FM.mapRowWithIndex player viewCell' board.cells
            viewCell' ref = viewCell state (f ref) ref
            css = style $ do
              apply4 C.padding (em 0.5)

viewStore :: forall a state. BoardView state
          => state -> Row -> Html a
viewStore state player = div [css] [text s]
    where s = "Player "
                <> show player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitStateColor Sowed
                  else pitStateColor Normal

viewCell :: forall a state. BoardView state
          => state -> a -> PitRef -> Pit -> Html a
viewCell state action ref count =
  H.pre [css, event] [body]
  where
    body = text $ numberPadded count
    event = onClick $ const action
    numberPadded num =
      if num < 10
        then " " <> show num
        else show num
    css = style $ do
      C.display C.inline
      C.fontSize (em 2.0)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      C.border C.solid (px 1.0) C.black
      where
        color = pitStateColor $ pitState state ref
        padding = 0.5

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a

module App.BoardView where

import App.FixedMatrix72 as FM
import Pux.CSS as C
import App.Board (Pit, PitRef, Player, Board, getStore)
import App.FixedMatrix72 (Row(B, A))
import Prelude (bind, const, show, ($), (<>), (<))
import Pux.CSS (Color, backgroundColor, border, display, em, px, flexFlow, fontSize, hsl, inline, left, lighten, padding, pct, rotateHue, style, width)
import Pux.Html as H
import Pux.Html (Html, div, hr, span, text)
import Pux.Html.Events (onClick)

class BoardView a where
  getBoard :: a -> Board
  isPlaying :: a -> Player -> Boolean
  pitState :: a -> PitRef -> PitState

data PitState = Normal | Lifted | Captured | Sowed

pitStateColor :: PitState -> Color
pitStateColor = go
  where go Normal = hsl 200.0 1.0 0.3
        go Captured = rotateHue 300.0 $ go Lifted
        go Lifted = rotateHue 200.0 $ go Normal
        go Sowed = lighten 0.3 $ go Normal

view :: forall action state. BoardView state
     => (PitRef -> action) -> state -> Html action
view f state =
  div []
  [ viewStore state A
  , viewRow A
  , viewRow B
  , viewStore state B
  ]
  where
    board = getBoard state
    viewRow player = div [css] $ rows
      where rows = FM.mapRowWithIndex player viewCell' board.cells
            viewCell' ref = viewCell state (f ref) ref
            css = style $ do
              apply4 C.padding (em 0.5)

viewStore :: forall a state. BoardView state
          => state -> Row -> Html a
viewStore state player = div [css] [text s]
    where s = "Player "
                <> show player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitStateColor Sowed
                  else pitStateColor Normal

viewCell :: forall a state. BoardView state
          => state -> a -> PitRef -> Pit -> Html a
viewCell state action ref count =
  H.pre [css, event] [body]
  where
    body = text $ numberPadded count
    event = onClick $ const action
    numberPadded num =
      if num < 10
        then " " <> show num
        else show num
    css = style $ do
      C.display C.inline
      C.fontSize (em 2.0)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      C.border C.solid (px 1.0) C.black
      where
        color = pitStateColor $ pitState state ref
        padding = 0.5

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a


Fix wrong name of transformer in chapter 4

module Levels.Chapter4 where

import Data.Array
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

cxToX :: Stack -> Stack
cxToX [] = []
cxToX [c] = [c]
cxToX (c:x:cs) = if c == Cyan
                   then x : cxToX cs
                   else c : cxToX (x : cs)

ooToC :: Stack -> Stack
ooToC [] = []
ooToC [c] = [c]
ooToC (c1:c2:cs) = if c1 == Orange && c2 == Orange
                   then Cyan : ooToC cs
                   else c1 : ooToC (c2 : cs)

chapter4 :: Chapter
chapter4 = {
    name: "Chapter 4",

    transformers: SM.fromList [
        "mapXtoOX" :> {
            name: "map {X}↦{Orange}{X}",
            function: map (concatMap (\c -> [Orange, c]))
        },
        "mapCXtoC" :> {
            name: "map {Cyan}{X}↦{X}",
            function: map cxToX
        },
        "mapOOtoC" :> {
            name: "map {Orange}{Orange}↦{Cyan}",
            function: map ooToC
        },
        "mapCtoO" :> {
            name: "map {Cyan}↦{Orange}",
            function: tReplace Cyan Orange
        },
        "rejectSizeG2" :> {
            name: "reject(size > 2)",
            function: reject (\x -> length x > 2)
        }
    ],

    levels: SM.fromList [
        "4.1" :> {
            name: "Brick",
            difficulty: Easy,
            initial: [[Cyan, Orange], [Cyan, Cyan, Orange], [Orange, Orange], [Cyan, Cyan, Orange], [Cyan, Orange]],
            target: [[Cyan], [Cyan, Orange], [Cyan], [Cyan, Orange], [Cyan]]
        },
        "4.2" :> {
            name: "Fort",
            difficulty: Hard,
            initial: [[Cyan, Orange], [Cyan, Cyan, Orange], [Orange, Orange], [Cyan, Cyan, Orange], [Cyan, Orange]],
            target: [[Orange, Cyan], [Orange, Orange], [Orange, Cyan], [Orange, Orange], [Orange, Cyan]]
        }

    ]
}

module Levels.Chapter4 where

import Data.Array
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

cxToC :: Stack -> Stack
cxToC [] = []
cxToC [c] = [c]
cxToC (c1:c2:cs) = if c1 == Cyan
                   then c2 : cxToC cs
                   else c1 : cxToC (c2 : cs)

ooToC :: Stack -> Stack
ooToC [] = []
ooToC [c] = [c]
ooToC (c1:c2:cs) = if c1 == Orange && c2 == Orange
                   then Cyan : ooToC cs
                   else c1 : ooToC (c2 : cs)

chapter4 :: Chapter
chapter4 = {
    name: "Chapter 4",

    transformers: SM.fromList [
        "mapXtoOX" :> {
            name: "map {X}↦{Orange}{X}",
            function: map (concatMap (\c -> [Orange, c]))
        },
        "mapCXtoC" :> {
            name: "map {Cyan}{X}↦{Cyan}",
            function: map cxToC
        },
        "mapOOtoC" :> {
            name: "map {Orange}{Orange}↦{Cyan}",
            function: map ooToC
        },
        "mapCtoO" :> {
            name: "map {Cyan}↦{Orange}",
            function: tReplace Cyan Orange
        },
        "rejectSizeG2" :> {
            name: "reject(size > 2)",
            function: reject (\x -> length x > 2)
        }
    ],

    levels: SM.fromList [
        "4.1" :> {
            name: "Brick",
            difficulty: Easy,
            initial: [[Cyan, Orange], [Cyan, Cyan, Orange], [Orange, Orange], [Cyan, Cyan, Orange], [Cyan, Orange]],
            target: [[Cyan], [Cyan, Orange], [Cyan], [Cyan, Orange], [Cyan]]
        },
        "4.2" :> {
            name: "Fort",
            difficulty: Hard,
            initial: [[Cyan, Orange], [Cyan, Cyan, Orange], [Orange, Orange], [Cyan, Cyan, Orange], [Cyan, Orange]],
            target: [[Orange, Cyan], [Orange, Orange], [Orange, Cyan], [Orange, Orange], [Orange, Cyan]]
        }

    ]
}


Export addColumn and add real column to list

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module ThirdTab
  ( class ColT
  , addColumn
  , empty
  , ThirdTab
  , Col
  ) where

import Data.List

class ColT a

type Cells a = ColT a => List a

newtype Col a = Col { id :: Int, name :: String }

newtype ThirdTab colTypes = ThirdTab
  { cols :: List colTypes
  , rows :: List (Cells colTypes)
  }

empty :: forall a. ColT a => ThirdTab a
empty = ThirdTab
  { cols : Nil
  , rows : Nil
  }

addColumn :: forall a. ColT a => Int -> String -> ThirdTab _ -> ThirdTab _
addColumn id name (ThirdTab table) = ThirdTab { cols: Cons (Col {id: id, name: name}) table.cols, rows: Nil }

module ThirdTab
  ( class ColT
  ) where

import Data.List

class ColT a

type Cells a = ColT a => List a

newtype Col a = Col { id :: Int, name :: String }

newtype ThirdTab colTypes = ThirdTab
  { cols :: List colTypes
  , rows :: List (Cells colTypes)
  }

empty :: forall a. ColT a => ThirdTab a
empty = ThirdTab
  { cols : Nil
  , rows : Nil
  }

addColumn :: forall a. ColT a => Int -> String -> ThirdTab a -> ThirdTab _
addColumn id name (ThirdTab table) = ThirdTab { cols: table.cols, rows: Nil }


Fix typo for Apply ContT instance.

Fix typo for Apply ContT instance.

module Control.Monad.Cont.Trans where

import Control.Monad.Trans

newtype ContT r m a = ContT ((a -> m r) -> m r)

runContT :: forall r m a. ContT r m a -> (a -> m r) -> m r
runContT (ContT f) k = f k

mapContT :: forall r m a. (m r -> m r) -> ContT r m a -> ContT r m a
mapContT f m = ContT (\k -> f $ runContT m k)

withContT :: forall r m a b. ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b
withContT f m = ContT (\k -> (runContT m) (f k))

callCC :: forall r m a b. ((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC f = ContT (\k -> runContT (f (\a -> ContT (\_ -> k a))) k)

instance functorContT :: (Monad m) => Functor (ContT r m) where
  (<$>) f m = ContT (\k -> runContT m (\a -> k $ f a))

instance applyContT :: (Functor m, Monad m) => Apply (ContT r m) where
  (<*>) f v = ContT (\k -> runContT f $ (\g -> runContT v (\a -> (k $ g a))))

instance applicativeContT :: (Functor m, Monad m) => Applicative (ContT r m) where
  pure a = ContT (\k -> k a)

instance bindContT :: (Monad m) => Bind (ContT r m) where
  (>>=) m k = ContT (\k' -> runContT m (\a -> runContT (k a) k'))

instance monadContT :: (Monad m) => Monad (ContT r m)

instance monadTransContT :: MonadTrans (ContT r) where
  lift m = ContT (\k -> m >>= k)

module Control.Monad.Cont.Trans where

import Control.Monad.Trans

newtype ContT r m a = ContT ((a -> m r) -> m r)

runContT :: forall r m a. ContT r m a -> (a -> m r) -> m r
runContT (ContT f) k = f k

mapContT :: forall r m a. (m r -> m r) -> ContT r m a -> ContT r m a
mapContT f m = ContT (\k -> f $ runContT m k)

withContT :: forall r m a b. ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b
withContT f m = ContT (\k -> (runContT m) (f k))

callCC :: forall r m a b. ((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC f = ContT (\k -> runContT (f (\a -> ContT (\_ -> k a))) k)

instance functorContT :: (Monad m) => Functor (ContT r m) where
  (<$>) f m = ContT (\k -> runContT m (\a -> k $ f a))

instance appluContT :: (Functor m, Monad m) => Apply (ContT r m) where
  (<*>) f v = ContT (\k -> runContT f $ (\g -> runContT v (\a -> (k $ g a))))

instance applicativeContT :: (Functor m, Monad m) => Applicative (ContT r m) where
  pure a = ContT (\k -> k a)

instance bindContT :: (Monad m) => Bind (ContT r m) where
  (>>=) m k = ContT (\k' -> runContT m (\a -> runContT (k a) k'))

instance monadContT :: (Monad m) => Monad (ContT r m)

instance monadTransContT :: MonadTrans (ContT r) where
  lift m = ContT (\k -> m >>= k)


Read `moduleName`, `filename` and `errorCode` fields from JSON (#9)

module PscIde.Command where

import Prelude
import Control.Alt ((<|>))
import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (jsonEmptyObject, jsonSingletonObject, Json, toString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Encode (class EncodeJson, encodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (singleton)
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe)

data PursuitType = Package | Ident

instance showPursuitType :: Show PursuitType where
  show Package = "package"
  show Ident   = "completion"

instance encodePursuitType :: EncodeJson PursuitType where
  encodeJson = encodeJson <<< show

data Matcher =
  Flex String
  | Distance String Int

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject
  encodeJson (Distance q maxDist) =
    "matcher" := "distance"
    ~> "params" := (
       "search" := q
       ~> "maximumDistance" := maxDist
       ~> jsonEmptyObject
      )
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)

data Command =
  Cwd
  | Ls ListType
  | Quit
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher)
  | Pursuit PursuitType String
  | Type String (Array Filter)
  | AddClause String Boolean
  | CaseSplit String Int Int Boolean String
  | ImportCmd FileName (Maybe FileName) (Array Filter) ImportCommand
  | RebuildCmd String

data ListType = LoadedModules | Imports String | AvailableModules

type FileName = String
data ImportCommand = AddImplicitImport String | AddImport String

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson (Ls LoadedModules) =
    commandWrapper "list" ("type" := "loadedModules" ~> jsonEmptyObject)
  encodeJson (Ls AvailableModules) =
    commandWrapper "list" ("type" := "availableModules" ~> jsonEmptyObject)
  encodeJson (Ls (Imports fp)) =
    commandWrapper "list" ("type" := "import" ~> "file" := fp ~> jsonEmptyObject)
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeJson matcher)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )
  encodeJson (Type text filters) =
    commandWrapper "type" (
        "search" := encodeJson text
        ~> "filters" := (encodeJson filters)
        ~> jsonEmptyObject
      )
  encodeJson (AddClause line annotations) =
    commandWrapper "addClause" (
        "line" := encodeJson line
        ~> "annotations" := encodeJson annotations
        ~> jsonEmptyObject
      )
  encodeJson (CaseSplit line begin end annotations typ) =
    commandWrapper "caseSplit" (
        "line" := encodeJson line
        ~> "begin" := encodeJson begin
        ~> "end" := encodeJson end
        ~> "annotations" := encodeJson annotations
        ~> "type" := encodeJson typ
        ~> jsonEmptyObject
      )
  encodeJson (ImportCmd inFile outFile filters cmd) =
    commandWrapper "import" (
      "file" := encodeJson inFile
      ~> "outfile" := encodeJson outFile
      ~> "filters" := encodeJson filters
      ~> "importCommand" := encodeJson cmd
      ~> jsonEmptyObject
      )
  encodeJson (RebuildCmd file) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> jsonEmptyObject
      )

instance encodeImportCommand :: EncodeJson ImportCommand where
  encodeJson (AddImplicitImport ident) =
    "importCommand" := "addImplicitImport"
    ~> "module" := encodeJson ident
    ~> jsonEmptyObject
  encodeJson (AddImport mod) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> jsonEmptyObject

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype Completion = Completion (GenCompletion ())
newtype PursuitCompletion = PursuitCompletion (GenCompletion (package :: String))
newtype ModuleList = ModuleList (Array String)
newtype Message = Message String
newtype ImportList = ImportList (Array Import)
newtype Import = Import
  {
    moduleName :: String,
    importType :: ImportType,
    qualifier  :: Maybe String
  }

newtype RebuildError =
  RebuildError
  { position :: Maybe {line :: Int, column :: Int}
  , moduleName :: Maybe String
  , filename :: Maybe String
  , errorCode :: String
  , message :: String
  }
newtype RebuildResult = RebuildResult (Array RebuildError)

data ImportType = Implicit | Explicit (Array String) | Hiding (Array String)

data ImportResult = SuccessFile Message | SuccessText (Array String) | MultipleResults (Array Completion)

unwrapResponse :: forall a b. (DecodeJson a, DecodeJson b) => String -> Either String (Either a b)
unwrapResponse s = do
  json <- jsonParser s
  o <- decodeJson json
  resultType <- o .? "resultType"
  case resultType of
    "success" -> do
      result <- o .? "result"
      pure (Right result)
    _ -> do
      result <- o .? "result"
      pure (Left result)

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe (Left "Message not string") (Right <<< Message) $ toString json

instance decodeModuleList :: DecodeJson ModuleList where
  decodeJson json = ModuleList <$> decodeJson json

instance decodeCompletion :: DecodeJson Completion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "identifier"
    type' <- o .? "type"
    module' <- o .? "module"
    pure (Completion {identifier: identifier, type': type', module': module'})

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "ident"
    type' <- o .? "type"
    module' <- o .? "module"
    package <- o .? "package"
    pure (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package
      })

instance decodeImportList :: DecodeJson ImportList where
  decodeJson json = do
    imports <- decodeJson json
    pure (ImportList imports)

instance decodeImport :: DecodeJson Import where
  decodeJson json = do
    o <- decodeJson json
    moduleName <- o .? "module"
    importType <- o .? "importType"
    case importType of
      "implicit" -> do
        q <- (Just <$> o .? "qualifier") <|> pure Nothing
        pure $ Import {moduleName: moduleName, importType: Implicit, qualifier: q}
      "explicit" -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Explicit identifiers, qualifier: Nothing}
      "hiding"   -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Hiding identifiers, qualifier: Nothing}
      _ -> Left "unknown importType"

instance decodeImportResult :: DecodeJson ImportResult where
  decodeJson json = do
    (SuccessText <$> decodeJson json)
    <|> (SuccessFile <$> decodeJson json)
    <|> (MultipleResults <$> decodeJson json)
    <|> (Left "Couldn't parse as ImportResult")

instance decodeRebuildError :: DecodeJson RebuildError where
  decodeJson json = do
    o <- decodeJson json
    message <- o .? "message"
    errorCode <- o .? "errorCode"
    moduleName <- o .? "moduleName"
    filename <- o .? "filename"
    position <- pure $ eitherToMaybe do
      p <- o .? "position"
      { line: _, column: _ } <$> p .? "startLine" <*> p .? "startColumn"
    pure (RebuildError { errorCode, moduleName, filename, message, position})
    where
      eitherToMaybe = either (const Nothing) Just

instance decodeRebuildResult :: DecodeJson RebuildResult where
  decodeJson json = RebuildResult <$> (decodeJson json <|> (singleton <$> decodeJson json))

module PscIde.Command where

import Prelude
import Control.Alt ((<|>))
import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (jsonEmptyObject, jsonSingletonObject, Json, toString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Encode (class EncodeJson, encodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (singleton)
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe)

data PursuitType = Package | Ident

instance showPursuitType :: Show PursuitType where
  show Package = "package"
  show Ident   = "completion"

instance encodePursuitType :: EncodeJson PursuitType where
  encodeJson = encodeJson <<< show

data Matcher =
  Flex String
  | Distance String Int

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject
  encodeJson (Distance q maxDist) =
    "matcher" := "distance"
    ~> "params" := (
       "search" := q
       ~> "maximumDistance" := maxDist
       ~> jsonEmptyObject
      )
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)

data Command =
  Cwd
  | Ls ListType
  | Quit
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher)
  | Pursuit PursuitType String
  | Type String (Array Filter)
  | AddClause String Boolean
  | CaseSplit String Int Int Boolean String
  | ImportCmd FileName (Maybe FileName) (Array Filter) ImportCommand
  | RebuildCmd String

data ListType = LoadedModules | Imports String | AvailableModules

type FileName = String
data ImportCommand = AddImplicitImport String | AddImport String

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson (Ls LoadedModules) =
    commandWrapper "list" ("type" := "loadedModules" ~> jsonEmptyObject)
  encodeJson (Ls AvailableModules) =
    commandWrapper "list" ("type" := "availableModules" ~> jsonEmptyObject)
  encodeJson (Ls (Imports fp)) =
    commandWrapper "list" ("type" := "import" ~> "file" := fp ~> jsonEmptyObject)
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeJson matcher)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )
  encodeJson (Type text filters) =
    commandWrapper "type" (
        "search" := encodeJson text
        ~> "filters" := (encodeJson filters)
        ~> jsonEmptyObject
      )
  encodeJson (AddClause line annotations) =
    commandWrapper "addClause" (
        "line" := encodeJson line
        ~> "annotations" := encodeJson annotations
        ~> jsonEmptyObject
      )
  encodeJson (CaseSplit line begin end annotations typ) =
    commandWrapper "caseSplit" (
        "line" := encodeJson line
        ~> "begin" := encodeJson begin
        ~> "end" := encodeJson end
        ~> "annotations" := encodeJson annotations
        ~> "type" := encodeJson typ
        ~> jsonEmptyObject
      )
  encodeJson (ImportCmd inFile outFile filters cmd) =
    commandWrapper "import" (
      "file" := encodeJson inFile
      ~> "outfile" := encodeJson outFile
      ~> "filters" := encodeJson filters
      ~> "importCommand" := encodeJson cmd
      ~> jsonEmptyObject
      )
  encodeJson (RebuildCmd file) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> jsonEmptyObject
      )

instance encodeImportCommand :: EncodeJson ImportCommand where
  encodeJson (AddImplicitImport ident) =
    "importCommand" := "addImplicitImport"
    ~> "module" := encodeJson ident
    ~> jsonEmptyObject
  encodeJson (AddImport mod) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> jsonEmptyObject

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype Completion = Completion (GenCompletion ())
newtype PursuitCompletion = PursuitCompletion (GenCompletion (package :: String))
newtype ModuleList = ModuleList (Array String)
newtype Message = Message String
newtype ImportList = ImportList (Array Import)
newtype Import = Import
  {
    moduleName :: String,
    importType :: ImportType,
    qualifier  :: Maybe String
  }

newtype RebuildError =
  RebuildError
  { position :: Maybe {line :: Int, column :: Int}
  , message :: String
  }
newtype RebuildResult = RebuildResult (Array RebuildError)

data ImportType = Implicit | Explicit (Array String) | Hiding (Array String)

data ImportResult = SuccessFile Message | SuccessText (Array String) | MultipleResults (Array Completion)

unwrapResponse :: forall a b. (DecodeJson a, DecodeJson b) => String -> Either String (Either a b)
unwrapResponse s = do
  json <- jsonParser s
  o <- decodeJson json
  resultType <- o .? "resultType"
  case resultType of
    "success" -> do
      result <- o .? "result"
      pure (Right result)
    _ -> do
      result <- o .? "result"
      pure (Left result)

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe (Left "Message not string") (Right <<< Message) $ toString json

instance decodeModuleList :: DecodeJson ModuleList where
  decodeJson json = ModuleList <$> decodeJson json

instance decodeCompletion :: DecodeJson Completion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "identifier"
    type' <- o .? "type"
    module' <- o .? "module"
    pure (Completion {identifier: identifier, type': type', module': module'})

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "ident"
    type' <- o .? "type"
    module' <- o .? "module"
    package <- o .? "package"
    pure (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package
      })

instance decodeImportList :: DecodeJson ImportList where
  decodeJson json = do
    imports <- decodeJson json
    pure (ImportList imports)

instance decodeImport :: DecodeJson Import where
  decodeJson json = do
    o <- decodeJson json
    moduleName <- o .? "module"
    importType <- o .? "importType"
    case importType of
      "implicit" -> do
        q <- (Just <$> o .? "qualifier") <|> pure Nothing
        pure $ Import {moduleName: moduleName, importType: Implicit, qualifier: q}
      "explicit" -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Explicit identifiers, qualifier: Nothing}
      "hiding"   -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Hiding identifiers, qualifier: Nothing}
      _ -> Left "unknown importType"

instance decodeImportResult :: DecodeJson ImportResult where
  decodeJson json = do
    (SuccessText <$> decodeJson json)
    <|> (SuccessFile <$> decodeJson json)
    <|> (MultipleResults <$> decodeJson json)
    <|> (Left "Couldn't parse as ImportResult")

instance decodeRebuildError :: DecodeJson RebuildError where
  decodeJson json = do
    o <- decodeJson json
    message <- o .? "message"
    position <- pure $ eitherToMaybe do
      p <- o .? "position"
      { line: _, column: _ } <$> p .? "startLine" <*> p .? "startColumn"
    pure (RebuildError { message, position})
    where
      eitherToMaybe = either (const Nothing) Just

instance decodeRebuildResult :: DecodeJson RebuildResult where
  decodeJson json = RebuildResult <$> (decodeJson json <|> (singleton <$> decodeJson json))


[CSE-62] Fix view states of address page

module Explorer.View.Address where

import Prelude
import Data.Array (length, (!!))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (addNotFound, cAddress, common, cOf, cTransactions, address, addScan, addQrCode, addFinalBalance) as I18nL
import Explorer.Lenses.State (addressDetail, addressTxPagination, currentAddressSummary, currentCAddress, lang, viewStates)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), State)
import Explorer.Util.DOM (targetToHTMLInputElement)
import Explorer.Util.String (substitute)
import Explorer.View.Common (currencyCSSClass, emptyTxHeaderView, mkEmptyViewProps, mkTxBodyViewProps, mkTxHeaderViewProps, txBodyView, txPaginationView, txHeaderView)
import Network.RemoteData (RemoteData(..))
import Pos.Core.Lenses.Types (_Coin, getCoin)
import Pos.Explorer.Web.ClientTypes (CAddressSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, caAddress, caBalance, caTxList, caTxNum)
import Pux.Html (Html, div, text, h3, p) as P
import Pux.Html.Attributes (className, dangerouslySetInnerHTML, id_) as P

addressView :: State -> P.Html Action
addressView state =
    let lang' = state ^. lang in
    P.div
        [ P.className "explorer-address" ]
        [ P.div
            [ P.className "explorer-address__wrapper" ]
            [ P.div
                  [ P.className "explorer-address__container" ]
                  [ P.h3
                          [ P.className "headline"]
                          [ P.text $ translate (I18nL.common <<< I18nL.cAddress) lang' ]
                  , case state ^. currentAddressSummary of
                      NotAsked -> emptyAddressDetail ""
                      Loading -> emptyAddressDetail ""
                      Failure _ -> emptyAddressDetail <<< flip substitute
                                    ["" <> (state ^. (currentCAddress <<< _CAddress)) <> ""]
                                    $ translate (I18nL.address <<< I18nL.addNotFound) lang'
                      Success addressSummary ->
                          P.div
                              []
                              [ addressDetailView addressSummary lang'
                              , addressQr addressSummary lang'
                              ]
                      ]
                  ]
            , P.div
                [ P.className "explorer-address__wrapper" ]
                [ P.div
                      [ P.className "explorer-address__container" ]
                      [ P.h3
                          [ P.className "headline"]
                          [ P.text $ translate (I18nL.common <<< I18nL.cTransactions) lang' ]
                        , case state ^. currentAddressSummary of
                              NotAsked -> emptyTxHeaderView state
                              Loading -> emptyTxHeaderView state
                              Failure _ -> emptyTxHeaderView state
                              Success (CAddressSummary addressSummary) ->
                                  let txList = addressSummary ^. caTxList
                                      txPagination = state ^. (viewStates <<< addressDetail <<< addressTxPagination)
                                      currentTxBrief = txList !! (txPagination - 1)
                                  in
                                  P.div
                                      []
                                      [ txHeaderView lang' $ case currentTxBrief of
                                                                Nothing -> mkTxHeaderViewProps mkEmptyViewProps
                                                                Just txBrief -> mkTxHeaderViewProps txBrief
                                      , txBodyView $ case currentTxBrief of
                                                                  Nothing -> mkTxBodyViewProps mkEmptyViewProps
                                                                  Just txBrief -> mkTxBodyViewProps txBrief
                                      , txPaginationView
                                            { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                            , currentPage: txPagination
                                            , maxPage: length txList
                                            , changePageAction: AddressPaginateTxs
                                            , onFocusAction: SelectInputText <<< targetToHTMLInputElement
                                            }
                                      ]

                      ]
                ]
            ]

addressDetailView :: CAddressSummary -> Language -> P.Html Action
addressDetailView addressSummary lang =
    P.div
        [ P.className "address-detail" ]
        $ map addressDetailRow $ addressDetailRowItems addressSummary lang

addressQr :: CAddressSummary -> Language -> P.Html Action
addressQr _ lang =
    P.div
      [ P.className "qr" ]
      [ P.p
          [ P.className "tab" ]
          [ P.text $ translate (I18nL.address <<< I18nL.addQrCode) lang  ]
      , P.div
          [ P.className "qr__wrapper" ]
          [ P.div
              [ P.className "qr__image"
              , P.id_ "qr_image_id"
              ]
              []
            , P.p
                [ P.className "qr__description" ]
                [ P.text $ translate (I18nL.address <<< I18nL.addScan) lang ]
          ]
      ]

type SummaryRowItem =
    { label :: String
    , value :: String
    , currency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

addressDetailRowItems :: CAddressSummary -> Language -> SummaryItems
addressDetailRowItems (CAddressSummary address) lang =
    [ { label: translate (I18nL.common <<< I18nL.cAddress) lang
      , value: address ^. (caAddress <<< _CAddress)
      , currency: Nothing
    }
    , { label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , value: show $ address ^. caTxNum
      , currency: Nothing
    }
    , { label: translate (I18nL.address <<< I18nL.addFinalBalance) lang
      , value: show $ address ^. (caBalance <<< _Coin <<< getCoin)
      , currency: Just ADA
      }
    ]

addressDetailRow :: SummaryRowItem -> P.Html Action
addressDetailRow item =
    P.div
        [ P.className "address-detail__row" ]
        [ P.div
            [ P.className "address-detail__column column label" ]
            [ P.text item.label ]
        , P.div
              [ P.className $ "address-detail__column amount" <> currencyCSSClass item.currency ]
              [ P.text item.value ]
        ]

emptyAddressDetail :: String -> P.Html Action
emptyAddressDetail message =
    P.div
        [ P.className "explorer-address__container" ]
        [ P.div
            [ P.dangerouslySetInnerHTML message ]
            []
        ]

module Explorer.View.Address where

import Prelude
import Data.Array (length, (!!))
import Data.Lens ((^.))
import Data.Maybe (Maybe(..))
import Explorer.I18n.Lang (Language, translate)
import Explorer.I18n.Lenses (addNotFound, cAddress, common, cOf, cTransactions, address, addScan, addQrCode, addFinalBalance) as I18nL
import Explorer.Lenses.State (addressDetail, addressTxPagination, currentAddressSummary, currentCAddress, lang, viewStates)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), State)
import Explorer.Util.DOM (targetToHTMLInputElement)
import Explorer.Util.String (substitute)
import Explorer.View.Common (currencyCSSClass, emptyTxHeaderView, mkEmptyViewProps, mkTxBodyViewProps, mkTxHeaderViewProps, txBodyView, txPaginationView, txHeaderView)
import Network.RemoteData (RemoteData(..))
import Pos.Core.Lenses.Types (_Coin, getCoin)
import Pos.Explorer.Web.ClientTypes (CAddressSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, caAddress, caBalance, caTxList, caTxNum)
import Pux.Html (Html, div, text, h3, p) as P
import Pux.Html.Attributes (className, dangerouslySetInnerHTML, id_) as P

addressView :: State -> P.Html Action
addressView state =
    let lang' = state ^. lang in
    P.div
        [ P.className "explorer-address" ]
        [ P.div
            [ P.className "explorer-address__wrapper" ]
            [ P.div
                  [ P.className "explorer-address__container" ]
                  [ P.h3
                          [ P.className "headline"]
                          [ P.text $ translate (I18nL.common <<< I18nL.cAddress) lang' ]
                  , case state ^. currentAddressSummary of
                      NotAsked -> emptyAddressDetail ""
                      -- Loading -> emptyAddressWrapper ""
                      Loading -> emptyAddressDetail <<< flip substitute
                                    ["" <> (state ^. (currentCAddress <<< _CAddress)) <> ""]
                                    $ translate (I18nL.address <<< I18nL.addNotFound) lang'
                      Failure _ -> emptyAddressDetail $ translate (I18nL.address <<< I18nL.addNotFound) lang'
                      Success addressSummary ->
                          P.div
                              []
                              [ addressDetailView addressSummary lang'
                              , addressQr addressSummary lang'
                              ]
                      ]
                  ]
            , P.div
                [ P.className "explorer-address__wrapper" ]
                [ P.div
                      [ P.className "explorer-address__container" ]
                      [ P.h3
                          [ P.className "headline"]
                          [ P.text $ translate (I18nL.common <<< I18nL.cTransactions) lang' ]
                        , case state ^. currentAddressSummary of
                              NotAsked -> emptyTxHeaderView state
                              Loading -> emptyTxHeaderView state
                              Failure _ -> emptyTxHeaderView state
                              Success (CAddressSummary addressSummary) ->
                                  let txList = addressSummary ^. caTxList
                                      txPagination = state ^. (viewStates <<< addressDetail <<< addressTxPagination)
                                      currentTxBrief = txList !! (txPagination - 1)
                                  in
                                  P.div
                                      []
                                      [ txHeaderView lang' $ case currentTxBrief of
                                                                Nothing -> mkTxHeaderViewProps mkEmptyViewProps
                                                                Just txBrief -> mkTxHeaderViewProps txBrief
                                      , txBodyView $ case currentTxBrief of
                                                                  Nothing -> mkTxBodyViewProps mkEmptyViewProps
                                                                  Just txBrief -> mkTxBodyViewProps txBrief
                                      , txPaginationView
                                            { label: translate (I18nL.common <<< I18nL.cOf) $ lang'
                                            , currentPage: txPagination
                                            , maxPage: length txList
                                            , changePageAction: AddressPaginateTxs
                                            , onFocusAction: SelectInputText <<< targetToHTMLInputElement
                                            }
                                      ]

                      ]
                ]
            ]

addressDetailView :: CAddressSummary -> Language -> P.Html Action
addressDetailView addressSummary lang =
    P.div
        [ P.className "address-detail" ]
        $ map addressDetailRow $ addressDetailRowItems addressSummary lang

addressQr :: CAddressSummary -> Language -> P.Html Action
addressQr _ lang =
    P.div
      [ P.className "qr" ]
      [ P.p
          [ P.className "tab" ]
          [ P.text $ translate (I18nL.address <<< I18nL.addQrCode) lang  ]
      , P.div
          [ P.className "qr__wrapper" ]
          [ P.div
              [ P.className "qr__image"
              , P.id_ "qr_image_id"
              ]
              []
            , P.p
                [ P.className "qr__description" ]
                [ P.text $ translate (I18nL.address <<< I18nL.addScan) lang ]
          ]
      ]

type SummaryRowItem =
    { label :: String
    , value :: String
    , currency :: Maybe CCurrency
    }

type SummaryItems = Array SummaryRowItem

addressDetailRowItems :: CAddressSummary -> Language -> SummaryItems
addressDetailRowItems (CAddressSummary address) lang =
    [ { label: translate (I18nL.common <<< I18nL.cAddress) lang
      , value: address ^. (caAddress <<< _CAddress)
      , currency: Nothing
    }
    , { label: translate (I18nL.common <<< I18nL.cTransactions) lang
      , value: show $ address ^. caTxNum
      , currency: Nothing
    }
    , { label: translate (I18nL.address <<< I18nL.addFinalBalance) lang
      , value: show $ address ^. (caBalance <<< _Coin <<< getCoin)
      , currency: Just ADA
      }
    ]

addressDetailRow :: SummaryRowItem -> P.Html Action
addressDetailRow item =
    P.div
        [ P.className "address-detail__row" ]
        [ P.div
            [ P.className "address-detail__column column label" ]
            [ P.text item.label ]
        , P.div
              [ P.className $ "address-detail__column amount" <> currencyCSSClass item.currency ]
              [ P.text item.value ]
        ]

emptyAddressDetail :: String -> P.Html Action
emptyAddressDetail message =
    P.div
        [ P.className "explorer-address__container" ]
        [ P.div
            [ P.dangerouslySetInnerHTML message ]
            []
        ]


Add functions for zooming/rescaling browser intervals

module Genetics.Browser.Types.Coordinates where

import Prelude

import Control.Alternative (empty)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Foldable (length, sum)
import Data.Foreign.Class (class Decode, class Encode)
import Data.Int as Int
import Data.Lens (APrism', Iso', Lens', Prism', Traversal', filtered, foldMapOf, iso, lens, preview, previewOn, prism', takeBoth, traversed, view, (^.))
import Data.Lens as Lens
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.Lens.Types (Iso')
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Choice (fanin)
import Data.Profunctor.Strong (fanout, splitStrong)
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Debug.Trace as Debug
import Genetics.Browser.Types (Bp(..), Point)
import Genetics.Browser.View (Pixels)
import Unsafe.Coerce (unsafeCoerce)

-- The global coordinate system works by taking the sum of the chromosome sizes;
-- we represent it using a BigInt

-- Consider making it a wrapper on Ratio BigInt instead.
-- Would ensure exactness when moving between global & interval points...
-- ... while that shouldn't be a problem anyway, it would make things feel safer.
newtype BrowserPoint = BPoint BigInt

derive instance eqBrowserPoint :: Eq BrowserPoint
derive instance ordBrowserPoint :: Ord BrowserPoint
derive instance newtypeBrowserPoint :: Newtype BrowserPoint _

derive newtype instance ringBrowserPoint :: Ring BrowserPoint
derive newtype instance semiringBrowserPoint :: Semiring BrowserPoint
derive newtype instance commutativeringBrowserPoint :: CommutativeRing BrowserPoint
derive newtype instance euclideanringBrowserPoint :: EuclideanRing BrowserPoint

-- Subsets of the global coordinate system are defined by some interval,
--

-- data Interval c = Interval c c

type Interval = Pair

type RelPoint = Ratio BigInt
-- data IntervalPoint c = IntervalPoint (Interval c) RelPoint

relPointToNumber :: RelPoint -> Number
relPointToNumber p =
  let d = Ratio.denominator p
      n = Ratio.numerator p
      qt = BigInt.toNumber $ n / d
      -- rm = BigInt.toNumber $ case n `mod` d of
      --                          0 -> 1
      --                          x -> x
      -- TODO be safer by using Number.EPSILON etc.
      -- eps =  2.220446049250313e-16
      -- epsD =  BigInt.fromString "22204460492503130000000000000000"
  in qt -- + (rm / (BigInt.toNumber d))

intervalSize :: forall c.
                Ring c
             => Interval c
             -> c
intervalSize (Pair l r) = r - l

inInterval :: forall c.
               Ord c
            => c
            -> Interval c
            -> Boolean
inInterval p (Pair l r) = l <= p && p <= r

-- TODO test this
intervalsOverlap :: forall c.
                    Ord c
                 => Interval c
                 -> Interval c
                 -> Boolean
intervalsOverlap (Pair l1 r1) (Pair l2 r2) =
  let (Pair l1' r1') = Pair (min l1 l2) (min r1 r2)
      (Pair l2' r2') = Pair (max l1 l2) (max r1 r2)
  in r1' >= l2'

p0 = Pair 0 0
p1 = Pair 0 2
p2 = Pair 2 4
p3 = Pair 3 4
p4 = Pair (-2) (-1)

coveringIntervals :: forall f i c.
                     Ord c
                  => Filterable f
                  => Interval c
                  -> f (Interval c)
                  -> f (Interval c)
coveringIntervals iv = filter (intervalsOverlap iv)

-- type ChrInterval c = { interval :: Interval c, chrSize :: Number }

type CoordInterval i c = { index :: i
                         , interval :: Interval c
                         , chrSize :: Bp }

_Index :: forall i c. Lens' (CoordInterval i c) i
_Index = Lens.prop (SProxy :: SProxy "index")

_Interval :: forall i c. Lens' (CoordInterval i c) (Interval c)
_Interval = Lens.prop (SProxy :: SProxy "interval")

_ChrSize :: forall i c. Lens' (CoordInterval i c) Bp
_ChrSize = Lens.prop (SProxy :: SProxy "chrSize")

type CoordSysRec i c =
  { size :: c
  , padding :: c
  -- , intervals :: Array (Tuple i (Interval c))
  , intervals :: Array (CoordInterval i c)
  }

newtype CoordSys i c =
  CoordSys (CoordSysRec i c)

-- traversed :: forall t a b. Traversable t => Traversal (t a) (t b) a b
_CoordSys :: forall i c. Lens' (CoordSys i c) (CoordSysRec i c)
_CoordSys = lens (\(CoordSys x) -> x) (\(CoordSys _) x -> CoordSys x)

_BrowserIntervals :: forall i c. Traversal' (CoordSys i c) (CoordInterval i c)
_BrowserIntervals = _CoordSys <<<
                    Lens.prop (SProxy :: SProxy "intervals") <<<
                    traversed

_BrowserSize :: forall i c. Lens' (CoordSys i c) c
_BrowserSize = _CoordSys <<<
               Lens.prop (SProxy :: SProxy "size")

_BrowserPadding :: forall i c. Lens' (CoordSys i c) c
_BrowserPadding = _CoordSys <<<
               Lens.prop (SProxy :: SProxy "padding")

findIntervalFromGlobal :: forall f i c r.
                          Ord c
                       => c
                       -> Array { interval :: Interval c | r }
                       -> Maybe { interval :: Interval c | r }
findIntervalFromGlobal x = Array.find (inInterval x <<< _.interval)

findBrowserInterval :: forall i c.
                       Ord c
                    => CoordSys i c
                    -> c
                    -> Maybe (CoordInterval i c)
findBrowserInterval cs x = previewOn cs
                            (_BrowserIntervals <<<
                             Lens.filtered
                             (inInterval x <<< view _Interval))

viewIntervals :: forall i c.
                 Ord c
              => CoordSys i c
              -> Interval c
              -> Array (CoordInterval i c)
viewIntervals cs vw = foldMapOf inView pure cs
  where inView = _BrowserIntervals <<<
                 Lens.filtered (intervalsOverlap vw <<< view _Interval)

globalToInterval :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> c
                 -> RelPoint
globalToInterval v x = globalToInterval' (map unwrap v) (unwrap x)

globalToInterval' :: forall c.
                     Ord c
                  => EuclideanRing c
                  => Interval c
                  -> c
                  -> Ratio c
globalToInterval' (Pair l r) x =
  let n = x - l
      d = max one (r - l)
  in n % d

-- Global <-> Interval are isomorphic for big enough intervals...
intervalToGlobal :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> RelPoint
                 -> c
intervalToGlobal v x = wrap $ intervalToGlobal' (map unwrap v) x

intervalToGlobal' :: forall c.
                     Ord c
                  => Show c
                  => EuclideanRing c
                  => Interval c
                  -> Ratio c
                  -> c
intervalToGlobal' iv@(Pair l r) p =
  let d1 = max one (r - l)
      d2 = Ratio.denominator p
      a = d1 / d2
      n = a * Ratio.numerator p
  in l + n

offsets :: BigInt -> Array BigInt -> Array (Pair BigInt)
offsets pad xs = ivals
  where os = Array.scanl (\x y -> pad + x + y) zero xs
        ivals = Array.zipWith Pair (zero `Array.cons` os) os

mkCoordSys :: forall i c.
           Array (Tuple i BigInt)
        -> BigInt
        -> CoordSys i BrowserPoint
mkCoordSys chrs pad = CoordSys { size
                               , intervals
                               , padding
                               }
  where (Tuple ids sizes) = Array.unzip chrs
        ivals = (map <<< map) wrap $ offsets pad sizes

        f :: i -> BigInt -> { index :: i, chrSize :: Bp }
        f index s = { index, chrSize: wrap $ BigInt.toNumber s }

        g :: Interval BrowserPoint -> { index :: i, chrSize :: _ } -> _
        g interval { index, chrSize } = { interval, index, chrSize }

        intervals :: Array (CoordInterval i _)
        intervals = Array.zipWith g ivals (uncurry f <$> chrs)

        size' = (sum sizes) + (length sizes * pad)
        size :: BrowserPoint
        size = wrap size'
        padding :: BrowserPoint
        padding = wrap pad

canvasToView :: forall r.
                { width :: Number | r }
             -> Number
             -> RelPoint
canvasToView {width} x = globalToInterval' (Pair zero w') x'
  where (Pair x' w') = BigInt.fromInt <<< Int.round <$> Pair x width

canvasToBrowserPoint :: forall r.
                        { width :: Number | r }
                     -> Interval BrowserPoint
                     -> Number
                     -> BrowserPoint
canvasToBrowserPoint cw v@(Pair vL vR) x =
  intervalToGlobal v $ (canvasToView cw x)

browserPointToCanvas :: forall r.
                        { width :: Number | r }
                     -> Interval BrowserPoint
                     -> BrowserPoint
                     -> Number
browserPointToCanvas screenSize v@(Pair vL vR) p = relPointToNumber pixels'
  where viewSize :: BigInt
        viewSize = unwrap $ intervalSize v
        width' = BigInt.fromInt $ Int.round screenSize.width
        -- Pixels/BrowserPoint
        scale :: Ratio BigInt
        scale = width' % viewSize
        pixels' = (unwrap (p - vL) % one) * scale

intervalToScreen :: forall i c r.
                    { width :: Number | r }
                 -> Interval BrowserPoint
                 -> Interval BrowserPoint
                 -> { width :: Number, offset :: Number }
intervalToScreen screen v interval = {width, offset}
  where (Pair l r) = browserPointToCanvas screen v <$> interval
        width = r - l
        offset = l

shiftIntervalBy :: forall c.
                   Newtype c BigInt
                => Interval c
                -> Ratio BigInt
                -> Interval c
shiftIntervalBy v rat = wrap <$> shiftIntervalBy' (unwrap <$> v) rat

shiftIntervalBy' :: forall c.
                    EuclideanRing c
                 => Interval c
                 -> Ratio c
                 -> Interval c
shiftIntervalBy' v@(Pair l r) rat =
  let diff = ((r - l) * (Ratio.numerator rat)) / (Ratio.denominator rat)
  in Pair (l + diff) (r + diff)

zoomIntervalBy :: forall c.
                  Newtype c BigInt
               => Interval c
               -> Ratio BigInt
               -> Interval c
zoomIntervalBy v r = wrap <$> zoomIntervalBy' (unwrap <$> v) r

zoomIntervalBy' :: forall c.
                   EuclideanRing c
                => Interval c
                -> Ratio c
                -> Interval c
zoomIntervalBy' v@(Pair l r) rat =
  let diff = ((r - l) * (Ratio.numerator rat)) / (Ratio.denominator rat)
  in Pair (l - diff) (r + diff)

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (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}

module Genetics.Browser.Types.Coordinates where

import Prelude

import Control.Alternative (empty)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Foldable (length, sum)
import Data.Foreign.Class (class Decode, class Encode)
import Data.Int as Int
import Data.Lens (APrism', Iso', Lens', Prism', Traversal', filtered, foldMapOf, iso, lens, preview, previewOn, prism', takeBoth, traversed, view, (^.))
import Data.Lens as Lens
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.Lens.Types (Iso')
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Choice (fanin)
import Data.Profunctor.Strong (fanout, splitStrong)
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Debug.Trace as Debug
import Genetics.Browser.Types (Bp(..), Point)
import Genetics.Browser.View (Pixels)
import Unsafe.Coerce (unsafeCoerce)

-- The global coordinate system works by taking the sum of the chromosome sizes;
-- we represent it using a BigInt

-- Consider making it a wrapper on Ratio BigInt instead.
-- Would ensure exactness when moving between global & interval points...
-- ... while that shouldn't be a problem anyway, it would make things feel safer.
newtype BrowserPoint = BPoint BigInt

derive instance eqBrowserPoint :: Eq BrowserPoint
derive instance ordBrowserPoint :: Ord BrowserPoint
derive instance newtypeBrowserPoint :: Newtype BrowserPoint _

derive newtype instance ringBrowserPoint :: Ring BrowserPoint
derive newtype instance semiringBrowserPoint :: Semiring BrowserPoint
derive newtype instance commutativeringBrowserPoint :: CommutativeRing BrowserPoint
derive newtype instance euclideanringBrowserPoint :: EuclideanRing BrowserPoint

-- Subsets of the global coordinate system are defined by some interval,
--

-- data Interval c = Interval c c

type Interval = Pair

type RelPoint = Ratio BigInt
-- data IntervalPoint c = IntervalPoint (Interval c) RelPoint

relPointToNumber :: RelPoint -> Number
relPointToNumber p =
  let d = Ratio.denominator p
      n = Ratio.numerator p
      qt = BigInt.toNumber $ n / d
      -- rm = BigInt.toNumber $ case n `mod` d of
      --                          0 -> 1
      --                          x -> x
      -- TODO be safer by using Number.EPSILON etc.
      -- eps =  2.220446049250313e-16
      -- epsD =  BigInt.fromString "22204460492503130000000000000000"
  in qt -- + (rm / (BigInt.toNumber d))

intervalSize :: forall c.
                Ring c
             => Interval c
             -> c
intervalSize (Pair l r) = r - l

inInterval :: forall c.
               Ord c
            => c
            -> Interval c
            -> Boolean
inInterval p (Pair l r) = l <= p && p <= r

-- TODO test this
intervalsOverlap :: forall c.
                    Ord c
                 => Interval c
                 -> Interval c
                 -> Boolean
intervalsOverlap (Pair l1 r1) (Pair l2 r2) =
  let (Pair l1' r1') = Pair (min l1 l2) (min r1 r2)
      (Pair l2' r2') = Pair (max l1 l2) (max r1 r2)
  in r1' >= l2'

p0 = Pair 0 0
p1 = Pair 0 2
p2 = Pair 2 4
p3 = Pair 3 4
p4 = Pair (-2) (-1)

coveringIntervals :: forall f i c.
                     Ord c
                  => Filterable f
                  => Interval c
                  -> f (Interval c)
                  -> f (Interval c)
coveringIntervals iv = filter (intervalsOverlap iv)

-- type ChrInterval c = { interval :: Interval c, chrSize :: Number }

type CoordInterval i c = { index :: i
                         , interval :: Interval c
                         , chrSize :: Bp }

_Index :: forall i c. Lens' (CoordInterval i c) i
_Index = Lens.prop (SProxy :: SProxy "index")

_Interval :: forall i c. Lens' (CoordInterval i c) (Interval c)
_Interval = Lens.prop (SProxy :: SProxy "interval")

_ChrSize :: forall i c. Lens' (CoordInterval i c) Bp
_ChrSize = Lens.prop (SProxy :: SProxy "chrSize")

type CoordSysRec i c =
  { size :: c
  , padding :: c
  -- , intervals :: Array (Tuple i (Interval c))
  , intervals :: Array (CoordInterval i c)
  }

newtype CoordSys i c =
  CoordSys (CoordSysRec i c)

-- traversed :: forall t a b. Traversable t => Traversal (t a) (t b) a b
_CoordSys :: forall i c. Lens' (CoordSys i c) (CoordSysRec i c)
_CoordSys = lens (\(CoordSys x) -> x) (\(CoordSys _) x -> CoordSys x)

_BrowserIntervals :: forall i c. Traversal' (CoordSys i c) (CoordInterval i c)
_BrowserIntervals = _CoordSys <<<
                    Lens.prop (SProxy :: SProxy "intervals") <<<
                    traversed

_BrowserSize :: forall i c. Lens' (CoordSys i c) c
_BrowserSize = _CoordSys <<<
               Lens.prop (SProxy :: SProxy "size")

_BrowserPadding :: forall i c. Lens' (CoordSys i c) c
_BrowserPadding = _CoordSys <<<
               Lens.prop (SProxy :: SProxy "padding")

findIntervalFromGlobal :: forall f i c r.
                          Ord c
                       => c
                       -> Array { interval :: Interval c | r }
                       -> Maybe { interval :: Interval c | r }
findIntervalFromGlobal x = Array.find (inInterval x <<< _.interval)

findBrowserInterval :: forall i c.
                       Ord c
                    => CoordSys i c
                    -> c
                    -> Maybe (CoordInterval i c)
findBrowserInterval cs x = previewOn cs
                            (_BrowserIntervals <<<
                             Lens.filtered
                             (inInterval x <<< view _Interval))

viewIntervals :: forall i c.
                 Ord c
              => CoordSys i c
              -> Interval c
              -> Array (CoordInterval i c)
viewIntervals cs vw = foldMapOf inView pure cs
  where inView = _BrowserIntervals <<<
                 Lens.filtered (intervalsOverlap vw <<< view _Interval)

globalToInterval :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> c
                 -> RelPoint
globalToInterval v x = globalToInterval' (map unwrap v) (unwrap x)

globalToInterval' :: forall c.
                     Ord c
                  => EuclideanRing c
                  => Interval c
                  -> c
                  -> Ratio c
globalToInterval' (Pair l r) x =
  let n = x - l
      d = max one (r - l)
  in n % d

-- Global <-> Interval are isomorphic for big enough intervals...
intervalToGlobal :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> RelPoint
                 -> c
intervalToGlobal v x = wrap $ intervalToGlobal' (map unwrap v) x

intervalToGlobal' :: forall c.
                     Ord c
                  => Show c
                  => EuclideanRing c
                  => Interval c
                  -> Ratio c
                  -> c
intervalToGlobal' iv@(Pair l r) p =
  let d1 = max one (r - l)
      d2 = Ratio.denominator p
      a = d1 / d2
      n = a * Ratio.numerator p
  in l + n

offsets :: BigInt -> Array BigInt -> Array (Pair BigInt)
offsets pad xs = ivals
  where os = Array.scanl (\x y -> pad + x + y) zero xs
        ivals = Array.zipWith Pair (zero `Array.cons` os) os

mkCoordSys :: forall i c.
           Array (Tuple i BigInt)
        -> BigInt
        -> CoordSys i BrowserPoint
mkCoordSys chrs pad = CoordSys { size
                               , intervals
                               , padding
                               }
  where (Tuple ids sizes) = Array.unzip chrs
        ivals = (map <<< map) wrap $ offsets pad sizes

        f :: i -> BigInt -> { index :: i, chrSize :: Bp }
        f index s = { index, chrSize: wrap $ BigInt.toNumber s }

        g :: Interval BrowserPoint -> { index :: i, chrSize :: _ } -> _
        g interval { index, chrSize } = { interval, index, chrSize }

        intervals :: Array (CoordInterval i _)
        intervals = Array.zipWith g ivals (uncurry f <$> chrs)

        size' = (sum sizes) + (length sizes * pad)
        size :: BrowserPoint
        size = wrap size'
        padding :: BrowserPoint
        padding = wrap pad

canvasToView :: forall r.
                { width :: Number | r }
             -> Number
             -> RelPoint
canvasToView {width} x = globalToInterval' (Pair zero w') x'
  where (Pair x' w') = BigInt.fromInt <<< Int.round <$> Pair x width

canvasToBrowserPoint :: forall r.
                        { width :: Number | r }
                     -> Interval BrowserPoint
                     -> Number
                     -> BrowserPoint
canvasToBrowserPoint cw v@(Pair vL vR) x =
  intervalToGlobal v $ (canvasToView cw x)

browserPointToCanvas :: forall r.
                        { width :: Number | r }
                     -> Interval BrowserPoint
                     -> BrowserPoint
                     -> Number
browserPointToCanvas screenSize v@(Pair vL vR) p = relPointToNumber pixels'
  where viewSize :: BigInt
        viewSize = unwrap $ intervalSize v
        width' = BigInt.fromInt $ Int.round screenSize.width
        -- Pixels/BrowserPoint
        scale :: Ratio BigInt
        scale = width' % viewSize
        pixels' = (unwrap (p - vL) % one) * scale

intervalToScreen :: forall i c r.
                    { width :: Number | r }
                 -> Interval BrowserPoint
                 -> Interval BrowserPoint
                 -> { width :: Number, offset :: Number }
intervalToScreen screen v interval = {width, offset}
  where (Pair l r) = browserPointToCanvas screen v <$> interval
        width = r - l
        offset = l

shiftIntervalBy :: forall c.
                   Newtype c BigInt
                => Interval c
                -> Ratio BigInt
                -> Interval c
shiftIntervalBy v rat = wrap <$> shiftIntervalBy' (unwrap <$> v) rat

shiftIntervalBy' :: forall c.
                    EuclideanRing c
                 => Interval c
                 -> Ratio c
                 -> Interval c
shiftIntervalBy' v@(Pair l r) rat =
  let diff = ((r - l) * (Ratio.numerator rat)) / (Ratio.denominator rat)
      v' = Pair (l + diff) (r + diff)
  in v'

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (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}


Add divisionRing instance for ApproxNumber (to support division law checking in strongcheck-laws)

module Test.StrongCheck.Data.ApproxNumber where

import Prelude

import Test.StrongCheck.Arbitrary (class Coarbitrary, class Arbitrary, coarbitrary, arbitrary)

-- | A newtype for `Number` whose `Eq` instance uses an epsilon value to allow
-- | for precision erros when comparing.
newtype ApproxNumber = ApproxNumber Number

-- Approximate equality comparison
approximateEqual :: Number -> Number -> Boolean
approximateEqual x y = (y - x) <= epsilon && (y - x) >= (-epsilon)
  where
  epsilon = 0.00000001

infix 2 approximateEqual as =~=

instance arbitraryApproxNumber :: Arbitrary ApproxNumber where
  arbitrary = ApproxNumber <$> arbitrary

instance coarbitraryApproxNumber :: Coarbitrary ApproxNumber where
  coarbitrary (ApproxNumber n) = coarbitrary n

instance eqApproxNumber :: Eq ApproxNumber where
  eq (ApproxNumber x) (ApproxNumber y) = x =~= y

instance ordApproxNumber :: Ord ApproxNumber where
  compare (ApproxNumber x) (ApproxNumber y) = compare x y

instance semiringApproxNumber :: Semiring ApproxNumber where
  add (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x + y)
  zero = ApproxNumber zero
  mul (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x * y)
  one = ApproxNumber one

instance ringApproxNumber :: Ring ApproxNumber where
  sub (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x - y)

instance commutativeRingApproxNumber :: CommutativeRing ApproxNumber

instance divisionRingApproxNumber :: DivisionRing ApproxNumber where
  recip (ApproxNumber x) = ApproxNumber (1.0 / x)

instance euclideanRingApproxNumber :: EuclideanRing ApproxNumber where
  degree (ApproxNumber x) = degree x
  div (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x / y)
  mod (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x `mod` y)

module Test.StrongCheck.Data.ApproxNumber where

import Prelude

import Test.StrongCheck.Arbitrary (class Coarbitrary, class Arbitrary, coarbitrary, arbitrary)

-- | A newtype for `Number` whose `Eq` instance uses an epsilon value to allow
-- | for precision erros when comparing.
newtype ApproxNumber = ApproxNumber Number

-- Approximate equality comparison
approximateEqual :: Number -> Number -> Boolean
approximateEqual x y = (y - x) <= epsilon && (y - x) >= (-epsilon)
  where
  epsilon = 0.00000001

infix 2 approximateEqual as =~=

instance arbitraryApproxNumber :: Arbitrary ApproxNumber where
  arbitrary = ApproxNumber <$> arbitrary

instance coarbitraryApproxNumber :: Coarbitrary ApproxNumber where
  coarbitrary (ApproxNumber n) = coarbitrary n

instance eqApproxNumber :: Eq ApproxNumber where
  eq (ApproxNumber x) (ApproxNumber y) = x =~= y

instance ordApproxNumber :: Ord ApproxNumber where
  compare (ApproxNumber x) (ApproxNumber y) = compare x y

instance semiringApproxNumber :: Semiring ApproxNumber where
  add (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x + y)
  zero = ApproxNumber zero
  mul (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x * y)
  one = ApproxNumber one

instance ringApproxNumber :: Ring ApproxNumber where
  sub (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x - y)

instance commutativeRingApproxNumber :: CommutativeRing ApproxNumber

instance euclideanRingApproxNumber :: EuclideanRing ApproxNumber where
  degree (ApproxNumber x) = degree x
  div (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x / y)
  mod (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x `mod` y)


Use SpecEffects in example

Use SpecEffects in example

module Main where

import Prelude
import Control.Monad.Aff (later')
import Control.Monad.Eff (Eff)
import Test.Spec (SpecEffects, pending, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (run)

main :: Eff (SpecEffects ()) Unit
main = run [consoleReporter] do
  describe "purescript-spec" do
    describe "Attributes" do
      it "awesome" do
        let isAwesome = true
        isAwesome `shouldEqual` true
      pending "feature complete"
    describe "Features" do
      it "runs in NodeJS" $ pure unit
      it "runs in the browser" $ pure unit
      it "supports streaming reporters" $ pure unit
      it "supports async specs" do
        res <- later' 100 $ pure "Alligator"
        res `shouldEqual` "Alligator"
      it "is PureScript 0.10.x compatible" $ pure unit

module Main where

import Prelude
import Control.Monad.Aff (later')
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Timer (TIMER)
import Node.Process (PROCESS)
import Test.Spec (pending, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (run)

main
  :: Eff
     ( process :: PROCESS
     , console :: CONSOLE
     , timer :: TIMER
     , avar :: AVAR
     )
     Unit
main = run [consoleReporter] do
  describe "purescript-spec" do
    describe "Attributes" do
      it "awesome" do
        let isAwesome = true
        isAwesome `shouldEqual` true
      pending "feature complete"
    describe "Features" do
      it "runs in NodeJS" $ pure unit
      it "runs in the browser" $ pure unit
      it "supports streaming reporters" $ pure unit
      it "supports async specs" do
        res <- later' 100 $ pure "Alligator"
        res `shouldEqual` "Alligator"
      it "is PureScript 0.10.x compatible" $ pure unit