Track based on Map from ChrId to data

Track based on Map from ChrId to data

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
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.Reader (Reader, ReaderT(..), ask, runReader, runReaderT)
import Control.MonadPlus (guard)
import Data.Array ((:))
import Data.Array as Array
import Data.Distributive (distribute)
import Data.Either (Either, Either(..))
import Data.Foldable (fold, foldMap, for_, length, sum)
import Data.List (List, mapMaybe)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap)
import Data.NonEmpty (foldl1, fromNonEmpty)
import Data.NonEmpty as NE
import Data.Record as Record
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, Pos, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat, readInt)
import Global.Unsafe (unsafeStringify)
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)
import Text.Parsing.CSV as CSV
import Text.Parsing.Parser as CSV
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

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

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
-- TODO this should be more closely connected to Frames
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

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

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

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

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

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

-- Renderers always run on collections (for now Arrays) of objects,
-- since it's rare to only want to render one single thing.
-- if that is desired, one can simply pass along a singleton array.
runRenderer :: forall a.
               Renderer _ a
            -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
            -> Array a
            -> Context2D
            -> Eff _ Unit
runRenderer r {xInfo, yInfo} as ctx =
  for_ as (\a -> C.withContext ctx do
              let translateX = r.hPos a xInfo
                  translateY = r.vPos a yInfo
              _ <- C.translate {translateX, translateY} ctx
              r.render a ctx)

-- A Frame contains the information required to, in conjunction with a Renderer on `a`,
-- render the contained data to a given place on the canvas.

-- not going to be entirely trivial to construct this -- need to take the
-- total size, padding, etc. into account. not just a map; we need a fold, too.
-- ... a hylomorphism?

-- The actual size the contents have to be rendered to is equal to width - (2.0 * padding).
-- When rendered, individual frames are always immediately adjacent to one another
-- Likewise, the sum of `width`s in a Frames' is always equal to the total width the
-- Frames' can be drawn to.
type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type Frames' r a = ChrCtx (frame :: Frame a | r)

chrIdsEq :: forall a b.
            Map ChrId a
         -> Map ChrId b
         -> Boolean
chrIdsEq a b = (Map.keys a) == (Map.keys b)

chrIdsSub :: forall a b.
             Map ChrId a
          -> Map ChrId b
          -> Boolean
chrIdsSub a b = setA `Map.isSubmap` setB
  where setA = map (const unit) a
        setB = map (const unit) b

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

mkFrame :: forall r a.
            RowLacks "frame" (size :: Bp | r)
         => Pixels
         -> (Bp -> Pixels)
         -> {size :: Bp | r}
         -> a
         -> {size :: Bp, frame :: Frame a | r}
mkFrame padding getWidth chr a = chr'
  where chr' :: {size :: Bp, frame :: Frame a | r}
        chr' = insertFrame frame chr
        frame :: Frame a
        frame = { padding, width: getWidth chr.size, contents: a }

zipChrs :: forall a b c.
           Map ChrId a
        -> Map ChrId b
        -> Maybe ((a -> b -> c) -> Map ChrId c)
zipChrs a b =
  if chrIdsEq a b
     then let (Tuple chrs a') = Array.unzip $ Map.toAscUnfoldable a
              b' = snd <$> Map.toAscUnfoldable b
          in pure $ \f -> Map.fromFoldable $ Array.zip chrs $ Array.zipWith f a' b'
     else Nothing

frames :: forall r a.
          RowLacks "frame" (size :: Bp | r)
       => Pixels
       -> Pixels
       -> Map ChrId a
       -> ReaderT (ChrCtx (size :: Bp | r))
            (Either String) (ChrCtx (size :: Bp, frame :: Frame a | r))
frames totalWidth padding chrs = do
  chrCtx <- ask
  let tot :: Bp
      tot = totalSize chrCtx
      width :: Bp -> Pixels
      width bp = unwrap $ bp / tot
      mkF :: {size :: Bp | r} -> a -> {size :: Bp, frame :: Frame a | r }
      mkF = mkFrame padding width

  case zipChrs chrCtx chrs of
    Nothing ->
      throwError $ "ChrIds mismatch when creating frames"
    Just zp -> pure $ zp mkF

chrSubrange :: forall a r.
               Range r
            -> Map ChrId a
            -> Map ChrId a
chrSubrange {lHand, rHand} = Map.submap (Just lHand.chrId) (Just rHand.chrId)

renderFrame :: forall r a.
               YPosInfo
            -> {size :: Bp, frame :: Frame (Array a) | r}
            -> Renderer _ a
            -> Context2D
            -> Eff _ Unit
renderFrame yInfo {size, frame} r ctx = foreachE frame.contents render
  where render a = C.withContext ctx do
              let xInfo = { size, scale: BpPerPixel ((unwrap size) / frame.width) }
                  translateX = r.hPos a xInfo
                  translateY = r.vPos a yInfo
              _ <- C.translate {translateX, translateY} ctx
              r.render a ctx

renderFrames :: forall r a.
                YPosInfo
             -> ChrCtx (size :: Bp, frame :: Frame (Array a) | r)
             -> Renderer _ a
             -> {lHand :: Pos, rHand :: Pos}
             -> Context2D
             -> Eff _ Unit
renderFrames yInfo fs r ran ctx = do
  let frames' :: Array _
      frames' = map snd <$> Map.toAscUnfoldable $ chrSubrange ran fs

  C.withContext ctx do
    for_ frames' (\f -> renderFrame yInfo f r ctx)

-- 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
-}

fetchGemma :: String
           -> Aff _ (List { chr :: ChrId, pos :: Bp, score :: Number })
fetchGemma url = do
  liftEff $ log "fetching gwas"
  csv <- _.response <$> Affjax.get url
  let parsed :: _
      parsed = CSV.runParser csv CSV.defaultParsers.fileHeaded
      parseEntry :: Map String String -> Maybe _
      parseEntry m = do
        chr <- ChrId <$> Map.lookup "chr" m
        pos <- Bp <<< readFloat <$> Map.lookup "ps" m
        score <- readFloat <$> Map.lookup "af" m
        pure { chr, pos, score }

  case parsed of
    Left err -> throwError $ error "error parsing csv"
    Right p  -> pure $ mapMaybe parseEntry p

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs

testRender :: forall a.
              Renderer _ a
           -> Map ChrId (Array a)
           -> Aff _ Unit
testRender r chrs = 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}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      fs :: _
      fs = runReaderT (frames w 20.0 chrs) mouseChrCtx

      lHand = { chrId: ChrId "3", bp: Bp 0.0 }
      rHand = { chrId: ChrId "9", bp: Bp 0.0 }
      ran :: Range ()
      ran = { lHand, rHand }

  liftEff $ log "chrs"
  liftEff $ log $ show $ Map.keys chrs
  liftEff $ log "mouseChrCtx"
  liftEff $ log $ show $ Map.keys mouseChrCtx
  liftEff $ log $ show $ chrIdsEq chrs mouseChrCtx

  case fs of
    Left err -> liftEff $ log err
    Right fs' -> liftEff $ renderFrames yInfo fs' r ran ctx

main = launchAff $ do
  let min = 0.1
      max = 0.4

      colors = fold $ Array.replicate 5 ["green", "yellow", "orange", "red", "purple", "blue"]
      chrColors :: _
      chrColors = Map.fromFoldable $ Array.zip mouseChrIds colors

      chrColor :: ChrId -> String
      chrColor chr = fromMaybe "black" (Map.lookup chr chrColors)

      render' :: Renderer _ _
      render' = gwasRenderer {min, max} chrColor

  dat <- Array.fromFoldable <$> fetchGemma "./gwas.csv"
  -- dat <- Array.fromFoldable <$> fetchGemma "./gwas_head.csv"

  let chrs :: _
      chrs = (\a -> let chrId = _.chr $ NE.head a
                    in Tuple chrId a) <$> Array.groupBy (\a b -> a.chr == b.chr) dat
      chrs' = Map.fromFoldable $ map (fromNonEmpty (:)) <$> chrs

  testRender render' chrs'

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 (foldl, (!!), (..), (:))
import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (fold, foldMap, for_, length)
import Data.Int as Int
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.List (List, mapMaybe)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe, Maybe(..), fromJust, fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap, wrap)
import Data.NonEmpty (foldl1, fromNonEmpty)
import Data.NonEmpty as NE
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat, readInt)
import Global.Unsafe (unsafeStringify)
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)
import Text.Parsing.CSV as CSV
import Text.Parsing.Parser as CSV

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

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
-- TODO this should be more closely connected to Frames
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

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

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

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

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

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

-- Renderers always run on collections (for now Arrays) of objects,
-- since it's rare to only want to render one single thing.
-- if that is desired, one can simply pass along a singleton array.
runRenderer :: forall a.
               Renderer _ a
            -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
            -> Array a
            -> Context2D
            -> Eff _ Unit
runRenderer r {xInfo, yInfo} as ctx =
  for_ as (\a -> C.withContext ctx do
              let translateX = r.hPos a xInfo
                  translateY = r.vPos a yInfo
              _ <- C.translate {translateX, translateY} ctx
              r.render a ctx)

-- A Frame contains the information required to, in conjunction with a Renderer on `a`,
-- render the contained data to a given place on the canvas.

-- not going to be entirely trivial to construct this -- need to take the
-- total size, padding, etc. into account. not just a map; we need a fold, too.
-- ... a hylomorphism?

-- The actual size the contents have to be rendered to is equal to width - (2.0 * padding).
-- When rendered, individual frames are always immediately adjacent to one another
-- Likewise, the sum of `width`s in a Frames' is always equal to the total width the
-- Frames' can be drawn to.
type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

type Frames' r a = ChrCtx (frame :: Frame a | r)

chrIdsEq :: forall a b.
            Map ChrId a
         -> Map ChrId b
         -> Boolean
chrIdsEq a b = (Map.keys a) == (Map.keys b)

chrIdsSub :: forall a b.
             Map ChrId a
          -> Map ChrId b
          -> Boolean
chrIdsSub a b = setA `Map.isSubmap` setB
  where setA = map (const unit) a
        setB = map (const unit) b

totalSize :: forall r.
             ChrCtx (size :: Bp | r)
          -> Bp
totalSize chrCtx = alaF Additive foldMap _.size chrCtx

insertFrame :: forall r a.
               RowLacks "frame" r
            => a
            -> { | r }
            -> { frame :: a | r }
insertFrame = Record.insert (SProxy :: SProxy "frame")

mkFrame :: forall r a.
            RowLacks "frame" (size :: Bp | r)
         => Pixels
         -> (Bp -> Pixels)
         -> {size :: Bp | r}
         -> a
         -> {size :: Bp, frame :: Frame a | r}
mkFrame padding getWidth chr a = chr'
  where chr' :: {size :: Bp, frame :: Frame a | r}
        chr' = insertFrame frame chr
        frame :: Frame a
        frame = { padding, width: getWidth chr.size, contents: a }

zipChrs :: forall a b c.
           Map ChrId a
        -> Map ChrId b
        -> Maybe ((a -> b -> c) -> Map ChrId c)
zipChrs a b =
  if chrIdsEq a b
     then let (Tuple chrs a') = Array.unzip $ Map.toAscUnfoldable a
              b' = snd <$> Map.toAscUnfoldable b
          in pure $ \f -> Map.fromFoldable $ Array.zip chrs $ Array.zipWith f a' b'
     else Nothing

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

-- 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
-}

fetchGemma :: String
           -> Aff _ (List { chr :: ChrId, pos :: Bp, score :: Number })
fetchGemma url = do
  liftEff $ log "fetching gwas"
  csv <- _.response <$> Affjax.get url
  let parsed :: _
      parsed = CSV.runParser csv CSV.defaultParsers.fileHeaded
      parseEntry :: Map String String -> Maybe _
      parseEntry m = do
        chr <- ChrId <$> Map.lookup "chr" m
        pos <- Bp <<< readFloat <$> Map.lookup "ps" m
        score <- readFloat <$> Map.lookup "af" m
        pure { chr, pos, score }

  case parsed of
    Left err -> throwError $ error "error parsing csv"
    Right p  -> pure $ mapMaybe parseEntry p

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

mouseChrCtx :: ChrCtx (size :: Bp)
mouseChrCtx = map (\size -> { size }) mouseChrs

mouseChrSize :: Bp -> ChrId -> Bp
mouseChrSize def chr = fromMaybe def $ Map.lookup chr mouseChrs

testRender :: forall a.
              Renderer _ a
           -> Map ChrId (Array a)
           -> Aff _ Unit
testRender r chrs = 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}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      fs :: Frames (Array a)
      fs = frames w 20.0 chrs

  liftEff $ renderFrames yInfo fs r ctx

main = launchAff $ do
  let min = 0.1
      max = 0.4

      colors = fold $ Array.replicate 5 ["green", "yellow", "orange", "red", "purple", "blue"]
      chrColors :: _
      chrColors = Map.fromFoldable $ Array.zip mouseChrIds colors

      chrColor :: ChrId -> String
      chrColor chr = fromMaybe "black" (Map.lookup chr chrColors)

      render' :: Renderer _ _
      render' = gwasRenderer {min, max} chrColor

      chrSize :: _ -> Bp
      chrSize x = mouseChrSize (Bp 0.0) x.chr

  dat <- Array.fromFoldable <$> fetchGemma "./gwas.csv"

  let chrs :: _
      chrs = (\a -> let bp = chrSize $ NE.head a
                    in Tuple bp a) <$> Array.groupBy (\a b -> a.chr == b.chr) dat
      chrs' = map (fromNonEmpty (:)) <$> chrs

  liftEff $ log $ show $ (length chrs' :: Int)

  testRender render' chrs'


add runSpec' (#101)

add runSpec' (#101)

* add runSpec'

* export runSpec'

module Test.Spec.Runner
  ( run
  , runSpecT
  , runSpec
  , runSpec'
  , defaultConfig
  , Config
  , TestEvents
  , Reporter
  ) where

import Prelude

import Control.Alternative ((<|>))
import Control.Monad.Trans.Class (lift)
import Control.Parallel (parTraverse, parallel, sequential)
import Data.Array (groupBy, mapWithIndex)
import Data.Array.NonEmpty as NEA
import Data.DateTime.Instant (unInstant)
import Data.Either (Either(..), either)
import Data.Foldable (foldl)
import Data.Function (on)
import Data.Identity (Identity(..))
import Data.Int as Int
import Data.Maybe (Maybe(..))
import Data.Newtype (un)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (class Traversable, for)
import Effect (Effect)
import Effect.Aff (Aff, attempt, delay, forkAff, joinFiber, makeAff, throwError, try)
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Exception (error)
import Effect.Now (now)
import Pipes ((>->), yield)
import Pipes.Core (Pipe, Producer, (//>))
import Pipes.Core (runEffectRec) as P
import Prim.TypeError (class Warn, Text)
import Test.Spec (Item(..), Spec, SpecT, SpecTree, Tree(..), collect)
import Test.Spec.Console as Console
import Test.Spec.Result (Result(..))
import Test.Spec.Runner.Event (Event, Execution(..))
import Test.Spec.Runner.Event as Event
import Test.Spec.Speed (speedOf)
import Test.Spec.Style (styled)
import Test.Spec.Style as Style
import Test.Spec.Summary (successful)
import Test.Spec.Tree (Path, PathItem(..), countTests, isAllParallelizable)

foreign import exit :: Int -> Effect Unit

type Config =
  { slow :: Milliseconds
  , timeout :: Maybe Milliseconds
  , exit :: Boolean
  }

defaultConfig :: Config
defaultConfig =
  { slow: Milliseconds 75.0
  , timeout: Just $ Milliseconds 2000.0
  , exit: true
  }

makeTimeout
  :: Milliseconds
  -> Aff Unit
makeTimeout ms@(Milliseconds ms') = do
  delay ms
  makeAff \cb -> mempty <$ do
    cb <<< Left $ error $ "test timed out after " <> show (Int.round ms') <> "ms"

timeout
  :: Milliseconds
  -> Aff Unit
  -> Aff Unit
timeout time t = do
  sequential (parallel (try (makeTimeout time)) <|> parallel (try t))
    >>= either throwError pure

type TestWithPath r = {test :: SpecTree Aff Unit, path :: Path | r}

-- Run the given spec as `Producer` in the underlying `Aff` monad.
-- This producer has two responsibilities:
--      1) emit events for key moments in the runner's lifecycle
--      2) collect the tst output into an array of results
-- This allows downstream consumers to report about the tests even before the
-- prodocer has completed and still benefit from the array of results the way
-- the runner sees it.
_run
  :: forall m
   . Functor m
  => Config
  -> SpecT Aff Unit m Unit
  -> m TestEvents
_run config = collect >>> map \tests -> do
  yield (Event.Start (countTests tests))
  let indexer index test = {test, path: [PathItem {name: Nothing, index}]}
  r <- loop $ mapWithIndex indexer tests
  yield (Event.End r)
  pure r
  where
    loop :: Array (TestWithPath ()) -> TestEvents
    loop tests =
      let
        noteWithIsAllParallelizable = map \{test,path} -> { isParallelizable: isAllParallelizable test, test, path}
        groupByIsParallelizable = groupBy (\a b -> a.isParallelizable && b.isParallelizable)
      in join <$> for (groupByIsParallelizable $ noteWithIsAllParallelizable tests) \g ->
        join <$> if (NEA.head g).isParallelizable
          then mergeProducers (runGroup <$> (NEA.toArray g))
          else for (NEA.toArray g) runGroup

    runGroup :: TestWithPath (isParallelizable :: Boolean) -> TestEvents
    runGroup {test, path, isParallelizable} = case test of
      (Leaf name (Just (Item item))) -> do
        yield $ Event.Test (if isParallelizable then Parallel else Sequential) path name
        let example = item.example \a -> a unit
        start <- lift $ liftEffect now
        e <- lift $ attempt case config.timeout of
          Just t -> timeout t example
          _      -> example
        end <- liftEffect now
        let duration = Milliseconds $ on (-) (unInstant >>> un Milliseconds) end start
        let res = either Failure (const $ Success (speedOf config.slow duration) duration) e
        yield $ Event.TestEnd path name res
        pure [ Leaf name $ Just res ]
      (Leaf name Nothing) -> do
        yield $ Event.Pending path name
        pure [ Leaf name Nothing ]
      (Node (Right cleanup) xs) -> do
        let indexer index x = {test:x, path: path <> [PathItem {name: Nothing, index}]}
        loop (mapWithIndex indexer xs) <* lift (cleanup unit)
      (Node (Left name) xs) -> do
        yield $ Event.Suite (if isParallelizable then Parallel else Sequential) path name
        let indexer index x = {test:x, path: path <> [PathItem {name: Just name, index}]}
        res <- loop (mapWithIndex indexer xs)
        yield $ Event.SuiteEnd path
        pure [ Node (Left name) res ]

-- https://github.com/felixSchl/purescript-pipes/issues/16
mergeProducers :: forall t o a. Traversable t => t (Producer o Aff a) -> Producer o Aff (t a)
mergeProducers ps = do
  var <- lift AV.empty

  fib <- lift $ forkAff do
    let consumer i = lift (AV.put i var) *> pure unit
    x <- parTraverse (\p -> P.runEffectRec $ p //> consumer) ps
    AV.kill (error "finished") var
    pure x

  let
    loop = do
      res <- lift $ try (AV.take var)
      case res of
        Left err -> lift $ joinFiber fib
        Right e -> do
          yield e
          loop
  loop

type TestEvents = Producer Event Aff (Array (Tree Void Result))

type Reporter = Pipe Event Event Aff (Array (Tree Void Result))

-- | Run the spec with `config`, returning the results, which
-- | are also reported using specified Reporters, if any.
-- | If configured as such, `exit` the program upon completion
-- | with appropriate exit code.
runSpecT
  :: forall m
   . Functor m
  => Config
  -> Array Reporter
  -> SpecT Aff Unit m Unit
  -> m (Aff (Array (Tree Void Result)))
runSpecT config reporters spec = _run config spec <#> \runner -> do
  let
    drain = const (pure unit)
    events = foldl (>->) runner reporters
    reportedEvents = P.runEffectRec $ events //> drain
  if config.exit
    then try reportedEvents >>= case _ of
      Left err -> do
        liftEffect $ Console.write $ styled Style.red (show err <> "\n")
        liftEffect $ exit 1
        throwError err
      Right results -> liftEffect do
        let code = if successful results then 0 else 1
        exit code
        pure results
    else reportedEvents

-- | Run the spec with the default config
run
  :: Warn (Text "`Test.Spec.Runner.run` is Deprecated use runSpec instead")
  => Array Reporter
  -> Spec Unit
  -> Aff Unit
run = runSpec' defaultConfig

-- | Run the spec with the default config
runSpec
  :: Array Reporter
  -> Spec Unit
  -> Aff Unit
runSpec = runSpec' defaultConfig

runSpec'
  :: Config
  -> Array Reporter
  -> Spec Unit
  -> Aff Unit
runSpec' config reporters spec = void $ un Identity $ runSpecT config reporters spec

module Test.Spec.Runner
  ( run
  , runSpecT
  , runSpec
  , defaultConfig
  , Config
  , TestEvents
  , Reporter
  ) where

import Prelude

import Control.Alternative ((<|>))
import Control.Monad.Trans.Class (lift)
import Control.Parallel (parTraverse, parallel, sequential)
import Data.Array (groupBy, mapWithIndex)
import Data.Array.NonEmpty as NEA
import Data.DateTime.Instant (unInstant)
import Data.Either (Either(..), either)
import Data.Foldable (foldl)
import Data.Function (on)
import Data.Identity (Identity(..))
import Data.Int as Int
import Data.Maybe (Maybe(..))
import Data.Newtype (un)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (class Traversable, for)
import Effect (Effect)
import Effect.Aff (Aff, attempt, delay, forkAff, joinFiber, makeAff, throwError, try)
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Exception (error)
import Effect.Now (now)
import Pipes ((>->), yield)
import Pipes.Core (Pipe, Producer, (//>))
import Pipes.Core (runEffectRec) as P
import Prim.TypeError (class Warn, Text)
import Test.Spec (Item(..), Spec, SpecT, SpecTree, Tree(..), collect)
import Test.Spec.Console as Console
import Test.Spec.Result (Result(..))
import Test.Spec.Runner.Event (Event, Execution(..))
import Test.Spec.Runner.Event as Event
import Test.Spec.Speed (speedOf)
import Test.Spec.Style (styled)
import Test.Spec.Style as Style
import Test.Spec.Summary (successful)
import Test.Spec.Tree (Path, PathItem(..), countTests, isAllParallelizable)

foreign import exit :: Int -> Effect Unit

type Config =
  { slow :: Milliseconds
  , timeout :: Maybe Milliseconds
  , exit :: Boolean
  }

defaultConfig :: Config
defaultConfig =
  { slow: Milliseconds 75.0
  , timeout: Just $ Milliseconds 2000.0
  , exit: true
  }

makeTimeout
  :: Milliseconds
  -> Aff Unit
makeTimeout ms@(Milliseconds ms') = do
  delay ms
  makeAff \cb -> mempty <$ do
    cb <<< Left $ error $ "test timed out after " <> show (Int.round ms') <> "ms"

timeout
  :: Milliseconds
  -> Aff Unit
  -> Aff Unit
timeout time t = do
  sequential (parallel (try (makeTimeout time)) <|> parallel (try t))
    >>= either throwError pure

type TestWithPath r = {test :: SpecTree Aff Unit, path :: Path | r}

-- Run the given spec as `Producer` in the underlying `Aff` monad.
-- This producer has two responsibilities:
--      1) emit events for key moments in the runner's lifecycle
--      2) collect the tst output into an array of results
-- This allows downstream consumers to report about the tests even before the
-- prodocer has completed and still benefit from the array of results the way
-- the runner sees it.
_run
  :: forall m
   . Functor m
  => Config
  -> SpecT Aff Unit m Unit
  -> m TestEvents
_run config = collect >>> map \tests -> do
  yield (Event.Start (countTests tests))
  let indexer index test = {test, path: [PathItem {name: Nothing, index}]}
  r <- loop $ mapWithIndex indexer tests
  yield (Event.End r)
  pure r
  where
    loop :: Array (TestWithPath ()) -> TestEvents
    loop tests =
      let
        noteWithIsAllParallelizable = map \{test,path} -> { isParallelizable: isAllParallelizable test, test, path}
        groupByIsParallelizable = groupBy (\a b -> a.isParallelizable && b.isParallelizable)
      in join <$> for (groupByIsParallelizable $ noteWithIsAllParallelizable tests) \g ->
        join <$> if (NEA.head g).isParallelizable
          then mergeProducers (runGroup <$> (NEA.toArray g))
          else for (NEA.toArray g) runGroup

    runGroup :: TestWithPath (isParallelizable :: Boolean) -> TestEvents
    runGroup {test, path, isParallelizable} = case test of
      (Leaf name (Just (Item item))) -> do
        yield $ Event.Test (if isParallelizable then Parallel else Sequential) path name
        let example = item.example \a -> a unit
        start <- lift $ liftEffect now
        e <- lift $ attempt case config.timeout of
          Just t -> timeout t example
          _      -> example
        end <- liftEffect now
        let duration = Milliseconds $ on (-) (unInstant >>> un Milliseconds) end start
        let res = either Failure (const $ Success (speedOf config.slow duration) duration) e
        yield $ Event.TestEnd path name res
        pure [ Leaf name $ Just res ]
      (Leaf name Nothing) -> do
        yield $ Event.Pending path name
        pure [ Leaf name Nothing ]
      (Node (Right cleanup) xs) -> do
        let indexer index x = {test:x, path: path <> [PathItem {name: Nothing, index}]}
        loop (mapWithIndex indexer xs) <* lift (cleanup unit)
      (Node (Left name) xs) -> do
        yield $ Event.Suite (if isParallelizable then Parallel else Sequential) path name
        let indexer index x = {test:x, path: path <> [PathItem {name: Just name, index}]}
        res <- loop (mapWithIndex indexer xs)
        yield $ Event.SuiteEnd path
        pure [ Node (Left name) res ]

-- https://github.com/felixSchl/purescript-pipes/issues/16
mergeProducers :: forall t o a. Traversable t => t (Producer o Aff a) -> Producer o Aff (t a)
mergeProducers ps = do
  var <- lift AV.empty

  fib <- lift $ forkAff do
    let consumer i = lift (AV.put i var) *> pure unit
    x <- parTraverse (\p -> P.runEffectRec $ p //> consumer) ps
    AV.kill (error "finished") var
    pure x

  let
    loop = do
      res <- lift $ try (AV.take var)
      case res of
        Left err -> lift $ joinFiber fib
        Right e -> do
          yield e
          loop
  loop

type TestEvents = Producer Event Aff (Array (Tree Void Result))

type Reporter = Pipe Event Event Aff (Array (Tree Void Result))

-- | Run the spec with `config`, returning the results, which
-- | are also reported using specified Reporters, if any.
-- | If configured as such, `exit` the program upon completion
-- | with appropriate exit code.
runSpecT
  :: forall m
   . Functor m
  => Config
  -> Array Reporter
  -> SpecT Aff Unit m Unit
  -> m (Aff (Array (Tree Void Result)))
runSpecT config reporters spec = _run config spec <#> \runner -> do
  let
    drain = const (pure unit)
    events = foldl (>->) runner reporters
    reportedEvents = P.runEffectRec $ events //> drain
  if config.exit
    then try reportedEvents >>= case _ of
      Left err -> do
        liftEffect $ Console.write $ styled Style.red (show err <> "\n")
        liftEffect $ exit 1
        throwError err
      Right results -> liftEffect do
        let code = if successful results then 0 else 1
        exit code
        pure results
    else reportedEvents

-- | Run the spec with the default config
run
  :: Warn (Text "`Test.Spec.Runner.run` is Deprecated use runSpec instead")
  => Array Reporter
  -> Spec Unit
  -> Aff Unit
run reporters spec = void $ un Identity $ runSpecT defaultConfig reporters spec

-- | Run the spec with the default config
runSpec
  :: Array Reporter
  -> Spec Unit
  -> Aff Unit
runSpec reporters spec = void $ un Identity $ runSpecT defaultConfig reporters spec


Fix shadowed variable names warnings

Fix shadowed variable names warnings

module App.View where

import Text.Smolder.HTML hiding (address)

import App.Routing (Location(..))
import App.State (Event(..), State, signerLens)
import App.State.Contracts as Contracts
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Locations as Locations
import App.State.Signers as Signers
import Data.Array (fromFoldable, mapWithIndex)
import Data.Either (Either(..))
import Data.Lens ((^.))
import Data.Map (toUnfoldable, values)
import Data.Maybe (Maybe(..), fromJust, isJust, maybe)
import Data.String (drop, length, take, toLower)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.Eth.Contracts (class EthContract, ContractLoadingError(..), getAddress)
import Lib.Eth.Web3 (TxHash(..), TxStatus(..))
import Lib.SignHash.Proofs.Display (SignerDisplayStatus(..), signerDisplayStatus)
import Lib.SignHash.Proofs.Methods (ProofMethod(..), canonicalName)
import Lib.SignHash.Proofs.Types (ProofState(..), ProofVerification(..))
import Lib.SignHash.Proofs.Values as ProofValues
import Lib.SignHash.Types (Address(..), HashSigner(..))
import Partial.Unsafe (unsafePartial)
import Prelude (discard, mod, not, show, ($), (-), (<<<), (<>), (==))
import Pux.DOM.Events (DOMEvent, onChange, onClick, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, src, type')
import Text.Smolder.HTML.Attributes as A
import Text.Smolder.Markup (Attribute, EventHandlers, attribute, text, (!), (#!))

foreign import images ::
  { logo :: String
  , ethIcon :: String }

dataQA :: String -> Attribute
dataQA = attribute "data-qa"

view :: State -> HTML Event
view state =
  do
    div ! className "Content" $ do
      div ! className "Header" $ do
        img ! src images.logo
        span ! className "title" $ text "SignHash"

      nav ! className "Navbar" $ do
        ul do
          li $ a ! A.href "#" $ text "Account"
          li $ a ! A.href "#" #! onClick (navigate Sign) $ text "Sign"
          li $ a ! A.href "#" #! onClick (navigate Verify) $ text "Verify"

      viewContent state

      hr
      div ! className "Contracts-info" $ do
        viewContracts state.contracts
      clear

viewContent :: State -> HTML Event
viewContent state@{ contracts: Contracts.Error error } = do
  renderSectionWarning do
    case error of
      NotDeployedToNetwork networkId ->
        sectionStatus (renderIcon "fa-repeat") do
          text "Please switch to Main Ethereum network"
viewContent state@{ location: Verify } = do
  withFileDetails state.file $ \file -> do
    viewFileSigners state file
viewContent state@{ location: Sign } = do
  withFileDetails state.file $ \file -> do
    sectionHeader "Signing address"
    guardAccountUnlocked state.myAccount $
      viewSigningDetails state file

withFileDetails ::
  Maybe Files.State
  -> (Files.State -> HTML Event)
  -> HTML Event
withFileDetails fileState viewDetails = do
  viewFileInput (isJust fileState)
  case fileState of
    Nothing -> empty
    Just file -> do
      viewFile file
      viewDetails file

viewFileSigners :: State -> Files.State -> HTML Event
viewFileSigners state file = do
  div $ signerStatus file.signer
  where
    signerStatus = case _ of
      Nothing -> sectionHeader "Loading signer..."
      Just NoSigner -> do
        renderSectionWarning do
          sectionStatus (renderIcon "fa-times") do
            text "This file has not been signed."
          a
            ! A.className "Button"
            #! onClick (navigate Sign)
            $ text "Sign it"

      Just (HashSigner address) -> do
        let selfSigned = case state.myAccount of
              Contracts.Available myAccount -> myAccount == address
              _ -> false
        sectionHeader "Signers"
        renderSection do
          if selfSigned then
            sectionStatus (renderIcon "fa-check-circle-o") do
            text "You have signed this file."
            else empty

          case state ^. signerLens address of
            Nothing -> div do
              text loading
              hr
            Just value -> do
              renderList
                [ child (Signer address) viewSigner $ value
                , child (Signer address) viewSigner $ value
                , child (Signer address) viewSigner $ value
                ]
        if not selfSigned then
          a
            ! A.className "Button block"
            #! onClick (navigate Sign)
            $ text "Add your signature"
          else empty

viewSigningDetails :: State -> Files.State -> Address -> HTML Event
viewSigningDetails state file address = do
  div ! dataQA "my-id" $ do
    let myDetails = expectResult $ state ^. signerLens address
    renderSectionHighlighted do
      child (Signer address) viewSigner $ myDetails
    case file.result of
      Nothing -> empty
      Just fileDetails ->
        case state.signingTx of
          Nothing ->
            a
              ! A.href "#"
              ! dataQA "sign"
              ! A.className "Button block"
              #! onClickAction (SignFile fileDetails.hash)
              $ do
                text "Sign it"
                renderLinkIcon "fa-paper-plane-o"
          Just (Left err) ->
            div
              ! A.className "Button block disabled"
              $ text "Error while issuing transaction"

          Just (Right hash) -> do
            let txStatus = Contracts.viewTxResult hash state.contracts
            div
              ! A.className "Button block disabled"
              $ txLink hash txStatus

viewContracts :: Contracts.State -> HTML Event
viewContracts Contracts.Loading =
  text $ "Loading contract..."
viewContracts (Contracts.Loaded state) = do
  contractLink "SignHash" state.signHash
  br
  contractLink "SignProof" state.signProof
  where
    contractLink :: forall c. EthContract c => String -> c -> HTML Event
    contractLink name contract = do
      span $ text $ name <> ": "
      (addressLink $ getAddress contract)
        ! dataQA ((toLower name) <> "-address")

viewContracts (Contracts.Error err) = do
  let msg = case err of
        NotDeployedToNetwork id ->
          "Contracts have not been deployed to selected network"
  div $ text msg

viewFileInput :: Boolean -> HTML Event
viewFileInput small =
  div do
    label
      ! for "file-upload"
      ! className ("File-upload" <> if small then " small" else "")
      #! onDrop handleNewFiles
      #! onDragOver ignoreEvent
      $ do
        renderIcon "fa-file-o"
        text (if small then "Upload another file" else "Upload file")
        if small then empty else
          div ! className "hint"
          $ text "Click or drag and drop on the page"
    input
      ! id "file-upload"
      ! type' "file"
      #! onChange handleNewFiles
  where
    handleNewFiles ev =
      preventingDefault (FileInput $ FileInputs.newFilesEvent ev) ev

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } = do
  div ! className "Files Section" $ do
    div ! className "row" $ do
      renderRow "Filename" $ text $ meta.name
      renderRow "SHA256" $ maybe (text loading) renderHash result
      renderRow "Size" $ renderSize meta.size

  where
    renderRow label value =
      div ! className "columns attribute four" $ do
        span ! className "header" $ text (label <> ":")
        span ! className "value" $ value

    renderSigner (HashSigner address) = show address
    renderSigner NoSigner = "Not signed"

    renderHash { hash } =
      let visibleOffset = 6
      in a
         ! dataQA "checksum"
         ! A.title hash
         ! A.href "#"
         $ text $ take visibleOffset hash
           <> "..."
           <> drop (length hash - visibleOffset) hash

    renderSize size = text $ show meta.size <> " B"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs, blockie } = do
  div ! className "Signer" $ do
    div ! className "header" $ do
      span ! className "status" $ do
        viewSignerStatus
    viewProofs address proofArray
    clear
  where
    proofStates = fromFoldable $ values proofs

    proofArray :: Array (Tuple ProofMethod ProofState)
    proofArray = toUnfoldable proofs

    viewSignerStatus =
      case signerDisplayStatus proofStates of
        SignerLoading -> renderIcon "fa-circle-o-notch loading"
        SignerVerified -> renderBlockie blockie
        SignerVerificationFailed -> renderIcon "fa-exclamation-circle failed"
        SignerNetworkError -> renderIcon "fa-question-circle-o network-error"

viewProofs ::
  Address
  -> Array (Tuple ProofMethod ProofState)
  -> HTML Signers.Event
viewProofs address proofs =
  div ! className "proofs" $ do
    renderEthProof
    for_ proofs renderProof
  where
    renderProof (Tuple method state) = do
      case state of
        Finished result -> renderFinishedProof method result
        NetworkError -> renderNetworkError method
        Pending -> empty

    renderFinishedProof method Unavailable = empty
    renderFinishedProof method (Unverified error) =
      div
        ! className ("proof " <> "failed")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          span ! dataQA "error" ! A.title (show error)
            $ text $ show method <> " verification failed"

    renderFinishedProof method (Verified proofValue) =
      div
        ! className ("proof " <> "verified")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          a ! A.href (methodHref method proof) ! A.target "_blank" $ text proof
      where
        proof = ProofValues.extract proofValue

    renderNetworkError method =
      div ! className ("proof" <> "network-error") $ do
        methodIcon method
        text $ "Network error while fetching proof"

    renderEthProof =
      div ! className "proof" $ do
        renderEthIcon
        (addressLink address) ! dataQA "proof-details-eth"

    methodIcon GitHub = renderIcon "fa-github"
    methodIcon HTTP = renderIcon "fa-world"

    methodHref GitHub username =
      "https://github.com/" <> username
    methodHref HTTP domain =
      "http://" <> domain

guardAccountUnlocked ::
  Contracts.ETHAccountState Address -> (Address -> HTML Event) -> HTML Event
guardAccountUnlocked state guardedView = do
  case state of
    Contracts.Unavailable -> do
      renderSectionWarning do
        sectionStatus (renderIcon "fa-wrench") do
          text "Please install MetaMask extension"
    Contracts.Locked ->
      renderSectionWarning do
        sectionStatus (renderIcon "fa-unlock-alt") do
          text "Please unlock MetaMask extension"
    Contracts.Available address -> guardedView address

sectionHeader :: forall a. String -> HTML a
sectionHeader msg =
  h4 ! className "Section-header" $ text msg

renderSection :: forall a. HTML a -> HTML a
renderSection = div ! className "Section"

renderSectionWarning :: forall a. HTML a -> HTML a
renderSectionWarning = div ! className "Section warning"

renderSectionHighlighted :: forall a. HTML a -> HTML a
renderSectionHighlighted = div ! className "Section highlighted"

sectionStatus :: forall a. HTML a -> HTML a -> HTML a
sectionStatus i content =
  div ! className "status" $ do
    div ! className "status-icon" $ i
    content

sectionHighlight :: Attribute
sectionHighlight = className "highlighted"

sectionWarning :: Attribute
sectionWarning = className "warning"

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa fa-lg " <> name) $ text ""

renderLinkIcon :: forall a. String -> HTML a
renderLinkIcon name = i ! className ("Link-icon fa fa-lg " <> name) $ text ""

renderEthIcon :: forall a. Html a
renderEthIcon =
  img
  ! className "Icon"
  ! src images.ethIcon

renderBlockie :: forall a. String -> HTML a
renderBlockie blockieSrc =
  img ! className "blockie" ! src blockieSrc

renderList :: forall a. Array (HTML a) -> HTML a
renderList elements = do
  let indexed = mapWithIndex Tuple elements
  div ! className "List" $
    for_ indexed \(Tuple i el) ->
      if i `mod` 2 == 1 then
        div ! className "row row-even" $ el
      else
        div ! className "row row-odd" $ el

loading :: String
loading = "Loading..."

empty :: forall a. HTML a
empty = text ""

clear :: forall a. HTML a
clear = div ! className "Clear" $ empty

addressLink :: forall a. Address -> HTML a
addressLink address = do
  a
  ! A.href (addressURL address)
  ! className "AddressURL"
  ! A.target "_blank"
  $ text $ show address

txLink :: forall a. TxHash -> Maybe TxStatus -> HTML a
txLink hash status = do
  div ! dataQA "tx-status" $ do
    text case status of
      Nothing -> "Tx " <> (take 8 $ show hash ) <> "..."
      Just result -> case result of
        TxPending -> "Tx Pending..."
        TxFailed -> "Tx Failed"
        TxOk -> "Tx Successful"
    a
      ! A.href (txURL hash)
      ! A.target "_blank"
      $ renderIcon "Link-icon fa-external-link"

addressURL :: Address -> String
addressURL (Address address) =
  "https://etherscan.io/address/" <> address

txURL :: TxHash -> String
txURL (TxHash hash) =
  "https://etherscan.io/tx/" <> hash

navigate :: Location -> DOMEvent -> Event
navigate location = Routing <<< Locations.Navigate location

ignoreEvent :: DOMEvent -> Event
ignoreEvent = PreventDefault Nothing

preventingDefault :: Event -> DOMEvent -> Event
preventingDefault next = PreventDefault $ Just next

onClickAction :: Event -> EventHandlers (DOMEvent -> Event)
onClickAction next = onClick $ preventingDefault next

-- | Use where result is expected to be always `Just` due to the app logic,
-- | eg. in internal store lookups
expectResult :: forall a. Maybe a -> a
expectResult a = unsafePartial $ fromJust $ a

module App.View where

import Text.Smolder.HTML hiding (address)

import App.Routing (Location(..))
import App.State (Event(..), State, signerLens)
import App.State.Contracts as Contracts
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Locations as Locations
import App.State.Signers as Signers
import Data.Array (fromFoldable, mapWithIndex)
import Data.Either (Either(..))
import Data.Lens ((^.))
import Data.Map (toUnfoldable, values)
import Data.Maybe (Maybe(..), fromJust, isJust, maybe)
import Data.String (drop, length, take, toLower)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.Eth.Contracts (class EthContract, ContractLoadingError(..), getAddress)
import Lib.Eth.Web3 (TxHash(..), TxStatus(..))
import Lib.SignHash.Proofs.Display (SignerDisplayStatus(..), signerDisplayStatus)
import Lib.SignHash.Proofs.Methods (ProofMethod(..), canonicalName)
import Lib.SignHash.Proofs.Types (ProofState(..), ProofVerification(..))
import Lib.SignHash.Proofs.Values as ProofValues
import Lib.SignHash.Types (Address(..), HashSigner(..))
import Partial.Unsafe (unsafePartial)
import Prelude (discard, mod, not, show, ($), (-), (<<<), (<>), (==))
import Pux.DOM.Events (DOMEvent, onChange, onClick, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, src, type')
import Text.Smolder.HTML.Attributes as A
import Text.Smolder.Markup (Attribute, EventHandlers, attribute, text, (!), (#!))

foreign import images ::
  { logo :: String
  , ethIcon :: String }

dataQA :: String -> Attribute
dataQA = attribute "data-qa"

view :: State -> HTML Event
view state =
  do
    div ! className "Content" $ do
      div ! className "Header" $ do
        img ! src images.logo
        span ! className "title" $ text "SignHash"

      nav ! className "Navbar" $ do
        ul do
          li $ a ! A.href "#" $ text "Account"
          li $ a ! A.href "#" #! onClick (navigate Sign) $ text "Sign"
          li $ a ! A.href "#" #! onClick (navigate Verify) $ text "Verify"

      viewContent state

      hr
      div ! className "Contracts-info" $ do
        viewContracts state.contracts
      clear

viewContent :: State -> HTML Event
viewContent state@{ contracts: Contracts.Error error } = do
  renderSectionWarning do
    case error of
      NotDeployedToNetwork networkId ->
        sectionStatus (renderIcon "fa-repeat") do
          text "Please switch to Main Ethereum network"
viewContent state@{ location: Verify } = do
  withFileDetails state.file $ \file -> do
    viewFileSigners state file
viewContent state@{ location: Sign } = do
  withFileDetails state.file $ \file -> do
    sectionHeader "Signing address"
    guardAccountUnlocked state.myAccount $
      viewSigningDetails state file

withFileDetails ::
  Maybe Files.State
  -> (Files.State -> HTML Event)
  -> HTML Event
withFileDetails file viewDetails = do
  viewFileInput (isJust file)
  case file of
    Nothing -> empty
    Just file -> do
      viewFile file
      viewDetails file

viewFileSigners :: State -> Files.State -> HTML Event
viewFileSigners state file = do
  div $ signerStatus file.signer
  where
    signerStatus = case _ of
      Nothing -> sectionHeader "Loading signer..."
      Just NoSigner -> do
        renderSectionWarning do
          sectionStatus (renderIcon "fa-times") do
            text "This file has not been signed."
          a
            ! A.className "Button"
            #! onClick (navigate Sign)
            $ text "Sign it"

      Just (HashSigner address) -> do
        let selfSigned = case state.myAccount of
              Contracts.Available myAccount -> myAccount == address
              _ -> false
        sectionHeader "Signers"
        renderSection do
          if selfSigned then
            sectionStatus (renderIcon "fa-check-circle-o") do
            text "You have signed this file."
            else empty

          case state ^. signerLens address of
            Nothing -> div do
              text loading
              hr
            Just value -> do
              renderList
                [ child (Signer address) viewSigner $ value
                , child (Signer address) viewSigner $ value
                , child (Signer address) viewSigner $ value
                ]
        if not selfSigned then
          a
            ! A.className "Button block"
            #! onClick (navigate Sign)
            $ text "Add your signature"
          else empty

viewSigningDetails :: State -> Files.State -> Address -> HTML Event
viewSigningDetails state file address = do
  div ! dataQA "my-id" $ do
    let myDetails = expectResult $ state ^. signerLens address
    renderSectionHighlighted do
      child (Signer address) viewSigner $ myDetails
    case file.result of
      Nothing -> empty
      Just fileDetails ->
        case state.signingTx of
          Nothing ->
            a
              ! A.href "#"
              ! dataQA "sign"
              ! A.className "Button block"
              #! onClickAction (SignFile fileDetails.hash)
              $ do
                text "Sign it"
                renderLinkIcon "fa-paper-plane-o"
          Just (Left err) ->
            div
              ! A.className "Button block disabled"
              $ text "Error while issuing transaction"

          Just (Right hash) -> do
            let txStatus = Contracts.viewTxResult hash state.contracts
            div
              ! A.className "Button block disabled"
              $ txLink hash txStatus

viewContracts :: Contracts.State -> HTML Event
viewContracts Contracts.Loading =
  text $ "Loading contract..."
viewContracts (Contracts.Loaded state) = do
  contractLink "SignHash" state.signHash
  br
  contractLink "SignProof" state.signProof
  where
    contractLink :: forall c. EthContract c => String -> c -> HTML Event
    contractLink name contract = do
      span $ text $ name <> ": "
      (addressLink $ getAddress contract)
        ! dataQA ((toLower name) <> "-address")

viewContracts (Contracts.Error err) = do
  let msg = case err of
        NotDeployedToNetwork id ->
          "Contracts have not been deployed to selected network"
  div $ text msg

viewFileInput :: Boolean -> HTML Event
viewFileInput small =
  div do
    label
      ! for "file-upload"
      ! className ("File-upload" <> if small then " small" else "")
      #! onDrop handleNewFiles
      #! onDragOver ignoreEvent
      $ do
        renderIcon "fa-file-o"
        text (if small then "Upload another file" else "Upload file")
        if small then empty else
          div ! className "hint"
          $ text "Click or drag and drop on the page"
    input
      ! id "file-upload"
      ! type' "file"
      #! onChange handleNewFiles
  where
    handleNewFiles ev =
      preventingDefault (FileInput $ FileInputs.newFilesEvent ev) ev

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } = do
  div ! className "Files Section" $ do
    div ! className "row" $ do
      renderRow "Filename" $ text $ meta.name
      renderRow "SHA256" $ maybe (text loading) renderHash result
      renderRow "Size" $ renderSize meta.size

  where
    renderRow label value =
      div ! className "columns attribute four" $ do
        span ! className "header" $ text (label <> ":")
        span ! className "value" $ value

    renderSigner (HashSigner address) = show address
    renderSigner NoSigner = "Not signed"

    renderHash { hash } =
      let visibleOffset = 6
      in a
         ! dataQA "checksum"
         ! A.title hash
         ! A.href "#"
         $ text $ take visibleOffset hash
           <> "..."
           <> drop (length hash - visibleOffset) hash

    renderSize size = text $ show meta.size <> " B"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs, blockie } = do
  div ! className "Signer" $ do
    div ! className "header" $ do
      span ! className "status" $ do
        viewSignerStatus
    viewProofs address proofArray
    clear
  where
    proofStates = fromFoldable $ values proofs

    proofArray :: Array (Tuple ProofMethod ProofState)
    proofArray = toUnfoldable proofs

    viewSignerStatus =
      case signerDisplayStatus proofStates of
        SignerLoading -> renderIcon "fa-circle-o-notch loading"
        SignerVerified -> renderBlockie blockie
        SignerVerificationFailed -> renderIcon "fa-exclamation-circle failed"
        SignerNetworkError -> renderIcon "fa-question-circle-o network-error"

viewProofs ::
  Address
  -> Array (Tuple ProofMethod ProofState)
  -> HTML Signers.Event
viewProofs address proofs =
  div ! className "proofs" $ do
    renderEthProof
    for_ proofs renderProof
  where
    renderProof (Tuple method state) = do
      case state of
        Finished result -> renderFinishedProof method result
        NetworkError -> renderNetworkError method
        Pending -> empty

    renderFinishedProof method Unavailable = empty
    renderFinishedProof method (Unverified error) =
      div
        ! className ("proof " <> "failed")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          span ! dataQA "error" ! A.title (show error)
            $ text $ show method <> " verification failed"

    renderFinishedProof method (Verified proofValue) =
      div
        ! className ("proof " <> "verified")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          a ! A.href (methodHref method proof) ! A.target "_blank" $ text proof
      where
        proof = ProofValues.extract proofValue

    renderNetworkError method =
      div ! className ("proof" <> "network-error") $ do
        methodIcon method
        text $ "Network error while fetching proof"

    renderEthProof =
      div ! className "proof" $ do
        renderEthIcon
        (addressLink address) ! dataQA "proof-details-eth"

    methodIcon GitHub = renderIcon "fa-github"
    methodIcon HTTP = renderIcon "fa-world"

    methodHref GitHub username =
      "https://github.com/" <> username
    methodHref HTTP domain =
      "http://" <> domain

guardAccountUnlocked ::
  Contracts.ETHAccountState Address -> (Address -> HTML Event) -> HTML Event
guardAccountUnlocked state view = do
  case state of
    Contracts.Unavailable -> do
      renderSectionWarning do
        sectionStatus (renderIcon "fa-wrench") do
          text "Please install MetaMask extension"
    Contracts.Locked ->
      renderSectionWarning do
        sectionStatus (renderIcon "fa-unlock-alt") do
          text "Please unlock MetaMask extension"
    Contracts.Available address -> view address

sectionHeader :: forall a. String -> HTML a
sectionHeader msg =
  h4 ! className "Section-header" $ text msg

renderSection :: forall a. HTML a -> HTML a
renderSection = div ! className "Section"

renderSectionWarning :: forall a. HTML a -> HTML a
renderSectionWarning = div ! className "Section warning"

renderSectionHighlighted :: forall a. HTML a -> HTML a
renderSectionHighlighted = div ! className "Section highlighted"

sectionStatus :: forall a. HTML a -> HTML a -> HTML a
sectionStatus i content =
  div ! className "status" $ do
    div ! className "status-icon" $ i
    content

sectionHighlight :: Attribute
sectionHighlight = className "highlighted"

sectionWarning :: Attribute
sectionWarning = className "warning"

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa fa-lg " <> name) $ text ""

renderLinkIcon :: forall a. String -> HTML a
renderLinkIcon name = i ! className ("Link-icon fa fa-lg " <> name) $ text ""

renderEthIcon :: forall a. Html a
renderEthIcon =
  img
  ! className "Icon"
  ! src images.ethIcon

renderBlockie :: forall a. String -> HTML a
renderBlockie blockieSrc =
  img ! className "blockie" ! src blockieSrc

renderList :: forall a. Array (HTML a) -> HTML a
renderList elements = do
  let indexed = mapWithIndex Tuple elements
  div ! className "List" $
    for_ indexed \(Tuple i el) ->
      if i `mod` 2 == 1 then
        div ! className "row row-even" $ el
      else
        div ! className "row row-odd" $ el

loading :: String
loading = "Loading..."

empty :: forall a. HTML a
empty = text ""

clear :: forall a. HTML a
clear = div ! className "Clear" $ empty

addressLink :: forall a. Address -> HTML a
addressLink address = do
  a
  ! A.href (addressURL address)
  ! className "AddressURL"
  ! A.target "_blank"
  $ text $ show address

txLink :: forall a. TxHash -> Maybe TxStatus -> HTML a
txLink hash status = do
  div ! dataQA "tx-status" $ do
    text case status of
      Nothing -> "Tx " <> (take 8 $ show hash ) <> "..."
      Just result -> case result of
        TxPending -> "Tx Pending..."
        TxFailed -> "Tx Failed"
        TxOk -> "Tx Successful"
    a
      ! A.href (txURL hash)
      ! A.target "_blank"
      $ renderIcon "Link-icon fa-external-link"

addressURL :: Address -> String
addressURL (Address address) =
  "https://etherscan.io/address/" <> address

txURL :: TxHash -> String
txURL (TxHash hash) =
  "https://etherscan.io/tx/" <> hash

navigate :: Location -> DOMEvent -> Event
navigate location = Routing <<< Locations.Navigate location

ignoreEvent :: DOMEvent -> Event
ignoreEvent = PreventDefault Nothing

preventingDefault :: Event -> DOMEvent -> Event
preventingDefault next = PreventDefault $ Just next

onClickAction :: Event -> EventHandlers (DOMEvent -> Event)
onClickAction next = onClick $ preventingDefault next

-- | Use where result is expected to be always `Just` due to the app logic,
-- | eg. in internal store lookups
expectResult :: forall a. Maybe a -> a
expectResult a = unsafePartial $ fromJust $ a


createImageDataCopy

createImageDataCopy