Start of glyph bounding boxes & scaled rendering

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (navy, red)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (Json, _Array)
import Data.Array ((..))
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.Either (Either(..))
import Data.Exists (Exists, runExists)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', view, (^?), (^.))
import Data.List (List)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (unwrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(SProxy))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), snd, uncurry)
import Data.Variant (Variant, case_, inj, onMatch)
import Genetics.Browser.Types (Bp, ChrId)
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), ViewScale(..), _Segments, pairSize, pairsOverlap, scaledSegments)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, FillStyle, OutlineStyle, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

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

_point = SProxy :: SProxy "point"
_range = SProxy :: SProxy "range"

-- Simplify & let all feature positions be represented as ranges
type GenPos = Pair Bp

-- The very basic shapes a glyph can consist of (for now)
data GlyphShape
  = GCircle Number
  | GRect Number Number
  | GMany (List GlyphShape)

-- A `GlyphDrawing` is a shape plus styles informing how to render it (from purescript-drawing)
data GlyphDrawing
  = GDrawing OutlineStyle FillStyle GlyphShape

-- A `Glyph p` is a given `GlyphDrawing` and zero or more points (of whatever type) to place it at
data Glyph p
  = Glyph GlyphDrawing (Array p)

{-
-- alternatively, we could enforce 2D glyphs here, idk if worthwhile
data Glyph' p
  = Glyph' GlyphDrawing (Array {x :: p, y :: p})
-}

type NPoint = { x :: Normalized Number
              , y :: Normalized Number }

type HitArea p = { point :: p, shape :: GlyphShape }

type FeatureSpot p a =
  { feature :: a
  , hitArea :: HitArea p }

type RenderOutput a p =
  { glyphs     :: Array (Glyph p) -- an array of the same or smaller size than the number of features
  , features   :: Array (FeatureSpot p a)    -- the features contained in the provided "rectangle" of `p`s
  }

type NormalRenderOutput a =
  RenderOutput a NPoint

type ScreenRenderOutput a =
  RenderOutput a Point

type NormalToScreen a = NormalRenderOutput a
                     -> ViewScale
                     -> ScreenRenderOutput a

type RendererN a
  = { segmentSize :: a -> Bp
    , render      :: Array a -> NormalRenderOutput a }

type RendererS a
  = { segmentSize :: a -> Bp
    , render      :: Array a -> ViewScale -> ScreenRenderOutput a }

gwasRendererN :: forall r a.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> CoordSys ChrId BigInt
              -> RendererN { score :: Number, pos :: GenPos, segmentSize :: Bp }
gwasRendererN vscale csys = { segmentSize, render }
  where featurePos  s = s.pos
        segmentSize s = s.segmentSize

        render :: Array _
               -> { glyphs   :: Array (Glyph NPoint)
                  , features :: Array (FeatureSpot NPoint _) }
        render input =
          let fps :: Array (Tuple _ NPoint)
              fps = map (\f -> Tuple f (npoint f)) input

              glyphs = [glyph (snd $ Array.unzip fps)]

              hit (Tuple a p) = { feature: a, hitArea: { point: p, shape: gshape }}
              features = map hit fps

          in { glyphs, features }

        radius = 2.2
        color = navy

        gshape :: GlyphShape
        gshape = GCircle radius

        glyph = Glyph (GDrawing (Drawing.outlineColor color)
                                (Drawing.fillColor color) gshape)

        npoint :: { score :: Number, pos :: GenPos, segmentSize :: Bp }
               -> NPoint
        npoint s =
          { x: Normalized (unwrap $ (Pair.fst s.pos) / s.segmentSize)
          , y: Normalized ((s.score - vscale.min) / (vscale.max - vscale.min)) }

-- | Basic normalized-to-screen transformation, that only rescales to fit
rescaleToScreen :: Number
                -> NormalRenderOutput _
                -> ViewScale
                -> ScreenRenderOutput _
rescaleToScreen height nro vs = unsafeCoerce unit

type GenomePosV = Variant ( point :: Bp
                          , range :: Pair Bp )

type FeatureR r = ( position :: GenomePosV
                  , frameSize :: Bp
                  | r )
type Feature r = Record (FeatureR r)

type DrawingR  = ( point :: Drawing
                 , range :: Number -> { drawing :: Unit -> Drawing, width :: Number } )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Pair (Normalized Number) )
type HPos = Variant HorPlaceR

type BatchRenderer a = { drawing :: Drawing
                       , place :: a -> Normalized Point }

type SingleRenderer a = { draw  :: a -> DrawingV
                        , horPlace :: a -> HPos
                        , verPlace :: a -> Normalized Number }

_batch = (SProxy :: SProxy "batch")
_single = (SProxy :: SProxy "single")

type Renderer a = Variant ( batch :: BatchRenderer a
                          , single :: SingleRenderer a )

type NormalizedGlyph = { drawing :: Variant DrawingR
                       , horPos  :: Variant HorPlaceR
                       , verPos  :: Normalized Number
                       }

type BatchGlyph c = { drawing :: Drawing
                    , points :: Array c }

type SingleGlyph = { drawing :: Unit -> Drawing, point :: Point, width :: Number }

horPlace :: forall r.
            Feature r
         -> HPos
horPlace {position, frameSize} =
  let f p = Normalized (unwrap $ p / frameSize)
  in case_
    # onMatch
      { point: inj _point <<< f
      , range: inj _range <<< (map f)
      }
    $ position

renderSingle :: forall a.
                SingleRenderer a
             -> a
             -> NormalizedGlyph
renderSingle render a =
      { drawing: render.draw a
      , horPos:  render.horPlace a
      , verPos:  render.verPlace a
      }

renderBatch :: forall a.
               BatchRenderer a
            -> Array a
            -> BatchGlyph (Normalized Point)
renderBatch render as = {drawing, points}
  where drawing = render.drawing
        points  = map render.place as

render :: forall a.
          Renderer a
       -> Array a
       -> Either
           (BatchGlyph (Normalized Point))
           (Array NormalizedGlyph)
render r as = case_
  # onMatch { batch:  \r -> Left  $ renderBatch r as
            , single: \r -> Right $ map (renderSingle r) as }
  $ r

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

chrLabelTrack :: CoordSys ChrId BigInt
              -> Canvas.Dimensions
              -> Map ChrId (Array NormalizedGlyph)
chrLabelTrack cs cdim =
  let font' = font sansSerif 12 mempty

      chrText :: ChrId -> Drawing
      chrText chr =
        Drawing.text font' zero zero (fillColor black) (unwrap chr)

      mkLabel :: ChrId -> NormalizedGlyph
      mkLabel chr = { drawing: inj _point $ chrText chr
                    , horPos:  inj _point $ Normalized (0.5)
                    , verPos: Normalized (0.05) }

  in mapWithIndex (\i _ -> [mkLabel i]) $ cs ^. _Segments

-- boxesTrack :: Number
--            -> CoordSys ChrId BigInt
--            -> Canvas.Dimensions
--            -> Pair BigInt -> CanvasReadyDrawing
-- boxesTrack h cs = unsafeCoerce unit
-- boxesTrack h cs = drawRelativeUI cs $ map (const [glyph]) $ cs ^. _BrowserIntervals
--   where glyph :: NormalizedGlyph
--         glyph = { drawing: inj _range draw
--                 , horPos:  inj _range $ Normalized <$> (Pair zero one)
--                 , verPos: aone }
--         draw = \w ->
--              let rect = rectangle 0.0 0.0 w h
--              in outlined (outlineColor black <> lineWidth 1.5) rect

featureInterval :: forall a. Feature a -> Pair Bp
featureInterval {position} = case_
  # onMatch
     { point: (\x -> Pair x x)
     , range: (\x -> x)
     }
  $ position

bumpFeatures :: forall f a l i o.
                Foldable f
             => Functor f
             => RowCons l Number (FeatureR i) (FeatureR o)
             => RowLacks l (FeatureR i)
             => IsSymbol l
             => Getter' (Feature a) Number
             -> SProxy l
             -> Bp
             -> f (Feature a)
             -> f (Feature i)
             -> f (Feature o)
bumpFeatures f l radius other = map bump
  where maxInRadius :: Pair Bp -> Number
        maxInRadius lr = fromMaybe 0.0 $ maximum
                          $ map (\g -> if pairsOverlap (featureInterval g) lr
                                          then f `view` g else 0.0) other

        bump :: Record (FeatureR i) -> Record (FeatureR o)
        bump a =
          let y = maxInRadius (featureInterval a)
          in Record.insert l y a

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

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { width :: Number
              , color :: Color
              | VScaleRow () }

drawVScale :: forall r.
              VScale
           -> Number
           -> Drawing
drawVScale vscale height =
  -- should have some padding here too; hardcode for now
  let hPad = vscale.width  / 8.0
      vPad = height / 10.0
      x = 7.0 * hPad

      y1 = 0.0
      y2 = height

      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, y}]

      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 8.0 else 3.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft hPad y (fillColor black)

      topLabel = mkT (y1+5.0) $ show vscale.max
      btmLabel = mkT (y2+5.0)       $ show vscale.min

  in outlined (outlineColor vscale.color <> lineWidth 2.0) (p <> ps)
     <> topLabel <> btmLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { width :: Number
              , entries :: Array LegendEntry }

mkIcon :: Color -> String -> LegendEntry
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}

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

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

type Padding = { vertical :: Number
               , horizontal :: Number
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

getData :: forall a i c.
           CoordSys i c
        -> (CoordSys i c -> Json -> Maybe a)
        -> String
        -> Aff _ (Array a)
getData cs p url = do
  json <- _.response <$> Affjax.get url

  maybe (throwError $ error $ "Error when parsing features from " <> url)
        pure
        $ json ^? _Array >>= traverse (p cs)

getDataGrouped :: forall a i c.
                  CoordSys ChrId c
               -> (CoordSys ChrId c -> Json -> Maybe _)
               -> String
               -> Aff _ (Map ChrId (Array _))
getDataGrouped cs p url = groupToChrs <$> getData cs p url

eqLegend a b = a.text == b.text

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy eqLegend $ Array.fromFoldable $ map f as

data Track a = Track (Renderer a) (Map ChrId (Array a))

horPlaceOnSegment :: forall r.
                     Pair Number
                  -> { horPos :: Variant HorPlaceR | r }
                  -> Number
horPlaceOnSegment segmentPixels o =
    case_
  # onMatch { point: \(Normalized x) -> x * pairSize segmentPixels
            , range: \(Pair l r)     -> unwrap l * pairSize segmentPixels }
  $ o.horPos

finalizeNormDrawing :: forall r.
                       Pair Number
                    -> { drawing :: DrawingV | r }
                    -> { drawing :: Unit -> Drawing, width :: Number }
finalizeNormDrawing seg o =
    case_
  # onMatch { point: \x -> { drawing: \_ -> x, width: 1.0 }
            , range: (_ $ pairSize seg) }
  $ o.drawing

renderNormalized1 :: Number
                  -> Pair Number
                  -> NormalizedGlyph
                  -> SingleGlyph
renderNormalized1 height seg@(Pair l _) ng =
  let x = horPlaceOnSegment seg ng + l
      y = height * (one - unwrap ng.verPos)
      {drawing, width} = finalizeNormDrawing seg ng
  in { point: {x,y}, drawing, width }

scalePoint :: Number
           -> Pair Number
           -> Normalized Point
           -> Point
scalePoint height seg@(Pair l _) np =
  let x = (unwrap np).x * pairSize seg + l
      y = height * (one - (unwrap np).y)
  in { x,y }

rescaleNormBatchGlyphs :: Number
                       -> Pair Number
                       -> BatchGlyph (Normalized Point)
                       -> BatchGlyph Point
rescaleNormBatchGlyphs height seg bg@{points} =
  bg { points = map (scalePoint height seg) points }

rescaleNormSingleGlyphs :: Number
                        -> Pair Number
                        -> Array NormalizedGlyph
                        -> Array SingleGlyph
rescaleNormSingleGlyphs height seg =
  map (renderNormalized1 height seg)

withPixelSegments :: forall r m.
                     Monoid m
                  => CoordSys ChrId BigInt
                  -> { width :: Number | r }
                  -> Pair BigInt
                  -> (ChrId -> Pair Number -> m)
                  -> m
withPixelSegments cs cdim bView =
  let scale = { screenWidth: cdim.width
              , viewWidth: pairSize bView }
  in flip foldMapWithIndex (scaledSegments cs scale)

renderNormalizedTrack :: CoordSys ChrId BigInt
                      -> Canvas.Dimensions
                      -> Pair BigInt
                      -> Map ChrId (Either
                                      (BatchGlyph (Normalized Point))
                                      (Array NormalizedGlyph))
                      -- TODO concatting the segments with array is just lazy but works for now
                      --      optimally, a whole track should be one or the other type of glyph
                      -> Array (Either
                                  (BatchGlyph Point)
                                  (Array SingleGlyph))
renderNormalizedTrack cs cdim bView ngs =
  let segs :: Map ChrId (Pair Number)
      segs = scaledSegments cs { screenWidth: cdim.width, viewWidth: pairSize bView }

      renderSeg :: ChrId -> Pair Number -> Array (Either (BatchGlyph Point) (Array SingleGlyph))
      renderSeg k seg =
        pure $ fromMaybe (pure [])
               $ bimap
                 (rescaleNormBatchGlyphs  cdim.height seg)
                 (rescaleNormSingleGlyphs cdim.height seg)
                 <$> Map.lookup k ngs

  in foldMapWithIndex renderSeg segs

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

type RenderedTrack = Either (BatchGlyph Point) (Array SingleGlyph)

browser :: CoordSys ChrId BigInt
        -> Canvas.Dimensions
        -> Canvas.Dimensions
        -> UISlots
        -> { legend :: Legend, vscale :: VScale }
        -> List (Exists Track)
        -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
           , relativeUI :: Pair BigInt -> Drawing
           , fixedUI    :: Drawing }
browser cs trackDim overlayDim uiSlots ui inputTracks =
  let
      drawInSlot {offset, size} d =
          (translate offset.x offset.y
           $ filled (fillColor white)
           $ rectangle zero zero size.width size.height)
        <> translate offset.x offset.y d

      vScale = drawInSlot uiSlots.left (drawVScale ui.vscale uiSlots.left.size.height)

      legend = drawInSlot uiSlots.right (drawLegend ui.legend uiSlots.right.size.height)

      ruler   = Drawing.translate ui.vscale.width zero
                $ horRulerTrack ui.vscale red trackDim

      fixedUI = ruler <> vScale <> legend

      normTracks :: List (Map ChrId
                          (Either (BatchGlyph (Normalized Point))
                                  (Array NormalizedGlyph)))
      normTracks = runExists (\(Track r as) -> render r <$> as) <$> inputTracks

      tracks :: Pair BigInt -> List (Array (Either (BatchGlyph Point) (Array SingleGlyph)))
      tracks v = (renderNormalizedTrack cs trackDim v) <$> normTracks

      renderUIElement :: Map ChrId (Array NormalizedGlyph)
                      -> ChrId -> Pair Number -> Array SingleGlyph
      renderUIElement m k s
          = fold $ rescaleNormSingleGlyphs trackDim.height s
                <$> (Map.lookup k m)

      drawTrackUI :: Pair BigInt -> (ChrId -> Pair Number -> (Array _)) -> Drawing
      drawTrackUI v = foldMap f <<< withPixelSegments cs trackDim v
        where f {drawing, point} = Drawing.translate point.x point.y (drawing unit)

      chrLabels :: _
      chrLabels = renderUIElement $ chrLabelTrack cs trackDim

      relativeUI :: Pair BigInt -> Drawing
      relativeUI v = drawTrackUI v chrLabels

  in { tracks
     , relativeUI
     , fixedUI
     }

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (red)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (Json, _Array)
import Data.Array ((..))
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.Either (Either(..))
import Data.Exists (Exists, runExists)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', view, (^?), (^.))
import Data.List (List)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (unwrap)
import Data.Pair (Pair(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(SProxy))
import Data.Traversable (traverse)
import Data.Tuple (Tuple, snd, uncurry)
import Data.Variant (Variant, case_, inj, onMatch)
import Genetics.Browser.Types (Bp, ChrId)
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), _Segments, pairSize, pairsOverlap, scaledSegments)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, 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

_point = SProxy :: SProxy "point"
_range = SProxy :: SProxy "range"

type GenomePosV = Variant ( point :: Bp
                          , range :: Pair Bp )

type FeatureR r = ( position :: GenomePosV
                  , frameSize :: Bp
                  | r )
type Feature r = Record (FeatureR r)

type DrawingR  = ( point :: Drawing
                 , range :: Number -> { drawing :: Unit -> Drawing, width :: Number } )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Pair (Normalized Number) )
type HPos = Variant HorPlaceR

type BatchRenderer a = { drawing :: Drawing
                       , place :: a -> Normalized Point }

type SingleRenderer a = { draw  :: a -> DrawingV
                        , horPlace :: a -> HPos
                        , verPlace :: a -> Normalized Number }

_batch = (SProxy :: SProxy "batch")
_single = (SProxy :: SProxy "single")

type Renderer a = Variant ( batch :: BatchRenderer a
                          , single :: SingleRenderer a )

type NormalizedGlyph = { drawing :: Variant DrawingR
                       , horPos  :: Variant HorPlaceR
                       , verPos  :: Normalized Number
                       }

type BatchGlyph c = { drawing :: Drawing
                    , points :: Array c }

type SingleGlyph = { drawing :: Unit -> Drawing, point :: Point, width :: Number }

horPlace :: forall r.
            Feature r
         -> HPos
horPlace {position, frameSize} =
  let f p = Normalized (unwrap $ p / frameSize)
  in case_
    # onMatch
      { point: inj _point <<< f
      , range: inj _range <<< (map f)
      }
    $ position

renderSingle :: forall a.
                SingleRenderer a
             -> a
             -> NormalizedGlyph
renderSingle render a =
      { drawing: render.draw a
      , horPos:  render.horPlace a
      , verPos:  render.verPlace a
      }

renderBatch :: forall a.
               BatchRenderer a
            -> Array a
            -> BatchGlyph (Normalized Point)
renderBatch render as = {drawing, points}
  where drawing = render.drawing
        points  = map render.place as

render :: forall a.
          Renderer a
       -> Array a
       -> Either
           (BatchGlyph (Normalized Point))
           (Array NormalizedGlyph)
render r as = case_
  # onMatch { batch:  \r -> Left  $ renderBatch r as
            , single: \r -> Right $ map (renderSingle r) as }
  $ r

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

chrLabelTrack :: CoordSys ChrId BigInt
              -> Canvas.Dimensions
              -> Map ChrId (Array NormalizedGlyph)
chrLabelTrack cs cdim =
  let font' = font sansSerif 12 mempty

      chrText :: ChrId -> Drawing
      chrText chr =
        Drawing.text font' zero zero (fillColor black) (unwrap chr)

      mkLabel :: ChrId -> NormalizedGlyph
      mkLabel chr = { drawing: inj _point $ chrText chr
                    , horPos:  inj _point $ Normalized (0.5)
                    , verPos: Normalized (0.05) }

  in mapWithIndex (\i _ -> [mkLabel i]) $ cs ^. _Segments

-- boxesTrack :: Number
--            -> CoordSys ChrId BigInt
--            -> Canvas.Dimensions
--            -> Pair BigInt -> CanvasReadyDrawing
-- boxesTrack h cs = unsafeCoerce unit
-- boxesTrack h cs = drawRelativeUI cs $ map (const [glyph]) $ cs ^. _BrowserIntervals
--   where glyph :: NormalizedGlyph
--         glyph = { drawing: inj _range draw
--                 , horPos:  inj _range $ Normalized <$> (Pair zero one)
--                 , verPos: aone }
--         draw = \w ->
--              let rect = rectangle 0.0 0.0 w h
--              in outlined (outlineColor black <> lineWidth 1.5) rect

featureInterval :: forall a. Feature a -> Pair Bp
featureInterval {position} = case_
  # onMatch
     { point: (\x -> Pair x x)
     , range: (\x -> x)
     }
  $ position

bumpFeatures :: forall f a l i o.
                Foldable f
             => Functor f
             => RowCons l Number (FeatureR i) (FeatureR o)
             => RowLacks l (FeatureR i)
             => IsSymbol l
             => Getter' (Feature a) Number
             -> SProxy l
             -> Bp
             -> f (Feature a)
             -> f (Feature i)
             -> f (Feature o)
bumpFeatures f l radius other = map bump
  where maxInRadius :: Pair Bp -> Number
        maxInRadius lr = fromMaybe 0.0 $ maximum
                          $ map (\g -> if pairsOverlap (featureInterval g) lr
                                          then f `view` g else 0.0) other

        bump :: Record (FeatureR i) -> Record (FeatureR o)
        bump a =
          let y = maxInRadius (featureInterval a)
          in Record.insert l y a

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

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { width :: Number
              , color :: Color
              | VScaleRow () }

drawVScale :: forall r.
              VScale
           -> Number
           -> Drawing
drawVScale vscale height =
  -- should have some padding here too; hardcode for now
  let hPad = vscale.width  / 8.0
      vPad = height / 10.0
      x = 7.0 * hPad

      y1 = 0.0
      y2 = height

      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, y}]

      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 8.0 else 3.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft hPad y (fillColor black)

      topLabel = mkT (y1+5.0) $ show vscale.max
      btmLabel = mkT (y2+5.0)       $ show vscale.min

  in outlined (outlineColor vscale.color <> lineWidth 2.0) (p <> ps)
     <> topLabel <> btmLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { width :: Number
              , entries :: Array LegendEntry }

mkIcon :: Color -> String -> LegendEntry
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}

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

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

type Padding = { vertical :: Number
               , horizontal :: Number
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

getData :: forall a i c.
           CoordSys i c
        -> (CoordSys i c -> Json -> Maybe a)
        -> String
        -> Aff _ (Array a)
getData cs p url = do
  json <- _.response <$> Affjax.get url

  maybe (throwError $ error $ "Error when parsing features from " <> url)
        pure
        $ json ^? _Array >>= traverse (p cs)

getDataGrouped :: forall a i c.
                  CoordSys ChrId c
               -> (CoordSys ChrId c -> Json -> Maybe _)
               -> String
               -> Aff _ (Map ChrId (Array _))
getDataGrouped cs p url = groupToChrs <$> getData cs p url

eqLegend a b = a.text == b.text

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy eqLegend $ Array.fromFoldable $ map f as

data Track a = Track (Renderer a) (Map ChrId (Array a))

horPlaceOnSegment :: forall r.
                     Pair Number
                  -> { horPos :: Variant HorPlaceR | r }
                  -> Number
horPlaceOnSegment segmentPixels o =
    case_
  # onMatch { point: \(Normalized x) -> x * pairSize segmentPixels
            , range: \(Pair l r)     -> unwrap l * pairSize segmentPixels }
  $ o.horPos

finalizeNormDrawing :: forall r.
                       Pair Number
                    -> { drawing :: DrawingV | r }
                    -> { drawing :: Unit -> Drawing, width :: Number }
finalizeNormDrawing seg o =
    case_
  # onMatch { point: \x -> { drawing: \_ -> x, width: 1.0 }
            , range: (_ $ pairSize seg) }
  $ o.drawing

renderNormalized1 :: Number
                  -> Pair Number
                  -> NormalizedGlyph
                  -> SingleGlyph
renderNormalized1 height seg@(Pair l _) ng =
  let x = horPlaceOnSegment seg ng + l
      y = height * (one - unwrap ng.verPos)
      {drawing, width} = finalizeNormDrawing seg ng
  in { point: {x,y}, drawing, width }

scalePoint :: Number
           -> Pair Number
           -> Normalized Point
           -> Point
scalePoint height seg@(Pair l _) np =
  let x = (unwrap np).x * pairSize seg + l
      y = height * (one - (unwrap np).y)
  in { x,y }

rescaleNormBatchGlyphs :: Number
                       -> Pair Number
                       -> BatchGlyph (Normalized Point)
                       -> BatchGlyph Point
rescaleNormBatchGlyphs height seg bg@{points} =
  bg { points = map (scalePoint height seg) points }

rescaleNormSingleGlyphs :: Number
                        -> Pair Number
                        -> Array NormalizedGlyph
                        -> Array SingleGlyph
rescaleNormSingleGlyphs height seg =
  map (renderNormalized1 height seg)

withPixelSegments :: forall r m.
                     Monoid m
                  => CoordSys ChrId BigInt
                  -> { width :: Number | r }
                  -> Pair BigInt
                  -> (ChrId -> Pair Number -> m)
                  -> m
withPixelSegments cs cdim bView =
  let scale = { screenWidth: cdim.width
              , viewWidth: pairSize bView }
  in flip foldMapWithIndex (scaledSegments cs scale)

renderNormalizedTrack :: CoordSys ChrId BigInt
                      -> Canvas.Dimensions
                      -> Pair BigInt
                      -> Map ChrId (Either
                                      (BatchGlyph (Normalized Point))
                                      (Array NormalizedGlyph))
                      -- TODO concatting the segments with array is just lazy but works for now
                      --      optimally, a whole track should be one or the other type of glyph
                      -> Array (Either
                                  (BatchGlyph Point)
                                  (Array SingleGlyph))
renderNormalizedTrack cs cdim bView ngs =
  let segs :: Map ChrId (Pair Number)
      segs = scaledSegments cs { screenWidth: cdim.width, viewWidth: pairSize bView }

      renderSeg :: ChrId -> Pair Number -> Array (Either (BatchGlyph Point) (Array SingleGlyph))
      renderSeg k seg =
        pure $ fromMaybe (pure [])
               $ bimap
                 (rescaleNormBatchGlyphs  cdim.height seg)
                 (rescaleNormSingleGlyphs cdim.height seg)
                 <$> Map.lookup k ngs

  in foldMapWithIndex renderSeg segs

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

type RenderedTrack = Either (BatchGlyph Point) (Array SingleGlyph)

browser :: CoordSys ChrId BigInt
        -> Canvas.Dimensions
        -> Canvas.Dimensions
        -> UISlots
        -> { legend :: Legend, vscale :: VScale }
        -> List (Exists Track)
        -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
           , relativeUI :: Pair BigInt -> Drawing
           , fixedUI    :: Drawing }
browser cs trackDim overlayDim uiSlots ui inputTracks =
  let
      drawInSlot {offset, size} d =
          (translate offset.x offset.y
           $ filled (fillColor white)
           $ rectangle zero zero size.width size.height)
        <> translate offset.x offset.y d

      vScale = drawInSlot uiSlots.left (drawVScale ui.vscale uiSlots.left.size.height)

      legend = drawInSlot uiSlots.right (drawLegend ui.legend uiSlots.right.size.height)

      ruler   = Drawing.translate ui.vscale.width zero
                $ horRulerTrack ui.vscale red trackDim

      fixedUI = ruler <> vScale <> legend

      normTracks :: List (Map ChrId
                          (Either (BatchGlyph (Normalized Point))
                                  (Array NormalizedGlyph)))
      normTracks = runExists (\(Track r as) -> render r <$> as) <$> inputTracks

      tracks :: Pair BigInt -> List (Array (Either (BatchGlyph Point) (Array SingleGlyph)))
      tracks v = (renderNormalizedTrack cs trackDim v) <$> normTracks

      renderUIElement :: Map ChrId (Array NormalizedGlyph)
                      -> ChrId -> Pair Number -> Array SingleGlyph
      renderUIElement m k s
          = fold $ rescaleNormSingleGlyphs trackDim.height s
                <$> (Map.lookup k m)

      drawTrackUI :: Pair BigInt -> (ChrId -> Pair Number -> (Array _)) -> Drawing
      drawTrackUI v = foldMap f <<< withPixelSegments cs trackDim v
        where f {drawing, point} = Drawing.translate point.x point.y (drawing unit)

      chrLabels :: _
      chrLabels = renderUIElement $ chrLabelTrack cs trackDim

      relativeUI :: Pair BigInt -> Drawing
      relativeUI v = drawTrackUI v chrLabels

  in { tracks
     , relativeUI
     , fixedUI
     }


Add (very basic) BD track config validation

module Genetics.Browser.Config.Track
       where

import Prelude
import Data.Argonaut (Json, _Object)
import Data.Either (Either(..))
import Data.Foreign (Foreign, toForeign)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))

-- TODO add some BD validation
newtype BDTrackConfig = BDTrackConfig Foreign

makeBDTrack :: ∀ r. { name :: String | r } -> BDTrackConfig
makeBDTrack = (BDTrackConfig <<< toForeign)

validateBDConfig :: Json -> Either String BDTrackConfig
validateBDConfig json = case json ^? _Object <<< ix "name" of
  Nothing -> Left $ "BD track config does not have a name"
  Just c  -> Right $ BDTrackConfig $ toForeign json

module Genetics.Browser.Config.Track
       where

import Prelude
import Data.Foreign (Foreign, toForeign)

newtype BDTrackConfig = BDTrackConfig Foreign

makeBDTrack :: ∀ r. { name :: String | r } -> BDTrackConfig
makeBDTrack = (BDTrackConfig <<< toForeign)


Fix global menu parse error

Fix global menu parse error

{-
Copyright 2016 SlamData, Inc.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.GlobalMenu.Component
  ( comp
  , MenuSlot
  , QueryP
  , StateP
  , ChildQuery
  , Query(..)
  , ChildSlot
  , ChildState
  , module SlamData.GlobalMenu.Component.State
  ) where

import SlamData.Prelude

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Menu.Component as Menu
import Halogen.Query.EventSource as ES
--import Halogen.Menu.Component (MenuQuery(..), menuComponent) as HalogenMenu
--import Halogen.Menu.Component.State (MenuItem, makeMenu)
--import Halogen.Menu.Submenu.Component (SubmenuQuery(..)) as HalogenMenu

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.GlobalMenu.Component.State (State, initialState)
import SlamData.GlobalMenu.Menu.Component.Query (QueryP) as MenuQuery
import SlamData.GlobalMenu.Menu.Component.State as MenuState
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Wiring as Wiring

data AuthenticateOrPresentHelp
  = Authenticate (Maybe ProviderR)
  | PresentHelp String

data Query a
  = DismissSubmenu a
  | HandleGlobalError GlobalError a
  | HanldeMenuMessage Menu.Message a
  | Init a

type State =
  { loggedIn ∷ Boolean
  }

type HTML = H.ParentHTML Query Menu.Query Unit Slam
type DSL = H.ParentDSL State Query Menu.Query Unit Void Slam

component ∷ H.Component HH.HTML Query Unit Unit Slam
component =
  H.lifecycleParentComponent
    { initialState: \_ → { loggedIn: false }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ]
    [ HH.slot unit Menu.component helpMenu $ HE.input HandleMenuMessage
    ]

eval ∷ Query ~> DSL
eval (Init next) = do
  { bus } ← H.lift Wiring.expose
  H.subscribe (flip HandleGlobalError ES.Listening) $ busEventSource bus.globalError
  update
  pure next
eval (DismissSubmenu next) = do
  queryMenu $ H.action Menu.DismissSubmenu
  pure next
eval (HandleGlobalError error next) = case error of
  GlobalError.Unauthorized _ → update $> next
  _ → pure next
eval (HandleMenuMessage (Menu.Selected a) next) = do
  case a of
    Authenticate providerR → authenticate providerR
    PresentHelp uri → presentHelp uri
  pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload = do
    queryMenu
      $ H.action
      $ Menu.Set
        { chosen: Nothing
        , submenus:
            [ { label:
                fromMaybe "unknown user"
                $ map Crypt.runEmail
                $ Crypt.pluckEmail
                $ payload
              , submenu:
                [ { label: "🔒 Sign out"
                  , shortcutLabel: Nothing
                  , value: Authenticate Nothing
                  }
                ]
              }
            ]
            ⊕ helpMenu
        }
    H.modify _{ loggedIn = true }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = do
    eProviders ← Api.retrieveAuthProviders
    queryMenu
      $ H.action
      $ HalogenMenu.SetMenu
          { chosen: Nothing
          , submenus: case eProviders of
              Right (Just providers) →
                let
                  makeSubmenuItem provider =
                    { label: "Sign in with " ⊕ provider.displayName
                    , shortcutLabel: Nothing
                    , value: Authenticate $ Just provider
                    }
                in
                  [ { label: "🔓 Sign in"
                    , submenu: makeSubmenuItem <$> providers
                    }
                  ]
                ⊕ helpMenu
              _ → helpMenu
          }

helpMenu ∷ Array (MenuItem AuthenticateOrPresentHelp)
helpMenu =
  [ { label: "Help"
    , submenu:
      [ { label: "User guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/users-guide.html"
        }
      , { label: "Administrator guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/administration-guide.html"
        }
      , { label: "Developer guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/developers-guide.html"
        }
      , { label: "Helpful tips"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/helpful-tips.html"
        }
      , { label: "SQL² reference"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/sql-squared-reference.html"
        }
      , { label: "SlamDown reference"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/slamdown-reference.html"
        }
      , { label: "Troubleshooting FAQ"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/troubleshooting-faq.html"
        }
      ]
    }
  ]

queryMenu
  ∷ Menu.Query MenuState.AuthenticateOrPresentHelp Unit
  → DSL Unit
queryMenu q = void ∘ H.query unit

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = H.liftEff do
    AuthStore.clearIdToken keySuffix
    AuthStore.clearUnhashedNonce keySuffix
    AuthStore.clearProvider keySuffix
    Browser.reload

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  -- TODO: Reattempt failed actions without loosing state, remove reload.
  signInSuccess ∷ DSL Unit
  signInSuccess = do
    { auth } ← H.lift Wiring.expose
    H.liftAff $ Bus.write SignInSuccess auth.signIn
    update
    H.liftEff Browser.reload

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab

{-
Copyright 2016 SlamData, Inc.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.GlobalMenu.Component
  ( comp
  , MenuSlot
  , QueryP
  , StateP
  , ChildQuery
  , Query(..)
  , ChildSlot
  , ChildState
  , module SlamData.GlobalMenu.Component.State
  ) where

import SlamData.Prelude

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Menu.Component as Menu
import Halogen.Query.EventSource as ES
--import Halogen.Menu.Component (MenuQuery(..), menuComponent) as HalogenMenu
--import Halogen.Menu.Component.State (MenuItem, makeMenu)
--import Halogen.Menu.Submenu.Component (SubmenuQuery(..)) as HalogenMenu

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.GlobalMenu.Component.State (State, initialState)
import SlamData.GlobalMenu.Menu.Component.Query (QueryP) as MenuQuery
import SlamData.GlobalMenu.Menu.Component.State as MenuState
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Wiring as Wiring

data AuthenticateOrPresentHelp
  = Authenticate (Maybe ProviderR)
  | PresentHelp String

data Query a
  = DismissSubmenu a
  | HandleGlobalError GlobalError a
  | HanldeMenuMessage Menu.Message a
  | Init a

type State =
  { loggedIn ∷ Boolean
  }

type HTML = H.ParentHTML Query Menu.Query Unit Slam
type DSL = H.ParentDSL State Query Menu.Query Unit Void Slam

component ∷ H.Component HH.HTML Query Unit Unit Slam
component =
  H.lifecycleParentComponent
    { initialState: \_ → { loggedIn: false }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ]
    [ HH.slot unit Menu.component helpMenu $ HE.input HandleMenuMessage
    ]

eval ∷ Query ~> DSL
eval (Init next) = do
  { bus } ← H.lift Wiring.expose
  H.subscribe (flip HandleGlobalError ES.Listening) $ busEventSource bus.globalError
  update
  pure next
eval (DismissSubmenu next) = do
  queryMenu $ H.action Menu.DismissSubmenu
  pure next
eval (HandleGlobalError error next) = case error of
  GlobalError.Unauthorized _ → update $> next
  _ → pure next
eval (HandleMenuMessage (Menu.Selected a) next) = case a of
  Authenticate providerR → authenticate providerR
  PresentHelp uri → presentHelp uri
  pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload = do
    queryMenu
      $ H.action
      $ Menu.Set
        { chosen: Nothing
        , submenus:
            [ { label:
                fromMaybe "unknown user"
                $ map Crypt.runEmail
                $ Crypt.pluckEmail
                $ payload
              , submenu:
                [ { label: "🔒 Sign out"
                  , shortcutLabel: Nothing
                  , value: Authenticate Nothing
                  }
                ]
              }
            ]
            ⊕ helpMenu
        }
    H.modify _{ loggedIn = true }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = do
    eProviders ← Api.retrieveAuthProviders
    queryMenu
      $ H.action
      $ HalogenMenu.SetMenu
          { chosen: Nothing
          , submenus: case eProviders of
              Right (Just providers) →
                let
                  makeSubmenuItem provider =
                    { label: "Sign in with " ⊕ provider.displayName
                    , shortcutLabel: Nothing
                    , value: Authenticate $ Just provider
                    }
                in
                  [ { label: "🔓 Sign in"
                    , submenu: makeSubmenuItem <$> providers
                    }
                  ]
                ⊕ helpMenu
              _ → helpMenu
          }

helpMenu ∷ Array (MenuItem AuthenticateOrPresentHelp)
helpMenu =
  [ { label: "Help"
    , submenu:
      [ { label: "User guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/users-guide.html"
        }
      , { label: "Administrator guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/administration-guide.html"
        }
      , { label: "Developer guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/developers-guide.html"
        }
      , { label: "Helpful tips"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/helpful-tips.html"
        }
      , { label: "SQL² reference"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/sql-squared-reference.html"
        }
      , { label: "SlamDown reference"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/slamdown-reference.html"
        }
      , { label: "Troubleshooting FAQ"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v3.0/troubleshooting-faq.html"
        }
      ]
    }
  ]

queryMenu
  ∷ Menu.Query MenuState.AuthenticateOrPresentHelp Unit
  → DSL Unit
queryMenu q = void ∘ H.query unit

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = H.liftEff do
    AuthStore.clearIdToken keySuffix
    AuthStore.clearUnhashedNonce keySuffix
    AuthStore.clearProvider keySuffix
    Browser.reload

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  -- TODO: Reattempt failed actions without loosing state, remove reload.
  signInSuccess ∷ DSL Unit
  signInSuccess = do
    { auth } ← H.lift Wiring.expose
    H.liftAff $ Bus.write SignInSuccess auth.signIn
    update
    H.liftEff Browser.reload

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab


Add offLocation in Aff

Add offLocation in Aff

module Web.Firebase.Monad.Aff
(
  child
, convertError
, key
, offLocation
, on
, once
, onceValue
, push
, set
, fb2error
, firebaseErrToString
-- conveniencde functions to be split out at some point
, readRecord
, readSnapshot
, valueAt
)
where

import Prelude (Unit, ($), (<<<), bind, show, pure)

import Data.Maybe (Maybe(Just,Nothing))
import Control.Monad.Eff (Eff())
import Control.Monad.Aff (Aff(), makeAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error(), error)
import Control.Monad.Error.Class (throwError)

import Data.Either (Either(Left,Right))

import Data.Foreign (Foreign)
import Data.Foreign.Class (class IsForeign, readWith)

import Web.Firebase as FB
import Web.Firebase.Types as FBT
import Web.Firebase.DataSnapshot (val)

-- | Inspired by its Eff relative.
-- Throw takes a message and throws a MonadError in Aff with that message
throw :: forall eff a. String -> Aff eff a
throw = throwError <<< error

foreign import fb2error :: FBT.FirebaseErr -> Error
foreign import firebaseErrToString :: FBT.FirebaseErr -> String

-- | Gets a Firebase reference for the location at the specified relative path.
-- https://www.firebase.com/docs/web/api/firebase/child.html

child :: forall eff.
       FBT.Key ->
       FBT.Firebase ->
       Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
child aKey ref = liftEff $ FB.child aKey ref

-- | Returns the key of the current firebase reference
-- throws a MonadError if there was no key (i.e. when you ask for the key of the root reference, according to
-- https://www.firebase.com/docs/web/api/firebase/key.html
-- We made it an error, because asking a key of the root reference is a programming error, and should normally not happen.
-- One could specialize this in a Firebase type that can't be the root, or return '/' as the key.
key :: forall eff.
       FBT.Firebase ->
       Aff (firebase :: FBT.FirebaseEff | eff) FBT.Key
key fb = do
  mKey <- liftEff $ FB.key fb
  case mKey of
       Nothing -> throw "Key was null. Did you ask key of root reference?"
       Just k -> pure k

-- | This is the start of a more 'purescript-ish' interface than can be found in Web.Firebase
-- We use the Aff monad to eliminate callback hell
-- This way we can deal with callbacks that are called once.
-- We envision Web.Firebase.Signals to generate signals from callbacks that can be called multiple times

-- TODO this works for value, but will ignore the prevChild argument for onChildAdded etc.
on :: forall eff.
      FB.EventType ->
      FBT.Firebase ->
      Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
on etype fb = makeAff (\eb cb -> FB.on etype cb (convertError eb) fb)

-- convert firebase error to purescript Error in javascript
-- see .js file for firebase Error documentation
convertError :: forall eff. (Error -> Eff (firebase :: FBT.FirebaseEff | eff) Unit) ->
	 FBT.FirebaseErr ->
         Eff (firebase :: Web.Firebase.Types.FirebaseEff | eff) Unit
convertError errorCallback firebaseError = errorCallback (fb2error firebaseError)

-- We also take the liberty to write more specific functions, e.g. once and on() in firebase have 4 event types. we get better error messages and code completion by making specific functions, e.g.
-- onvalue and onchildadded instead of on(value) and on(childAdded)

once :: forall e. FB.EventType -> FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | e) FBT.DataSnapshot
once eventType root = makeAff (\errorCb successCb ->
		                FB.once eventType successCb (convertError errorCb) root)

push :: forall e. FBT.Firebase -> Foreign -> Aff (firebase :: FBT.FirebaseEff | e) FBT.Firebase
push ref value = makeAff (\onError onSuccess -> FB.pushA value onSuccess (convertError onError) ref)

set :: forall e. FBT.Firebase -> Foreign -> Aff (firebase :: FBT.FirebaseEff | e) Unit
set ref value = makeAff (\onError onSuccess -> FB.setA value onSuccess (convertError onError) ref)

-- | Extra functions not part of firebase api, grown out of our use
offLocation :: forall e. FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | e) Unit
offLocation = liftEff <<< FB.offSimple

onceValue :: forall e. FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | e) FBT.DataSnapshot
onceValue root = once FB.Value root

valueAt :: forall eff. FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | eff) Foreign
valueAt ref = do
       snap <- onceValue ref
       pure $ (val snap)

-- | read a record from a reference. Throws exception when any part fails
-- possible failures include network, database and conversion from Foreign value to purescript.
readRecord :: forall a eff. (IsForeign a) => FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | eff) a
readRecord ref = do
  value <- valueAt ref
  case (readWith show value) of
    Left msg    -> throw msg
    Right value -> pure value

-- | read a snapshot to a record. Throws exception when any part fails
-- possible failures include network, database and conversion from Foreign value to purescript.
readSnapshot :: forall a eff. (IsForeign a) => FBT.DataSnapshot -> Aff (firebase :: FBT.FirebaseEff | eff) a
readSnapshot snapshot = do
  let value = val snapshot
  case (readWith show value) of
    Left msg    -> throw msg
    Right value -> pure value

module Web.Firebase.Monad.Aff
(
  child
, convertError
, key
, on
, once
, onceValue
, push
, set
, fb2error
, firebaseErrToString
-- conveniencde functions to be split out at some point
, readRecord
, readSnapshot
, valueAt
)
where

import Prelude (Unit, ($), (<<<), bind, show, pure)

import Data.Maybe (Maybe(Just,Nothing))
import Control.Monad.Eff (Eff())
import Control.Monad.Aff (Aff(), makeAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error(), error)
import Control.Monad.Error.Class (throwError)

import Data.Either (Either(Left,Right))

import Data.Foreign (Foreign)
import Data.Foreign.Class (class IsForeign, readWith)

import Web.Firebase as FB
import Web.Firebase.Types as FBT
import Web.Firebase.DataSnapshot (val)

-- | Inspired by its Eff relative.
-- Throw takes a message and throws a MonadError in Aff with that message
throw :: forall eff a. String -> Aff eff a
throw = throwError <<< error

foreign import fb2error :: FBT.FirebaseErr -> Error
foreign import firebaseErrToString :: FBT.FirebaseErr -> String

-- | Gets a Firebase reference for the location at the specified relative path.
-- https://www.firebase.com/docs/web/api/firebase/child.html

child :: forall eff.
       FBT.Key ->
       FBT.Firebase ->
       Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
child aKey ref = liftEff $ FB.child aKey ref

-- | Returns the key of the current firebase reference
-- throws a MonadError if there was no key (i.e. when you ask for the key of the root reference, according to
-- https://www.firebase.com/docs/web/api/firebase/key.html
-- We made it an error, because asking a key of the root reference is a programming error, and should normally not happen.
-- One could specialize this in a Firebase type that can't be the root, or return '/' as the key.
key :: forall eff.
       FBT.Firebase ->
       Aff (firebase :: FBT.FirebaseEff | eff) FBT.Key
key fb = do
  mKey <- liftEff $ FB.key fb
  case mKey of
       Nothing -> throw "Key was null. Did you ask key of root reference?"
       Just k -> pure k

-- | This is the start of a more 'purescript-ish' interface than can be found in Web.Firebase
-- We use the Aff monad to eliminate callback hell
-- This way we can deal with callbacks that are called once.
-- We envision Web.Firebase.Signals to generate signals from callbacks that can be called multiple times

-- TODO this works for value, but will ignore the prevChild argument for onChildAdded etc.
on :: forall eff.
      FB.EventType ->
      FBT.Firebase ->
      Aff (firebase :: FBT.FirebaseEff | eff) FBT.DataSnapshot
on etype fb = makeAff (\eb cb -> FB.on etype cb (convertError eb) fb)

-- convert firebase error to purescript Error in javascript
-- see .js file for firebase Error documentation
convertError :: forall eff. (Error -> Eff (firebase :: FBT.FirebaseEff | eff) Unit) ->
	 FBT.FirebaseErr ->
         Eff (firebase :: Web.Firebase.Types.FirebaseEff | eff) Unit
convertError errorCallback firebaseError = errorCallback (fb2error firebaseError)

-- We also take the liberty to write more specific functions, e.g. once and on() in firebase have 4 event types. we get better error messages and code completion by making specific functions, e.g.
-- onvalue and onchildadded instead of on(value) and on(childAdded)

once :: forall e. FB.EventType -> FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | e) FBT.DataSnapshot
once eventType root = makeAff (\errorCb successCb ->
		                FB.once eventType successCb (convertError errorCb) root)

push :: forall e. FBT.Firebase -> Foreign -> Aff (firebase :: FBT.FirebaseEff | e) FBT.Firebase
push ref value = makeAff (\onError onSuccess -> FB.pushA value onSuccess (convertError onError) ref)

set :: forall e. FBT.Firebase -> Foreign -> Aff (firebase :: FBT.FirebaseEff | e) Unit
set ref value = makeAff (\onError onSuccess -> FB.setA value onSuccess (convertError onError) ref)

-- | Extra functions not part of firebase api, grown out of our use
onceValue :: forall e. FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | e) FBT.DataSnapshot
onceValue root = once FB.Value root

valueAt :: forall eff. FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | eff) Foreign
valueAt ref = do
       snap <- onceValue ref
       pure $ (val snap)

-- | read a record from a reference. Throws exception when any part fails
-- possible failures include network, database and conversion from Foreign value to purescript.
readRecord :: forall a eff. (IsForeign a) => FBT.Firebase -> Aff (firebase :: FBT.FirebaseEff | eff) a
readRecord ref = do
  value <- valueAt ref
  case (readWith show value) of
    Left msg    -> throw msg
    Right value -> pure value

-- | read a snapshot to a record. Throws exception when any part fails
-- possible failures include network, database and conversion from Foreign value to purescript.
readSnapshot :: forall a eff. (IsForeign a) => FBT.DataSnapshot -> Aff (firebase :: FBT.FirebaseEff | eff) a
readSnapshot snapshot = do
  let value = val snapshot
  case (readWith show value) of
    Left msg    -> throw msg
    Right value -> pure value


Notebook will most likely be directories

module Model.Resource (
  FilePath(), DirPath(), AnyPath(), Resource(),
  isNotebook, isFile, isDatabase, isDirectory,
  resourceTag, getPath, getNameStr, getDir,
  setDir, renameAny, resourceName, resourceDir,
  nameOfFileOrDir, root, resourcePath,
  newFile, newDatabase, newDirectory, newNotebook,
  mkFile, mkDatabase, mkDirectory, mkNotebook,
  setPath, setName, nameAnyPath, rootAnyPath,
  pathL, rootL, nameL, sortResource, parent,
  resourceFileName
  ) where

import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Inject1
import Data.Path.Pathy
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign (ForeignError(TypeMismatch))
import Data.Bifunctor (bimap)
import Optic.Core (lens, LensP())
import Model.Sort (Sort(..))
import Utils
import Config

type FilePath = AbsFile Sandboxed
type DirPath = AbsDir Sandboxed
type AnyPath = Either FilePath DirPath

data Resource
  = File FilePath
  | Notebook FilePath
  | Directory DirPath
  | Database DirPath

isNotebook :: Resource -> Boolean
isNotebook (Notebook _) = true
isNotebook _ = false

isFile :: Resource -> Boolean
isFile (File _) = true
isFile _ = false

isDirectory :: Resource -> Boolean
isDirectory (Directory _) = true
isDirectory _ = false

isDatabase :: Resource -> Boolean
isDatabase (Database _) = true
isDatabase _ = false

resourceTag :: Resource -> String
resourceTag r = case r of
  File _ -> "file"
  Database _ -> "mount"
  Notebook _ -> "notebook"
  Directory _ -> "directory"

getPath :: Resource -> AnyPath
getPath r = case r of
  File p -> inj p
  Notebook p -> inj p
  Directory p -> inj p
  Database p -> inj p

getNameStr :: AnyPath -> String
getNameStr ap = either getNameStr' getNameStr' ap
  where
  getNameStr' :: forall b a s. Path a b s -> String
  getNameStr' p = maybe "" (snd >>> nameOfFileOrDir) $ peel p

getDir :: AnyPath -> DirPath
getDir ap = either getDir' getDir' ap
  where
  getDir' :: forall b. Path Abs b Sandboxed -> DirPath
  getDir' p = maybe rootDir fst $ peel p

setDir :: AnyPath -> DirPath -> AnyPath
setDir ap d = bimap (setFile' d) (setDir' d) ap
  where
  setDir' :: DirPath -> DirPath -> DirPath
  setDir' d p =
    d </>
    (maybe currentDir (snd >>> nameOfFileOrDir >>> dir) $ peel p)

  setFile' :: DirPath -> FilePath -> FilePath
  setFile' d p =
    d </>
    (maybe (file "") (snd >>> nameOfFileOrDir >>> file) $ peel p)

renameAny :: (String -> String) -> AnyPath -> AnyPath
renameAny fn ap = bimap (renameFile $ liftFile fn) (renameDir $ liftDir fn) ap
  where
  liftFile fn (FileName a) = FileName $ fn a
  liftDir fn (DirName a) = DirName $ fn a

resourceName :: Resource -> String
resourceName = getPath >>> getNameStr

resourceDir :: Resource -> DirPath
resourceDir = getPath >>> getDir

resourceFileName :: Resource -> String
resourceFileName r =
  if isNotebook r
  then resourceFileName' $ getPath r
  else resourceName r
  where
  resourceFileName' ap = maybe "" (snd >>> dropExt >>> nameOfFileOrDir) $
                         either peel peel ap
  dropExt = bimap id dropExtension

nameOfFileOrDir :: Either DirName FileName -> String
nameOfFileOrDir (Left (DirName name)) = name
nameOfFileOrDir (Right (FileName name)) = name

root :: Resource
root = Directory rootDir

-- This is not real parent because it can't determine
-- is it a directory or mount
parent :: Resource -> Resource
parent = Directory <<< resourceDir

resourcePath :: Resource -> String
resourcePath r = either printPath printPath $ getPath r

newNotebook :: Resource
newNotebook = Notebook $ rootDir </> file newNotebookName

newFile :: Resource
newFile = File $ rootDir </> file newFileName

newDirectory :: Resource
newDirectory = Directory $ rootDir </> dir newFolderName

newDatabase :: Resource
newDatabase = Database $ rootDir </> dir newDatabaseName

mkNotebook :: AnyPath -> Resource
mkNotebook ap =
  either (Notebook <<< (<.> notebookExtension)) go ap
  where
  go :: DirPath -> Resource
  go p = maybe newNotebook id do
    Tuple pp dirOrFile <- peel p
    pure $ Notebook
      (pp </> file (nameOfFileOrDir dirOrFile) <.> notebookExtension)

mkFile :: AnyPath -> Resource
mkFile ap = either File go ap
  where
  go :: DirPath -> Resource
  go p = maybe newFile id do
    Tuple pp dirOrFile <- peel p
    pure $ File (pp </> file (nameOfFileOrDir dirOrFile))

mkDirectory :: AnyPath -> Resource
mkDirectory ap = either go Directory ap
  where
  go :: FilePath -> Resource
  go p = maybe newDirectory id do
    Tuple pp dirOrFile <- peel p
    pure $ Directory (pp </> dir (nameOfFileOrDir dirOrFile))

mkDatabase :: AnyPath -> Resource
mkDatabase ap = either go Database ap
  where
  go :: FilePath -> Resource
  go p = maybe newDatabase id do
    Tuple pp dirOrFile <- peel p
    pure $ Database (pp </> dir (nameOfFileOrDir dirOrFile))

setPath :: Resource -> AnyPath -> Resource
setPath (Notebook _) p = mkNotebook p
setPath (File _) p = mkFile p
setPath (Database _) p = mkDatabase p
setPath (Directory _) p = mkDirectory p

setName :: Resource -> String -> Resource
setName r name =
  setPath r ((renameAny (const name) (getPath r)))

pathL :: LensP Resource AnyPath
pathL = lens getPath setPath

nameAnyPath :: LensP AnyPath String
nameAnyPath = lens getNameStr (\p x -> renameAny (const x) p)

nameL :: LensP Resource String
nameL = pathL <<< nameAnyPath

rootAnyPath :: LensP AnyPath DirPath
rootAnyPath = lens getDir setDir

rootL :: LensP Resource DirPath
rootL = pathL <<< rootAnyPath

instance resourceEq :: Eq Resource where
  (==) (File p) (File p') = p == p'
  (==) (Notebook p) (Notebook p') = p == p'
  (==) (Directory p) (Directory p') = p == p'
  (==) (Database p) (Database p') = p == p'
  (==) _ _ = false
  (/=) a b = not $ a == b

instance resourceIsForeign :: IsForeign Resource where
  read f = do
    name <- readProp "name" f
    ty <- readProp "type" f
    template <- case ty of
      "mount" -> pure newDatabase
      "directory" -> pure $ if endsWith notebookExtension name
                       then newNotebook
                       else newDirectory
      "file" -> pure $ if endsWith notebookExtension name
                       then newNotebook
                       else newFile
      _ -> Left $ TypeMismatch "resource" "string"
    pure $ setName template name

sortResource :: (Resource -> String) -> Sort -> Resource -> Resource -> Ordering
sortResource project direction a b =
  case direction of
    Asc -> compare (project a) (project b)
    Desc -> compare (project b) (project a)

instance resourceOrd :: Ord Resource where
  compare = sortResource resourcePath Asc

module Model.Resource (
  FilePath(), DirPath(), AnyPath(), Resource(),
  isNotebook, isFile, isDatabase, isDirectory,
  resourceTag, getPath, getNameStr, getDir,
  setDir, renameAny, resourceName, resourceDir,
  nameOfFileOrDir, root, resourcePath,
  newFile, newDatabase, newDirectory, newNotebook,
  mkFile, mkDatabase, mkDirectory, mkNotebook,
  setPath, setName, nameAnyPath, rootAnyPath,
  pathL, rootL, nameL, sortResource, parent,
  resourceFileName
  ) where

import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Inject1
import Data.Path.Pathy
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign (ForeignError(TypeMismatch))
import Data.Bifunctor (bimap)
import Optic.Core (lens, LensP())
import Model.Sort (Sort(..))
import Utils
import Config

type FilePath = AbsFile Sandboxed
type DirPath = AbsDir Sandboxed
type AnyPath = Either FilePath DirPath

data Resource
  = File FilePath
  | Notebook FilePath
  | Directory DirPath
  | Database DirPath

isNotebook :: Resource -> Boolean
isNotebook (Notebook _) = true
isNotebook _ = false

isFile :: Resource -> Boolean
isFile (File _) = true
isFile _ = false

isDirectory :: Resource -> Boolean
isDirectory (Directory _) = true
isDirectory _ = false

isDatabase :: Resource -> Boolean
isDatabase (Database _) = true
isDatabase _ = false

resourceTag :: Resource -> String
resourceTag r = case r of
  File _ -> "file"
  Database _ -> "mount"
  Notebook _ -> "notebook"
  Directory _ -> "directory"

getPath :: Resource -> AnyPath
getPath r = case r of
  File p -> inj p
  Notebook p -> inj p
  Directory p -> inj p
  Database p -> inj p

getNameStr :: AnyPath -> String
getNameStr ap = either getNameStr' getNameStr' ap
  where
  getNameStr' :: forall b a s. Path a b s -> String
  getNameStr' p = maybe "" (snd >>> nameOfFileOrDir) $ peel p

getDir :: AnyPath -> DirPath
getDir ap = either getDir' getDir' ap
  where
  getDir' :: forall b. Path Abs b Sandboxed -> DirPath
  getDir' p = maybe rootDir fst $ peel p

setDir :: AnyPath -> DirPath -> AnyPath
setDir ap d = bimap (setFile' d) (setDir' d) ap
  where
  setDir' :: DirPath -> DirPath -> DirPath
  setDir' d p =
    d </>
    (maybe currentDir (snd >>> nameOfFileOrDir >>> dir) $ peel p)

  setFile' :: DirPath -> FilePath -> FilePath
  setFile' d p =
    d </>
    (maybe (file "") (snd >>> nameOfFileOrDir >>> file) $ peel p)

renameAny :: (String -> String) -> AnyPath -> AnyPath
renameAny fn ap = bimap (renameFile $ liftFile fn) (renameDir $ liftDir fn) ap
  where
  liftFile fn (FileName a) = FileName $ fn a
  liftDir fn (DirName a) = DirName $ fn a

resourceName :: Resource -> String
resourceName = getPath >>> getNameStr

resourceDir :: Resource -> DirPath
resourceDir = getPath >>> getDir

resourceFileName :: Resource -> String
resourceFileName r =
  if isNotebook r
  then resourceFileName' $ getPath r
  else resourceName r
  where
  resourceFileName' ap = maybe "" (snd >>> dropExt >>> nameOfFileOrDir) $
                         either peel peel ap
  dropExt = bimap id dropExtension

nameOfFileOrDir :: Either DirName FileName -> String
nameOfFileOrDir (Left (DirName name)) = name
nameOfFileOrDir (Right (FileName name)) = name

root :: Resource
root = Directory rootDir

-- This is not real parent because it can't determine
-- is it a directory or mount
parent :: Resource -> Resource
parent = Directory <<< resourceDir

resourcePath :: Resource -> String
resourcePath r = either printPath printPath $ getPath r

newNotebook :: Resource
newNotebook = Notebook $ rootDir </> file newNotebookName

newFile :: Resource
newFile = File $ rootDir </> file newFileName

newDirectory :: Resource
newDirectory = Directory $ rootDir </> dir newFolderName

newDatabase :: Resource
newDatabase = Database $ rootDir </> dir newDatabaseName

mkNotebook :: AnyPath -> Resource
mkNotebook ap =
  either (Notebook <<< (<.> notebookExtension)) go ap
  where
  go :: DirPath -> Resource
  go p = maybe newNotebook id do
    Tuple pp dirOrFile <- peel p
    pure $ Notebook
      (pp </> file (nameOfFileOrDir dirOrFile) <.> notebookExtension)

mkFile :: AnyPath -> Resource
mkFile ap = either File go ap
  where
  go :: DirPath -> Resource
  go p = maybe newFile id do
    Tuple pp dirOrFile <- peel p
    pure $ File (pp </> file (nameOfFileOrDir dirOrFile))

mkDirectory :: AnyPath -> Resource
mkDirectory ap = either go Directory ap
  where
  go :: FilePath -> Resource
  go p = maybe newDirectory id do
    Tuple pp dirOrFile <- peel p
    pure $ Directory (pp </> dir (nameOfFileOrDir dirOrFile))

mkDatabase :: AnyPath -> Resource
mkDatabase ap = either go Database ap
  where
  go :: FilePath -> Resource
  go p = maybe newDatabase id do
    Tuple pp dirOrFile <- peel p
    pure $ Database (pp </> dir (nameOfFileOrDir dirOrFile))

setPath :: Resource -> AnyPath -> Resource
setPath (Notebook _) p = mkNotebook p
setPath (File _) p = mkFile p
setPath (Database _) p = mkDatabase p
setPath (Directory _) p = mkDirectory p

setName :: Resource -> String -> Resource
setName r name =
  setPath r ((renameAny (const name) (getPath r)))

pathL :: LensP Resource AnyPath
pathL = lens getPath setPath

nameAnyPath :: LensP AnyPath String
nameAnyPath = lens getNameStr (\p x -> renameAny (const x) p)

nameL :: LensP Resource String
nameL = pathL <<< nameAnyPath

rootAnyPath :: LensP AnyPath DirPath
rootAnyPath = lens getDir setDir

rootL :: LensP Resource DirPath
rootL = pathL <<< rootAnyPath

instance resourceEq :: Eq Resource where
  (==) (File p) (File p') = p == p'
  (==) (Notebook p) (Notebook p') = p == p'
  (==) (Directory p) (Directory p') = p == p'
  (==) (Database p) (Database p') = p == p'
  (==) _ _ = false
  (/=) a b = not $ a == b

instance resourceIsForeign :: IsForeign Resource where
  read f = do
    name <- readProp "name" f
    ty <- readProp "type" f
    template <- case ty of
      "mount" -> pure newDatabase
      "directory" -> pure newDirectory
      "file" -> pure $ if endsWith notebookExtension name
                       then newNotebook
                       else newFile
      _ -> Left $ TypeMismatch "resource" "string"
    pure $ setName template name

sortResource :: (Resource -> String) -> Sort -> Resource -> Resource -> Ordering
sortResource project direction a b =
  case direction of
    Asc -> compare (project a) (project b)
    Desc -> compare (project b) (project a)

instance resourceOrd :: Ord Resource where
  compare = sortResource resourcePath Asc


forgot to hide Resource constructors

forgot to hide Resource constructors

module Model.Resource (
  FilePath(), DirPath(), AnyPath(), Resource(),
  isNotebook, isFile, isDatabase, isDirectory,
  resourceTag, getPath, getNameStr, getDir,
  setDir, renameAny, resourceName, resourceDir,
  nameOfFileOrDir, root, resourcePath,
  newFile, newDatabase, newDirectory, newNotebook,
  mkFile, mkDatabase, mkDirectory, mkNotebook,
  setPath, setName, nameAnyPath, rootAnyPath,
  pathL, rootL, nameL, sortResource
  ) where

import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Inject1
import Data.Path.Pathy
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign (ForeignError(TypeMismatch))
import Data.Bifunctor (bimap)
import Optic.Core (lens, LensP())
import Model.Sort (Sort(..))
import Utils
import Config

type FilePath = AbsFile Sandboxed
type DirPath = AbsDir Sandboxed
type AnyPath = Either FilePath DirPath

data Resource
  = File FilePath
  | Notebook FilePath
  | Directory DirPath
  | Database DirPath

isNotebook :: Resource -> Boolean
isNotebook (Notebook _) = true
isNotebook _ = false

isFile :: Resource -> Boolean
isFile (File _) = true
isFile _ = false

isDirectory :: Resource -> Boolean
isDirectory (Directory _) = true
isDirectory _ = false

isDatabase :: Resource -> Boolean
isDatabase (Database _) = true
isDatabase _ = false

resourceTag :: Resource -> String
resourceTag r = case r of
  File _ -> "file"
  Database _ -> "mount"
  Notebook _ -> "notebook"
  Directory _ -> "directory"

getPath :: Resource -> AnyPath
getPath r = case r of
  File p -> inj p
  Notebook p -> inj p
  Directory p -> inj p
  Database p -> inj p

getNameStr :: AnyPath -> String
getNameStr ap = either getNameStr' getNameStr' ap
  where
  getNameStr' :: forall b a s. Path a b s -> String
  getNameStr' p = maybe "" (snd >>> nameOfFileOrDir) $ peel p

getDir :: AnyPath -> DirPath
getDir ap = either getDir' getDir' ap
  where
  getDir' :: forall b. Path Abs b Sandboxed -> DirPath
  getDir' p = maybe rootDir fst $ peel p

setDir :: AnyPath -> DirPath -> AnyPath
setDir ap d = bimap (setFile' d) (setDir' d) ap
  where
  setDir' :: DirPath -> DirPath -> DirPath
  setDir' d p =
    d </>
    (maybe currentDir (snd >>> nameOfFileOrDir >>> dir) $ peel p)

  setFile' :: DirPath -> FilePath -> FilePath
  setFile' d p =
    d </>
    (maybe (file "") (snd >>> nameOfFileOrDir >>> file) $ peel p)

renameAny :: (String -> String) -> AnyPath -> AnyPath
renameAny fn ap = bimap (renameFile $ liftFile fn) (renameDir $ liftDir fn) ap
  where
  liftFile fn (FileName a) = FileName $ fn a
  liftDir fn (DirName a) = DirName $ fn a

resourceName :: Resource -> String
resourceName = getPath >>> getNameStr

resourceDir :: Resource -> DirPath
resourceDir = getPath >>> getDir

nameOfFileOrDir :: Either DirName FileName -> String
nameOfFileOrDir (Left (DirName name)) = name
nameOfFileOrDir (Right (FileName name)) = name

root :: Resource
root = Directory rootDir

resourcePath :: Resource -> String
resourcePath r = either printPath printPath $ getPath r

newNotebook :: Resource
newNotebook = Notebook $ rootDir </> file newNotebookName

newFile :: Resource
newFile = File $ rootDir </> file newFileName

newDirectory :: Resource
newDirectory = Directory $ rootDir </> dir newFolderName

newDatabase :: Resource
newDatabase = Database $ rootDir </> dir newDatabaseName

mkNotebook :: AnyPath -> Resource
mkNotebook ap =
  either (Notebook <<< (<.> notebookExtension)) go ap
  where
  go :: DirPath -> Resource
  go p = maybe newNotebook id do
    Tuple pp dirOrFile <- peel p
    pure $ Notebook
      (pp </> file (nameOfFileOrDir dirOrFile) <.> notebookExtension)

mkFile :: AnyPath -> Resource
mkFile ap = either File go ap
  where
  go :: DirPath -> Resource
  go p = maybe newFile id do
    Tuple pp dirOrFile <- peel p
    pure $ File (pp </> file (nameOfFileOrDir dirOrFile))

mkDirectory :: AnyPath -> Resource
mkDirectory ap = either go Directory ap
  where
  go :: FilePath -> Resource
  go p = maybe newDirectory id do
    Tuple pp dirOrFile <- peel p
    pure $ Directory (pp </> dir (nameOfFileOrDir dirOrFile))

mkDatabase :: AnyPath -> Resource
mkDatabase ap = either go Database ap
  where
  go :: FilePath -> Resource
  go p = maybe newDatabase id do
    Tuple pp dirOrFile <- peel p
    pure $ Database (pp </> dir (nameOfFileOrDir dirOrFile))

setPath :: Resource -> AnyPath -> Resource
setPath (Notebook _) p = mkNotebook p
setPath (File _) p = mkFile p
setPath (Database _) p = mkDatabase p
setPath (Directory _) p = mkDirectory p

setName :: Resource -> String -> Resource
setName r name =
  setPath r ((renameAny (const name) (getPath r)))

pathL :: LensP Resource AnyPath
pathL = lens getPath setPath

nameAnyPath :: LensP AnyPath String
nameAnyPath = lens getNameStr (\p x -> renameAny (const x) p)

nameL :: LensP Resource String
nameL = pathL <<< nameAnyPath

rootAnyPath :: LensP AnyPath DirPath
rootAnyPath = lens getDir setDir

rootL :: LensP Resource DirPath
rootL = pathL <<< rootAnyPath

instance resourceEq :: Eq Resource where
  (==) (File p) (File p') = p == p'
  (==) (Notebook p) (Notebook p') = p == p'
  (==) (Directory p) (Directory p') = p == p'
  (==) (Database p) (Database p') = p == p'
  (==) _ _ = false
  (/=) a b = not $ a == b

instance resourceIsForeign :: IsForeign Resource where
  read f = do
    name <- readProp "name" f
    ty <- readProp "type" f
    template <- case ty of
      "mount" -> pure newDatabase
      "directory" -> pure newDirectory
      "file" -> pure $ if endsWith notebookExtension name
                       then newNotebook
                       else newFile
      _ -> Left $ TypeMismatch "resource" "string"
    pure $ setName template name

sortResource :: (Resource -> String) -> Sort -> Resource -> Resource -> Ordering
sortResource project direction a b =
  case direction of
    Asc -> compare (project a) (project b)
    Desc -> compare (project b) (project a)

instance resourceOrd :: Ord Resource where
  compare = sortResource resourcePath Asc

module Model.Resource where

import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Inject1
import Data.Path.Pathy
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign (ForeignError(TypeMismatch))
import Data.Bifunctor (bimap)
import Optic.Core (lens, LensP())
import Model.Sort (Sort(..))
import Utils
import Config

type FilePath = AbsFile Sandboxed
type DirPath = AbsDir Sandboxed
type AnyPath = Either FilePath DirPath

data Resource
  = File FilePath
  | Notebook FilePath
  | Directory DirPath
  | Database DirPath

isNotebook :: Resource -> Boolean
isNotebook (Notebook _) = true
isNotebook _ = false

isFile :: Resource -> Boolean
isFile (File _) = true
isFile _ = false

isDirectory :: Resource -> Boolean
isDirectory (Directory _) = true
isDirectory _ = false

isDatabase :: Resource -> Boolean
isDatabase (Database _) = true
isDatabase _ = false

resourceTag :: Resource -> String
resourceTag r = case r of
  File _ -> "file"
  Database _ -> "mount"
  Notebook _ -> "notebook"
  Directory _ -> "directory"

getPath :: Resource -> AnyPath
getPath r = case r of
  File p -> inj p
  Notebook p -> inj p
  Directory p -> inj p
  Database p -> inj p

getNameStr :: AnyPath -> String
getNameStr ap = either getNameStr' getNameStr' ap
  where
  getNameStr' :: forall b a s. Path a b s -> String
  getNameStr' p = maybe "" (snd >>> nameOfFileOrDir) $ peel p

getDir :: AnyPath -> DirPath
getDir ap = either getDir' getDir' ap
  where
  getDir' :: forall b. Path Abs b Sandboxed -> DirPath
  getDir' p = maybe rootDir fst $ peel p

setDir :: AnyPath -> DirPath -> AnyPath
setDir ap d = bimap (setFile' d) (setDir' d) ap
  where
  setDir' :: DirPath -> DirPath -> DirPath
  setDir' d p =
    d </>
    (maybe currentDir (snd >>> nameOfFileOrDir >>> dir) $ peel p)

  setFile' :: DirPath -> FilePath -> FilePath
  setFile' d p =
    d </>
    (maybe (file "") (snd >>> nameOfFileOrDir >>> file) $ peel p)

renameAny :: (String -> String) -> AnyPath -> AnyPath
renameAny fn ap = bimap (renameFile $ liftFile fn) (renameDir $ liftDir fn) ap
  where
  liftFile fn (FileName a) = FileName $ fn a
  liftDir fn (DirName a) = DirName $ fn a

resourceName :: Resource -> String
resourceName = getPath >>> getNameStr

resourceDir :: Resource -> DirPath
resourceDir = getPath >>> getDir

nameOfFileOrDir :: Either DirName FileName -> String
nameOfFileOrDir (Left (DirName name)) = name
nameOfFileOrDir (Right (FileName name)) = name

root :: Resource
root = Directory rootDir

resourcePath :: Resource -> String
resourcePath r = either printPath printPath $ getPath r

newNotebook :: Resource
newNotebook = Notebook $ rootDir </> file newNotebookName

newFile :: Resource
newFile = File $ rootDir </> file newFileName

newDirectory :: Resource
newDirectory = Directory $ rootDir </> dir newFolderName

newDatabase :: Resource
newDatabase = Database $ rootDir </> dir newDatabaseName

mkNotebook :: AnyPath -> Resource
mkNotebook ap =
  either (Notebook <<< (<.> notebookExtension)) go ap
  where
  go :: DirPath -> Resource
  go p = maybe newNotebook id do
    Tuple pp dirOrFile <- peel p
    pure $ Notebook
      (pp </> file (nameOfFileOrDir dirOrFile) <.> notebookExtension)

mkFile :: AnyPath -> Resource
mkFile ap = either File go ap
  where
  go :: DirPath -> Resource
  go p = maybe newFile id do
    Tuple pp dirOrFile <- peel p
    pure $ File (pp </> file (nameOfFileOrDir dirOrFile))

mkDirectory :: AnyPath -> Resource
mkDirectory ap = either go Directory ap
  where
  go :: FilePath -> Resource
  go p = maybe newDirectory id do
    Tuple pp dirOrFile <- peel p
    pure $ Directory (pp </> dir (nameOfFileOrDir dirOrFile))

mkDatabase :: AnyPath -> Resource
mkDatabase ap = either go Database ap
  where
  go :: FilePath -> Resource
  go p = maybe newDatabase id do
    Tuple pp dirOrFile <- peel p
    pure $ Database (pp </> dir (nameOfFileOrDir dirOrFile))

setPath :: Resource -> AnyPath -> Resource
setPath (Notebook _) p = mkNotebook p
setPath (File _) p = mkFile p
setPath (Database _) p = mkDatabase p
setPath (Directory _) p = mkDirectory p

setName :: Resource -> String -> Resource
setName r name =
  setPath r ((renameAny (const name) (getPath r)))

pathL :: LensP Resource AnyPath
pathL = lens getPath setPath

nameAnyPath :: LensP AnyPath String
nameAnyPath = lens getNameStr (\p x -> renameAny (const x) p)

nameL :: LensP Resource String
nameL = pathL <<< nameAnyPath

rootAnyPath :: LensP AnyPath DirPath
rootAnyPath = lens getDir setDir

rootL :: LensP Resource DirPath
rootL = pathL <<< rootAnyPath

instance resourceEq :: Eq Resource where
  (==) (File p) (File p') = p == p'
  (==) (Notebook p) (Notebook p') = p == p'
  (==) (Directory p) (Directory p') = p == p'
  (==) (Database p) (Database p') = p == p'
  (==) _ _ = false
  (/=) a b = not $ a == b

instance resourceIsForeign :: IsForeign Resource where
  read f = do
    name <- readProp "name" f
    ty <- readProp "type" f
    template <- case ty of
      "mount" -> pure newDatabase
      "directory" -> pure newDirectory
      "file" -> pure $ if endsWith notebookExtension name
                       then newNotebook
                       else newFile
      _ -> Left $ TypeMismatch "resource" "string"
    pure $ setName template name

sortResource :: (Resource -> String) -> Sort -> Resource -> Resource -> Ordering
sortResource project direction a b =
  case direction of
    Asc -> compare (project a) (project b)
    Desc -> compare (project b) (project a)

instance resourceOrd :: Ord Resource where
  compare = sortResource resourcePath Asc