updated tests

updated tests

module Main where

import Data.Array
import Data.Maybe

import Control.Monad.Eff
import Debug.Trace

import Data.DOM.Simple.Types
import Data.DOM.Simple.Element
import Data.DOM.Simple.Document
import Data.DOM.Simple.Window
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Events
import Data.DOM.Simple.Navigator

import Test.QuickCheck

foreign import inspect
  "function inspect(msg) { console.log(msg); }"
  :: forall a. a -> Unit

foreign import tagname
  "function tagname(obj) { return obj.tagName; }"
  :: forall a. a -> String

checkTagName shouldBe element = do
  let name = tagname element
  quickCheck' 1 $ name == shouldBe

checkContents shouldBe element = do
  contents <- textContent (element :: HTMLElement)
  quickCheck' 1 $ contents == shouldBe

checkValue shouldBe element = do
  val <- value (element :: HTMLElement)
  quickCheck' 1 $ val == shouldBe

main = do
  doc <- document globalWindow

  trace "Able to get the title of a document"

  docTitle <- title doc
  quickCheck' 1 $ docTitle == "testTitle"

  -- attrib <- "#testDiv1" `getAttribute` "hello"

  trace "Able to set the title of a document"

  setTitle "modifiedTitle" doc
  docTitle1 <- title doc

  quickCheck' 1 $ docTitle1 == "modifiedTitle"

  trace "Able to get the body element of a document"

  docBody <- body doc

  checkTagName "BODY" docBody

  trace "Able to look up elements"

  Just testDiv1 <- getElementById "test1" doc

  checkTagName "DIV" testDiv1
  checkContents "testContent1" testDiv1

  Just testDiv2 <- querySelector ".test2" doc

  checkTagName "DIV" testDiv2
  checkContents "testContent2" testDiv2

  Just testDiv3 <- querySelector "test3" doc

  checkTagName "TEST3" testDiv3
  checkContents "testContent3" testDiv3

  trace "Able to modify an elements contents"

  setTextContent "Hello" testDiv1

  checkContents "Hello" testDiv1

  trace "Able to modify a form element's value"

  Just testInput1 <- getElementById "input1" doc

  setValue "foo bar baz" testInput1

  checkValue "foo bar baz" testInput1

  trace "Able to set an attribute on an element"

  setAttribute "data-test" "hello" testDiv1
  testDiv1Attribute <- getAttribute "data-test" testDiv1

  quickCheck' 1 $ testDiv1Attribute == "hello"

  trace "Able to remove an attribute from an element"

  testDiv1HasAttribute <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute == true
  removeAttribute "data-test" testDiv1
  testDiv1HasAttribute' <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute' == false

  navigator <- navigator globalWindow
  trace "Able to receive the appName from navigator"
  appName navigator >>= (\name -> quickCheck' 1 $ name == "Node.js jsDom")
  trace "Able to receive the appVersion from navigator"
  appVersion navigator >>= (\name -> quickCheck' 1 $ name == "Node.js jsDom")
  trace "Able to receive the language from navigator"
  language navigator >>= (\name -> quickCheck' 1 $ name == "en-US")
  trace "Able to receive the userAgent from navigator"
  userAgent navigator >>= (\name -> quickCheck' 1 $ name == "Mozilla/5.0 Chrome/10.0.613.0 Safari/534.15 Zombie.js/2.0.0-alpha31")

  -- Unavailable in Zombie
  -- trace "Able to add a class"

  --hasTestClass1 <- classContains "testClass" testDiv1
  -- quickCheck' 1 $ hasTestClass1 == false

  -- classAdd "testClass" testDiv1
  -- hasTestClass2 <- classContains "testClass" testDiv1
  -- quickCheck' 1 $ hasTestClass2 == true

module Main where

import Data.Array
import Data.Maybe

import Control.Monad.Eff
import Debug.Trace

import Data.DOM.Simple.Types
import Data.DOM.Simple.Element
import Data.DOM.Simple.Document
import Data.DOM.Simple.Window
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Events

import Test.QuickCheck

foreign import inspect
  "function inspect(msg) { console.log(msg); }"
  :: forall a. a -> Unit

foreign import tagname
  "function tagname(obj) { return obj.tagName; }"
  :: forall a. a -> String

checkTagName shouldBe element = do
  let name = tagname element
  quickCheck' 1 $ name == shouldBe

checkContents shouldBe element = do
  contents <- textContent (element :: HTMLElement)
  quickCheck' 1 $ contents == shouldBe

checkValue shouldBe element = do
  val <- value (element :: HTMLElement)
  quickCheck' 1 $ val == shouldBe

main = do
  doc <- document globalWindow

  trace "Able to get the title of a document"

  docTitle <- title doc
  quickCheck' 1 $ docTitle == "testTitle"

  -- attrib <- "#testDiv1" `getAttribute` "hello"

  trace "Able to set the title of a document"

  setTitle "modifiedTitle" doc
  docTitle1 <- title doc

  quickCheck' 1 $ docTitle1 == "modifiedTitle"

  trace "Able to get the body element of a document"

  docBody <- body doc

  checkTagName "BODY" docBody

  trace "Able to look up elements"

  Just testDiv1 <- getElementById "test1" doc

  checkTagName "DIV" testDiv1
  checkContents "testContent1" testDiv1

  Just testDiv2 <- querySelector ".test2" doc

  checkTagName "DIV" testDiv2
  checkContents "testContent2" testDiv2

  Just testDiv3 <- querySelector "test3" doc

  checkTagName "TEST3" testDiv3
  checkContents "testContent3" testDiv3

  trace "Able to modify an elements contents"

  setTextContent "Hello" testDiv1

  checkContents "Hello" testDiv1

  trace "Able to modify a form element's value"

  Just testInput1 <- getElementById "input1" doc

  setValue "foo bar baz" testInput1

  checkValue "foo bar baz" testInput1

  trace "Able to set an attribute on an element"

  setAttribute "data-test" "hello" testDiv1
  testDiv1Attribute <- getAttribute "data-test" testDiv1

  quickCheck' 1 $ testDiv1Attribute == "hello"

  trace "Able to remove an attribute from an element"

  testDiv1HasAttribute <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute == true
  removeAttribute "data-test" testDiv1
  testDiv1HasAttribute' <- hasAttribute "data-test" testDiv1
  quickCheck' 1 $ testDiv1HasAttribute' == false

  -- Unavailable in Zombie
  -- trace "Able to add a class"

  --hasTestClass1 <- classContains "testClass" testDiv1
  -- quickCheck' 1 $ hasTestClass1 == false

  -- classAdd "testClass" testDiv1
  -- hasTestClass2 <- classContains "testClass" testDiv1
  -- quickCheck' 1 $ hasTestClass2 == true


most of Layer creation, manipulation, rendering

-- | This module provides a HTML5 canvas interface for the genetics browser,
-- | which wraps and optimizes all rendering calls

module Genetics.Browser.Canvas where

import Prelude

import Control.Monad.Aff (Aff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Uncurried (EffFn2, EffFn3, EffFn4, runEffFn2, runEffFn3, runEffFn4)
import DOM.Node.Types (Element)
import Data.Either (Either(..))
import Data.Foldable (any, fold, foldl, for_)
import Data.Int as Int
import Data.Lens (Getter', Lens', Prism', Traversal, Traversal', iso, lens, lens', prism', re, to, united, view, (^.), (^?))
import Data.Lens.Iso (Iso')
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.List (List)
import Data.List as List
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds)
import Data.Traversable (traverse, traverse_)
import Data.TraversableWithIndex (forWithIndex)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Variant (Variant, case_, onMatch)
import Debug.Trace as Debug
import Genetics.Browser.Layer (Component(..), ComponentSlot, Layer(..), LayerDimensions, LayerMask(..), LayerPadding, LayerSlots, LayerType(..), layerSlots)
import Graphics.Canvas (CanvasElement, Context2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Graphics.Drawing (render, translate) as Drawing
import Graphics.Drawing.Font (font, fontString) as Drawing
import Graphics.Drawing.Font (sansSerif)
import Unsafe.Coerce (unsafeCoerce)

_Element :: Iso' CanvasElement Element
_Element = iso unsafeCoerce unsafeCoerce

-- | Create a new CanvasElement, not attached to the DOM, with the provided String as its CSS class
foreign import createCanvas :: ∀ eff.
                               { width :: Number, height :: Number }
                            -> String
                            -> Eff eff CanvasElement

foreign import setElementStyleImpl :: ∀ e.
                                      EffFn3 e
                                      Element String String
                                      Unit

setElementStyle :: Element
                -> String
                -> String
                -> Eff _ Unit
setElementStyle = runEffFn3 setElementStyleImpl

setElementStyles :: Element -> Array (Tuple String String) -> Eff _ Unit
setElementStyles el =
  traverse_ (uncurry $ setElementStyle el)

setCanvasStyles :: CanvasElement -> Array (Tuple String String) -> Eff _ Unit
setCanvasStyles = setElementStyles <<< view _Element

setCanvasStyle :: CanvasElement
               -> String
               -> String
               -> Eff _ Unit
setCanvasStyle ce = setElementStyle (ce ^. _Element)

setCanvasZIndex :: CanvasElement -> Int -> Eff _ Unit
setCanvasZIndex ce i = setCanvasStyle ce "z-index" (show i)

setCanvasPosition :: ∀ r.
                     { left :: Number, top :: Number | r }
                  -> CanvasElement
                  -> Eff _ Unit
setCanvasPosition {left, top} ce =
  setCanvasStyles ce
    [ Tuple "position" "absolute"
    , Tuple "top"  (show top  <> "px")
    , Tuple "left" (show left <> "px") ]

foreign import appendCanvasElem :: ∀ e.
                                   Element
                                -> CanvasElement
                                -> Eff e Unit

-- | Sets some of the browser container's CSS to reasonable defaults
foreign import setContainerStyle :: ∀ e. Element -> Canvas.Dimensions -> Eff e Unit

foreign import drawCopies :: ∀ eff a.
                             EffFn4 eff
                             CanvasElement Canvas.Dimensions Context2D (Array Point)
                             Unit

foreign import setCanvasTranslation :: ∀ e.
                                       Point
                                    -> CanvasElement
                                    -> Eff e Unit

foreign import canvasClickImpl :: ∀ e.
                                  EffFn2 e
                                  CanvasElement (Point -> Eff e Unit)
                                  Unit

canvasClick :: CanvasElement -> (Point -> Eff _ Unit) -> Eff _ Unit
canvasClick = runEffFn2 canvasClickImpl

-- | Attaches two callbacks to the BrowserCanvas click event handler,
-- | provided with the track canvas and static overlay canvas' relative
-- | coordinates of the click, respectively.
browserOnClick :: BrowserCanvas
               -> { track   :: Point -> Eff _ Unit
                  , overlay :: Point -> Eff _ Unit }
               -> Eff _ Unit
browserOnClick (BrowserCanvas bc) {track, overlay} =
  canvasClick bc.staticOverlay \o -> do
    let t = { x: o.x - bc.trackPadding.left
            , y: o.y - bc.trackPadding.top }
    overlay o
    track t

foreign import scrollCanvasImpl :: ∀ e.
                                   EffFn3 e
                                   CanvasElement CanvasElement Point
                                   Unit

scrollCanvas :: BufferedCanvas
             -> Point
             -> Eff _ Unit
scrollCanvas (BufferedCanvas bc) = runEffFn3 scrollCanvasImpl bc.back bc.front

scrollCanvas' :: BrowserContainer
              -> Point
              -> Eff _ Unit
scrollCanvas' (BrowserContainer bc) pt = do
  layers <- Ref.readRef bc.layers

  for_ layers $ \lc -> case lc ^? _LayerCanvas <<< _Buffer of
    Nothing -> pure unit
    Just bc -> scrollCanvas bc pt

foreign import canvasDragImpl :: ∀ eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

foreign import canvasWheelCBImpl :: ∀ eff.
                                    CanvasElement
                                 -> (Number -> Eff eff Unit)
                                 -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- | Takes a BrowserCanvas and a callback function that is called with the
-- | total dragged distance when a click & drag action is completed.
dragScroll :: BrowserCanvas
           -> (Point -> Eff _ Unit)
           -> Eff _ Unit
dragScroll (BrowserCanvas bc) cb = canvasDrag f bc.staticOverlay
  where f = case _ of
              Left  p     -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas (_.canvas $ unwrap bc.track) p'
                scrollCanvas bc.trackOverlay p'

dragScroll' :: BrowserContainer
            -> (Point -> Eff _ Unit)
            -> Eff _ Unit
dragScroll' bc'@(BrowserContainer {element}) cb =
  canvasDrag f (unsafeCoerce element) -- actually safe
  where f = case _ of
              Left  p    -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas' bc' p'

-- | Takes a BrowserCanvas and a callback function that is called with each
-- | wheel scroll `deltaY`. Callback is provided with only the sign of `deltaY`
-- | as to be `deltaMode` agnostic.
wheelZoom :: BrowserCanvas
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom (BrowserCanvas bc) cb =
  canvasWheelCBImpl bc.staticOverlay cb

wheelZoom' :: BrowserContainer
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom' bc cb = Debug.trace "unimplemented!" \_ -> pure unit
  -- canvasWheelCBImpl bc.staticOverlay cb

-- | Helper function for erasing the contents of a canvas context given its dimensions
clearCanvas :: Context2D -> Canvas.Dimensions -> Eff _ Unit
clearCanvas ctx {width, height} =
  void $ Canvas.clearRect ctx { x: 0.0, y: 0.0, w: width, h: height }

blankLayer :: LayerContainer
           -> Eff _ Unit
blankLayer (LayerContainer ld lc) =
  case lc of
    Buffer bc -> blankBuffer bc
    Static el -> do
      setCanvasTranslation {x: zero, y: zero} el
      ctx <- Canvas.getContext2D el
      clearCanvas ctx ld.size

-- TODO browser background color shouldn't be hardcoded
backgroundColor :: String
backgroundColor = "white"

-- TODO the back canvas should have the option of being bigger than
-- the front, to minimize redrawing
-- needs adding the offset of the front canvas, and validating that back >= front
newtype BufferedCanvas =
  BufferedCanvas { back  :: CanvasElement
                 , front :: CanvasElement
                 }

derive instance newtypeBufferedCanvas :: Newtype BufferedCanvas _

createBufferedCanvas :: Canvas.Dimensions
                     -> Eff _ BufferedCanvas
createBufferedCanvas dim = do
  back  <- createCanvas dim "buffer"
  front <- createCanvas dim "front"
  let bc = BufferedCanvas { back, front }
  blankBuffer bc
  pure bc

getBufferedContext :: BufferedCanvas
                   -> Eff _ Context2D
getBufferedContext = Canvas.getContext2D <$> _.front <<< unwrap

setBufferedCanvasSize :: Canvas.Dimensions
                      -> BufferedCanvas
                      -> Eff _ Unit
setBufferedCanvasSize dim bc@(BufferedCanvas {back, front}) = do
  _ <- Canvas.setCanvasDimensions dim back
  _ <- Canvas.setCanvasDimensions dim front
  blankBuffer bc
  pure unit

translateBuffer :: Point
                -> BufferedCanvas
                -> Eff _ Unit
translateBuffer p (BufferedCanvas bc) = do
  setCanvasTranslation p bc.back
  setCanvasTranslation p bc.front

drawToBuffer :: BufferedCanvas
             -> (Context2D -> Eff _ Unit)
             -> Eff _ Unit
drawToBuffer (BufferedCanvas {back}) f = do
  ctx <- Canvas.getContext2D back
  f ctx

drawToLayer :: LayerContainer
            -> (Context2D -> Eff _ Unit)
            -> Eff _ Unit
drawToLayer (LayerContainer ld lc) f =
  case lc of
    Static c -> f =<< Canvas.getContext2D c
    Buffer b -> drawToBuffer b f

blankBuffer :: BufferedCanvas
            -> Eff _ Unit
blankBuffer bc@(BufferedCanvas {back, front}) = do
  translateBuffer {x: zero, y: zero} bc

  dim <- Canvas.getCanvasDimensions back

  for_ [back, front]
    $ flip clearCanvas dim <=< Canvas.getContext2D

flipBuffer :: BufferedCanvas
           -> Eff _ Unit
flipBuffer (BufferedCanvas {back, front}) = do
-- NOTE this assumes back and front are the same size
  frontCtx <- Canvas.getContext2D front
  let imgSrc = Canvas.canvasElementToImageSource back

  dim <- Canvas.getCanvasDimensions front

  clearCanvas frontCtx dim
  _ <- Canvas.drawImage frontCtx imgSrc 0.0 0.0
  pure unit

-- | The `width` & `height` of the TrackCanvas is the area glyphs render to;
-- | the browser shows a `width` pixels slice of the whole coordinate system.
-- | `glyphBuffer` is what individual glyphs can be rendered to and copied from, for speed.
newtype TrackCanvas =
  TrackCanvas { canvas      :: BufferedCanvas
              , dimensions  :: Canvas.Dimensions
              , glyphBuffer :: CanvasElement
              }

-- | using hardcoded inner padding for now; makes it look a bit better
trackInnerPad :: Number
trackInnerPad = 5.0

derive instance newtypeTrackCanvas :: Newtype TrackCanvas _

_Dimensions :: ∀ n r1 r2.
               Newtype n { dimensions :: Canvas.Dimensions | r1 }
            => Lens' n Canvas.Dimensions
_Dimensions = _Newtype <<< Lens.prop (SProxy :: SProxy "dimensions")

trackTotalDimensions :: Canvas.Dimensions -> Canvas.Dimensions
trackTotalDimensions d = { width:  d.width  + extra
                         , height: d.height + extra }
  where extra = 2.0 * trackInnerPad

-- TODO calculate based on glyph bounding boxes
glyphBufferSize :: Canvas.Dimensions
glyphBufferSize = { width: 15.0, height: 300.0 }

trackCanvas :: Canvas.Dimensions
            -> Eff _ TrackCanvas
trackCanvas dim = do
  canvas <- createBufferedCanvas $ trackTotalDimensions dim
  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  pure $ TrackCanvas { dimensions: dim
                     , canvas, glyphBuffer }

setTrackCanvasSize :: Canvas.Dimensions
                   -> TrackCanvas
                   -> Eff _ TrackCanvas
setTrackCanvasSize dim (TrackCanvas tc) = do
  setBufferedCanvasSize (trackTotalDimensions dim) tc.canvas
  pure $ TrackCanvas
    $ tc { dimensions = dim }

-- TODO change name to BrowserPadding
type TrackPadding =
  { left :: Number, right :: Number
  , top :: Number, bottom :: Number }

-- | A `BrowserCanvas` consists of a double-buffered `track`
-- | which is what the genetics browser view is rendered onto,
-- | and a transparent `staticOverlay` canvas the UI is rendered onto,
-- | with a (also transparent) `trackOverlay` that scrolls with the track view.

-- | The `dimensions`, `trackPadding`, and track.width/height are
-- | related such that
-- | track.width + horizontal.left + horizontal.right = dimensions.width
-- | track.height + vertical.top + vertical.bottom = dimensions.height
newtype BrowserCanvas =
  BrowserCanvas { track         :: TrackCanvas
                , trackPadding  :: TrackPadding
                , dimensions    :: Canvas.Dimensions
                , staticOverlay :: CanvasElement
                , trackOverlay  :: BufferedCanvas
                , container :: Element
                }

derive instance newtypeBrowserCanvas :: Newtype BrowserCanvas _

newtype BrowserContainer =
  BrowserContainer { layers     :: Ref (List LayerContainer)
                   , dimensions :: Ref LayerDimensions -- ? is this better just kept as a function?
                   , element    :: Element }

getDimensions :: ∀ m.
                 MonadEff _ m
              => BrowserContainer
              -> m LayerDimensions
getDimensions (BrowserContainer {dimensions}) =
  liftEff $ Ref.readRef dimensions

_Track :: Lens' BrowserCanvas TrackCanvas
_Track = _Newtype <<< Lens.prop (SProxy :: SProxy "track")

foreign import debugBrowserCanvas :: ∀ e.
                                     String
                                  -> BrowserCanvas
                                  -> Eff e Unit

subtractPadding :: Canvas.Dimensions
                -> TrackPadding
                -> Canvas.Dimensions
subtractPadding {width, height} pad =
  { width:  width - pad.left - pad.right
  , height: height - pad.top - pad.bottom }

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

data UISlotGravity = UILeft | UIRight | UITop | UIBottom

derive instance eqUISlotGravity :: Eq UISlotGravity
derive instance ordUISlotGravity :: Ord UISlotGravity

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

uiSlots :: BrowserCanvas
        -> UISlots
uiSlots (BrowserCanvas bc) =
  let track   = subtractPadding bc.dimensions bc.trackPadding
      browser = bc.dimensions
      pad     = bc.trackPadding
  in { left:   { offset: { x: 0.0, y: pad.top }
               , size:   { height: track.height, width: pad.left }}
     , right:  { offset: { x: browser.width - pad.right, y: pad.top }
               , size:   { height: track.height, width: pad.right }}
     , top:    { offset: { x: pad.left, y: 0.0 }
               , size:   { height: pad.top, width: track.width }}
     , bottom: { offset: { x: browser.width  - pad.right
                         , y: browser.height - pad.bottom }
               , size:   { height: pad.bottom, width: track.width }}
    }

setBrowserCanvasSize :: Canvas.Dimensions
                     -> BrowserCanvas
                     -> Eff _ BrowserCanvas
setBrowserCanvasSize dim (BrowserCanvas bc) = do

  setContainerStyle bc.container dim
  let trackDim = subtractPadding dim bc.trackPadding

  track <- setTrackCanvasSize trackDim bc.track

  setBufferedCanvasSize dim bc.trackOverlay
  _ <- Canvas.setCanvasDimensions dim bc.staticOverlay

  pure $ BrowserCanvas
       $ bc { dimensions = dim
            , track = track }

setBrowserContainerSize :: Canvas.Dimensions
                        -> BrowserContainer
                        -> Eff _ Unit
setBrowserContainerSize dim bc'@(BrowserContainer bc) = do
  -- set the container
  setContainerStyle bc.element dim
  -- set each layer
  _ <- traverseLayers (\l@(LayerContainer ld lc) -> resizeLayer (ld { size = dim }) l) bc'
  -- layers <- getLayers bc
  -- traverse f layers
  pure unit

-- | Creates a `BrowserCanvas` and appends it to the provided element.
-- | Resizes the container element to fit.
browserCanvas :: Canvas.Dimensions
              -> TrackPadding
              -> Element
              -> Eff _ BrowserCanvas
browserCanvas dimensions trackPadding el = do

  setContainerStyle el dimensions

  let trackDim = subtractPadding dimensions trackPadding
  track   <- trackCanvas trackDim

  trackOverlay  <- createBufferedCanvas { width: trackDim.width
                                        , height: dimensions.height }

  staticOverlay <- createCanvas dimensions "staticOverlay"

  let trackEl = _.front  $ unwrap
                $ _.canvas $ unwrap $ track

      trackOverlayEl = _.front $ unwrap $ trackOverlay

  setCanvasZIndex trackEl 10
  setCanvasZIndex trackOverlayEl 20
  setCanvasZIndex staticOverlay 30

  -- TODO handle this nicer maybe idk
  let trackElPosition = { left: trackPadding.left - trackInnerPad
                        , top:  trackPadding.top  - trackInnerPad }

  setCanvasPosition trackElPosition trackEl
  setCanvasPosition { left: trackPadding.left, top: 0.0 } trackOverlayEl
  setCanvasPosition { left: 0.0, top: 0.0} staticOverlay

  appendCanvasElem el trackEl
  appendCanvasElem el trackOverlayEl
  appendCanvasElem el staticOverlay

  pure $ BrowserCanvas { dimensions
                       , track, trackPadding
                       , trackOverlay, staticOverlay
                       , container: el}

-- | Creates an *empty* BrowserContainer, to which layers can be added
browserContainer :: Canvas.Dimensions
                 -> LayerPadding
                 -> Element
                 -> Eff _ BrowserContainer
browserContainer size padding element = do

  setContainerStyle element size

  dimensions <- Ref.newRef { size, padding }
  layers     <- Ref.newRef mempty

  pure $
    BrowserContainer
      { layers, dimensions, element }

-- | Set the CSS z-indices of the Layers in the browser, so their
-- | canvases are drawn in the correct order (i.e. as the
-- | BrowserContainer layer list is ordered)
zIndexLayers :: BrowserContainer
             -> Eff _ Unit
zIndexLayers (BrowserContainer bc) = do
  layers <- Ref.readRef bc.layers
  void $ forWithIndex layers
           (\i l -> setCanvasZIndex
                      (l ^. _LayerCanvas <<< _FrontCanvas) i)

traverseLayers :: ∀ m a.
                  MonadEff _ m
               => (LayerContainer -> m a)
               -> BrowserContainer
               -> m (List a)
traverseLayers f bc = do
  layers <- getLayers bc
  traverse f layers

getLayers :: ∀ m.
             MonadEff _ m
          => BrowserContainer
          -> m (List LayerContainer)
getLayers (BrowserContainer bc) =
  liftEff $ Ref.readRef bc.layers

resizeLayer :: ∀ m.
               MonadEff _ m
            => LayerDimensions
            -> LayerContainer
            -> m LayerContainer
resizeLayer ld' (LayerContainer ld lc) = liftEff do
  case lc of
    Static e -> void $ Canvas.setCanvasDimensions ld.size e
    Buffer b -> setBufferedCanvasSize ld.size b

  pure $ LayerContainer ld' lc

appendLayer :: BrowserContainer
            -> LayerContainer
            -> Eff _ Unit
appendLayer bc@(BrowserContainer {element}) l@(LayerContainer _ cEl)  = do
  layers <- getLayers bc
  appendCanvasElem element (cEl ^. _FrontCanvas)
  zIndexLayers bc

addLayers :: BrowserContainer
          -> List LayerContainer
          -> Eff _ Unit
addLayers bc = traverse_ (appendLayer bc)

deleteLayers :: BrowserContainer
             -> Eff _ Unit
deleteLayers (BrowserContainer bc) = do
  Ref.writeRef bc.layers mempty
  -- TODO update the DOM appropriately,
  -- by just removing the children of bc.element??? or be more specific

  -- maybe expose a function (BrowserContainer -> (LayerContainer -> Eff _ a) -> Eff _ (List a))
  -- so we can effectfully traverse all the layers.
  -- sounds useful at least~~

renderGlyphs :: TrackCanvas
             -> { drawing :: Drawing, points :: Array Point }
             -> Eff _ Unit
renderGlyphs (TrackCanvas tc) {drawing, points} = do
  glyphBfr <- Canvas.getContext2D tc.glyphBuffer
  ctx <- getBufferedContext tc.canvas

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphBfr glyphBufferSize

  Drawing.render glyphBfr
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies tc.glyphBuffer glyphBufferSize ctx points

type Label = { text :: String, point :: Point, gravity :: LabelPlace }

data LabelPlace = LLeft | LCenter | LRight

derive instance eqLabelPlace :: Eq LabelPlace

-- hardcoded global label font for now
-- can't use Drawing.Font because we need raw Canvas to measure the text size,
-- but we can at least use Drawing to generate the font string

labelFontSize :: Int
labelFontSize = 14

labelFont :: String
labelFont = Drawing.fontString $ Drawing.font sansSerif labelFontSize mempty

-- | Calculate the rectangle covered by a label when it'd be rendered
-- | to a provided canvas context
labelBox :: Context2D -> Label -> Eff _ Canvas.Rectangle
labelBox ctx {text, point, gravity} = do
  {width} <- Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx
    Canvas.measureText ctx text

  -- close enough height, actually calculating it is a nightmare
  let height = Int.toNumber labelFontSize
      pad = 14.0 + width / 2.0
      x = case gravity of
        LCenter -> point.x
        LLeft   -> point.x - pad
        LRight  -> point.x + pad

  pure $ { x
         , y: point.y - height
         , w: width, h: height }

-- | Returns `true` if the input rectangles overlap
isOverlapping :: Canvas.Rectangle
              -> Canvas.Rectangle
              -> Boolean
isOverlapping r1 r2 =
     r1.x < r2.x + r2.w
  && r1.x + r1.w > r2.x
  && r1.y < r2.y + r2.h
  && r1.h + r1.y > r2.y

eqRectangle :: Canvas.Rectangle
            -> Canvas.Rectangle
            -> Boolean
eqRectangle {x,y,w,h} r =
     x == r.x && y == r.y
  && w == r.w && h == r.h

appendBoxed :: ∀ r.
               Array {rect :: Canvas.Rectangle | r}
            -> {rect :: Canvas.Rectangle | r}
            -> Array {rect :: Canvas.Rectangle | r}
appendBoxed sofar next =
  let overlapsAny :: Boolean
      overlapsAny = any overlaps sofar
        where overlaps r' = (not $ eqRectangle next.rect r'.rect)
                            && next.rect `isOverlapping` r'.rect
  in if overlapsAny then sofar else sofar <> [next]

renderLabels :: Array Label -> Context2D -> Eff _ Unit
renderLabels ls ctx = do

  boxed <- traverse (\l -> {text: l.text, rect: _} <$> labelBox ctx l) ls

  let toRender = foldl appendBoxed [] boxed

  Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx

    for_ toRender \box ->
      Canvas.fillText ctx box.text
        (box.rect.x - (box.rect.w / 2.0))
        box.rect.y

type Renderable r = { drawings :: Array { drawing :: Drawing
                                        , points :: Array Point }
                    , labels :: Array Label | r }

renderBrowser' :: BrowserContainer
               -> Milliseconds
               -> Number
               -> List (Layer ({|LayerSlots ComponentSlot} -> LayerRenderable))
               -> Aff _ Unit
renderBrowser' bc d offset lrs = do
  layers <- getLayers bc

  let aa :: List LayerContainer
      aa = layers

      fun :: _ -> Layer (Record _ -> LayerRenderable) -> Aff _ _
      fun lct@(LayerContainer ld lc) l@(Layer ltype lmask c) = do

        ctx <- layerContext l lct
        let slots = layerSlots ld

        let fixed    :: Drawing -> Aff _ Unit
            fixed d  = liftEff do
              clearCanvas ctx ?later
              Drawing.render ctx d
            drawings :: Array _ -> Aff _ Unit
            drawings = traverse_ \d -> pure unit
            labels   :: Array _ -> Aff _ Unit
            labels   = traverse_ \l -> pure unit

            drawLayer :: LayerRenderable -> Aff _ Unit
            drawLayer = case_ # onMatch { fixed, drawings, labels }

        traverse_ drawLayer $ map (_ $ slots) c

        pure unit

  -- TODO these lists should be named and lined up properly -- and validated!
  xxx <- List.zipWithA fun layers lrs

  let x :: List _
      x = xxx
  pure unit

renderBrowser :: ∀ a b c.
                 Milliseconds
              -> BrowserCanvas
              -> Number
              -> { tracks     :: { snps :: Renderable a
                                 , annotations :: Renderable b }
                 , relativeUI :: Drawing
                 , fixedUI :: Drawing }
             -> Aff _ Unit
renderBrowser d (BrowserCanvas bc) offset ui = do

  let
      labels = ui.tracks.snps.labels <> ui.tracks.annotations.labels

  -- Render the UI
  liftEff do
    staticOverlayCtx <- Canvas.getContext2D bc.staticOverlay

    clearCanvas staticOverlayCtx bc.dimensions
    Drawing.render staticOverlayCtx ui.fixedUI

    translateBuffer {x: zero, y: zero} bc.trackOverlay
    blankBuffer bc.trackOverlay

    translateBuffer {x: (-offset), y: zero} bc.trackOverlay
    trackOverlayCtx <- getBufferedContext bc.trackOverlay

    Drawing.render trackOverlayCtx ui.relativeUI

    translateBuffer {x: (-offset), y: bc.trackPadding.top} bc.trackOverlay
    renderLabels labels trackOverlayCtx

  -- Render the tracks
  let bfr = (unwrap bc.track).canvas
      cnv = (unwrap bfr).front

  -- TODO extract functions `clearTrack` and `translateTrack` that bake in padding
  ctx <- liftEff $ Canvas.getContext2D cnv
  liftEff do
    dim <- Canvas.getCanvasDimensions cnv

    translateBuffer {x: zero, y: zero} bfr
    clearCanvas ctx $ trackTotalDimensions dim

  liftEff $ translateBuffer { x: trackInnerPad - offset
                            , y: trackInnerPad } bfr

  let snpsTrack  = ui.tracks.snps.drawings
      annotTrack = ui.tracks.annotations.drawings

  for_ [snpsTrack, annotTrack] \t ->
    for_ t \s -> do
      liftEff $ renderGlyphs bc.track s
      delay d

-- TODO it doesn't make sense for LayerContainers to contain the
-- actual size of the element, since that can change externally.
-- however, the LayerPadding should be consistent/only changed by the
-- layer, and so should stay in the LayerContainer.
data LayerContainer =
    LayerContainer LayerDimensions LayerCanvas

data LayerCanvas =
    Static Canvas.CanvasElement
  | Buffer BufferedCanvas

_LayerCanvas :: Lens' LayerContainer LayerCanvas
_LayerCanvas = lens
         (\(LayerContainer _ ct)    -> ct)
         (\(LayerContainer ld _) ct -> LayerContainer ld ct)

_FrontCanvas :: Getter' LayerCanvas CanvasElement
_FrontCanvas = to case _ of
  Static c -> c
  Buffer c -> (unwrap c).front

_Buffer :: Prism' LayerCanvas BufferedCanvas
_Buffer = prism' Buffer from
  where from (Static _) = Nothing
        from (Buffer b) = Just b

_Static :: Prism' LayerCanvas CanvasElement
_Static = prism' Static $ case _ of
  Static el -> Just el
  Buffer _  -> Nothing

_LayerBuffer :: Traversal' LayerContainer BufferedCanvas
_LayerBuffer = _LayerCanvas <<< _Buffer

layerContainer :: ∀ a.
                  LayerDimensions
               -> Layer a
               -> Eff _ LayerContainer
layerContainer lDim (Layer lt _ c) = do

  let slots = layerSlots lDim

  let {size, pos} = case c of
        Padded _ _ -> let p' = lDim.padding
                      in { size: slots.padded.size, pos: { left: p'.left, top: p'.top } }
        _        ->      { size: slots.full.size,   pos: { left: 0.0, top: 0.0 } }

  canvas <-
    case lt of
      Fixed     -> Static <$> createCanvas         size "fixed"
      Scrolling -> Buffer <$> createBufferedCanvas size

  setCanvasPosition pos (canvas ^. _FrontCanvas)

  pure $ LayerContainer lDim canvas

type LayerRenderable =
  Variant ( fixed    :: Drawing
          , drawings :: Array { drawing :: Drawing
                              , points :: Array Point }
          , labels   :: Array Label )

runLayer' :: ∀ m.
             Monoid m
          => Layer (ComponentSlot -> m)
          -> LayerContainer
          -> m
runLayer' layer@(Layer lt lm com) c@(LayerContainer ld ct) =
  let slots = layerSlots ld
  in case com of
      Full     f -> f slots.full
      Padded r f -> f slots.padded
      Outside  f -> fold [ f.top    slots.top
                         , f.right  slots.right
                         , f.bottom slots.bottom
                         , f.left   slots.left ]

layerContext :: ∀ m a.
                MonadEff _ m
             => Layer a
             -> LayerContainer
             -> m Context2D
layerContext (Layer _ lmask com) (LayerContainer ld ct) = liftEff do
  ctx <- Canvas.getContext2D $ ct ^. _FrontCanvas
  _ <- Canvas.transform { m11: one,  m21: zero, m31: zero
                        , m12: zero, m22: one,  m32: zero } ctx

  -- let whenMasked = when (lmask == Masked)

  case com of
    -- translate to 0.0, 0.0
    Full     _ -> do
      -- whenMasked do
      --   pure unit

      pure ctx
    -- translate inward by the padding
    Padded r _ -> do
      -- whenMasked do
      --   pure unit
      Canvas.translate { translateX: r, translateY: r } ctx
    Outside  _ -> do

      -- whenMasked do
      --   pure unit
      -- translate to 0.0, set mask to not draw on the padded canvas
      _ <- Canvas.beginPath ctx
      _ <- Canvas.moveTo ctx 0.0           0.0
      _ <- Canvas.lineTo ctx ld.size.width 0.0
      _ <- Canvas.lineTo ctx ld.size.width ld.size.height
      _ <- Canvas.lineTo ctx 0.0           ld.size.height
      _ <- Canvas.lineTo ctx 0.0           0.0
      Canvas.clip ctx

-- | This module provides a HTML5 canvas interface for the genetics browser,
-- | which wraps and optimizes all rendering calls

module Genetics.Browser.Canvas where

import Prelude

import Control.Monad.Aff (Aff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Ref (Ref)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Uncurried (EffFn2, EffFn3, EffFn4, runEffFn2, runEffFn3, runEffFn4)
import DOM.Node.Types (Element)
import Data.Either (Either(..))
import Data.Foldable (any, fold, foldl, for_)
import Data.Int as Int
import Data.Lens (Getter', Lens', Prism', Traversal', Traversal, iso, lens, lens', prism', re, to, united, view, (^.), (^?))
import Data.Lens.Iso (Iso')
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.List (List)
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds)
import Data.Traversable (traverse, traverse_)
import Data.TraversableWithIndex (forWithIndex)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Variant (Variant, case_, onMatch)
import Genetics.Browser.Layer (Component(..), ComponentSlot, Layer(..), LayerDimensions, LayerSlots, LayerType(..), LayerPadding, layerSlots)
import Graphics.Canvas (CanvasElement, Context2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Graphics.Drawing (render, translate) as Drawing
import Graphics.Drawing.Font (font, fontString) as Drawing
import Graphics.Drawing.Font (sansSerif)
import Unsafe.Coerce (unsafeCoerce)

_Element :: Iso' CanvasElement Element
_Element = iso unsafeCoerce unsafeCoerce

-- | Create a new CanvasElement, not attached to the DOM, with the provided String as its CSS class
foreign import createCanvas :: ∀ eff.
                               { width :: Number, height :: Number }
                            -> String
                            -> Eff eff CanvasElement

foreign import setElementStyleImpl :: ∀ e.
                                      EffFn3 e
                                      Element String String
                                      Unit

setElementStyle :: Element
                -> String
                -> String
                -> Eff _ Unit
setElementStyle = runEffFn3 setElementStyleImpl

setElementStyles :: Element -> Array (Tuple String String) -> Eff _ Unit
setElementStyles el =
  traverse_ (uncurry $ setElementStyle el)

setCanvasStyles :: CanvasElement -> Array (Tuple String String) -> Eff _ Unit
setCanvasStyles = setElementStyles <<< view _Element

setCanvasStyle :: CanvasElement
               -> String
               -> String
               -> Eff _ Unit
setCanvasStyle ce = setElementStyle (ce ^. _Element)

setCanvasZIndex :: CanvasElement -> Int -> Eff _ Unit
setCanvasZIndex ce i = setCanvasStyle ce "z-index" (show i)

setCanvasPosition :: ∀ r.
                     { left :: Number, top :: Number | r }
                  -> CanvasElement
                  -> Eff _ Unit
setCanvasPosition {left, top} ce =
  setCanvasStyles ce
    [ Tuple "position" "absolute"
    , Tuple "top"  (show top  <> "px")
    , Tuple "left" (show left <> "px") ]

foreign import appendCanvasElem :: ∀ e.
                                   Element
                                -> CanvasElement
                                -> Eff e Unit

-- | Sets some of the browser container's CSS to reasonable defaults
foreign import setContainerStyle :: ∀ e. Element -> Canvas.Dimensions -> Eff e Unit

foreign import drawCopies :: ∀ eff a.
                             EffFn4 eff
                             CanvasElement Canvas.Dimensions Context2D (Array Point)
                             Unit

foreign import setCanvasTranslation :: ∀ e.
                                       Point
                                    -> CanvasElement
                                    -> Eff e Unit

foreign import canvasClickImpl :: ∀ e.
                                  EffFn2 e
                                  CanvasElement (Point -> Eff e Unit)
                                  Unit

canvasClick :: CanvasElement -> (Point -> Eff _ Unit) -> Eff _ Unit
canvasClick = runEffFn2 canvasClickImpl

-- | Attaches two callbacks to the BrowserCanvas click event handler,
-- | provided with the track canvas and static overlay canvas' relative
-- | coordinates of the click, respectively.
browserOnClick :: BrowserCanvas
               -> { track   :: Point -> Eff _ Unit
                  , overlay :: Point -> Eff _ Unit }
               -> Eff _ Unit
browserOnClick (BrowserCanvas bc) {track, overlay} =
  canvasClick bc.staticOverlay \o -> do
    let t = { x: o.x - bc.trackPadding.left
            , y: o.y - bc.trackPadding.top }
    overlay o
    track t

foreign import scrollCanvasImpl :: ∀ e.
                                   EffFn3 e
                                   CanvasElement CanvasElement Point
                                   Unit

scrollCanvas :: BufferedCanvas
             -> Point
             -> Eff _ Unit
scrollCanvas (BufferedCanvas bc) = runEffFn3 scrollCanvasImpl bc.back bc.front

scrollCanvas' :: BrowserContainer
              -> Point
              -> Eff _ Unit
scrollCanvas' (BrowserContainer bc) pt = do
  layers <- Ref.readRef bc.layers

  for_ layers $ \lc -> case lc ^? _LayerCanvas <<< _Buffer of
    Nothing -> pure unit
    Just bc -> scrollCanvas bc pt

foreign import canvasDragImpl :: ∀ eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

foreign import canvasWheelCBImpl :: ∀ eff.
                                    CanvasElement
                                 -> (Number -> Eff eff Unit)
                                 -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- | Takes a BrowserCanvas and a callback function that is called with the
-- | total dragged distance when a click & drag action is completed.
dragScroll :: BrowserCanvas
           -> (Point -> Eff _ Unit)
           -> Eff _ Unit
dragScroll (BrowserCanvas bc) cb = canvasDrag f bc.staticOverlay
  where f = case _ of
              Left  p     -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas (_.canvas $ unwrap bc.track) p'
                scrollCanvas bc.trackOverlay p'

dragScroll' :: BrowserContainer
            -> (Point -> Eff _ Unit)
            -> Eff _ Unit
dragScroll' bc'@(BrowserContainer {element}) cb =
  canvasDrag f (unsafeCoerce element) -- actually safe
  where f = case _ of
              Left  p    -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas' bc' p'

-- | Takes a BrowserCanvas and a callback function that is called with each
-- | wheel scroll `deltaY`. Callback is provided with only the sign of `deltaY`
-- | as to be `deltaMode` agnostic.
wheelZoom :: BrowserCanvas
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom (BrowserCanvas bc) cb =
  canvasWheelCBImpl bc.staticOverlay cb

-- | Helper function for erasing the contents of a canvas context given its dimensions
clearCanvas :: Context2D -> Canvas.Dimensions -> Eff _ Unit
clearCanvas ctx {width, height} =
  void $ Canvas.clearRect ctx { x: 0.0, y: 0.0, w: width, h: height }

blankLayer :: LayerContainer
           -> Eff _ Unit
blankLayer (LayerContainer ld lc) =
  case lc of
    Buffer bc -> blankBuffer bc
    Static el -> do
      setCanvasTranslation {x: zero, y: zero} el
      ctx <- Canvas.getContext2D el
      clearCanvas ctx ld.size

-- TODO browser background color shouldn't be hardcoded
backgroundColor :: String
backgroundColor = "white"

-- TODO the back canvas should have the option of being bigger than
-- the front, to minimize redrawing
-- needs adding the offset of the front canvas, and validating that back >= front
newtype BufferedCanvas =
  BufferedCanvas { back  :: CanvasElement
                 , front :: CanvasElement
                 }

derive instance newtypeBufferedCanvas :: Newtype BufferedCanvas _

createBufferedCanvas :: Canvas.Dimensions
                     -> Eff _ BufferedCanvas
createBufferedCanvas dim = do
  back  <- createCanvas dim "buffer"
  front <- createCanvas dim "front"
  let bc = BufferedCanvas { back, front }
  blankBuffer bc
  pure bc

getBufferedContext :: BufferedCanvas
                   -> Eff _ Context2D
getBufferedContext = Canvas.getContext2D <$> _.front <<< unwrap

setBufferedCanvasSize :: Canvas.Dimensions
                      -> BufferedCanvas
                      -> Eff _ Unit
setBufferedCanvasSize dim bc@(BufferedCanvas {back, front}) = do
  _ <- Canvas.setCanvasDimensions dim back
  _ <- Canvas.setCanvasDimensions dim front
  blankBuffer bc
  pure unit

translateBuffer :: Point
                -> BufferedCanvas
                -> Eff _ Unit
translateBuffer p (BufferedCanvas bc) = do
  setCanvasTranslation p bc.back
  setCanvasTranslation p bc.front

drawToBuffer :: BufferedCanvas
             -> (Context2D -> Eff _ Unit)
             -> Eff _ Unit
drawToBuffer (BufferedCanvas {back}) f = do
  ctx <- Canvas.getContext2D back
  f ctx

blankBuffer :: BufferedCanvas
            -> Eff _ Unit
blankBuffer bc@(BufferedCanvas {back, front}) = do
  translateBuffer {x: zero, y: zero} bc

  dim <- Canvas.getCanvasDimensions back

  for_ [back, front]
    $ flip clearCanvas dim <=< Canvas.getContext2D

flipBuffer :: BufferedCanvas
           -> Eff _ Unit
flipBuffer (BufferedCanvas {back, front}) = do
-- NOTE this assumes back and front are the same size
  frontCtx <- Canvas.getContext2D front
  let imgSrc = Canvas.canvasElementToImageSource back

  dim <- Canvas.getCanvasDimensions front

  clearCanvas frontCtx dim
  _ <- Canvas.drawImage frontCtx imgSrc 0.0 0.0
  pure unit

-- | The `width` & `height` of the TrackCanvas is the area glyphs render to;
-- | the browser shows a `width` pixels slice of the whole coordinate system.
-- | `glyphBuffer` is what individual glyphs can be rendered to and copied from, for speed.
newtype TrackCanvas =
  TrackCanvas { canvas      :: BufferedCanvas
              , dimensions  :: Canvas.Dimensions
              , glyphBuffer :: CanvasElement
              }

-- | using hardcoded inner padding for now; makes it look a bit better
trackInnerPad :: Number
trackInnerPad = 5.0

derive instance newtypeTrackCanvas :: Newtype TrackCanvas _

_Dimensions :: ∀ n r1 r2.
               Newtype n { dimensions :: Canvas.Dimensions | r1 }
            => Lens' n Canvas.Dimensions
_Dimensions = _Newtype <<< Lens.prop (SProxy :: SProxy "dimensions")

trackTotalDimensions :: Canvas.Dimensions -> Canvas.Dimensions
trackTotalDimensions d = { width:  d.width  + extra
                         , height: d.height + extra }
  where extra = 2.0 * trackInnerPad

-- TODO calculate based on glyph bounding boxes
glyphBufferSize :: Canvas.Dimensions
glyphBufferSize = { width: 15.0, height: 300.0 }

trackCanvas :: Canvas.Dimensions
            -> Eff _ TrackCanvas
trackCanvas dim = do
  canvas <- createBufferedCanvas $ trackTotalDimensions dim
  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  pure $ TrackCanvas { dimensions: dim
                     , canvas, glyphBuffer }

setTrackCanvasSize :: Canvas.Dimensions
                   -> TrackCanvas
                   -> Eff _ TrackCanvas
setTrackCanvasSize dim (TrackCanvas tc) = do
  setBufferedCanvasSize (trackTotalDimensions dim) tc.canvas
  pure $ TrackCanvas
    $ tc { dimensions = dim }

-- TODO change name to BrowserPadding
type TrackPadding =
  { left :: Number, right :: Number
  , top :: Number, bottom :: Number }

-- | A `BrowserCanvas` consists of a double-buffered `track`
-- | which is what the genetics browser view is rendered onto,
-- | and a transparent `staticOverlay` canvas the UI is rendered onto,
-- | with a (also transparent) `trackOverlay` that scrolls with the track view.

-- | The `dimensions`, `trackPadding`, and track.width/height are
-- | related such that
-- | track.width + horizontal.left + horizontal.right = dimensions.width
-- | track.height + vertical.top + vertical.bottom = dimensions.height
newtype BrowserCanvas =
  BrowserCanvas { track         :: TrackCanvas
                , trackPadding  :: TrackPadding
                , dimensions    :: Canvas.Dimensions
                , staticOverlay :: CanvasElement
                , trackOverlay  :: BufferedCanvas
                , container :: Element
                }

derive instance newtypeBrowserCanvas :: Newtype BrowserCanvas _

newtype BrowserContainer =
  BrowserContainer { layers     :: Ref (List LayerContainer)
                   , dimensions :: Ref LayerDimensions -- ? is this better just kept as a function?
                   , element    :: Element }

_Track :: Lens' BrowserCanvas TrackCanvas
_Track = _Newtype <<< Lens.prop (SProxy :: SProxy "track")

foreign import debugBrowserCanvas :: ∀ e.
                                     String
                                  -> BrowserCanvas
                                  -> Eff e Unit

subtractPadding :: Canvas.Dimensions
                -> TrackPadding
                -> Canvas.Dimensions
subtractPadding {width, height} pad =
  { width:  width - pad.left - pad.right
  , height: height - pad.top - pad.bottom }

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

data UISlotGravity = UILeft | UIRight | UITop | UIBottom

derive instance eqUISlotGravity :: Eq UISlotGravity
derive instance ordUISlotGravity :: Ord UISlotGravity

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

uiSlots :: BrowserCanvas
        -> UISlots
uiSlots (BrowserCanvas bc) =
  let track   = subtractPadding bc.dimensions bc.trackPadding
      browser = bc.dimensions
      pad     = bc.trackPadding
  in { left:   { offset: { x: 0.0, y: pad.top }
               , size:   { height: track.height, width: pad.left }}
     , right:  { offset: { x: browser.width - pad.right, y: pad.top }
               , size:   { height: track.height, width: pad.right }}
     , top:    { offset: { x: pad.left, y: 0.0 }
               , size:   { height: pad.top, width: track.width }}
     , bottom: { offset: { x: browser.width  - pad.right
                         , y: browser.height - pad.bottom }
               , size:   { height: pad.bottom, width: track.width }}
    }

setBrowserCanvasSize :: Canvas.Dimensions
                     -> BrowserCanvas
                     -> Eff _ BrowserCanvas
setBrowserCanvasSize dim (BrowserCanvas bc) = do

  setContainerStyle bc.container dim
  let trackDim = subtractPadding dim bc.trackPadding

  track <- setTrackCanvasSize trackDim bc.track

  setBufferedCanvasSize dim bc.trackOverlay
  _ <- Canvas.setCanvasDimensions dim bc.staticOverlay

  pure $ BrowserCanvas
       $ bc { dimensions = dim
            , track = track }

-- | Creates a `BrowserCanvas` and appends it to the provided element.
-- | Resizes the container element to fit.
browserCanvas :: Canvas.Dimensions
              -> TrackPadding
              -> Element
              -> Eff _ BrowserCanvas
browserCanvas dimensions trackPadding el = do

  setContainerStyle el dimensions

  let trackDim = subtractPadding dimensions trackPadding
  track   <- trackCanvas trackDim

  trackOverlay  <- createBufferedCanvas { width: trackDim.width
                                        , height: dimensions.height }

  staticOverlay <- createCanvas dimensions "staticOverlay"

  let trackEl = _.front  $ unwrap
                $ _.canvas $ unwrap $ track

      trackOverlayEl = _.front $ unwrap $ trackOverlay

  setCanvasZIndex trackEl 10
  setCanvasZIndex trackOverlayEl 20
  setCanvasZIndex staticOverlay 30

  -- TODO handle this nicer maybe idk
  let trackElPosition = { left: trackPadding.left - trackInnerPad
                        , top:  trackPadding.top  - trackInnerPad }

  setCanvasPosition trackElPosition trackEl
  setCanvasPosition { left: trackPadding.left, top: 0.0 } trackOverlayEl
  setCanvasPosition { left: 0.0, top: 0.0} staticOverlay

  appendCanvasElem el trackEl
  appendCanvasElem el trackOverlayEl
  appendCanvasElem el staticOverlay

  pure $ BrowserCanvas { dimensions
                       , track, trackPadding
                       , trackOverlay, staticOverlay
                       , container: el}

-- | Creates an *empty* BrowserContainer, to which layers can be added
browserContainer :: Canvas.Dimensions
                 -> LayerPadding
                 -> Element
                 -> Eff _ BrowserContainer
browserContainer size padding element = do

  setContainerStyle element size

  dimensions <- Ref.newRef { size, padding }
  layers     <- Ref.newRef mempty
  -- padding    <- Ref.newRef $ unsafeCoerce unit

  pure $
    BrowserContainer
      { layers, dimensions, element }

-- | Set the CSS z-indices of the Layers in the browser, so their
-- | canvases are drawn in the correct order (i.e. as the
-- | BrowserContainer layer list is ordered)
zIndexLayers :: BrowserContainer
             -> Eff _ Unit
zIndexLayers (BrowserContainer bc) = do
  layers <- Ref.readRef bc.layers
  void $ forWithIndex layers
           (\i l -> setCanvasZIndex
                      (l ^. _LayerCanvas <<< _FrontCanvas) i)

traverseLayers :: ∀ a.
                  (LayerContainer -> Eff _ a)
               -> BrowserContainer
               -> Eff _ (List a)
traverseLayers f bc = do
  layers <- getLayers bc
  traverse f layers

getLayers :: BrowserContainer
          -> Eff _ (List LayerContainer)
getLayers (BrowserContainer bc) =
  Ref.readRef bc.layers

appendLayer :: BrowserContainer
            -> LayerContainer
            -> Eff _ Unit
appendLayer bc@(BrowserContainer {element}) l@(LayerContainer _ cEl)  = do
  layers <- getLayers bc
  appendCanvasElem element (cEl ^. _FrontCanvas)
  zIndexLayers bc

addLayers :: BrowserContainer
          -> List LayerContainer
          -> Eff _ Unit
addLayers bc = traverse_ (appendLayer bc)

renderGlyphs :: TrackCanvas
             -> { drawing :: Drawing, points :: Array Point }
             -> Eff _ Unit
renderGlyphs (TrackCanvas tc) {drawing, points} = do
  glyphBfr <- Canvas.getContext2D tc.glyphBuffer
  ctx <- getBufferedContext tc.canvas

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphBfr glyphBufferSize

  Drawing.render glyphBfr
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies tc.glyphBuffer glyphBufferSize ctx points

type Label = { text :: String, point :: Point, gravity :: LabelPlace }

data LabelPlace = LLeft | LCenter | LRight

derive instance eqLabelPlace :: Eq LabelPlace

-- hardcoded global label font for now
-- can't use Drawing.Font because we need raw Canvas to measure the text size,
-- but we can at least use Drawing to generate the font string

labelFontSize :: Int
labelFontSize = 14

labelFont :: String
labelFont = Drawing.fontString $ Drawing.font sansSerif labelFontSize mempty

-- | Calculate the rectangle covered by a label when it'd be rendered
-- | to a provided canvas context
labelBox :: Context2D -> Label -> Eff _ Canvas.Rectangle
labelBox ctx {text, point, gravity} = do
  {width} <- Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx
    Canvas.measureText ctx text

  -- close enough height, actually calculating it is a nightmare
  let height = Int.toNumber labelFontSize
      pad = 14.0 + width / 2.0
      x = case gravity of
        LCenter -> point.x
        LLeft   -> point.x - pad
        LRight  -> point.x + pad

  pure $ { x
         , y: point.y - height
         , w: width, h: height }

-- | Returns `true` if the input rectangles overlap
isOverlapping :: Canvas.Rectangle
              -> Canvas.Rectangle
              -> Boolean
isOverlapping r1 r2 =
     r1.x < r2.x + r2.w
  && r1.x + r1.w > r2.x
  && r1.y < r2.y + r2.h
  && r1.h + r1.y > r2.y

eqRectangle :: Canvas.Rectangle
            -> Canvas.Rectangle
            -> Boolean
eqRectangle {x,y,w,h} r =
     x == r.x && y == r.y
  && w == r.w && h == r.h

appendBoxed :: ∀ r.
               Array {rect :: Canvas.Rectangle | r}
            -> {rect :: Canvas.Rectangle | r}
            -> Array {rect :: Canvas.Rectangle | r}
appendBoxed sofar next =
  let overlapsAny :: Boolean
      overlapsAny = any overlaps sofar
        where overlaps r' = (not $ eqRectangle next.rect r'.rect)
                            && next.rect `isOverlapping` r'.rect
  in if overlapsAny then sofar else sofar <> [next]

renderLabels :: Array Label -> Context2D -> Eff _ Unit
renderLabels ls ctx = do

  boxed <- traverse (\l -> {text: l.text, rect: _} <$> labelBox ctx l) ls

  let toRender = foldl appendBoxed [] boxed

  Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx

    for_ toRender \box ->
      Canvas.fillText ctx box.text
        (box.rect.x - (box.rect.w / 2.0))
        box.rect.y

type Renderable r = { drawings :: Array { drawing :: Drawing
                                        , points :: Array Point }
                    , labels :: Array Label | r }

renderBrowser :: ∀ a b c.
                 Milliseconds
              -> BrowserCanvas
              -> Number
              -> { tracks     :: { snps :: Renderable a
                                 , annotations :: Renderable b }
                 , relativeUI :: Drawing
                 , fixedUI :: Drawing }
             -> Aff _ Unit
renderBrowser d (BrowserCanvas bc) offset ui = do

  let
      labels = ui.tracks.snps.labels <> ui.tracks.annotations.labels

  -- Render the UI
  liftEff do
    staticOverlayCtx <- Canvas.getContext2D bc.staticOverlay

    clearCanvas staticOverlayCtx bc.dimensions
    Drawing.render staticOverlayCtx ui.fixedUI

    translateBuffer {x: zero, y: zero} bc.trackOverlay
    blankBuffer bc.trackOverlay

    translateBuffer {x: (-offset), y: zero} bc.trackOverlay
    trackOverlayCtx <- getBufferedContext bc.trackOverlay

    Drawing.render trackOverlayCtx ui.relativeUI

    translateBuffer {x: (-offset), y: bc.trackPadding.top} bc.trackOverlay
    renderLabels labels trackOverlayCtx

  -- Render the tracks
  let bfr = (unwrap bc.track).canvas
      cnv = (unwrap bfr).front

  -- TODO extract functions `clearTrack` and `translateTrack` that bake in padding
  ctx <- liftEff $ Canvas.getContext2D cnv
  liftEff do
    dim <- Canvas.getCanvasDimensions cnv

    translateBuffer {x: zero, y: zero} bfr
    clearCanvas ctx $ trackTotalDimensions dim

  liftEff $ translateBuffer { x: trackInnerPad - offset
                            , y: trackInnerPad } bfr

  let snpsTrack  = ui.tracks.snps.drawings
      annotTrack = ui.tracks.annotations.drawings

  for_ [snpsTrack, annotTrack] \t ->
    for_ t \s -> do
      liftEff $ renderGlyphs bc.track s
      delay d

data LayerContainer =
    LayerContainer LayerDimensions LayerCanvas

data LayerCanvas =
    Static Canvas.CanvasElement
  | Buffer BufferedCanvas

_LayerCanvas :: Lens' LayerContainer LayerCanvas
_LayerCanvas = lens
         (\(LayerContainer _ ct)    -> ct)
         (\(LayerContainer ld _) ct -> LayerContainer ld ct)

_FrontCanvas :: Getter' LayerCanvas CanvasElement
_FrontCanvas = to case _ of
  Static c -> c
  Buffer c -> (unwrap c).front

_Buffer :: Prism' LayerCanvas BufferedCanvas
_Buffer = prism' Buffer from
  where from (Static _) = Nothing
        from (Buffer b) = Just b

_Static :: Prism' LayerCanvas CanvasElement
_Static = prism' Static $ case _ of
  Static el -> Just el
  Buffer _  -> Nothing

_LayerBuffer :: Traversal' LayerContainer BufferedCanvas
_LayerBuffer = _LayerCanvas <<< _Buffer

layerContainer :: ∀ a.
                  LayerDimensions
               -> Layer a
               -> Eff _ LayerContainer
layerContainer lDim (Layer lt _ c) = do

  let slots = layerSlots lDim

  let {size, pos} = case c of
        Padded _ _ -> let p' = lDim.padding
                      in { size: slots.padded.size, pos: { left: p'.left, top: p'.top } }
        _        ->      { size: slots.full.size,   pos: { left: 0.0, top: 0.0 } }

  canvas <-
    case lt of
      Fixed     -> Static <$> createCanvas         size "fixed"
      Scrolling -> Buffer <$> createBufferedCanvas size

  setCanvasPosition pos (canvas ^. _FrontCanvas)

  pure $ LayerContainer lDim canvas

type LayerRenderable =
  Variant ( fixed    :: Drawing
          , drawings :: Array { drawing :: Drawing
                              , points :: Array Point }
          , labels   :: Array Label )

runLayer' :: ∀ m.
             Monoid m
          => Layer (ComponentSlot -> m)
          -> LayerContainer
          -> m
runLayer' layer@(Layer lt lm com) c@(LayerContainer ld ct) =
  let slots = layerSlots ld
  in case com of
      Full     f -> f slots.full
      Padded r f -> f slots.padded
      Outside  f -> fold [ f.top    slots.top
                         , f.right  slots.right
                         , f.bottom slots.bottom
                         , f.left   slots.left ]

layerContext :: ∀ a.
                Layer a
             -> LayerContainer
             -> Eff _ Context2D
layerContext (Layer _ _ com) (LayerContainer ld ct) = do
  ctx <- Canvas.getContext2D $ ct ^. _FrontCanvas
  _ <- Canvas.transform { m11: one,  m21: zero, m31: zero
                        , m12: zero, m22: one,  m32: zero } ctx
  case com of
    -- translate to 0.0, 0.0
    Full     _ -> pure ctx
    -- translate inward by the padding
    Padded r _ -> Canvas.translate { translateX: r, translateY: r } ctx
    Outside  _ -> do
      -- translate to 0.0, set mask to not draw on the padded canvas
      _ <- Canvas.beginPath ctx
      _ <- Canvas.moveTo ctx 0.0           0.0
      _ <- Canvas.lineTo ctx ld.size.width 0.0
      _ <- Canvas.lineTo ctx ld.size.width ld.size.height
      _ <- Canvas.lineTo ctx 0.0           ld.size.height
      _ <- Canvas.lineTo ctx 0.0           0.0
      Canvas.clip ctx


Added key codes for W, A, S and D.

Added key codes for W, A, S and D.

module DOM.Event.KeyboardEvent (
	KeyboardEventType(),
	keydown,
	keypress,
	keyup,
	keyCode,
	wKeyCode,
	aKeyCode,
	sKeyCode,
	dKeyCode,
	addKeyboardEventListener
	) where

import Prelude
import Control.Monad.Eff
import DOM
import DOM.Event.Types
import qualified DOM.Event.EventTypes as D

data KeyboardEventType = KeyboardEventType EventType
keydown = KeyboardEventType D.keydown
keypress = KeyboardEventType D.keypress
keyup = KeyboardEventType D.keyup

foreign import keyCode :: KeyboardEvent -> Int

wKeyCode :: Int
wKeyCode = 87

aKeyCode :: Int
aKeyCode = 65

sKeyCode :: Int
sKeyCode = 83

dKeyCode :: Int
dKeyCode = 68

foreign import data KeyboardEventListener :: # ! -> *
foreign import keyboardEventListener :: forall eff a. (KeyboardEvent -> Eff eff a) -> KeyboardEventListener eff
foreign import addKeyboardEventListenerImpl :: forall eff. EventType -> KeyboardEventListener (dom :: DOM | eff) -> Boolean -> EventTarget -> Eff (dom :: DOM | eff) Unit

addKeyboardEventListener :: forall eff a. KeyboardEventType -> (KeyboardEvent -> Eff (dom :: DOM | eff) a) -> Boolean -> EventTarget -> Eff (dom :: DOM | eff) Unit
addKeyboardEventListener (KeyboardEventType event) callback useCapture target =
	addKeyboardEventListenerImpl event (keyboardEventListener callback) useCapture target

module DOM.Event.KeyboardEvent where

import Prelude
import Control.Monad.Eff
import DOM
import DOM.Event.Types
import qualified DOM.Event.EventTypes as D

data KeyboardEventType = KeyboardEventType EventType
keydown = KeyboardEventType D.keydown
keypress = KeyboardEventType D.keypress
keyup = KeyboardEventType D.keyup

foreign import keyCode :: KeyboardEvent -> Int

foreign import data KeyboardEventListener :: # ! -> *
foreign import keyboardEventListener :: forall eff a. (KeyboardEvent -> Eff eff a) -> KeyboardEventListener eff
foreign import addKeyboardEventListenerImpl :: forall eff. EventType -> KeyboardEventListener (dom :: DOM | eff) -> Boolean -> EventTarget -> Eff (dom :: DOM | eff) Unit

addKeyboardEventListener :: forall eff a. KeyboardEventType -> (KeyboardEvent -> Eff (dom :: DOM | eff) a) -> Boolean -> EventTarget -> Eff (dom :: DOM | eff) Unit
addKeyboardEventListener (KeyboardEventType event) callback useCapture target =
	addKeyboardEventListenerImpl event (keyboardEventListener callback) useCapture target


Add insertions

Add insertions

module Scansion where

import Prelude
import UIHelpers
import CSS as CSS
import CSS.Overflow as CSS.Overflow
import CSS.TextAlign as CSS.TextAlign
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import DOM.HTML.HTMLTextAreaElement as HTextArea
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import ArrayState (evalArrayState, evalReversedArrayState, sequence, sequenceReversed)
import CSS (CSS, StyleM, canvas, ex, fromHexString, nil, value)
import CSS.Common (auto)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.State (State)
import Control.Monad.State.Trans (get, put)
import Control.Plus (empty)
import DOM (DOM)
import DOM.Event.Types (Event, focusEventToEvent, inputEventToEvent, keyboardEventToEvent, mouseEventToEvent)
import DOM.HTML.HTMLElement (focus)
import DOM.HTML.Types (HTMLInputElement, HTMLTextAreaElement)
import Data.Array (filter, mapWithIndex) as Array
import Data.Generic (class Generic, gCompare, gEq, gShow)
import Data.Int (odd)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.String (Pattern(..), indexOf, joinWith, length, splitAt, trim)
import Data.String (split) as String
import Data.String.Regex (Regex, replace, split, test)
import Data.String.Regex.Flags (global, ignoreCase, noFlags)
import Data.String.Regex.Unsafe (unsafeRegex)
import Data.Tuple (Tuple(..), fst, snd)
import Halogen.Aff (HalogenEffects)
import Halogen.Aff.Util (awaitBody, runHalogenAff)
import Halogen.HTML.CSS (style)
import Halogen.VDom.Driver (runUI)
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

newtype Line =
    Line (Array Res)

instance showLine :: Show Line where
    show (Line line) = joinWith "" do
        res <- line
        pure case res of
            Punct s -> s
            Verb { syllables } ->
                joinWith "" do
                    Syllable { value, stype } <- syllables
                    --pure (value <> show stype)
                    pure value

instance displayLine :: Display Line where
    display line_@(Line line) =
        HH.div_ [ scanned, raw ]
        where
            raw = HH.span [ style $ zindex 1 ] [ HH.text $ show line_ ]
            scanned = HH.div [ divstyle ] $ evalArrayState (map mapper line) 0.0
            divstyle = style do
                CSS.height (1.2#ex)
                zindex (-1)
                no_pointer_events
            mapper (Punct "\n") = pure HH.br_
            mapper (Punct s) = pure (spacer $ HH.text s)
            mapper (Verb { syllables, gloss }) =
                map HH.span_ $ sequence $ map displaySyllableColored syllables

y_mark :: forall a b. CSS -> HP.IProp ( style :: String | a ) b
y_mark extra =
    style do
        CSS.color (unsafePartial $ fromJust $ fromHexString "#F50057")
        CSS.Overflow.overflow CSS.Overflow.visible
        CSS.height (ex 1.0)
        scale 2.0 1.4
        no_user_select
        CSS.margin auto auto auto auto
        CSS.TextAlign.textAlign CSS.TextAlign.center
        extra

instance displaySyllable :: Display Syllable where
    display = displaySyllableStyled (CSS.height nil)

displaySyllableStyled :: forall a b. CSS -> Syllable -> HH.HTML a b
displaySyllableStyled extraStyle (Syllable { value, stype }) =
    HH.div
        [ style do
            CSS.display CSS.inlineBlock
        ]
        [ HH.div [ y_mark extraStyle ] [ HH.text $ show stype ]
        , spacer $ HH.text value
        ]

displaySyllableColored :: forall a b. Syllable -> State Number (HH.HTML a b)
displaySyllableColored syllable@(Syllable { value, stype }) = do
    position <- get
    let incr = case stype of
            Elided ->
                0.0

            Long ->
                1.0

            Ambiguous (Just a) | a ->
                1.0

            _ ->
                0.5
    put (position + incr)
    let clr =
            CSS.color $ fromMaybe (CSS.gray) $ CSS.fromHexString $
                case position of
                    0.0 ->
                        "#F50057"

                    2.0 ->
                        "#D500F9"

                    4.0 ->
                        "#651FFF"

                    6.0 ->
                        "#00E5FF"

                    8.0 ->
                        "#1DE9B6"

                    10.0 ->
                        "#00E676"

                    11.0 ->
                        "#2E7D32"

                    10.5 ->
                        "#FF3D00"

                    11.5 ->
                        "#FF3D00"

                    12.0 ->
                        "#FF3D00"

                    _ ->
                        ""
    pure $ displaySyllableStyled (clr) syllable

data Res
    = Punct String
    | Verb Word

type Word =
    { syllables :: Array Syllable
    , gloss :: String
    }

newtype Syllable = Syllable
    { value :: String
    , stype :: SyllableType
    }

data SyllableType
    = Long
    | Ambiguous (Maybe Boolean)
    | Short
    | Elided

instance showSyllableType :: Show SyllableType where
    show s =
        case s of
            Short ->
                "˘"

            Long ->
                "¯"

            Elided ->
                "˙"

            Ambiguous Nothing ->
                "˟"

            Ambiguous (Just b)
                | b -> "˜"
                | otherwise -> "ˇ"

startsWith :: Pattern -> String -> Boolean
startsWith p s = case indexOf p s of
    Just 0 -> true
    _ -> false

weight :: String -> ScanBias
weight syllable =
    if startsWith (Pattern "x") syllable || startsWith (Pattern "z") syllable then
        IntoDoubleConsonant
    else if test r_cx syllable then
        IntoConsonant
    else
        IntoVowel

data ScanBias = Elidable | IntoVowel | IntoConsonant | IntoDoubleConsonant | LineEnd
derive instance genericScanBias :: Generic ScanBias

instance showScanBias :: Show ScanBias where
  show = gShow

instance eqScanBias :: Eq ScanBias where
  eq = gEq

instance ordScanBias :: Ord ScanBias where
  compare = gCompare

reform :: Syllable -> ScanBias -> SyllableType
reform _ IntoDoubleConsonant = Long
reform (Syllable {stype: Ambiguous _}) LineEnd = Long
reform (Syllable {stype: Short}) LineEnd = Ambiguous Nothing
reform (Syllable {value}) Elidable
    | test r_elision value = Elided
reform (Syllable {stype: Ambiguous Nothing}) IntoVowel = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) Elidable = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) IntoConsonant = Ambiguous (Just true)
reform (Syllable {stype}) _ = stype

resimplify :: Boolean -> SyllableType -> SyllableType
resimplify true (Ambiguous (Just false)) = Short
resimplify true (Ambiguous (Just true)) = Long
resimplify _ stype = stype

inner :: Boolean -> Syllable -> State ScanBias Syllable
inner simplify syllable@(Syllable {value}) = do
    bias <- get
    put (weight value)
    let stype = resimplify simplify $ reform syllable bias
    pure (Syllable { value, stype })

middle :: Boolean -> Array Syllable -> State ScanBias (Array Syllable)
middle simplify syllables = sequenceReversed $ map (inner simplify) syllables

outer :: Boolean -> Res -> State ScanBias Res
outer simplify (Verb w) = do
    bias <- get
    case bias of
        IntoVowel -> put Elidable
        -- double consonants do not affect preceding word in scansion
        IntoDoubleConsonant -> put IntoConsonant
        _ -> pure unit
    syllables <- middle simplify w.syllables
    pure $ Verb { syllables, gloss: w.gloss }
outer _ (res@Punct "\n") = do
    put LineEnd
    pure res
outer _ res = pure res

rescan :: Boolean -> Line -> Line
rescan simplify (Line line) = Line rescanned
    where
        rescanned = evalReversedArrayState statecomputation LineEnd
        statecomputation = map (outer simplify) line

v :: String
v =
    "(?:[aeiouy]͡[aeiouyāēīōūȳ]̄?|(?:a[eu]|oe|eu)(?![̄̈])|[aeiouyāēīōūȳ]̄?|[aeiouy]̄|[äëïöüÿ])"

c :: String
c =
    "(?:[qg]u(?=" <> v <> ")|[ck]h|[bcdfghjklmnprstvwxz]|\\bi(?=" <> v <> "))"

l :: String
l =
    "(?:" <> c <> "|" <> v <> ")"

r_word :: Regex
r_word =
    unsafeRegex ("((?:" <> c <> "|" <> v <> ")+)") (ignoreCase <> global)

r_syllable :: Regex
r_syllable =
    unsafeRegex (c <> "*" <> v <> "(" <> c <> "*$|(?![dbpckgt][rl])" <> c <> "((?=" <> c <> "+" <> v <> "?))" <> ")?") (ignoreCase <> global)

r_short :: Regex
r_short =
    unsafeRegex ("(\\bi?|[^aeiouy]|[qg]u)[aeiouy]$") ignoreCase

r_long :: Regex
r_long =
    unsafeRegex ("[aeiouy]̄|[āēīōūȳ]|a[eu]|oe|eu|(x|z|" <> c <> c <> ")$") ignoreCase

r_cx :: Regex
r_cx =
    unsafeRegex ("^((?!h)" <> c <> "|[ij]" <> v <> ")") ignoreCase

r_elision :: Regex
r_elision =
    unsafeRegex (v <> "m?$") ignoreCase

r_wordbreak :: Regex
r_wordbreak =
    unsafeRegex ("(?:(?:^|" <> l <> ")" <> l <> "*(?=))") ignoreCase

foreign import _findall :: Regex -> String -> Array String

mksyllables :: String -> Array Syllable
mksyllables content =
    content # _findall r_syllable # map mksyllable
    --content # Regex.find Regex.All r_syllable # map (_.match >>> syllable)
    --content # Regex.match r_syllable # fromMaybe [] # map (_.match >>> syllable)

mksyllable :: String -> Syllable
mksyllable s = Syllable
    { value: s
    , stype:
        if test r_short s then
            Short
        else if test r_long s then
            Long
        else
            Ambiguous Nothing
    }

mkline :: Boolean -> String -> Line
mkline simplify content =
    content # mkwords # Array.filter nonempty # Line # rescan simplify
    where
        nonempty (Punct "") = false
        nonempty (Verb { syllables: [] }) = false
        nonempty _ = true

mklines :: Boolean -> String -> Array Line
mklines simplify content =
    trim content # String.split (Pattern "\n") # map (trim >>> mkline simplify)

processtext :: (String -> Res) -> (String -> Res) -> String -> Array Res
processtext mkverb mkpunct =
    let
        mapper i
            | odd i = mkverb
            | otherwise = mkpunct
    in
        Array.mapWithIndex mapper <<< split r_word

mkwords :: String -> Array Res
mkwords content =
    --content # split r_word # map (\s -> Verb { syllables: mksyllables s, gloss: s})
    processtext (\s -> Verb $ { syllables: mksyllables s, gloss: s }) Punct content

data Query a
    = ToggleState a
    | UserInput Event a
    | Insert String a

type UIState =
    { simplify :: Boolean
    , text :: TextCursor
    }

initialState :: UIState
initialState =
    { simplify: true
    , text: TextCursor
        { before: """arma virumque canō, Trōiae quī prīmus ab ōrīs"""
        , selected: "\n"
        , after: """Ītaliam fātō profugus Lāvīni͡aque vēnit"""
        }
    }

legend :: forall a b. Boolean -> HH.HTML a b
legend true =
    HH.div_/>"¯ a long (heavy) syllable, ˘ a short syllable"
legend false =
    HH.div_/>"¯ a long (heavy) syllable, ˜ a syllable long by position, ˇ a syllable short by position, ˘ a short syllable"

newtype TextCursor = TextCursor
    { before :: String
    , selected :: String
    , after :: String
    }

splitAtTuple :: Int -> String -> Tuple String String
splitAtTuple i s = case splitAt i s of
    Just [first, second] -> Tuple first second
    _ | i > 0     -> Tuple s ""
      | otherwise -> Tuple "" s

textCursor :: forall eff. HTMLTextAreaElement -> Eff ( dom :: DOM | eff ) TextCursor
textCursor element = do
    value <- HTextArea.value element
    start <- HTextArea.selectionStart element
    end <- HTextArea.selectionEnd element
    let prior_after = splitAtTuple end value
    let prior = fst prior_after
    let after = snd prior_after
    let before_selected = splitAtTuple start prior
    let before = fst before_selected
    let selected = snd before_selected
    pure $ TextCursor
        { before
        , selected
        , after
        }

setTextCursor :: forall eff. TextCursor -> HTMLTextAreaElement -> Eff ( dom :: DOM | eff ) Unit
setTextCursor (TextCursor { before, selected, after }) element = do
    HTextArea.setValue (before <> selected <> after) element
    let start = length before
    let end = start + length selected
    HTextArea.setSelectionStart start element
    HTextArea.setSelectionEnd end element

tcValue :: TextCursor -> String
tcValue (TextCursor { before, selected, after }) = before <> selected <> after

select :: TextCursor
select = TextCursor
    { before: """arma virumque canō, Trōiae quī prīmus ab ōrīs"""
    , selected: "\n"
    , after: """Ītaliam fātō profugus Lāvīni͡aque vēnit"""
    }

normalize :: String -> String
normalize =
    replace (unsafeRegex "[\\s\\n]+\\n\\s*|\\s*\\n[\\s\\n]+" global) "\n"
    >>> replace (unsafeRegex "\\d+" global) ""
    >>> replace (unsafeRegex "'([^']+)'" global) "‘$1’"
    >>> replace (unsafeRegex "\"([^\"]+)\"" global) "“$1”"
    >>> replace (unsafeRegex "([aeiouy])\\1" global) "$1\x0304"

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (dom :: DOM | eff))
ui = H.component { render, eval, initialState: const initialState, receiver: const Nothing }
  where

  render :: UIState -> H.ComponentHTML Query
  render state =
    HH.div_
        [ HH.h2_/>"Pantheum: Scansion"
        , HH.div_ $ map display $ mklines state.simplify (tcValue state.text)
        , HH.br_
        , legend state.simplify
        , checkbox (HE.input_ ToggleState) [] "Simplify scansion marks" state.simplify
        , button (HE.input_ $ Insert "\x0304") [] "Add macron (¯)"
        , button (HE.input_ $ Insert "\x0361") [] ("Add tie (i\x0361" <> "a)")
        , HH.textarea
            [ HP.placeholder "Text to scan"
            , HP.rows 5
            , HP.value $ tcValue state.text
            , HE.onInput $ HE.input UserInput
            , HE.onClick $ HE.input (UserInput <<< mouseEventToEvent)
            , HE.onKeyUp $ HE.input (UserInput <<< keyboardEventToEvent)
            , HE.onBlur $ HE.input (UserInput <<< focusEventToEvent)
            ]
        , HH.br_
        ]

  eval :: Query ~> H.ComponentDSL UIState Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { simplify: not state.simplify, text: state.text })
    pure next
  eval (Insert insertion next) = do
    state <- get
    let text = case state.text of
            TextCursor { before, selected, after } -> TextCursor
                { before: before
                , selected: selected <> insertion
                , after: after
                }
    --H.liftEff $ setTextCursor text node
    H.modify (\state -> { simplify: state.simplify, text })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLTextAreaElement
    s <- H.liftEff $ textCursor node
    let text = case s of
            TextCursor { before, selected, after } -> TextCursor
                { before: normalize before
                , selected: normalize selected
                , after: normalize after
                }
    H.liftEff $ setTextCursor text node
    H.modify (\state -> { simplify: state.simplify, text })
    pure next

main :: Eff (HalogenEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  runUI ui unit body

module Scansion where

import Prelude
import UIHelpers
import CSS as CSS
import CSS.Overflow as CSS.Overflow
import CSS.TextAlign as CSS.TextAlign
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import DOM.HTML.HTMLTextAreaElement as HTextArea
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import ArrayState (evalArrayState, evalReversedArrayState, sequence, sequenceReversed)
import CSS (CSS, StyleM, ex, fromHexString, nil, value)
import CSS.Common (auto)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.State (State)
import Control.Monad.State.Trans (get, put)
import Control.Plus (empty)
import DOM (DOM)
import DOM.Event.Types (Event)
import DOM.HTML.Types (HTMLInputElement, HTMLTextAreaElement)
import Data.Array (filter, mapWithIndex) as Array
import Data.Generic (class Generic, gCompare, gEq, gShow)
import Data.Int (odd)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.String (Pattern(..), indexOf, joinWith, length, splitAt, trim)
import Data.String (split) as String
import Data.String.Regex (Regex, replace, split, test)
import Data.String.Regex.Flags (global, ignoreCase, noFlags)
import Data.String.Regex.Unsafe (unsafeRegex)
import Data.Tuple (Tuple(..), fst, snd)
import Halogen.Aff (HalogenEffects)
import Halogen.Aff.Util (awaitBody, runHalogenAff)
import Halogen.HTML.CSS (style)
import Halogen.VDom.Driver (runUI)
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

newtype Line =
    Line (Array Res)

instance showLine :: Show Line where
    show (Line line) = joinWith "" do
        res <- line
        pure case res of
            Punct s -> s
            Verb { syllables } ->
                joinWith "" do
                    Syllable { value, stype } <- syllables
                    --pure (value <> show stype)
                    pure value

instance displayLine :: Display Line where
    display line_@(Line line) =
        HH.div_ [ scanned, raw ]
        where
            raw = HH.span [ style $ zindex 1 ] [ HH.text $ show line_ ]
            scanned = HH.div [ divstyle ] $ evalArrayState (map mapper line) 0.0
            divstyle = style do
                CSS.height (1.2#ex)
                zindex (-1)
                no_pointer_events
            mapper (Punct "\n") = pure HH.br_
            mapper (Punct s) = pure (spacer $ HH.text s)
            mapper (Verb { syllables, gloss }) =
                map HH.span_ $ sequence $ map displaySyllableColored syllables

y_mark :: forall a b. CSS -> HP.IProp ( style :: String | a ) b
y_mark extra =
    style do
        CSS.color (unsafePartial $ fromJust $ fromHexString "#F50057")
        CSS.Overflow.overflow CSS.Overflow.visible
        CSS.height (ex 1.0)
        scale 2.0 1.4
        no_user_select
        CSS.margin auto auto auto auto
        CSS.TextAlign.textAlign CSS.TextAlign.center
        extra

instance displaySyllable :: Display Syllable where
    display = displaySyllableStyled (CSS.height nil)

displaySyllableStyled :: forall a b. CSS -> Syllable -> HH.HTML a b
displaySyllableStyled extraStyle (Syllable { value, stype }) =
    HH.div
        [ style do
            CSS.display CSS.inlineBlock
        ]
        [ HH.div [ y_mark extraStyle ] [ HH.text $ show stype ]
        , spacer $ HH.text value
        ]

displaySyllableColored :: forall a b. Syllable -> State Number (HH.HTML a b)
displaySyllableColored syllable@(Syllable { value, stype }) = do
    position <- get
    let incr = case stype of
            Elided ->
                0.0

            Long ->
                1.0

            Ambiguous (Just a) | a ->
                1.0

            _ ->
                0.5
    put (position + incr)
    let clr =
            CSS.color $ fromMaybe (CSS.gray) $ CSS.fromHexString $
                case position of
                    0.0 ->
                        "#F50057"

                    2.0 ->
                        "#D500F9"

                    4.0 ->
                        "#651FFF"

                    6.0 ->
                        "#00E5FF"

                    8.0 ->
                        "#1DE9B6"

                    10.0 ->
                        "#00E676"

                    11.0 ->
                        "#2E7D32"

                    10.5 ->
                        "#FF3D00"

                    11.5 ->
                        "#FF3D00"

                    12.0 ->
                        "#FF3D00"

                    _ ->
                        ""
    pure $ displaySyllableStyled (clr) syllable

data Res
    = Punct String
    | Verb Word

type Word =
    { syllables :: Array Syllable
    , gloss :: String
    }

newtype Syllable = Syllable
    { value :: String
    , stype :: SyllableType
    }

data SyllableType
    = Long
    | Ambiguous (Maybe Boolean)
    | Short
    | Elided

instance showSyllableType :: Show SyllableType where
    show s =
        case s of
            Short ->
                "˘"

            Long ->
                "¯"

            Elided ->
                "˙"

            Ambiguous Nothing ->
                "˟"

            Ambiguous (Just b)
                | b -> "˜"
                | otherwise -> "ˇ"

startsWith :: Pattern -> String -> Boolean
startsWith p s = case indexOf p s of
    Just 0 -> true
    _ -> false

weight :: String -> ScanBias
weight syllable =
    if startsWith (Pattern "x") syllable || startsWith (Pattern "z") syllable then
        IntoDoubleConsonant
    else if test r_cx syllable then
        IntoConsonant
    else
        IntoVowel

data ScanBias = Elidable | IntoVowel | IntoConsonant | IntoDoubleConsonant | LineEnd
derive instance genericScanBias :: Generic ScanBias

instance showScanBias :: Show ScanBias where
  show = gShow

instance eqScanBias :: Eq ScanBias where
  eq = gEq

instance ordScanBias :: Ord ScanBias where
  compare = gCompare

reform :: Syllable -> ScanBias -> SyllableType
reform _ IntoDoubleConsonant = Long
reform (Syllable {stype: Ambiguous _}) LineEnd = Long
reform (Syllable {stype: Short}) LineEnd = Ambiguous Nothing
reform (Syllable {value}) Elidable
    | test r_elision value = Elided
reform (Syllable {stype: Ambiguous Nothing}) IntoVowel = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) Elidable = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) IntoConsonant = Ambiguous (Just true)
reform (Syllable {stype}) _ = stype

resimplify :: Boolean -> SyllableType -> SyllableType
resimplify true (Ambiguous (Just false)) = Short
resimplify true (Ambiguous (Just true)) = Long
resimplify _ stype = stype

inner :: Boolean -> Syllable -> State ScanBias Syllable
inner simplify syllable@(Syllable {value}) = do
    bias <- get
    put (weight value)
    let stype = resimplify simplify $ reform syllable bias
    pure (Syllable { value, stype })

middle :: Boolean -> Array Syllable -> State ScanBias (Array Syllable)
middle simplify syllables = sequenceReversed $ map (inner simplify) syllables

outer :: Boolean -> Res -> State ScanBias Res
outer simplify (Verb w) = do
    bias <- get
    case bias of
        IntoVowel -> put Elidable
        -- double consonants do not affect preceding word in scansion
        IntoDoubleConsonant -> put IntoConsonant
        _ -> pure unit
    syllables <- middle simplify w.syllables
    pure $ Verb { syllables, gloss: w.gloss }
outer _ (res@Punct "\n") = do
    put LineEnd
    pure res
outer _ res = pure res

rescan :: Boolean -> Line -> Line
rescan simplify (Line line) = Line rescanned
    where
        rescanned = evalReversedArrayState statecomputation LineEnd
        statecomputation = map (outer simplify) line

v :: String
v =
    "(?:[aeiouy]͡[aeiouyāēīōūȳ]̄?|(?:a[eu]|oe|eu)(?![̄̈])|[aeiouyāēīōūȳ]̄?|[aeiouy]̄|[äëïöüÿ])"

c :: String
c =
    "(?:[qg]u(?=" <> v <> ")|[ck]h|[bcdfghjklmnprstvwxz]|\\bi(?=" <> v <> "))"

l :: String
l =
    "(?:" <> c <> "|" <> v <> ")"

r_word :: Regex
r_word =
    unsafeRegex ("((?:" <> c <> "|" <> v <> ")+)") (ignoreCase <> global)

r_syllable :: Regex
r_syllable =
    unsafeRegex (c <> "*" <> v <> "(" <> c <> "*$|(?![dbpckgt][rl])" <> c <> "((?=" <> c <> "+" <> v <> "?))" <> ")?") (ignoreCase <> global)

r_short :: Regex
r_short =
    unsafeRegex ("(\\bi?|[^aeiouy]|[qg]u)[aeiouy]$") ignoreCase

r_long :: Regex
r_long =
    unsafeRegex ("[aeiouy]̄|[āēīōūȳ]|a[eu]|oe|eu|(x|z|" <> c <> c <> ")$") ignoreCase

r_cx :: Regex
r_cx =
    unsafeRegex ("^((?!h)" <> c <> "|[ij]" <> v <> "|[aeiouy]̄|[äëïöüÿ])") ignoreCase

r_elision :: Regex
r_elision =
    unsafeRegex (v <> "m?$") ignoreCase

r_wordbreak :: Regex
r_wordbreak =
    unsafeRegex ("(?:(?:^|" <> l <> ")" <> l <> "*(?=))") ignoreCase

foreign import _findall :: Regex -> String -> Array String

mksyllables :: String -> Array Syllable
mksyllables content =
    content # _findall r_syllable # map mksyllable
    --content # Regex.find Regex.All r_syllable # map (_.match >>> syllable)
    --content # Regex.match r_syllable # fromMaybe [] # map (_.match >>> syllable)

mksyllable :: String -> Syllable
mksyllable s = Syllable
    { value: s
    , stype:
        if test r_short s then
            Short
        else if test r_long s then
            Long
        else
            Ambiguous Nothing
    }

mkline :: Boolean -> String -> Line
mkline simplify content =
    content # mkwords # Array.filter nonempty # Line # rescan simplify
    where
        nonempty (Punct "") = false
        nonempty (Verb { syllables: [] }) = false
        nonempty _ = true

mklines :: Boolean -> String -> Array Line
mklines simplify content =
    trim content # String.split (Pattern "\n") # map (trim >>> mkline simplify)

processtext :: (String -> Res) -> (String -> Res) -> String -> Array Res
processtext mkverb mkpunct =
    let
        mapper i
            | odd i = mkverb
            | otherwise = mkpunct
    in
        Array.mapWithIndex mapper <<< split r_word

mkwords :: String -> Array Res
mkwords content =
    --content # split r_word # map (\s -> Verb { syllables: mksyllables s, gloss: s})
    processtext (\s -> Verb $ { syllables: mksyllables s, gloss: s }) Punct content

data Query a
    = ToggleState a
    | UserInput Event a

type UIState =
    { simplify :: Boolean
    , text :: TextCursor
    }

initialState :: UIState
initialState =
    { simplify: true
    , text: TextCursor
        { before: """arma virumque canō, Trōiae quī prīmus ab ōrīs"""
        , selected: "\n"
        , after: """Ītaliam fātō profugus Lāvīni͡aque vēnit"""
        }
    }

legend :: forall a b. Boolean -> HH.HTML a b
legend true =
    HH.div_/>"¯ a long (heavy) syllable, ˘ a short syllable"
legend false =
    HH.div_/>"¯ a long (heavy) syllable, ˜ a syllable long by position, ˇ a syllable short by position, ˘ a short syllable"

newtype TextCursor = TextCursor
    { before :: String
    , selected :: String
    , after :: String
    }

splitAtTuple :: Int -> String -> Tuple String String
splitAtTuple i s = case splitAt i s of
    Just [first, second] -> Tuple first second
    _ | i > 0     -> Tuple s ""
      | otherwise -> Tuple "" s

textCursor :: forall eff. HTMLTextAreaElement -> Eff ( dom :: DOM | eff ) TextCursor
textCursor element = do
    value <- HTextArea.value element
    start <- HTextArea.selectionStart element
    end <- HTextArea.selectionEnd element
    let prior_after = splitAtTuple end value
    let prior = fst prior_after
    let after = snd prior_after
    let before_selected = splitAtTuple start prior
    let before = fst before_selected
    let selected = snd before_selected
    pure $ TextCursor
        { before
        , selected
        , after
        }

setTextCursor :: forall eff. TextCursor -> HTMLTextAreaElement -> Eff ( dom :: DOM | eff ) Unit
setTextCursor (TextCursor { before, selected, after }) element = do
    HTextArea.setValue (before <> selected <> after) element
    let start = length before
    let end = start + length selected
    HTextArea.setSelectionStart start element
    HTextArea.setSelectionEnd end element

tcValue :: TextCursor -> String
tcValue (TextCursor { before, selected, after }) = before <> selected <> after

select :: TextCursor
select = TextCursor
    { before: """arma virumque canō, Trōiae quī prīmus ab ōrīs"""
    , selected: "\n"
    , after: """Ītaliam fātō profugus Lāvīni͡aque vēnit"""
    }

normalize :: String -> String
normalize =
    replace (unsafeRegex "[\\s\\n]+\\n\\s*|\\s*\\n[\\s\\n]+" global) "\n"
    >>> replace (unsafeRegex "\\d+" global) ""
    >>> replace (unsafeRegex "'([^']+)'" global) "‘$1’"
    >>> replace (unsafeRegex "\"([^\"]+)\"" global) "“$1”"

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (dom :: DOM | eff))
ui = H.component { render, eval, initialState: const initialState, receiver: const Nothing }
  where

  render :: UIState -> H.ComponentHTML Query
  render state =
    HH.div_
        [ HH.h2_/>"Pantheum: Scansion"
        , HH.div_ $ map display $ mklines state.simplify (tcValue state.text)
        , HH.br_
        , legend state.simplify
        , checkbox (HE.input_ ToggleState) [] "Simplify scansion marks" state.simplify
        , textarea (HE.input UserInput) [] "Text to scan" 5 (tcValue state.text)
        , HH.br_
        ]

  eval :: Query ~> H.ComponentDSL UIState Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { simplify: not state.simplify, text: state.text })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLTextAreaElement
    --s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    --let text = normalize s
    s <- H.liftEff $ textCursor node
    let text = case s of
            TextCursor { before, selected, after } -> TextCursor
                { before: normalize before
                , selected: normalize selected
                , after: normalize after
                }
    H.liftEff $ setTextCursor text node
    H.modify (\state -> { simplify: state.simplify, text })
    pure next

main :: Eff (HalogenEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  runUI ui unit body


Clean up tests

Clean up tests

module Test.Main where

import Prelude
import Test.Unit
import Test.Unit.Console (TestOutput())

import Global (infinity)
import Data.Date (Now(), now)
import Data.String (contains)
import Data.Maybe (isJust, isNothing)
import Data.Maybe.Unsafe (fromJust)
import Data.Time (Milliseconds(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import qualified Data.Moment.Simple as M
import qualified Data.Moment.Simple.Relative as M
import qualified Data.Moment.Simple.Internal as M

main :: forall eff. Eff ( testOutput :: TestOutput
                        , now :: Now
                        | eff ) Unit
main = do
  now' <- now
  runTest $ do
    test "valid" $ do
      assert "now is always valid" $
        M.isValid (M.fromDate now')

      assert "0 is valid" $
        isJust $ M.fromEpoch $ Milliseconds 0.0

      assert "∞ is invalid" $
        isNothing $ M.fromEpoch $ Milliseconds infinity

    test "relative" $ do
      assertFn "fromNow contains ago" $ \done -> do
        timeStr <- unsafeInterleaveEff $ M.fromNow $ M.fromDate now'
        done $ "ago" `contains` timeStr

      assertFn "fromNow' doesn't contain ago" $ \done -> do
        timeStr <- unsafeInterleaveEff $ M.fromNow' $ M.fromDate now'
        done $ not $ "ago" `contains` timeStr

    test "format" $ do
      assert "ISO-8601" $ do
        let d = fromJust $ M.fromEpoch $ Milliseconds 0.0
        M.formatUTCISO8601 d == "1970-01-01T00:00:00+00:00"

      assert "custom format" $ do
        let d = fromJust $ M.fromEpoch $ Milliseconds 0.0
        M.formatUTC "dddd, MMMM Do YYYY, h:mm:ss a" d == "Thursday, January 1st 1970, 12:00:00 am"

module Test.Main where

import Prelude
import Test.Unit
import Debug.Trace

import Global (infinity)
import Data.Date (now)
import Data.String (contains)
import Data.Maybe (isJust, isNothing)
import Data.Maybe.Unsafe (fromJust)
import Data.Time (Milliseconds(..))
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import qualified Data.Moment.Simple as M
import qualified Data.Moment.Simple.Relative as M
import qualified Data.Moment.Simple.Internal as M

main = do
  now' <- now
  runTest $ do
    test "valid" $ do
      assert "now is always valid" $
        M.isValid (M.fromDate now')

      assert "0 is valid" $
        isJust $ M.fromEpoch $ Milliseconds 0.0

      assert "∞ is invalid" $
        isNothing $ M.fromEpoch $ Milliseconds infinity

    test "relative" $ do
      assertFn "fromNow contains ago" $ \done -> do
        timeStr <- unsafeInterleaveEff $ M.fromNow $ M.fromDate now'
        done $ "ago" `contains` timeStr

      assertFn "fromNow' doesn't contain ago" $ \done -> do
        timeStr <- unsafeInterleaveEff $ M.fromNow' $ M.fromDate now'
        done $ not $ "ago" `contains` timeStr

    test "format" $ do
      assert "ISO-8601" $ do
        let d = fromJust $ M.fromEpoch $ Milliseconds 0.0
        M.formatUTCISO8601 d == "1970-01-01T00:00:00+00:00"

      assert "custom format" $ do
        let d = fromJust $ M.fromEpoch $ Milliseconds 0.0
        M.formatUTC "dddd, MMMM Do YYYY, h:mm:ss a" d == "Thursday, January 1st 1970, 12:00:00 am"