Ensure seeds are coprime to modulus

Ensure seeds are coprime to modulus

module Test.QuickCheck.LCG
  ( Seed()
  , lcgM
  , lcgC
  , lcgN
  , lcgNext
  , randomSeed
  ) where

import Prelude

import Math ((%))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Random (RANDOM(), randomInt)
import Data.Int (fromNumber, toNumber)
import Data.Int.Bits (shl, (.|.))
import Data.Array (replicate)
import Data.Foldable (product)
import qualified Data.Maybe.Unsafe as U

type Seed = Int

-- | The *multiplier*: a magic constant for the linear congruential generator
lcgM :: Int
lcgM = 48271

-- | The *increment*: a magic constant for the linear congruential generator
lcgC :: Int
lcgC = 0

-- | The *modulus*: a magic constant for the linear congruential generator
lcgN :: Int
lcgN = product (replicate 31 2) - 1

-- | Step the linear congruential generator
lcgNext :: Int -> Int
lcgNext n = U.fromJust $ fromNumber $ (toNumber lcgM * toNumber n + toNumber lcgC) % toNumber lcgN

-- | Create a random seed
randomSeed :: forall e. Eff (random :: RANDOM | e) Seed
randomSeed =
  -- Because the increment is 0, we must ensure that any seed is coprime to the
  -- modulus. Luckily, this is easy: the modulus has just one prime factor, 2,
  -- so this means our seed will be coprime to the modulus iff it is odd.
  -- We ensure oddness by perfoming a bitwise OR with 1.
  randomInt 0 lcgM <#> (.|. 1)

module Test.QuickCheck.LCG
  ( Seed()
  , lcgM
  , lcgC
  , lcgN
  , lcgNext
  , randomSeed
  ) where

import Prelude

import Math ((%))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Random (RANDOM(), randomInt)
import Data.Int (fromNumber, toNumber)
import Data.Int.Bits (shl)
import Data.Array (replicate)
import Data.Foldable (product)
import qualified Data.Maybe.Unsafe as U

type Seed = Int

-- | The *multiplier*: a magic constant for the linear congruential generator
lcgM :: Int
lcgM = 48271

-- | The *increment*: a magic constant for the linear congruential generator
lcgC :: Int
lcgC = 0

-- | The *modulus*: a magic constant for the linear congruential generator
lcgN :: Int
lcgN = product (replicate 31 2) - 1

-- | Step the linear congruential generator
lcgNext :: Int -> Int
lcgNext n = U.fromJust $ fromNumber $ (toNumber lcgM * toNumber n + toNumber lcgC) % toNumber lcgN

-- | Create a random seed
randomSeed :: forall e. Eff (random :: RANDOM | e) Seed
randomSeed = randomInt 0 lcgM


Use `exception` rather than `err` label

Use `exception` rather than `err` label


Start reworking Track.Backend to use new coordinates

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((:))
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, maximum, sum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (united, (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, ala, alaF, unwrap)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio(..), denominator, numerator, (%))
import Data.Ratio as Ratio
import Data.Record as Record
import Data.Symbol (SProxy(..))
import Data.Traversable (scanl, traverse)
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Data.Variant (class Contractable, Variant)
import Data.Variant as Variant
import Genetics.Browser.Types (Bp(Bp), BrowserPoint, ChrId(ChrId), ChrInterval, CoordSys(..), Interval(..), Point, intervalSeenFromCanvas, viewIntervals)
import Genetics.Browser.View (Pixels)
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, scale, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class IsSymbol, class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

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

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.

type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

-- Drawings are not entirely pure. They can depend on the width of the
-- frame, if they something that spans across a range of the genome.
-- So, the `drawing` field should really have type
--   Pixels -> Drawing
-- where the `Pixels` is the width of the frame. Renderers already
-- have access to the chr size when created, so the width is all that's needed.
type PureRenderer' a = a -> Maybe { drawing :: Pixels -> Drawing
                                  , point   :: Normalized Point
                                  }

-- tagRenderer :: forall a sym r1 r2.
--                RowCons sym a r1 r2
--             => IsSymbol sym
--             => SProxy sym
--             -> PureRenderer a
--             -> PureRenderer (Variant r2)
-- tagRenderer sym renderer var = Variant.prj sym var >>= renderer

-- combineRenderers :: forall r1 r2 r3.
--                     Union r1 r2 r3
--                  => Contractable r3 r1
--                  => Contractable r3 r2
--                  => PureRenderer (Variant r1)
--                  -> PureRenderer (Variant r2)
--                  -> PureRenderer (Variant r3)
-- combineRenderers r1 r2 var = (Variant.contract var >>= r1) <|>
--                              (Variant.contract var >>= r2)

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx
        let r = 2.2
            x = unwrap $ f.pos / size
            y = (f.score - min) / (max - min)
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

pureRender :: forall f a.
              Filterable f
           => PureRenderer a
           -> f a
           -> f { drawing :: Drawing, point :: Normalized Point }
pureRender r as = filterMap r as

-- csysFrames :: forall i c.
--               { interval :: Interval BrowserPoint, chrSize :: Bp }
--            -> Pixels
--            ->

-- TODO simplify these two functions by extracting `padding` and `height` to another argument;
-- after all, only `width` changes per frame
drawPureFrame :: forall f r.
                 Foldable f
              => f { drawing :: Drawing, point :: Normalized Point | r }
              -> { width :: Pixels, padding :: Pixels, height :: Pixels }
              -> Drawing
drawPureFrame fs { width, padding, height } = foldMap render' fs
  where render' {drawing, point} =
            let {x,y} = nPointToFrame (width - padding * 2.0) height $ point
            in translate (x + padding) y drawing

-- Draw a collection of , lined up one after another
drawPureFrames :: forall a.
                  Array (Tuple (Array { drawing :: Drawing, point :: Normalized Point })
                               { width :: Pixels, padding :: Pixels, height :: Pixels })
               -> Drawing
drawPureFrames frames = fold $ Array.zipWith (\o -> translate o 0.0) os drawings'
  where os = framesOffsets $ snd <$> frames
        drawings' = map (uncurry drawPureFrame) frames

framesOffsets :: forall r.
                 Array { width :: Pixels | r }
              -> Array Pixels
framesOffsets fs = 0.0 : scanl (\o {width} -> width + o) 0.0 fs
    -- add 0.0 since scanl in framesOffsets doesn't include seed

shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: Number }
                   -> PureRenderer (Record rf)
                   -> PureRenderer (Record (minY :: Number | rf))
shiftRendererMinY dist s render f = do
  {drawing, point} <- render (Record.delete (SProxy :: SProxy "minY") f)
  let {x,y} = unwrap point
      normY = (f.minY - s.min) / (s.max - s.min)
      y' = min (normY + dist) 0.95

  point' <- normPoint {x, y: y'}
  pure {drawing, point: point'}

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

fetchJSON :: forall 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

gemmaJSONParse :: Json -> Maybe (GWASFeature ())
gemmaJSONParse j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "af"  <<< _Number
  pure {pos, score, chrId}

fetchGemmaJSON :: String -> Aff _ (Array (GWASFeature ()))
fetchGemmaJSON = fetchJSON gemmaJSONParse

type GeneRow r = ( geneID :: String
                 , desc :: String
                 , start :: Bp
                 , end :: Bp
                 , name :: String
                 , chrId :: ChrId | r )

type Gene r = Record (GeneRow r)

geneJSONParse :: Json -> Maybe (Gene ())
geneJSONParse 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
  pure {geneID, desc, name, start, end, chrId}

fetchGeneJSON :: String -> Aff _ (Array (Gene ()))
fetchGeneJSON = fetchJSON geneJSONParse

type AnnotRow r = ( geneID :: String
                  , desc :: String
                  , pos :: Bp
                  , name :: String
                  , chrId :: ChrId | r )

type Annot r = Record (AnnotRow r)

mkAnnotRenderer :: forall m rf rctx.
                   MonadReader (ChrCtx (size :: Bp | rctx)) m
                => m (PureRenderer (Annot rf))
mkAnnotRenderer = do
  ctx <- ask
  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx

        let rad = 5.0
            x = unwrap $ f.pos / size
            y = 0.0
            c = circle x y rad
            out  = outlined (outlineColor maroon <> lineWidth 3.0) c
            fill = filled   (fillColor red) c
            -- the canvas is flipped so y-axis increases upward, need to flip the text too
            text' = scale 1.0 (-1.0)
                    $ Drawing.text font' (x+7.5) (y+2.5) (fillColor black) f.name
            drawing = out <> fill <> text'

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

fetchAnnotJSON :: String -> Aff _ (Array (Annot ()))
fetchAnnotJSON str = map toAnnot <$> fetchJSON geneJSONParse str
  where toAnnot :: Gene () -> Annot ()
        toAnnot gene = { geneID: gene.geneID
                       , desc: gene.desc
                       , pos: gene.start
                       , name: gene.name
                       , chrId: gene.chrId }

bumpAnnots :: forall rAnnot rGWAS.
             RowLacks "minY" (AnnotRow rAnnot)
          => Bp
          -> Map ChrId (List (GWASFeature rGWAS))
          -> Map ChrId (List (Annot rAnnot))
          -> Map ChrId (List (Annot (minY :: Number | rAnnot)))
bumpAnnots radius = zipMapsWith (map <<< bumpAnnot)
  where maxScoreIn :: Bp -> Bp -> List (GWASFeature rGWAS) -> Number
        maxScoreIn l r gwas = fromMaybe 0.5 $ maximum
                              $ map (\g -> if g.pos >= l && g.pos <= r
                                           then g.score else 0.0) gwas
        bumpAnnot :: List (GWASFeature rGWAS) -> Annot rAnnot -> Annot (minY :: Number | rAnnot)
        bumpAnnot l g = let minY = maxScoreIn (g.pos - radius) (g.pos + radius) l
                       in Record.insert (SProxy :: SProxy "minY") minY g

getDataDemo :: { gwas :: String
               , annots :: String }
            -> Aff _ { gwas  :: Map ChrId (List (GWASFeature ()       ))
                     , annots :: Map ChrId (List (Annot (minY :: Number)))
                     }
getDataDemo urls = do
  gwas <- fetchGemmaJSON urls.gwas
  annots' <- fetchAnnotJSON urls.annots
  -- Divide data by chromosomes
  let gwasChr :: Map ChrId (List (GWASFeature ()))
      gwasChr = List.fromFoldable <$> groupToChrs gwas
  let annotsChr :: Map ChrId (List (Annot ()))
      annotsChr = List.fromFoldable <$> groupToChrs annots'
  let bumpedAnnots :: Map ChrId (List (Annot (minY :: Number)))
      bumpedAnnots = bumpAnnots (Bp 1000000.0) gwasChr annotsChr

  pure { gwas: gwasChr, annots: bumpedAnnots }

renderersDemo :: { min :: Number, max :: Number }
              -> { gwas  :: PureRenderer (GWASFeature ()       )
                 , annots :: PureRenderer (Annot (minY :: Number)) }
renderersDemo s = { gwas, annots }
  where colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                      mouseChrCtx mouseColors
        gwas :: PureRenderer (GWASFeature ())
        gwas = mkGwasRenderer s colorsCtx

        annots :: PureRenderer (Annot (minY :: Number))
        annots = shiftRendererMinY 0.06 s $ mkAnnotRenderer mouseChrCtx

ruler :: forall r.
         { min :: Number, max :: Number }
      -> Number
      -> Color
      -> { width :: Pixels, height :: Pixels, yOffset :: Pixels | r}
      -> Drawing
ruler {min, max} val color f = outlined outline rulerDrawing
  where normY = (val - min) / (max - min)
        y = f.height - (normY * f.height + f.yOffset)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

drawDemo :: forall f.
            Foldable f
         => Filterable f
         => { min :: Number, max :: Number }
         -> Number
         -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
         -> { gwas :: Map ChrId (f (GWASFeature ()))
            , annots :: Map ChrId (f (Annot (minY :: Number))) }
         -> Array ChrId
         -> Drawing
drawDemo s sig f {gwas, annots} =
  let renderers = renderersDemo s
      ruler' = ruler s sig red
      drawGwas   = drawData f mouseChrCtx renderers.gwas   gwas
      drawAnnots = drawData f mouseChrCtx renderers.annots annots
  in \chrs -> (drawGwas chrs) <> (drawAnnots chrs) <> ruler' f

drawDemo' :: _
drawDemo' = unsafeCoerce

mkFrame :: forall r i.
           { width :: Pixels, height :: Pixels | r }
        -> Interval BrowserPoint
        -> Interval BrowserPoint
        -> { width :: Pixels, height :: Pixels, offset :: Pixels }
mkFrame canvasSize interval view@(Interval l r) =
  let (Interval l r) = intervalSeenFromCanvas canvasSize interval view
      width = r - l
      offset = l
  in { width, height: canvasSize.height, offset }

mkFrames :: forall i c r.
            { width :: Pixels, height :: Pixels | r }
         -> Array (Interval BrowserPoint)
         -> Interval BrowserPoint
         -> Array ( {width :: Pixels, height :: Pixels, offset :: Pixels} )
mkFrames canvasSize ivals view = map (mkFrame canvasSize view) ivals

drawData' :: forall i f a r.
             Ord i
          => Foldable f
          => Filterable f
          => CoordSys i BrowserPoint
          -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
          -> PureRenderer a
          -> Map i (f a)
          -> Interval BrowserPoint
          -> Drawing
drawData' cs canvasBox renderer dat =
  let drawings :: Map i (Array {drawing :: Drawing, point :: _})
      drawings = map (Array.fromFoldable <<< pureRender renderer) dat

      fIvals :: _
      fIvals v' = (map <<< map) _.interval $ viewIntervals cs v'

      -- mkFrame :: Array i -> i -> Maybe {width :: _, height :: _, padding :: _}
      -- mkFrame chrs' chr = do
      --   {size} <- Map.lookup chr chrCtx
      --   let total = sum $ filterMap (\c -> _.size <$> Map.lookup c chrCtx) chrs'
      --       width = (unwrap $ size / total) * frameBox.width
      --   pure { height: frameBox.height - frameBox.yOffset, padding: frameBox.padding, width }

      -- frames :: Array ChrId -> Array (Tuple (Array _) (_))
      -- frames chrs' = Array.zip (map (\c -> fromMaybe [] $ Map.lookup c drawings) chrs')
      --                          (filterMap (mkFrame chrs') chrs')

      mkFrames' :: Interval BrowserPoint -> Array { | _ }
      mkFrames' v = mkFrames canvasBox (fromMaybe [] $ fIvals v) v

      frames :: Interval BrowserPoint -> Array (Tuple (Array _) (_))
      frames v = Array.zip (unsafeCoerce unit) (mkFrames' v)

  in \view -> translate 0.0 (canvasBox.height - canvasBox.yOffset)
                $ scale 1.0 (-1.0)
                $ drawPureFrames (frames view)

-- Draw data by rendering it only once
drawData :: forall f a r.
            Foldable f
         => Filterable f
         -- NOTE! the width is the canvas width, not frame. Same w/ yOffset
         => { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
         -> Map ChrId { size :: Bp | r}
         -> PureRenderer a
         -> Map ChrId (f a)
         -> Array ChrId
         -> Drawing
drawData frameBox chrCtx renderer dat =
  let drawings :: Map ChrId (Array {drawing :: Drawing, point :: _})
      drawings = map (Array.fromFoldable <<< pureRender renderer) dat

      mkFrame :: Array ChrId -> ChrId -> Maybe {width :: _, height :: _, padding :: _}
      mkFrame chrs' chr = do
        {size} <- Map.lookup chr chrCtx
        let total = sum $ filterMap (\c -> _.size <$> Map.lookup c chrCtx) chrs'
            width = (unwrap $ size / total) * frameBox.width
        pure { height: frameBox.height - frameBox.yOffset, padding: frameBox.padding, width }

      frames :: Array ChrId -> Array (Tuple (Array _) (_))
      frames chrs' = Array.zip (map (\c -> fromMaybe [] $ Map.lookup c drawings) chrs')
                               (filterMap (mkFrame chrs') chrs')

  in \chrs -> translate 0.0 (frameBox.height - frameBox.yOffset)
                $ scale 1.0 (-1.0)
                $ drawPureFrames (frames chrs)

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)
            ]

mouseColors :: ChrCtx (color :: Color)
mouseColors = Map.fromFoldable $ Array.zip mouseChrIds $ map (\x -> {color: x})
              [ navy, blue, aqua, teal, olive
              , green, lime, yellow, orange, red
              , maroon, fuchsia, purple, navy, blue
              , aqua, teal, olive, green, lime
              , yellow ]

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

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((:))
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, maximum, sum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (united, (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype, ala, alaF, unwrap)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio(..), denominator, numerator, (%))
import Data.Ratio as Ratio
import Data.Record as Record
import Data.Symbol (SProxy(..))
import Data.Traversable (scanl, traverse)
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Data.Variant (class Contractable, Variant)
import Data.Variant as Variant
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.View (Pixels)
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, scale, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class IsSymbol, class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

-- This type represents a point on the *browser*, not the *genome*.
-- It includes spaces between chromosomes, for example.
newtype BrowserPoint = BrowserPoint (Ratio BigInt)

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

inRange :: forall c.
              Ord c
           => c
           -> Tuple c c
           -> Boolean
inRange c (Tuple l r) = l <= c && c <= r

ivals :: forall i c.
         Eq i
      => Ord c
      => EuclideanRing c
      => Array (Tuple i c)
      -> { toLocal  :: Ratio c   -> Maybe (Tuple i c)
         , toGlobal  :: Tuple i c -> Maybe (Ratio c)
         , intervals :: Array (Tuple i (Tuple (Ratio c) (Ratio c)))
         }
ivals frames = { toLocal, toGlobal, intervals }
  where (Tuple is sizes) = Array.unzip frames
        normalized :: Array (Ratio c)
        normalized = let total = sum sizes in map (_ % total) sizes
        intervals = Array.zip is
                      $ Array.zip (zero `Array.cons` normalized) normalized
        toLocal :: Ratio c -> Maybe (Tuple i c)
        toLocal r = do
          -- xx <-
          (Tuple i (Tuple start end)) <- Array.find (inRange r <<< snd) intervals
          (Tuple _ size) <- Array.find ((==) i <<< fst) frames

          -- TODO this might be totally messed up
          -- r' should be possible to round to the final value safely

          -- Needs testing!!!
          let r' :: Ratio c
              r' = ((r - start) / (end - start)) * (size % one)
              n = Ratio.numerator r'
              d = Ratio.denominator r'

          pure $ Tuple i (n / d)

        toGlobal :: Tuple i c -> Maybe (Ratio c)
        toGlobal (Tuple i c) = do

          (Tuple _ (Tuple sR eR)) <- Array.find ((==) i <<< fst) intervals

          (Tuple _ size) <- Array.find ((==) i <<< fst) frames

              -- I'm not sure what's going on here
              -- also needs testing...
          let iLenR :: _
              iLenR = eR - sR   -- the proportion of the interval to the entire browser
              iLenR' = one / iLenR -- scaling from interval to browser
              r = c % size -- the given point in interval-local coordinates
              r' = r % iLenR'  --- and in global coordinates

          pure $ (c % size) * (one / eR - sR)

newtype CoordSystem = CoordSystem { genLength :: BigInt
                                  , toGenome :: Ratio BigInt -> Maybe (Tuple ChrId Bp)
                                  , toGlobal :: Tuple ChrId Bp -> Maybe (Ratio BigInt)
                                  , frames :: Array (Tuple ChrId
                                                     { start :: Ratio BigInt
                                                     , end :: Ratio BigInt
                                                     })
                                  }

toBigInt :: Bp -> BigInt
toBigInt (Bp x) = BigInt.fromInt $ Int.round $ x

chrIntervals :: Array (Tuple ChrId Bp)
             -> Array (Tuple ChrId (Tuple BigInt BigInt))
chrIntervals chrs = case Array.uncons chrs of
  Nothing -> []
  Just {head, tail} ->
    let first = Tuple (toBigInt (Bp 0.0)) (toBigInt (snd head))
        g :: Tuple BigInt BigInt -> Bp -> Tuple BigInt BigInt
        g (Tuple start end) size = (Tuple end (end+(toBigInt size)))
        (Tuple ids sizes) = Array.unzip chrs
    in Array.zip ids (Array.cons first $ scanl g first sizes)

toBp :: Ratio BigInt -> Ratio BigInt -> Ratio BigInt -> Bp -> Bp
toBp start end pos bp =
  let norm = (pos - start) - (end - start)
      norm' = (BigInt.toNumber $ numerator norm) / (BigInt.toNumber $ denominator norm)
  in (Bp norm') * bp

frameToGenome :: Array (Tuple ChrId { start :: Ratio BigInt
                                    , end :: Ratio BigInt })
         -> Ratio BigInt
         -> Maybe (Tuple ChrId Bp)
frameToGenome frames r = do
  chr <- Array.find (\(Tuple _ {start, end}) -> start <= r && r <= end) frames

  let chr' :: _
      chr' = chr

  pure $ unsafeCoerce unit

-- toGlobal :: Tuple ChrId Bp -> Maybe (Ratio BigInt)
-- toGlobal = unsafeCoerce unit

mkCoordSystem :: forall f.
                 Functor f
              => Foldable f
              => f (Tuple ChrId Bp)
              -> CoordSystem
mkCoordSystem chrs = CoordSystem { genLength, toGenome, toGlobal, frames }
  where genLength :: BigInt
        genLength = Additive `ala` foldMap $ map (toBigInt <<< snd) chrs

        frames :: Array (Tuple ChrId {start :: Ratio BigInt, end :: Ratio BigInt})
        frames = map (\(Tuple s e) -> {start: s % genLength, end: e % genLength})
                   <$> (chrIntervals $ Array.fromFoldable chrs)

        toGenome :: Ratio BigInt -> Maybe (Tuple ChrId Bp)
        toGenome r = unsafeCoerce unit

        toGlobal :: Tuple ChrId Bp -> Maybe (Ratio BigInt)
        toGlobal = unsafeCoerce unit

-- testin :: List _ -> _
-- testin = Additive `ala` foldMap

-- To map a BrowserPoint to a point on the genome, we need to know
-- the intervals of the chromosomes, and their respective sizes.
-- I.e. we need to "invert" the Frames.
-- To simplify that we should simplify Frames, decoupling the concept of width from height.
-- Then produce a function
{-
  x in [0.0, 1.0] -> Tuple ChrId Bp
-}
-- So extract the `frames` function from `drawData'` (again).
-- Or, well
-- the drawData' function should grow to handle events on glyphs,
-- which will involve this type of thing as well.

-- toGenome :: BrowserPoint -> ChrCtx

type Frame a = { padding :: Pixels, width :: Pixels, contents :: a }

type ChrCtx r = Map ChrId (Record r)

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

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

-- A renderer draws a single value to a normalized "canvas",
-- i.e. the whole chromosome is located in x = (0.0, 1.0),
-- and the whole track height in y = (0.0, 1.0).
-- It can fail if the given feature for some reason cannot be rendered,
-- either because the feature lacks information, or because the context lacks something.

type PureRenderer a = a -> Maybe { drawing :: Drawing
                                 , point   :: Normalized Point
                                 }

-- Drawings are not entirely pure. They can depend on the width of the
-- frame, if they something that spans across a range of the genome.
-- So, the `drawing` field should really have type
--   Pixels -> Drawing
-- where the `Pixels` is the width of the frame. Renderers already
-- have access to the chr size when created, so the width is all that's needed.
type PureRenderer' a = a -> Maybe { drawing :: Pixels -> Drawing
                                  , point   :: Normalized Point
                                  }

tagRenderer :: forall a sym r1 r2.
               RowCons sym a r1 r2
            => IsSymbol sym
            => SProxy sym
            -> PureRenderer a
            -> PureRenderer (Variant r2)
tagRenderer sym renderer var = Variant.prj sym var >>= renderer

combineRenderers :: forall r1 r2 r3.
                    Union r1 r2 r3
                 => Contractable r3 r1
                 => Contractable r3 r2
                 => PureRenderer (Variant r1)
                 -> PureRenderer (Variant r2)
                 -> PureRenderer (Variant r3)
combineRenderers r1 r2 var = (Variant.contract var >>= r1) <|>
                             (Variant.contract var >>= r2)

type GWASFeature r = { score :: Number
                     , pos :: Bp
                     , chrId :: ChrId | r }

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               -- => MonadError Unit m
               => {min :: Number, max :: Number}
               -> m (PureRenderer (GWASFeature rf))
mkGwasRenderer {min, max} = do
  ctx <- ask
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx
        color <- _.color <$> Map.lookup f.chrId ctx
        let r = 2.2
            x = unwrap $ f.pos / size
            y = (f.score - min) / (max - min)
            c = circle x y r
            out = outlined (outlineColor color) c
            fill = filled (fillColor color) c
            drawing = out <> fill

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

pureRender :: forall f a.
              Filterable f
           => PureRenderer a
           -> f a
           -> f { drawing :: Drawing, point :: Normalized Point }
pureRender r as = filterMap r as

-- TODO simplify these two functions by extracting `padding` and `height` to another argument;
-- after all, only `width` changes per frame
drawPureFrame :: forall f r.
                 Foldable f
              => f { drawing :: Drawing, point :: Normalized Point | r }
              -> { width :: Pixels, padding :: Pixels, height :: Pixels }
              -> Drawing
drawPureFrame fs { width, padding, height } = foldMap render' fs
  where render' {drawing, point} =
            let {x,y} = nPointToFrame (width - padding * 2.0) height $ point
            in translate (x + padding) y drawing

-- Draw a collection of , lined up one after another
drawPureFrames :: forall a.
                  Array (Tuple (Array { drawing :: Drawing, point :: Normalized Point })
                               { width :: Pixels, padding :: Pixels, height :: Pixels })
               -> Drawing
drawPureFrames frames = fold $ Array.zipWith (\o -> translate o 0.0) os drawings'
  where os = framesOffsets $ snd <$> frames
        drawings' = map (uncurry drawPureFrame) frames

framesOffsets :: forall r.
                 Array { width :: Pixels | r }
              -> Array Pixels
framesOffsets fs = 0.0 : scanl (\o {width} -> width + o) 0.0 fs
    -- add 0.0 since scanl in framesOffsets doesn't include seed

shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: Number }
                   -> PureRenderer (Record rf)
                   -> PureRenderer (Record (minY :: Number | rf))
shiftRendererMinY dist s render f = do
  {drawing, point} <- render (Record.delete (SProxy :: SProxy "minY") f)
  let {x,y} = unwrap point
      normY = (f.minY - s.min) / (s.max - s.min)
      y' = min (normY + dist) 0.95

  point' <- normPoint {x, y: y'}
  pure {drawing, point: point'}

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

fetchJSON :: forall 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

gemmaJSONParse :: Json -> Maybe (GWASFeature ())
gemmaJSONParse j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "af"  <<< _Number
  pure {pos, score, chrId}

fetchGemmaJSON :: String -> Aff _ (Array (GWASFeature ()))
fetchGemmaJSON = fetchJSON gemmaJSONParse

type GeneRow r = ( geneID :: String
                 , desc :: String
                 , start :: Bp
                 , end :: Bp
                 , name :: String
                 , chrId :: ChrId | r )

type Gene r = Record (GeneRow r)

geneJSONParse :: Json -> Maybe (Gene ())
geneJSONParse 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
  pure {geneID, desc, name, start, end, chrId}

fetchGeneJSON :: String -> Aff _ (Array (Gene ()))
fetchGeneJSON = fetchJSON geneJSONParse

type AnnotRow r = ( geneID :: String
                  , desc :: String
                  , pos :: Bp
                  , name :: String
                  , chrId :: ChrId | r )

type Annot r = Record (AnnotRow r)

mkAnnotRenderer :: forall m rf rctx.
                   MonadReader (ChrCtx (size :: Bp | rctx)) m
                => m (PureRenderer (Annot rf))
mkAnnotRenderer = do
  ctx <- ask
  let font' = font sansSerif 12 mempty
  let renderer f = do
        size <- _.size <$> Map.lookup f.chrId ctx

        let rad = 5.0
            x = unwrap $ f.pos / size
            y = 0.0
            c = circle x y rad
            out  = outlined (outlineColor maroon <> lineWidth 3.0) c
            fill = filled   (fillColor red) c
            -- the canvas is flipped so y-axis increases upward, need to flip the text too
            text' = scale 1.0 (-1.0)
                    $ Drawing.text font' (x+7.5) (y+2.5) (fillColor black) f.name
            drawing = out <> fill <> text'

        point <- normPoint {x, y}
        pure { drawing, point }

  pure renderer

fetchAnnotJSON :: String -> Aff _ (Array (Annot ()))
fetchAnnotJSON str = map toAnnot <$> fetchJSON geneJSONParse str
  where toAnnot :: Gene () -> Annot ()
        toAnnot gene = { geneID: gene.geneID
                       , desc: gene.desc
                       , pos: gene.start
                       , name: gene.name
                       , chrId: gene.chrId }

bumpAnnots :: forall rAnnot rGWAS.
             RowLacks "minY" (AnnotRow rAnnot)
          => Bp
          -> Map ChrId (List (GWASFeature rGWAS))
          -> Map ChrId (List (Annot rAnnot))
          -> Map ChrId (List (Annot (minY :: Number | rAnnot)))
bumpAnnots radius = zipMapsWith (map <<< bumpAnnot)
  where maxScoreIn :: Bp -> Bp -> List (GWASFeature rGWAS) -> Number
        maxScoreIn l r gwas = fromMaybe 0.5 $ maximum
                              $ map (\g -> if g.pos >= l && g.pos <= r
                                           then g.score else 0.0) gwas
        bumpAnnot :: List (GWASFeature rGWAS) -> Annot rAnnot -> Annot (minY :: Number | rAnnot)
        bumpAnnot l g = let minY = maxScoreIn (g.pos - radius) (g.pos + radius) l
                       in Record.insert (SProxy :: SProxy "minY") minY g

getDataDemo :: { gwas :: String
               , annots :: String }
            -> Aff _ { gwas  :: Map ChrId (List (GWASFeature ()       ))
                     , annots :: Map ChrId (List (Annot (minY :: Number)))
                     }
getDataDemo urls = do
  gwas <- fetchGemmaJSON urls.gwas
  annots' <- fetchAnnotJSON urls.annots
  -- Divide data by chromosomes
  let gwasChr :: Map ChrId (List (GWASFeature ()))
      gwasChr = List.fromFoldable <$> groupToChrs gwas
  let annotsChr :: Map ChrId (List (Annot ()))
      annotsChr = List.fromFoldable <$> groupToChrs annots'
  let bumpedAnnots :: Map ChrId (List (Annot (minY :: Number)))
      bumpedAnnots = bumpAnnots (Bp 1000000.0) gwasChr annotsChr

  pure { gwas: gwasChr, annots: bumpedAnnots }

renderersDemo :: { min :: Number, max :: Number }
              -> { gwas  :: PureRenderer (GWASFeature ()       )
                 , annots :: PureRenderer (Annot (minY :: Number)) }
renderersDemo s = { gwas, annots }
  where colorsCtx = zipMapsWith (\r {color} -> Record.insert (SProxy :: SProxy "color") color r)
                      mouseChrCtx mouseColors
        gwas :: PureRenderer (GWASFeature ())
        gwas = mkGwasRenderer s colorsCtx

        annots :: PureRenderer (Annot (minY :: Number))
        annots = shiftRendererMinY 0.06 s $ mkAnnotRenderer mouseChrCtx

ruler :: forall r.
         { min :: Number, max :: Number }
      -> Number
      -> Color
      -> { width :: Pixels, height :: Pixels, yOffset :: Pixels | r}
      -> Drawing
ruler {min, max} val color f = outlined outline rulerDrawing
  where normY = (val - min) / (max - min)
        y = f.height - (normY * f.height + f.yOffset)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

drawDemo :: forall f.
            Foldable f
         => Filterable f
         => { min :: Number, max :: Number }
         -> Number
         -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
         -> { gwas :: Map ChrId (f (GWASFeature ()))
            , annots :: Map ChrId (f (Annot (minY :: Number))) }
         -> Array ChrId
         -> Drawing
drawDemo s sig f {gwas, annots} =
  let renderers = renderersDemo s
      ruler' = ruler s sig red
      drawGwas   = drawData f mouseChrCtx renderers.gwas   gwas
      drawAnnots = drawData f mouseChrCtx renderers.annots annots
  in \chrs -> (drawGwas chrs) <> (drawAnnots chrs) <> ruler' f

-- Draw data by rendering it only once
drawData :: forall f a r.
            Foldable f
         => Filterable f
         -- NOTE! the width is the canvas width, not frame. Same w/ yOffset
         => { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
         -> Map ChrId { size :: Bp | r}
         -> PureRenderer a
         -> Map ChrId (f a)
         -> Array ChrId
         -> Drawing
drawData frameBox chrCtx renderer dat =
  let drawings :: Map ChrId (Array {drawing :: Drawing, point :: _})
      drawings = map (Array.fromFoldable <<< pureRender renderer) dat

      mkFrame :: Array ChrId -> ChrId -> Maybe {width :: _, height :: _, padding :: _}
      mkFrame chrs' chr = do
        {size} <- Map.lookup chr chrCtx
        let total = sum $ filterMap (\c -> _.size <$> Map.lookup c chrCtx) chrs'
            width = (unwrap $ size / total) * frameBox.width
        pure { height: frameBox.height - frameBox.yOffset, padding: frameBox.padding, width }

      frames :: Array ChrId -> Array (Tuple (Array _) (_))
      frames chrs' = Array.zip (map (\c -> fromMaybe [] $ Map.lookup c drawings) chrs')
                               (filterMap (mkFrame chrs') chrs')

  in \chrs -> translate 0.0 (frameBox.height - frameBox.yOffset)
                $ scale 1.0 (-1.0)
                $ drawPureFrames (frames chrs)

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)
            ]

mouseColors :: ChrCtx (color :: Color)
mouseColors = Map.fromFoldable $ Array.zip mouseChrIds $ map (\x -> {color: x})
              [ navy, blue, aqua, teal, olive
              , green, lime, yellow, orange, red
              , maroon, fuchsia, purple, navy, blue
              , aqua, teal, olive, green, lime
              , yellow ]

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


[DAE-5] Improve error handling (HTTPStatus, JSON decoding)

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Array.Partial (last)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (split, joinWith)
import Network.HTTP.Affjax (AffjaxResponse, affjax, defaultRequest, AJAX, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader(ContentType))
import Network.HTTP.StatusCode (StatusCode(..))
import Partial.Unsafe (unsafePartial)

-- HELPERS

type URLPath = Array String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path

data ApiError
    = HTTPStatusError (AffjaxResponse Json)
    | JSONDecodingError String

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show res.status
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult res = bimap (error <<< show <<< JSONDecodingError) id $ decodeJson res.response

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
    res <- affjax $ request { url = backendApi urlPath }
    when (res.status /= StatusCode 200) $
      throwError <<< error <<< show $ HTTPStatusError res
    either throwError pure $ decodeResult res

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

-- REQUESTS
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["get_wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["get_wallet", _address addr]

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = getR ["history", _address addr]

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["send", _address addrFrom, _address addrTo, show $ _coin amount]

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["new_wallet"]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["update_transaction", _address addr, _ctxIdValue ctxId]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = postRBody ["update_wallet", _address addr]

-- FIXME: use DELETE method
deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = postR ["delete_wallet", _address addr]

isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["valid_address", dropModuleName $ gShow cCurrency, addr]
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split "."

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error, Error)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST))
import Data.Maybe (Maybe (Just))
import Data.String (split, joinWith)
import Data.Array.Partial (last)
import Network.HTTP.Affjax (affjax, defaultRequest, AJAX, get, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader (ContentType))
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency)
import Daedalus.Constants (backendPrefix)
import Data.MediaType.Common (applicationJSON)
import Partial.Unsafe (unsafePartial)

-- HELPERS

type URLPath = Array String

urlPath :: forall a. URLPath -> URL
urlPath = joinWith "/"

backendApi :: forall a. URLPath -> URL
backendApi path = urlPath $ [backendPrefix, "api"] <> path

-- REQUESTS HELPERS
decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult res = bimap error id $ decodeJson res.response

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
  res <- affjax $ request { url = backendApi urlPath }
  either throwError pure $ decodeResult res

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

-- REQUESTS
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["get_wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["get_wallet", _address addr]

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = getR ["history", _address addr]

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["send", _address addrFrom, _address addrTo, show $ _coin amount]

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["new_wallet"]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["update_transaction", _address addr, _ctxIdValue ctxId]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = postRBody ["update_wallet", _address addr]

-- FIXME: use DELETE method
deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = postR ["delete_wallet", _address addr]

isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["valid_address", dropModuleName $ gShow cCurrency, addr]
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split "."


Updated ft warning (#1606)

Updated ft warning (#1606)

module Test.SlamData.Feature.Test.FlipDeck where

import SlamData.Prelude (Unit, ($), bind, unit, pure)

import Selenium.Monad (later, sequence)
import Test.Feature.Log (successMsg, warnMsg)
import Test.Feature.Scenario (scenario)
import Test.SlamData.Feature.Expectations as Expect
import Test.SlamData.Feature.Interactions as Interact
import Test.SlamData.Feature.Monad (SlamFeature)
import Test.Feature.ActionSequence as Actions

flipDeckScenario ∷ String → Array String → SlamFeature Unit → SlamFeature Unit
flipDeckScenario =
  scenario
    "Deck backside"
    (Interact.createWorkspaceInTestFolder "Flipped deck")
    (Interact.deleteFileInTestFolder "Flipped deck.slam")

mkDeckWithLastTable ∷ SlamFeature Unit
mkDeckWithLastTable = do
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "select measureOne, measureTwo from `/test-mount/testDb/flatViz`"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "measureOne"
    Interact.addColumn "measureTwo"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.tableColumnsAre ["measureOne", "measureTwo"]

test ∷ SlamFeature Unit
test = do
  flipDeckScenario "Flip deck" [] do
    mkDeckWithLastTable
    Interact.flipDeck
    Expect.backsideMenuPresented
    Interact.flipDeck
    Expect.backsideMenuNotPresented
    Expect.tableColumnsAre ["measureOne", "measureTwo"]
    successMsg "Ok, 'flip deck' button works"

  -- Note: Trash button deletes last or active card
  flipDeckScenario "Trash last card" [] do
    mkDeckWithLastTable
    Interact.flipDeck
    Expect.backsideMenuPresented
    Interact.trashActiveOrLastCard
    -- Note, user should see that last|active card has been deleted
    -- That's why we immediately flip deck after trashing
    Expect.backsideMenuNotPresented
    Expect.noTablesPresented
    successMsg "Successfuly deleted last|active card"

  flipDeckScenario "Share deck" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard "Quarterly"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.textInDisplayMarkdownCard "Quarterly"
    warnMsg "https://github.com/slamdata/slamdata/issues/1077, we don't know if workspace has been saved already"
    later 1000 $ pure unit
    Interact.flipDeck
    Expect.backsideMenuPresented
    Interact.publishDeck
    Interact.accessPublishingUrl
    Expect.textInDisplayMarkdownCard "Quarterly"
    Interact.launchSlamData
    successMsg "Successfully shared deck"

  flipDeckScenario "Filter backside buttons" [] do
    mkDeckWithLastTable
    Interact.flipDeck
    Expect.backsideMenuPresented
    Interact.filterDeckAndCardActions "delete c"
    Expect.onlyTrashActionPresented
    sequence $ Actions.sendBackspaces 8
    Expect.backsideMenuPresented
    sequence $ Actions.sendBackspaces 8
    Expect.backsideMenuPresented
    Interact.filterDeckAndCardActions "emb"
    Expect.onlyEmbedActionPresented
    sequence $ Actions.sendBackspaces 5
    Expect.backsideMenuPresented
    Interact.filterDeckAndCardActions "ub"
    Expect.onlyPublishActionPresented
    sequence $ Actions.sendBackspaces 5
    successMsg "Successfully filtered backside actions"

module Test.SlamData.Feature.Test.FlipDeck where

import SlamData.Prelude (Unit, ($), bind, unit, pure)

import Selenium.Monad (later, sequence)
import Test.Feature.Log (successMsg, warnMsg)
import Test.Feature.Scenario (scenario)
import Test.SlamData.Feature.Expectations as Expect
import Test.SlamData.Feature.Interactions as Interact
import Test.SlamData.Feature.Monad (SlamFeature)
import Test.Feature.ActionSequence as Actions

flipDeckScenario ∷ String → Array String → SlamFeature Unit → SlamFeature Unit
flipDeckScenario =
  scenario
    "Deck backside"
    (Interact.createWorkspaceInTestFolder "Flipped deck")
    (Interact.deleteFileInTestFolder "Flipped deck.slam")

mkDeckWithLastTable ∷ SlamFeature Unit
mkDeckWithLastTable = do
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "select measureOne, measureTwo from `/test-mount/testDb/flatViz`"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "measureOne"
    Interact.addColumn "measureTwo"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.tableColumnsAre ["measureOne", "measureTwo"]

test ∷ SlamFeature Unit
test = do
  flipDeckScenario "Flip deck" [] do
    mkDeckWithLastTable
    Interact.flipDeck
    Expect.backsideMenuPresented
    Interact.flipDeck
    Expect.backsideMenuNotPresented
    Expect.tableColumnsAre ["measureOne", "measureTwo"]
    successMsg "Ok, 'flip deck' button works"

  -- Note: Trash button deletes last or active card
  flipDeckScenario "Trash last card" [] do
    mkDeckWithLastTable
    Interact.flipDeck
    Expect.backsideMenuPresented
    Interact.trashActiveOrLastCard
    -- Note, user should see that last|active card has been deleted
    -- That's why we immediately flip deck after trashing
    Expect.backsideMenuNotPresented
    Expect.noTablesPresented
    successMsg "Successfuly deleted last|active card"

  flipDeckScenario "Share deck" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard "Quarterly"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.textInDisplayMarkdownCard "Quarterly"
    warnMsg "SD-1538, we don't know if workspace has been saved already"
    later 1000 $ pure unit
    Interact.flipDeck
    Expect.backsideMenuPresented
    Interact.publishDeck
    Interact.accessPublishingUrl
    Expect.textInDisplayMarkdownCard "Quarterly"
    Interact.launchSlamData
    successMsg "Successfully shared deck"

  flipDeckScenario "Filter backside buttons" [] do
    mkDeckWithLastTable
    Interact.flipDeck
    Expect.backsideMenuPresented
    Interact.filterDeckAndCardActions "delete c"
    Expect.onlyTrashActionPresented
    sequence $ Actions.sendBackspaces 8
    Expect.backsideMenuPresented
    sequence $ Actions.sendBackspaces 8
    Expect.backsideMenuPresented
    Interact.filterDeckAndCardActions "emb"
    Expect.onlyEmbedActionPresented
    sequence $ Actions.sendBackspaces 5
    Expect.backsideMenuPresented
    Interact.filterDeckAndCardActions "ub"
    Expect.onlyPublishActionPresented
    sequence $ Actions.sendBackspaces 5
    successMsg "Successfully filtered backside actions"


Add guard, trace, traceM, spy to Lambfda.Prelude

module Lambda.Prelude
  ( module Prelude
  , module X
  ) where

import Prelude

import Control.Alt ((<|>)) as X
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM) as X
import Control.Monad.State (class MonadState, evalState, execState, gets, get, modify_, put) as X
import Control.MonadZero (guard) as X
import Data.Either (Either(..), either) as X
import Data.Foldable (class Foldable, fold, foldr, foldl, foldM, foldMap, for_, traverse_) as X
import Data.Generic.Rep (class Generic) as X
import Data.Generic.Rep.Eq (genericEq) as X
import Data.Generic.Rep.Ord (genericCompare) as X
import Data.Generic.Rep.Show (genericShow) as X
import Data.HashMap (HashMap) as X
import Data.HashSet (HashSet) as X
import Data.Hashable (class Hashable, hash) as X
import Data.List (List(..), (:)) as X
import Data.Map (Map) as X
import Data.Maybe (Maybe(..), fromMaybe, maybe) as X
import Data.Newtype (class Newtype, un, wrap) as X
import Data.Set (Set) as X
import Data.Traversable (class Traversable, traverse, for) as X
import Data.Tuple (Tuple(..), uncurry, fst, snd) as X
import Data.Tuple.Nested ((/\)) as X
import Data.Unfoldable (class Unfoldable) as X
import Debug.Trace (trace, traceM, spy) as X
import Effect (Effect) as X

module Lambda.Prelude
  ( module Prelude
  , module X
  ) where

import Prelude

import Control.Alt ((<|>)) as X
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM) as X
import Control.Monad.State (class MonadState, evalState, execState, gets, get, modify_, put) as X
import Data.Either (Either(..), either) as X
import Data.Foldable (class Foldable, fold, foldr, foldl, foldM, foldMap, for_, traverse_) as X
import Data.Generic.Rep (class Generic) as X
import Data.Generic.Rep.Eq (genericEq) as X
import Data.Generic.Rep.Ord (genericCompare) as X
import Data.Generic.Rep.Show (genericShow) as X
import Data.HashMap (HashMap) as X
import Data.HashSet (HashSet) as X
import Data.Hashable (class Hashable, hash) as X
import Data.List (List(..), (:)) as X
import Data.Map (Map) as X
import Data.Maybe (Maybe(..), fromMaybe, maybe) as X
import Data.Newtype (class Newtype, un, wrap) as X
import Data.Set (Set) as X
import Data.Traversable (class Traversable, traverse, for) as X
import Data.Tuple (Tuple(..), uncurry, fst, snd) as X
import Data.Tuple.Nested ((/\)) as X
import Data.Unfoldable (class Unfoldable) as X
import Effect (Effect) as X


React rendering is nice but the thermite bindings is not mature enough, may be time to look else where till then

module Example.Main where

import Debug.Trace
import Control.Monad.Eff

import qualified Thermite as T
import qualified Thermite.Html as T
import qualified Thermite.Html.Elements as T
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Action as T
import qualified Thermite.Events as T
import qualified Thermite.Types as T

-- To implement additional attribute types
import qualified Thermite.Internal as I

foreign import data ScrollSpy :: !

foreign import scrollspy
    "function scrollspy() { \
    \   $('body').scrollspy({ \
    \       target: '.bs-docs-sidebar', \
    \       offset: 40 \
    \   }); \
    \}" :: forall r. Eff (scrollspy :: ScrollSpy | r) Unit

foreign import data Affix :: !

foreign import affix
    "function affix() { \
    \   $('#sidebar').affix({ \
    \       offset: { \
    \           top: 60 \
    \       } \
    \   }); \
    \}" :: forall r. Eff (affix :: Affix | r) Unit

-- Footer renderer
footer :: T.Html _
footer =
    T.footer (A.className "footer")
        [ T.div (A.className "container-fluid")
            [ T.p (A.className "text-muted")
                [ T.text "Copyright © Anja Berens"
                ]
            ]
        ]

-- Navbar renderer
dataToggle :: String -> T.Attr
dataToggle = I.unsafeAttribute "data-toggle"

dataTarget :: String -> T.Attr
dataTarget = I.unsafeAttribute "data-target"

ariaExpanded :: String -> T.Attr
ariaExpanded = I.unsafeAttribute "aria-expanded"

ariaControls :: String -> T.Attr
ariaControls = I.unsafeAttribute "aria-controls"

-- TODO: Property - which navbar element is active
-- data Page = Dice | Docs | About
navbar :: T.Html _
navbar =
    T.nav (A.className "navbar navbar-default navbar-static-top")
        [ T.div (A.className "container-fluid")
            [ T.div (A.className "navbar-header")
                -- TODO: tweak when it collapses cos it collapses too soon at the moment
                -- Customize the @grid-float-breakpoint variable or add your own media query.
                [ T.button (A._type "button" <>
                            A.className "navbar-toggle collapsed" <>
                            dataToggle "collapse" <>
                            dataTarget "#navbar" <>
                            ariaExpanded "false" <>
                            ariaControls "navbar")
                    [ T.span (A.className "sr-only") [ T.text "Toggle navigation" ]
                    , T.span (A.className "icon-bar") []
                    , T.span (A.className "icon-bar") []
                    , T.span (A.className "icon-bar") []
                ]
            , T.a (A.className "navbar-brand" <> A.href "index.html") [ T.text "AllDice" ]
            ]
        , T.div (A._id "navbar" <> A.className "navbar-collapse collapse")
            [ T.ul (A.className "nav navbar-nav navbar-right")
                [ T.li (A.className "active") [ T.a (A.href "index.html") [ T.text "Dice" ] ]
                , T.li' [ T.a (A.href "documentation.html") [ T.text "Docs" ] ]
                , T.li' [ T.a (A.href "about.html") [ T.text "About" ] ]
                ]
            ]
        ]
    ]

-- Editor Renderer
formFor :: String -> T.Attr
formFor = I.unsafeAttribute "for"

-- TODO: state - editor stuff i suspect
-- TODO: default content of textarea (currently undefined, we probably want empty here)
-- TODO: property for available dice type, available data view
editor :: T.Html _
editor =
    T.div (A._id "diceInput")
        [ T.form'
            [ T.div (A.className "form-group")
                [ T.label (formFor "diceProgram") [ T.text "Dice Program" ]
                , T.textarea (A._id "diceProgram" <>
                              A.className "form-control" <>
                              A._type "text" <>
                              A.rows "10") []
                ]
            , T.div (A.className "form-inline")
                [ T.button (A._type "submit" <> A.className "btn btn-default") [ T.text "Submit" ]
                , T.div (A.className "form-group")
                    [ T.label (formFor "diceType") [ T.text "Program Type" ]
                    , T.select (A._id "diceType" <> A.className "form-control")
                        [ T.option' [ T.text "Scheme" ]
                        , T.option' [ T.text "PCGen" ]
                        ]
                    ]
                , T.div (A.className "form-group")
                    [ T.label (formFor "dataView") [ T.text "View" ]
                    , T.select (A._id "dataView" <> A.className "form-control")
                        [ T.option' [ T.text "Table" ]
                        , T.option' [ T.text "Graph" ]
                        ]
                    ]
                ]
            ]
        ]

-- Result Renderer
-- TODO: Property - crapton (data/etc)
result :: T.Html _
result =
    T.div (A._id "diceResult" <> A.className "panel panel-default")
        [ T.div (A.className "panel-body")
            [ T.text "Foobar"
            ]
        ]

-- Documentation Renderer
document :: T.Html _
document =
    T.div (A._id "content" <> A.className "container-fluid")
        [ T.div (A.className "row")
            [ T.div (A.className "col-xs-9" <> A.role "main") content
            , T.nav (A.className "col-xs-3 bs-docs-sidebar" <> A.role "complementary")
                [ T.ul (A._id "sidebar" <> A.className "nav nav-stacked") contentNav
                ]
            ]
        ]

content :: [T.Html _]
content =
    [ T.section (A._id "GroupA" <> A.className "group")
        [ T.h3' [ T.text "Group A" ]
        , T.div (A._id "GroupASub1" <> A.className "subgroup") [ T.h4' [ T.text "Group A Sub 1" ] ]
        , T.div (A._id "GroupASub2" <> A.className "subgroup") [ T.h4' [ T.text "Group A Sub 2" ] ]
        ]
    , T.section (A._id "GroupB" <> A.className "group")
        [ T.h3' [ T.text "Group B" ]
        , T.div (A._id "GroupBSub1" <> A.className "subgroup") [ T.h4' [ T.text "Group B Sub 1" ] ]
        , T.div (A._id "GroupBSub2" <> A.className "subgroup") [ T.h4' [ T.text "Group B Sub 2" ] ]
        ]
    , T.section (A._id "GroupC" <> A.className "group")
        [ T.h3' [ T.text "Group C" ]
        , T.div (A._id "GroupCSub1" <> A.className "subgroup") [ T.h4' [ T.text "Group C Sub 1" ] ]
        , T.div (A._id "GroupCSub2" <> A.className "subgroup") [ T.h4' [ T.text "Group C Sub 2" ] ]
        ]
    ]

contentNav :: [T.Html _]
contentNav =
    [ T.li'
        [ T.a (A.href "#GroupA") [ T.text "Group A" ]
        , T.ul (A.className "nav nav-stacked")
            [ T.li' [ T.a (A.href "#GroupASub1") [ T.text "Sub-Group 1" ] ]
            , T.li' [ T.a (A.href "#GroupASub2") [ T.text "Sub-Group 2" ] ]
            ]
        ]
    , T.li'
        [ T.a (A.href "#GroupB") [ T.text "Group B" ]
        , T.ul (A.className "nav nav-stacked")
            [ T.li' [ T.a (A.href "#GroupBSub1") [ T.text "Sub-Group 1" ] ]
            , T.li' [ T.a (A.href "#GroupBSub2") [ T.text "Sub-Group 2" ] ]
            ]
        ]
    , T.li'
        [ T.a (A.href "#GroupC") [ T.text "Group C" ]
        , T.ul (A.className "nav nav-stacked")
            [ T.li' [ T.a (A.href "#GroupCSub1") [ T.text "Sub-Group 1" ] ]
            , T.li' [ T.a (A.href "#GroupCSub2") [ T.text "Sub-Group 2" ] ]
            ]
        ]
    ]

-- About page render
about :: T.Html _
about =
    T.div (A.className "panel panel-default")
        [ T.div (A.className "panel-body")
            [ T.text "About stuff"
            ]
        ]

-- React bits for the navbar
data Page = Dice | Docs | About

data Action = GoTo Page
            | DoNothing

data State = State
           { page :: Page
           }

-- Setup for action bits
initialState :: State
initialState = State { page: Dice }

performAction :: T.PerformAction _ State _ Action
performAction _ action = T.modifyState (updateState action)
  where
    updateState :: Action -> State -> State
    updateState DoNothing = id

render :: T.Render _ State _ Action
render _ _ _ _ = T.body' [navbar, T.div (A.className "container-fluid") [editor, result], footer]

spec :: T.Spec _ State _ Action
spec = T.simpleSpec initialState performAction render
-- React bits

main = do
    trace "Setup reactjs"
    let component = T.createClass spec
    T.render component {}

    trace "Setup bootstrap"
    scrollspy
    affix

module Example.Main where

import Debug.Trace
import Control.Monad.Eff

import qualified Thermite as T
import qualified Thermite.Html as T
import qualified Thermite.Html.Elements as T
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Action as T
import qualified Thermite.Events as T
import qualified Thermite.Types as T

-- To implement additional attribute types
import qualified Thermite.Internal as I

foreign import data ScrollSpy :: !

foreign import scrollspy
    "function scrollspy() { \
    \   $('body').scrollspy({ \
    \       target: '.bs-docs-sidebar', \
    \       offset: 40 \
    \   }); \
    \}" :: forall r. Eff (scrollspy :: ScrollSpy | r) Unit

foreign import data Affix :: !

foreign import affix
    "function affix() { \
    \   $('#sidebar').affix({ \
    \       offset: { \
    \           top: 60 \
    \       } \
    \   }); \
    \}" :: forall r. Eff (affix :: Affix | r) Unit

-- Footer renderer
footer :: T.Html _
footer =
    T.footer (A.className "footer")
        [ T.div (A.className "container-fluid")
            [ T.p (A.className "text-muted")
                [ T.text "Copyright © Anja Berens"
                ]
            ]
        ]

-- Navbar renderer
dataToggle :: String -> T.Attr
dataToggle = I.unsafeAttribute "data-toggle"

dataTarget :: String -> T.Attr
dataTarget = I.unsafeAttribute "data-target"

ariaExpanded :: String -> T.Attr
ariaExpanded = I.unsafeAttribute "aria-expanded"

ariaControls :: String -> T.Attr
ariaControls = I.unsafeAttribute "aria-controls"

-- TODO: Property - which navbar element is active
navbar :: T.Html _
navbar =
    T.nav (A.className "navbar navbar-default navbar-static-top")
        [ T.div (A.className "container-fluid")
            [ T.div (A.className "navbar-header")
                -- TODO: tweak when it collapses cos it collapses too soon at the moment
                -- Customize the @grid-float-breakpoint variable or add your own media query.
                [ T.button (A._type "button" <>
                            A.className "navbar-toggle collapsed" <>
                            dataToggle "collapse" <>
                            dataTarget "#navbar" <>
                            ariaExpanded "false" <>
                            ariaControls "navbar")
                    [ T.span (A.className "sr-only") [ T.text "Toggle navigation" ]
                    , T.span (A.className "icon-bar") []
                    , T.span (A.className "icon-bar") []
                    , T.span (A.className "icon-bar") []
                ]
            , T.a (A.className "navbar-brand" <> A.href "index.html") [ T.text "AllDice" ]
            ]
        , T.div (A._id "navbar" <> A.className "navbar-collapse collapse")
            [ T.ul (A.className "nav navbar-nav navbar-right")
                [ T.li (A.className "active") [ T.a (A.href "index.html") [ T.text "Dice" ] ]
                , T.li' [ T.a (A.href "documentation.html") [ T.text "Docs" ] ]
                , T.li' [ T.a (A.href "about.html") [ T.text "About" ] ]
                ]
            ]
        ]
    ]

-- Editor Renderer
formFor :: String -> T.Attr
formFor = I.unsafeAttribute "for"

-- TODO: state - editor stuff i suspect
-- TODO: default content of textarea (currently undefined, we probably want empty here)
-- TODO: property for available dice type, available data view
editor :: T.Html _
editor =
    T.div (A._id "diceInput")
        [ T.form'
            [ T.div (A.className "form-group")
                [ T.label (formFor "diceProgram") [ T.text "Dice Program" ]
                , T.textarea (A._id "diceProgram" <>
                              A.className "form-control" <>
                              A._type "text" <>
                              A.rows "10") []
                ]
            , T.div (A.className "form-inline")
                [ T.button (A._type "submit" <> A.className "btn btn-default") [ T.text "Submit" ]
                , T.div (A.className "form-group")
                    [ T.label (formFor "diceType") [ T.text "Program Type" ]
                    , T.select (A._id "diceType" <> A.className "form-control")
                        [ T.option' [ T.text "Scheme" ]
                        , T.option' [ T.text "PCGen" ]
                        ]
                    ]
                , T.div (A.className "form-group")
                    [ T.label (formFor "dataView") [ T.text "View" ]
                    , T.select (A._id "dataView" <> A.className "form-control")
                        [ T.option' [ T.text "Table" ]
                        , T.option' [ T.text "Graph" ]
                        ]
                    ]
                ]
            ]
        ]

-- Result Renderer
-- TODO: Property - crapton (data/etc)
result :: T.Html _
result =
    T.div (A._id "diceResult" <> A.className "panel panel-default")
        [ T.div (A.className "panel-body")
            [ T.text "Foobar"
            ]
        ]

-- Documentation Renderer
document :: T.Html _
document =
    T.div (A._id "content" <> A.className "container-fluid")
        [ T.div (A.className "row")
            [ T.div (A.className "col-xs-9" <> A.role "main") content
            , T.nav (A.className "col-xs-3 bs-docs-sidebar" <> A.role "complementary")
                [ T.ul (A._id "sidebar" <> A.className "nav nav-stacked") contentNav
                ]
            ]
        ]

content :: [T.Html _]
content =
    [ T.section (A._id "GroupA" <> A.className "group")
        [ T.h3' [ T.text "Group A" ]
        , T.div (A._id "GroupASub1" <> A.className "subgroup") [ T.h4' [ T.text "Group A Sub 1" ] ]
        , T.div (A._id "GroupASub2" <> A.className "subgroup") [ T.h4' [ T.text "Group A Sub 2" ] ]
        ]
    , T.section (A._id "GroupB" <> A.className "group")
        [ T.h3' [ T.text "Group B" ]
        , T.div (A._id "GroupBSub1" <> A.className "subgroup") [ T.h4' [ T.text "Group B Sub 1" ] ]
        , T.div (A._id "GroupBSub2" <> A.className "subgroup") [ T.h4' [ T.text "Group B Sub 2" ] ]
        ]
    , T.section (A._id "GroupC" <> A.className "group")
        [ T.h3' [ T.text "Group C" ]
        , T.div (A._id "GroupCSub1" <> A.className "subgroup") [ T.h4' [ T.text "Group C Sub 1" ] ]
        , T.div (A._id "GroupCSub2" <> A.className "subgroup") [ T.h4' [ T.text "Group C Sub 2" ] ]
        ]
    ]

contentNav :: [T.Html _]
contentNav =
    [ T.li'
        [ T.a (A.href "#GroupA") [ T.text "Group A" ]
        , T.ul (A.className "nav nav-stacked")
            [ T.li' [ T.a (A.href "#GroupASub1") [ T.text "Sub-Group 1" ] ]
            , T.li' [ T.a (A.href "#GroupASub2") [ T.text "Sub-Group 2" ] ]
            ]
        ]
    , T.li'
        [ T.a (A.href "#GroupB") [ T.text "Group B" ]
        , T.ul (A.className "nav nav-stacked")
            [ T.li' [ T.a (A.href "#GroupBSub1") [ T.text "Sub-Group 1" ] ]
            , T.li' [ T.a (A.href "#GroupBSub2") [ T.text "Sub-Group 2" ] ]
            ]
        ]
    , T.li'
        [ T.a (A.href "#GroupC") [ T.text "Group C" ]
        , T.ul (A.className "nav nav-stacked")
            [ T.li' [ T.a (A.href "#GroupCSub1") [ T.text "Sub-Group 1" ] ]
            , T.li' [ T.a (A.href "#GroupCSub2") [ T.text "Sub-Group 2" ] ]
            ]
        ]
    ]

-- React bits for the navbar

-- React bits
data Action = DoNothing

data State = State { editText :: String }

initialState :: State
initialState = State { editText: "" }

performAction :: T.PerformAction _ State _ Action
performAction _ action = T.modifyState (updateState action)
  where
    updateState :: Action -> State -> State
    updateState DoNothing = id

render :: T.Render _ State _ Action
render _ _ _ _ = T.body' [navbar, T.div (A.className "container-fluid") [editor, result], footer]

spec :: T.Spec _ State _ Action
spec = T.simpleSpec initialState performAction render
-- React bits

main = do
    trace "Setup reactjs"
    let component = T.createClass spec
    T.render component {}

    trace "Setup bootstrap"
    scrollspy
    affix


Bought items are grey now

Bought items are grey now

module App.View.LoggedIn.Detail where

import App.Routes
import App.State
import App.Types
import Text.Smolder.HTML

import App.Events (Event(..))
import CSS (offset)
import Data.Foldable (for_)
import Data.List (List)
import Data.Maybe (Maybe(..))
import Prelude hiding (div)
import Pux.DOM.Events (onClick, onChange, onInput, targetValue)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML.Attributes as Attributes
import Text.Smolder.Markup ((#!), (!), text)
import App.View.LoggedIn (disableIfStringEmpty, createCheckbox)

view :: State -> HTML Event
view (State st) = div $ do
  button
    ! Attributes.className "btn btn-secondary mb-3"
    #! onClick (const $ PageView (LoggedIn Overview))
    $ text "regresar"
  case (getSelectedList (State st)) of
    Just sl -> showSelectedList sl st.newItemName
    Nothing -> span $ text "Error mientras cargar lista de compras"

-- TODO: datetime serialization
-- TODO: button for actually deleting?
-- TODO:
-- In a future version, have all lists be "selected", i.e. and in edit mode. then we'd need a component for this to be reusable with a state each
-- Alternatively, the overview in the main page could just be an overview, whereas on detail selection the actual items are loaded. this has the disadvantage of increased loading time

showSelectedList :: ShoppingList -> String -> HTML Event
showSelectedList (ShoppingList sl) newItemName = div do
  showList (ShoppingList sl) ( div do
    h5 $ text "Añadir artículo a la lista"
    form ! Attributes.className "form-inline" $ do
      div ! Attributes.className "form-group" $ do
        input
          ! Attributes.className "form-control"
          ! Attributes.value newItemName
          #! onChange (\ev -> ChangeNewItemName $ targetValue ev)
        (disableIfStringEmpty newItemName button )
          ! Attributes.className "btn btn-primary ml-1"
          #! onClick (const $ AddNewItem sl.id) $ text "añadir"
  )

showList :: ShoppingList -> HTML Event -> HTML Event
showList (ShoppingList shoppingList) transclusion =
  div ! Attributes.className "card" $ do
     div ! Attributes.className "card-body" $ do
       h2 ! Attributes.className "card-title text-info" $ text shoppingList.name
       ul ! Attributes.className "list-unstyled" $ for_ shoppingList.items showItem
       transclusion

showItem :: Item -> HTML Event
showItem (Item item) = li do
  -- using labels for the checkbox would be the most standard and accessible way,
  -- however it screws up bootstrap styling. so we just make everything clickable here
  div
    ! Attributes.className "input-group"
    #! onClick (const $ RequestToggleBoughtState item.id (not item.bought))
    $ do
      span ! Attributes.className "input-group-addon" $
        createCheckbox item.bought
      span
        ! Attributes.className ( "form-control form-control-plaintext span-with-border " <> (if item.bought then "text-muted" else "") )
        $ text item.name

module App.View.LoggedIn.Detail where

import App.Routes
import App.State
import App.Types
import Text.Smolder.HTML

import App.Events (Event(..))
import CSS (offset)
import Data.Foldable (for_)
import Data.List (List)
import Data.Maybe (Maybe(..))
import Prelude hiding (div)
import Pux.DOM.Events (onClick, onChange, onInput, targetValue)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML.Attributes as Attributes
import Text.Smolder.Markup ((#!), (!), text, class Attributable)
import App.View.LoggedIn (disableIfStringEmpty, createCheckbox)

view :: State -> HTML Event
view (State st) = div $ do
  button
    ! Attributes.className "btn btn-secondary mb-3"
    #! onClick (const $ PageView (LoggedIn Overview))
    $ text "regresar"
  case (getSelectedList (State st)) of
    Just sl -> showSelectedList sl st.newItemName
    Nothing -> span $ text "Error mientras cargar lista de compras"

-- TODO: datetime serialization
-- TODO: button for actually deleting?
-- TODO:
-- In a future version, have all lists be "selected", i.e. and in edit mode. then we'd need a component for this to be reusable with a state each
-- Alternatively, the overview in the main page could just be an overview, whereas on detail selection the actual items are loaded. this has the disadvantage of increased loading time

showSelectedList :: ShoppingList -> String -> HTML Event
showSelectedList (ShoppingList sl) newItemName = div do
  showList (ShoppingList sl) ( div do
    h5 $ text "Añadir artículo a la lista"
    form ! Attributes.className "form-inline" $ do
      div ! Attributes.className "form-group" $ do
        input
          ! Attributes.className "form-control"
          ! Attributes.value newItemName
          #! onChange (\ev -> ChangeNewItemName $ targetValue ev)
        (disableIfStringEmpty newItemName button )
          ! Attributes.className "btn btn-primary ml-1"
          #! onClick (const $ AddNewItem sl.id) $ text "añadir"
  )

showList :: ShoppingList -> HTML Event -> HTML Event
showList (ShoppingList shoppingList) transclusion =
  div ! Attributes.className "card" $ do
     div ! Attributes.className "card-body" $ do
       h2 ! Attributes.className "card-title text-info" $ text shoppingList.name
       ul ! Attributes.className "list-unstyled" $ for_ shoppingList.items showItem
       transclusion

showItem :: Item -> HTML Event
showItem (Item item) = li do
  -- using labels for the checkbox would be the most standard and accessible way,
  -- however it screws up bootstrap styling. so we just make everything clickable here
  div ! Attributes.className "input-group" #! onClick (const $ RequestToggleBoughtState item.id (not item.bought)) $ do
    span ! Attributes.className "input-group-addon" $
      createCheckbox item.bought
    span
      ! Attributes.className "form-control form-control-plaintext span-with-border"
      $ text item.name