Playing with alternative Peak' type

Playing with alternative Peak' type

module Genetics.Browser.Track.Demo where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (blue, navy, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgrey)
import Control.Coroutine (Producer, transform, ($~), (~~))
import Control.Monad.Aff (Aff, throwError)
import Control.Monad.Eff.Exception (error)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filter, filterMap, partition)
import Data.Foldable (class Foldable, any, fold, foldMap, foldr, maximumBy, minimumBy, or, sum)
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (view, (^?))
import Data.Lens.Index (ix)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.String as String
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple as Tuple
import Data.Unfoldable (unfoldr)
import Data.Variant (inj)
import Debug.Trace as Debug
import Genetics.Browser.Track.Backend (DrawingN, DrawingV, Feature, LegendEntry, NPoint, OldRenderer, RenderedTrack, Label, _range, _single, groupToMap, mkIcon, negLog10, trackLegend, zipMapsWith)
import Genetics.Browser.Track.Bed (ParsedLine, chunkProducer, fetchBed, fetchForeignChunks, parsedLineTransformer)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), ViewScale(..), _Segments, aroundPair, pairSize, pairsOverlap, xPerPixel)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Unsafe.Coerce (unsafeCoerce)

type BedFeature = Feature { thickRange :: Pair Bp
                          , blocks :: Array (Pair Bp)
                          , geneId :: String
                          , geneName :: String
                          , chrId :: ChrId }

bedToFeature :: CoordSys ChrId BigInt -> ParsedLine -> Maybe BedFeature
bedToFeature cs pl = do
  seg@(Pair offset _ ) <- cs ^? _Segments <<< ix pl.chrom

  -- TODO validate ranges maybe, idk
  let toBp :: BigInt -> Bp
      toBp = wrap <<< BigInt.toNumber

      frameSize = toBp $ pairSize seg
      position = toBp  <$> Pair pl.chromStart pl.chromEnd
      thickRange = toBp  <$> Pair pl.thickStart pl.thickEnd

      blocks = Array.zipWith
                 (\start size -> map toBp (Pair start size))
                 pl.blockStarts pl.blockSizes

  pure { position
       , frameSize
       , feature: { thickRange
                  , blocks
                  , geneId: pl.geneId
                  , geneName: pl.geneName
                  , chrId: pl.chrom
                  }
       }

getGenes :: CoordSys ChrId BigInt
         -> String
         -> Aff _ (Map ChrId (Array BedFeature))
getGenes cs url = do
  ls <- fetchBed url

  let fs = filterMap (bedToFeature cs) ls

  pure $ groupToMap _.feature.chrId $ fs

produceGenes :: CoordSys ChrId BigInt -> String
             -> Aff _
                (Producer
                 (Map ChrId (Array BedFeature))
                 (Aff _) Unit)
produceGenes cs url = do
  prod <- fetchForeignChunks url

  pure
    $ prod
    $~ parsedLineTransformer
    ~~ transform
       (groupToMap _.feature.chrId <<< filterMap (bedToFeature cs))

bedDraw :: BedFeature
        -> DrawingV
bedDraw gene = inj _range \w ->
  let (Pair l r) = gene.position
      toLocal x = w * (unwrap $ x / gene.frameSize)

      width = toLocal (r - l)

      exon block =
        let p@(Pair exL' size') = toLocal <$> block
            s = rectangle exL' zero size' 30.0
        in (outlined (outlineColor darkgrey <> lineWidth 1.0) s)
        <> (filled (fillColor lightgrey) s)

      introns _ =
        let s = rectangle 1.5 14.0 (width-1.5) 2.0
        in outlined (outlineColor black <> lineWidth 3.0) s
        <> filled   (fillColor black) s

      label _ =
        Drawing.text
          (font sansSerif 12 mempty)
             (2.5) (35.0)
             (fillColor black) gene.feature.geneName

      drawing =
        if width < one
        then mempty
        else \_ -> introns unit
                <> foldMap exon gene.feature.blocks
                <> label unit

  in { drawing, width }

geneRenderer :: OldRenderer BedFeature
geneRenderer = inj _single { draw: bedDraw, horPlace, verPlace: const (Normalized 0.10) }
  where horPlace {position, frameSize} =
          let f p = Normalized (unwrap $ p / frameSize)
          in inj _range $ map f position

fetchJsonChunks :: String
                -> Aff _ (Producer (Array Json) (Aff _) Unit)
fetchJsonChunks url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just ls -> pure $ chunkProducer 512 ls

featureProd :: ∀ r1 r2.
               String
            -> (Json -> Maybe { feature :: { chrId :: ChrId | r1 } | r2 })
            -> Aff _
                 (Producer
                 (Map ChrId (Array { feature :: { chrId :: ChrId | r1 } | r2 }))
                 (Aff _) Unit)
featureProd url parse = do
  prod <- fetchJsonChunks url
  pure $ prod $~ (transform $ groupToMap _.feature.chrId <<< filterMap parse)

-- TODO bundle up all the producers into one function on a record of URLs
--      to a record of producers (maprecord? applyrecord?)
produceGWAS :: CoordSys ChrId _
            -> String
            -> Aff _
               (Producer
                (Map ChrId
                 (Array (GWASFeature ())))
                 (Aff _) Unit)
produceGWAS cs url = featureProd url $ gemmaJSONParse cs

produceAnnots :: CoordSys ChrId _
              -> String
              -> Aff _
                 (Producer
                  (Map ChrId
                   (Array (Annot ())))
                   (Aff _) Unit)
produceAnnots cs url = featureProd url $ (annotJSONParse cs)

fetchJSON :: ∀ a.
             (Json -> Maybe a)
          -> String
          -> Aff _ (Array a)
fetchJSON p url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just as -> case traverse p as of
      Nothing -> throwError $ error "Failed to parse JSON features"
      Just fs -> pure $ fs

type GWASFeature r = Feature { score :: Number
                             , chrId :: ChrId
                             , name  :: String | r }

gemmaJSONParse :: CoordSys ChrId BigInt
               -> Json
               -> Maybe (GWASFeature ())
gemmaJSONParse cs j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "p_wald"  <<< _Number
  name  <-           obj ^? ix "rs"  <<< _String

  chrSize <- (Bp <<< BigInt.toNumber <<< pairSize) <$> Map.lookup chrId (view _Segments cs)

  pure { position: Pair pos pos
       , frameSize: chrSize
       , feature: { score, chrId, name }
       }

type AnnotRow r = ( geneID :: String
                   , desc :: String
                   , name :: String
                   , chrId :: ChrId | r )
type Annot r = Feature {| AnnotRow r}

annotJSONParse :: CoordSys ChrId BigInt
              -> Json
              -> Maybe (Annot ())
annotJSONParse cs j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  chrId  <- ChrId <$> obj ^? ix "ChrId" <<< _String

  chrSize <- (Bp <<< BigInt.toNumber <<< pairSize) <$> Map.lookup chrId (view _Segments cs)

  pure { position: Pair start end
       , frameSize: chrSize
       , feature: { geneID, desc, name, chrId }
       }

fetchAnnotJSON :: CoordSys ChrId BigInt -> String
               -> Aff _ (Array (Annot ()))
fetchAnnotJSON cs str = fetchJSON (annotJSONParse cs) str

getGWAS :: CoordSys ChrId BigInt -> String
        -> Aff _ (Map ChrId (Array (GWASFeature ())))
getGWAS cs url = groupToMap _.feature.chrId
                  <$> filter (\f -> Pair.fst (f.position) >= wrap zero)
                  <$> fetchJSON (gemmaJSONParse cs) url

getAnnotations :: CoordSys ChrId BigInt -> String
               -> Aff _ (Map ChrId (Array (Annot ())))
getAnnotations cs url = groupToMap _.feature.chrId
                        <$> fetchAnnotJSON cs url

getAnnotations' :: ∀ rS.
                   CoordSys ChrId BigInt
                -> Map ChrId (Array (GWASFeature rS))
                -> String
                -> Aff _ (Map ChrId (Array (Annot ())))
getAnnotations' cs snps url =  groupToMap _.feature.chrId
                              <$> interestingAnnots (Bp 50000.0) snps
                              <$> fetchAnnotJSON cs url

inRangeOf :: ∀ rA rB.
             Bp
          -> { position :: Pair Bp | rA }
          -> { position :: Pair Bp | rB }
          -> Boolean
inRangeOf r a b = pairsOverlap a.position
                             $ r `aroundPair` b.position

interestingAnnots :: ∀ rA rS f.
                     Filterable f
                  => Bp
                  -> Map ChrId (Array (GWASFeature rS))
                  -> f (Annot rA)
                  -> f (Annot rA)
interestingAnnots radius snps = filter (any (any (inRangeOf radius)) snps)

type Peak' x r = { covers :: Pair x
                 , peak   :: r
                 , mountain  :: Array r }

peak' :: ∀ x y a.
         Ord x
      => Ring x
      => { pos   :: a -> Pair x
         , value :: a -> Ordering }
      -> x
      -> Array a
      -> Maybe (Tuple (Peak' x a)
                      (Array a))
peak' {pos, value} radius as = do
  peak <- maximumBy (compare `on` value) as

  let covers = radius `aroundPair` pos peak
      {no, yes} = partition (\p -> pos p `pairsOverlap` covers) as

  pure $ Tuple {covers, peak, mountain: yes} no

type Peak x y r = { covers :: Pair x
                  , y :: y
                  , elements :: Array r }

peak1 :: ∀ rS.
         Bp
      -> Array (GWASFeature rS)
      -> Maybe (Tuple (Peak _ _ (GWASFeature rS))
                      (Array (GWASFeature rS)))
peak1 radius snps = do
  top <- minimumBy (compare `on` _.feature.score) snps

  let covers = radius `aroundPair` top.position
      y = top.feature.score
      {no, yes} = partition (\p -> p.position `pairsOverlap` covers) snps

  pure $ Tuple {covers, y, elements: yes} no

peaks :: ∀ rS.
         Bp
      -> Array (GWASFeature rS)
      -> Array (Peak Bp Number (GWASFeature rS))
peaks r snps = unfoldr (peak1 r) snps

visiblePeaks :: ∀ rS.
                ViewScale
             -> Map ChrId (Array (GWASFeature rS))
             -> Map ChrId (Array (Peak Bp Number (GWASFeature rS)))
visiblePeaks vs snps = Debug.trace ("radius: " <> show radius) \_ -> map (peaks radius) snps
  where radius :: Bp
        radius = wrap $ (xPerPixel vs) * 3.75 -- GWAS glyph radius is 3.75px, see renderGWAS

-- TODO Configgable Annotation -> LegendEntry function (somehow?!)
annotLegendEntry :: ∀ r. Annot r -> LegendEntry
annotLegendEntry a =
  if (String.length a.feature.name) `mod` 2 == 0
    then mkIcon blue "even name"
    else mkIcon red  "odd name"

annotLegendTest :: ∀ f r.
                   Foldable f
                => Functor f
                => Map ChrId (f (Annot r))
                -> Array LegendEntry
annotLegendTest fs = trackLegend annotLegendEntry as
  where as = Array.concat
             $ Array.fromFoldable
             $ Array.fromFoldable <$> Map.values fs

------------ new renderers~~~~~~~~~

placeScored :: ∀ r1 r2.
               { min :: Number, max :: Number | r1 }
            -> Feature { score :: Number | r2 }
            -> NPoint
placeScored verScale { frameSize, position: (Pair l _), feature } = {x, y}
  where x = Normalized $ unwrap $ l / frameSize
        y = normalizedY verScale feature.score

normalizedY :: ∀ r.
               { min :: Number, max :: Number | r }
            -> Number
            -> Normalized Number
normalizedY {min, max} y = Normalized $ ((negLog10 y) - min) / (max - min)

dist :: Point -> Point -> Number
dist p1 p2 = Math.sqrt $ x' `Math.pow` 2.0 + y' `Math.pow` 2.0
  where x' = p1.x - p2.x
        y' = p1.y - p2.y

filterSig :: ∀ r1 r2.
             { sig :: Number | r1 }
          -> Map ChrId (Array (GWASFeature r2))
          -> Map ChrId (Array (GWASFeature r2))
filterSig {sig} = map (filter isSignificant)
  where sig' = 10.0 `Math.pow` (-sig)
        isSignificant {feature} = feature.score <= sig'

renderGWAS :: ∀ r.
              { min :: Number, max :: Number | r }
           -> Canvas.Dimensions
           -> Map ChrId (Array (GWASFeature ()))
           -> Map ChrId (Pair Number)
           -> RenderedTrack (GWASFeature ())
renderGWAS verscale cdim snps =
  let features :: Array (GWASFeature ())
      features = fold snps

      radius = 3.75

      drawing =
          let color = darkblue
              c = circle 0.0 0.0 radius
              out = outlined (outlineColor color) c
              fill = filled (fillColor color) c
          in out <> fill

      drawings :: Array (Tuple (GWASFeature ()) Point) -> Array DrawingN
      drawings pts = let (Tuple _ points) = Array.unzip pts
                     in [{ drawing, points }]

      npointed :: Map ChrId (Array (Tuple (GWASFeature ()) NPoint))
      npointed = (map <<< map) (fanout id (placeScored verscale)) snps

      rescale :: Pair Number -> NPoint -> Point
      rescale seg npoint =
        let (Pair offset _) = seg
            x = offset + (pairSize seg) * (unwrap npoint.x)
            y = cdim.height * (one - unwrap npoint.y)
        in {x, y}

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (GWASFeature ()) Point)
      pointed segs = fold $ zipMapsWith (\s p -> (map <<< map) (rescale s) p) segs npointed

      overlaps :: Array (Tuple (GWASFeature ()) Point)
               -> Number -> Point
               -> Array (GWASFeature ())
      overlaps pts radius' pt = filterMap covers pts
        where covers :: Tuple (GWASFeature ()) Point -> Maybe (GWASFeature ())
              covers (Tuple f fPt)
                | dist fPt pt <= radius + radius'   = Just f
                | otherwise = Nothing

  in \seg -> let pts = pointed seg
             in { features
                , drawings: drawings pts
                , labels: mempty
                , overlaps: overlaps pts }

renderAnnot :: ∀ r.
               { min :: Number, max :: Number | r }
            -> Canvas.Dimensions
            -> Map ChrId (Array (Annot (score :: Number)))
            -> Map ChrId (Pair Number)
            -> RenderedTrack (Annot (score :: Number))
renderAnnot verscale cdim annots =
  let features :: Array (Annot (score :: Number))
      features = fold annots

      tailHeight = 0.15

      drawing :: Tuple (Annot (score :: Number)) Point -> DrawingN
      drawing (Tuple an pt) = { drawing: tail <> lg.icon , points: [pt] }
        where lg = annotLegendEntry an
              tail = Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                     $ Drawing.path
                       [ {x: 0.0, y: 0.0 }
                       , {x: 0.0, y: tailHeight * cdim.height }]

      drawings :: Array (Tuple (Annot (score :: Number)) Point) -> Array DrawingN
      drawings = map drawing

      label :: Tuple (Annot (score :: Number)) Point -> Label
      label (Tuple an {x,y}) =
        { text: an.feature.name
        , point: { x, y: y - 12.0 }  }

      labels :: Array (Tuple (Annot (score :: Number)) Point) -> Array Label
      labels = map label

      npointed :: Map ChrId (Array (Tuple (Annot (score :: Number)) NPoint))
      npointed = (map <<< map) (fanout id place) annots
        where place p = let p' = placeScored verscale p
                        in { x: p'.x
                           , y: Normalized $ min 1.0 (unwrap p'.y + tailHeight) }

      rescale :: Pair Number -> NPoint -> Point
      rescale seg npoint =
        let (Pair offset _) = seg
            x = offset + (pairSize seg) * (unwrap npoint.x)
            y = cdim.height * (one - unwrap npoint.y)
        in {x, y}

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (Annot (score :: Number)) Point)
      pointed segs = fold $ zipMapsWith (\s p -> (map <<< map) (rescale s) p) segs npointed

      overlaps :: Number -> Point -> Array (Annot (score :: Number))
      overlaps r p = mempty

  in \seg -> let pts = pointed seg
             in { features
                , drawings: drawings pts
                , labels: labels pts
                , overlaps: overlaps  }

annotForSnp :: ∀ rA rS.
               Bp
            -> Map ChrId (Array (Annot rA))
            -> GWASFeature rS
            -> Maybe (Annot rA)
annotForSnp radius annotations {position, feature} = do
  chr <- Map.lookup feature.chrId annotations
  Array.find (\a -> ((radius `aroundPair` a.position) `pairsOverlap` position)) chr

renderAnnot' :: ∀ r r1 r2.
                CoordSys _ _
             -> Map ChrId (Array (GWASFeature ()))
             -> { min :: Number, max :: Number | r }
             -> Canvas.Dimensions
             -> Map ChrId (Array (Annot r2))
             -> Map ChrId (Pair Number)
             -> RenderedTrack (Annot r2)
renderAnnot' cSys sigSnps verscale cdim allAnnots =
  let features :: Array (Annot r2)
      features = fold allAnnots

      -- Returns the annotations collected per SNP peak, where the
      -- peaks are calculated based on current view scale, and peak x
      -- and y values converted to track canvas coordinates... TODO
      -- seriously need better mapping between normalized and
      -- trackcanvas coordinates (9th time the charm)
      curAnnotPeaks :: Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Number Number (Annot r2)))
      curAnnotPeaks = mapWithIndex f
        where f :: ChrId -> Pair Number -> Array (Peak _ _ (Annot r2))
              f chr seg = fromMaybe [] do
                  snps <- Map.lookup chr sigSnps
                  segSize <- _.frameSize <$> Array.head snps

                  let rad = (wrap $ pairSize seg * 3.75) / segSize
                      snpPeaks = peaks rad snps

                      peakAnnots pk = { covers, y, elements }
                        where offset = Pair.fst seg
                              covers = map (\x -> offset + pairSize seg * (unwrap $ x / segSize)) pk.covers
                              y = cdim.height * (one - (unwrap $ normalizedY verscale pk.y))
                              elements = fromMaybe [] do
                                chr <- Map.lookup chr allAnnots
                                pure $ filter (\a -> a.position
                                                  `pairsOverlap` pk.covers) chr

                  pure $ map peakAnnots snpPeaks

      tailHeight = 0.08
      tailPixels = tailHeight * cdim.height
      iconYOffset = -7.5
      labelOffset = -10.0

      drawing :: Peak Number Number (Annot r2)
              -> DrawingN
      drawing aPeak = { drawing: Drawing.translate 0.0 (-15.0) $ tail <> icons
                      , points: [{x, y: aPeak.y - (tailPixels * 0.8) }] }
        where (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)
              icon' = _.icon <<< annotLegendEntry
              icons = foldr (\a d -> Drawing.translate 0.0 iconYOffset
                                     $ d <> icon' a) mempty aPeak.elements

              tail = if Array.null aPeak.elements
                       then mempty
                       else Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                              $ Drawing.path
                                [ {x: 0.0, y: 0.0 }
                                , {x: 0.0, y: tailPixels }]

      drawings :: Map ChrId (Array (Peak Number Number (Annot r2)))
               -> Array DrawingN
      drawings = foldMap (map drawing)

      label :: Peak Number Number (Annot r2) -> Array Label
      label aPeak = Tuple.snd
                    $ foldr f (Tuple (aPeak.y - 2.5 * tailPixels)
                                     mempty) aPeak.elements
        where (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)
              f a (Tuple y ls) = Tuple (y + iconYOffset)
                                    $ Array.snoc ls -- TODO this is probably reaaaal slow
                                         { text: a.feature.name
                                         , point: { x, y } }

      labels :: Map ChrId (Array (Peak Number Number (Annot r2)))
             -> Array Label
      labels = foldMap (foldMap label)

      overlaps :: Number -> Point -> Array (Annot r2)
      overlaps r p = mempty

  in \segs -> let curPeaks = curAnnotPeaks segs
                  aa = Debug.trace ("#curPeaks: " <> show (sum $ map Array.length curPeaks)) \_ -> unit
              in { features
                 , drawings: drawings curPeaks
                 , labels: labels curPeaks
                 , overlaps: overlaps  }

module Genetics.Browser.Track.Demo where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (blue, navy, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgrey)
import Control.Coroutine (Producer, transform, ($~), (~~))
import Control.Monad.Aff (Aff, throwError)
import Control.Monad.Eff.Exception (error)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filter, filterMap, partition)
import Data.Foldable (class Foldable, any, fold, foldMap, foldr, maximumBy, minimumBy, or, sum)
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (view, (^?))
import Data.Lens.Index (ix)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.String as String
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple as Tuple
import Data.Unfoldable (unfoldr)
import Data.Variant (inj)
import Debug.Trace as Debug
import Genetics.Browser.Track.Backend (DrawingN, DrawingV, Feature, LegendEntry, NPoint, OldRenderer, RenderedTrack, Label, _range, _single, groupToMap, mkIcon, negLog10, trackLegend, zipMapsWith)
import Genetics.Browser.Track.Bed (ParsedLine, chunkProducer, fetchBed, fetchForeignChunks, parsedLineTransformer)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), ViewScale(..), _Segments, aroundPair, pairSize, pairsOverlap, xPerPixel)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Unsafe.Coerce (unsafeCoerce)

type BedFeature = Feature { thickRange :: Pair Bp
                          , blocks :: Array (Pair Bp)
                          , geneId :: String
                          , geneName :: String
                          , chrId :: ChrId }

bedToFeature :: CoordSys ChrId BigInt -> ParsedLine -> Maybe BedFeature
bedToFeature cs pl = do
  seg@(Pair offset _ ) <- cs ^? _Segments <<< ix pl.chrom

  -- TODO validate ranges maybe, idk
  let toBp :: BigInt -> Bp
      toBp = wrap <<< BigInt.toNumber

      frameSize = toBp $ pairSize seg
      position = toBp  <$> Pair pl.chromStart pl.chromEnd
      thickRange = toBp  <$> Pair pl.thickStart pl.thickEnd

      blocks = Array.zipWith
                 (\start size -> map toBp (Pair start size))
                 pl.blockStarts pl.blockSizes

  pure { position
       , frameSize
       , feature: { thickRange
                  , blocks
                  , geneId: pl.geneId
                  , geneName: pl.geneName
                  , chrId: pl.chrom
                  }
       }

getGenes :: CoordSys ChrId BigInt
         -> String
         -> Aff _ (Map ChrId (Array BedFeature))
getGenes cs url = do
  ls <- fetchBed url

  let fs = filterMap (bedToFeature cs) ls

  pure $ groupToMap _.feature.chrId $ fs

produceGenes :: CoordSys ChrId BigInt -> String
             -> Aff _
                (Producer
                 (Map ChrId (Array BedFeature))
                 (Aff _) Unit)
produceGenes cs url = do
  prod <- fetchForeignChunks url

  pure
    $ prod
    $~ parsedLineTransformer
    ~~ transform
       (groupToMap _.feature.chrId <<< filterMap (bedToFeature cs))

bedDraw :: BedFeature
        -> DrawingV
bedDraw gene = inj _range \w ->
  let (Pair l r) = gene.position
      toLocal x = w * (unwrap $ x / gene.frameSize)

      width = toLocal (r - l)

      exon block =
        let p@(Pair exL' size') = toLocal <$> block
            s = rectangle exL' zero size' 30.0
        in (outlined (outlineColor darkgrey <> lineWidth 1.0) s)
        <> (filled (fillColor lightgrey) s)

      introns _ =
        let s = rectangle 1.5 14.0 (width-1.5) 2.0
        in outlined (outlineColor black <> lineWidth 3.0) s
        <> filled   (fillColor black) s

      label _ =
        Drawing.text
          (font sansSerif 12 mempty)
             (2.5) (35.0)
             (fillColor black) gene.feature.geneName

      drawing =
        if width < one
        then mempty
        else \_ -> introns unit
                <> foldMap exon gene.feature.blocks
                <> label unit

  in { drawing, width }

geneRenderer :: OldRenderer BedFeature
geneRenderer = inj _single { draw: bedDraw, horPlace, verPlace: const (Normalized 0.10) }
  where horPlace {position, frameSize} =
          let f p = Normalized (unwrap $ p / frameSize)
          in inj _range $ map f position

fetchJsonChunks :: String
                -> Aff _ (Producer (Array Json) (Aff _) Unit)
fetchJsonChunks url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just ls -> pure $ chunkProducer 512 ls

featureProd :: ∀ r1 r2.
               String
            -> (Json -> Maybe { feature :: { chrId :: ChrId | r1 } | r2 })
            -> Aff _
                 (Producer
                 (Map ChrId (Array { feature :: { chrId :: ChrId | r1 } | r2 }))
                 (Aff _) Unit)
featureProd url parse = do
  prod <- fetchJsonChunks url
  pure $ prod $~ (transform $ groupToMap _.feature.chrId <<< filterMap parse)

-- TODO bundle up all the producers into one function on a record of URLs
--      to a record of producers (maprecord? applyrecord?)
produceGWAS :: CoordSys ChrId _
            -> String
            -> Aff _
               (Producer
                (Map ChrId
                 (Array (GWASFeature ())))
                 (Aff _) Unit)
produceGWAS cs url = featureProd url $ gemmaJSONParse cs

produceAnnots :: CoordSys ChrId _
              -> String
              -> Aff _
                 (Producer
                  (Map ChrId
                   (Array (Annot ())))
                   (Aff _) Unit)
produceAnnots cs url = featureProd url $ (annotJSONParse cs)

fetchJSON :: ∀ a.
             (Json -> Maybe a)
          -> String
          -> Aff _ (Array a)
fetchJSON p url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just as -> case traverse p as of
      Nothing -> throwError $ error "Failed to parse JSON features"
      Just fs -> pure $ fs

type GWASFeature r = Feature { score :: Number
                             , chrId :: ChrId
                             , name  :: String | r }

gemmaJSONParse :: CoordSys ChrId BigInt
               -> Json
               -> Maybe (GWASFeature ())
gemmaJSONParse cs j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "p_wald"  <<< _Number
  name  <-           obj ^? ix "rs"  <<< _String

  chrSize <- (Bp <<< BigInt.toNumber <<< pairSize) <$> Map.lookup chrId (view _Segments cs)

  pure { position: Pair pos pos
       , frameSize: chrSize
       , feature: { score, chrId, name }
       }

type AnnotRow r = ( geneID :: String
                   , desc :: String
                   , name :: String
                   , chrId :: ChrId | r )
type Annot r = Feature {| AnnotRow r}

annotJSONParse :: CoordSys ChrId BigInt
              -> Json
              -> Maybe (Annot ())
annotJSONParse cs j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  chrId  <- ChrId <$> obj ^? ix "ChrId" <<< _String

  chrSize <- (Bp <<< BigInt.toNumber <<< pairSize) <$> Map.lookup chrId (view _Segments cs)

  pure { position: Pair start end
       , frameSize: chrSize
       , feature: { geneID, desc, name, chrId }
       }

fetchAnnotJSON :: CoordSys ChrId BigInt -> String
               -> Aff _ (Array (Annot ()))
fetchAnnotJSON cs str = fetchJSON (annotJSONParse cs) str

getGWAS :: CoordSys ChrId BigInt -> String
        -> Aff _ (Map ChrId (Array (GWASFeature ())))
getGWAS cs url = groupToMap _.feature.chrId
                  <$> filter (\f -> Pair.fst (f.position) >= wrap zero)
                  <$> fetchJSON (gemmaJSONParse cs) url

getAnnotations :: CoordSys ChrId BigInt -> String
               -> Aff _ (Map ChrId (Array (Annot ())))
getAnnotations cs url = groupToMap _.feature.chrId
                        <$> fetchAnnotJSON cs url

getAnnotations' :: ∀ rS.
                   CoordSys ChrId BigInt
                -> Map ChrId (Array (GWASFeature rS))
                -> String
                -> Aff _ (Map ChrId (Array (Annot ())))
getAnnotations' cs snps url =  groupToMap _.feature.chrId
                              <$> interestingAnnots (Bp 50000.0) snps
                              <$> fetchAnnotJSON cs url

inRangeOf :: ∀ rA rB.
             Bp
          -> { position :: Pair Bp | rA }
          -> { position :: Pair Bp | rB }
          -> Boolean
inRangeOf r a b = pairsOverlap a.position
                             $ r `aroundPair` b.position

interestingAnnots :: ∀ rA rS f.
                     Filterable f
                  => Bp
                  -> Map ChrId (Array (GWASFeature rS))
                  -> f (Annot rA)
                  -> f (Annot rA)
interestingAnnots radius snps = filter (any (any (inRangeOf radius)) snps)

type Peak x y r = { covers :: Pair x
                   , y :: y
                   , elements :: Array r }

peak1 :: ∀ rS.
         Bp
      -> Array (GWASFeature rS)
      -> Maybe (Tuple (Peak _ _ (GWASFeature rS))
                      (Array (GWASFeature rS)))
peak1 radius snps = do
  top <- minimumBy (compare `on` _.feature.score) snps

  let covers = radius `aroundPair` top.position
      y = top.feature.score
      {no, yes} = partition (\p -> p.position `pairsOverlap` covers) snps

  pure $ Tuple {covers, y, elements: yes} no

peaks :: ∀ rS.
         Bp
      -> Array (GWASFeature rS)
      -> Array (Peak Bp Number (GWASFeature rS))
peaks r snps = unfoldr (peak1 r) snps

visiblePeaks :: ∀ rS.
                ViewScale
             -> Map ChrId (Array (GWASFeature rS))
             -> Map ChrId (Array (Peak Bp Number (GWASFeature rS)))
visiblePeaks vs snps = Debug.trace ("radius: " <> show radius) \_ -> map (peaks radius) snps
  where radius :: Bp
        radius = wrap $ (xPerPixel vs) * 3.75 -- GWAS glyph radius is 3.75px, see renderGWAS

-- TODO Configgable Annotation -> LegendEntry function (somehow?!)
annotLegendEntry :: ∀ r. Annot r -> LegendEntry
annotLegendEntry a =
  if (String.length a.feature.name) `mod` 2 == 0
    then mkIcon blue "even name"
    else mkIcon red  "odd name"

annotLegendTest :: ∀ f r.
                   Foldable f
                => Functor f
                => Map ChrId (f (Annot r))
                -> Array LegendEntry
annotLegendTest fs = trackLegend annotLegendEntry as
  where as = Array.concat
             $ Array.fromFoldable
             $ Array.fromFoldable <$> Map.values fs

------------ new renderers~~~~~~~~~

placeScored :: ∀ r1 r2.
               { min :: Number, max :: Number | r1 }
            -> Feature { score :: Number | r2 }
            -> NPoint
placeScored verScale { frameSize, position: (Pair l _), feature } = {x, y}
  where x = Normalized $ unwrap $ l / frameSize
        y = normalizedY verScale feature.score

normalizedY :: ∀ r.
               { min :: Number, max :: Number | r }
            -> Number
            -> Normalized Number
normalizedY {min, max} y = Normalized $ ((negLog10 y) - min) / (max - min)

dist :: Point -> Point -> Number
dist p1 p2 = Math.sqrt $ x' `Math.pow` 2.0 + y' `Math.pow` 2.0
  where x' = p1.x - p2.x
        y' = p1.y - p2.y

filterSig :: ∀ r1 r2.
             { sig :: Number | r1 }
          -> Map ChrId (Array (GWASFeature r2))
          -> Map ChrId (Array (GWASFeature r2))
filterSig {sig} = map (filter isSignificant)
  where sig' = 10.0 `Math.pow` (-sig)
        isSignificant {feature} = feature.score <= sig'

renderGWAS :: ∀ r.
              { min :: Number, max :: Number | r }
           -> Canvas.Dimensions
           -> Map ChrId (Array (GWASFeature ()))
           -> Map ChrId (Pair Number)
           -> RenderedTrack (GWASFeature ())
renderGWAS verscale cdim snps =
  let features :: Array (GWASFeature ())
      features = fold snps

      radius = 3.75

      drawing =
          let color = darkblue
              c = circle 0.0 0.0 radius
              out = outlined (outlineColor color) c
              fill = filled (fillColor color) c
          in out <> fill

      drawings :: Array (Tuple (GWASFeature ()) Point) -> Array DrawingN
      drawings pts = let (Tuple _ points) = Array.unzip pts
                     in [{ drawing, points }]

      npointed :: Map ChrId (Array (Tuple (GWASFeature ()) NPoint))
      npointed = (map <<< map) (fanout id (placeScored verscale)) snps

      rescale :: Pair Number -> NPoint -> Point
      rescale seg npoint =
        let (Pair offset _) = seg
            x = offset + (pairSize seg) * (unwrap npoint.x)
            y = cdim.height * (one - unwrap npoint.y)
        in {x, y}

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (GWASFeature ()) Point)
      pointed segs = fold $ zipMapsWith (\s p -> (map <<< map) (rescale s) p) segs npointed

      overlaps :: Array (Tuple (GWASFeature ()) Point)
               -> Number -> Point
               -> Array (GWASFeature ())
      overlaps pts radius' pt = filterMap covers pts
        where covers :: Tuple (GWASFeature ()) Point -> Maybe (GWASFeature ())
              covers (Tuple f fPt)
                | dist fPt pt <= radius + radius'   = Just f
                | otherwise = Nothing

  in \seg -> let pts = pointed seg
             in { features
                , drawings: drawings pts
                , labels: mempty
                , overlaps: overlaps pts }

renderAnnot :: ∀ r.
               { min :: Number, max :: Number | r }
            -> Canvas.Dimensions
            -> Map ChrId (Array (Annot (score :: Number)))
            -> Map ChrId (Pair Number)
            -> RenderedTrack (Annot (score :: Number))
renderAnnot verscale cdim annots =
  let features :: Array (Annot (score :: Number))
      features = fold annots

      tailHeight = 0.15

      drawing :: Tuple (Annot (score :: Number)) Point -> DrawingN
      drawing (Tuple an pt) = { drawing: tail <> lg.icon , points: [pt] }
        where lg = annotLegendEntry an
              tail = Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                     $ Drawing.path
                       [ {x: 0.0, y: 0.0 }
                       , {x: 0.0, y: tailHeight * cdim.height }]

      drawings :: Array (Tuple (Annot (score :: Number)) Point) -> Array DrawingN
      drawings = map drawing

      label :: Tuple (Annot (score :: Number)) Point -> Label
      label (Tuple an {x,y}) =
        { text: an.feature.name
        , point: { x, y: y - 12.0 }  }

      labels :: Array (Tuple (Annot (score :: Number)) Point) -> Array Label
      labels = map label

      npointed :: Map ChrId (Array (Tuple (Annot (score :: Number)) NPoint))
      npointed = (map <<< map) (fanout id place) annots
        where place p = let p' = placeScored verscale p
                        in { x: p'.x
                           , y: Normalized $ min 1.0 (unwrap p'.y + tailHeight) }

      rescale :: Pair Number -> NPoint -> Point
      rescale seg npoint =
        let (Pair offset _) = seg
            x = offset + (pairSize seg) * (unwrap npoint.x)
            y = cdim.height * (one - unwrap npoint.y)
        in {x, y}

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (Annot (score :: Number)) Point)
      pointed segs = fold $ zipMapsWith (\s p -> (map <<< map) (rescale s) p) segs npointed

      overlaps :: Number -> Point -> Array (Annot (score :: Number))
      overlaps r p = mempty

  in \seg -> let pts = pointed seg
             in { features
                , drawings: drawings pts
                , labels: labels pts
                , overlaps: overlaps  }

annotForSnp :: ∀ rA rS.
               Bp
            -> Map ChrId (Array (Annot rA))
            -> GWASFeature rS
            -> Maybe (Annot rA)
annotForSnp radius annotations {position, feature} = do
  chr <- Map.lookup feature.chrId annotations
  Array.find (\a -> ((radius `aroundPair` a.position) `pairsOverlap` position)) chr

renderAnnot' :: ∀ r r1 r2.
                CoordSys _ _
             -> Map ChrId (Array (GWASFeature ()))
             -> { min :: Number, max :: Number | r }
             -> Canvas.Dimensions
             -> Map ChrId (Array (Annot r2))
             -> Map ChrId (Pair Number)
             -> RenderedTrack (Annot r2)
renderAnnot' cSys sigSnps verscale cdim allAnnots =
  let features :: Array (Annot r2)
      features = fold allAnnots

      -- Returns the annotations collected per SNP peak, where the
      -- peaks are calculated based on current view scale, and peak x
      -- and y values converted to track canvas coordinates... TODO
      -- seriously need better mapping between normalized and
      -- trackcanvas coordinates (9th time the charm)
      curAnnotPeaks :: Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Number Number (Annot r2)))
      curAnnotPeaks = mapWithIndex f
        where f :: ChrId -> Pair Number -> Array (Peak _ _ (Annot r2))
              f chr seg = fromMaybe [] do
                  snps <- Map.lookup chr sigSnps
                  segSize <- _.frameSize <$> Array.head snps

                  let rad = (wrap $ pairSize seg * 3.75) / segSize
                      snpPeaks = peaks rad snps

                      peakAnnots pk = { covers, y, elements }
                        where offset = Pair.fst seg
                              covers = map (\x -> offset + pairSize seg * (unwrap $ x / segSize)) pk.covers
                              y = cdim.height * (one - (unwrap $ normalizedY verscale pk.y))
                              elements = fromMaybe [] do
                                chr <- Map.lookup chr allAnnots
                                pure $ filter (\a -> a.position
                                                  `pairsOverlap` pk.covers) chr

                  pure $ map peakAnnots snpPeaks

      tailHeight = 0.08
      tailPixels = tailHeight * cdim.height
      iconYOffset = -7.5
      labelOffset = -10.0

      drawing :: Peak Number Number (Annot r2)
              -> DrawingN
      drawing aPeak = { drawing: Drawing.translate 0.0 (-15.0) $ tail <> icons
                      , points: [{x, y: aPeak.y - (tailPixels * 0.8) }] }
        where (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)
              icon' = _.icon <<< annotLegendEntry
              icons = foldr (\a d -> Drawing.translate 0.0 iconYOffset
                                     $ d <> icon' a) mempty aPeak.elements

              tail = if Array.null aPeak.elements
                       then mempty
                       else Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                              $ Drawing.path
                                [ {x: 0.0, y: 0.0 }
                                , {x: 0.0, y: tailPixels }]

      drawings :: Map ChrId (Array (Peak Number Number (Annot r2)))
               -> Array DrawingN
      drawings = foldMap (map drawing)

      label :: Peak Number Number (Annot r2) -> Array Label
      label aPeak = Tuple.snd
                    $ foldr f (Tuple (aPeak.y - 2.5 * tailPixels)
                                     mempty) aPeak.elements
        where (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)
              f a (Tuple y ls) = Tuple (y + iconYOffset)
                                    $ Array.snoc ls -- TODO this is probably reaaaal slow
                                         { text: a.feature.name
                                         , point: { x, y } }

      labels :: Map ChrId (Array (Peak Number Number (Annot r2)))
             -> Array Label
      labels = foldMap (foldMap label)

      overlaps :: Number -> Point -> Array (Annot r2)
      overlaps r p = mempty

  in \segs -> let curPeaks = curAnnotPeaks segs
                  aa = Debug.trace ("#curPeaks: " <> show (sum $ map Array.length curPeaks)) \_ -> unit
              in { features
                 , drawings: drawings curPeaks
                 , labels: labels curPeaks
                 , overlaps: overlaps  }


General functions for rendering

General functions for rendering

module Genetics.Browser.Track where

import Prelude

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

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

{-

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

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

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

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

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

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

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

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

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

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

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

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

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

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

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

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

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

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

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

    Scroll n -> do
      pure unit

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

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

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

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

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

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

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

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

      fs' :: Frames (Tuple String (Array _))
      fs' = zipWithFrames colors fs

      r' :: Renderer _ (Tuple String a)
      r' = strokeRenderer r

  liftEff $ renderFramesN yInfo fs r ctx

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

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

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

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

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

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

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

  -- trackState <- makeVar

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

  -- feats <- fetch
  -- pure unit

{-

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

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

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

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

  fs <- f v

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

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

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

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

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

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

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

  fetch v
  -}

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse_)
import Data.Tuple (Tuple(..))
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C

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

{-

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

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

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

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

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

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

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

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

-- Given a score range,
-- size of the current chr + scale (scale should be somewhere else...)
-- vertical size of the track
-- we can produce a mapping from canvases to SingleGlyph renderers

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

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

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

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

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

    Scroll n -> do
      pure unit

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

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

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

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

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

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

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

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

      fs' :: Frames (Tuple String (Array _))
      fs' = zipWithFrames colors fs

      r' :: Renderer _ (Tuple String a)
      r' = strokeRenderer r

  liftEff $ renderFramesN yInfo fs r ctx

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

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

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

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

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

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

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

  -- trackState <- makeVar

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

  -- feats <- fetch
  -- pure unit

{-

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

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

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

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

  fs <- f v

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

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

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

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

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

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

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

  fetch v
  -}


Fix "hitch" when scrolling browser by click & drag

module Genetics.Browser.Track.UI
       ( main
       ) where

import Prelude

import Color (black)
import Control.Alt ((<|>))
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.Classy.Node (toNode)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Element as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, Node)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (filterMap)
import Data.Int as Int
import Data.Lens (_Left, (^?), (^.))
import Data.List (List)
import Data.Map (Map)
import Data.Maybe (Maybe(Nothing, Just), fromJust, fromMaybe)
import Data.Newtype (unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Ratio (Ratio, (%))
import Data.Tuple (Tuple(Tuple))
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (demoBrowser, demoLegend, getDataDemo)
import Genetics.Browser.Types (Bp, ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordInterval, CoordSys, Interval, RelPoint, _BrowserSize, canvasToView, findBrowserInterval, intervalToGlobal, mkCoordSys, shiftIntervalBy, zoomIntervalBy)
import Genetics.Browser.View (Pixels)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { width :: Number, height :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { width :: Number, height :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type BrowserView = Interval BrowserPoint

data UpdateView =
    ScrollView (Ratio BigInt)
  | ZoomView (Ratio BigInt)
  | ModView (BrowserView -> BrowserView)

btnScroll :: forall r.
             Ratio BigInt
          -> Event UpdateView
btnScroll x =  const (ScrollView (-x)) <$> buttonEvent "scrollLeft"
           <|> const (ScrollView   x ) <$> buttonEvent "scrollRight"

btnZoom :: (Ratio BigInt)
        -> Event UpdateView
btnZoom m =  const (ZoomView    m ) <$> buttonEvent "zoomOut"
         <|> const (ZoomView  (-m)) <$> buttonEvent "zoomIn"

btnUpdateView :: { scroll :: Ratio BigInt
                 , zoom :: Ratio BigInt
                 , reset :: BrowserView }
              -> Event UpdateView
btnUpdateView {scroll, zoom, reset}
  =  btnScroll scroll
 <|> btnZoom zoom
 <|> (const (ModView (const reset)) <$> buttonEvent "reset")

updateViewFold :: CoordSys ChrId BrowserPoint
               -> UpdateView
               -> BrowserView
               -> BrowserView
updateViewFold cs uv iv@(Pair l r) = case uv of
  ZoomView   x -> iv `zoomIntervalBy`  x
  ScrollView x -> iv `shiftIntervalBy` x
  ModView f    -> f iv

browserViewEvent :: CoordSys ChrId BrowserPoint
                 -> BrowserView
                 -> Event UpdateView
                 -> Event BrowserView
browserViewEvent cs start ev =
  Event.fold
    (\a b -> (normalizeView start) (updateViewFold cs a b)) ev start
  where normalizeView (Pair lhs rhs) (Pair l r)
          = Pair (max lhs l) (min r rhs)

browserDrawEvent :: CoordSys ChrId BrowserPoint
                 -> { width :: Pixels, height :: Pixels }
                 -> Pixels
                 -> { min :: Number, max :: Number, sig :: Number }
                 -> { vScaleWidth :: Pixels, legendWidth :: Pixels }
                 -> { gwas   :: Map ChrId (List _)
                    , annots :: Map ChrId (List _) }
                 -> Event BrowserView
                 -> Event {track :: Drawing, overlay :: Drawing}
browserDrawEvent csys canvasSize vpadding vscale uiSize dat
  = let dd = demoBrowser csys canvasSize vpadding vscale uiSize black demoLegend dat
    in map dd

clickEvent :: forall r. CanvasElement -> Event Pixels
clickEvent el = (_.x) <$> canvasEvent "mousedown" el

globalClick :: Event (Interval BrowserPoint) -> Event (Ratio BigInt) -> Event BrowserPoint
globalClick vs vx = (\iv r -> intervalToGlobal iv r) <$> vs <*> vx

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (CoordInterval _ _))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = map (\ {chrSize, index}
                       -> Tuple index chrSize) <$> ev

showView :: Interval BrowserPoint -> String
showView (Pair l r) =
     "< "
  <> BigInt.toString (unwrap l)
  <> " -- "
  <> BigInt.toString (unwrap r)
  <> " >"

showLP :: Interval BrowserPoint -> RelPoint -> String
showLP iv p =
     "Interval: "
  <> showView iv
  <> ";\t"
  <> show p

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ fromMaybe {x:zero,y:zero} (toMaybe ev.total)

browserDrag :: forall r.
               { width :: Number | r }
            -> Event Point
            -> Event (Ratio BigInt)
browserDrag w ev = f <$> ev
  where f :: _ -> _
        f {x} = let width' = BigInt.fromInt $ Int.round w.width
                    x' = BigInt.fromInt $ Int.round x
                in x' % width'

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoomEvent :: CanvasElement -> Event UpdateView
scrollZoomEvent el = map (ZoomView <<< f) $ canvasWheelEvent el
  where f :: Number -> Ratio BigInt
        f dY = let d' = 10000.0
                   n = BigInt.fromInt $ Int.round $ dY * d'
                   d = BigInt.fromInt $ Int.round $ d' * 100.0
               in n % d

type BrowserCanvas = { buffer  :: CanvasElement
                     , track   :: CanvasElement
                     , overlay :: CanvasElement
                     }

createBrowserCanvas :: Element
                    -> { width :: Number, height :: Number }
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  overlay <- newCanvas dim

  DOM.setId (wrap "buffer")  (element buffer)
  DOM.setId (wrap "track")   (element track)
  DOM.setId (wrap "overlay") (element overlay)

  DOM.setAttribute "style" (   "width: "  <> show dim.width  <> "px"
                          <> "; height: " <> show dim.height <> "px"
                          <> "; position:relative"
                          <> "; border: 1px solid black; display: block; margin: 0; padding: 0"
                          ) el

  let css i = "position:absolute; z-index: " <> i

  DOM.setAttribute "style" (css "1") (element track)
  DOM.setAttribute "style" (css "2") (element overlay)

  _ <- DOM.appendChild (node track)   (toNode el)
  _ <- DOM.appendChild (node overlay) (toNode el)

  pure { buffer, track, overlay }

main :: Eff _ _
main = launchAff $ do

  {width} <- liftEff $ getScreenSize

  let height = 200.0
      browserDimensions = {width, height}
      vScaleWidth = 40.0
      legendWidth = 100.0
      trackWidth = width - (vScaleWidth + legendWidth)

  bCanvas <- do
    doc <- liftEff $ DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    cont <- liftEff $ DOM.querySelector (wrap "#browser") (toParentNode doc)
    case cont of
      Nothing -> throwError $ error "Could not find browser element"
      Just el -> liftEff $ createBrowserCanvas el browserDimensions

  let browserDragEvent :: Event (Ratio BigInt)
      browserDragEvent = map negate
                         $ browserDrag {width: trackWidth}
                         $ filterMap (_^?_Left) (canvasDrag bCanvas.overlay)

  void $ liftEff $ unsafeCoerceEff $ FRP.subscribe (canvasDrag bCanvas.overlay) $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas bCanvas.buffer bCanvas.track {x: -x, y: 0.0}

  updateBrowser <- liftEff $ Event.create

  let
      begin :: Interval BrowserPoint
      begin = Pair zero (coordSys^._BrowserSize)

      viewEvent :: Event BrowserView
      viewEvent = browserViewEvent coordSys begin
                  $  btnUpdateView { scroll: one % BigInt.fromInt 20
                                   , zoom:   one % BigInt.fromInt 20
                                   , reset: begin
                                   }
                 <|> map ScrollView browserDragEvent
                 <|> const (ModView id) <$> updateBrowser.event
                 <|> scrollZoomEvent bCanvas.overlay

      click = clickEvent bCanvas.overlay
      vClick = map (canvasToView {width}) click
      gClick = globalClick viewEvent vClick
      fClick = map (findBrowserInterval coordSys) gClick

      clickEvs :: Event { view :: BrowserView
                        , canvasClick :: Number
                        , vClick :: Ratio BigInt
                        , gClick :: BrowserPoint
                        , fClick :: Maybe (CoordInterval ChrId BrowserPoint)
                        , cClick :: Maybe (Tuple ChrId Bp) }
      clickEvs = { view: _
                 , canvasClick: _
                 , vClick: _
                 , gClick: _
                 , fClick: _
                 , cClick: _
                 }
                 <$> viewEvent
                 <*> click
                 <*> vClick
                 <*> gClick
                 <*> fClick
                 <*> chrClick coordSys fClick

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sF (Just x) = "Frame: " <> show (unsafeStringify x)
               sF Nothing = "No Frame"
               sChr x = "Chr: " <> unsafeStringify x
               -- sChr (Just x) = "Chr: " <> show chr <> "\t" <> show (unwrap bp)
               -- sChr Nothing = "No Chr"

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> "
" <> "Canvas click:" <> show ev.canvasClick <> "
"
                    <> "
" <> "View click:" <> show ev.vClick <> "
"
                    <> "
" <> "Global click:" <> show (unwrap ev.gClick) <> "
"
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- do
    res <- getDataDemo { gwas: "./gwas.json"
                       , annots: "./annots_fake.json" }
    liftEff $ updateBrowser.push unit
    pure res

  let score = {min: 0.125, max: 0.42, sig: 0.25}

  let ev' = browserDrawEvent
              coordSys
              browserDimensions
              25.0 score
              {vScaleWidth, legendWidth}
              dat
              viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 width height

  -- TODO correctly render the layers
  trackCtx <- liftEff $ getContext2D bCanvas.track
  overlayCtx <- liftEff $ getContext2D bCanvas.overlay
  void $ liftEff $ Event.subscribe ev' \d -> do
    Drawing.render trackCtx (bg <> d.track)
    Drawing.render overlayCtx d.overlay

  liftEff $ updateBrowser.push unit

coordSys :: CoordSys ChrId BrowserPoint
coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
            [ Tuple (ChrId "1")   (unsafePartial $ fromJust $ BigInt.fromString "195471971")
            , Tuple (ChrId "2")   (unsafePartial $ fromJust $ BigInt.fromString "182113224")
            , Tuple (ChrId "3")   (unsafePartial $ fromJust $ BigInt.fromString "160039680")
            , Tuple (ChrId "4")   (unsafePartial $ fromJust $ BigInt.fromString "156508116")
            , Tuple (ChrId "5")   (unsafePartial $ fromJust $ BigInt.fromString "151834684")
            , Tuple (ChrId "6")   (unsafePartial $ fromJust $ BigInt.fromString "149736546")
            , Tuple (ChrId "7")   (unsafePartial $ fromJust $ BigInt.fromString "145441459")
            , Tuple (ChrId "8")   (unsafePartial $ fromJust $ BigInt.fromString "129401213")
            , Tuple (ChrId "9")   (unsafePartial $ fromJust $ BigInt.fromString "124595110")
            , Tuple (ChrId "10")  (unsafePartial $ fromJust $ BigInt.fromString "130694993")
            , Tuple (ChrId "11")  (unsafePartial $ fromJust $ BigInt.fromString "122082543")
            , Tuple (ChrId "12")  (unsafePartial $ fromJust $ BigInt.fromString "120129022")
            , Tuple (ChrId "13")  (unsafePartial $ fromJust $ BigInt.fromString "120421639")
            , Tuple (ChrId "14")  (unsafePartial $ fromJust $ BigInt.fromString "124902244")
            , Tuple (ChrId "15")  (unsafePartial $ fromJust $ BigInt.fromString "104043685")
            , Tuple (ChrId "16")  (unsafePartial $ fromJust $ BigInt.fromString "98207768")
            , Tuple (ChrId "17")  (unsafePartial $ fromJust $ BigInt.fromString "94987271")
            , Tuple (ChrId "18")  (unsafePartial $ fromJust $ BigInt.fromString "90702639")
            , Tuple (ChrId "19")  (unsafePartial $ fromJust $ BigInt.fromString "61431566")
            , Tuple (ChrId "X")   (unsafePartial $ fromJust $ BigInt.fromString "17103129")
            , Tuple (ChrId "Y")   (unsafePartial $ fromJust $ BigInt.fromString "9174469")
            ]

module Genetics.Browser.Track.UI
       ( main
       ) where

import Prelude

import Color (black)
import Control.Alt ((<|>))
import Control.Monad.Aff (launchAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.Classy.Node (toNode)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Element as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (Element, Node)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (filterMap)
import Data.Int as Int
import Data.Lens (_Left, (^?), (^.))
import Data.List (List)
import Data.Map (Map)
import Data.Maybe (Maybe(Nothing, Just), fromJust, fromMaybe)
import Data.Newtype (unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Pair (Pair(..))
import Data.Ratio (Ratio, (%))
import Data.Tuple (Tuple(Tuple))
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (demoBrowser, demoLegend, getDataDemo)
import Genetics.Browser.Types (Bp, ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordInterval, CoordSys, Interval, RelPoint, _BrowserSize, canvasToView, findBrowserInterval, intervalToGlobal, mkCoordSys, shiftIntervalBy, zoomIntervalBy)
import Genetics.Browser.View (Pixels)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { width :: Number, height :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { width :: Number, height :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type BrowserView = Interval BrowserPoint

data UpdateView =
    ScrollView (Ratio BigInt)
  | ZoomView (Ratio BigInt)
  | ModView (BrowserView -> BrowserView)

btnScroll :: forall r.
             Ratio BigInt
          -> Event UpdateView
btnScroll x =  const (ScrollView (-x)) <$> buttonEvent "scrollLeft"
           <|> const (ScrollView   x ) <$> buttonEvent "scrollRight"

btnZoom :: (Ratio BigInt)
        -> Event UpdateView
btnZoom m =  const (ZoomView    m ) <$> buttonEvent "zoomOut"
         <|> const (ZoomView  (-m)) <$> buttonEvent "zoomIn"

btnUpdateView :: { scroll :: Ratio BigInt
                 , zoom :: Ratio BigInt
                 , reset :: BrowserView }
              -> Event UpdateView
btnUpdateView {scroll, zoom, reset}
  =  btnScroll scroll
 <|> btnZoom zoom
 <|> (const (ModView (const reset)) <$> buttonEvent "reset")

updateViewFold :: CoordSys ChrId BrowserPoint
               -> UpdateView
               -> BrowserView
               -> BrowserView
updateViewFold cs uv iv@(Pair l r) = case uv of
  ZoomView   x -> iv `zoomIntervalBy`  x
  ScrollView x -> iv `shiftIntervalBy` x
  ModView f    -> f iv

browserViewEvent :: CoordSys ChrId BrowserPoint
                 -> BrowserView
                 -> Event UpdateView
                 -> Event BrowserView
browserViewEvent cs start ev =
  Event.fold
    (\a b -> (normalizeView start) (updateViewFold cs a b)) ev start
  where normalizeView (Pair lhs rhs) (Pair l r)
          = Pair (max lhs l) (min r rhs)

browserDrawEvent :: CoordSys ChrId BrowserPoint
                 -> { width :: Pixels, height :: Pixels }
                 -> Pixels
                 -> { min :: Number, max :: Number, sig :: Number }
                 -- -> { vScaleWidth :: Pixels, legendWidth :: Pixels }
                 -> { gwas   :: Map ChrId (List _)
                    , annots :: Map ChrId (List _) }
                 -> Event BrowserView
                 -> Event {track :: Drawing, overlay :: Drawing}
browserDrawEvent csys canvasSize vpadding vscale dat
  = let dd = demoBrowser csys canvasSize vpadding vscale {vScaleWidth, legendWidth} black demoLegend dat
        vScaleWidth = 40.0
        legendWidth = 100.0
    in map dd

clickEvent :: forall r. CanvasElement -> Event Pixels
clickEvent el = (_.x) <$> canvasEvent "mousedown" el

globalClick :: Event (Interval BrowserPoint) -> Event (Ratio BigInt) -> Event BrowserPoint
globalClick vs vx = (\iv r -> intervalToGlobal iv r) <$> vs <*> vx

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (CoordInterval _ _))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = map (\ {chrSize, index}
                       -> Tuple index chrSize) <$> ev

showView :: Interval BrowserPoint -> String
showView (Pair l r) =
     "< "
  <> BigInt.toString (unwrap l)
  <> " -- "
  <> BigInt.toString (unwrap r)
  <> " >"

showLP :: Interval BrowserPoint -> RelPoint -> String
showLP iv p =
     "Interval: "
  <> showView iv
  <> ";\t"
  <> show p

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ fromMaybe {x:zero,y:zero} (toMaybe ev.total)

browserDrag :: forall r.
               { width :: Number | r }
            -> Event Point
            -> Event (Ratio BigInt)
browserDrag w ev = f <$> ev
  where f :: _ -> _
        f {x} = let width' = BigInt.fromInt $ Int.round w.width
                    x' = BigInt.fromInt $ Int.round x
                in x' % width'

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoomEvent :: CanvasElement -> Event UpdateView
scrollZoomEvent el = map (ZoomView <<< f) $ canvasWheelEvent el
  where f :: Number -> Ratio BigInt
        f dY = let d' = 10000.0
                   n = BigInt.fromInt $ Int.round $ dY * d'
                   d = BigInt.fromInt $ Int.round $ d' * 100.0
               in n % d

type BrowserCanvas = { buffer  :: CanvasElement
                     , track   :: CanvasElement
                     , overlay :: CanvasElement
                     }

createBrowserCanvas :: Element
                    -> { width :: Number, height :: Number }
                    -> Eff _ BrowserCanvas
createBrowserCanvas el dim = do
  let node :: CanvasElement -> Node
      node = unsafeCoerce
      element :: CanvasElement -> Element
      element = unsafeCoerce

  buffer  <- newCanvas dim
  track   <- newCanvas dim
  overlay <- newCanvas dim

  DOM.setId (wrap "buffer")  (element buffer)
  DOM.setId (wrap "track")   (element track)
  DOM.setId (wrap "overlay") (element overlay)

  DOM.setAttribute "style" (   "width: "  <> show dim.width  <> "px"
                          <> "; height: " <> show dim.height <> "px"
                          <> "; position:relative"
                          <> "; border: 1px solid black; display: block; margin: 0; padding: 0"
                          ) el

  let css i = "position:absolute; z-index: " <> i

  DOM.setAttribute "style" (css "1") (element track)
  DOM.setAttribute "style" (css "2") (element overlay)

  _ <- DOM.appendChild (node track)   (toNode el)
  _ <- DOM.appendChild (node overlay) (toNode el)

  pure { buffer, track, overlay }

main :: Eff _ _
main = launchAff $ do

  {width} <- liftEff $ getScreenSize

  let height = 200.0
      browserDimensions = {width, height}

  bCanvas <- do
    doc <- liftEff $ DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    cont <- liftEff $ DOM.querySelector (wrap "#browser") (toParentNode doc)
    case cont of
      Nothing -> throwError $ error "Could not find browser element"
      Just el -> liftEff $ createBrowserCanvas el browserDimensions

  let browserDragEvent :: Event (Ratio BigInt)
      browserDragEvent = map negate
                         $ browserDrag {width}
                         $ filterMap (_^?_Left) (canvasDrag bCanvas.overlay)

  void $ liftEff $ unsafeCoerceEff $ FRP.subscribe (canvasDrag bCanvas.overlay) $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas bCanvas.buffer bCanvas.track {x: -x, y: 0.0}

  updateBrowser <- liftEff $ Event.create

  let
      begin :: Interval BrowserPoint
      begin = Pair zero (coordSys^._BrowserSize)

      viewEvent :: Event BrowserView
      viewEvent = browserViewEvent coordSys begin
                  $  btnUpdateView { scroll: one % BigInt.fromInt 20
                                   , zoom:   one % BigInt.fromInt 20
                                   , reset: begin
                                   }
                 <|> map ScrollView browserDragEvent
                 <|> const (ModView id) <$> updateBrowser.event
                 <|> scrollZoomEvent bCanvas.overlay

      click = clickEvent bCanvas.overlay
      vClick = map (canvasToView {width}) click
      gClick = globalClick viewEvent vClick
      fClick = map (findBrowserInterval coordSys) gClick

      clickEvs :: Event { view :: BrowserView
                        , canvasClick :: Number
                        , vClick :: Ratio BigInt
                        , gClick :: BrowserPoint
                        , fClick :: Maybe (CoordInterval ChrId BrowserPoint)
                        , cClick :: Maybe (Tuple ChrId Bp) }
      clickEvs = { view: _
                 , canvasClick: _
                 , vClick: _
                 , gClick: _
                 , fClick: _
                 , cClick: _
                 }
                 <$> viewEvent
                 <*> click
                 <*> vClick
                 <*> gClick
                 <*> fClick
                 <*> chrClick coordSys fClick

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sF (Just x) = "Frame: " <> show (unsafeStringify x)
               sF Nothing = "No Frame"
               sChr x = "Chr: " <> unsafeStringify x
               -- sChr (Just x) = "Chr: " <> show chr <> "\t" <> show (unwrap bp)
               -- sChr Nothing = "No Chr"

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> "
" <> "Canvas click:" <> show ev.canvasClick <> "
"
                    <> "
" <> "View click:" <> show ev.vClick <> "
"
                    <> "
" <> "Global click:" <> show (unwrap ev.gClick) <> "
"
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- do
    res <- getDataDemo { gwas: "./gwas.json"
                       , annots: "./annots_fake.json" }
    liftEff $ updateBrowser.push unit
    pure res

  let score = {min: 0.125, max: 0.42, sig: 0.25}

  let ev' = browserDrawEvent coordSys browserDimensions 25.0 score dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 width height

  -- TODO correctly render the layers
  trackCtx <- liftEff $ getContext2D bCanvas.track
  overlayCtx <- liftEff $ getContext2D bCanvas.overlay
  void $ liftEff $ Event.subscribe ev' \d -> do
    Drawing.render trackCtx (bg <> d.track)
    Drawing.render overlayCtx d.overlay

  liftEff $ updateBrowser.push unit

coordSys :: CoordSys ChrId BrowserPoint
coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
            [ Tuple (ChrId "1")   (unsafePartial $ fromJust $ BigInt.fromString "195471971")
            , Tuple (ChrId "2")   (unsafePartial $ fromJust $ BigInt.fromString "182113224")
            , Tuple (ChrId "3")   (unsafePartial $ fromJust $ BigInt.fromString "160039680")
            , Tuple (ChrId "4")   (unsafePartial $ fromJust $ BigInt.fromString "156508116")
            , Tuple (ChrId "5")   (unsafePartial $ fromJust $ BigInt.fromString "151834684")
            , Tuple (ChrId "6")   (unsafePartial $ fromJust $ BigInt.fromString "149736546")
            , Tuple (ChrId "7")   (unsafePartial $ fromJust $ BigInt.fromString "145441459")
            , Tuple (ChrId "8")   (unsafePartial $ fromJust $ BigInt.fromString "129401213")
            , Tuple (ChrId "9")   (unsafePartial $ fromJust $ BigInt.fromString "124595110")
            , Tuple (ChrId "10")  (unsafePartial $ fromJust $ BigInt.fromString "130694993")
            , Tuple (ChrId "11")  (unsafePartial $ fromJust $ BigInt.fromString "122082543")
            , Tuple (ChrId "12")  (unsafePartial $ fromJust $ BigInt.fromString "120129022")
            , Tuple (ChrId "13")  (unsafePartial $ fromJust $ BigInt.fromString "120421639")
            , Tuple (ChrId "14")  (unsafePartial $ fromJust $ BigInt.fromString "124902244")
            , Tuple (ChrId "15")  (unsafePartial $ fromJust $ BigInt.fromString "104043685")
            , Tuple (ChrId "16")  (unsafePartial $ fromJust $ BigInt.fromString "98207768")
            , Tuple (ChrId "17")  (unsafePartial $ fromJust $ BigInt.fromString "94987271")
            , Tuple (ChrId "18")  (unsafePartial $ fromJust $ BigInt.fromString "90702639")
            , Tuple (ChrId "19")  (unsafePartial $ fromJust $ BigInt.fromString "61431566")
            , Tuple (ChrId "X")   (unsafePartial $ fromJust $ BigInt.fromString "17103129")
            , Tuple (ChrId "Y")   (unsafePartial $ fromJust $ BigInt.fromString "9174469")
            ]


Use qualified access to 'State.{modify,get}'

-- |
-- | This module defines commonly used TokenParser-combinators
-- |

module Language.Docopt.SpecParser.Common where

import Prelude
import Control.Monad.Trans (lift)
import Control.MonadPlus (guard)
import Control.Monad.State (State, evalState)
import Control.Monad.State (get, modify) as State
import Data.List (List(..))
import Data.Either (Either(..))
import Language.Docopt.SpecParser.Lexer (TokenParser, PositionedToken(..))
import Language.Docopt.SpecParser.State (ParserState)
import Text.Parsing.Parser (PState(..), ParserT(..)) as P
import Text.Parsing.Parser.Combinators ((<?>), try) as P
import Text.Parsing.Parser.Pos (Position(..)) as P

traceState :: TokenParser String
traceState = do
  (st :: ParserState) <- lift State.get
  pure $ "(" <> (show st.line) <> "|" <> (show st.indentation) <> ")"

-- |
-- Get the position of the token at the head of the stream.
--
getTokenPosition :: TokenParser P.Position
getTokenPosition = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  pure case s of
    Cons (PositionedToken { sourcePos: spos }) _ ->
      { input: s, result: Right spos, consumed: false, position: pos }
    _ ->
      { input: s, result: Right pos, consumed: false, position: pos }

-- |
-- Mark the current indentation level
--
markIndent :: forall a. TokenParser a -> TokenParser a
markIndent p = do
  { indentation: current } <- lift State.get
  P.Position { column: pos } <- getTokenPosition
  P.try do
    lift $ State.modify \st -> ((st { indentation = pos }) :: ParserState)
    a <- p
    lift $ State.modify \st -> ((st { indentation = current }) :: ParserState)
    pure a

-- |
-- Mark the current line
--
markLine :: forall a. TokenParser a -> TokenParser a
markLine p = do
  { line: current } <- lift State.get
  P.Position { line: pos } <- getTokenPosition
  P.try do
    lift $ State.modify \st -> ((st { line = pos }) :: ParserState)
    a <- p
    lift $ State.modify \st -> ((st { line = current }) :: ParserState)
    pure a

-- |
-- Mark a custom indentation level
--
markIndent' :: forall a. Int -> TokenParser a -> TokenParser a
markIndent' level p = do
  { indentation: current } <- lift State.get
  lift $ State.modify \st -> ((st { indentation = level }) :: ParserState)
  a <- p
  lift $ State.modify \st -> ((st { indentation = current }) :: ParserState)
  pure a

-- |
-- Check that the current identation level matches a predicate
--
checkIndentation :: (Int -> Int -> Boolean) -> TokenParser Unit
checkIndentation rel = do
  P.Position { column: col } <- getTokenPosition
  { indentation: current } <- lift State.get
  guard (col `rel` current)

-- |
-- Check that the current indentation level is past the current mark
--
indented :: TokenParser Unit
indented = checkIndentation (>=) P.<?> "indentation"

-- |
-- Check that the current indentation level is before or at the current mark
--
lessOrEquallyIndented :: TokenParser Unit
lessOrEquallyIndented = checkIndentation (<=) P.<?> "less or equal indentation"

-- |
-- Check that the current indentation level is before the current mark
--
moreIndented :: TokenParser Unit
moreIndented = checkIndentation (>) P.<?> "more indentation"

-- |
-- Check that the current indentation level is before the current mark
--
lessIndented :: TokenParser Unit
lessIndented = checkIndentation (<) P.<?> "less indentation"

-- |
-- Check that the current indentation level is at the same indentation as the
-- current mark
--
sameIndent :: TokenParser Unit
sameIndent = checkIndentation (==) P.<?> "same indentation"

-- |
-- Check that the current line matches a predicate
--
checkLine :: (Int -> Int -> Boolean) -> TokenParser Unit
checkLine rel = do
  P.Position { line: line } <- getTokenPosition
  { line: current } <- lift State.get
  guard (line `rel` current)

sameLine :: TokenParser Unit
sameLine = checkLine (==) P.<?> "same line"

successiveLine :: TokenParser Unit
successiveLine = checkLine (>) P.<?> "successive line"

-- |
-- | This module defines commonly used TokenParser-combinators
-- |

module Language.Docopt.SpecParser.Common where

import Prelude
import Control.Monad.Trans (lift)
import Control.MonadPlus (guard)
import Control.Monad.State (get, modify)
import Data.List (List(..))
import Data.Either (Either(..))
import Language.Docopt.SpecParser.Lexer (TokenParser, PositionedToken(..))
import Language.Docopt.SpecParser.State (ParserState)
import Text.Parsing.Parser (PState(..), ParserT(..)) as P
import Text.Parsing.Parser.Combinators ((<?>), try) as P
import Text.Parsing.Parser.Pos (Position(..)) as P

traceState :: TokenParser String
traceState = do
  (st :: ParserState) <- lift get
  pure $ "(" <> (show st.line) <> "|" <> (show st.indentation) <> ")"

-- |
-- Get the position of the token at the head of the stream.
--
getTokenPosition :: TokenParser P.Position
getTokenPosition = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  pure case s of
    Cons (PositionedToken { sourcePos: spos }) _ ->
      { input: s, result: Right spos, consumed: false, position: pos }
    _ ->
      { input: s, result: Right pos, consumed: false, position: pos }

-- |
-- Mark the current indentation level
--
markIndent :: forall a. TokenParser a -> TokenParser a
markIndent p = do
  { indentation: current } <- lift get
  P.Position { column: pos } <- getTokenPosition
  P.try do
    lift $ modify \st -> ((st { indentation = pos }) :: ParserState)
    a <- p
    lift $ modify \st -> ((st { indentation = current }) :: ParserState)
    pure a

-- |
-- Mark the current line
--
markLine :: forall a. TokenParser a -> TokenParser a
markLine p = do
  { line: current } <- lift get
  P.Position { line: pos } <- getTokenPosition
  P.try do
    lift $ modify \st -> ((st { line = pos }) :: ParserState)
    a <- p
    lift $ modify \st -> ((st { line = current }) :: ParserState)
    pure a

-- |
-- Mark a custom indentation level
--
markIndent' :: forall a. Int -> TokenParser a -> TokenParser a
markIndent' level p = do
  { indentation: current } <- lift get
  lift $ modify \st -> ((st { indentation = level }) :: ParserState)
  a <- p
  lift $ modify \st -> ((st { indentation = current }) :: ParserState)
  pure a

-- |
-- Check that the current identation level matches a predicate
--
checkIndentation :: (Int -> Int -> Boolean) -> TokenParser Unit
checkIndentation rel = do
  P.Position { column: col } <- getTokenPosition
  { indentation: current } <- lift get
  guard (col `rel` current)

-- |
-- Check that the current indentation level is past the current mark
--
indented :: TokenParser Unit
indented = checkIndentation (>=) P.<?> "indentation"

-- |
-- Check that the current indentation level is before or at the current mark
--
lessOrEquallyIndented :: TokenParser Unit
lessOrEquallyIndented = checkIndentation (<=) P.<?> "less or equal indentation"

-- |
-- Check that the current indentation level is before the current mark
--
moreIndented :: TokenParser Unit
moreIndented = checkIndentation (>) P.<?> "more indentation"

-- |
-- Check that the current indentation level is before the current mark
--
lessIndented :: TokenParser Unit
lessIndented = checkIndentation (<) P.<?> "less indentation"

-- |
-- Check that the current indentation level is at the same indentation as the
-- current mark
--
sameIndent :: TokenParser Unit
sameIndent = checkIndentation (==) P.<?> "same indentation"

-- |
-- Check that the current line matches a predicate
--
checkLine :: (Int -> Int -> Boolean) -> TokenParser Unit
checkLine rel = do
  P.Position { line: line } <- getTokenPosition
  { line: current } <- lift get
  guard (line `rel` current)

sameLine :: TokenParser Unit
sameLine = checkLine (==) P.<?> "same line"

successiveLine :: TokenParser Unit
successiveLine = checkLine (>) P.<?> "successive line"