redoing snp renderer w/ hitbox support

redoing snp renderer w/ hitbox support

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.Profunctor.Strong (fanout)
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, CoordSysView(..), Normalized(..), ViewScale(..), _Segments, pairSize, pairsOverlap, scaledSegments, viewScale)
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"

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

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

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

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 HPosN = Pair (Normalized Number)

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

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

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
     }

--------------------------

type Feature' a = { segmentSize :: Bp
                  , pos         :: Pair Bp
                  , feature     :: a }

type DrawingN = { drawing :: Drawing, points :: Array Point }

type Render a =
     CoordSys ChrId BigInt   -- probably superfluous w/ Pair BigInt in the later tuple
  -> Canvas.Dimensions
  -> Tuple (Pair BigInt) (Array a)
  -> CoordSysView
  -> { features :: Array a
     , drawings :: Array DrawingN
     , overlaps :: Number -> Point -> Array a }

type SNPFeature r = Feature' { score :: Number | r }

placeSNP :: forall r1 r2.
            { min :: Number, max :: Number | r1 }
         -> SNPFeature r2
         -> NPoint
placeSNP {min, max} { segmentSize, pos: (Pair l _), feature } = {x, y}
  where x = Normalized $ unwrap $ l / segmentSize
        y = Normalized $ (feature.score - min) / (max - min)

renderSNP :: forall r.
             CoordSys ChrId BigInt
          -> { min :: Number, max :: Number | r }
          -> Canvas.Dimensions
          -> Tuple (Pair BigInt) (Array (SNPFeature ()))
          -> CoordSysView
          -> { features :: Array (SNPFeature ())
             , drawings :: Array DrawingN
             , overlaps :: Number -> Point -> Array (SNPFeature ()) }
renderSNP csys verscale cdim (Tuple seg snps) =
  let features = snps

      radius = 2.2

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

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

      npointed :: Array (Tuple (SNPFeature ()) NPoint)
      npointed = map (fanout id (placeSNP verscale)) snps

      scale :: CoordSysView -> ViewScale
      scale csv = viewScale cdim csv

      -- doesn't translate (esp. horizontally), only scales
      rescale :: Number -> NPoint -> Point
      rescale sc npoint =
        let x = sc * (unwrap npoint.x)
            y = cdim.height * unwrap npoint.y
        in {x, y}

      pointed :: CoordSysView -> Array (Tuple (SNPFeature ()) Point)
      pointed csv = (map <<< map) (rescale s) npointed
        where s = ?pixelsView_something

      overlaps :: Array (Tuple (SNPFeature ()) Point)
               -> Number -> Point
               -> Array (SNPFeature ())
      overlaps pts radius' pt = unsafeCoerce unit

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

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
     }


Test that form parsing handles percent-encoded URI components

module Hyper.FormSpec where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Either (Either(..))
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.StrMap (singleton)
import Data.Tuple (Tuple(Tuple), fst)
import Hyper.Form (Form(Form), parseForm)
import Hyper.Middleware (runMiddleware)
import Hyper.Test.TestServer (TestRequest(TestRequest))
import Test.Spec (Spec, it, describe)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)

liftEither ∷ ∀ e a. Either String a → Aff e a
liftEither e =
  case e of
    Left err → throwError (error err)
    Right x → pure x

spec :: forall e. Spec e Unit
spec =
  describe "Hyper.Form" do
    it "parses key without value" do
      form <- runParseForm "foo" Nothing
      form `shouldEqual` (Form [Tuple "foo" Nothing])

    it "parses multiple keys without values" do
      form <- runParseForm "foo&foo&bar&foo" Nothing
      form `shouldEqual` (Form [ Tuple "foo" Nothing
                               , Tuple "foo" Nothing
                               , Tuple "bar" Nothing
                               , Tuple "foo" Nothing
                               ])

    it "parses key and value" do
      form <- runParseForm "foo=bar" Nothing
      form `shouldEqual` (Form [Tuple "foo" (Just "bar")])

    it "handles percent-encoding" do
      form <- runParseForm "foo=%62%61%72" Nothing
      form `shouldEqual` (Form [Tuple "foo" (Just "bar")])

    it "parses multiple keys and values" do
      form <- runParseForm "foo=bar&baz=quux&a=1&b=2" Nothing
      form `shouldEqual` (Form [ Tuple "foo" (Just "bar")
                               , Tuple "baz" (Just "quux")
                               , Tuple "a" (Just "1")
                               , Tuple "b" (Just "2")
                               ])

    it "fails to parse request body as a form when invalid" $ expectError $
      runParseForm "foo=bar=baz" Nothing

  where
    runParseForm body contentType =
      runMiddleware
      parseForm
      { request: TestRequest { method: Left GET
                             , body: body
                             , url: ""
                             , headers: singleton
                                         "content-type"
                                         (fromMaybe
                                         "application/x-www-form-urlencoded; charset=utf8"
                                         contentType)
                             }
      , response: {}
      , components: {}
      }
      # map fst
      >>= liftEither

module Hyper.FormSpec where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Either (Either(..))
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.StrMap (singleton)
import Data.Tuple (Tuple(Tuple), fst)
import Hyper.Form (Form(Form), parseForm)
import Hyper.Middleware (runMiddleware)
import Hyper.Test.TestServer (TestRequest(TestRequest))
import Test.Spec (Spec, it, describe)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)

liftEither ∷ ∀ e a. Either String a → Aff e a
liftEither e =
  case e of
    Left err → throwError (error err)
    Right x → pure x

spec :: forall e. Spec e Unit
spec =
  describe "Hyper.Form" do
    it "parses key without value" do
      form <- runParseForm "foo" Nothing
      form `shouldEqual` (Form [Tuple "foo" Nothing])

    it "parses multiple keys without values" do
      form <- runParseForm "foo&foo&bar&foo" Nothing
      form `shouldEqual` (Form [ Tuple "foo" Nothing
                               , Tuple "foo" Nothing
                               , Tuple "bar" Nothing
                               , Tuple "foo" Nothing
                               ])

    it "parses key and value" do
      form <- runParseForm "foo=bar" Nothing
      form `shouldEqual` (Form [Tuple "foo" (Just "bar")])

    it "parses multiple keys and values" do
      form <- runParseForm "foo=bar&baz=quux&a=1&b=2" Nothing
      form `shouldEqual` (Form [ Tuple "foo" (Just "bar")
                               , Tuple "baz" (Just "quux")
                               , Tuple "a" (Just "1")
                               , Tuple "b" (Just "2")
                               ])

    it "fails to parse request body as a form when invalid" $ expectError $
      runParseForm "foo=bar=baz" Nothing

  where
    runParseForm body contentType =
      runMiddleware
      parseForm
      { request: TestRequest { method: Left GET
                             , body: body
                             , url: ""
                             , headers: singleton
                                         "content-type"
                                         (fromMaybe
                                         "application/x-www-form-urlencoded; charset=utf8"
                                         contentType)
                             }
      , response: {}
      , components: {}
      }
      # map fst
      >>= liftEither


Restore stuff that was merged out accidentally

module Data.Array
  ( (:)
  , singleton
  , head
  , tail
  , map
  , length
  , indexOf
  , lastIndexOf
  , concat
  , joinWith
  , reverse
  , drop
  , take
  , slice
  , insertAt
  , deleteAt
  , updateAt
  , concatMap
  , filter
  , isEmpty
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  ) where

import Data.Maybe
import Data.Monoid

infixr 6 :

(:) :: forall a. a -> [a] -> [a]
(:) a = concat [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _ = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _ = Nothing

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import indexOf
  "function indexOf (l) {\
  \  return function (e) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import elem
  "function elem(l) {\
  \  return function (e) {\
  \    return l.indexOf(e) !== -1;\
  \  };\
  \}" :: forall a. [a] -> a -> Boolean

foreign import lastIndexOf
  "function lastIndexOf (l) {\
  \  return function (e) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import concat
  "function concat (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import joinWith
  "function joinWith (l) {\
  \  return function (s) {\
  \    return l.join(s);\
  \  };\
  \}" :: [String] -> String -> String

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

foreign import take
  "function take (n) {\
  \  return function (l) {\
  \    return l.slice(0, n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1[index] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

isEmpty :: forall a. [a] -> Boolean
isEmpty [] = true
isEmpty _ = false

range :: Number -> Number -> [Number]
range lo hi | lo > hi = []
range lo hi = lo : range (lo + 1) hi

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortJS comp xs
  where
  comp x y = case compare x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

instance showArray :: (Show a) => Show [a] where
  show xs = "[" ++ joinWith (map show xs) "," ++ "]"

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = concat

instance monoidArray :: Monoid [a] where
  mempty = []

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = concat

module Data.Array where

import Prelude
import Data.Maybe
import Data.Monoid

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _ = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _ = Nothing

map :: forall a b. (a -> b) -> [a] -> [b]
map _ [] = []
map f (x:xs) = f x : map f xs

foreign import length
  "function length(xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import indexOf
  "function indexOf(l) {\
  \  return function (e) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import lastIndexOf
  "function lastIndexOf(l) {\
  \  return function (e) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import concat
  "function concat(l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import joinS
  "function joinS(l) {\
  \  return l.join();\
  \}" :: [String] -> String

foreign import joinWith
  "function joinWith(l) {\
  \  return function (s) {\
  \    return l.join(s);\
  \  };\
  \}" :: [String] -> String -> String

foreign import push
  "function push(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

foreign import reverse
  "function reverse(l) {\
  \  var l1 = l.slice();\
  \  l1.reverse(); \
  \  return l1;\
  \}" :: forall a. [a] -> [a]

foreign import shift
  "function shift(l) {\
  \  var l1 = l.slice();\
  \  l1.shift();\
  \  return l1;\
  \}" :: forall a. [a] -> [a]

foreign import slice
  "function slice(s) {\
  \  return function(e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import sort
  "function sort(l) {\
  \  var l1 = l.slice();\
  \  l1.sort();\
  \  return l1;\
  \}" :: forall a. [a] -> [a]

foreign import insertAt
  "function insertAt(index) {\
  \  return function(a) {\
  \    return function(l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt(index) {\
  \  return function(n) {\
  \    return function(l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt(index) {\
  \  return function(a) {\
  \    return function(l) {\
  \      var l1 = l.slice();\
  \      l1[index] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

infixr 6 :

(:) :: forall a. a -> [a] -> [a]
(:) a = concat [a]

singleton :: forall a. a -> [a]
singleton a = [a]

concatMap :: forall a b. (a -> [b]) -> [a] -> [b]
concatMap _ [] = []
concatMap f (a:as) = f a `concat` concatMap f as

filter :: forall a. (a -> Boolean) -> [a] -> [a]
filter _ [] = []
filter p (x:xs) | p x = x : filter p xs
filter p (_:xs) = filter p xs

isEmpty :: forall a. [a] -> Boolean
isEmpty [] = true
isEmpty _ = false

range :: Number -> Number -> [Number]
range lo hi | lo > hi = []
range lo hi = lo : range (lo + 1) hi

zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
zipWith _ _ _ = []

drop :: forall a. Number -> [a] -> [a]
drop 0 xs = xs
drop _ [] = []
drop n (x:xs) = drop (n - 1) xs

take :: forall a. Number -> [a] -> [a]
take 0 _ = []
take _ [] = []
take n (x:xs) = x : take (n - 1) xs

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

instance showArray :: (Show a) => Show [a] where
  show xs = "[" ++ joinWith (map show xs) "," ++ "]"

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = concat

instance monoidArray :: Monoid [a] where
  mempty = []

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = concat


Refine comments

Refine comments

Original commit 0e3425adca70eee1a52a5a32a1996c1c79027387

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Either as Either
import Data.Foldable (all, for_, intercalate, maximum)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: ["Convert"]
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = interfaceNamify $ combineNames names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c = isLetter c || generalCategory c == Just LetterNumber

isStartCharacter :: Char -> Boolean
isStartCharacter c = isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "null"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a@(IRUnion _) -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

getContainedClassName :: IRType -> Doc (Maybe String)
getContainedClassName = case _ of
    IRArray a -> getContainedClassName a
    IRClass i -> Just <$> lookupClassName i
    _ -> pure Nothing

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "'" <> s <> "'"
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just _ | all isStartCharacter (Str.toCharArray s) -> s
                   | otherwise -> "'" <> s <> "'"

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    topType <- getTopLevel
    topFull <- renderType topType
    topClassName <- getContainedClassName topType
    module_ <- getTopLevelNameGiven
    let imports =
            case topClassName of
                Just name -> {
                    basic:    "{ " <> name  <> " }",
                    advanced: "{ " <> name  <> ", Convert }"
                }
                Nothing -> {
                    basic:    "* as " <> module_,
                    advanced: "{ Convert }"
                }

    line $ """// To parse this data:
//
//   import """ <> imports.basic  <> """ from "./""" <> module_  <> """";
//   let value: """ <> topFull  <> """ = JSON.parse(json);
//
// Or use Convert.fromJson to perform a type-checking conversion:
//
//   import """ <> imports.advanced  <> """ from "./""" <> module_  <> """";
//   let value: """ <> topFull  <> """ = Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank

    line "//"
    line "// The Convert module parses JSON and asserts types"
    line "//"
    blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`;
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        return typ.isUnion  ? isValidUnion(typ.typs, val)
             : typ.isArray  ? isValidArray(typ.typ, val)
             : typ.isMap    ? isValidMap(typ.typ, val)
             : typ.isObject ? isValidObject(typ.cls, val)
             :                isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Either as Either
import Data.Foldable (all, for_, intercalate, maximum)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: ["Convert"]
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = interfaceNamify $ combineNames names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c = isLetter c || generalCategory c == Just LetterNumber

isStartCharacter :: Char -> Boolean
isStartCharacter c = isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "null"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a@(IRUnion _) -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

getContainedClassName :: IRType -> Doc (Maybe String)
getContainedClassName = case _ of
    IRArray a -> getContainedClassName a
    IRClass i -> Just <$> lookupClassName i
    _ -> pure Nothing

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "'" <> s <> "'"
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just _ | all isStartCharacter (Str.toCharArray s) -> s
                   | otherwise -> "'" <> s <> "'"

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    topType <- getTopLevel
    topFull <- renderType topType
    topClassName <- getContainedClassName topType
    module_ <- getTopLevelNameGiven
    let imports =
            case topClassName of
                Just name -> {
                    basic:    "{ " <> name  <> " }",
                    advanced: "{ " <> name  <> ", Convert }"
                }
                Nothing -> {
                    basic:    "* as " <> module_,
                    advanced: "{ Convert }"
                }

    line $ """// To parse this JSON data:
//
//     import """ <> imports.basic  <> """ from "./""" <> module_  <> """";
//     let value: """ <> topFull  <> """ = JSON.parse(json);
//
// Or use `Convert.fromJson` to perform a runtime assertion on your data:
//
//     import """ <> imports.advanced  <> """ from "./""" <> module_  <> """";
//     let value: """ <> topFull  <> """ = Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank

    line "//"
    line "// The Convert module parses JSON and asserts types"
    line "//"
    blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`;
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        return typ.isUnion  ? isValidUnion(typ.typs, val)
             : typ.isArray  ? isValidArray(typ.typ, val)
             : typ.isMap    ? isValidMap(typ.typ, val)
             : typ.isObject ? isValidObject(typ.cls, val)
             :                isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""


Remove experiment

Remove experiment

module Util.Parse where

import Control.Alt ((<|>))
import Data.Array (fromFoldable)
import Data.Char (toLower, toCharCode)
import Data.List (List)
import Data.Either (either)
import Data.String (fromCharArray)
import Data.Maybe (Maybe(..))
import Data.Semigroup ((<>))
import Control.Applicative (pure, (*>))
import Color (fromHexString)
import Text.Parsing.StringParser (Parser, try, fail, runParser)
import Text.Parsing.StringParser.String (char, satisfy, skipSpaces, whiteSpace)
import Text.Parsing.StringParser.Combinators (optional, sepEndBy)
import Prelude ((<$>), (>=), (<=), (&&), (<<<), (||), bind, const)
import Util.Types

isHex :: Char -> Boolean
isHex c = isDigit || isABCDEF where
  isDigit  = code >= 48 && code <= 57  {- 0, 9 -}
  isABCDEF = code >= 97 && code <= 102 {- a, f -}
  code     = (toCharCode <<< toLower) c

hex :: Parser Char
hex = satisfy isHex

parseHex3 :: Parser Color'
parseHex3 = do
  _ <- optional (char '#')
  r <- hex
  g <- hex
  b <- hex
  case fromHexString ("#" <> fromCharArray [r, g, b]) of
    Nothing -> fail "Could not parse HEX3"
    Just c  -> pure (Color' c)

parseHex6 :: Parser Color'
parseHex6 = do
  _  <- optional (char '#')
  r  <- hex
  r' <- hex
  g  <- hex
  g' <- hex
  b  <- hex
  b' <- hex
  case fromHexString ("#" <> fromCharArray [r, r', g, g', b, b']) of
    Nothing -> fail "Could not parse HEX6"
    Just c  -> pure (Color' c)

parseHex :: Parser Color'
parseHex = try parseHex6 <|> parseHex3

parseColor :: Parser (List Color')
parseColor = skipSpaces *> sepEndBy parseHex whiteSpace

parse' :: Parser (List Color') -> String -> Colors'
parse' p s = either
  (const (Colors' []))
  (Colors' <$> fromFoldable)
  (runParser p s)

parse :: String -> Colors'
parse = parse' parseColor

module Util.Parse where

import Control.Alt ((<|>))
import Data.Array (fromFoldable)
import Data.Char (toLower, toCharCode)
import Data.List (List)
import Data.Either (either)
import Data.String (fromCharArray)
import Data.Maybe (Maybe(..))
import Data.Semigroup ((<>))
import Control.Applicative (pure, (*>))
import Color (fromHexString)
import Text.Parsing.StringParser (Parser, try, fail, runParser)
import Text.Parsing.StringParser.String (char, satisfy, skipSpaces, whiteSpace)
import Text.Parsing.StringParser.Combinators (optional, sepEndBy)
import Prelude ((<$>), (>=), (<=), (&&), (<<<), (||), bind, const)
import Util.Types

isHex :: Char -> Boolean
isHex c = isDigit || isABCDEF where
  isDigit  = code >= 48 && code <= 57  {- 0, 9 -}
  isABCDEF = code >= 97 && code <= 102 {- a, f -}
  code     = (toCharCode <<< toLower) c

hex :: Parser Char
hex = satisfy isHex

parseHex3 :: Parser Color'
parseHex3 = do
  _ <- optional (char '#')
  r <- hex
  g <- hex
  b <- hex
  case fromHexString ("#" <> fromCharArray [r, g, b]) of
    Nothing -> fail "Could not parse HEX3"
    Just c  -> pure (Color' c)

parseHex6 :: Parser Color'
parseHex6 = do
  _  <- optional (char '#')
  r  <- hex
  r' <- hex
  g  <- hex
  g' <- hex
  b  <- hex
  b' <- hex
  case fromHexString ("#" <> fromCharArray [r, r', g, g', b, b']) of
    Nothing -> fail "Could not parse HEX6"
    Just c  -> pure (Color' c)

parseHex :: Parser Color'
parseHex = try parseHex6 <|> parseHex3

-- trying some kind of recursive cleverness here...^
-- parseColor :: Parser Color
-- parseColor = (parseHex <|> anyChar *> parseColor)

parseColor :: Parser (List Color')
parseColor = skipSpaces *> sepEndBy parseHex whiteSpace

parse' :: Parser (List Color') -> String -> Colors'
parse' p s = either
  (const (Colors' []))
  (Colors' <$> fromFoldable)
  (runParser p s)

parse :: String -> Colors'
parse = parse' parseColor


More work on service methods

More work on service methods

module Main where

import Debug.Trace

import Data.Int
import Data.Maybe
import Data.Tuple
import Data.Array (filter, map, nub, sort)
import Data.Foldable (elem)

import qualified Data.Map as M

import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Class

import Node.Express.Types
import Node.Express.App
import Node.Express.Handler

type Key = String

newtype Lang = Lang
  { name :: String
  , description :: String
  , homepage :: String
  , rating :: Int
  , tags :: [String]
  }

runLang (Lang lang) = lang

type DB = M.Map Key Lang

-- Ratings based on number of GitHub search results

purescript :: Lang
purescript = Lang
  { name: "PureScript"
  , description: "A small strongly typed programming language that compiles to JavaScript"
  , homepage: "http://purescript.org/"
  , rating: fromNumber 463
  , tags: [ "Pure", "Functional", "Static", "AltJS" ]
  }

haskell :: Lang
haskell = Lang
  { name: "Haskell"
  , description: "An advanced purely-functional programming language"
  , homepage: "http://haskell.org/"
  , rating: fromNumber 16586
  , tags: [ "Pure", "Functional", "Static", "Lazy" ]
  }

clojure :: Lang
clojure = Lang
  { name: "Clojure"
  , description: "A dynamic programming language that targets the Java Virtual Machine"
  , homepage: "http://clojure.org/"
  , rating: fromNumber 14616
  , tags: [ "Functional", "JVM", "Dynamic", "Lisp" ]
  }

befunge :: Lang
befunge = Lang
  { name: "Befunge"
  , description: "A two-dimensional esoteric programming language"
  , homepage: "https://esolangs.org/wiki/Befunge"
  , rating: fromNumber 153
  , tags: [ "2D", "Esoteric" ]
  }

initialDb :: DB
initialDb = M.fromList
  [ Tuple "purescript" purescript
  , Tuple "haskell" haskell
  , Tuple "clojure" clojure
  , Tuple "befunge" befunge
  ]

indexHandler :: Handler
indexHandler = send
  { name: "langdb server"
  , lang: "http://localhost:9000/lang"
  , tag: "http://localhost:9000/tag"
  }

shortLang :: Tuple Key Lang -> { key :: Key, name :: String, uri :: String, like :: String, dislike :: String }
shortLang (Tuple key (Lang o)) =
  { key: key
  , name: o.name
  , uri: "http://localhost:9000/lang/" <> key
  , like: "http://localhost:9000/lang/" <> key <> "/like"
  , dislike: "http://localhost:9000/lang/" <> key <> "/dislike"
  }

listHandler :: RefVal DB -> Handler
listHandler db = do
  m <- liftEff $ readRef db
  send <<< map shortLang <<< M.toList $ m
  where
  fromTuple (Tuple key (Lang o)) = { key: key, name: o.name, uri: "http://localhost:9000/lang/" <> key }

getHandler :: RefVal DB -> Handler
getHandler db = do
  idParam <- getRouteParam "id"
  case idParam of
    Nothing -> nextThrow (error "id parameter is required")
    Just _id -> do
      m <- liftEff $ readRef db
      case M.lookup _id m of
        Nothing -> do
          setStatus 404
          send "Not found"
        Just val -> send val

rateHandler :: RefVal DB -> (Int -> Int) -> Handler
rateHandler db f = do
  idParam <- getRouteParam "id"
  case idParam of
    Nothing -> nextThrow (error "id parameter is required")
    Just _id -> do
      m <- liftEff $ readRef db
      case M.lookup _id m of
        Nothing -> do
          setStatus 404
          send "Not found"
        Just _ -> do
          liftEff $ modifyRef db $ M.update (\(Lang lang) -> Just $ Lang (lang { rating = f lang.rating })) _id
          send "ok"

putHandler :: RefVal DB -> Handler
putHandler db = do
  idParam <- getRouteParam "id"
  case idParam of
    Nothing -> nextThrow (error "id parameter is required")
    Just _id -> do
      name <- getBodyParam "name"
      description <- getBodyParam "description"
      homepage <- getBodyParam "homepage"
      tags <- getBodyParam "tags"
      let lang = { name: _
                 , description: _
                 , homepage: _
                 , rating: zero :: Int
                 , tags: _
                 } <$> name
                   <*> description
                   <*> homepage
                   <*> tags
      case lang of
        Nothing -> do
          setStatus 406
          send "Parameters missing"
        Just lang -> do
          liftEff $ modifyRef db $ M.insert _id $ Lang lang
          send "ok"

tagsHandler :: RefVal DB -> Handler
tagsHandler db = do
  m <- liftEff $ readRef db
  send <<< map makeEntry <<< sort <<< nub $ do
    lang <- M.values m
    (runLang lang).tags
  where
  makeEntry tag = { tag: tag, uri: "http://localhost:9000/tag/" <> tag }

tagHandler :: RefVal DB -> Handler
tagHandler db = do
  tagParam <- getRouteParam "tag"
  case tagParam of
    Nothing -> nextThrow (error "tag parameter is required")
    Just _tag -> do
      m <- liftEff $ readRef db
      send <<< map shortLang <<< filter (hasTag _tag) <<< M.toList $ m
  where
  hasTag t (Tuple _ (Lang o)) = t `elem` o.tags

foreign import jsonBodyParser "var jsonBodyParser = require('body-parser').json()" :: forall middleware. middleware

app :: RefVal DB -> App
app db = do
  setProp "json spaces" 2

  useExternal jsonBodyParser

  get "/" indexHandler

  get "/lang" (listHandler db)
  get "/lang/:id" (getHandler db)
  put "/lang/:id" (putHandler db)

  post "/lang/:id/like" (rateHandler db (+ one))
  post "/lang/:id/dislike" (rateHandler db (+ (fromNumber (-1))))

  get "/tag" (tagsHandler db)
  get "/tag/:tag" (tagHandler db)

main = do
  db <- newRef initialDb
  listenHttp (app db) 9000 \_ -> trace "Listening on port 9000"

module Main where

import Debug.Trace

import Data.Int
import Data.Maybe
import Data.Tuple

import qualified Data.Map as M

import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Class

import Node.Express.Types
import Node.Express.App
import Node.Express.Handler

type Key = String

newtype Lang = Lang
  { name :: String
  , description :: String
  , homepage :: String
  , rating :: Int
  , tags :: [String]
  }

type DB = M.Map Key Lang

purescript :: Lang
purescript = Lang
  { name: "PureScript"
  , description: "A small strongly typed programming language that compiles to JavaScript"
  , homepage: "http://purescript.org/"
  , rating: zero
  , tags: [ "Pure", "Functional", "Static", "AltJS" ]
  }

haskell :: Lang
haskell = Lang
  { name: "Haskell"
  , description: "An advanced purely-functional programming language"
  , homepage: "http://haskell.org/"
  , rating: zero
  , tags: [ "Pure", "Functional", "Static", "Lazy" ]
  }

clojure :: Lang
clojure = Lang
  { name: "Clojure"
  , description: "A dynamic programming language that targets the Java Virtual Machine"
  , homepage: "http://clojure.org/"
  , rating: zero
  , tags: [ "Functional", "JVM", "Dynamic", "Lisp" ]
  }

befunge :: Lang
befunge = Lang
  { name: "Befunge"
  , description: "A two-dimensional esoteric programming language"
  , homepage: "https://esolangs.org/wiki/Befunge"
  , rating: zero
  , tags: [ "2D", "Esoteric" ]
  }

initialDb :: DB
initialDb = M.fromList
  [ Tuple "purescript" purescript
  , Tuple "haskell" haskell
  , Tuple "clojure" clojure
  , Tuple "befunge" befunge
  ]

indexHandler :: Handler
indexHandler = send
  { name: "langdb server"
  , follow: "http://localhost:9000/lang"
  }

listHandler :: RefVal DB -> Handler
listHandler db = do
  m <- liftEff $ readRef db
  send $ fromTuple <$> M.toList m
  where
  fromTuple (Tuple key (Lang o)) = { key: key, name: o.name, uri: "http://localhost:9000/lang/" <> key }

getHandler :: RefVal DB -> Handler
getHandler db = do
  idParam <- getRouteParam "id"
  case idParam of
    Nothing -> nextThrow (error "id parameter is required")
    Just _id -> do
      m <- liftEff $ readRef db
      case M.lookup _id m of
        Nothing -> do
          setStatus 404
          send "Not found"
        Just val -> send val

app :: RefVal DB -> App
app db = do
  setProp "json spaces" 2
  get "/" indexHandler
  get "/lang/" (listHandler db)
  get "/lang/:id" (getHandler db)

main = do
  db <- newRef initialDb
  listenHttp (app db) 9000 \_ -> trace "Listening on port 9000"