Clean up, start splitting renderers into reasonable chunks

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
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.Bifunctor (bimap)
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens ((^.), (^?))
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.Newtype (unwrap)
import Data.Record as Record
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Unfoldable (class Unfoldable, none)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordInterval, CoordSys(CoordSys), Interval, Normalized(Normalized), _Index, _Interval, intervalToScreen, nPointToFrame, normPoint, 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 RowLacks)

type BrowserView = Interval BrowserPoint

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

type ChrCtx r = Map ChrId (Record r)

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

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

gwasDraw :: forall a. Color -> a -> Drawing
gwasDraw color =
  let r = 2.2
      c = circle 0.0 0.0 r
      out = outlined (outlineColor color) c
      fill = filled (fillColor color) c
  in const $ out <> fill

gwasPlace :: forall a r.
             { min :: Number, max :: Number | r }
          -> { chrSize :: a -> Maybe Bp
             , pos     :: a -> Bp
             , score   :: a -> Number }
          -> a
          -> Maybe (Normalized Point)
gwasPlace {min, max} get a = do
  size <- get.chrSize a
  let x = unwrap $ (get.pos a) / size
      y = (get.score a - min) / (max - min)
  normPoint {x, y}

gwasRenderer :: forall r rf.
                { min :: Number, max :: Number | r }
             -> Array (GWASFeature rf)
             -> { drawing :: Drawing
                , points :: Array (Normalized Point) }
gwasRenderer vs gwas = { drawing, points }
  where get = { chrSize: \a -> Map.lookup a.chrId mouseChrs
              , pos: _.pos, score: _.score }
        drawing = gwasDraw red unit
        points = filterMap (gwasPlace vs get) gwas

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               => {min :: Number, max :: Number, sig :: 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

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

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

drawPureInterval :: forall f r .
                    Foldable f
                 => { height :: Pixels | r }
                 -> { width :: Pixels, offset :: Pixels }
                 -> f { drawing :: Drawing, point :: Normalized Point }
                 -> Drawing
drawPureInterval {height} {width, offset} = foldMap render'
  where render' {drawing, point} =
          let {x,y} = nPointToFrame width height $ point
          in translate (x + offset) y drawing

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

      f :: Interval _  -> CoordInterval i _ -> { width :: _, offset :: _ }
      f iv c = (intervalToScreen canvasBox iv) (c^._Interval)

      g :: CoordInterval i _ -> Array { drawing :: _, point :: _ }
      g c = fromMaybe [] $ Map.lookup (c^._Index) drawings

      toDraw :: Interval BrowserPoint -> Array (Tuple _ (Array _))
      toDraw iv = (\x -> Tuple (f iv x) (g x)) <$> (viewIntervals cs iv)

      drawIvs :: Array (Tuple _ (Array _)) -> Drawing
      drawIvs = foldMap (uncurry $ drawPureInterval canvasBox)

      drawIvs' :: Array (Tuple _ (Array _)) -> Array Drawing
      drawIvs' = map (uncurry $ drawPureInterval canvasBox)

  in \bView -> translate 0.0 (canvasBox.height - canvasBox.yOffset)
                $ scale 1.0 (-1.0)
                $ drawIvs (toDraw bView)

shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: Number, sig :: 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'}

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)

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 :: forall r.
                 { min :: Number, max :: Number, sig :: 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 r1.
         { min :: Number, max :: Number, sig :: Number }
      -> Color
      -> { width :: Pixels, height :: Pixels, yOffset :: Pixels | r}
      -> Drawing
ruler {min, max, sig} color f = outlined outline rulerDrawing
  where normY = (sig - 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 r.
            Foldable f
         => Filterable f
         => CoordSys _ _
         -> { min :: Number, max :: Number, sig :: Number }
         -> { width :: Pixels, height :: Pixels, yOffset :: Pixels }
         -> { gwas   :: Map ChrId (f (GWASFeature ()))
            , annots :: Map ChrId (f (Annot (minY :: Number))) }
         -> Interval BrowserPoint
         -> Drawing
drawDemo cs s canvasBox {gwas, annots} =
  let renderers = renderersDemo s
      ruler' = ruler s red
      drawGwas   = drawData cs canvasBox renderers.gwas gwas
      drawAnnots = drawData cs canvasBox renderers.annots annots
  in \view -> (drawGwas view) <> (drawAnnots view) <> ruler' canvasBox

{-
TODO
there is currently no connection between the vertical scale's
position and the track. Need to take stuff like vertical
offset and padding into account; calculate once and use
in both places. However don't just use canvasheight - yoffset
or whatever; actually derive the top and bottom of the track.
-}

drawVScale :: forall r.
              Number
           -> Number
           -> { min :: Number, max :: Number, sig :: Number }
           -> Color
           -> Drawing
drawVScale width height vs col =
  -- should have some padding here too; hardcode for now
  let hPad = width  / 5.0
      vPad = height / 10.0
      x = width / 2.0
      y1 = vPad
      y2 = height - vPad
      n = (_ * 0.1) <<< Int.toNumber <$> (0 .. 10)
      p = Drawing.path [{x, y:y1}, {x, y:y2}]
      bar w y = Drawing.path [{x:x-w, y}, {x:x+w, y}]
      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 4.0 else 2.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft (x+12.0) y (fillColor black)
      top = mkT y1 $ show vs.max
      btm = mkT y2 $ show vs.min

  in outlined (outlineColor col <> lineWidth 2.0) (p <> ps) <>
     top <> btm

drawLegendItem :: Number
               -> { text :: String, icon :: Drawing }
               -> Drawing
drawLegendItem w {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

drawLegend :: Number
           -> Number
           -> Array { text :: String, icon :: Drawing }
           -> Drawing
drawLegend width height icons =
  let hPad = width  / 5.0
      vPad = height / 5.0
      n :: Int
      n = length icons
      x = hPad
      f :: Number -> { text :: String, icon :: Drawing } -> Drawing
      f y ic = translate x y $ drawLegendItem (width - 2.0*hPad) ic
      d = (height - 2.0*vPad) / (length icons)
      ds = mapWithIndex (\i ic -> f (vPad+(vPad*(Int.toNumber i))) ic) icons
  in fold ds

mkIcon :: Color -> String -> { text :: String, icon :: Drawing }
mkIcon c text =
  let sh = circle (-2.5) (-2.5) 5.0
      icon = outlined (outlineColor c <> lineWidth 2.0) sh <>
             filled (fillColor c) sh
  in {text, icon}

demoLegend :: Array {text :: String, icon :: Drawing}
demoLegend =
  [ mkIcon red "Red thing"
  , mkIcon blue "blue thing"
  , mkIcon purple "boop"
  ]

              -- the first 2 are used by all parts of the browser
demoBrowser :: forall f.
               Foldable f
            => Filterable f
            => CoordSys ChrId BrowserPoint
            -> { width :: Pixels, height :: Pixels }
            -- this by the vertical scale and the tracks
            -> { min :: Number, max :: Number, sig :: Number }
            -- these define the width of the non-track parts of the browser;
            -- the browser takes up the remaining space.
            -> { vScaleWidth :: Pixels
               , legendWidth :: Pixels }
            -- vScale only
            -> Color
            -- to be drawn in the legend on the RHS
            -> Array { text :: String, icon :: Drawing }
            -- finally, used by the main track
            -> { gwas :: Map ChrId (f (GWASFeature ()))
               , annots :: Map ChrId (f (Annot (minY :: Number))) }
            -> Interval BrowserPoint
            -- the drawing produced contains all 3 parts.
            -> { track :: Drawing, overlay :: Drawing }
demoBrowser cs canvas vscale sizes vscaleColor legend {gwas, annots} =
  let trackCanvas = { width: canvas.width - sizes.vScaleWidth - sizes.legendWidth
                    , height: canvas.height, yOffset: 0.0 }

      h = canvas.height

      bg w' h' = filled (fillColor white) $ rectangle 0.0 0.0 w' h'

      vScale :: _ -> Drawing
      vScale _ = let w = sizes.vScaleWidth
                 in  bg w h
                  <> drawVScale w h vscale vscaleColor

      track v = translate sizes.vScaleWidth 0.0
                  $ drawDemo cs vscale trackCanvas {gwas, annots} v

      legendD :: _ -> Drawing
      legendD _ = let w = sizes.legendWidth
                  in translate (canvas.width - w) 0.0
                    $ (bg w h
                    <> drawLegend sizes.legendWidth canvas.height legend)

  in \view -> { track: track view
              , overlay: vScale view <> legendD view }

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, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
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.Bifunctor (bimap)
import Data.Filterable (class Filterable, filterMap)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens ((^.), (^?))
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.Newtype (unwrap)
import Data.Record as Record
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Unfoldable (class Unfoldable, none)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordInterval, CoordSys(CoordSys), Interval, Normalized(Normalized), _Index, _Interval, intervalToScreen, nPointToFrame, normPoint, 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 RowLacks)

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

type ChrCtx r = Map ChrId (Record r)

-- 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 Drawable a r      = ( draw  :: a -> Drawing | r )
type Placeable a r     = ( place :: a -> Maybe (Normalized Point) | r )
type Scorable a r      = ( score :: a -> Number | r )
-- `Categorizable` means there's a categorical/qualitative difference between
-- some members of `a`. e.g. a bunch of SNPs in a GWAS track are not,
-- since the only difference is really their position and value (Chr could arguably be categorized, but eh),
-- but annotations could be, where the categories are e.g. what kind of trait
-- for a concrete example, in https://raw.githubusercontent.com/genetics-statistics/GEMMA/master/cfw.gif
-- the annotation categories would be "Muscle or bone", "Other physiological trait", "Behavior".
type Categorizable a r = ( categorize :: a -> String | r )

type Renderable a r = Drawable  a (Placeable a r)
type Scaleable  a r = Placeable a (Scorable a r)

emptyTrack :: forall a.
              Record
              (Drawable a
               (Placeable a
                (Scorable a
                 (Categorizable a ()))))
emptyTrack = { draw: const mempty
             , place: const Nothing
             , score: const zero
             , categorize: const mempty
             }

{-
idea:
configurations for a track define how these various "actions"
are performed, i.e. how a thing is drawn, placed, categorized, etc.

parsing a configuration, then, produces a list of
Variants:
  List (Variant (Drawable (Placeable _))) etc.

then we can apply each variant individually to automate the
process of mapping a "track" or w/e to the various browser parts,
simply returning mempty (since it's all a Drawing in the end, for now)
if a given track does not support some action.

problem: lose help from the type system. need to think more
  is this a problem?
  only (obvious) risk is forgetting to implement one of the things...
  which is pretty obvious when it happens, hopefully why, too.
  becomes even less of a problem when configuration is added;
  we still have the type system's help for actually typing each of
  the actions individually.
-}

render :: forall f a r.
          Filterable f
       => Record (Renderable a r)
       -> f a
       -> f { drawing :: Drawing, point :: Normalized Point }
render { draw, place } = filterMap f
  where f a = do
          point <- place a
          let drawing = draw a
          pure { drawing, point }

scaledPoint :: forall a r r'.
               Record (Scaleable a r)
            -> { min :: Number, max :: Number | r' }
            -> a
            -> Maybe (Normalized Point)
scaledPoint { place, score } { min, max } a = do
  (Normalized pt) <- place a
  normPoint $ pt { y = (pt.y - min) / (max - min) }

mkLegend :: forall a r f.
            Functor f
         => Record (Categorizable a (Drawable a r))
         -> f a
         -> f { text :: String, icon :: Drawing }
mkLegend { categorize, draw } = map f
  where f a = let text = categorize a
                  icon = draw a
              in { text, icon }

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

-- TODO Instead of tag & combine, we can just use Variant.match & Record.Builder!
-- tagRenderer :: forall a sym r1 r2.
-- combineRenderers :: forall r1 r2 r3.

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

mkGwasRenderer :: forall m rf rctx.
                  MonadReader (ChrCtx (size :: Bp, color :: Color | rctx)) m
               => {min :: Number, max :: Number, sig :: 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

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

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

drawPureInterval :: forall f r .
                    Foldable f
                 => { height :: Pixels | r }
                 -> { width :: Pixels, offset :: Pixels }
                 -> f { drawing :: Drawing, point :: Normalized Point }
                 -> Drawing
drawPureInterval {height} {width, offset} = foldMap render'
  where render' {drawing, point} =
          let {x,y} = nPointToFrame width height $ point
          in translate (x + offset) y drawing

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

      f :: Interval _  -> CoordInterval i _ -> { width :: _, offset :: _ }
      f iv c = (intervalToScreen canvasBox iv) (c^._Interval)

      g :: CoordInterval i _ -> Array { drawing :: _, point :: _ }
      g c = fromMaybe [] $ Map.lookup (c^._Index) drawings

      toDraw :: Interval BrowserPoint -> Array (Tuple _ (Array _))
      toDraw iv = (\x -> Tuple (f iv x) (g x)) <$> (viewIntervals cs iv)

      drawIvs :: Array (Tuple _ (Array _)) -> Drawing
      drawIvs = foldMap (uncurry $ drawPureInterval canvasBox)

      drawIvs' :: Array (Tuple _ (Array _)) -> Array Drawing
      drawIvs' = map (uncurry $ drawPureInterval canvasBox)

  in \bView -> translate 0.0 (canvasBox.height - canvasBox.yOffset)
                $ scale 1.0 (-1.0)
                $ drawIvs (toDraw bView)

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

      f :: Interval _  -> CoordInterval i _ -> { width :: _, offset :: _ }
      f iv c = (intervalToScreen canvasBox iv) (c^._Interval)

      g :: CoordInterval i _ -> f { drawing :: _, point :: _ }
      g c = fromMaybe none $ Map.lookup (c^._Index) drawings

      toDraw :: Interval BrowserPoint -> f (Tuple _ (f _))
      toDraw iv = (\x -> Tuple (f iv x) (g x)) <$>
                  (Array.toUnfoldable $ viewIntervals cs iv)

      drawIvs :: f (Tuple _ (f _)) -> f Drawing
      drawIvs = map (uncurry $ drawPureInterval canvasBox)

  in \bView -> translate 0.0 (canvasBox.height - canvasBox.yOffset)
                <<< scale 1.0 (-1.0)
                <$> drawIvs (toDraw bView)

shiftRendererMinY :: forall rf.
                      RowLacks "minY" rf
                   => Number
                   -> { min :: Number, max :: Number, sig :: 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'}

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)

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 :: forall r.
                 { min :: Number, max :: Number, sig :: 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 r1.
         { min :: Number, max :: Number, sig :: Number }
      -> Color
      -> { width :: Pixels, height :: Pixels, yOffset :: Pixels | r}
      -> Drawing
ruler {min, max, sig} color f = outlined outline rulerDrawing
  where normY = (sig - 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 r.
            Foldable f
         => Filterable f
         => CoordSys _ _
         -> { min :: Number, max :: Number, sig :: Number }
         -> { width :: Pixels, height :: Pixels, yOffset :: Pixels }
         -> { gwas   :: Map ChrId (f (GWASFeature ()))
            , annots :: Map ChrId (f (Annot (minY :: Number))) }
         -> Interval BrowserPoint
         -> Drawing
drawDemo cs s canvasBox {gwas, annots} =
  let renderers = renderersDemo s
      ruler' = ruler s red
      drawGwas   = drawData cs canvasBox renderers.gwas gwas
      drawAnnots = drawData cs canvasBox renderers.annots annots
  in \view -> (drawGwas view) <> (drawAnnots view) <> ruler' canvasBox

drawDemo' :: forall f r.
             Foldable f
          => Unfoldable f
          => Filterable f
          => CoordSys _ _
          -> { min :: Number, max :: Number, sig :: Number }
          -> { width :: Pixels, height :: Pixels, yOffset :: Pixels }
          -> { gwas   :: Map ChrId (f (GWASFeature ()))
             , annots :: Map ChrId (f (Annot (minY :: Number))) }
          -> Interval BrowserPoint
          -> Tuple Drawing (Array Drawing)
drawDemo' cs s canvasBox {gwas, annots} =
  let renderers = renderersDemo s
      ruler' = ruler s red
      drawGwas   = Array.fromFoldable <$> drawData' cs canvasBox renderers.gwas gwas
      drawAnnots = drawData cs canvasBox renderers.annots annots
  in \view -> Tuple (drawAnnots view <> ruler' canvasBox) (drawGwas view)

{-
TODO
there is currently no connection between the vertical scale's
position and the track. Need to take stuff like vertical
offset and padding into account; calculate once and use
in both places. However don't just use canvasheight - yoffset
or whatever; actually derive the top and bottom of the track.
-}

drawVScale :: forall r.
              Number
           -> Number
           -> { min :: Number, max :: Number, sig :: Number }
           -> Color
           -> Drawing
drawVScale width height vs col =
  -- should have some padding here too; hardcode for now
  let hPad = width  / 5.0
      vPad = height / 10.0
      x = width / 2.0
      y1 = vPad
      y2 = height - vPad
      n = (_ * 0.1) <<< Int.toNumber <$> (0 .. 10)
      p = Drawing.path [{x, y:y1}, {x, y:y2}]
      bar w y = Drawing.path [{x:x-w, y}, {x:x+w, y}]
      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 4.0 else 2.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft (x+12.0) y (fillColor black)
      top = mkT y1 $ show vs.max
      btm = mkT y2 $ show vs.min

  in outlined (outlineColor col <> lineWidth 2.0) (p <> ps) <>
     top <> btm

drawLegendItem :: Number
               -> { text :: String, icon :: Drawing }
               -> Drawing
drawLegendItem w {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

drawLegend :: Number
           -> Number
           -> Array { text :: String, icon :: Drawing }
           -> Drawing
drawLegend width height icons =
  let hPad = width  / 5.0
      vPad = height / 5.0
      n :: Int
      n = length icons
      x = hPad
      f :: Number -> { text :: String, icon :: Drawing } -> Drawing
      f y ic = translate x y $ drawLegendItem (width - 2.0*hPad) ic
      d = (height - 2.0*vPad) / (length icons)
      ds = mapWithIndex (\i ic -> f (vPad+(vPad*(Int.toNumber i))) ic) icons
  in fold ds

mkIcon :: Color -> String -> { text :: String, icon :: Drawing }
mkIcon c text =
  let sh = circle (-2.5) (-2.5) 5.0
      icon = outlined (outlineColor c <> lineWidth 2.0) sh <>
             filled (fillColor c) sh
  in {text, icon}

demoLegend :: Array {text :: String, icon :: Drawing}
demoLegend =
  [ mkIcon red "Red thing"
  , mkIcon blue "blue thing"
  , mkIcon purple "boop"
  ]

              -- the first 2 are used by all parts of the browser
demoBrowser :: forall f.
               Foldable f
            => Filterable f
            => CoordSys ChrId BrowserPoint
            -> { width :: Pixels, height :: Pixels }
            -- this by the vertical scale and the tracks
            -> { min :: Number, max :: Number, sig :: Number }
            -- these define the width of the non-track parts of the browser;
            -- the browser takes up the remaining space.
            -> { vScaleWidth :: Pixels
               , legendWidth :: Pixels }
            -- vScale only
            -> Color
            -- to be drawn in the legend on the RHS
            -> Array { text :: String, icon :: Drawing }
            -- finally, used by the main track
            -> { gwas :: Map ChrId (f (GWASFeature ()))
               , annots :: Map ChrId (f (Annot (minY :: Number))) }
            -> Interval BrowserPoint
            -- the drawing produced contains all 3 parts.
            -> { track :: Drawing, overlay :: Drawing }
demoBrowser cs canvas vscale sizes vscaleColor legend {gwas, annots} =
  let trackCanvas = { width: canvas.width - sizes.vScaleWidth - sizes.legendWidth
                    , height: canvas.height, yOffset: 0.0 }

      h = canvas.height

      bg w' h' = filled (fillColor white) $ rectangle 0.0 0.0 w' h'

      vScale :: _ -> Drawing
      vScale _ = let w = sizes.vScaleWidth
                 in  bg w h
                  <> drawVScale w h vscale vscaleColor

      track v = translate sizes.vScaleWidth 0.0
                  $ drawDemo cs vscale trackCanvas {gwas, annots} v

      legendD :: _ -> Drawing
      legendD _ = let w = sizes.legendWidth
                  in translate (canvas.width - w) 0.0
                    $ (bg w h
                    <> drawLegend sizes.legendWidth canvas.height legend)

  in \view -> { track: track view
              , overlay: vScale view <> legendD view }

demoBrowser' :: forall f.
                Foldable f
             => Unfoldable f
             => Filterable f
             => CoordSys ChrId BrowserPoint
             -> { width :: Pixels, height :: Pixels }
             -- this by the vertical scale and the tracks
             -> { min :: Number, max :: Number, sig :: Number }
             -- these define the width of the non-track parts of the browser;
             -- the browser takes up the remaining space.
             -> { vScaleWidth :: Pixels
                , legendWidth :: Pixels }
             -- vScale only
             -> Color
             -- to be drawn in the legend on the RHS
             -> Array { text :: String, icon :: Drawing }
             -- finally, used by the main track
             -> { gwas :: Map ChrId (f (GWASFeature ()))
                , annots :: Map ChrId (f (Annot (minY :: Number))) }
             -> Interval BrowserPoint
             -- the drawing produced contains all 3 parts.
             -> Tuple Drawing (Array Drawing)
demoBrowser' cs canvas vscale sizes vscaleColor legend {gwas, annots} =
  let trackCanvas = { width: canvas.width - sizes.vScaleWidth - sizes.legendWidth
                    , height: canvas.height, yOffset: 0.0 }

      vScale :: _ -> Drawing
      vScale _ = drawVScale sizes.vScaleWidth canvas.height vscale vscaleColor

      track :: _ -> _
      track v = let f = translate sizes.vScaleWidth 0.0
                in bimap f (map f) $ drawDemo' cs vscale trackCanvas {gwas, annots} v

      legendD :: _ -> Drawing
      legendD _ = translate (canvas.width - sizes.legendWidth) 0.0
                    $ drawLegend sizes.legendWidth canvas.height legend

  in \view -> let (Tuple bg ds) = track view
              in Tuple (vScale view <> bg <> legendD view) ds

-- the browser as an entire thing can be split into
-- some functions for drawing it given a current view;
-- this is because (for now) the only state that can
-- change is the view.
-- components of the browser can thus simply be provided
-- as a foldable containing the components.

-- More generally, this is some kinda comonad, certainly
-- contravariant, and it should be possible to use those
-- abstractions to construct a nice interface!
-- applicative something.
browser :: forall f.
           Foldable f
        => Filterable f
        => f { width :: Pixels
             , draw  :: Interval BrowserPoint -> Drawing}
        -> Interval BrowserPoint
        -> Drawing
-- TODO sum up offsets so the translation is correct
browser parts bView = foldMap (\p -> translate p.width 0.0 $ p.draw bView) parts

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


Import from Partial explicitly

Import from Partial explicitly

-- | Utilities for working with partial functions.
module Partial.Unsafe
  ( unsafePartial
  , unsafeCrashWith
  ) where

import Partial (crashWith)

-- | Discharge a partiality constraint, unsafely.
foreign import unsafePartial :: forall a. (Partial => a) -> a

-- | A function which crashes with the specified error message.
unsafeCrashWith :: forall a. String -> a
unsafeCrashWith msg = unsafePartial (crashWith msg)

-- | Utilities for working with partial functions.
module Partial.Unsafe
  ( unsafePartial
  , unsafeCrashWith
  ) where

-- | Discharge a partiality constraint, unsafely.
foreign import unsafePartial :: forall a. (Partial => a) -> a

-- | A function which crashes with the specified error message.
unsafeCrashWith :: forall a. String -> a
unsafeCrashWith msg = unsafePartial (Partial.crashWith msg)


fix ReferenceError on `Data_Maybe`

fix ReferenceError on `Data_Maybe`

it seems PS has been updated and everything is under a global `PS` object now.

module Data.DOM.Simple.Unsafe.Utils where

import Data.Maybe

forceImport = Just "a"

foreign import ensure
  "function ensure(v) {                         \
  \  if (v === undefined || v === null) {       \
  \    return new PS.Data_Maybe.Nothing;           \
  \  } else {                                   \
  \    return new PS.Data_Maybe.Just(v);           \
  \  }                                          \
  \}" :: forall a. a -> Maybe a

foreign import showImpl
  "function showImpl(v) {   \
  \  return function () {   \
  \    return v.toString(); \
  \  };                     \
  \}" :: forall a. a -> String

module Data.DOM.Simple.Unsafe.Utils where

import Data.Maybe

forceImport = Just "a"

foreign import ensure
  "function ensure(v) {                         \
  \  if (v === undefined || v === null) {       \
  \    return new Data_Maybe.Nothing;           \
  \  } else {                                   \
  \    return new Data_Maybe.Just(v);           \
  \  }                                          \
  \}" :: forall a. a -> Maybe a

foreign import showImpl
  "function showImpl(v) {   \
  \  return function () {   \
  \    return v.toString(); \
  \  };                     \
  \}" :: forall a. a -> String


Leave notes on desc parser

Leave notes on desc parser

module Language.Docopt.Parser.Desc where

import Prelude
import Debug.Trace
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (get)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Data.List (List(..), some, (:), toList, length
                 , singleton, many, head, catMaybes, filter)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.Foldable (intercalate)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Generic
import Data.String (toLower, fromChar)
import qualified Data.Array as A
import qualified Data.String as Str

import Language.Docopt.Value
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.Common
import Language.Docopt.Parser.State
import Language.Docopt.Parser.Lexer (lex)
import qualified Language.Docopt.Parser.Lexer as L

data Desc = OptionDesc Option
          | CommandDesc

data Name = Flag Char | Long String | Full Char String

getFlag :: Name -> Maybe Char
getFlag (Flag c)   = pure c
getFlag (Full c _) = pure c
getFlag _          = Nothing

getName :: Name -> Maybe String
getName (Long   n) = pure n
getName (Full _ n) = pure n
getName _          = Nothing

newtype Argument = Argument {
  name    :: String
, default :: Maybe Value
}

runArgument :: Argument -> {
  name    :: String
, default :: Maybe Value
}
runArgument (Argument a) = a

newtype Option = Option {
  name :: Name
, arg  :: Maybe Argument
, env  :: Maybe String
}

data Content
  = Text
  | Default String
  | Env     String

isDefaultTag :: Content -> Boolean
isDefaultTag (Default _) = true
isDefaultTag _           = false

getDefaultValue :: Content -> Maybe String
getDefaultValue (Default v) = Just v
getDefaultValue _           = Nothing

isEnvTag :: Content -> Boolean
isEnvTag (Env _) = true
isEnvTag _       = false

getEnvKey :: Content -> Maybe String
getEnvKey (Env k) = Just k
getEnvKey _       = Nothing

derive instance genericDesc     :: Generic Desc
derive instance genericArgument :: Generic Argument
derive instance genericName     :: Generic Name
derive instance genericOption   :: Generic Option
derive instance genericContent  :: Generic Content

instance showDesc :: Show Desc
  where show = gShow

instance showOption :: Show Option
  where show = gShow

instance showArgument :: Show Argument
  where show = gShow

instance showName :: Show Name
  where show = gShow

instance showContent :: Show Content
  where show = gShow

instance eqOption :: Eq Option
  where eq = gEq

instance eqArgument :: Eq Argument
  where eq = gEq

instance eqName :: Eq Name
  where eq = gEq

instance eqDesc :: Eq Desc
  where eq = gEq

prettyPrintDesc :: Desc -> String
prettyPrintDesc (OptionDesc opt) = "Option " ++ prettyPrintOption opt

prettyPrintOption :: Option -> String
prettyPrintOption (Option opt)
  = (name opt.name) ++ arg ++ env
  where
      name (Flag c)   = "-" ++ fromChar c
      name (Long n)   = "--" ++ n
      name (Full c n) = "-" ++ fromChar c ++ ", --" ++ n

      arg = maybe "" id do
        (Argument a) <- opt.arg
        return $ "=" ++ a.name ++ case a.default of
                                    Nothing  -> ""
                                    (Just v) -> " [default: "
                                                    ++ prettyPrintValue v
                                                    ++ "]"

      env = maybe "" id do
        k <- opt.env
        return $ " [env: " ++ k ++ "]"

prettyPrintArgument :: Argument -> String
prettyPrintArgument (Argument { name: n, default: d })
  = n ++ maybe "" (\v -> " [default: " ++ (prettyPrintValue v) ++  "]") d

argument :: String -> Maybe String -> Argument
argument name default = Argument { name:    name
                                 , default: StringValue <$> default
                                 }

run :: String -> Either P.ParseError (List Desc)
run x = lex x >>= parse

parse :: (List L.PositionedToken) -> Either P.ParseError (List Desc)
parse = flip L.runTokenParser descParser

descParser :: L.TokenParser (List Desc)
descParser =
  markIndent do
    opt  <- option
    opts <- many $ sameIndent *> option
    return (opt : opts)
  where

    anyName :: L.TokenParser String
    anyName = L.angleName <|> L.shoutName <|> L.name

    option :: L.TokenParser Desc
    option = do
      xopt@(Option opt) <- start

      description <- do
        flip P.manyTill (L.eof <|> (P.lookAhead $ P.try $ void start)) do
          P.choice $ P.try <$> [
            Default <$> L.tag "default"
          , Env     <$> L.tag "env"
          , L.anyToken *> pure Text
          ]

      let defaults = getDefaultValue <$> filter isDefaultTag description
          envs     = getEnvKey       <$> filter isEnvTag     description

      if (length defaults > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple defaults!"
         else return unit

      if (length envs > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple environment mappings!"
         else return unit

      let default = head defaults >>= id
          env     = head envs     >>= id

      if (isJust default) && (not $ isJust opt.arg)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " does not take arguments. "
                    ++ "Cannot specify defaults."
         else return unit

      return $ OptionDesc $ Option $
        opt { env = env
            , arg = do
                (Argument arg) <- opt.arg
                return $ Argument $ arg {
                  default = StringValue <$> default
                }
            }

      where

        -- XXX: This parser needs to be extended to parse adjacent 'name'
        --      tokens as potential arguments:
        --      `-p PATH`, `-p, --path PATH`, `-p PATH, --path PATH`.

        start :: L.TokenParser Option
        start = do
          P.choice $ P.try <$> [
            short <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> long, long ]
          , long <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> short, short ]
          , both
          ]

        short :: L.TokenParser Option
        short = do
          opt <- sopt
          return $ Option { name: Flag opt.flag
                          , arg:  flip argument Nothing <$> opt.arg
                          , env:  Nothing
                          }

        long :: L.TokenParser Option
        long = do
          opt <- lopt
          return $ Option { name: Long opt.name
                          , arg:  flip argument Nothing <$>  opt.arg
                          , env:  Nothing
                          }

        both :: L.TokenParser Option
        both = markLine do
          x <- short
          y <- do sameLine
                  P.choice $ P.try <$> [ L.comma *> long
                                       , long
                                       ]
          combine x y

          where
            -- Combine two options into one. This function *does not* cover all
            -- cases right now. It deals only with a known subset and can there-
            -- fore make assumptions
            combine :: Option -> Option -> L.TokenParser Option
            combine (Option x@{ name: Flag f }) (Option y@{ name: Long n }) = do
              either P.fail return do
                arg <- combineArg x.arg y.arg
                return $ Option {
                  name: Full f n
                , arg: arg
                , env: Nothing -- No need to keep at this stage
                }

              where
                combineArg (Just a) (Just b) | (a == b) = return (pure a)
                combineArg Nothing  (Just b)            = return (pure b)
                combineArg (Just a) Nothing             = return (pure a)
                combineArg Nothing Nothing              = return Nothing
                combineArg (Just a) (Just b) | (a /= b) = Left $
                        "Arguments mismatch: " ++ (show $ prettyPrintArgument a)
                                    ++ " and " ++ (show $ prettyPrintArgument b)

    sopt :: L.TokenParser { flag :: Char, arg :: Maybe String }
    sopt = do
      opt <- L.sopt
      (guard $ (A.length opt.stack == 0)) P.<?> "No stacked options"
      return { flag: opt.flag, arg: opt.arg }

    lopt :: L.TokenParser { name :: String, arg :: Maybe String }
    lopt = L.lopt

module Language.Docopt.Parser.Desc where

import Prelude
import Debug.Trace
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (get)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Data.List (List(..), some, (:), toList, length
                 , singleton, many, head, catMaybes, filter)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.Foldable (intercalate)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Generic
import Data.String (toLower, fromChar)
import qualified Data.Array as A
import qualified Data.String as Str

import Language.Docopt.Value
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.Common
import Language.Docopt.Parser.State
import Language.Docopt.Parser.Lexer (lex)
import qualified Language.Docopt.Parser.Lexer as L

data Desc = OptionDesc Option
          | CommandDesc

data Name = Flag Char | Long String | Full Char String

getFlag :: Name -> Maybe Char
getFlag (Flag c)   = pure c
getFlag (Full c _) = pure c
getFlag _          = Nothing

getName :: Name -> Maybe String
getName (Long   n) = pure n
getName (Full _ n) = pure n
getName _          = Nothing

newtype Argument = Argument {
  name    :: String
, default :: Maybe Value
}

runArgument :: Argument -> {
  name    :: String
, default :: Maybe Value
}
runArgument (Argument a) = a

newtype Option = Option {
  name :: Name
, arg  :: Maybe Argument
, env  :: Maybe String
}

data Content
  = Text
  | Default String
  | Env     String

isDefaultTag :: Content -> Boolean
isDefaultTag (Default _) = true
isDefaultTag _           = false

getDefaultValue :: Content -> Maybe String
getDefaultValue (Default v) = Just v
getDefaultValue _           = Nothing

isEnvTag :: Content -> Boolean
isEnvTag (Env _) = true
isEnvTag _       = false

getEnvKey :: Content -> Maybe String
getEnvKey (Env k) = Just k
getEnvKey _       = Nothing

derive instance genericDesc     :: Generic Desc
derive instance genericArgument :: Generic Argument
derive instance genericName     :: Generic Name
derive instance genericOption   :: Generic Option
derive instance genericContent  :: Generic Content

instance showDesc :: Show Desc
  where show = gShow

instance showOption :: Show Option
  where show = gShow

instance showArgument :: Show Argument
  where show = gShow

instance showName :: Show Name
  where show = gShow

instance showContent :: Show Content
  where show = gShow

instance eqOption :: Eq Option
  where eq = gEq

instance eqArgument :: Eq Argument
  where eq = gEq

instance eqName :: Eq Name
  where eq = gEq

instance eqDesc :: Eq Desc
  where eq = gEq

prettyPrintDesc :: Desc -> String
prettyPrintDesc (OptionDesc opt) = "Option " ++ prettyPrintOption opt

prettyPrintOption :: Option -> String
prettyPrintOption (Option opt)
  = (name opt.name) ++ arg ++ env
  where
      name (Flag c)   = "-" ++ fromChar c
      name (Long n)   = "--" ++ n
      name (Full c n) = "-" ++ fromChar c ++ ", --" ++ n

      arg = maybe "" id do
        (Argument a) <- opt.arg
        return $ "=" ++ a.name ++ case a.default of
                                    Nothing  -> ""
                                    (Just v) -> " [default: "
                                                    ++ prettyPrintValue v
                                                    ++ "]"

      env = maybe "" id do
        k <- opt.env
        return $ " [env: " ++ k ++ "]"

prettyPrintArgument :: Argument -> String
prettyPrintArgument (Argument { name: n, default: d })
  = n ++ maybe "" (\v -> " [default: " ++ (prettyPrintValue v) ++  "]") d

argument :: String -> Maybe String -> Argument
argument name default = Argument { name:    name
                                 , default: StringValue <$> default
                                 }

run :: String -> Either P.ParseError (List Desc)
run x = lex x >>= parse

parse :: (List L.PositionedToken) -> Either P.ParseError (List Desc)
parse = flip L.runTokenParser descParser

descParser :: L.TokenParser (List Desc)
descParser =
  markIndent do
    opt  <- option
    opts <- many $ sameIndent *> option
    return (opt : opts)
  where

    anyName :: L.TokenParser String
    anyName = L.angleName <|> L.shoutName <|> L.name

    option :: L.TokenParser Desc
    option = do
      xopt@(Option opt) <- start

      description <- do
        flip P.manyTill (L.eof <|> (P.lookAhead $ P.try $ void start)) do
          P.choice $ P.try <$> [
            Default <$> L.tag "default"
          , Env     <$> L.tag "env"
          , L.anyToken *> pure Text
          ]

      let defaults = getDefaultValue <$> filter isDefaultTag description
          envs     = getEnvKey       <$> filter isEnvTag     description

      if (length defaults > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple defaults!"
         else return unit

      if (length envs > 1)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " has multiple environment mappings!"
         else return unit

      let default = head defaults >>= id
          env     = head envs     >>= id

      if (isJust default) && (not $ isJust opt.arg)
         then P.fail $
          "Option " ++ (show $ prettyPrintOption xopt)
                    ++ " does not take arguments. "
                    ++ "Cannot specify defaults."
         else return unit

      return $ OptionDesc $ Option $
        opt { env = env
            , arg = do
                (Argument arg) <- opt.arg
                return $ Argument $ arg {
                  default = StringValue <$> default
                }
            }

      where

        start :: L.TokenParser Option
        start = do
          P.choice $ P.try <$> [
            short <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> long, long ]
          , long <* do
              P.notFollowedBy do
                P.choice $ P.try <$> [ L.comma *> short, short ]
          , both
          ]

        short :: L.TokenParser Option
        short = do
          opt <- sopt
          return $ Option { name: Flag opt.flag
                          , arg:  flip argument Nothing <$> opt.arg
                          , env:  Nothing
                          }

        long :: L.TokenParser Option
        long = do
          opt <- lopt
          return $ Option { name: Long opt.name
                          , arg:  flip argument Nothing <$>  opt.arg
                          , env:  Nothing
                          }

        both :: L.TokenParser Option
        both = markLine do
          x <- short
          y <- do sameLine
                  P.choice $ P.try <$> [ L.comma *> long
                                       , long
                                       ]
          combine x y

          where
            -- Combine two options into one. This function *does not* cover all
            -- cases right now. It deals only with a known subset and can there-
            -- fore make assumptions
            combine :: Option -> Option -> L.TokenParser Option
            combine (Option x@{ name: Flag f }) (Option y@{ name: Long n }) = do
              either P.fail return do
                arg <- combineArg x.arg y.arg
                return $ Option {
                  name: Full f n
                , arg: arg
                , env: Nothing -- No need to keep at this stage
                }

              where
                combineArg (Just a) (Just b) | (a == b) = return (pure a)
                combineArg Nothing  (Just b)            = return (pure b)
                combineArg (Just a) Nothing             = return (pure a)
                combineArg Nothing Nothing              = return Nothing
                combineArg (Just a) (Just b) | (a /= b) = Left $
                        "Arguments mismatch: " ++ (show $ prettyPrintArgument a)
                                    ++ " and " ++ (show $ prettyPrintArgument b)

    sopt :: L.TokenParser { flag :: Char, arg :: Maybe String }
    sopt = do
      opt <- L.sopt
      (guard $ (A.length opt.stack == 0)) P.<?> "No stacked options"
      return { flag: opt.flag, arg: opt.arg }

    lopt :: L.TokenParser { name :: String, arg :: Maybe String }
    lopt = L.lopt


updated readImpl with suggestion from @jacereda

module Simple.JSON (
  readJSON
, writeJSON
, write
, read

, class ReadForeign
, readImpl

, class ReadForeignFields
, getFields

, class WriteForeign
, writeImpl

, class WriteForeignFields
, writeImplFields

) where

import Prelude

import Control.Monad.Except (withExcept)
import Data.Foreign (F, Foreign, ForeignError(..), readArray, readBoolean, readChar, readInt, readNumber, readString, toForeign)
import Data.Foreign.Index (readProp)
import Data.Foreign.Internal (readStrMap)
import Data.Foreign.JSON (parseJSON)
import Data.Foreign.NullOrUndefined (NullOrUndefined(NullOrUndefined), readNullOrUndefined, unNullOrUndefined, undefined)
import Data.Maybe (Maybe(..), maybe)
import Data.Record (get, insert)
import Data.StrMap as StrMap
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence)
import Global.Unsafe (unsafeStringify)
import Type.Prelude (class TypeEquals, to)
import Type.Row (class ListToRow, class RowLacks, class RowToList, Cons, Nil, RLProxy(RLProxy), RProxy(..), kind RowList)

-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
readJSON :: forall a
  .  ReadForeign a
  => String
  -> F a
readJSON = readImpl <=< parseJSON

-- | Write a JSON string from a type `a`.
writeJSON :: forall a
  .  WriteForeign a
  => a
  -> String
writeJSON = unsafeStringify <<< writeImpl

write :: forall a
  .  WriteForeign a
  => a
  -> Foreign
write = writeImpl

read :: forall a
  .  ReadForeign a
  => Foreign
  -> F a
read = readImpl

-- | A class for reading foreign values to a type
class ReadForeign a where
  readImpl :: Foreign -> F a

instance readForeign :: ReadForeign Foreign where
  readImpl = pure

instance readChar :: ReadForeign Char where
  readImpl = readChar

instance readNumber :: ReadForeign Number where
  readImpl = readNumber

instance readInt :: ReadForeign Int where
  readImpl = readInt

instance readString :: ReadForeign String where
  readImpl = readString

instance readBoolean :: ReadForeign Boolean where
  readImpl = readBoolean

instance readArray :: ReadForeign a => ReadForeign (Array a) where
  readImpl = readElements <=< readArray
    where
      readElements xs = sequence $ readImpl <$> xs

instance readNullOrUndefined :: ReadForeign a => ReadForeign (NullOrUndefined a) where
  readImpl = readNullOrUndefined readImpl

instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
  readImpl = map unNullOrUndefined <<< readImpl

instance readStrMap :: ReadForeign a => ReadForeign (StrMap.StrMap a) where
  readImpl = sequence <<< StrMap.mapWithKey (const readImpl) <=< readStrMap

instance readRecord ::
  ( RowToList fields fieldList
  , ReadForeignFields fieldList fields
  , ListToRow fieldList fields
  ) => ReadForeign (Record fields) where
  readImpl = getFields (RLProxy :: RLProxy fieldList) (RProxy :: RProxy fields)

-- | A class for reading foreign values from properties
class ReadForeignFields (xs :: RowList) (row :: # Type) where
  getFields :: RLProxy xs
    -> RProxy row
    -> Foreign
    -> F (Record row)

instance readFieldsCons ::
  ( IsSymbol name
  , ReadForeign ty
  , ReadForeignFields tail tailRow
  , RowLacks name tailRow
  , RowCons name ty tailRow row
  ) => ReadForeignFields (Cons name ty tail) row where
  getFields _ _ obj = do
    value <- withExcept' $ readImpl =<< readProp name obj
    rest <- getFields tailP tailRowP obj
    pure $ insert nameP value rest
    where
      nameP = SProxy :: SProxy name
      tailP = RLProxy :: RLProxy tail
      tailRowP = RProxy :: RProxy tailRow
      name = reflectSymbol nameP
      withExcept' = withExcept <<< map $ ErrorAtProperty name

instance readFieldsNil ::
  ( TypeEquals {} (Record row)
  ) => ReadForeignFields Nil row where
  getFields _ _ _ =
    pure $ to {}

-- | A class for writing a value into JSON
-- | need to do this intelligently using Foreign probably, because of null and undefined whatever
class WriteForeign a where
  writeImpl :: a -> Foreign

instance writeForeignForeign :: WriteForeign Foreign where
  writeImpl = id

instance writeForeignString :: WriteForeign String where
  writeImpl = toForeign

instance writeForeignInt :: WriteForeign Int where
  writeImpl = toForeign

instance writeForeignChar :: WriteForeign Char where
  writeImpl = toForeign

instance writeForeignNumber :: WriteForeign Number where
  writeImpl = toForeign

instance writeForeignBoolean :: WriteForeign Boolean where
  writeImpl = toForeign

instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
  writeImpl xs = toForeign $ writeImpl <$> xs

instance writeForeignNullOrUndefined :: WriteForeign a => WriteForeign (NullOrUndefined a) where
  writeImpl (NullOrUndefined a) = maybe undefined writeImpl a

instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
  writeImpl (Just a) = writeImpl a
  writeImpl Nothing = null

foreign import null :: Foreign

instance writeForeignStrMap :: WriteForeign a => WriteForeign (StrMap.StrMap a) where
  writeImpl = toForeign <<< StrMap.mapWithKey (const writeImpl)

instance recordWriteForeign ::
  ( RowToList row rl
  , WriteForeignFields rl row row'
  ) => WriteForeign (Record row) where
  writeImpl rec = toForeign $ writeImplFields rlp rec
    where
      rlp = RLProxy :: RLProxy rl

class WriteForeignFields (rl :: RowList) row (row' :: # Type)
  | rl -> row row' where
  writeImplFields :: forall g. g rl -> Record row -> Record row'

instance consWriteForeignFields ::
  ( IsSymbol name
  , WriteForeign ty
  , WriteForeignFields tail row tailRow
  , RowCons name ty whatever row
  , RowLacks name tailRow
  , RowCons name Foreign tailRow row'
  ) => WriteForeignFields (Cons name ty tail) row row' where
  writeImplFields _ rec = result
    where
      namep = SProxy :: SProxy name
      value = writeImpl $ get namep rec
      tailp = RLProxy :: RLProxy tail
      rest = writeImplFields tailp rec
      result = insert namep value rest

instance nilWriteForeignFields ::
  ( TypeEquals {} (Record row')
  ) => WriteForeignFields Nil row row' where
  writeImplFields _ _ = to {}

module Simple.JSON (
  readJSON
, writeJSON
, write
, read

, class ReadForeign
, readImpl

, class ReadForeignFields
, getFields

, class WriteForeign
, writeImpl

, class WriteForeignFields
, writeImplFields

) where

import Prelude

import Control.Monad.Except (withExcept)
import Data.Foreign (F, Foreign, ForeignError(..), readArray, readBoolean, readChar, readInt, readNumber, readString, toForeign)
import Data.Foreign as Foreign
import Data.Foreign.Index (readProp)
import Data.Foreign.Internal (readStrMap)
import Data.Foreign.JSON (parseJSON)
import Data.Foreign.NullOrUndefined (NullOrUndefined(NullOrUndefined), readNullOrUndefined, undefined)
import Data.Maybe (Maybe(..), maybe)
import Data.Record (get, insert)
import Data.StrMap as StrMap
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse)
import Global.Unsafe (unsafeStringify)

import Type.Prelude (class TypeEquals, to)
import Type.Row (class ListToRow, class RowLacks, class RowToList, Cons, Nil, RLProxy(RLProxy), RProxy(..), kind RowList)

-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
readJSON :: forall a
  .  ReadForeign a
  => String
  -> F a
readJSON = readImpl <=< parseJSON

-- | Write a JSON string from a type `a`.
writeJSON :: forall a
  .  WriteForeign a
  => a
  -> String
writeJSON = unsafeStringify <<< writeImpl

write :: forall a
  .  WriteForeign a
  => a
  -> Foreign
write = writeImpl

read :: forall a
  .  ReadForeign a
  => Foreign
  -> F a
read = readImpl

-- | A class for reading foreign values to a type
class ReadForeign a where
  readImpl :: Foreign -> F a

instance readForeign :: ReadForeign Foreign where
  readImpl = pure

instance readChar :: ReadForeign Char where
  readImpl = readChar

instance readNumber :: ReadForeign Number where
  readImpl = readNumber

instance readInt :: ReadForeign Int where
  readImpl = readInt

instance readString :: ReadForeign String where
  readImpl = readString

instance readBoolean :: ReadForeign Boolean where
  readImpl = readBoolean

instance readArray :: ReadForeign a => ReadForeign (Array a) where
  readImpl = readElements <=< readArray
    where
      readElements xs = sequence $ readImpl <$> xs

instance readNullOrUndefined :: ReadForeign a => ReadForeign (NullOrUndefined a) where
  readImpl = readNullOrUndefined readImpl

instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
  readImpl foreignValue = (Foreign.readNullOrUndefined foreignValue) >>= (traverse readImpl)

instance readStrMap :: ReadForeign a => ReadForeign (StrMap.StrMap a) where
  readImpl = sequence <<< StrMap.mapWithKey (const readImpl) <=< readStrMap

instance readRecord ::
  ( RowToList fields fieldList
  , ReadForeignFields fieldList fields
  , ListToRow fieldList fields
  ) => ReadForeign (Record fields) where
  readImpl = getFields (RLProxy :: RLProxy fieldList) (RProxy :: RProxy fields)

-- | A class for reading foreign values from properties
class ReadForeignFields (xs :: RowList) (row :: # Type) where
  getFields :: RLProxy xs
    -> RProxy row
    -> Foreign
    -> F (Record row)

instance readFieldsCons ::
  ( IsSymbol name
  , ReadForeign ty
  , ReadForeignFields tail tailRow
  , RowLacks name tailRow
  , RowCons name ty tailRow row
  ) => ReadForeignFields (Cons name ty tail) row where
  getFields _ _ obj = do
    value <- withExcept' $ readImpl =<< readProp name obj
    rest <- getFields tailP tailRowP obj
    pure $ insert nameP value rest
    where
      nameP = SProxy :: SProxy name
      tailP = RLProxy :: RLProxy tail
      tailRowP = RProxy :: RProxy tailRow
      name = reflectSymbol nameP
      withExcept' = withExcept <<< map $ ErrorAtProperty name

instance readFieldsNil ::
  ( TypeEquals {} (Record row)
  ) => ReadForeignFields Nil row where
  getFields _ _ _ =
    pure $ to {}

-- | A class for writing a value into JSON
-- | need to do this intelligently using Foreign probably, because of null and undefined whatever
class WriteForeign a where
  writeImpl :: a -> Foreign

instance writeForeignForeign :: WriteForeign Foreign where
  writeImpl = id

instance writeForeignString :: WriteForeign String where
  writeImpl = toForeign

instance writeForeignInt :: WriteForeign Int where
  writeImpl = toForeign

instance writeForeignChar :: WriteForeign Char where
  writeImpl = toForeign

instance writeForeignNumber :: WriteForeign Number where
  writeImpl = toForeign

instance writeForeignBoolean :: WriteForeign Boolean where
  writeImpl = toForeign

instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
  writeImpl xs = toForeign $ writeImpl <$> xs

instance writeForeignNullOrUndefined :: WriteForeign a => WriteForeign (NullOrUndefined a) where
  writeImpl (NullOrUndefined a) = maybe undefined writeImpl a

instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
  writeImpl (Just a) = writeImpl a
  writeImpl Nothing = null

foreign import null :: Foreign

instance writeForeignStrMap :: WriteForeign a => WriteForeign (StrMap.StrMap a) where
  writeImpl = toForeign <<< StrMap.mapWithKey (const writeImpl)

instance recordWriteForeign ::
  ( RowToList row rl
  , WriteForeignFields rl row row'
  ) => WriteForeign (Record row) where
  writeImpl rec = toForeign $ writeImplFields rlp rec
    where
      rlp = RLProxy :: RLProxy rl

class WriteForeignFields (rl :: RowList) row (row' :: # Type)
  | rl -> row row' where
  writeImplFields :: forall g. g rl -> Record row -> Record row'

instance consWriteForeignFields ::
  ( IsSymbol name
  , WriteForeign ty
  , WriteForeignFields tail row tailRow
  , RowCons name ty whatever row
  , RowLacks name tailRow
  , RowCons name Foreign tailRow row'
  ) => WriteForeignFields (Cons name ty tail) row row' where
  writeImplFields _ rec = result
    where
      namep = SProxy :: SProxy name
      value = writeImpl $ get namep rec
      tailp = RLProxy :: RLProxy tail
      rest = writeImplFields tailp rec
      result = insert namep value rest

instance nilWriteForeignFields ::
  ( TypeEquals {} (Record row')
  ) => WriteForeignFields Nil row row' where
  writeImplFields _ _ = to {}


Changed Coordiantes data types from Maybe to Nullable

module Data.Geolocation (
    class Geolocation, LOCATION, Coordinates, Position, PositionError,
    PositionOptions, clearWatch, defaultOptions, getCurrentPosition,
    watchPosition
) where

import Control.Monad.Eff (Eff)
import Data.Date (Date)
import Data.Int (ceil)
import Data.Nullable (Nullable)
import Global (infinity)
import Prelude (Unit)

{-|
  | The Geolocation object is used by scripts to programmatically determine the
  | location information associated with the hosting device.
-}
class Geolocation g where
    getCurrentPosition :: forall eff. g -> (
                                Position ->
                                Eff (location :: LOCATION | eff) Unit
                            ) -> (
                                PositionError ->
                                Eff (location :: LOCATION | eff) Unit
                            ) -> PositionOptions ->
                            Eff (location :: LOCATION | eff) Unit

    watchPosition :: forall eff. g -> (
                            Position ->
                            Eff (location :: LOCATION | eff) Unit
                        ) -> (
                            PositionError ->
                            Eff (location :: LOCATION | eff) Unit
                        ) -> PositionOptions ->
                         Eff (location :: LOCATION | eff) Int

    clearWatch :: forall eff. g -> Int -> Eff (location :: LOCATION | eff) Unit

{-|
  | The effect type of the location side effect.
-}
foreign import data LOCATION :: !

{-|
  | Coordinates is the datatype of the coordinates of a position.
  | The geographic coordinate reference system used by the attributes in this
  | interface is the World Geodetic System (2d).
-}
type Coordinates = {
    latitude         :: Number,
    longitude        :: Number,
    altitude         :: Nullable Number,
    accuracy         :: Number,
    altitudeAccuracy :: Nullable Number,
    heading          :: Nullable Number,
    speed            :: Nullable Number
}

{-|
  | Postion is the container for the geolocation information returned by this
  | API.
-}
type Position = {
    coords    :: Coordinates,
    timestamp :: Date
}

{-|
  | PositionError is the datatype of the error which might be returned by
  | getCurrentPosition() and watchPosition().
-}
type PositionError = {
    code    :: Int,
    message :: String
}

{-|
  | PositionOptions is the data type of the options for getCurrentPosition() and
  | watchPosition().
-}
type PositionOptions = {
    enableHighAccuracy :: Boolean,
    timeout            :: Int,
    maximumAge         :: Int
}

{-|
  | defaultOptions is an PositionOptions object with the defaults.
-}
defaultOptions :: PositionOptions
defaultOptions = {
    enableHighAccuracy: false,
    timeout           : ceil infinity,
    maximumAge        : 0
}

module Data.Geolocation (
    class Geolocation, LOCATION, Coordinates, Position, PositionError,
    PositionOptions, clearWatch, defaultOptions, getCurrentPosition,
    watchPosition
) where

import Control.Monad.Eff (Eff)
import Data.Date (Date)
import Data.Int (ceil)
import Data.Maybe (Maybe)
import Global (infinity)
import Prelude (Unit)

{-|
  | The Geolocation object is used by scripts to programmatically determine the
  | location information associated with the hosting device.
-}
class Geolocation g where
    getCurrentPosition :: forall eff. g -> (
                                Position ->
                                Eff (location :: LOCATION | eff) Unit
                            ) -> (
                                PositionError ->
                                Eff (location :: LOCATION | eff) Unit
                            ) -> PositionOptions ->
                            Eff (location :: LOCATION | eff) Unit

    watchPosition :: forall eff. g -> (
                            Position ->
                            Eff (location :: LOCATION | eff) Unit
                        ) -> (
                            PositionError ->
                            Eff (location :: LOCATION | eff) Unit
                        ) -> PositionOptions ->
                         Eff (location :: LOCATION | eff) Int

    clearWatch :: forall eff. g -> Int -> Eff (location :: LOCATION | eff) Unit

{-|
  | The effect type of the location side effect.
-}
foreign import data LOCATION :: !

{-|
  | Coordinates is the datatype of the coordinates of a position.
  | The geographic coordinate reference system used by the attributes in this
  | interface is the World Geodetic System (2d).
-}
type Coordinates = {
    latitude         :: Number,
    longitude        :: Number,
    altitude         :: Maybe Number,
    accuracy         :: Number,
    altitudeAccuracy :: Maybe Number,
    heading          :: Maybe Number,
    speed            :: Maybe Number
}

{-|
  | Postion is the container for the geolocation information returned by this
  | API.
-}
type Position = {
    coords    :: Coordinates,
    timestamp :: Date
}

{-|
  | PositionError is the datatype of the error which might be returned by
  | getCurrentPosition() and watchPosition().
-}
type PositionError = {
    code    :: Int,
    message :: String
}

{-|
  | PositionOptions is the data type of the options for getCurrentPosition() and
  | watchPosition().
-}
type PositionOptions = {
    enableHighAccuracy :: Boolean,
    timeout            :: Int,
    maximumAge         :: Int
}

{-|
  | defaultOptions is an PositionOptions object with the defaults.
-}
defaultOptions :: PositionOptions
defaultOptions = {
    enableHighAccuracy: false,
    timeout           : ceil infinity,
    maximumAge        : 0
}


Export SimulationState component types.

Export SimulationState component types.

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Math

type RadiansPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise
type CubeState = {direction :: RotationDirection, angle :: Radians}
type CameraState = {yaw :: Radians, pitch :: Radians}
type SimulationState = {cube :: CubeState, camera :: CameraState}

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f st = {cube: st.cube, camera: f st.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f st = {cube: f st.cube, camera: st.camera}

initialSimulationState :: SimulationState
initialSimulationState = {
  cube: {direction: Anticlockwise, angle: 0.0},
  camera: {pitch: 0.0, yaw: 0.0}
  }

angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | Angle change is velocity multiplied by time
angleFromVelocity :: RadiansPerSecond -> Seconds -> Radians
angleFromVelocity v (Seconds t) = v * t

-- | Update the simulation state to reflect a change in simulation time
timestep :: Milliseconds -> SimulationState -> SimulationState
timestep step = mapCubeState (\cs -> {direction: cs.direction, angle: cs.angle + angleChange cs.direction})
  where
  angleChange :: RotationDirection -> Radians
  angleChange direction = directionMultiplier direction * angleFromVelocity angularSpeed (toSeconds step)
  directionMultiplier :: RotationDirection -> Number
  directionMultiplier direction = case direction of
    Anticlockwise -> 1.0
    Clockwise -> -1.0

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\cs -> {direction: newDirection cs.direction, angle: cs.angle})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

pitchSensitivity :: Radians
pitchSensitivity = 0.05

yawSensitivity :: Radians
yawSensitivity = 0.05

applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \cs -> {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw + dx * yawSensitivity
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Math

type RadiansPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise
type CubeState = {direction :: RotationDirection, angle :: Radians}
type CameraState = {yaw :: Radians, pitch :: Radians}
type SimulationState = {cube :: CubeState, camera :: CameraState}

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f st = {cube: st.cube, camera: f st.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f st = {cube: f st.cube, camera: st.camera}

initialSimulationState :: SimulationState
initialSimulationState = {
  cube: {direction: Anticlockwise, angle: 0.0},
  camera: {pitch: 0.0, yaw: 0.0}
  }

angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | Angle change is velocity multiplied by time
angleFromVelocity :: RadiansPerSecond -> Seconds -> Radians
angleFromVelocity v (Seconds t) = v * t

-- | Update the simulation state to reflect a change in simulation time
timestep :: Milliseconds -> SimulationState -> SimulationState
timestep step = mapCubeState (\cs -> {direction: cs.direction, angle: cs.angle + angleChange cs.direction})
  where
  angleChange :: RotationDirection -> Radians
  angleChange direction = directionMultiplier direction * angleFromVelocity angularSpeed (toSeconds step)
  directionMultiplier :: RotationDirection -> Number
  directionMultiplier direction = case direction of
    Anticlockwise -> 1.0
    Clockwise -> -1.0

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\cs -> {direction: newDirection cs.direction, angle: cs.angle})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

pitchSensitivity :: Radians
pitchSensitivity = 0.1

yawSensitivity :: Radians
yawSensitivity = 0.1

applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \cs -> {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw + dx * yawSensitivity
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p


Update CLI solver to PS 0.11

Update CLI solver to PS 0.11

module Main (main) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Array as A
import Data.List (List)
import Data.Traversable (for, for_)

import Types (Cube(..))
import Solver (solve)
import Levels (levelTitle, getLevel, getChapter, allLevelIds)

ttyColor :: Cube -> Int
ttyColor Yellow = 0
ttyColor Orange = 1
ttyColor Brown = 2
ttyColor Red = 3
ttyColor Cyan = 4

showList :: forall a. (Show a) => List a -> String
showList xs = show (A.fromFoldable xs :: Array a)

showList2 :: forall a. (Show a) => List (List a) -> String
showList2 xss = show ((A.fromFoldable <<< map A.fromFoldable) xss :: Array (Array a))

main :: forall eff. Eff (console :: CONSOLE | eff) Unit
main = void do
    for allLevelIds $ \lid -> do
        let chapter = getChapter lid
            level = getLevel lid
            solutions = solve lid

        log $ levelTitle lid level
        log $ "  Initial: " <> showList2 (map (map ttyColor) level.initial)
        log $ "  Target:  " <> showList2 (map (map ttyColor) level.target)
        log $ "  Solutions: "
        for_ solutions $ \sol ->
            log $ "    " <> showList sol
        log ""

module Main (main) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Array as A
import Data.List (List)
import Data.Traversable (for)

import Types (Cube(..))
import Solver (solve)
import Levels (levelTitle, getLevel, getChapter, allLevelIds)

ttyColor :: Cube -> Int
ttyColor Yellow = 0
ttyColor Orange = 1
ttyColor Brown = 2
ttyColor Red = 3
ttyColor Cyan = 4

showList :: forall a. (Show a) => List a -> String
showList xs = show (A.fromFoldable xs :: Array a)

showList2 :: forall a. (Show a) => List (List a) -> String
showList2 xss = show ((A.fromFoldable <<< map A.fromFoldable) xss :: Array (Array a))

main :: forall eff. Eff (console :: CONSOLE | eff) Unit
main = void do
    for allLevelIds $ \lid -> do
        let chapter = getChapter lid
            level = getLevel lid
            solutions = solve lid

        log $ levelTitle lid level
        log $ "  Initial: " <> showList2 (map (map ttyColor) level.initial)
        log $ "  Target:  " <> showList2 (map (map ttyColor) level.target)
        log $ "  Solutions: "
        for solutions $ \sol ->
            log $ "    " <> showList sol
        log ""


Implementing patch regex

Implementing patch regex

module Patch ( addPatch ) where

import Data.String.Regex
import Data.Maybe
import Data.Either
import Prelude

type ValuePatch =
  {
    op :: String
  , path :: String
  , value :: String
  }

pathReg = regex "^(/[a-zA-Z0-9]*)+$" noFlags

isPatch :: String -> Either String Boolean
isPatch x = flip test x <$> pathReg

addPatch :: String -> String -> Maybe ValuePatch
addPatch path value = if true then
  Just ({
    op: "add"
  , path: path
  , value: value
  }) else Nothing

module Patch ( add ) where

type ValuePatch =
  {
    op :: String
  , path :: String
  , value :: String
  }

add :: String -> String -> ValuePatch
add path value =
  ({
    op: "add"
  , path: path
  , value: value
  })