smarter filtering of labels before rendering

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

module Genetics.Browser.Canvas
       ( TrackContainer
       , Renderable
       , BatchDrawing
       , BigDrawing
       , ContentLayer
       , RenderableLayer
       , RenderableLayerHotspots
       , Label
       , LabelPlace(..)
       , _drawing
       , _bigDrawing
       , _drawingBatch
       , _labels
       , createAndAddLayer
       , createAndAddLayer_
       , renderLayer
       , getDimensions
       , _Container
       , dragScroll
       , wheelZoom
       , trackClickHandler
       , trackContainer
       , withLoadingIndicator
       , setTrackContainerSize
       , setElementStyle
       , BrowserContainer
       , browserContainer
       , addTrack
       , getTrack
       ) where

import Prelude

import Data.Array as Array
import Data.Either (Either(..))
import Data.Filterable (filter, filterMap)
import Data.Foldable (any, foldl, for_, length)
import Data.Int as Int
import Data.Lens (Getter', Lens', Prism', preview, prism', to, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Traversable (for, traverse_)
import Data.TraversableWithIndex (forWithIndex)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Unfoldable (unfoldr)
import Data.Variant (Variant, case_, onMatch)
import Effect (Effect)
import Effect.Aff (Aff, delay, error, throwError)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Class.Console (log)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Effect.Uncurried (EffectFn2, EffectFn3, EffectFn5, runEffectFn2, runEffectFn3, runEffectFn5)
import Genetics.Browser.Layer (Component, Layer(Layer), LayerType(Scrolling, Fixed), TrackDimensions, TrackPadding, _Component, asSlot, setContextTranslation, slotContext, slotOffset, slotSize)
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 Partial.Unsafe (unsafeCrashWith)
import Record as Record
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM (Element)
import Web.DOM.Element as Element
import Web.DOM.Node as DOM

foreign import unsafeCreateElementImpl
  :: EffectFn2 String String Element

unsafeCreateElement :: { elementType :: String
                       , id :: String }
                    -> Effect Element
unsafeCreateElement args =
  runEffectFn2
    unsafeCreateElementImpl
    args.elementType args.id

foreign import initializeCanvasImpl
  :: EffectFn2 CanvasElement Canvas.Dimensions Unit

-- | Create a new CanvasElement, not attached to the DOM, with the provided String as its CSS id
createCanvas :: Canvas.Dimensions
             -> String
             -> Effect CanvasElement
createCanvas size name = do
  el <- unsafeCoerce <$>
        unsafeCreateElement { elementType: "canvas", id: name }

  runEffectFn2 initializeCanvasImpl el size

  pure el

foreign import setElementStyleImpl :: EffectFn3
                                      Element String String
                                      Unit

setElementStyle :: Element
                -> String
                -> String
                -> Effect Unit
setElementStyle = runEffectFn3 setElementStyleImpl

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

setCanvasStyles :: CanvasElement -> Array (Tuple String String) -> Effect Unit
setCanvasStyles = setElementStyles <<< unsafeCoerce

setCanvasStyle :: CanvasElement
               -> String
               -> String
               -> Effect Unit
setCanvasStyle = setElementStyle <<< unsafeCoerce

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

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

foreign import appendElem :: Element
                          -> Element
                          -> Effect Unit

appendCanvasElem :: Element -> CanvasElement -> Effect Unit
appendCanvasElem e c = appendElem e (unsafeCoerce c)

-- | Sets some of the track container's CSS to reasonable defaults
foreign import setContainerStyle :: Element -> Canvas.Dimensions -> Effect Unit

foreign import drawCopies
  :: EffectFn5
     CanvasElement
     Canvas.Dimensions
     Context2D
     (Point -> Boolean)
     (Array Point)
     Unit

foreign import setCanvasTranslation :: Point
                                    -> CanvasElement
                                    -> Effect Unit

foreign import elementClickImpl :: EffectFn2
                                   Element (Point -> Effect Unit)
                                   Unit

elementClick :: Element
             -> (Point -> Effect Unit)
             -> Effect Unit
elementClick e = runEffectFn2 elementClickImpl e

-- | Attaches a callback to the trackcontainer, to be called when
-- | the track element is clicked. The callback is called with
-- | coordinates relative to the provided component slot.
trackClickHandler :: ∀ m.
                       MonadEffect m
                    => TrackContainer
                    -> Component (Point -> Effect Unit)
                    -> m Unit
trackClickHandler bc com = liftEffect do
  dims <- getDimensions bc

  let cb = com ^. _Component
      translate p = p - (slotOffset dims $ asSlot com)

  elementClick (bc ^. _Container) (cb <<< translate)

foreign import scrollCanvasImpl :: EffectFn3
                                   CanvasElement CanvasElement Point
                                   Unit

-- | Scroll a buffered canvas by copying its contents to its backbuffer,
-- | then copying it back at an offset
scrollCanvas :: BufferedCanvas
             -> Point
             -> Effect Unit
scrollCanvas (BufferedCanvas bc) = runEffectFn3 scrollCanvasImpl bc.back bc.front

-- | Scroll all buffered canvases in a container
scrollTrack :: TrackContainer
            -> Point
            -> Effect Unit
scrollTrack (TrackContainer bc) pt = do
  layers <- Ref.read bc.layers
  -- | Filter out all layers that don't scroll
  let scrolling = filterMap (preview _Buffer) layers
  -- | then... scroll them
  for_ scrolling \bc' -> scrollCanvas bc' pt

foreign import canvasDragImpl :: CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Effect Unit )
                              -> Effect Unit

foreign import canvasWheelCBImpl :: CanvasElement
                                 -> (Number -> Effect Unit)
                                 -> Effect Unit

-- |
canvasDrag :: CanvasElement
           -> (Either Point Point -> Effect Unit)
           -> Effect Unit
canvasDrag el f =
  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 BrowserContainer and a callback function that is called
-- | with the total dragged distance, on each track, when a click &
-- | drag action is completed.
dragScroll :: BrowserContainer
           -> (Point -> Effect Unit)
           -> Effect Unit
dragScroll (BrowserContainer bc) cb = do
  tracks <- Ref.read bc.tracks

  canvasDrag (unsafeCoerce bc.element) case _ of
    Left  p -> cb p
    Right p -> pure unit

-- | Takes a TrackContainer 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 :: ∀ t r.
             Newtype t { element :: Element | r }
          => t
          -> (Number -> Effect Unit)
          -> Effect Unit
wheelZoom bc cb =
  canvasWheelCBImpl
    (unsafeCoerce $ _.element $ unwrap bc) cb

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

-- 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
                     -> String
                     -> Effect BufferedCanvas
createBufferedCanvas dim name = do
  back  <- createCanvas dim $ name <> "-buffer"
  front <- createCanvas dim $ name
  let bc = BufferedCanvas { back, front }
  blankBuffer bc
  pure bc

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

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

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

blankBuffer :: BufferedCanvas
            -> Effect 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

newtype TrackContainer =
  TrackContainer { layers      :: Ref (Map String LayerCanvas)
                 , dimensions  :: Ref TrackDimensions
                 , element     :: Element
                 , glyphBuffer :: CanvasElement }

derive instance newtypeTrackContainer :: Newtype TrackContainer _

newtype BrowserContainer =
  BrowserContainer { tracks :: Ref (Map String TrackContainer)
                   -- , dimensions :: Ref Canvas.Dimensions
                   , element :: Element }

derive instance newtypeBrowserContainer :: Newtype BrowserContainer _

browserContainer :: ∀ m.
                    MonadEffect m
                 => Element
                 -> m BrowserContainer
browserContainer element = liftEffect do
  -- el <- unsafeCreateElement { elementType: "div", id: "browserContainer" }
  tracks <- Ref.new mempty

  -- add a callback to visually scroll all tracks in the browser, on click & drag
  canvasDrag (unsafeCoerce element) case _ of
    Left  _ -> pure unit
    Right p -> do
      ts <- Ref.read tracks
      for_ ts \c -> scrollTrack c {x: -p.x, y: 0.0}

  pure $ BrowserContainer { tracks, element }

getTrack :: String
         -> BrowserContainer
         -> Aff TrackContainer
getTrack n (BrowserContainer bc) = do
  tracks <- liftEffect $ Ref.read bc.tracks

  case Map.lookup n tracks of
    Just t -> pure t
    Nothing -> throwError
               $ error
               $ "Could not find track '" <> n <> "'!"

addTrack :: ∀ m.
            MonadEffect m
         => BrowserContainer
         -> String
         -> TrackContainer
         -> m Unit
addTrack (BrowserContainer bc) name (TrackContainer tc) = liftEffect do
  Ref.modify_ (Map.insert name (wrap tc)) bc.tracks

  appendElem bc.element tc.element

getDimensions :: ∀ m.
                 MonadEffect m
              => TrackContainer
              -> m TrackDimensions
getDimensions (TrackContainer {dimensions}) =
  liftEffect $ Ref.read dimensions

_Layers :: Lens' TrackContainer (Ref (Map String LayerCanvas))
_Layers = _Newtype <<< Lens.prop (SProxy :: SProxy "layers")

_Container :: ∀ t r.
              Newtype t { element :: Element | r }
           => Lens' t Element
_Container = _Newtype <<< Lens.prop (SProxy :: SProxy "element")

setTrackContainerSize :: ∀ m.
                           MonadEffect m
                        => Canvas.Dimensions
                        -> TrackContainer
                        -> m Unit
setTrackContainerSize dim bc'@(TrackContainer bc) = liftEffect $ do
  Ref.modify_ (_ { size = dim }) bc.dimensions
  setContainerStyle bc.element dim
  traverse_ (resizeLayer dim) =<< getLayers bc'

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

-- | Creates an *empty* TrackContainer, to which layers can be added,
-- | but does not attach its Element to the DOM
trackContainer :: Canvas.Dimensions
               -> TrackPadding
               -> String
               -> Effect TrackContainer
trackContainer size padding name = do

  element <- unsafeCreateElement { elementType: "div"
                                 , id: name }

  setContainerStyle element size

  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

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

  pure $
    TrackContainer
      { layers, dimensions, element, glyphBuffer }

withLoadingIndicator :: ∀ m a.
                         MonadEffect m
                      => TrackContainer
                      -> m a
                      -> m a
withLoadingIndicator tc cb = do
  let nd = Element.toNode $ tc ^. _Container

  liftEffect $ DOM.setTextContent "loading" nd
  val <- cb
  liftEffect $ DOM.setTextContent "" nd
  pure val

-- | Set the CSS z-indices of the Layers in the track, so their
-- | canvases are drawn in the correct order (i.e. as the
-- | TrackContainer layer list is ordered)
zIndexLayers :: ∀ m.
                MonadEffect m
             => TrackContainer
             -> List String
             -> m Unit
zIndexLayers (TrackContainer bc) order = liftEffect do
  layers <- Ref.read bc.layers
  let layerNames = Map.keys layers
      n = length layerNames :: Int
  -- if order does not have the same layer names as the TrackContainer, fail
  if List.null (List.difference order $ List.fromFoldable layerNames)
    then do
      void $ forWithIndex order \i ln ->
        traverse_ (\l -> setCanvasZIndex (l ^. _FrontCanvas) i)
          $ Map.lookup ln layers

    else
      unsafeCrashWith "Called `zIndexLayers` with an order that did not contain all layers"

getLayers :: ∀ m.
             MonadEffect m
          => TrackContainer
          -> m (Map String LayerCanvas)
getLayers (TrackContainer bc) =
  liftEffect $ Ref.read bc.layers

resizeLayer :: ∀ m.
               MonadEffect m
            => Canvas.Dimensions
            -> LayerCanvas
            -> m Unit
resizeLayer dims lc = liftEffect do
  case lc of
    Static e -> void $ Canvas.setCanvasDimensions e dims
    Buffer b -> setBufferedCanvasSize dims b

-- | Add a LayerCanvas with the provided name to the track container
-- | and its element. The LayerCanvas' front element is added without
-- | a Z-index, and replaces any existing layer with the same name!
addLayer :: ∀ m.
            MonadEffect m
         => TrackContainer
         -> String
         -> LayerCanvas
         -> m Unit
addLayer bc name lc = liftEffect do
  layers <- getLayers bc

  Ref.modify_  (Map.insert name lc) (bc ^. _Layers)
  let toNode l = unsafeCoerce $ l ^. _FrontCanvas

  void $ case Map.lookup name layers of
    Just oldL  -> DOM.replaceChild (toNode lc) (toNode oldL) (unsafeCoerce $ bc ^. _Container)
    Nothing    -> DOM.appendChild  (toNode lc)               (unsafeCoerce $ bc ^. _Container)

-- | Delete a LayerCanvas by name from the track container, and the
-- | container DOM element.
deleteLayer :: ∀ m.
               MonadEffect m
            => TrackContainer
            -> String
            -> m Unit
deleteLayer bc name = liftEffect do
  layers <- getLayers bc
  let toNode l = unsafeCoerce $ l ^. _FrontCanvas

  case Map.lookup name layers of
    Nothing -> pure unit
    Just l  -> void $ DOM.removeChild (toNode l) (unsafeCoerce $ bc ^. _Container)

  Ref.modify_ (Map.delete name) $ bc ^. _Layers

renderGlyphs :: CanvasElement
             -> Canvas.Context2D
             -> Pair Number
             -> { drawing :: Drawing, points :: Array Point }
             -> Effect Unit
renderGlyphs glyphBuffer ctx (Pair l r) {drawing, points}  = do
  glyphCtx <- Canvas.getContext2D glyphBuffer

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

  clearCanvas glyphCtx glyphBufferSize

  Drawing.render glyphCtx
    $ Drawing.translate x0 y0 drawing

  let pred {x} = x >= l && x <= r

  runEffectFn5 drawCopies glyphBuffer glyphBufferSize ctx pred 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, filtering by a horizontal range of pixels
labelBox :: Pair Number
         -> Context2D
         -> Label
         -> Effect Canvas.Rectangle
labelBox (Pair minX maxX) ctx {text, point, gravity} = do

  {width} <- Canvas.withContext ctx do
    _ <- Canvas.setFont ctx labelFont
    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
       , width, height }

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

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

renderLabels :: Pair Number
             -> List Label
             -> Context2D
             -> Effect Unit
renderLabels vis@(Pair minX maxX) ls' ctx = do

  let arr = filter (\l -> l.point.x < maxX && l.point.x+100.0 > minX)
            $ Array.fromFoldable ls'

  boxed <- for arr \lb -> {text: lb.text, rect: _}
                          <$> labelBox vis ctx lb

  let toRender = foldl appendBoxed mempty boxed

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

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

data LayerCanvas =
    Static Canvas.CanvasElement
  | Buffer BufferedCanvas

_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

type BatchDrawing = { drawing :: Drawing, points :: Array Point }
type BigDrawing = { drawing :: Unit -> Drawing
                  , topLeft :: Point
                  , bottomRight :: Point }

type Renderable =
  Variant ( drawing      :: Drawing
          , bigDrawing   :: BigDrawing
          , drawingBatch :: Array BatchDrawing
          , labels       :: List Label )

_drawing      = SProxy :: SProxy "drawing"
_bigDrawing      = SProxy :: SProxy "bigDrawing"
_drawingBatch = SProxy :: SProxy "drawingBatch"
_labels       = SProxy :: SProxy "labels"

-- | A `ContentLayer` represents anything that can be produced in the
-- | context of a Layer with a Canvas, and some sort of additional configuration.
type ContentLayer c a = Layer (c -> Canvas.Dimensions -> a)

type RenderableLayer c = ContentLayer c (List Renderable)
type RenderableLayerHotspots c a =
  ContentLayer c { renderables :: List Renderable
                 , hotspots :: Number -> Point -> Array a }

-- | Provided a TrackContainer, we can initialize and add a named layer.
-- | This returns a function that can be used to render to the layer maybe idk????
-- | If the layer already existed, overwrites it
createAndAddLayer :: ∀ m c a.
                     MonadAff m
                  => TrackContainer
                  -> String
                  -> RenderableLayerHotspots c a
                  -> m { render :: c -> m (List Renderable)
                       , drawOnCanvas :: Pair Number -> List Renderable -> m Unit
                       , lastHotspots :: m (Number -> Point -> Array a) }
createAndAddLayer bc name layer@(Layer lt _ com) = do

  -- 1. create the layercanvas

  size <- _.size <$> getDimensions bc
  let pos = { left: 0.0, top: 0.0 }

  canvas <- liftEffect do
    cv <- case lt of
      Fixed     -> Static <$> createCanvas         size name
      Scrolling -> Buffer <$> createBufferedCanvas size name
    setCanvasPosition pos (cv ^. _FrontCanvas)
    pure cv

  hotspotsRef <- liftEffect $ Ref.new { offset: 0.0, hotspots: (\r p -> []) }
  let lastHotspots = liftEffect do
        { offset, hotspots } <- Ref.read hotspotsRef
        pure \r {x, y} -> hotspots r {x: x+offset, y}

  -- 2. add the canvas to the trackcontainer & DOM
  let layerRef = _.layers $ unwrap bc
  liftEffect do
    Ref.modify_ (Map.insert name canvas) layerRef
    appendCanvasElem (unwrap bc).element $ canvas ^. _FrontCanvas

  -- 3. create the rendering function
  let render :: c -> m (List Renderable)
      render c = do
        dims <- getDimensions bc

        let toRender = (com ^. _Component) c $ slotSize dims (asSlot com)

        liftEffect $ Ref.modify_ (_ { hotspots = toRender.hotspots }) hotspotsRef

        pure toRender.renderables

      drawOnCanvas :: Pair Number -> List Renderable -> m Unit
      drawOnCanvas (Pair l r) renderables = do
        layers <- getLayers bc

        liftEffect $ Ref.modify_ ( _ { offset = l }) hotspotsRef
        -- TODO handle exceptions!!! :|
        el  <- case Map.lookup name layers of
                 Nothing -> unsafeCrashWith $ "Tried to render layer '" <> name <> "', but it did not exist!"
                 Just e  -> pure $ e ^. _FrontCanvas

        dims <- getDimensions bc
        ctx <- slotContext layer dims el

        liftEffect $ Canvas.withContext ctx do
          setContextTranslation {x: zero, y: zero} ctx
          void $ Canvas.clearRect ctx $ Record.merge {x: 0.0, y: 0.0} dims.size

        -- temporary hack to offset scrolling tracks as needed

        _ <- liftEffect $ Canvas.translate ctx { translateX: -l, translateY: 0.0 }

        -- use the List Renderable to draw to the canvas
        let
            drawing :: Drawing -> m Unit
            drawing d = liftEffect $ Drawing.render ctx d

            bigDrawing :: BigDrawing -> m Unit
            bigDrawing d = liftEffect do
              when (d.topLeft.x <= r && d.bottomRight.x >= l) do
                Drawing.render ctx
                  $ Drawing.translate d.topLeft.x d.topLeft.y
                  $ d.drawing unit

            drawingBatch :: Array { drawing :: Drawing, points :: Array Point }
                     -> m Unit
            drawingBatch ds = liftEffect $ for_ ds
                            $ renderGlyphs (_.glyphBuffer $ unwrap bc) ctx (Pair l r)

            labels :: List Label -> m Unit
            labels ls = liftEffect $ renderLabels (Pair l r) ls ctx

        let chunkSize = 100

            chunkF l = if List.null l
                       then Nothing
                       else Just (Tuple (List.take chunkSize l) (List.drop chunkSize l))

            chunks :: List _
            chunks = unfoldr chunkF renderables

        for_ chunks \c -> do

          for_ c \d -> do
            case_ # onMatch { drawing, bigDrawing, drawingBatch, labels } $ d

          liftAff $ delay $ wrap 0.01

  pure { render, drawOnCanvas, lastHotspots }

-- | Used for layers that don't contain clickable features
createAndAddLayer_ :: ∀ m c.
                     MonadAff m
                  => TrackContainer
                  -> String
                  -> RenderableLayer c
                  -> m { render :: c -> m (List Renderable)
                       , drawOnCanvas :: Pair Number -> List Renderable -> m Unit }
createAndAddLayer_ bc name layer@(Layer lt _ com) = do
  -- silly solution to avoid code duping createAndAddLayer
  let layer' :: ∀ a. RenderableLayerHotspots c a
      layer' = (map <<< map <<< map) (\ renderables -> { renderables, hotspots: \r p -> [] }) layer

  { render, drawOnCanvas } <- createAndAddLayer bc name layer'
  pure { render, drawOnCanvas }

-- | Convenience function for rendering layers when manipulating the
-- | Renderable contents isn't desired.
renderLayer :: ∀ m c r.
               MonadAff m
            => Pair Number
            -> c
            -> { render :: c -> m (List Renderable)
               , drawOnCanvas :: Pair Number -> List Renderable -> m Unit
               | r }
            -> m Unit
renderLayer p c l = l.render c >>= l.drawOnCanvas p

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

module Genetics.Browser.Canvas
       ( TrackContainer
       , Renderable
       , BatchDrawing
       , BigDrawing
       , ContentLayer
       , RenderableLayer
       , RenderableLayerHotspots
       , Label
       , LabelPlace(..)
       , _drawing
       , _bigDrawing
       , _drawingBatch
       , _labels
       , createAndAddLayer
       , createAndAddLayer_
       , renderLayer
       , getDimensions
       , _Container
       , dragScroll
       , wheelZoom
       , trackClickHandler
       , trackContainer
       , withLoadingIndicator
       , setTrackContainerSize
       , setElementStyle
       , BrowserContainer
       , browserContainer
       , addTrack
       , getTrack
       ) where

import Prelude

import Data.Array as Array
import Data.Either (Either(..))
import Data.Filterable (filterMap)
import Data.Foldable (any, foldl, for_, length)
import Data.Int as Int
import Data.Lens (Getter', Lens', Prism', preview, prism', to, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse, traverse_)
import Data.TraversableWithIndex (forWithIndex)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Unfoldable (unfoldr)
import Data.Variant (Variant, case_, onMatch)
import Data.Witherable (wither)
import Effect (Effect)
import Effect.Aff (Aff, delay, error, throwError)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Class.Console (log)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Effect.Uncurried (EffectFn2, EffectFn3, EffectFn5, runEffectFn2, runEffectFn3, runEffectFn5)
import Genetics.Browser.Layer (Component, Layer(Layer), LayerType(Scrolling, Fixed), TrackDimensions, TrackPadding, _Component, asSlot, setContextTranslation, slotContext, slotOffset, slotSize)
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 Partial.Unsafe (unsafeCrashWith)
import Record as Record
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM (Element)
import Web.DOM.Document (createElement)
import Web.DOM.Element as Element
import Web.DOM.Node as DOM

foreign import unsafeCreateElementImpl
  :: EffectFn2 String String Element

unsafeCreateElement :: { elementType :: String
                       , id :: String }
                    -> Effect Element
unsafeCreateElement args =
  runEffectFn2
    unsafeCreateElementImpl
    args.elementType args.id

foreign import initializeCanvasImpl
  :: EffectFn2 CanvasElement Canvas.Dimensions Unit

-- | Create a new CanvasElement, not attached to the DOM, with the provided String as its CSS id
createCanvas :: Canvas.Dimensions
             -> String
             -> Effect CanvasElement
createCanvas size name = do
  el <- unsafeCoerce <$>
        unsafeCreateElement { elementType: "canvas", id: name }

  runEffectFn2 initializeCanvasImpl el size

  pure el

foreign import setElementStyleImpl :: EffectFn3
                                      Element String String
                                      Unit

setElementStyle :: Element
                -> String
                -> String
                -> Effect Unit
setElementStyle = runEffectFn3 setElementStyleImpl

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

setCanvasStyles :: CanvasElement -> Array (Tuple String String) -> Effect Unit
setCanvasStyles = setElementStyles <<< unsafeCoerce

setCanvasStyle :: CanvasElement
               -> String
               -> String
               -> Effect Unit
setCanvasStyle = setElementStyle <<< unsafeCoerce

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

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

foreign import appendElem :: Element
                          -> Element
                          -> Effect Unit

appendCanvasElem :: Element -> CanvasElement -> Effect Unit
appendCanvasElem e c = appendElem e (unsafeCoerce c)

-- | Sets some of the track container's CSS to reasonable defaults
foreign import setContainerStyle :: Element -> Canvas.Dimensions -> Effect Unit

foreign import drawCopies
  :: EffectFn5
     CanvasElement
     Canvas.Dimensions
     Context2D
     (Point -> Boolean)
     (Array Point)
     Unit

foreign import setCanvasTranslation :: Point
                                    -> CanvasElement
                                    -> Effect Unit

foreign import elementClickImpl :: EffectFn2
                                   Element (Point -> Effect Unit)
                                   Unit

elementClick :: Element
             -> (Point -> Effect Unit)
             -> Effect Unit
elementClick e = runEffectFn2 elementClickImpl e

-- | Attaches a callback to the trackcontainer, to be called when
-- | the track element is clicked. The callback is called with
-- | coordinates relative to the provided component slot.
trackClickHandler :: ∀ m.
                       MonadEffect m
                    => TrackContainer
                    -> Component (Point -> Effect Unit)
                    -> m Unit
trackClickHandler bc com = liftEffect do
  dims <- getDimensions bc

  let cb = com ^. _Component
      translate p = p - (slotOffset dims $ asSlot com)

  elementClick (bc ^. _Container) (cb <<< translate)

foreign import scrollCanvasImpl :: EffectFn3
                                   CanvasElement CanvasElement Point
                                   Unit

-- | Scroll a buffered canvas by copying its contents to its backbuffer,
-- | then copying it back at an offset
scrollCanvas :: BufferedCanvas
             -> Point
             -> Effect Unit
scrollCanvas (BufferedCanvas bc) = runEffectFn3 scrollCanvasImpl bc.back bc.front

-- | Scroll all buffered canvases in a container
scrollTrack :: TrackContainer
            -> Point
            -> Effect Unit
scrollTrack (TrackContainer bc) pt = do
  layers <- Ref.read bc.layers
  -- | Filter out all layers that don't scroll
  let scrolling = filterMap (preview _Buffer) layers
  -- | then... scroll them
  for_ scrolling \bc' -> scrollCanvas bc' pt

foreign import canvasDragImpl :: CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Effect Unit )
                              -> Effect Unit

foreign import canvasWheelCBImpl :: CanvasElement
                                 -> (Number -> Effect Unit)
                                 -> Effect Unit

-- |
canvasDrag :: CanvasElement
           -> (Either Point Point -> Effect Unit)
           -> Effect Unit
canvasDrag el f =
  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 BrowserContainer and a callback function that is called
-- | with the total dragged distance, on each track, when a click &
-- | drag action is completed.
dragScroll :: BrowserContainer
           -> (Point -> Effect Unit)
           -> Effect Unit
dragScroll (BrowserContainer bc) cb = do
  tracks <- Ref.read bc.tracks

  canvasDrag (unsafeCoerce bc.element) case _ of
    Left  p -> cb p
    Right p -> pure unit

-- | Takes a TrackContainer 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 :: ∀ t r.
             Newtype t { element :: Element | r }
          => t
          -> (Number -> Effect Unit)
          -> Effect Unit
wheelZoom bc cb =
  canvasWheelCBImpl
    (unsafeCoerce $ _.element $ unwrap bc) cb

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

-- 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
                     -> String
                     -> Effect BufferedCanvas
createBufferedCanvas dim name = do
  back  <- createCanvas dim $ name <> "-buffer"
  front <- createCanvas dim $ name
  let bc = BufferedCanvas { back, front }
  blankBuffer bc
  pure bc

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

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

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

blankBuffer :: BufferedCanvas
            -> Effect 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

newtype TrackContainer =
  TrackContainer { layers      :: Ref (Map String LayerCanvas)
                 , dimensions  :: Ref TrackDimensions
                 , element     :: Element
                 , glyphBuffer :: CanvasElement }

derive instance newtypeTrackContainer :: Newtype TrackContainer _

newtype BrowserContainer =
  BrowserContainer { tracks :: Ref (Map String TrackContainer)
                   -- , dimensions :: Ref Canvas.Dimensions
                   , element :: Element }

derive instance newtypeBrowserContainer :: Newtype BrowserContainer _

browserContainer :: ∀ m.
                    MonadEffect m
                 => Element
                 -> m BrowserContainer
browserContainer element = liftEffect do
  -- el <- unsafeCreateElement { elementType: "div", id: "browserContainer" }
  tracks <- Ref.new mempty

  -- add a callback to visually scroll all tracks in the browser, on click & drag
  canvasDrag (unsafeCoerce element) case _ of
    Left  _ -> pure unit
    Right p -> do
      ts <- Ref.read tracks
      for_ ts \c -> scrollTrack c {x: -p.x, y: 0.0}

  pure $ BrowserContainer { tracks, element }

getTrack :: String
         -> BrowserContainer
         -> Aff TrackContainer
getTrack n (BrowserContainer bc) = do
  tracks <- liftEffect $ Ref.read bc.tracks

  case Map.lookup n tracks of
    Just t -> pure t
    Nothing -> throwError
               $ error
               $ "Could not find track '" <> n <> "'!"

addTrack :: ∀ m.
            MonadEffect m
         => BrowserContainer
         -> String
         -> TrackContainer
         -> m Unit
addTrack (BrowserContainer bc) name (TrackContainer tc) = liftEffect do
  Ref.modify_ (Map.insert name (wrap tc)) bc.tracks

  appendElem bc.element tc.element

getDimensions :: ∀ m.
                 MonadEffect m
              => TrackContainer
              -> m TrackDimensions
getDimensions (TrackContainer {dimensions}) =
  liftEffect $ Ref.read dimensions

_Layers :: Lens' TrackContainer (Ref (Map String LayerCanvas))
_Layers = _Newtype <<< Lens.prop (SProxy :: SProxy "layers")

_Container :: ∀ t r.
              Newtype t { element :: Element | r }
           => Lens' t Element
_Container = _Newtype <<< Lens.prop (SProxy :: SProxy "element")

setTrackContainerSize :: ∀ m.
                           MonadEffect m
                        => Canvas.Dimensions
                        -> TrackContainer
                        -> m Unit
setTrackContainerSize dim bc'@(TrackContainer bc) = liftEffect $ do
  Ref.modify_ (_ { size = dim }) bc.dimensions
  setContainerStyle bc.element dim
  traverse_ (resizeLayer dim) =<< getLayers bc'

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

-- | Creates an *empty* TrackContainer, to which layers can be added,
-- | but does not attach its Element to the DOM
trackContainer :: Canvas.Dimensions
               -> TrackPadding
               -> String
               -> Effect TrackContainer
trackContainer size padding name = do

  element <- unsafeCreateElement { elementType: "div"
                                 , id: name }

  setContainerStyle element size

  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

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

  pure $
    TrackContainer
      { layers, dimensions, element, glyphBuffer }

withLoadingIndicator :: ∀ m a.
                         MonadEffect m
                      => TrackContainer
                      -> m a
                      -> m a
withLoadingIndicator tc cb = do
  let nd = Element.toNode $ tc ^. _Container

  liftEffect $ DOM.setTextContent "loading" nd
  val <- cb
  liftEffect $ DOM.setTextContent "" nd
  pure val

-- | Set the CSS z-indices of the Layers in the track, so their
-- | canvases are drawn in the correct order (i.e. as the
-- | TrackContainer layer list is ordered)
zIndexLayers :: ∀ m.
                MonadEffect m
             => TrackContainer
             -> List String
             -> m Unit
zIndexLayers (TrackContainer bc) order = liftEffect do
  layers <- Ref.read bc.layers
  let layerNames = Map.keys layers
      n = length layerNames :: Int
  -- if order does not have the same layer names as the TrackContainer, fail
  if List.null (List.difference order $ List.fromFoldable layerNames)
    then do
      void $ forWithIndex order \i ln ->
        traverse_ (\l -> setCanvasZIndex (l ^. _FrontCanvas) i)
          $ Map.lookup ln layers

    else
      unsafeCrashWith "Called `zIndexLayers` with an order that did not contain all layers"

getLayers :: ∀ m.
             MonadEffect m
          => TrackContainer
          -> m (Map String LayerCanvas)
getLayers (TrackContainer bc) =
  liftEffect $ Ref.read bc.layers

resizeLayer :: ∀ m.
               MonadEffect m
            => Canvas.Dimensions
            -> LayerCanvas
            -> m Unit
resizeLayer dims lc = liftEffect do
  case lc of
    Static e -> void $ Canvas.setCanvasDimensions e dims
    Buffer b -> setBufferedCanvasSize dims b

-- | Add a LayerCanvas with the provided name to the track container
-- | and its element. The LayerCanvas' front element is added without
-- | a Z-index, and replaces any existing layer with the same name!
addLayer :: ∀ m.
            MonadEffect m
         => TrackContainer
         -> String
         -> LayerCanvas
         -> m Unit
addLayer bc name lc = liftEffect do
  layers <- getLayers bc

  Ref.modify_  (Map.insert name lc) (bc ^. _Layers)
  let toNode l = unsafeCoerce $ l ^. _FrontCanvas

  void $ case Map.lookup name layers of
    Just oldL  -> DOM.replaceChild (toNode lc) (toNode oldL) (unsafeCoerce $ bc ^. _Container)
    Nothing    -> DOM.appendChild  (toNode lc)               (unsafeCoerce $ bc ^. _Container)

-- | Delete a LayerCanvas by name from the track container, and the
-- | container DOM element.
deleteLayer :: ∀ m.
               MonadEffect m
            => TrackContainer
            -> String
            -> m Unit
deleteLayer bc name = liftEffect do
  layers <- getLayers bc
  let toNode l = unsafeCoerce $ l ^. _FrontCanvas

  case Map.lookup name layers of
    Nothing -> pure unit
    Just l  -> void $ DOM.removeChild (toNode l) (unsafeCoerce $ bc ^. _Container)

  Ref.modify_ (Map.delete name) $ bc ^. _Layers

renderGlyphs :: CanvasElement
             -> Canvas.Context2D
             -> Pair Number
             -> { drawing :: Drawing, points :: Array Point }
             -> Effect Unit
renderGlyphs glyphBuffer ctx (Pair l r) {drawing, points}  = do
  glyphCtx <- Canvas.getContext2D glyphBuffer

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

  clearCanvas glyphCtx glyphBufferSize

  Drawing.render glyphCtx
    $ Drawing.translate x0 y0 drawing

  let pred {x} = x >= l && x <= r

  runEffectFn5 drawCopies glyphBuffer glyphBufferSize ctx pred 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, filtering by a horizontal range of pixels
labelBox :: Pair Number
         -> Context2D
         -> Label
         -> Effect (Maybe Canvas.Rectangle)
labelBox (Pair minX maxX) ctx {text, point, gravity} = do

  {width} <- Canvas.withContext ctx do
    _ <- Canvas.setFont ctx labelFont
    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 $ if x < maxX && x+width > minX
    then pure $ { x, y: point.y - height
                , width, height }
    else Nothing

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

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

renderLabels :: Pair Number
             -> List Label
             -> Context2D
             -> Effect Unit
renderLabels vis ls' ctx = do

  boxed <- wither (\lb -> map {text: lb.text, rect: _}
                          <$> labelBox vis ctx lb) ls'

  let toRender = foldl appendBoxed mempty boxed

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

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

data LayerCanvas =
    Static Canvas.CanvasElement
  | Buffer BufferedCanvas

_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

type BatchDrawing = { drawing :: Drawing, points :: Array Point }
type BigDrawing = { drawing :: Unit -> Drawing
                  , topLeft :: Point
                  , bottomRight :: Point }

type Renderable =
  Variant ( drawing      :: Drawing
          , bigDrawing   :: BigDrawing
          , drawingBatch :: Array BatchDrawing
          , labels       :: List Label )

_drawing      = SProxy :: SProxy "drawing"
_bigDrawing      = SProxy :: SProxy "bigDrawing"
_drawingBatch = SProxy :: SProxy "drawingBatch"
_labels       = SProxy :: SProxy "labels"

-- | A `ContentLayer` represents anything that can be produced in the
-- | context of a Layer with a Canvas, and some sort of additional configuration.
type ContentLayer c a = Layer (c -> Canvas.Dimensions -> a)

type RenderableLayer c = ContentLayer c (List Renderable)
type RenderableLayerHotspots c a =
  ContentLayer c { renderables :: List Renderable
                 , hotspots :: Number -> Point -> Array a }

-- | Provided a TrackContainer, we can initialize and add a named layer.
-- | This returns a function that can be used to render to the layer maybe idk????
-- | If the layer already existed, overwrites it
createAndAddLayer :: ∀ m c a.
                     MonadAff m
                  => TrackContainer
                  -> String
                  -> RenderableLayerHotspots c a
                  -> m { render :: c -> m (List Renderable)
                       , drawOnCanvas :: Pair Number -> List Renderable -> m Unit
                       , lastHotspots :: m (Number -> Point -> Array a) }
createAndAddLayer bc name layer@(Layer lt _ com) = do

  -- 1. create the layercanvas

  size <- _.size <$> getDimensions bc
  let pos = { left: 0.0, top: 0.0 }

  canvas <- liftEffect do
    cv <- case lt of
      Fixed     -> Static <$> createCanvas         size name
      Scrolling -> Buffer <$> createBufferedCanvas size name
    setCanvasPosition pos (cv ^. _FrontCanvas)
    pure cv

  hotspotsRef <- liftEffect $ Ref.new { offset: 0.0, hotspots: (\r p -> []) }
  let lastHotspots = liftEffect do
        { offset, hotspots } <- Ref.read hotspotsRef
        pure \r {x, y} -> hotspots r {x: x+offset, y}

  -- 2. add the canvas to the trackcontainer & DOM
  let layerRef = _.layers $ unwrap bc
  liftEffect do
    Ref.modify_ (Map.insert name canvas) layerRef
    appendCanvasElem (unwrap bc).element $ canvas ^. _FrontCanvas

  -- 3. create the rendering function
  let render :: c -> m (List Renderable)
      render c = do
        dims <- getDimensions bc

        let toRender = (com ^. _Component) c $ slotSize dims (asSlot com)

        liftEffect $ Ref.modify_ (_ { hotspots = toRender.hotspots }) hotspotsRef

        pure toRender.renderables

      drawOnCanvas :: Pair Number -> List Renderable -> m Unit
      drawOnCanvas (Pair l r) renderables = do
        layers <- getLayers bc

        liftEffect $ Ref.modify_ ( _ { offset = l }) hotspotsRef
        -- TODO handle exceptions!!! :|
        el  <- case Map.lookup name layers of
                 Nothing -> unsafeCrashWith $ "Tried to render layer '" <> name <> "', but it did not exist!"
                 Just e  -> pure $ e ^. _FrontCanvas

        dims <- getDimensions bc
        ctx <- slotContext layer dims el

        liftEffect $ Canvas.withContext ctx do
          setContextTranslation {x: zero, y: zero} ctx
          void $ Canvas.clearRect ctx $ Record.merge {x: 0.0, y: 0.0} dims.size

        -- temporary hack to offset scrolling tracks as needed

        _ <- liftEffect $ Canvas.translate ctx { translateX: -l, translateY: 0.0 }

        -- use the List Renderable to draw to the canvas
        let
            drawing :: Drawing -> m Unit
            drawing d = liftEffect $ Drawing.render ctx d

            bigDrawing :: BigDrawing -> m Unit
            bigDrawing d = liftEffect do
              when (d.topLeft.x <= r && d.bottomRight.x >= l) do
                Drawing.render ctx
                  $ Drawing.translate d.topLeft.x d.topLeft.y
                  $ d.drawing unit

            drawingBatch :: Array { drawing :: Drawing, points :: Array Point }
                     -> m Unit
            drawingBatch ds = liftEffect $ for_ ds
                            $ renderGlyphs (_.glyphBuffer $ unwrap bc) ctx (Pair l r)

            labels :: List Label -> m Unit
            labels ls = liftEffect $ renderLabels (Pair l r) ls ctx

        let chunkSize = 100

            chunkF l = if List.null l
                       then Nothing
                       else Just (Tuple (List.take chunkSize l) (List.drop chunkSize l))

            chunks :: List _
            chunks = unfoldr chunkF renderables

        for_ chunks \c -> do

          for_ c \d -> do
            case_ # onMatch { drawing, bigDrawing, drawingBatch, labels } $ d

          liftAff $ delay $ wrap 0.01

  pure { render, drawOnCanvas, lastHotspots }

-- | Used for layers that don't contain clickable features
createAndAddLayer_ :: ∀ m c.
                     MonadAff m
                  => TrackContainer
                  -> String
                  -> RenderableLayer c
                  -> m { render :: c -> m (List Renderable)
                       , drawOnCanvas :: Pair Number -> List Renderable -> m Unit }
createAndAddLayer_ bc name layer@(Layer lt _ com) = do
  -- silly solution to avoid code duping createAndAddLayer
  let layer' :: ∀ a. RenderableLayerHotspots c a
      layer' = (map <<< map <<< map) (\ renderables -> { renderables, hotspots: \r p -> [] }) layer

  { render, drawOnCanvas } <- createAndAddLayer bc name layer'
  pure { render, drawOnCanvas }

-- | Convenience function for rendering layers when manipulating the
-- | Renderable contents isn't desired.
renderLayer :: ∀ m c r.
               MonadAff m
            => Pair Number
            -> c
            -> { render :: c -> m (List Renderable)
               , drawOnCanvas :: Pair Number -> List Renderable -> m Unit
               | r }
            -> m Unit
renderLayer p c l = l.render c >>= l.drawOnCanvas p


Fix shadowing warning

Fix shadowing warning

module Test.Spec.Reporter.Base
       ( defaultUpdate
       , defaultSummary
       , defaultReporter
       ) where

import Prelude
import Control.Monad.Eff.Exception as Error
import Control.Monad.State as State
import Data.Array as Array
import Data.String as String
import Test.Spec as S
import Test.Spec.Color as Color
import Test.Spec.Summary as Summary
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.State (StateT, evalStateT)
import Control.Monad.Trans.Class (lift)
import Data.Array ((:), reverse)
import Data.Foldable (intercalate)
import Data.Traversable (for_)
import Pipes (await, yield)
import Pipes.Core (Pipe)
import Test.Spec (Group, Result(..))
import Test.Spec.Color (colored)
import Test.Spec.Runner (Reporter)
import Test.Spec.Runner.Event (Event)
import Test.Spec.Summary (Summary(..))

-- TODO: move this somewhere central
indent :: Int -> String
indent i = String.fromCharArray $ Array.replicate i ' '

defaultUpdate :: forall s e. s -> Event -> Eff e s
defaultUpdate s _ = pure s

defaultSummary :: forall s e. s -> Array (Group Result) -> Eff (console :: CONSOLE | e) Unit
defaultSummary _ xs = do
  case Summary.summarize xs of
    (Count passed failed pending) -> do
      when (passed  > 0) $ log $ colored Color.Green   $ show passed  <> " passing"
      when (pending > 0) $ log $ colored Color.Pending $ show pending <> " pending"
      when (failed  > 0) $ log $ colored Color.Fail    $ show failed  <> " failed"
  log ""
  printFailures xs

printFailures
  :: forall e
   . Array (Group Result)
  -> Eff (console :: CONSOLE | e) Unit
printFailures xs = void $ evalStateT (go [] xs) 0
  where
    go
      :: Array String
      -> Array (Group Result)
      -> StateT Int (Eff (console :: CONSOLE | e)) Unit
    go crumbs groups =
      for_ groups case _ of
        S.Describe _ n xs' -> go (n:crumbs) xs'
        S.It _ n (Failure err) ->
          let label = intercalate " " (reverse $ n:crumbs)
            in do
                State.modify (_ + 1)
                i <- State.get
                lift $ log $ show i <> ") " <> label
                lift $ log $ colored Color.ErrorMessage $ indent 2 <> Error.message err
        _ -> pure unit

-- | Monadic left scan with state.
-- | TODO: Is this already included in purescript-pipes somehow, or should be?
scanWithStateM
  :: forall a x m r
   . Monad m
  => (x -> a -> m x) -> m x -> Pipe a a m r
scanWithStateM step begin = do
  x <- lift begin
  go x
  where
    go x = do
        a  <- await
        yield a
        x' <- lift (step x a)
        go $ x'

-- | A default reporter implementation that can be used as a base to build
-- | other reporters on top of.
defaultReporter
  :: ∀ s e.
     s
  -> (s -> Event -> Eff e s)
  -> (s -> Array (Group Result) -> Eff e Unit)
  -> Reporter e
defaultReporter initialState onEvent onSummary =
  scanWithStateM dispatch (pure initialState)
  where
    dispatch s e = liftEff (onEvent s e)

module Test.Spec.Reporter.Base
       ( defaultUpdate
       , defaultSummary
       , defaultReporter
       ) where

import Prelude
import Control.Monad.Eff.Exception as Error
import Control.Monad.State as State
import Data.Array as Array
import Data.String as String
import Test.Spec as S
import Test.Spec.Color as Color
import Test.Spec.Summary as Summary
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.State (StateT, evalStateT)
import Control.Monad.Trans.Class (lift)
import Data.Array ((:), reverse)
import Data.Foldable (intercalate)
import Data.Traversable (for_)
import Pipes (await, yield)
import Pipes.Core (Pipe)
import Test.Spec (Group, Result(..))
import Test.Spec.Color (colored)
import Test.Spec.Runner (Reporter)
import Test.Spec.Runner.Event (Event)
import Test.Spec.Summary (Summary(..))

-- TODO: move this somewhere central
indent :: Int -> String
indent i = String.fromCharArray $ Array.replicate i ' '

defaultUpdate :: forall s e. s -> Event -> Eff e s
defaultUpdate s _ = pure s

defaultSummary :: forall s e. s -> Array (Group Result) -> Eff (console :: CONSOLE | e) Unit
defaultSummary _ xs = do
  case Summary.summarize xs of
    (Count passed failed pending) -> do
      when (passed  > 0) $ log $ colored Color.Green   $ show passed  <> " passing"
      when (pending > 0) $ log $ colored Color.Pending $ show pending <> " pending"
      when (failed  > 0) $ log $ colored Color.Fail    $ show failed  <> " failed"
  log ""
  printFailures xs

printFailures
  :: forall e
   . Array (Group Result)
  -> Eff (console :: CONSOLE | e) Unit
printFailures xs = void $ evalStateT (go [] xs) 0
  where
    go
      :: Array String
      -> Array (Group Result)
      -> StateT Int (Eff (console :: CONSOLE | e)) Unit
    go crumbs groups =
      for_ groups case _ of
        S.Describe _ n xs -> go (n:crumbs) xs
        S.It _ n (Failure err) ->
          let label = intercalate " " (reverse $ n:crumbs)
            in do
                State.modify (_ + 1)
                i <- State.get
                lift $ log $ show i <> ") " <> label
                lift $ log $ colored Color.ErrorMessage $ indent 2 <> Error.message err
        _ -> pure unit

-- | Monadic left scan with state.
-- | TODO: Is this already included in purescript-pipes somehow, or should be?
scanWithStateM
  :: forall a x m r
   . Monad m
  => (x -> a -> m x) -> m x -> Pipe a a m r
scanWithStateM step begin = do
  x <- lift begin
  go x
  where
    go x = do
        a  <- await
        yield a
        x' <- lift (step x a)
        go $ x'

-- | A default reporter implementation that can be used as a base to build
-- | other reporters on top of.
defaultReporter
  :: ∀ s e.
     s
  -> (s -> Event -> Eff e s)
  -> (s -> Array (Group Result) -> Eff e Unit)
  -> Reporter e
defaultReporter initialState onEvent onSummary =
  scanWithStateM dispatch (pure initialState)
  where
    dispatch s e = liftEff (onEvent s e)


Implement unary and binary evaluation.

Implement unary and binary evaluation.

module Evaluator where

import Data.Array    (head, mapMaybe)
import Data.StrMap   (StrMap(), empty, lookup, insert)
import Data.Tuple
import Data.Maybe
import Data.Foldable (foldl)

import Control.Apply ((*>))
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Trans

import AST

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Maybe Expr
eval1 env expr = case expr of
  (Binary op e1 e2) -> binary op e1 e2
  (Unary op e)      -> unary op e
  (App name args)   -> apply env name args
  _                 -> Nothing

binary :: Op -> Expr -> Expr -> Maybe Expr
binary = go
  where
  go Add (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i - j
  go Mul (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Div (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ Math.floor (i / j)

  go And (Atom (Bool true))  b = Just b
  go And (Atom (Bool false)) _ = Just $ Atom $ Bool $ false
  go Or  (Atom (Bool true))  _ = Just $ Atom $ Bool $ true
  go Or  (Atom (Bool false)) b = Just b

  go Cons   e          (List es)  = Just $ List $ e:es
  go Append (List es1) (List es2) = Just $ List $ es1 ++ es2

  go _       _               _               = Nothing

unary :: Op -> Expr -> Maybe Expr
unary Sub (Atom (Num i)) = Just $ Atom $ Num (-i)
unary _   _              = Nothing

apply :: Env -> String -> [Expr] -> Maybe Expr
apply env name args = case lookup name env of
  Nothing    -> Nothing
  Just cases -> head $ mapMaybe app cases
    where
    app :: Tuple [Binding] Expr -> Maybe Expr
    app (Tuple binds body) = matchls binds args body

matchls :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchls []     []     expr = Just expr
matchls (b:bs) (e:es) expr = do
  expr' <- execStateT (match b e) expr
  matchls bs es expr'
matchls _ _ _ = Nothing

match :: Binding -> Expr -> StateT Expr Maybe Unit
match (Lit (Name x))   e                = modify (replace x e)
match (Lit (Num i))    (Atom (Num j))   | i == j  = return unit
match (Lit (Bool b))   (Atom (Bool b')) | b == b' = return unit
match (ConsLit b bs)   (List (e:es))    = match b e *> match bs (List es)
match (ListLit [])     (List [])        = return unit
match (ListLit (b:bs)) (List (e:es))    = match b e *> match (ListLit bs) (List es)
match _                _                = lift Nothing

replace :: String -> Expr -> Expr -> Expr
replace name value = go
  where
  go expr = case expr of
    a@(Atom (Name str)) -> if str == name then value else a
    (List exprs)        -> List (go <$> exprs)
    (Binary op e1 e2)   -> Binary op (go e1) (go e2)
    (Unary op e)        -> Unary op (go e)
    (SectL e op)        -> SectL (go e) op
    (SectR op e)        -> SectR op (go e)
    (App appName exprs) -> App appName (go <$> exprs)
    e                   -> e

module Evaluator where

import Data.StrMap
import Data.Tuple
import Data.Maybe
import Data.Foldable (foldl)

import Control.Apply ((*>))
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Trans

import AST

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Expr
eval1 _ _ = Atom $ Name $ "not_implemented"

apply :: Env -> String -> [Expr] -> Maybe Expr
apply _ _ _ = Nothing

matchls :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchls []     []     expr = Just expr
matchls (b:bs) (e:es) expr = do
  expr' <- execStateT (match b e) expr
  matchls bs es expr'
matchls _ _ _ = Nothing

match :: Binding -> Expr -> StateT Expr Maybe Unit
match (Lit (Name x))   e                = modify (replace x e)
match (Lit (Num i))    (Atom (Num j))   | i == j  = return unit
match (Lit (Bool b))   (Atom (Bool b')) | b == b' = return unit
match (ConsLit b bs)   (List (e:es))    = match b e *> match bs (List es)
match (ListLit [])     (List [])        = return unit
match (ListLit (b:bs)) (List (e:es))    = match b e *> match (ListLit bs) (List es)
match _                _                = lift Nothing

replace :: String -> Expr -> Expr -> Expr
replace name value = go
  where
  go expr = case expr of
    a@(Atom (Name str)) -> if str == name then value else a
    (List exprs)        -> List (go <$> exprs)
    (Binary op e1 e2)   -> Binary op (go e1) (go e2)
    (Unary op e)        -> Unary op (go e)
    (SectL e op)        -> SectL (go e) op
    (SectR op e)        -> SectR op (go e)
    (App appName exprs) -> App appName (go <$> exprs)
    e                   -> e


Include line/col in unterminated string error

module Language.PureScript.Parser.Lexer where

import Data.Array ()
import Data.Either
import Data.String

import Language.PureScript.Keywords (opCharsString)

data Token
  = LParen
  | RParen
  | LBrace
  | RBrace
  | LAngle
  | RAngle
  | LSquare
  | RSquare

  | Newline Indentation
  | ShouldIndent Indentation

  | LArrow
  | RArrow
  | LFatArrow
  | RFatArrow

  | Colon
  | DoubleColon
  | Equals
  | Pipe
  | Tick
  | Dot
  | Comma
  | Semi
  | At

  | LName String
  | UName String
  | Symbol String

  | StringLiteral String

  | Natural Number
  | Integer Number
  | Float Number
  | Hex Number

instance showToken :: Show Token where
  show LParen                = "LParen"
  show RParen                = "RParen"
  show LBrace                = "LBrace"
  show RBrace                = "RBrace"
  show LAngle                = "LAngle"
  show RAngle                = "RAngle"
  show LSquare               = "LSquare"
  show RSquare               = "RSquare"
  show LArrow                = "LArrow"
  show RArrow                = "RArrow"
  show LFatArrow             = "LFatArrow"
  show RFatArrow             = "RFatArrow"
  show Colon                 = "Colon"
  show DoubleColon           = "DoubleColon"
  show Equals                = "Equals"
  show Pipe                  = "Pipe"
  show Tick                  = "Tick"
  show Dot                   = "Dot"
  show Comma                 = "Comma"
  show Semi                  = "Semi"
  show At                    = "At"
  show (Newline n)           = "Newline (" ++ show n ++ ")"
  show (ShouldIndent n)      = "ShouldIndent (" ++ show n ++ ")"
  show (LName s)             = "LName (" ++ show s ++ ")"
  show (UName s)             = "UName (" ++ show s ++ ")"
  show (Symbol s)            = "Symbol (" ++ show s ++ ")"
  show (StringLiteral s)     = "StringLiteral (" ++ show s ++ ")"
  show (Natural n)           = "Natural (" ++ show n ++ ")"
  show (Integer n)           = "Integer (" ++ show n ++ ")"
  show (Float n)             = "Float (" ++ show n ++ ")"
  show (Hex n)               = "Hex (" ++ show n ++ ")"

instance eqToken :: Eq Token where
  (==) LParen              LParen              = true
  (==) RParen              RParen              = true
  (==) LBrace              LBrace              = true
  (==) RBrace              RBrace              = true
  (==) LAngle              LAngle              = true
  (==) RAngle              RAngle              = true
  (==) LSquare             LSquare             = true
  (==) RSquare             RSquare             = true
  (==) LArrow              LArrow              = true
  (==) RArrow              RArrow              = true
  (==) LFatArrow           LFatArrow           = true
  (==) RFatArrow           RFatArrow           = true
  (==) Colon               Colon               = true
  (==) DoubleColon         DoubleColon         = true
  (==) Equals              Equals              = true
  (==) Pipe                Pipe                = true
  (==) Tick                Tick                = true
  (==) Dot                 Dot                 = true
  (==) Comma               Comma               = true
  (==) Semi                Semi                = true
  (==) At                  At                  = true
  (==) (Newline n1)        (Newline n2)        = n1 == n2
  (==) (ShouldIndent n1)   (ShouldIndent n2)   = n1 == n2
  (==) (LName s1)          (LName s2)          = s1 == s2
  (==) (UName s1)          (UName s2)          = s1 == s2
  (==) (Symbol s1)         (Symbol s2)         = s1 == s2
  (==) (StringLiteral s1)  (StringLiteral s2)  = s1 == s2
  (==) (Natural n1)        (Natural n2)        = n1 == n2
  (==) (Integer n1)        (Integer n2)        = n1 == n2
  (==) (Float n1)          (Float n2)          = n1 == n2
  (==) (Hex n1)            (Hex n2)            = n1 == n2
  (==) _                   _                   = false
  (/=) tok1                tok2                = not (tok1 == tok2)

type Indentation = Number

type Line = Number
type Column = Number

type Position = Number

type Comments = [String]

type PositionedToken =
  { line :: Line
  , column :: Column
  , token :: Token
  , comments :: Comments
  }

mkPositionedToken :: Line -> Column -> [String] -> Token -> PositionedToken
mkPositionedToken line column comments token = { line: line, column: column, token: token, comments: comments }

foreign import unEscape
  "function unEscape(s) {\
  \  return function (sc) {\
  \    return function (fc) {\
  \      try {\
  \        return sc(JSON.parse('\"' + s + '\"'));\
  \      } catch (ex) {\
  \        return fc;\
  \      }\
  \    };\
  \  };\
  \}" :: forall r. String -> (String -> r) -> r -> r

lex :: String -> Either String [PositionedToken]
lex input = do
  let wh = eatWhitespace 0 []
  ts <- go 1 (wh.next + 1) wh.next [] []
  removeWhitespace [] ts []
  where
  go :: Line -> Column -> Position -> Comments -> [PositionedToken] -> Either String [PositionedToken]
  go _    _   i _  ts | i >= length input = Right (Data.Array.reverse ts)
  go line col i cs ts | charAt i input == " " = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\r" = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\n" =
    let wh = eatWhitespace (i + 1) ts
    in go (line + 1) (wh.len + 1) wh.next cs wh.toks

  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) =
    let tok = eatWhile (i + 2) (\s -> s /= "\n")
    in go line (col + length tok.str) tok.next (cs ++ [tok.str]) ts
  go line col i cs ts | charAt i input == "{" && charAt (i + 1) input == "-" =
    let tok = eatWhile' (i + 2) (\j -> j < length input && ((charAt j input /= "-") || (charAt (j + 1) input /= "}")))
    in go line (col + length tok.str + 2) (tok.next + 2) (cs ++ [tok.str]) ts

  go line col i cs ts | charAt i input == "(" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LParen : ts)
  go line col i cs ts | charAt i input == ")" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RParen : ts)
  go line col i cs ts | charAt i input == "{" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LBrace : ts)
  go line col i cs ts | charAt i input == "}" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RBrace : ts)
  go line col i cs ts | charAt i input == "[" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LSquare : ts)
  go line col i cs ts | charAt i input == "]" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RSquare : ts)
  go line col i cs ts | charAt i input == "." && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Dot : ts)
  go line col i cs ts | charAt i input == "<" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LAngle : ts)
  go line col i cs ts | charAt i input == ">" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RAngle : ts)
  go line col i cs ts | charAt i input == ":" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Colon : ts)
  go line col i cs ts | charAt i input == "=" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Equals : ts)
  go line col i cs ts | charAt i input == "|" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Pipe : ts)
  go line col i cs ts | charAt i input == "@" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs At : ts)
  go line col i cs ts | charAt i input == "`" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Tick : ts)
  go line col i cs ts | charAt i input == "," = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Comma : ts)
  go line col i cs ts | charAt i input == ";" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Semi : ts)

  go line col i cs ts | charAt i input == ":" && charAt (i + 1) input == ":" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs DoubleColon : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LArrow : ts)
  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RArrow : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "=" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LFatArrow : ts)
  go line col i cs ts | charAt i input == "=" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RFatArrow : ts)

  go line col i cs ts | isNumeric (charAt i input) =
    let ns = eatWhile i isNumeric
    in go line (col + length ns.str) ns.next [] (mkPositionedToken line col cs (Natural (buildNat ns.str 0 0)) : ts)
    where
    buildNat :: String -> Number -> Number -> Number
    buildNat s i acc | i >= length s = acc
    buildNat s i acc = buildNat s (i + 1) (acc * 10 + toDigit (charAt i s))

    toDigit :: String -> Number
    toDigit "0" = 0
    toDigit "1" = 1
    toDigit "2" = 2
    toDigit "3" = 3
    toDigit "4" = 4
    toDigit "5" = 5
    toDigit "6" = 6
    toDigit "7" = 7
    toDigit "8" = 8
    toDigit "9" = 9

  go line col i cs ts | isIdentStart (charAt i input) =
    let tok = eatWhile i isIdentChar
        col' = col + length tok.str
    in case tok.str of
      s | shouldIndent tok.str ->
        let lme = nextLexeme line col' tok.next
        in case {} of
          _ | charAt lme.next input == "{" -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)
          _ -> go lme.line lme.col lme.next [] (mkPositionedToken line col cs (ShouldIndent lme.col) : mkPositionedToken line col [] (LName tok.str) : ts)
      s -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)

  go line col i cs ts | isUpper (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (UName tok.str) : ts)
  go line col i cs ts | isSymbolChar (charAt i input) =
    let tok = eatWhile i isSymbolChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (Symbol tok.str) : ts)

  go line col i cs ts | indexOf' "\"\"\"" i input == i =
    case readStringLiteral line col (i + 3) "\"\"\"" replaceNewLines of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)
    where
    replaceNewLines :: String -> String
    replaceNewLines = joinWith "\\n" <<< split "\n"
  go line col i cs ts | charAt i input == "\"" =
    case readStringLiteral line col (i + 1) "\"" id of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)

  go line col _ _ _ = Left $ "Lexer error at line " ++ show line ++ ", column " ++ show col

  removeWhitespace :: [Indentation] -> [PositionedToken] -> [PositionedToken] -> Either String [PositionedToken]
  removeWhitespace ms       ({ token = Newline _ } : (t@{ token = Newline _ }) : ts) acc = removeWhitespace ms (t : ts) acc
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | m == n = removeWhitespace (m : ms) ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace []       ((t@{ token = Newline 1 })      : ts) acc = removeWhitespace [] ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | n < m = removeWhitespace ms (t : ts) (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace ms       ((t@{ token = Newline n })      : ts) acc = removeWhitespace ms ts acc
  removeWhitespace (m : ms) ((t@{ token = ShouldIndent n }) : ts) acc | n > m = removeWhitespace (n : m : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace []       ((t@{ token = ShouldIndent n }) : ts) acc | n > 1 = removeWhitespace [n] ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       ((t@{ token = ShouldIndent n }) : ts) acc = removeWhitespace ms (mkPositionedToken t.line t.column t.comments (Newline n) : ts) (mkPositionedToken t.line t.column [] RBrace : mkPositionedToken t.line t.column [] LBrace : acc)
  removeWhitespace (1 : ms) ((t@{ token = RBrace })         : ts) acc = removeWhitespace ms ts (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace _        ((t@{ token = RBrace })         : ts) acc = Left "Unexpected }"
  removeWhitespace ms       ((t@{ token = LBrace })         : ts) acc = removeWhitespace (1 : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       (t : ts)                              acc = removeWhitespace ms ts (t : acc)
  removeWhitespace []       []                                    acc = return (Data.Array.reverse acc)
  removeWhitespace (m : ms) []                                    acc | m > 1 = removeWhitespace ms [] (mkPositionedToken 0 0 [] RBrace : acc)

  nextLexeme :: Line -> Column -> Position -> { line :: Line, col :: Column, next :: Position }
  nextLexeme = eat
    where
    eat line col i | charAt i input == " "  = eat line (col + 1) (i + 1)
    eat line col i | charAt i input == "\r" = eat line col (i + 1)
    eat line col i | charAt i input == "\n" = eat (line + 1) 1 (i + 1)
    eat line col i = { line: line, col: col, next: i }

  eatWhitespace :: Position -> [PositionedToken] -> { len :: Number, count :: Number, next :: Position, toks :: [PositionedToken] }
  eatWhitespace = eat 0 0
    where
    eat len count i ts | charAt i input == " " = eat (len + 1) (count + 1) (i + 1) ts
    eat len count i ts | charAt i input == "\r" = eat len (count + 1) (i + 1) ts
    -- TODO: include position info here
    eat len count i ts = { len: len, count: count, next: i, toks: mkPositionedToken 0 0 [] (Newline (len + 1)) : ts }

  eatWhile :: Position -> (String -> Boolean) -> { next :: Position, str :: String }
  eatWhile start p = eatWhile' start (\i -> p (charAt i input))

  eatWhile' :: Position -> (Number -> Boolean) -> { next :: Position, str :: String }
  eatWhile' start p = eat start 0
    where
    eat i _   | i >= length input = { next: i, str: drop start input }
    eat i len | p i = eat (i + 1) (len + 1)
    eat i len = { next: i, str: take len (drop start input) }

  readStringLiteral :: Line -> Column -> Position -> String -> (String -> String) -> Either String { next :: Position, str :: String, count :: Number }
  readStringLiteral line col start term replace = eat false 0 start
    where
    eat :: Boolean -> Number -> Position -> Either String { next :: Position, str :: String, count :: Number }
    eat _     _     i | i >= length input = Left $ "Unterminated string literal at line " ++ show line ++ ", column " ++ show col
    eat false count i | indexOf' term i input == i =
      let escaped = replace (take count (drop start input))
      in unEscape escaped (\s -> Right { next: i + length term, str: s, count: count }) (Left $ "Invalid string literal at line " ++ show line ++ ", column " ++ show col ++ ": " ++ show escaped)
    eat _     count i | charAt i input == "\\" = eat true (count + 1) (i + 1)
    eat _     count i = eat false (count + 1) (i + 1)

  lookaheadChar :: Position -> (String -> Boolean) -> Boolean
  lookaheadChar i pred = pred (charAt i input)

  isSymbolChar :: String -> Boolean
  isSymbolChar c = indexOf c opCharsString >= 0

  isLower :: String -> Boolean
  isLower c = c >= "a" && c <= "z"

  isUpper :: String -> Boolean
  isUpper c = c >= "A" && c <= "Z"

  isAlpha :: String -> Boolean
  isAlpha c = isLower c || isUpper c

  isNumeric :: String -> Boolean
  isNumeric c = c >= "0" && c <= "9"

  isAlphaNum :: String -> Boolean
  isAlphaNum c = isAlpha c || isNumeric c

  isIdentStart :: String -> Boolean
  isIdentStart c = isLower c || (c == "_")

  isIdentChar :: String -> Boolean
  isIdentChar c = isAlphaNum c || (c == "_")

  isNumericLiteralChar :: String -> Boolean
  isNumericLiteralChar c = isNumeric c || (c == ".") || (c == "b") || (c == "x") || (c == "-")

  shouldIndent :: String -> Boolean
  shouldIndent "of" = true
  shouldIndent "do" = true
  shouldIndent "where" = true
  shouldIndent "let" = true
  shouldIndent _ = false

module Language.PureScript.Parser.Lexer where

import Data.Array ()
import Data.Either
import Data.String

import Language.PureScript.Keywords (opCharsString)

data Token
  = LParen
  | RParen
  | LBrace
  | RBrace
  | LAngle
  | RAngle
  | LSquare
  | RSquare

  | Newline Indentation
  | ShouldIndent Indentation

  | LArrow
  | RArrow
  | LFatArrow
  | RFatArrow

  | Colon
  | DoubleColon
  | Equals
  | Pipe
  | Tick
  | Dot
  | Comma
  | Semi
  | At

  | LName String
  | UName String
  | Symbol String

  | StringLiteral String

  | Natural Number
  | Integer Number
  | Float Number
  | Hex Number

instance showToken :: Show Token where
  show LParen                = "LParen"
  show RParen                = "RParen"
  show LBrace                = "LBrace"
  show RBrace                = "RBrace"
  show LAngle                = "LAngle"
  show RAngle                = "RAngle"
  show LSquare               = "LSquare"
  show RSquare               = "RSquare"
  show LArrow                = "LArrow"
  show RArrow                = "RArrow"
  show LFatArrow             = "LFatArrow"
  show RFatArrow             = "RFatArrow"
  show Colon                 = "Colon"
  show DoubleColon           = "DoubleColon"
  show Equals                = "Equals"
  show Pipe                  = "Pipe"
  show Tick                  = "Tick"
  show Dot                   = "Dot"
  show Comma                 = "Comma"
  show Semi                  = "Semi"
  show At                    = "At"
  show (Newline n)           = "Newline (" ++ show n ++ ")"
  show (ShouldIndent n)      = "ShouldIndent (" ++ show n ++ ")"
  show (LName s)             = "LName (" ++ show s ++ ")"
  show (UName s)             = "UName (" ++ show s ++ ")"
  show (Symbol s)            = "Symbol (" ++ show s ++ ")"
  show (StringLiteral s)     = "StringLiteral (" ++ show s ++ ")"
  show (Natural n)           = "Natural (" ++ show n ++ ")"
  show (Integer n)           = "Integer (" ++ show n ++ ")"
  show (Float n)             = "Float (" ++ show n ++ ")"
  show (Hex n)               = "Hex (" ++ show n ++ ")"

instance eqToken :: Eq Token where
  (==) LParen              LParen              = true
  (==) RParen              RParen              = true
  (==) LBrace              LBrace              = true
  (==) RBrace              RBrace              = true
  (==) LAngle              LAngle              = true
  (==) RAngle              RAngle              = true
  (==) LSquare             LSquare             = true
  (==) RSquare             RSquare             = true
  (==) LArrow              LArrow              = true
  (==) RArrow              RArrow              = true
  (==) LFatArrow           LFatArrow           = true
  (==) RFatArrow           RFatArrow           = true
  (==) Colon               Colon               = true
  (==) DoubleColon         DoubleColon         = true
  (==) Equals              Equals              = true
  (==) Pipe                Pipe                = true
  (==) Tick                Tick                = true
  (==) Dot                 Dot                 = true
  (==) Comma               Comma               = true
  (==) Semi                Semi                = true
  (==) At                  At                  = true
  (==) (Newline n1)        (Newline n2)        = n1 == n2
  (==) (ShouldIndent n1)   (ShouldIndent n2)   = n1 == n2
  (==) (LName s1)          (LName s2)          = s1 == s2
  (==) (UName s1)          (UName s2)          = s1 == s2
  (==) (Symbol s1)         (Symbol s2)         = s1 == s2
  (==) (StringLiteral s1)  (StringLiteral s2)  = s1 == s2
  (==) (Natural n1)        (Natural n2)        = n1 == n2
  (==) (Integer n1)        (Integer n2)        = n1 == n2
  (==) (Float n1)          (Float n2)          = n1 == n2
  (==) (Hex n1)            (Hex n2)            = n1 == n2
  (==) _                   _                   = false
  (/=) tok1                tok2                = not (tok1 == tok2)

type Indentation = Number

type Line = Number
type Column = Number

type Position = Number

type Comments = [String]

type PositionedToken =
  { line :: Line
  , column :: Column
  , token :: Token
  , comments :: Comments
  }

mkPositionedToken :: Line -> Column -> [String] -> Token -> PositionedToken
mkPositionedToken line column comments token = { line: line, column: column, token: token, comments: comments }

foreign import unEscape
  "function unEscape(s) {\
  \  return function (sc) {\
  \    return function (fc) {\
  \      try {\
  \        return sc(JSON.parse('\"' + s + '\"'));\
  \      } catch (ex) {\
  \        return fc;\
  \      }\
  \    };\
  \  };\
  \}" :: forall r. String -> (String -> r) -> r -> r

lex :: String -> Either String [PositionedToken]
lex input = do
  let wh = eatWhitespace 0 []
  ts <- go 1 (wh.next + 1) wh.next [] []
  removeWhitespace [] ts []
  where
  go :: Line -> Column -> Position -> Comments -> [PositionedToken] -> Either String [PositionedToken]
  go _    _   i _  ts | i >= length input = Right (Data.Array.reverse ts)
  go line col i cs ts | charAt i input == " " = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\r" = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\n" =
    let wh = eatWhitespace (i + 1) ts
    in go (line + 1) (wh.len + 1) wh.next cs wh.toks

  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) =
    let tok = eatWhile (i + 2) (\s -> s /= "\n")
    in go line (col + length tok.str) tok.next (cs ++ [tok.str]) ts
  go line col i cs ts | charAt i input == "{" && charAt (i + 1) input == "-" =
    let tok = eatWhile' (i + 2) (\j -> j < length input && ((charAt j input /= "-") || (charAt (j + 1) input /= "}")))
    in go line (col + length tok.str + 2) (tok.next + 2) (cs ++ [tok.str]) ts

  go line col i cs ts | charAt i input == "(" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LParen : ts)
  go line col i cs ts | charAt i input == ")" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RParen : ts)
  go line col i cs ts | charAt i input == "{" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LBrace : ts)
  go line col i cs ts | charAt i input == "}" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RBrace : ts)
  go line col i cs ts | charAt i input == "[" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LSquare : ts)
  go line col i cs ts | charAt i input == "]" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RSquare : ts)
  go line col i cs ts | charAt i input == "." && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Dot : ts)
  go line col i cs ts | charAt i input == "<" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LAngle : ts)
  go line col i cs ts | charAt i input == ">" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RAngle : ts)
  go line col i cs ts | charAt i input == ":" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Colon : ts)
  go line col i cs ts | charAt i input == "=" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Equals : ts)
  go line col i cs ts | charAt i input == "|" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Pipe : ts)
  go line col i cs ts | charAt i input == "@" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs At : ts)
  go line col i cs ts | charAt i input == "`" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Tick : ts)
  go line col i cs ts | charAt i input == "," = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Comma : ts)
  go line col i cs ts | charAt i input == ";" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Semi : ts)

  go line col i cs ts | charAt i input == ":" && charAt (i + 1) input == ":" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs DoubleColon : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LArrow : ts)
  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RArrow : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "=" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LFatArrow : ts)
  go line col i cs ts | charAt i input == "=" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RFatArrow : ts)

  go line col i cs ts | isNumeric (charAt i input) =
    let ns = eatWhile i isNumeric
    in go line (col + length ns.str) ns.next [] (mkPositionedToken line col cs (Natural (buildNat ns.str 0 0)) : ts)
    where
    buildNat :: String -> Number -> Number -> Number
    buildNat s i acc | i >= length s = acc
    buildNat s i acc = buildNat s (i + 1) (acc * 10 + toDigit (charAt i s))

    toDigit :: String -> Number
    toDigit "0" = 0
    toDigit "1" = 1
    toDigit "2" = 2
    toDigit "3" = 3
    toDigit "4" = 4
    toDigit "5" = 5
    toDigit "6" = 6
    toDigit "7" = 7
    toDigit "8" = 8
    toDigit "9" = 9

  go line col i cs ts | isIdentStart (charAt i input) =
    let tok = eatWhile i isIdentChar
        col' = col + length tok.str
    in case tok.str of
      s | shouldIndent tok.str ->
        let lme = nextLexeme line col' tok.next
        in case {} of
          _ | charAt lme.next input == "{" -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)
          _ -> go lme.line lme.col lme.next [] (mkPositionedToken line col cs (ShouldIndent lme.col) : mkPositionedToken line col [] (LName tok.str) : ts)
      s -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)

  go line col i cs ts | isUpper (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (UName tok.str) : ts)
  go line col i cs ts | isSymbolChar (charAt i input) =
    let tok = eatWhile i isSymbolChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (Symbol tok.str) : ts)

  go line col i cs ts | indexOf' "\"\"\"" i input == i =
    case readStringLiteral line col (i + 3) "\"\"\"" replaceNewLines of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)
    where
    replaceNewLines :: String -> String
    replaceNewLines = joinWith "\\n" <<< split "\n"
  go line col i cs ts | charAt i input == "\"" =
    case readStringLiteral line col (i + 1) "\"" id of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)

  go line col _ _ _ = Left $ "Lexer error at line " ++ show line ++ ", column " ++ show col

  removeWhitespace :: [Indentation] -> [PositionedToken] -> [PositionedToken] -> Either String [PositionedToken]
  removeWhitespace ms       ({ token = Newline _ } : (t@{ token = Newline _ }) : ts) acc = removeWhitespace ms (t : ts) acc
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | m == n = removeWhitespace (m : ms) ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace []       ((t@{ token = Newline 1 })      : ts) acc = removeWhitespace [] ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | n < m = removeWhitespace ms (t : ts) (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace ms       ((t@{ token = Newline n })      : ts) acc = removeWhitespace ms ts acc
  removeWhitespace (m : ms) ((t@{ token = ShouldIndent n }) : ts) acc | n > m = removeWhitespace (n : m : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace []       ((t@{ token = ShouldIndent n }) : ts) acc | n > 1 = removeWhitespace [n] ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       ((t@{ token = ShouldIndent n }) : ts) acc = removeWhitespace ms (mkPositionedToken t.line t.column t.comments (Newline n) : ts) (mkPositionedToken t.line t.column [] RBrace : mkPositionedToken t.line t.column [] LBrace : acc)
  removeWhitespace (1 : ms) ((t@{ token = RBrace })         : ts) acc = removeWhitespace ms ts (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace _        ((t@{ token = RBrace })         : ts) acc = Left "Unexpected }"
  removeWhitespace ms       ((t@{ token = LBrace })         : ts) acc = removeWhitespace (1 : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       (t : ts)                              acc = removeWhitespace ms ts (t : acc)
  removeWhitespace []       []                                    acc = return (Data.Array.reverse acc)
  removeWhitespace (m : ms) []                                    acc | m > 1 = removeWhitespace ms [] (mkPositionedToken 0 0 [] RBrace : acc)

  nextLexeme :: Line -> Column -> Position -> { line :: Line, col :: Column, next :: Position }
  nextLexeme = eat
    where
    eat line col i | charAt i input == " "  = eat line (col + 1) (i + 1)
    eat line col i | charAt i input == "\r" = eat line col (i + 1)
    eat line col i | charAt i input == "\n" = eat (line + 1) 1 (i + 1)
    eat line col i = { line: line, col: col, next: i }

  eatWhitespace :: Position -> [PositionedToken] -> { len :: Number, count :: Number, next :: Position, toks :: [PositionedToken] }
  eatWhitespace = eat 0 0
    where
    eat len count i ts | charAt i input == " " = eat (len + 1) (count + 1) (i + 1) ts
    eat len count i ts | charAt i input == "\r" = eat len (count + 1) (i + 1) ts
    -- TODO: include position info here
    eat len count i ts = { len: len, count: count, next: i, toks: mkPositionedToken 0 0 [] (Newline (len + 1)) : ts }

  eatWhile :: Position -> (String -> Boolean) -> { next :: Position, str :: String }
  eatWhile start p = eatWhile' start (\i -> p (charAt i input))

  eatWhile' :: Position -> (Number -> Boolean) -> { next :: Position, str :: String }
  eatWhile' start p = eat start 0
    where
    eat i _   | i >= length input = { next: i, str: drop start input }
    eat i len | p i = eat (i + 1) (len + 1)
    eat i len = { next: i, str: take len (drop start input) }

  readStringLiteral :: Line -> Column -> Position -> String -> (String -> String) -> Either String { next :: Position, str :: String, count :: Number }
  readStringLiteral line col start term replace = eat false 0 start
    where
    eat :: Boolean -> Number -> Position -> Either String { next :: Position, str :: String, count :: Number }
    eat _     _     i | i >= length input = Left $ "Unterminated string literal"
    eat false count i | indexOf' term i input == i =
      let escaped = replace (take count (drop start input))
      in unEscape escaped (\s -> Right { next: i + length term, str: s, count: count }) (Left $ "Invalid string literal at line " ++ show line ++ ", column " ++ show col ++ ": " ++ show escaped)
    eat _     count i | charAt i input == "\\" = eat true (count + 1) (i + 1)
    eat _     count i = eat false (count + 1) (i + 1)

  lookaheadChar :: Position -> (String -> Boolean) -> Boolean
  lookaheadChar i pred = pred (charAt i input)

  isSymbolChar :: String -> Boolean
  isSymbolChar c = indexOf c opCharsString >= 0

  isLower :: String -> Boolean
  isLower c = c >= "a" && c <= "z"

  isUpper :: String -> Boolean
  isUpper c = c >= "A" && c <= "Z"

  isAlpha :: String -> Boolean
  isAlpha c = isLower c || isUpper c

  isNumeric :: String -> Boolean
  isNumeric c = c >= "0" && c <= "9"

  isAlphaNum :: String -> Boolean
  isAlphaNum c = isAlpha c || isNumeric c

  isIdentStart :: String -> Boolean
  isIdentStart c = isLower c || (c == "_")

  isIdentChar :: String -> Boolean
  isIdentChar c = isAlphaNum c || (c == "_")

  isNumericLiteralChar :: String -> Boolean
  isNumericLiteralChar c = isNumeric c || (c == ".") || (c == "b") || (c == "x") || (c == "-")

  shouldIndent :: String -> Boolean
  shouldIndent "of" = true
  shouldIndent "do" = true
  shouldIndent "where" = true
  shouldIndent "let" = true
  shouldIndent _ = false