Add debug track for observing frames

Add debug track for observing frames

module Genetics.Browser.Track.Backend where
       -- ( demoBrowser
       -- , demoLegend
       -- , getDataDemo
       -- ) where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alternative (class Alternative, alt, empty)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Array as Array
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', Traversal', Traversal, over, to, traverseOf, traversed, view, viewOn, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Star (Star(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Variant (Variant, case_, inj, on, onMatch)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordSys, Interval, Normalized(Normalized), _BrowserIntervals, _Index, _Interval, intervalToScreen, intervalsOverlap, intervalsToMap, lookupInterval)
import Genetics.Browser.View (Pixels)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, 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)

type BrowserView = Interval BrowserPoint

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

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

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

type ChrCtx r = Map ChrId (Record r)

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

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

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

type DrawingR  = ( point :: Drawing
                 , range :: Pixels -> Drawing )
type DrawingV  = Variant DrawingR

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

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

type ReadyGlyph = { drawing :: DrawingV
                  , horPos  :: HPos
                  , verPos  :: Normalized 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

verPlace :: forall r.
            (Getter' (Feature r) (Normalized Number))
         -> Feature r
         -> Normalized Number
verPlace = view

render :: forall err a.
          Renderer a
       -> a
       -> ReadyGlyph
render render a =
      { drawing: render.draw a
      , horPos:  render.horPlace a
      , verPos:  render.verPlace a
      }

type CanvasReadyDrawing = Drawing

type BrowserTrack = Canvas.Dimensions
                 -> Interval BrowserPoint
                 -> CanvasReadyDrawing

-- Given a frame-normalized drawing, finalize it so it can be rendered to a canvas;
-- `width` is the width in pixels of the frame the drawing resides in.
resizeDrawing :: forall r.
                 { width :: Pixels | r }
              -> DrawingV
              -> Drawing
resizeDrawing {width} = case_
  # onMatch
     { point: (\x -> x)
     , range: (_ $ width) }

drawIntervalFeature :: forall f r a.
                     Foldable f
                  => Canvas.Dimensions
                  -> { width :: Pixels, offset :: Pixels }
                  -> f ReadyGlyph
                  -> CanvasReadyDrawing
drawIntervalFeature {height} {width, offset} = foldMap drawIt
  where drawIt {drawing, horPos, verPos} =
          let x' = case_
                    # on _point (\x -> x)
                    # on _range (\(Pair l _) -> l)
                    $ horPos
              x = width * unwrap x'
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
          in translate (x + offset) y d

-- | Returns the left-hand-edge offset, and width, in pixels,
-- | of each interval (chromosome) in the provided coordinate system
viewportIntervals :: forall i a r.
                     Ord i
                  => CoordSys i BrowserPoint
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Map i { width :: Pixels, offset :: Pixels }
viewportIntervals cs cdim bView =
  intervalToScreen cdim bView <$> (view _Interval <$> intervalsToMap cs)

pureTrack :: forall f i a.
             Ord i
          => Foldable f
          => CoordSys i BrowserPoint
          -> Map i (f ReadyGlyph)
          -> BrowserTrack
pureTrack cs drawings cd v =
  fold $ zipMapsWith (drawIntervalFeature cd) (viewportIntervals cs cd v) drawings

renderTrack :: forall f i a.
               Ord i
            => Foldable f
            => Traversable f
            => CoordSys i BrowserPoint
            -> Renderer a
            -> Map i (f a)
            -> BrowserTrack
renderTrack cs r chrs =
  let validDrawings :: Map i (f ReadyGlyph)
      validDrawings = (map <<< map) (render r) chrs
  in pureTrack cs validDrawings

horRulerTrack :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> BrowserTrack
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 BrowserPoint
              -> BrowserTrack
chrLabelTrack cs = pureTrack cs (Map.fromFoldable results)
  where mkLabel :: ChrId -> ReadyGlyph
        mkLabel chr = { drawing: inj _point $ chrText chr
                      , horPos:  inj _point $ Normalized (0.5)
                      , verPos: Normalized (0.05) }

        font' = font sansSerif 12 mempty

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

        results :: Array _
        results = map (\x -> Tuple (x^._Index) [mkLabel (x^._Index)]) $ cs^._BrowserIntervals

boxesTrack :: Number
           -> CoordSys ChrId BrowserPoint
           -> BrowserTrack
boxesTrack h cs = pureTrack cs $ map (const [glyph]) $ intervalsToMap cs
  where glyph :: ReadyGlyph
        glyph = { drawing: inj _range draw
                , horPos:  inj _range $ Normalized <$> (Pair zero one)
                , verPos: Normalized one }
        draw = \w ->
             let rect = rectangle 0.0 0.0 w h
             in outlined (outlineColor black <> lineWidth 1.5) rect

featureInterval :: forall a. Feature a -> Interval 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 :: Interval Bp -> Number
        maxInRadius lr = fromMaybe 0.0 $ maximum
                          $ map (\g -> if intervalsOverlap (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 :: Pixels
              , 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  / 5.0
      vPad = height / 10.0
      x = vscale.width / 2.0

      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 (x-12.0) y (fillColor black)

      topLabel = mkT (y1-(0.5*vPad)) $ show vscale.max
      btmLabel = mkT (y2+vPad)       $ show vscale.min

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

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

type Legend = { width :: Pixels
              , 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 :: Pixels
               , horizontal :: Pixels
               }

browser :: forall f.
           Traversable f
        => CoordSys ChrId BrowserPoint
        -> Canvas.Dimensions
        -> Padding
        -> { legend :: Legend, vscale :: VScale }
        -> _
        -- -> { gwas   :: Map ChrId (f (GWASFeature ()))
        --    , annots :: Map ChrId (f (Annot (score :: Number))) }
        -> Interval BrowserPoint
        -> { track :: Drawing, overlay :: Drawing }
browser cs cdim padding ui input =
  let height = cdim.height - 2.0 * padding.vertical
      width  = cdim.width

      trackCanvas = { width: width - ui.vscale.width - ui.legend.width
                    , height }

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

      -- TODO unify vertical offset by padding further; do it as late as possible

      vScale _ = let w = ui.vscale.width
                 in  translate zero padding.vertical
                   $ bg w height
                  <> drawVScale ui.vscale height

      track v = mempty

      legendD _ = let w = ui.legend.width
                  in translate (cdim.width - w) padding.vertical
                    $ bg w height
                   <> drawLegend ui.legend cdim.height

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

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

type TrackRow c a = ( url :: String
                    , parse :: c -> Json -> Maybe a
                    , render :: Renderer a )

type GWASTrack c a  = { vscale :: { | VScaleRow () }
                      | TrackRow c a }

type AnnotTrack c a = { getEntry :: a -> LegendEntry | TrackRow c a }

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

module Genetics.Browser.Track.Backend where
       -- ( demoBrowser
       -- , demoLegend
       -- , getDataDemo
       -- ) where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Alternative (class Alternative, alt, empty)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Array as Array
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', Traversal', Traversal, over, to, traverseOf, traversed, view, viewOn, (^.), (^?))
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Star (Star(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Variant (Variant, case_, inj, on, onMatch)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordSys, Interval, Normalized(Normalized), _BrowserIntervals, _Index, _Interval, intervalToScreen, intervalsOverlap, intervalsToMap, lookupInterval)
import Genetics.Browser.View (Pixels)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, 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)

type BrowserView = Interval BrowserPoint

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

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

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

type ChrCtx r = Map ChrId (Record r)

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

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

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

type DrawingR  = ( point :: Drawing
                 , range :: Pixels -> Drawing )
type DrawingV  = Variant DrawingR

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

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

type ReadyGlyph = { drawing :: DrawingV
                  , horPos  :: HPos
                  , verPos  :: Normalized 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

verPlace :: forall r.
            (Getter' (Feature r) (Normalized Number))
         -> Feature r
         -> Normalized Number
verPlace = view

render :: forall err a.
          Renderer a
       -> a
       -> ReadyGlyph
render render a =
      { drawing: render.draw a
      , horPos:  render.horPlace a
      , verPos:  render.verPlace a
      }

type CanvasReadyDrawing = Drawing

type BrowserTrack = Canvas.Dimensions
                 -> Interval BrowserPoint
                 -> CanvasReadyDrawing

-- Given a frame-normalized drawing, finalize it so it can be rendered to a canvas;
-- `width` is the width in pixels of the frame the drawing resides in.
resizeDrawing :: forall r.
                 { width :: Pixels | r }
              -> DrawingV
              -> Drawing
resizeDrawing {width} = case_
  # onMatch
     { point: (\x -> x)
     , range: (_ $ width) }

drawIntervalFeature :: forall f r a.
                     Foldable f
                  => Canvas.Dimensions
                  -> { width :: Pixels, offset :: Pixels }
                  -> f ReadyGlyph
                  -> CanvasReadyDrawing
drawIntervalFeature {height} {width, offset} = foldMap drawIt
  where drawIt {drawing, horPos, verPos} =
          let x' = case_
                    # on _point (\x -> x)
                    # on _range (\(Pair l _) -> l)
                    $ horPos
              x = width * unwrap x'
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
          in translate (x + offset) y d

-- | Returns the left-hand-edge offset, and width, in pixels,
-- | of each interval (chromosome) in the provided coordinate system
viewportIntervals :: forall i a r.
                     Ord i
                  => CoordSys i BrowserPoint
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Map i { width :: Pixels, offset :: Pixels }
viewportIntervals cs cdim bView =
  intervalToScreen cdim bView <$> (view _Interval <$> intervalsToMap cs)

pureTrack :: forall f i a.
             Ord i
          => Foldable f
          => CoordSys i BrowserPoint
          -> Map i (f ReadyGlyph)
          -> BrowserTrack
pureTrack cs drawings cd v =
  fold $ zipMapsWith (drawIntervalFeature cd) (viewportIntervals cs cd v) drawings

renderTrack :: forall f i a.
               Ord i
            => Foldable f
            => Traversable f
            => CoordSys i BrowserPoint
            -> Renderer a
            -> Map i (f a)
            -> BrowserTrack
renderTrack cs r chrs =
  let validDrawings :: Map i (f ReadyGlyph)
      validDrawings = (map <<< map) (render r) chrs
  in pureTrack cs validDrawings

horRulerTrack :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> BrowserTrack
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 BrowserPoint
              -> BrowserTrack
chrLabelTrack cs = pureTrack cs (Map.fromFoldable results)
  where mkLabel :: ChrId -> ReadyGlyph
        mkLabel chr = { drawing: inj _point $ chrText chr
                      , horPos:  inj _point $ Normalized $ one
                      , verPos: Normalized (-0.1) }

        font' = font sansSerif 12 mempty

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

        results :: Array _
        results = map (\x -> Tuple (x^._Index) [mkLabel (x^._Index)]) $ cs^._BrowserIntervals

featureInterval :: forall a. Feature a -> Interval 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 :: Interval Bp -> Number
        maxInRadius lr = fromMaybe 0.0 $ maximum
                          $ map (\g -> if intervalsOverlap (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 :: Pixels
              , 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  / 5.0
      vPad = height / 10.0
      x = vscale.width / 2.0

      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 (x-12.0) y (fillColor black)

      topLabel = mkT (y1-(0.5*vPad)) $ show vscale.max
      btmLabel = mkT (y2+vPad)       $ show vscale.min

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

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

type Legend = { width :: Pixels
              , 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 :: Pixels
               , horizontal :: Pixels
               }

browser :: forall f.
           Traversable f
        => CoordSys ChrId BrowserPoint
        -> Canvas.Dimensions
        -> Padding
        -> { legend :: Legend, vscale :: VScale }
        -> _
        -- -> { gwas   :: Map ChrId (f (GWASFeature ()))
        --    , annots :: Map ChrId (f (Annot (score :: Number))) }
        -> Interval BrowserPoint
        -> { track :: Drawing, overlay :: Drawing }
browser cs cdim padding ui input =
  let height = cdim.height - 2.0 * padding.vertical
      width  = cdim.width

      trackCanvas = { width: width - ui.vscale.width - ui.legend.width
                    , height }

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

      -- TODO unify vertical offset by padding further; do it as late as possible

      vScale _ = let w = ui.vscale.width
                 in  translate zero padding.vertical
                   $ bg w height
                  <> drawVScale ui.vscale height

      track v = mempty

      legendD _ = let w = ui.legend.width
                  in translate (cdim.width - w) padding.vertical
                    $ bg w height
                   <> drawLegend ui.legend cdim.height

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

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

type TrackRow c a = ( url :: String
                    , parse :: c -> Json -> Maybe a
                    , render :: Renderer a )

type GWASTrack c a  = { vscale :: { | VScaleRow () }
                      | TrackRow c a }

type AnnotTrack c a = { getEntry :: a -> LegendEntry | TrackRow c a }

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


Use httpbin for GET (#139)

Use httpbin for GET (#139)

module Main where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)

import Data.Either (Either(..))
import Data.Foldable (foldMap)
import Data.Foreign.Class (readProp)
import Data.Maybe (Maybe(..))

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Util (runHalogenAff, awaitBody)

import Data.HTTP.Method (Method(GET))
import Network.HTTP.Affjax (AJAX, defaultRequest, affjax)

-- | The state of the component.
type State = { busy :: Boolean, result :: Maybe String }

initialState :: State
initialState = { busy: false, result: Nothing }

-- | The component query algebra.
data Query a = MakeRequest a

-- | The effects used in the app.
type AppEffects eff = H.HalogenEffects (ajax :: AJAX | eff)

-- | The definition for the app's main UI component.
ui :: forall eff. H.Component State Query (Aff (AppEffects eff))
ui = H.component { render, eval }
  where

  render :: State -> H.ComponentHTML Query
  render st =
    HH.div_ $
      [ HH.h1_
          [ HH.text "ajax example / httpbin" ]
      , HH.p_
          [ HH.button
              [ HP.disabled st.busy
              , HE.onClick (HE.input_ MakeRequest)
              ]
              [ HH.text "GET" ]
          ]
      , HH.p_
          [ HH.text (if st.busy then "Working..." else "") ]
      ]
      <> flip foldMap st.result \s ->
          [ HH.div_
              [ HH.h2_
                  [ HH.text "response headers.User-Agent:" ]
              , HH.pre_
                  [ HH.code_ [ HH.text s] ]
              ]
          ]

  eval :: Query ~> H.ComponentDSL State Query (Aff (AppEffects eff))
  eval (MakeRequest next) = do
    H.modify (_ { busy = true })
    result <- H.fromAff (fetchJS unit)
    H.modify (_ { busy = false, result = Just result })
    pure next

-- | GET JSON and pull fields from the result.
fetchJS :: forall eff. Unit -> Aff (ajax :: AJAX | eff) String
fetchJS unit = do
  let req = defaultRequest { method = Left GET
                           , url = "http://httpbin.org/get"
                           }
  result <- affjax req
  let response = result.response

  pure $ case runExcept $ readProp "headers" response of
    Right headers ->
      case runExcept $ readProp "User-Agent" headers of
        Right ua -> ua
        Left _ -> "Unexpected response"
    Left _ -> "Unexpected response"

-- | Run the app.
main :: Eff (AppEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  H.runUI ui initialState body

module Main where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)

import Data.Either (Either(..))
import Data.Foldable (foldMap)
import Data.Foreign.Class (readProp)
import Data.Maybe (Maybe(..))

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Util (runHalogenAff, awaitBody)

import Network.HTTP.Affjax (AJAX, post)

-- | The state of the component.
type State = { busy :: Boolean, code :: String, result :: Maybe String }

initialState :: State
initialState = { busy: false, code: exampleCode, result: Nothing }

exampleCode :: String
exampleCode = """module Main where

import Prelude
import Control.Monad.Eff.Console (print)

fact :: Int -> Int
fact 0 = 1
fact n = n * fact (n - 1)

main = print (fact 20)
"""

-- | The component query algebra.
data Query a
  = SetCode String a
  | MakeRequest String a

-- | The effects used in the app.
type AppEffects eff = H.HalogenEffects (ajax :: AJAX | eff)

-- | The definition for the app's main UI component.
ui :: forall eff. H.Component State Query (Aff (AppEffects eff))
ui = H.component { render, eval }
  where

  render :: State -> H.ComponentHTML Query
  render st =
    HH.div_ $
      [ HH.h1_
          [ HH.text "ajax example / trypurescript" ]
      , HH.h2_
          [ HH.text "purescript input:" ]
      , HH.p_
          [ HH.textarea
              [ HP.value st.code
              , HE.onValueInput (HE.input SetCode)
              ]
          ]
      , HH.p_
          [ HH.button
              [ HP.disabled st.busy
              , HE.onClick (HE.input_ (MakeRequest st.code))
              ]
              [ HH.text "Compile" ]
          ]
      , HH.p_
          [ HH.text (if st.busy then "Working..." else "") ]
      ]
      <> flip foldMap st.result \js ->
          [ HH.div_
              [ HH.h2_
                  [ HH.text "javascript output:" ]
              , HH.pre_
                  [ HH.code_ [ HH.text js ] ]
              ]
          ]

  eval :: Query ~> H.ComponentDSL State Query (Aff (AppEffects eff))
  eval (SetCode code next) = H.modify (_ { code = code, result = Nothing :: Maybe String }) $> next
  eval (MakeRequest code next) = do
    H.modify (_ { busy = true })
    result <- H.fromAff (fetchJS code)
    H.modify (_ { busy = false, result = Just result })
    pure next

-- | Post some PureScript code to the trypurescript API and fetch the JS result.
fetchJS :: forall eff. String -> Aff (ajax :: AJAX | eff) String
fetchJS code = do
  result <- post "http://try.purescript.org/compile/text" code
  let response = result.response
  pure case runExcept $ readProp "js" response <|> readProp "error" response of
    Right js -> js
    Left _ -> "Invalid response"

-- | Run the app.
main :: Eff (AppEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  H.runUI ui initialState body


Fix spacing between closing ]

Fix spacing between closing ]

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , class Discard, discard
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (identity)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k -> f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class Apply m <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixr 1 bindFlipped as =<<

instance bindFn :: Bind ((->) r) where
  bind m f x = f (m x) x

-- | The `Array` monad works like a nested for loop. Each
-- | `bind`/`>>=` adds another level of nesting in the loop:
-- | ```
-- | foo :: Array Int
-- | foo =
-- |   ["a", "b"] >>= \eachElementInArray1 ->
-- |     ["c", "d"] >>= \eachElementInArray2
-- |       pure (eachElementInArray1 <> eachElementInArray2)
-- |
-- | -- In other words...
-- | foo
-- | -- ... is the same as...
-- | [ ("a" <> "c"), ("a" <> "d"), ("b" <> "c"), ("b" <> "d") ]
-- | -- which simplifies to...
-- | [ "ac", "ad", "bc", "bd" ]
-- | ```
instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | A class for types whose values can safely be discarded
-- | in a `do` notation block.
-- |
-- | An example is the `Unit` type, since there is only one
-- | possible value which can be returned.
class Discard a where
  discard :: forall f b. Bind f => f a -> (a -> f b) -> f b

instance discardUnit :: Discard Unit where
  discard = bind

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= identity

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , class Discard, discard
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (identity)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k -> f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class Apply m <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixr 1 bindFlipped as =<<

instance bindFn :: Bind ((->) r) where
  bind m f x = f (m x) x

-- | The `Array` monad works like a nested for loop. Each
-- | `bind`/`>>=` adds another level of nesting in the loop:
-- | ```
-- | foo :: Array Int
-- | foo =
-- |   ["a", "b"] >>= \eachElementInArray1 ->
-- |     ["c", "d"] >>= \eachElementInArray2
-- |       pure (eachElementInArray1 <> eachElementInArray2)
-- |
-- | -- In other words...
-- | foo
-- | -- ... is the same as...
-- | [ ("a" <> "c"), ("a" <> "d"), ("b" <> "c"), ("b" <> "d") ]
-- | -- which simplifies to...
-- | [ "ac", "ad", "bc", "bd"]
-- | ```
instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | A class for types whose values can safely be discarded
-- | in a `do` notation block.
-- |
-- | An example is the `Unit` type, since there is only one
-- | possible value which can be returned.
class Discard a where
  discard :: forall f b. Bind f => f a -> (a -> f b) -> f b

instance discardUnit :: Discard Unit where
  discard = bind

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= identity

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f


Fix missing errors (#101)

Fix missing errors (#101)

module Main where

import Prelude

import Control.Monad.Cont.Trans (ContT(..), runContT)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, error)
import Control.Monad.Eff.JQuery (JQuery, addClass, append, appendText, attr, create, display, hide, on, ready, removeClass, select, setProp, setValue, toggleClass) as JQuery
import Control.Monad.Eff.JQuery.Extras (empty, filter, getValueMaybe, is) as JQuery
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Timer (TIMER, setTimeout)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, EffFn4, EffFn5, mkEffFn1, runEffFn1, runEffFn2, runEffFn4, runEffFn5)
import Control.Monad.Except.Trans (runExceptT)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Location (setHref)
import DOM.HTML.Types (ALERT, CONFIRM)
import DOM.HTML.Window (alert, confirm, location)
import Data.Array (mapMaybe)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (elem, fold, for_, intercalate, traverse_)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Foreign (renderForeignError)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.StrMap as StrMap
import Data.String (joinWith)
import Data.String as String
import Data.String.Regex (replace')
import Data.String.Regex.Flags (global)
import Data.String.Regex.Unsafe (unsafeRegex)
import Try.API (BackendConfig(..), CompileError(..), CompileResult(..), CompileWarning(..), CompilerError(..), ErrorPosition(..), FailedResult(..), SuccessResult(..), getBackendConfigFromString)
import Try.API as API
import Try.Gist (getGistById, tryLoadFileFromGist, uploadGist)
import Try.QueryString (getQueryStringMaybe, setQueryStrings)
import Try.Session (createSessionIdIfNecessary, storeSession, tryRetrieveSession)
import Try.Types (JS(..))

-- | Display a loading message in the right hand column.
displayLoadingMessage :: forall eff. Eff (dom :: DOM | eff) Unit
displayLoadingMessage = do
  column2 <- JQuery.select "#column2"
  JQuery.empty column2
  div <- JQuery.create "<div>"
  JQuery.addClass "loading" div
  JQuery.appendText "Loading..." div
  JQuery.append div column2

-- | Display a list of errors in the right hand column.
displayErrors :: forall eff. Array CompilerError -> Eff (dom :: DOM | eff) Unit
displayErrors errs = do
  column2 <- JQuery.select "#column2"
  JQuery.empty column2

  forWithIndex_ errs \i (CompilerError{ message }) -> do
    h1 <- JQuery.create "<h1>"
    JQuery.addClass "error-banner" h1
    JQuery.appendText ("Error " <> show (i + 1) <> " of " <> show (Array.length errs)) h1

    pre <- JQuery.create "<pre>"
    code_ <- JQuery.create "<code>"
    JQuery.append code_ pre
    JQuery.appendText message code_

    JQuery.append h1 column2
    JQuery.append pre column2

-- | Display plain text in the right hand column.
displayPlainText
  :: forall eff
   . String
  -> Eff (dom :: DOM | eff) Unit
displayPlainText s = do
  column2 <- JQuery.select "#column2"
  JQuery.empty column2
  pre <- JQuery.create "<pre>"
  code_ <- JQuery.create "<code>"
  JQuery.append code_ pre
  JQuery.appendText s code_
  JQuery.append pre column2

isShowJsChecked :: forall eff. Eff (dom :: DOM | eff) Boolean
isShowJsChecked = JQuery.select "#showjs" >>= \jq -> JQuery.is jq ":checked"

isAutoCompileChecked :: forall eff. Eff (dom :: DOM | eff) Boolean
isAutoCompileChecked = JQuery.select "#auto_compile" >>= \jq -> JQuery.is jq ":checked"

-- | Hide the drop down menus
hideMenus :: forall eff. Eff (dom :: DOM | eff) Unit
hideMenus = do
  JQuery.select "#menu" >>= JQuery.removeClass "show"
  JQuery.select "#view_mode" >>= JQuery.removeClass "show-sub-menu"
  JQuery.select "#backend" >>= JQuery.removeClass "show-sub-menu"

-- | Update the view mode based on the menu selection
changeViewMode :: forall eff. Maybe String -> Eff (dom :: DOM | eff) Unit
changeViewMode viewMode = do
  column1 <- JQuery.select "#column1"
  column2 <- JQuery.select "#column2"
  showjs <- JQuery.select "#showjs"
  showjsLabel <- JQuery.select "#showjs_label"
  case viewMode of
    Just "code" -> do
      JQuery.display column1
      JQuery.hide column2
      JQuery.hide showjs
      JQuery.hide showjsLabel
    Just "output" -> do
      JQuery.hide column1
      JQuery.display column2
      JQuery.display showjs
      JQuery.display showjsLabel
    _ -> do
      JQuery.display column1
      JQuery.display column2
      JQuery.display showjs
      JQuery.display showjsLabel

getTextAreaContent :: forall eff. Eff (dom :: DOM | eff) String
getTextAreaContent = fold <$> (JQuery.select "#code_textarea" >>= JQuery.getValueMaybe)

setTextAreaContent :: forall eff. String -> Eff (dom :: DOM | eff) Unit
setTextAreaContent value = JQuery.select "#code_textarea" >>= JQuery.setValue value

-- | Set the editor content to the specified string.
foreign import setEditorContent :: forall eff. EffFn1 (dom :: DOM | eff) String Unit

-- | Register a callback for editor change events.
foreign import onEditorChanged
  :: forall eff
   . EffFn2 (dom :: DOM | eff)
            (EffFn1 (dom :: DOM | eff) String Unit)
            Int
            Unit

-- | Clean up any global state associated with any visible error markers.
foreign import cleanUpMarkers :: forall eff. Eff (dom :: DOM | eff) Unit

-- | Add a visible marker at the specified location.
foreign import addMarker :: forall eff. EffFn5 (dom :: DOM | eff) String Int Int Int Int Unit

type Annotation =
  { row :: Int
  , column :: Int
  , type :: String
  , text :: String
  }

-- | Set the gutter annotations
foreign import setAnnotations :: forall eff. EffFn1 (dom :: DOM | eff) (Array Annotation) Unit

clearAnnotations :: forall eff. Eff (dom :: DOM | eff) Unit
clearAnnotations = runEffFn1 setAnnotations []

-- | Set up a fresh iframe in the specified container, and use it
-- | to execute the provided JavaScript code.
foreign import setupIFrame
  :: forall eff
   . EffFn4 (dom :: DOM | eff)
            JQuery.JQuery
            String
            String
            (EffFn1 (dom :: DOM | eff) JQuery.JQuery Unit)
            Unit

-- | Compile the current code and execute it.
compile :: forall eff. BackendConfig -> Eff (console :: CONSOLE, dom :: DOM | eff) Unit
compile bc@(BackendConfig backend) = do
  code <- getTextAreaContent

  clearAnnotations

  runContT (runExceptT (backend.compile code)) \res_ ->
    case res_ of
      Left err -> displayPlainText err
      Right res -> do
        cleanUpMarkers

        case res of
          Right (CompileSuccess (SuccessResult { js, warnings })) -> do
            showJs <- isShowJsChecked
            if showJs
              then displayPlainText js
              else runContT (runExceptT backend.getBundle)
                     case _ of
                       Left err -> error ("Unable to retrieve JS bundle: " <> err)
                       Right bundle -> do
                         for_ (unwrap warnings) \warnings_ -> do
                           let toAnnotation (CompileWarning{ errorCode, position, message }) =
                                 unwrap position <#> \(ErrorPosition pos) ->
                                   { row: pos.startLine - 1
                                   , column: pos.startColumn - 1
                                   , type: "warning"
                                   , text: message
                                   }
                           runEffFn1 setAnnotations (mapMaybe toAnnotation warnings_)
                         execute (JS js) bundle bc
          Right (CompileFailed (FailedResult { error })) ->
            case error of
              CompilerErrors errs -> do
                displayErrors errs

                let toAnnotation (CompilerError{ position, message }) =
                      unwrap position <#> \(ErrorPosition pos) ->
                        { row: pos.startLine - 1
                        , column: pos.startColumn - 1
                        , type: "error"
                        , text: message
                        }
                runEffFn1 setAnnotations (mapMaybe toAnnotation errs)

                for_ errs \(CompilerError{ position }) ->
                  for_ (unwrap position) \(ErrorPosition pos) ->
                    runEffFn5 addMarker
                      "error"
                      pos.startLine
                      pos.startColumn
                      pos.endLine
                      pos.endColumn
              OtherError err -> displayPlainText err
          Left errs -> do
            displayPlainText "Unable to parse the response from the server"
            traverse_ (error <<< renderForeignError) errs

-- | Execute the compiled code in a new iframe.
execute :: forall eff. JS -> JS -> BackendConfig -> Eff (dom :: DOM | eff) Unit
execute js bundle bc@(BackendConfig backend) = do
  let html = joinWith "\n"
        [ """<!DOCTYPE html>"""
        , """<html>"""
        , """  <head>"""
        , """    <meta content="text/html;charset=utf-8" http-equiv="Content-Type">"""
        , """    <meta content="utf-8" http-equiv="encoding">"""
        , """    <meta name="viewport" content="width=device-width, initial-scale=1.0">"""
        , """    <title>Try PureScript!</title>"""
        , """    <link rel="stylesheet" href="css/style.css">"""
        , backend.extra_styling
        , """  </head>"""
        , """  <body>"""
        , backend.extra_body
        , """  </body>"""
        , """</html>"""
        ]

      replaced = replace' (unsafeRegex """require\("[^"]*"\)""" global) (\s _ ->
        "PS['" <> String.drop 12 (String.take (String.length s - 2) s) <> "']") (unwrap js)

      wrapped = joinWith "\n"
        [ "var module = {};"
        , "(function(module) {"
        , replaced
        , "})(module);"
        , "module.exports.main && module.exports.main();"
        ]

      scripts = joinWith "\n" [unwrap bundle, wrapped]

  column2 <- JQuery.select "#column2"
  runEffFn4 setupIFrame column2 html scripts $ mkEffFn1 \body ->
    JQuery.on "click" (\_ _ -> hideMenus) body

-- | Setup the editor component and some event handlers.
setupEditor
  :: forall eff
   . { code :: String, backend :: BackendConfig }
  -> Eff ( alert :: ALERT
         , console :: CONSOLE
         , confirm :: CONFIRM
         , dom :: DOM
         , timer :: TIMER
         | eff
         ) Unit
setupEditor { code, backend } = do
  loadOptions backend
  setupBackendMenu backend

  setTextAreaContent code
  runEffFn1 setEditorContent code

  runEffFn2 onEditorChanged (mkEffFn1 \value -> do
    setTextAreaContent value
    cacheCurrentCode backend
    autoCompile <- isAutoCompileChecked
    when autoCompile do
      compile backend) 750

  JQuery.select "#showjs" >>= JQuery.on "change" \e _ ->
    compile backend

  JQuery.select "#compile_label" >>= JQuery.on "click" \e _ ->
    compile backend

  JQuery.select "#gist_save" >>= JQuery.on "click" \e _ ->
    publishNewGist backend

  compile backend
  cacheCurrentCode backend

loadFromGist
  :: forall eff
   . String
  -> BackendConfig
  -> ({ code :: String, backend :: BackendConfig }
      -> Eff ( confirm :: CONFIRM
             , console :: CONSOLE
             , dom :: DOM
             , timer :: TIMER
             | eff
             ) Unit)
  -> Eff ( confirm :: CONFIRM
         , console :: CONSOLE
         , dom :: DOM
         , timer :: TIMER
         | eff
         ) Unit
loadFromGist id_ backend k = do
  runContT (runExceptT (getGistById id_ >>= \gi -> tryLoadFileFromGist gi "Main.purs")) $
    case _ of
      Left err -> do
        error ("Unable to load gist metadata or contents: " <> err)
        k { code: "", backend }
      Right code -> k { code, backend }

withSession
  :: forall eff
   . String
  -> ({ code :: String, backend :: BackendConfig }
      -> Eff ( confirm :: CONFIRM
             , console :: CONSOLE
             , dom :: DOM
             , timer :: TIMER
             | eff
             ) Unit)
  -> Eff ( confirm :: CONFIRM
         , console :: CONSOLE
         , dom :: DOM
         , timer :: TIMER
         | eff
         ) Unit
withSession sessionId k = do
  state <- tryRetrieveSession sessionId
  case state of
    Just { code, backend } -> do
      k { code, backend: API.getBackendConfigFromString backend }
    Nothing -> do
      bc@(BackendConfig backend) <- API.getBackendConfigFromString <<< fromMaybe "core" <$> getQueryStringMaybe "backend"
      gist <- fromMaybe backend.mainGist <$> getQueryStringMaybe "gist"
      loadFromGist gist bc k

-- | Cache the current code in the session state
cacheCurrentCode
  :: forall eff
   . BackendConfig
  -> Eff (console :: CONSOLE, dom :: DOM | eff) Unit
cacheCurrentCode bc@(BackendConfig backend) = do
  sessionId <- getQueryStringMaybe "session"
  case sessionId of
    Just sessionId_ -> do
      code <- getTextAreaContent
      storeSession sessionId_ { code, backend: backend.backend }
    Nothing -> error "No session ID"

-- | Create a new Gist using the current content
publishNewGist
  :: forall eff
   . BackendConfig
  -> Eff ( alert :: ALERT
         , confirm :: CONFIRM
         , console :: CONSOLE
         , dom :: DOM
         | eff
         ) Unit
publishNewGist bc@(BackendConfig backend) = do
  ok <- window >>= confirm (intercalate "\n"
          [ "Do you really want to publish this code as an anonymous Gist?"
          , ""
          , "Note: this code will be available to anyone with a link to the Gist."
          ])
  when ok do
    content <- getTextAreaContent
    runContT (runExceptT (uploadGist content)) $
      case _ of
        Left err -> do
          window >>= alert "Failed to create gist"
          error ("Failed to create gist: " <> err)
        Right gistId -> do
          setQueryStrings (StrMap.singleton "gist" gistId <>
                           StrMap.singleton "backend" backend.backend)

-- | Navigate to the specified URL.
navigateTo :: forall eff. String -> Eff (dom :: DOM | eff) Unit
navigateTo uri = void (window >>= location >>= setHref uri)

-- | Read query string options and update the state accordingly
loadOptions
  :: forall eff
   . BackendConfig
  -> Eff ( console :: CONSOLE
         , confirm :: CONFIRM
         , dom :: DOM
         , timer :: TIMER
         | eff
         ) Unit
loadOptions bc = do
  viewMode <- getQueryStringMaybe "view"
  case viewMode of
    Just viewMode_
      | viewMode_ `elem` ["sidebyside", "code", "output"]
      -> changeViewMode viewMode
    _ -> pure unit

  showJs <- getQueryStringMaybe "js"
  case showJs of
    Just showJs_ ->
      JQuery.select "input:checkbox[name=showjs]" >>= JQuery.setProp "checked" (showJs_ == "true")
    _ -> pure unit

  autoCompile <- getQueryStringMaybe "compile"
  case autoCompile of
    Just autoCompile_ ->
      JQuery.select "input:checkbox[name=auto_compile]" >>= JQuery.setProp "checked" (autoCompile_ == "true")
    _ -> pure unit

  gist <- getQueryStringMaybe "gist"
  case gist of
    Just gist_ -> JQuery.select "#view_gist" >>= JQuery.attr { href: "https://gist.github.com/" <> gist_ }
    Nothing -> JQuery.select "#view_gist_li" >>= JQuery.hide

-- | Setup event listeners for the backend dropdown menu.
setupBackendMenu
  :: forall eff
   . BackendConfig
  -> Eff
       ( dom :: DOM
       , confirm :: CONFIRM
       , console :: CONSOLE
       , timer :: TIMER
       | eff
       )
       Unit
setupBackendMenu bc@(BackendConfig backend) = do
  JQuery.select ("#backend_" <> backend.backend) >>= JQuery.attr { checked: "checked" }
  JQuery.select "input[name=backend_inputs]" >>= JQuery.on "change" \e jq -> do
    bc_@(BackendConfig newBackend) <- getBackendConfigFromString <<< fromMaybe "core" <$> JQuery.getValueMaybe jq

    ok <- window >>= confirm ("Replace your current code with the " <> newBackend.backend <> " backend sample code?")
    if ok
      then navigateTo ("?backend=" <> newBackend.backend)
      else void $ setTimeout 1000 do
             compile bc_
             cacheCurrentCode bc_
    hideMenus

main :: Eff ( alert :: ALERT
            , confirm :: CONFIRM
            , console :: CONSOLE
            , dom :: DOM
            , random :: RANDOM
            , timer :: TIMER
            ) Unit
main = JQuery.ready do
  JQuery.select "input[name=view_mode]" >>= JQuery.on "change" \_ jq -> do
    viewMode <- JQuery.filter jq ":checked" >>= JQuery.getValueMaybe
    changeViewMode viewMode

  JQuery.select "#hamburger" >>= JQuery.on "click" \e _ -> do
    JQuery.select "#menu" >>= JQuery.toggleClass "show"

  JQuery.select "#view_mode_label" >>= JQuery.on "click" \e _ -> do
    JQuery.select "#view_mode" >>= JQuery.toggleClass "show-sub-menu"

  JQuery.select "#backend_label" >>= JQuery.on "click" \e _ -> do
    JQuery.select "#backend" >>= JQuery.toggleClass "show-sub-menu"

  JQuery.select "#editor_view" >>= JQuery.on "click" \e _ -> hideMenus

  runContT (do sessionId <- ContT createSessionIdIfNecessary
               ContT (withSession sessionId)) setupEditor

module Main where

import Prelude

import Control.Monad.Cont.Trans (ContT(..), runContT)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, error)
import Control.Monad.Eff.JQuery (JQuery, addClass, append, appendText, attr, create, display, hide, on, ready, removeClass, select, setProp, setValue, toggleClass) as JQuery
import Control.Monad.Eff.JQuery.Extras (empty, filter, getValueMaybe, is) as JQuery
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Timer (TIMER, setTimeout)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, EffFn4, EffFn5, mkEffFn1, runEffFn1, runEffFn2, runEffFn4, runEffFn5)
import Control.Monad.Except.Trans (runExceptT)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Location (setHref)
import DOM.HTML.Types (ALERT, CONFIRM)
import DOM.HTML.Window (alert, confirm, location)
import Data.Array (mapMaybe)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (elem, fold, for_, intercalate, traverse_)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Foreign (renderForeignError)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.StrMap as StrMap
import Data.String (joinWith)
import Data.String as String
import Data.String.Regex (replace')
import Data.String.Regex.Flags (global)
import Data.String.Regex.Unsafe (unsafeRegex)
import Try.API (BackendConfig(..), CompileError(..), CompileResult(..), CompileWarning(..), CompilerError(..), ErrorPosition(..), FailedResult(..), SuccessResult(..), getBackendConfigFromString)
import Try.API as API
import Try.Gist (getGistById, tryLoadFileFromGist, uploadGist)
import Try.QueryString (getQueryStringMaybe, setQueryStrings)
import Try.Session (createSessionIdIfNecessary, storeSession, tryRetrieveSession)
import Try.Types (JS(..))

-- | Display a loading message in the right hand column.
displayLoadingMessage :: forall eff. Eff (dom :: DOM | eff) Unit
displayLoadingMessage = do
  column2 <- JQuery.select "#column2"
  JQuery.empty column2
  div <- JQuery.create "<div>"
  JQuery.addClass "loading" div
  JQuery.appendText "Loading..." div
  JQuery.append div column2

-- | Display a list of errors in the right hand column.
displayErrors :: forall eff. Array CompilerError -> Eff (dom :: DOM | eff) Unit
displayErrors errs = do
  column2 <- JQuery.select "#column2"
  JQuery.empty column2

  forWithIndex_ errs \i (CompilerError{ position, message }) ->
    for_ (unwrap position) \(ErrorPosition pos) -> do
      h1 <- JQuery.create "<h1>"
      JQuery.addClass "error-banner" h1
      JQuery.appendText ("Error " <> show (i + 1) <> " of " <> show (Array.length errs)) h1

      pre <- JQuery.create "<pre>"
      code_ <- JQuery.create "<code>"
      JQuery.append code_ pre
      JQuery.appendText message code_

      JQuery.append h1 column2
      JQuery.append pre column2

-- | Display plain text in the right hand column.
displayPlainText
  :: forall eff
   . String
  -> Eff (dom :: DOM | eff) Unit
displayPlainText s = do
  column2 <- JQuery.select "#column2"
  JQuery.empty column2
  pre <- JQuery.create "<pre>"
  code_ <- JQuery.create "<code>"
  JQuery.append code_ pre
  JQuery.appendText s code_
  JQuery.append pre column2

isShowJsChecked :: forall eff. Eff (dom :: DOM | eff) Boolean
isShowJsChecked = JQuery.select "#showjs" >>= \jq -> JQuery.is jq ":checked"

isAutoCompileChecked :: forall eff. Eff (dom :: DOM | eff) Boolean
isAutoCompileChecked = JQuery.select "#auto_compile" >>= \jq -> JQuery.is jq ":checked"

-- | Hide the drop down menus
hideMenus :: forall eff. Eff (dom :: DOM | eff) Unit
hideMenus = do
  JQuery.select "#menu" >>= JQuery.removeClass "show"
  JQuery.select "#view_mode" >>= JQuery.removeClass "show-sub-menu"
  JQuery.select "#backend" >>= JQuery.removeClass "show-sub-menu"

-- | Update the view mode based on the menu selection
changeViewMode :: forall eff. Maybe String -> Eff (dom :: DOM | eff) Unit
changeViewMode viewMode = do
  column1 <- JQuery.select "#column1"
  column2 <- JQuery.select "#column2"
  showjs <- JQuery.select "#showjs"
  showjsLabel <- JQuery.select "#showjs_label"
  case viewMode of
    Just "code" -> do
      JQuery.display column1
      JQuery.hide column2
      JQuery.hide showjs
      JQuery.hide showjsLabel
    Just "output" -> do
      JQuery.hide column1
      JQuery.display column2
      JQuery.display showjs
      JQuery.display showjsLabel
    _ -> do
      JQuery.display column1
      JQuery.display column2
      JQuery.display showjs
      JQuery.display showjsLabel

getTextAreaContent :: forall eff. Eff (dom :: DOM | eff) String
getTextAreaContent = fold <$> (JQuery.select "#code_textarea" >>= JQuery.getValueMaybe)

setTextAreaContent :: forall eff. String -> Eff (dom :: DOM | eff) Unit
setTextAreaContent value = JQuery.select "#code_textarea" >>= JQuery.setValue value

-- | Set the editor content to the specified string.
foreign import setEditorContent :: forall eff. EffFn1 (dom :: DOM | eff) String Unit

-- | Register a callback for editor change events.
foreign import onEditorChanged
  :: forall eff
   . EffFn2 (dom :: DOM | eff)
            (EffFn1 (dom :: DOM | eff) String Unit)
            Int
            Unit

-- | Clean up any global state associated with any visible error markers.
foreign import cleanUpMarkers :: forall eff. Eff (dom :: DOM | eff) Unit

-- | Add a visible marker at the specified location.
foreign import addMarker :: forall eff. EffFn5 (dom :: DOM | eff) String Int Int Int Int Unit

type Annotation =
  { row :: Int
  , column :: Int
  , type :: String
  , text :: String
  }

-- | Set the gutter annotations
foreign import setAnnotations :: forall eff. EffFn1 (dom :: DOM | eff) (Array Annotation) Unit

clearAnnotations :: forall eff. Eff (dom :: DOM | eff) Unit
clearAnnotations = runEffFn1 setAnnotations []

-- | Set up a fresh iframe in the specified container, and use it
-- | to execute the provided JavaScript code.
foreign import setupIFrame
  :: forall eff
   . EffFn4 (dom :: DOM | eff)
            JQuery.JQuery
            String
            String
            (EffFn1 (dom :: DOM | eff) JQuery.JQuery Unit)
            Unit

-- | Compile the current code and execute it.
compile :: forall eff. BackendConfig -> Eff (console :: CONSOLE, dom :: DOM | eff) Unit
compile bc@(BackendConfig backend) = do
  code <- getTextAreaContent

  clearAnnotations

  runContT (runExceptT (backend.compile code)) \res_ ->
    case res_ of
      Left err -> displayPlainText err
      Right res -> do
        cleanUpMarkers

        case res of
          Right (CompileSuccess (SuccessResult { js, warnings })) -> do
            showJs <- isShowJsChecked
            if showJs
              then displayPlainText js
              else runContT (runExceptT backend.getBundle)
                     case _ of
                       Left err -> error ("Unable to retrieve JS bundle: " <> err)
                       Right bundle -> do
                         for_ (unwrap warnings) \warnings_ -> do
                           let toAnnotation (CompileWarning{ errorCode, position, message }) =
                                 unwrap position <#> \(ErrorPosition pos) ->
                                   { row: pos.startLine - 1
                                   , column: pos.startColumn - 1
                                   , type: "warning"
                                   , text: message
                                   }
                           runEffFn1 setAnnotations (mapMaybe toAnnotation warnings_)
                         execute (JS js) bundle bc
          Right (CompileFailed (FailedResult { error })) ->
            case error of
              CompilerErrors errs -> do
                displayErrors errs

                let toAnnotation (CompilerError{ position, message }) =
                      unwrap position <#> \(ErrorPosition pos) ->
                        { row: pos.startLine - 1
                        , column: pos.startColumn - 1
                        , type: "error"
                        , text: message
                        }
                runEffFn1 setAnnotations (mapMaybe toAnnotation errs)

                for_ errs \(CompilerError{ position }) ->
                  for_ (unwrap position) \(ErrorPosition pos) ->
                    runEffFn5 addMarker
                      "error"
                      pos.startLine
                      pos.startColumn
                      pos.endLine
                      pos.endColumn
              OtherError err -> displayPlainText err
          Left errs -> do
            displayPlainText "Unable to parse the response from the server"
            traverse_ (error <<< renderForeignError) errs

-- | Execute the compiled code in a new iframe.
execute :: forall eff. JS -> JS -> BackendConfig -> Eff (dom :: DOM | eff) Unit
execute js bundle bc@(BackendConfig backend) = do
  let html = joinWith "\n"
        [ """<!DOCTYPE html>"""
        , """<html>"""
        , """  <head>"""
        , """    <meta content="text/html;charset=utf-8" http-equiv="Content-Type">"""
        , """    <meta content="utf-8" http-equiv="encoding">"""
        , """    <meta name="viewport" content="width=device-width, initial-scale=1.0">"""
        , """    <title>Try PureScript!</title>"""
        , """    <link rel="stylesheet" href="css/style.css">"""
        , backend.extra_styling
        , """  </head>"""
        , """  <body>"""
        , backend.extra_body
        , """  </body>"""
        , """</html>"""
        ]

      replaced = replace' (unsafeRegex """require\("[^"]*"\)""" global) (\s _ ->
        "PS['" <> String.drop 12 (String.take (String.length s - 2) s) <> "']") (unwrap js)

      wrapped = joinWith "\n"
        [ "var module = {};"
        , "(function(module) {"
        , replaced
        , "})(module);"
        , "module.exports.main && module.exports.main();"
        ]

      scripts = joinWith "\n" [unwrap bundle, wrapped]

  column2 <- JQuery.select "#column2"
  runEffFn4 setupIFrame column2 html scripts $ mkEffFn1 \body ->
    JQuery.on "click" (\_ _ -> hideMenus) body

-- | Setup the editor component and some event handlers.
setupEditor
  :: forall eff
   . { code :: String, backend :: BackendConfig }
  -> Eff ( alert :: ALERT
         , console :: CONSOLE
         , confirm :: CONFIRM
         , dom :: DOM
         , timer :: TIMER
         | eff
         ) Unit
setupEditor { code, backend } = do
  loadOptions backend
  setupBackendMenu backend

  setTextAreaContent code
  runEffFn1 setEditorContent code

  runEffFn2 onEditorChanged (mkEffFn1 \value -> do
    setTextAreaContent value
    cacheCurrentCode backend
    autoCompile <- isAutoCompileChecked
    when autoCompile do
      compile backend) 750

  JQuery.select "#showjs" >>= JQuery.on "change" \e _ ->
    compile backend

  JQuery.select "#compile_label" >>= JQuery.on "click" \e _ ->
    compile backend

  JQuery.select "#gist_save" >>= JQuery.on "click" \e _ ->
    publishNewGist backend

  compile backend
  cacheCurrentCode backend

loadFromGist
  :: forall eff
   . String
  -> BackendConfig
  -> ({ code :: String, backend :: BackendConfig }
      -> Eff ( confirm :: CONFIRM
             , console :: CONSOLE
             , dom :: DOM
             , timer :: TIMER
             | eff
             ) Unit)
  -> Eff ( confirm :: CONFIRM
         , console :: CONSOLE
         , dom :: DOM
         , timer :: TIMER
         | eff
         ) Unit
loadFromGist id_ backend k = do
  runContT (runExceptT (getGistById id_ >>= \gi -> tryLoadFileFromGist gi "Main.purs")) $
    case _ of
      Left err -> do
        error ("Unable to load gist metadata or contents: " <> err)
        k { code: "", backend }
      Right code -> k { code, backend }

withSession
  :: forall eff
   . String
  -> ({ code :: String, backend :: BackendConfig }
      -> Eff ( confirm :: CONFIRM
             , console :: CONSOLE
             , dom :: DOM
             , timer :: TIMER
             | eff
             ) Unit)
  -> Eff ( confirm :: CONFIRM
         , console :: CONSOLE
         , dom :: DOM
         , timer :: TIMER
         | eff
         ) Unit
withSession sessionId k = do
  state <- tryRetrieveSession sessionId
  case state of
    Just { code, backend } -> do
      k { code, backend: API.getBackendConfigFromString backend }
    Nothing -> do
      bc@(BackendConfig backend) <- API.getBackendConfigFromString <<< fromMaybe "core" <$> getQueryStringMaybe "backend"
      gist <- fromMaybe backend.mainGist <$> getQueryStringMaybe "gist"
      loadFromGist gist bc k

-- | Cache the current code in the session state
cacheCurrentCode
  :: forall eff
   . BackendConfig
  -> Eff (console :: CONSOLE, dom :: DOM | eff) Unit
cacheCurrentCode bc@(BackendConfig backend) = do
  sessionId <- getQueryStringMaybe "session"
  case sessionId of
    Just sessionId_ -> do
      code <- getTextAreaContent
      storeSession sessionId_ { code, backend: backend.backend }
    Nothing -> error "No session ID"

-- | Create a new Gist using the current content
publishNewGist
  :: forall eff
   . BackendConfig
  -> Eff ( alert :: ALERT
         , confirm :: CONFIRM
         , console :: CONSOLE
         , dom :: DOM
         | eff
         ) Unit
publishNewGist bc@(BackendConfig backend) = do
  ok <- window >>= confirm (intercalate "\n"
          [ "Do you really want to publish this code as an anonymous Gist?"
          , ""
          , "Note: this code will be available to anyone with a link to the Gist."
          ])
  when ok do
    content <- getTextAreaContent
    runContT (runExceptT (uploadGist content)) $
      case _ of
        Left err -> do
          window >>= alert "Failed to create gist"
          error ("Failed to create gist: " <> err)
        Right gistId -> do
          setQueryStrings (StrMap.singleton "gist" gistId <>
                           StrMap.singleton "backend" backend.backend)

-- | Navigate to the specified URL.
navigateTo :: forall eff. String -> Eff (dom :: DOM | eff) Unit
navigateTo uri = void (window >>= location >>= setHref uri)

-- | Read query string options and update the state accordingly
loadOptions
  :: forall eff
   . BackendConfig
  -> Eff ( console :: CONSOLE
         , confirm :: CONFIRM
         , dom :: DOM
         , timer :: TIMER
         | eff
         ) Unit
loadOptions bc = do
  viewMode <- getQueryStringMaybe "view"
  case viewMode of
    Just viewMode_
      | viewMode_ `elem` ["sidebyside", "code", "output"]
      -> changeViewMode viewMode
    _ -> pure unit

  showJs <- getQueryStringMaybe "js"
  case showJs of
    Just showJs_ ->
      JQuery.select "input:checkbox[name=showjs]" >>= JQuery.setProp "checked" (showJs_ == "true")
    _ -> pure unit

  autoCompile <- getQueryStringMaybe "compile"
  case autoCompile of
    Just autoCompile_ ->
      JQuery.select "input:checkbox[name=auto_compile]" >>= JQuery.setProp "checked" (autoCompile_ == "true")
    _ -> pure unit

  gist <- getQueryStringMaybe "gist"
  case gist of
    Just gist_ -> JQuery.select "#view_gist" >>= JQuery.attr { href: "https://gist.github.com/" <> gist_ }
    Nothing -> JQuery.select "#view_gist_li" >>= JQuery.hide

-- | Setup event listeners for the backend dropdown menu.
setupBackendMenu
  :: forall eff
   . BackendConfig
  -> Eff
       ( dom :: DOM
       , confirm :: CONFIRM
       , console :: CONSOLE
       , timer :: TIMER
       | eff
       )
       Unit
setupBackendMenu bc@(BackendConfig backend) = do
  JQuery.select ("#backend_" <> backend.backend) >>= JQuery.attr { checked: "checked" }
  JQuery.select "input[name=backend_inputs]" >>= JQuery.on "change" \e jq -> do
    bc_@(BackendConfig newBackend) <- getBackendConfigFromString <<< fromMaybe "core" <$> JQuery.getValueMaybe jq

    ok <- window >>= confirm ("Replace your current code with the " <> newBackend.backend <> " backend sample code?")
    if ok
      then navigateTo ("?backend=" <> newBackend.backend)
      else void $ setTimeout 1000 do
             compile bc_
             cacheCurrentCode bc_
    hideMenus

main :: Eff ( alert :: ALERT
            , confirm :: CONFIRM
            , console :: CONSOLE
            , dom :: DOM
            , random :: RANDOM
            , timer :: TIMER
            ) Unit
main = JQuery.ready do
  JQuery.select "input[name=view_mode]" >>= JQuery.on "change" \_ jq -> do
    viewMode <- JQuery.filter jq ":checked" >>= JQuery.getValueMaybe
    changeViewMode viewMode

  JQuery.select "#hamburger" >>= JQuery.on "click" \e _ -> do
    JQuery.select "#menu" >>= JQuery.toggleClass "show"

  JQuery.select "#view_mode_label" >>= JQuery.on "click" \e _ -> do
    JQuery.select "#view_mode" >>= JQuery.toggleClass "show-sub-menu"

  JQuery.select "#backend_label" >>= JQuery.on "click" \e _ -> do
    JQuery.select "#backend" >>= JQuery.toggleClass "show-sub-menu"

  JQuery.select "#editor_view" >>= JQuery.on "click" \e _ -> hideMenus

  runContT (do sessionId <- ContT createSessionIdIfNecessary
               ContT (withSession sessionId)) setupEditor


Using 'Names' alias type

Using 'Names' alias type

module Flag.App (Event, Country(..), shuffle, init, foldp, view) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (drop, head, length, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (fromNumber, round)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_, sequence)
import Data.Tuple (Tuple(..), snd)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

type State = { all :: Countries, current :: Names, correct :: Number, incorrect :: Number }
type Countries = Array Country
type Names = Array String

data Event = RequestCountries | ReceiveCountries (Tuple Countries Names) | ReceiveAnswer String | ReceiveAnswers Names

newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    model <- decodeJson json
    name <- model .? "name"
    flag <- model .? "flag"
    pure $ Country { name, flag }

answerCount :: Int
answerCount = 4

init :: State
init = { all: [], current: [], correct: 0.0, incorrect: 0.0 }

decode :: ∀ r. { response :: Json | r } -> Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX, random :: RANDOM | e) (Tuple Countries Names)
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< Tuple countries <=< liftEff <<< pick $ countries

shuffle :: forall e a. Array a -> Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

pick :: forall e. Countries -> Eff (random :: RANDOM | e) Names
pick xs = pure <=< shuffle <<< (next <> _) <<< take (answerCount - 1) <=< shuffle $ _.name <<< unwrap <$> xs
  where next = _.name <<< unwrap <$> take 1 xs

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX, random :: RANDOM)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe mempty (_.name <<< unwrap) $ head state.all of
           true -> state { all = drop 1 state.all, correct = state.correct + 1.0 }
           _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1.0 },
  effects: [pure <<< Just <<< ReceiveAnswers <=< liftEff <<< pick <<< drop 1 $ state.all]
}
foldp (ReceiveAnswers current) state = noEffects state { current = current }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0.0, incorrect = 0.0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show correct
    div ! className "incorrect" $ text $ show incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0.0 -> div $ text mempty
    Nothing, _   -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = maybe 0 id <<< fromNumber $ (state.correct + state.incorrect)
            correct = maybe 0 id <<< fromNumber $ state.correct
            incorrect = maybe 0 id <<< fromNumber $ state.incorrect
            percentage = round $ (state.correct / (state.correct + state.incorrect)) * 100.0

module Flag.App (Event, Country(..), shuffle, init, foldp, view) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (drop, head, length, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (fromNumber, round)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_, sequence)
import Data.Tuple (Tuple(..), snd)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

type State = { all :: Countries, current :: Array String, correct :: Number, incorrect :: Number }
type Countries = Array Country
type Names = Array String

data Event = RequestCountries | ReceiveCountries (Tuple Countries Names) | ReceiveAnswer String | ReceiveAnswers Names

newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    model <- decodeJson json
    name <- model .? "name"
    flag <- model .? "flag"
    pure $ Country { name, flag }

answerCount :: Int
answerCount = 4

init :: State
init = { all: [], current: [], correct: 0.0, incorrect: 0.0 }

decode :: ∀ r. { response :: Json | r } -> Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX, random :: RANDOM | e) (Tuple Countries (Array String))
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< Tuple countries <=< liftEff <<< pick $ countries

shuffle :: forall e a. Array a -> Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

pick :: forall e. Countries -> Eff (random :: RANDOM | e) (Array String)
pick xs = pure <=< shuffle <<< (next <> _) <<< take (answerCount - 1) <=< shuffle $ _.name <<< unwrap <$> xs
  where next = _.name <<< unwrap <$> take 1 xs

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX, random :: RANDOM)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe mempty (_.name <<< unwrap) $ head state.all of
           true -> state { all = drop 1 state.all, correct = state.correct + 1.0 }
           _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1.0 },
  effects: [pure <<< Just <<< ReceiveAnswers <=< liftEff <<< pick <<< drop 1 $ state.all]
}
foldp (ReceiveAnswers current) state = noEffects state { current = current }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0.0, incorrect = 0.0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show correct
    div ! className "incorrect" $ text $ show incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0.0 -> div $ text mempty
    Nothing, _   -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = maybe 0 id <<< fromNumber $ (state.correct + state.incorrect)
            correct = maybe 0 id <<< fromNumber $ state.correct
            incorrect = maybe 0 id <<< fromNumber $ state.incorrect
            percentage = round $ (state.correct / (state.correct + state.incorrect)) * 100.0


Remove duplicate classes

Remove duplicate classes

This is very stupid and inefficient.

Original commit 4b8c076d63c70ee98c0a5c35236f057dd5eda696

module Main where

import IR
import Prelude

import CSharp as CSharp
import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson, isString)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Either.Nested (in1)
import Data.Foldable (find)
import Data.Foldable (for_)
import Data.List (List(..), fromFoldable, length, nub, partition, (:))
import Data.List as L
import Data.List.Types (List(..))
import Data.Map (Map, lookup, mapWithKey, toUnfoldable)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set (Set, insert)
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Data.Tuple as Tuple
import Doc (Doc)
import Doc as Doc
import Swift as Swift

type Renderer = IRClassData -> Doc Unit

renderers = {
    csharp: CSharp.renderCSharpClass --, swift: Swift.renderSwiftClass
}

lookupOrDefault :: forall k v. Ord k => v -> k -> Map.Map k v -> v
lookupOrDefault default key m =
    case Map.lookup key m of
    Nothing -> default
    Just x -> x

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> v) -> v -> Map.Map k v -> Map.Map k v -> Map.Map k v
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ Map.keys m1) (S.fromFoldable $ Map.keys m2)
        valueFor k = (unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2))
        kvps = map (\k -> Tuple.Tuple k (valueFor k)) allKeys
    in
        Map.fromFoldable kvps

unifyClasses :: IRClassData -> IRClassData -> IRClassData
unifyClasses (IRClassData na pa) (IRClassData nb pb) =
    IRClassData na (unionWithDefault unifyTypesWithNull IRNothing pa pb)

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.difference s (S.delete x s) }
            Nothing -> { element: element, rest: s }

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

unifyMaybes :: Maybe IRType -> Maybe IRType -> IRType
unifyMaybes Nothing Nothing = IRNothing
unifyMaybes (Just a) Nothing = a
unifyMaybes Nothing (Just b) = b
unifyMaybes (Just a) (Just b) = unifyTypes a b

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

unifyUnion :: S.Set IRType -> S.Set IRType -> S.Set IRType
unifyUnion sa sb =
    let { element: arrayA, rest: sa } = removeElement isArray sa
        { element: arrayB, rest: sb } = removeElement isArray sb
        { element: classA, rest: sa } = removeElement isClass sa
        { element: classB, rest: sb } = removeElement isClass sb
        unifiedArray = setFromType $ unifyMaybes arrayA arrayB
        unifiedClasses = setFromType $ unifyMaybes classA classB
    in
        S.unions [sa, sb, unifiedArray, unifiedClasses]

unifyTypes :: IRType -> IRType -> IRType
unifyTypes IRNothing x = x
unifyTypes x IRNothing = x
unifyTypes (IRArray a) (IRArray b) = IRArray (unifyTypes a b)
unifyTypes (IRClass a) (IRClass b) = IRClass (unifyClasses a b)
unifyTypes (IRUnion a) (IRUnion b) = IRUnion (unifyUnion a b)
unifyTypes (IRUnion a) b = IRUnion (unifyUnion a (S.singleton b))
unifyTypes a (IRUnion b) = IRUnion (unifyUnion (S.singleton a) b)
unifyTypes a b = if a == b then a else IRUnion (S.fromFoldable [a, b])

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

unifyTypesWithNull :: IRType -> IRType -> IRType
unifyTypesWithNull IRNothing IRNothing = IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    (\arr -> let typeName = singular name
        in
            IRArray (L.foldl (\t j -> unifyTypes t (makeTypeFromJson typeName j)) IRNothing arr))
    fromJObject
    json
    where
        fromJObject obj = IRClass (IRClassData name (Map.fromFoldable $ StrMap.foldMap toProperty obj))
        toProperty name json = L.singleton $ Tuple.Tuple name (makeTypeFromJson name json)

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType = case _ of
    IRClass cls@(IRClassData _ properties) -> cls : L.concatMap gatherClassesFromType (Map.values properties)
    IRArray t -> gatherClassesFromType t
    IRUnion s -> L.concatMap gatherClassesFromType (L.fromFoldable s)
    _ -> empty

matchingProperties :: forall v. Eq v => Map.Map String v -> Map.Map String v -> Map.Map String v
matchingProperties ma mb =
    Map.fromFoldable (L.concatMap getFromB (Map.toUnfoldable ma))
    where
        getFromB (Tuple.Tuple k va) =
            case Map.lookup k mb of
            Just vb -> if va == vb then Tuple.Tuple k vb : L.Nil else L.Nil
            Nothing -> L.Nil

propertiesSimilar :: forall v. Eq v => Map.Map String v -> Map.Map String v -> Boolean
propertiesSimilar pa pb =
    let aInB = Map.size $ matchingProperties pa pb
        bInA = Map.size $ matchingProperties pb pa
    in
        (aInB * 4 >= (Map.size pa) * 3) && (bInA * 4 >= (Map.size pb) * 3)

similarClasses :: L.List IRClassData -> { classes :: S.Set IRClassData, replacements :: Map.Map IRClassData IRClassData }
similarClasses L.Nil = { classes: S.empty, replacements: Map.empty }
similarClasses (thisClass@(IRClassData name properties) : rest) =
    let { yes: similar, no: others } = L.partition isSimilar rest
        recursiveResult@{ classes, replacements } = similarClasses others
    in
        if L.length similar == 0 then
            recursiveResult
        else
            let unified = L.foldl unifyClasses thisClass similar
                newReplacements = Map.fromFoldable (map (\c -> Tuple.Tuple c unified) (thisClass : similar))
            in
                { classes: S.insert unified classes, replacements: Map.union replacements newReplacements  }
    where isSimilar (IRClassData _ p) = propertiesSimilar p properties

replaceClasses :: (Map.Map IRClassData IRClassData) -> IRType -> IRType
replaceClasses m t@(IRClass c@(IRClassData name properties)) =
    case Map.lookup c m of
    Nothing -> IRClass (IRClassData name (Map.mapWithKey (\n t -> replaceClasses m t) properties))
    Just replacement -> IRClass replacement
replaceClasses m (IRArray t) = IRArray (replaceClasses m t)
replaceClasses m (IRUnion s) = IRUnion (S.map (replaceClasses m) s)
replaceClasses _ t = t

replaceSimilarClasses :: IRType -> IRType
replaceSimilarClasses t =
    let { classes, replacements } = similarClasses (gatherClassesFromType t)
    in
        replaceClasses replacements t

renderClasses :: Renderer -> L.List IRClassData -> Doc Unit
renderClasses renderer classes = for_ classes \cls -> do
    renderer cls
    Doc.blank

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> replaceSimilarClasses
    <#> gatherClassesFromType
    <#> L.nub
    <#> renderClasses renderers.csharp
    <#> Doc.render

module Main where

import Prelude

import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Foldable (find)
import Data.Maybe (Maybe(..))
import Data.String.Util (singular)
import Data.List ((:))
import Data.List as L
import Data.Tuple as Tuple
import Data.List.Types (List(..))
import Data.StrMap as StrMap
import Data.Map as Map
import Data.Foldable (for_)
import Data.Set as S

import IR

import Doc (Doc())
import Doc as Doc

import Swift as Swift
import CSharp as CSharp

type Renderer = IRClassData -> Doc Unit

renderers = {
    csharp: CSharp.renderCSharpClass --, swift: Swift.renderSwiftClass
}

lookupOrDefault :: forall k v. Ord k => v -> k -> Map.Map k v -> v
lookupOrDefault default key m =
    case Map.lookup key m of
    Nothing -> default
    Just x -> x

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> v) -> v -> Map.Map k v -> Map.Map k v -> Map.Map k v
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ Map.keys m1) (S.fromFoldable $ Map.keys m2)
        valueFor k = (unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2))
        kvps = map (\k -> Tuple.Tuple k (valueFor k)) allKeys
    in
        Map.fromFoldable kvps

unifyClasses :: IRClassData -> IRClassData -> IRClassData
unifyClasses (IRClassData na pa) (IRClassData nb pb) =
    IRClassData na (unionWithDefault unifyTypesWithNull IRNothing pa pb)

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.difference s (S.delete x s) }
            Nothing -> { element: element, rest: s }

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

unifyMaybes :: Maybe IRType -> Maybe IRType -> IRType
unifyMaybes Nothing Nothing = IRNothing
unifyMaybes (Just a) Nothing = a
unifyMaybes Nothing (Just b) = b
unifyMaybes (Just a) (Just b) = unifyTypes a b

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

unifyUnion :: S.Set IRType -> S.Set IRType -> S.Set IRType
unifyUnion sa sb =
    let { element: arrayA, rest: sa } = removeElement isArray sa
        { element: arrayB, rest: sb } = removeElement isArray sb
        { element: classA, rest: sa } = removeElement isClass sa
        { element: classB, rest: sb } = removeElement isClass sb
        unifiedArray = setFromType $ unifyMaybes arrayA arrayB
        unifiedClasses = setFromType $ unifyMaybes classA classB
    in
        S.unions [sa, sb, unifiedArray, unifiedClasses]

unifyTypes :: IRType -> IRType -> IRType
unifyTypes IRNothing x = x
unifyTypes x IRNothing = x
unifyTypes (IRArray a) (IRArray b) = IRArray (unifyTypes a b)
unifyTypes (IRClass a) (IRClass b) = IRClass (unifyClasses a b)
unifyTypes (IRUnion a) (IRUnion b) = IRUnion (unifyUnion a b)
unifyTypes (IRUnion a) b = IRUnion (unifyUnion a (S.singleton b))
unifyTypes a (IRUnion b) = IRUnion (unifyUnion (S.singleton a) b)
unifyTypes a b = if a == b then a else IRUnion (S.fromFoldable [a, b])

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

unifyTypesWithNull :: IRType -> IRType -> IRType
unifyTypesWithNull IRNothing IRNothing = IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    (\arr -> let typeName = singular name
        in
            IRArray (L.foldl (\t j -> unifyTypes t (makeTypeFromJson typeName j)) IRNothing arr))
    fromJObject
    json
    where
        fromJObject obj = IRClass (IRClassData name (Map.fromFoldable $ StrMap.foldMap toProperty obj))
        toProperty name json = L.singleton $ Tuple.Tuple name (makeTypeFromJson name json)

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType = case _ of
    IRClass cls@(IRClassData _ properties) -> cls : L.concatMap gatherClassesFromType (Map.values properties)
    IRArray t -> gatherClassesFromType t
    IRUnion s -> L.concatMap gatherClassesFromType (L.fromFoldable s)
    _ -> empty

renderClasses :: Renderer -> L.List IRClassData -> Doc Unit
renderClasses renderer classes = for_ classes \cls -> do
    renderer cls
    Doc.blank

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClasses renderers.csharp
    <#> Doc.render