Add gene renderer

Add gene renderer

module Genetics.Browser.Track.Demo where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Monad.Aff (Aff, throwError)
import Control.Monad.Eff.Exception (error)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.Foldable (class Foldable, length)
import Data.Lens (to, (^?))
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(..))
import Data.Monoid (mempty)
import Data.Newtype (unwrap)
import Data.Pair (Pair(..))
import Data.String as String
import Data.Symbol (SProxy(SProxy))
import Data.Traversable (class Traversable, traverse)
import Data.Variant (inj)
import Genetics.Browser.Track.Backend (BrowserTrack, ChrCtx, DrawingV, Feature, Legend, LegendEntry, Padding, Renderer, VScale, _point, _range, bumpFeatures, chrLabelTrack, drawLegend, drawVScale, featureInterval, groupToChrs, horPlace, horRulerTrack, mkIcon, renderTrack, trackLegend, verPlace, zipMapsWith)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordSys, Interval, Normalized(Normalized), 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 Unsafe.Coerce (unsafeCoerce)

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

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just as -> case traverse p as of
      Nothing -> throwError $ error "Failed to parse JSON features"
      Just fs -> pure $ fs

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

scoreVerPlace :: forall r1 r2.
                  { min :: Number, max :: Number | r1 }
               -> Feature (score :: Number | r2)
               -> Normalized Number
scoreVerPlace s =
  verPlace (to (\x -> Normalized $ (x.score - s.min) / (s.max - s.min)))

type GWASFeature r = Feature ( score :: Number
                             , chrId :: ChrId | r )

gemmaJSONParse :: forall a.
                  CoordSys ChrId a
               -> Json
               -> Maybe (GWASFeature ())
gemmaJSONParse cs j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "af"  <<< _Number

  {chrSize} <- lookupInterval cs chrId

  pure { position: inj _point pos
       , frameSize: chrSize
       , score
       , chrId }

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

type Gene r = Feature (GeneRow r)

geneDraw :: forall r.
            (Gene r)
         -> DrawingV
geneDraw gene = inj _range \w ->
  let (Pair l r) = featureInterval gene
      glyphW = unwrap $ (r - l) / gene.frameSize
      rect = rectangle 0.0 0.0 (w * glyphW) 5.0
      out  = outlined (outlineColor maroon <> lineWidth 3.0) rect
      fill = filled   (fillColor white) rect

  in out <> fill

geneRenderer :: forall r. Renderer (Gene r)
geneRenderer =
  { draw: geneDraw
  , horPlace
  , verPlace: const (Normalized 0.5) }

geneJSONParse :: CoordSys _ _
              -> Json
              -> Maybe (Gene ())
geneJSONParse cs j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  chrId  <- ChrId <$> obj ^? ix "ChrId" <<< _String

  {chrSize} <- lookupInterval cs chrId

  pure { position: inj _range (Pair start end)
       , frameSize: chrSize
       , geneID
       , desc
       , name
       , start
       , end
       , chrId
       }

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

type AnnotRow r = ( geneID :: String
                   , desc :: String
                   , name :: String
                   , chrId :: ChrId | r )
type Annot r = Feature (AnnotRow r)

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

getDataDemo :: CoordSys _ _
            -> { gwas :: String
               , annots :: String }
            -> Aff _ { gwas   :: Map ChrId (List (GWASFeature ()       ))
                     , annots :: Map ChrId (List (Annot (score :: Number)))
                     }
getDataDemo cs urls = do
  gwas    <- fetchJSON (gemmaJSONParse cs) urls.gwas
  annots' <- fetchAnnotJSON cs urls.annots
  -- Divide data by chromosomes
  let gwasChr :: Map ChrId (List (GWASFeature ()))
      gwasChr = List.fromFoldable <$> groupToChrs gwas
  let annotsChr :: Map ChrId (List (Annot ()))
      annotsChr = List.fromFoldable <$> groupToChrs annots'
  let bumpedAnnots :: Map ChrId (List (Annot (score :: Number)))
      bumpedAnnots = zipMapsWith
                     (bumpFeatures (to (_.score)) (SProxy :: SProxy "score")
                       (Bp 1000000.0))
                     gwasChr annotsChr

  pure { gwas: gwasChr, annots: bumpedAnnots }

demoTrack :: forall f r.
             Foldable f
          => Traversable f
          => CoordSys ChrId BrowserPoint
          -> { min :: Number, max :: Number, sig :: Number | r }
          -> { gwas   :: Map ChrId (f (GWASFeature ()))
             , annots :: Map ChrId (f (Annot (score :: Number))) }
          -> BrowserTrack
demoTrack cs s {gwas, annots} =
  let renderers = renderersDemo s

      gwasTrack   = renderTrack cs renderers.gwas gwas
      annotsTrack = renderTrack cs renderers.annots annots

      chrLabels = chrLabelTrack cs
      ruler = horRulerTrack s red

  in chrLabels
  <> ruler
  <> gwasTrack
  <> annotsTrack

pointRenderer :: forall r1 r2.
                 { min :: Number, max :: Number, sig :: Number | r2 }
              -> (Feature (score :: Number | r1) -> DrawingV)
              -> Renderer (Feature (score :: Number | r1))
pointRenderer s draw = { horPlace, verPlace: scoreVerPlace s, draw }

renderersDemo :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> { gwas   :: Renderer _
                 , annots :: Renderer _
                 }
renderersDemo s = { gwas:   pointRenderer s (gwasDraw navy)
                  , annots: pointRenderer s annotDraw }

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

annotLegendEntry :: forall r. Annot r -> LegendEntry
annotLegendEntry a =
  if (String.length a.name) `mod` 2 == 0
    then mkIcon blue "even length name"
    else mkIcon red  "odd length name"

annotLegendTest :: forall f r.
                   Foldable f
                => Functor f
                => Map ChrId (f (Annot r))
                -> Array LegendEntry
annotLegendTest fs = trackLegend annotLegendEntry as
  where as = Array.concat $ Array.fromFoldable $ (Array.fromFoldable <$> Map.values fs)

annotDraw :: forall r.
             Annot r
          -> DrawingV
annotDraw an = inj _point $ (lg.icon) <> text'
  where lg = annotLegendEntry an
        text' = Drawing.text
                  (font sansSerif 12 mempty)
                  (7.5) (2.5)
                  (fillColor black) an.name

demoBrowser :: 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 }
demoBrowser 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 :: _
      vScale _ = let w = ui.vscale.width
                 in  translate zero padding.vertical
                   $ bg w height
                  <> drawVScale ui.vscale height

      track :: _
      track v = demoTrack cs ui.vscale input trackCanvas v

      legendD :: _
      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 }

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

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

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

module Genetics.Browser.Track.Demo where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (aqua, blue, fuchsia, green, lime, maroon, navy, olive, orange, purple, red, teal, yellow)
import Control.Monad.Aff (Aff, throwError)
import Control.Monad.Eff.Exception (error)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.Foldable (class Foldable, length)
import Data.Lens (to, (^?))
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(..))
import Data.Monoid (mempty)
import Data.Newtype (unwrap)
import Data.Pair (Pair(..))
import Data.String as String
import Data.Symbol (SProxy(SProxy))
import Data.Traversable (class Traversable, traverse)
import Data.Variant (inj)
import Genetics.Browser.Track.Backend (BrowserTrack, ChrCtx, DrawingV, Feature, Legend, LegendEntry, Padding, Renderer, VScale, _point, _range, bumpFeatures, chrLabelTrack, drawLegend, drawVScale, featureInterval, groupToChrs, horPlace, horRulerTrack, mkIcon, renderTrack, trackLegend, verPlace, zipMapsWith)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordSys, Interval, Normalized(Normalized), 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 Unsafe.Coerce (unsafeCoerce)

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

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just as -> case traverse p as of
      Nothing -> throwError $ error "Failed to parse JSON features"
      Just fs -> pure $ fs

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

scoreVerPlace :: forall r1 r2.
                  { min :: Number, max :: Number | r1 }
               -> Feature (score :: Number | r2)
               -> Normalized Number
scoreVerPlace s =
  verPlace (to (\x -> Normalized $ (x.score - s.min) / (s.max - s.min)))

type GWASFeature r = Feature ( score :: Number
                             , chrId :: ChrId | r )

gemmaJSONParse :: forall a.
                  CoordSys ChrId a
               -> Json
               -> Maybe (GWASFeature ())
gemmaJSONParse cs j = do
  obj <- j ^? _Object
  chrId <- ChrId <$> obj ^? ix "chr" <<< _String
  pos   <- Bp    <$> obj ^? ix "ps"  <<< _Number
  score <-           obj ^? ix "af"  <<< _Number

  {chrSize} <- lookupInterval cs chrId

  pure { position: inj _point pos
       , frameSize: chrSize
       , score
       , chrId }

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

type Gene r = Feature (GeneRow r)

geneJSONParse :: CoordSys _ _
              -> Json
              -> Maybe (Gene ())
geneJSONParse cs j = do
  obj    <- j ^? _Object
  geneID <- obj ^? ix "Gene stable ID" <<< _String
  desc   <- obj ^? ix "Gene description" <<< _String
  name   <- obj ^? ix "Gene name" <<< _String
  start  <- Bp    <$> obj ^? ix "Gene start (bp)"  <<< _Number
  end    <- Bp    <$> obj ^? ix "Gene end (bp)"  <<< _Number
  chrId  <- ChrId <$> obj ^? ix "ChrId" <<< _String

  {chrSize} <- lookupInterval cs chrId

  pure { position: inj _range (Pair start end)
       , frameSize: chrSize
       , geneID
       , desc
       , name
       , start
       , end
       , chrId
       }

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

type AnnotRow r = ( geneID :: String
                   , desc :: String
                   , name :: String
                   , chrId :: ChrId | r )
type Annot r = Feature (AnnotRow r)

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

getDataDemo :: CoordSys _ _
            -> { gwas :: String
               , annots :: String }
            -> Aff _ { gwas   :: Map ChrId (List (GWASFeature ()       ))
                     , annots :: Map ChrId (List (Annot (score :: Number)))
                     }
getDataDemo cs urls = do
  gwas    <- fetchJSON (gemmaJSONParse cs) urls.gwas
  annots' <- fetchAnnotJSON cs urls.annots
  -- Divide data by chromosomes
  let gwasChr :: Map ChrId (List (GWASFeature ()))
      gwasChr = List.fromFoldable <$> groupToChrs gwas
  let annotsChr :: Map ChrId (List (Annot ()))
      annotsChr = List.fromFoldable <$> groupToChrs annots'
  let bumpedAnnots :: Map ChrId (List (Annot (score :: Number)))
      bumpedAnnots = zipMapsWith
                     (bumpFeatures (to (_.score)) (SProxy :: SProxy "score")
                       (Bp 1000000.0))
                     gwasChr annotsChr

  pure { gwas: gwasChr, annots: bumpedAnnots }

demoTrack :: forall f r.
             Foldable f
          => Traversable f
          => CoordSys ChrId BrowserPoint
          -> { min :: Number, max :: Number, sig :: Number | r }
          -> { gwas   :: Map ChrId (f (GWASFeature ()))
             , annots :: Map ChrId (f (Annot (score :: Number))) }
          -> BrowserTrack
demoTrack cs s {gwas, annots} =
  let renderers = renderersDemo s

      gwasTrack   = renderTrack cs renderers.gwas gwas
      annotsTrack = renderTrack cs renderers.annots annots

      chrLabels = chrLabelTrack cs
      ruler = horRulerTrack s red

  in chrLabels
  <> ruler
  <> gwasTrack
  <> annotsTrack

pointRenderer :: forall r1 r2.
                 { min :: Number, max :: Number, sig :: Number | r2 }
              -> (Feature (score :: Number | r1) -> DrawingV)
              -> Renderer (Feature (score :: Number | r1))
pointRenderer s draw = { horPlace, verPlace: scoreVerPlace s, draw }

renderersDemo :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> { gwas   :: Renderer _
                 , annots :: Renderer _
                 }
renderersDemo s = { gwas:   pointRenderer s (gwasDraw navy)
                  , annots: pointRenderer s annotDraw }

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

annotLegendEntry :: forall r. Annot r -> LegendEntry
annotLegendEntry a =
  if (String.length a.name) `mod` 2 == 0
    then mkIcon blue "even length name"
    else mkIcon red  "odd length name"

annotLegendTest :: forall f r.
                   Foldable f
                => Functor f
                => Map ChrId (f (Annot r))
                -> Array LegendEntry
annotLegendTest fs = trackLegend annotLegendEntry as
  where as = Array.concat $ Array.fromFoldable $ (Array.fromFoldable <$> Map.values fs)

annotDraw :: forall r.
             Annot r
          -> DrawingV
annotDraw an = inj _point $ (lg.icon) <> text'
  where lg = annotLegendEntry an
        text' = Drawing.text
                  (font sansSerif 12 mempty)
                  (7.5) (2.5)
                  (fillColor black) an.name

demoBrowser :: 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 }
demoBrowser 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 :: _
      vScale _ = let w = ui.vscale.width
                 in  translate zero padding.vertical
                   $ bg w height
                  <> drawVScale ui.vscale height

      track :: _
      track v = demoTrack cs ui.vscale input trackCanvas v

      legendD :: _
      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 }

mouseChrIds :: Array ChrId
mouseChrIds =
            [ (ChrId "1")
            , (ChrId "2")
            , (ChrId "3")
            , (ChrId "4")
            , (ChrId "5")
            , (ChrId "6")
            , (ChrId "7")
            , (ChrId "8")
            , (ChrId "9")
            , (ChrId "10")
            , (ChrId "11")
            , (ChrId "12")
            , (ChrId "13")
            , (ChrId "14")
            , (ChrId "15")
            , (ChrId "16")
            , (ChrId "17")
            , (ChrId "18")
            , (ChrId "19")
            , (ChrId "X")
            , (ChrId "Y")
            ]

mouseChrs :: Map ChrId Bp
mouseChrs = Map.fromFoldable $ Array.zip mouseChrIds $
            [ (Bp 195471971.0)
            , (Bp 182113224.0)
            , (Bp 160039680.0)
            , (Bp 156508116.0)
            , (Bp 151834684.0)
            , (Bp 149736546.0)
            , (Bp 145441459.0)
            , (Bp 129401213.0)
            , (Bp 124595110.0)
            , (Bp 130694993.0)
            , (Bp 122082543.0)
            , (Bp 120129022.0)
            , (Bp 120421639.0)
            , (Bp 124902244.0)
            , (Bp 104043685.0)
            , (Bp 98207768.0)
            , (Bp 94987271.0)
            , (Bp 90702639.0)
            , (Bp 61431566.0)
            , (Bp 17103129.0)
            , (Bp 9174469.0)
            ]

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

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


Formatting

Formatting

module Main (main) where

import Data.Function

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

data Action = TextChanged String | ClearText

data State = State { name :: String }

data Props = Props { greeting :: String }

foreign import unsafeStringValue
  "function unsafeStringValue(e) {\
  \  return e.target.value;\
  \}" :: T.FormEvent -> String

initialState :: State
initialState = State { name: "" }

render :: T.Render State Props Action
render = mkFn3 render'
  where
  render' :: T.Context Action -> State -> Props -> T.Html Action
  render' ctx (State s) (Props p) = T.div' $ welcome : response s.name
    where
    welcome :: T.Html _
    welcome =
      T.div'
        [ T.input [ A.value s.name
                  , A.placeholder "What is your name?"
                  , T.onChange ctx (TextChanged <<< unsafeStringValue)
                  ] []
        , T.button [ T.onClick ctx (\_ -> TextChanged "") ]
                   [ T.text "Clear" ]
        ]

    response :: String -> [T.Html _]
    response "" = []
    response s =
      [ T.div'
          [ T.text p.greeting
          , T.text s
          ]
      ]

performAction :: T.PerformAction State Props Action _
performAction = mkFn3 \_ _ (TextChanged s) k -> k (State { name: s })

spec :: T.Spec _ State Props Action
spec = T.Spec { initialState: initialState
              , performAction: performAction
              , render: render
              }

main = do
  let component = T.createClass spec
  T.render component (Props { greeting: "Hello, " })

module Main (main) where

import Data.Function

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

data Action = TextChanged String | ClearText

data State = State { name :: String }

data Props = Props { greeting :: String }

foreign import unsafeStringValue
  "function unsafeStringValue(e) {\
  \  return e.target.value;\
  \}" :: T.FormEvent -> String

initialState :: State
initialState = State { name: "" }

render :: T.Render State Props Action
render = mkFn3 render'
  where
  render' :: T.Context Action -> State -> Props -> T.Html Action
  render' ctx (State s) (Props p) = T.div' $ welcome : response s.name
    where
    welcome :: T.Html _
    welcome =
      T.div'
        [ T.input [ A.value s.name, A.placeholder "What is your name?", T.onChange ctx (TextChanged <<< unsafeStringValue) ] []
        , T.button [ T.onClick ctx (\_ -> TextChanged "") ] [ T.text "Clear" ]
        ]

    response :: String -> [T.Html _]
    response "" = []
    response s =
      [ T.div'
          [ T.text p.greeting
          , T.text s
          ]
      ]

performAction :: T.PerformAction State Props Action _
performAction = mkFn3 \_ _ (TextChanged s) k -> k (State { name: s })

spec :: T.Spec _ State Props Action
spec = T.Spec { initialState: initialState
              , performAction: performAction
              , render: render
              }

main = do
  let component = T.createClass spec
  T.render component (Props { greeting: "Hello, " })


Remove Copy/Paste/Cut input from bad merge

module Input.Notebook (runCellEvent, updateState, CellResultContent(..), Input(..)) where

import Data.Tuple (fst)
import Data.Maybe (maybe, Maybe(..))
import Data.Array (filter, modifyAt, (!!))
import Data.Function (on)
import Data.Date (Date(), Now(), now, toEpochMilliseconds)
import Control.Monad.Eff.Class (liftEff)
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Domain (notebookCells, addCell)
import Model.Resource (resourceName, nameL, Resource())
import Optic.Core ((..), (<>~), (%~), (+~), (.~))
import Optic.Setter (mapped, over)
import Halogen.HTML.Events.Monad (Event(), async)
import Control.Timer (Timeout())

data CellResultContent = AceContent String

data Input
  = Dropdown Number
  | CloseDropdowns
  | SetTimeout (Maybe Timeout)
  | SetName String
  | SetResource Resource
  | SetSiblings [Resource]
  | SetLoaded Boolean
  | SetError String
  | SetEditable Boolean
  | SetModalError String
  | SetAddingCell Boolean
  | AddCell CellType
  | ToggleEditorCell CellId
  | TrashCell CellId
  | RunCell CellId Date
  | CellResult CellId Date CellResultContent
  | SetActiveCell CellId

runCellEvent :: forall eff. CellId -> Event (now :: Now | eff) Input
runCellEvent cid = async $ RunCell cid <$> liftEff now

updateState :: State -> Input -> State

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # dropdowns %~
  (modifyAt i (\x -> x{visible = visSet})) <<<  (_{visible = false} <$>)

updateState state CloseDropdowns =
  state{addingCell = false} # dropdowns %~ (_{visible = false} <$>)

updateState state (SetTimeout mbTm) =
  state{timeout = mbTm}

updateState state (SetResource res) =
  state{resource = res, name = resourceName res}

updateState state (SetName name) =
  state{resource = state.resource # nameL .~ name}

updateState state (SetSiblings ss) =
  state{siblings = ss}

updateState state (SetLoaded loaded) =
  state{loaded = loaded}

updateState state (SetError error) =
  state{error = error}

updateState state (SetEditable editable) =
  state{editable = editable}

updateState state (SetModalError error) =
  state{modalError = error}

updateState state (SetAddingCell adding) =
  state{addingCell = adding}

updateState state (AddCell cellType) =
  state # notebook %~ (addCell cellType Nothing >>> fst)

updateState state (ToggleEditorCell cellId) =
  state # notebook..notebookCells..mapped %~ onCell cellId toggleEditor

updateState state (TrashCell cellId) =
  state # notebook..notebookCells %~ filter (not <<< isCell cellId)

updateState state (CellResult cellId date (AceContent content)) =
  let f (RunningSince d) = RunFinished $ on (-) toEpochMilliseconds date d
      f _                = RunInitial -- TODO: Cell in bad state
  in state # notebook..notebookCells..mapped %~ onCell cellId (modifyRunState f <<< setContent content)

updateState state (SetActiveCell cellId) =
  state # activeCellId .~ cellId

updateState state (RunCell cellId date) =
  state # notebook..notebookCells..mapped %~ onCell cellId (modifyRunState <<< const $ RunningSince date)

updateState state i = state

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

toggleEditor :: Cell -> Cell
toggleEditor (Cell o) = Cell $ o { hiddenEditor = not o.hiddenEditor }

setContent :: String -> Cell -> Cell
setContent content (Cell o) = Cell $ o { content = content }

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

module Input.Notebook (runCellEvent, updateState, CellResultContent(..), Input(..)) where

import Data.Tuple (fst)
import Data.Maybe (maybe, Maybe(..))
import Data.Array (filter, modifyAt, (!!))
import Data.Function (on)
import Data.Date (Date(), Now(), now, toEpochMilliseconds)
import Control.Monad.Eff.Class (liftEff)
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Domain (notebookCells, addCell)
import Model.Resource (resourceName, nameL, Resource())
import Optic.Core ((..), (<>~), (%~), (+~), (.~))
import Optic.Setter (mapped, over)
import Halogen.HTML.Events.Monad (Event(), async)
import Control.Timer (Timeout())

data CellResultContent = AceContent String

data Input
  = Dropdown Number
  | CloseDropdowns
  | SetTimeout (Maybe Timeout)
  | SetName String
  | SetResource Resource
  | SetSiblings [Resource]
  | SetLoaded Boolean
  | SetError String
  | SetEditable Boolean
  | SetModalError String
  | SetAddingCell Boolean
  | AddCell CellType
  | ToggleEditorCell CellId
  | TrashCell CellId
  | RunCell CellId Date
  | CellResult CellId Date CellResultContent
  | SetActiveCell CellId
  | Copy
  | Paste
  | Cut

runCellEvent :: forall eff. CellId -> Event (now :: Now | eff) Input
runCellEvent cid = async $ RunCell cid <$> liftEff now

updateState :: State -> Input -> State

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # dropdowns %~
  (modifyAt i (\x -> x{visible = visSet})) <<<  (_{visible = false} <$>)

updateState state CloseDropdowns =
  state{addingCell = false} # dropdowns %~ (_{visible = false} <$>)

updateState state (SetTimeout mbTm) =
  state{timeout = mbTm}

updateState state (SetResource res) =
  state{resource = res, name = resourceName res}

updateState state (SetName name) =
  state{resource = state.resource # nameL .~ name}

updateState state (SetSiblings ss) =
  state{siblings = ss}

updateState state (SetLoaded loaded) =
  state{loaded = loaded}

updateState state (SetError error) =
  state{error = error}

updateState state (SetEditable editable) =
  state{editable = editable}

updateState state (SetModalError error) =
  state{modalError = error}

updateState state (SetAddingCell adding) =
  state{addingCell = adding}

updateState state (AddCell cellType) =
  state # notebook %~ (addCell cellType Nothing >>> fst)

updateState state (ToggleEditorCell cellId) =
  state # notebook..notebookCells..mapped %~ onCell cellId toggleEditor

updateState state (TrashCell cellId) =
  state # notebook..notebookCells %~ filter (not <<< isCell cellId)

updateState state (CellResult cellId date (AceContent content)) =
  let f (RunningSince d) = RunFinished $ on (-) toEpochMilliseconds date d
      f _                = RunInitial -- TODO: Cell in bad state
  in state # notebook..notebookCells..mapped %~ onCell cellId (modifyRunState f <<< setContent content)

updateState state (SetActiveCell cellId) =
  state # activeCellId .~ cellId

updateState state (RunCell cellId date) =
  state # notebook..notebookCells..mapped %~ onCell cellId (modifyRunState <<< const $ RunningSince date)

updateState state i = state

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

toggleEditor :: Cell -> Cell
toggleEditor (Cell o) = Cell $ o { hiddenEditor = not o.hiddenEditor }

setContent :: String -> Cell -> Cell
setContent content (Cell o) = Cell $ o { content = content }

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'


Add filter Query to Cytoscape

Add filter Query to Cytoscape

module Genetics.Browser.UI.Cytoscape
       where

import Prelude
import Genetics.Browser.Cytoscape as Cytoscape
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Network.HTTP.Affjax as Affjax
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Argonaut.Core (JObject)
import Data.Maybe (Maybe(..))
import Genetics.Browser.Cytoscape (CyCollection, CyElement, resize, runLayout)
import Genetics.Browser.Types (CY, Cytoscape)
import Network.HTTP.Affjax (AJAX)

-- TODO: elemsUrl should be safer. Maybe it should cache too, idk
type State = { cy :: Maybe Cytoscape
             , elemsUrl :: String
             }

data Query a
  = Initialize String a
  | Reset a
  | Filter (JObject -> Boolean) a
  | Click Cytoscape.ParsedEvent (H.SubscribeStatus -> a)

data Output
  = Clicked Cytoscape.ParsedEvent

type Effects eff = ( cy :: CY
                   , ajax :: AJAX
                   , console :: CONSOLE
                   , exception :: EXCEPTION
                   , avar :: AVAR | eff)

data Slot = Slot
derive instance eqCySlot :: Eq Slot
derive instance ordCySlot :: Ord Slot

component :: ∀ eff. H.Component HH.HTML Query Unit Output (Aff (Effects eff))
component =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = { cy: Nothing
                 , elemsUrl: ""
                 }

  -- TODO: set css here instead of pgb.html
  render :: State -> H.ComponentHTML Query
  render = const $ HH.div [ HP.ref (H.RefLabel "cy")
                          , HP.id_ "cyDiv"
                          -- , HP.prop
                          ] []

  getElements :: forall eff'. String -> Aff (ajax :: AJAX | eff') (CyCollection CyElement)
  getElements url = Affjax.get url <#> (\r -> Cytoscape.unsafeParseCollection r.response)

  getAndSetElements :: forall eff'. String -> Cytoscape -> Aff (ajax :: AJAX, cy :: CY | eff') Unit
  getAndSetElements url cy = do
    eles <- getElements url
    liftEff $ Cytoscape.coreAddCollection cy eles

  eval :: Query ~> H.ComponentDSL State Query Output (Aff (Effects eff))
  eval = case _ of
    Initialize url next -> do
      H.getHTMLElementRef (H.RefLabel "cy") >>= case _ of
        Nothing -> pure unit
        Just el' -> do
          cy <- liftEff $ Cytoscape.cytoscape el' Nothing

          liftAff $ getAndSetElements url cy

          liftEff $ do
            runLayout cy Cytoscape.circle
            resize cy

          H.subscribe $ H.eventSource (Cytoscape.onClick cy) $ Just <<< H.request <<< Click
          H.modify (_ { cy = Just cy
                      , elemsUrl = url
                      })
      pure next
    Reset next -> do
      H.gets _.cy >>= case _ of
        Nothing -> (liftEff $ log "No cytoscape found!.") *> pure unit
        Just cy -> do
          H.gets _.elemsUrl >>= case _ of
            "" -> do
              liftEff $ log "no element URL; can't reset"
              pure unit
            url -> do
              -- remove all elements
              liftEff $ Cytoscape.coreRemoveAllElements cy
              -- refetch all elements
              liftAff $ getAndSetElements url cy

              liftEff $ log $ "resetting with stored URL " <> url
              pure unit

          liftEff $ do
            runLayout cy Cytoscape.circle
            resize cy
      pure next

    Filter pred next -> do
      H.gets _.cy >>= case _ of
        Nothing -> pure unit
        Just cy -> do
          eles <- liftEff $ Cytoscape.coreFilterImpl cy pred
          _ <- liftEff $ Cytoscape.collRemoveElements eles
          pure unit
      pure next

    Click el reply -> do
      H.raise $ Clicked el
      pure $ reply H.Listening

module Genetics.Browser.UI.Cytoscape
       where

import Prelude
import Genetics.Browser.Cytoscape as Cytoscape
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Network.HTTP.Affjax as Affjax
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Maybe (Maybe(..))
import Genetics.Browser.Cytoscape (CyCollection, CyElement, resize, runLayout)
import Genetics.Browser.Types (CY, Cytoscape)
import Network.HTTP.Affjax (AJAX)

-- TODO: elemsUrl should be safer. Maybe it should cache too, idk
type State = { cy :: Maybe Cytoscape
             , elemsUrl :: String
             }

data Query a
  = Initialize String a
  | Reset a
  | Filter (Cytoscape.CyElement -> Boolean) a
  | Click Cytoscape.ParsedEvent (H.SubscribeStatus -> a)

data Output
  = Clicked Cytoscape.ParsedEvent

type Effects eff = ( cy :: CY
                   , ajax :: AJAX
                   , console :: CONSOLE
                   , exception :: EXCEPTION
                   , avar :: AVAR | eff)

data Slot = Slot
derive instance eqCySlot :: Eq Slot
derive instance ordCySlot :: Ord Slot

component :: ∀ eff. H.Component HH.HTML Query Unit Output (Aff (Effects eff))
component =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = { cy: Nothing
                 , elemsUrl: ""
                 }

  -- TODO: set css here instead of pgb.html
  render :: State -> H.ComponentHTML Query
  render = const $ HH.div [ HP.ref (H.RefLabel "cy")
                          , HP.id_ "cyDiv"
                          -- , HP.prop
                          ] []

  getElements :: forall eff'. String -> Aff (ajax :: AJAX | eff') (CyCollection CyElement)
  getElements url = Affjax.get url <#> (\r -> Cytoscape.unsafeParseCollection r.response)

  getAndSetElements :: forall eff'. String -> Cytoscape -> Aff (ajax :: AJAX, cy :: CY | eff') Unit
  getAndSetElements url cy = do
    eles <- getElements url
    liftEff $ Cytoscape.coreAddCollection cy eles

  eval :: Query ~> H.ComponentDSL State Query Output (Aff (Effects eff))
  eval = case _ of
    Initialize url next -> do
      H.getHTMLElementRef (H.RefLabel "cy") >>= case _ of
        Nothing -> pure unit
        Just el' -> do
          cy <- liftEff $ Cytoscape.cytoscape el' Nothing

          liftAff $ getAndSetElements url cy

          liftEff $ do
            runLayout cy Cytoscape.circle
            resize cy

          H.subscribe $ H.eventSource (Cytoscape.onClick cy) $ Just <<< H.request <<< Click
          H.modify (_ { cy = Just cy
                      , elemsUrl = url
                      })
      pure next
    Reset next -> do
      H.gets _.cy >>= case _ of
        Nothing -> (liftEff $ log "No cytoscape found!.") *> pure unit
        Just cy -> do
          H.gets _.elemsUrl >>= case _ of
            "" -> do
              liftEff $ log "no element URL; can't reset"
              pure unit
            url -> do
              -- remove all elements
              liftEff $ Cytoscape.coreRemoveAllElements cy
              -- refetch all elements
              liftAff $ getAndSetElements url cy

              liftEff $ log $ "resetting with stored URL " <> url
              pure unit

          liftEff $ do
            runLayout cy Cytoscape.circle
            resize cy
      pure next
    Filter pred next -> do
      pure next
    Click el reply -> do
      H.raise $ Clicked el
      pure $ reply H.Listening


Eq instance for RoutePart

Eq instance for RoutePart

module Routing.Types where

import Data.List (List)
import Data.Map (Map)
import Prelude (class Eq)

data RoutePart = Path String | Query (Map String String)

derive instance eqRoutePart :: Eq RoutePart

type Route = List RoutePart

module Routing.Types where

import Data.List (List())
import Data.Map (Map())

data RoutePart = Path String | Query (Map String String)
type Route = List RoutePart


removing redundant import

removing redundant import

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

module SlamData.GlobalMenu.Component
  ( component
  , Query(..)
  , MenuOpen(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

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

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

import Utils.DOM as DOM

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | SignOut a
  | StopPropagation DOM.Event (Query a)
  | ToggleMenu MenuOpen a

data MenuOpen
 = SignInMenu
 | HelpMenu

derive instance eqMenuOpen ∷ Eq MenuOpen

type State =
  { email ∷ Maybe String
  , loggedIn ∷ Boolean
  , menuOpen ∷ Maybe MenuOpen
  , providers ∷ Maybe (Array ProviderR)
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

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

render ∷ State → HTML
render state =
  let
    stopProp action e =
      Just $ StopPropagation (DOM.toEvent e) $ H.action action

    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    active ∷ HH.ClassName
    active = HH.ClassName "active"

    submenuItem =
      HP.classes $ HH.ClassName <$> [ "menu-item", "submenu-item" ]

    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
            [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
            , HE.onClick $ stopProp $ Authenticate $ pure provider
            ]
            [ HH.text $ "Sign in with " <> provider.displayName ]
        ]

    -- wraps stuff in `li > a`
    hitem attrs children =
      HH.li [ submenuItem ]
        [ HH.a
          ([ HP.classes $ HH.ClassName <$> [ "menu-item-link", "submenu-item-link" ] ] <> attrs)
          children
        ]

    userInfo =
      flip foldMap state.email \e →
        [ HH.div [ HP.class_ $ HH.ClassName "user-info" ] [ HH.text e ] ]

    signInMenu =
      case state.providers, state.email of
        Just ps, _ →
          [ HH.div
            [ HP.classes $ [ container, HH.ClassName "sign-in-menu-container" ] ] $
            [ HH.button
                [ HP.classes $ [ HH.ClassName "sign-in-menu-button " ]
                  <> if state.menuOpen == Just SignInMenu then [ active ] else []
                , HE.onClick $ stopProp $ ToggleMenu SignInMenu
                ]
                [ I.lockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]
        _, Just _ →
          [ HH.div
              [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
              [ HH.button
                  [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                  , HE.onClick $ stopProp $ SignOut -- Authenticate Nothing
                  ]
                  [ I.unlockSm, HH.text "Sign out" ]
              ]
          ]
        _, _ →
          []

    helpMenu =
      HH.div
        [ HP.classes $ [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
            [ HP.classes $ [ HH.ClassName "help-menu-button" ]
                <> if state.menuOpen == Just HelpMenu then [ active ] else []
            , HE.onClick $ stopProp $ ToggleMenu HelpMenu
            ]
            [ I.helpSm, HH.text "Help" ]
        ] <>
          if state.menuOpen == Just HelpMenu then
            [ submenu
              [ hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/users-guide.html" ]
                  [ HH.text "User guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/administration-guide.html" ]
                  [ HH.text "Administrator guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/developers-guide.html" ]
                  [ HH.text "Developer guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/helpful-tips.html" ]
                  [ HH.text "Helpful tips" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html" ]
                  [ HH.text "SQL² reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/slamdown-reference.html" ]
                  [ HH.text "SlamDown reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html" ]
                  [ HH.text "Troubleshooting FAQ" ]
              , HH.li [ submenuItem ]
                  [ HH.button
                      [ HP.classes $ HH.ClassName <$>
                          [ "menu-item-button", "submenu-item-button" ]
                      , HE.onClick $ stopProp $ PresentAttribution
                      ]
                      [ HH.text $ "Attribution" ]
                  ]
              ]
            ]
          else
            []

  in
    HH.div
      [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ] $
      userInfo <> signInMenu <> [ helpMenu ]

eval ∷ Query ~> DSL
eval = case _ of
  Authenticate providerR next → do
    authenticate providerR
    pure next
  DismissSubmenu next → do
    H.modify _{ menuOpen = Nothing }
    pure next
  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next
  PresentAttribution next → do
    H.modify _{ menuOpen = Nothing }
    H.raise PresentAttributionsDialog
    pure next
  SignOut next → do
    H.modify _{ email = Nothing }
    eval $ Authenticate Nothing next
  StopPropagation e q → do
    H.liftEff $ DEE.stopPropagation e
    eval q
  ToggleMenu which next → do
    menuOpen ← H.gets _.menuOpen
    let
      m = case menuOpen, which of
        Just HelpMenu, HelpMenu → Nothing
        Just SignInMenu, SignInMenu → Nothing
        _, _ → Just which
    H.modify _{ menuOpen = m }
    pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload =
    H.modify _{ loggedIn = true, email = map unwrap $ Crypt.pluckEmail payload }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    case eProviders of
      Right p → H.modify _{ providers = p }
      _ → pure unit

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

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

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

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

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

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

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

module SlamData.GlobalMenu.Component
  ( component
  , Query(..)
  , MenuOpen(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import DOM.Event.Event as DEE

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

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

import Utils.DOM as DOM

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | SignOut a
  | StopPropagation DOM.Event (Query a)
  | ToggleMenu MenuOpen a

data MenuOpen
 = SignInMenu
 | HelpMenu

derive instance eqMenuOpen ∷ Eq MenuOpen

type State =
  { email ∷ Maybe String
  , loggedIn ∷ Boolean
  , menuOpen ∷ Maybe MenuOpen
  , providers ∷ Maybe (Array ProviderR)
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

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

render ∷ State → HTML
render state =
  let
    stopProp action e =
      Just $ StopPropagation (DOM.toEvent e) $ H.action action

    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    active ∷ HH.ClassName
    active = HH.ClassName "active"

    submenuItem =
      HP.classes $ HH.ClassName <$> [ "menu-item", "submenu-item" ]

    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
            [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
            , HE.onClick $ stopProp $ Authenticate $ pure provider
            ]
            [ HH.text $ "Sign in with " <> provider.displayName ]
        ]

    -- wraps stuff in `li > a`
    hitem attrs children =
      HH.li [ submenuItem ]
        [ HH.a
          ([ HP.classes $ HH.ClassName <$> [ "menu-item-link", "submenu-item-link" ] ] <> attrs)
          children
        ]

    userInfo =
      flip foldMap state.email \e →
        [ HH.div [ HP.class_ $ HH.ClassName "user-info" ] [ HH.text e ] ]

    signInMenu =
      case state.providers, state.email of
        Just ps, _ →
          [ HH.div
            [ HP.classes $ [ container, HH.ClassName "sign-in-menu-container" ] ] $
            [ HH.button
                [ HP.classes $ [ HH.ClassName "sign-in-menu-button " ]
                  <> if state.menuOpen == Just SignInMenu then [ active ] else []
                , HE.onClick $ stopProp $ ToggleMenu SignInMenu
                ]
                [ I.lockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]
        _, Just _ →
          [ HH.div
              [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
              [ HH.button
                  [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                  , HE.onClick $ stopProp $ SignOut -- Authenticate Nothing
                  ]
                  [ I.unlockSm, HH.text "Sign out" ]
              ]
          ]
        _, _ →
          []

    helpMenu =
      HH.div
        [ HP.classes $ [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
            [ HP.classes $ [ HH.ClassName "help-menu-button" ]
                <> if state.menuOpen == Just HelpMenu then [ active ] else []
            , HE.onClick $ stopProp $ ToggleMenu HelpMenu
            ]
            [ I.helpSm, HH.text "Help" ]
        ] <>
          if state.menuOpen == Just HelpMenu then
            [ submenu
              [ hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/users-guide.html" ]
                  [ HH.text "User guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/administration-guide.html" ]
                  [ HH.text "Administrator guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/developers-guide.html" ]
                  [ HH.text "Developer guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/helpful-tips.html" ]
                  [ HH.text "Helpful tips" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html" ]
                  [ HH.text "SQL² reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/slamdown-reference.html" ]
                  [ HH.text "SlamDown reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html" ]
                  [ HH.text "Troubleshooting FAQ" ]
              , HH.li [ submenuItem ]
                  [ HH.button
                      [ HP.classes $ HH.ClassName <$>
                          [ "menu-item-button", "submenu-item-button" ]
                      , HE.onClick $ stopProp $ PresentAttribution
                      ]
                      [ HH.text $ "Attribution" ]
                  ]
              ]
            ]
          else
            []

  in
    HH.div
      [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ] $
      userInfo <> signInMenu <> [ helpMenu ]

eval ∷ Query ~> DSL
eval = case _ of
  Authenticate providerR next → do
    authenticate providerR
    pure next
  DismissSubmenu next → do
    H.modify _{ menuOpen = Nothing }
    pure next
  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next
  PresentAttribution next → do
    H.modify _{ menuOpen = Nothing }
    H.raise PresentAttributionsDialog
    pure next
  SignOut next → do
    H.modify _{ email = Nothing }
    eval $ Authenticate Nothing next
  StopPropagation e q → do
    H.liftEff $ DEE.stopPropagation e
    eval q
  ToggleMenu which next → do
    menuOpen ← H.gets _.menuOpen
    let
      m = case menuOpen, which of
        Just HelpMenu, HelpMenu → Nothing
        Just SignInMenu, SignInMenu → Nothing
        _, _ → Just which
    H.modify _{ menuOpen = m }
    pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload =
    H.modify _{ loggedIn = true, email = map unwrap $ Crypt.pluckEmail payload }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    case eProviders of
      Right p → H.modify _{ providers = p }
      _ → pure unit

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

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

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

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

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

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


Tweak test error message and type

Tweak test error message and type

module Main where

foreign import testError
  "function testError(f) {\
  \  try {\
  \    return f();\
  \  } catch (e) {\
  \    if (e instanceof Error) return 'success';\
  \    throw new Error('Pattern match failure is not Error');\
  \  }\
  \}" :: (Unit -> Number) -> String

fn :: Number -> Number
fn 0 = 0
fn 1 = 2

main = Debug.Trace.trace (show $ testError $ \_ -> fn 2)

module Main where

foreign import testError
  "function testError(f) {\
  \  try {\
  \    return f();\
  \  } catch (e) {\
  \    if (e instanceof Error) return 'success';\
  \    throw new Error('Pattern match failure is not TypeError');\
  \  }\
  \}" :: (Unit -> Number) -> Number

fn :: Number -> Number
fn 0 = 0
fn 1 = 2

main = Debug.Trace.trace (show $ testError $ \_ -> fn 2)


Fix ffi example.

Fix ffi example.

module Main where

import Control.Monad.Eff

foreign import data Random :: !

foreign import random """
  function random() {
    return Math.random();
  }""" :: forall eff. Eff (random :: Random | eff) Number

main = random >>= Debug.Trace.print

module Main where

import Control.Monad.Eff

foreign import data Random :: !

foreign import random """
  function random() {
    return Math.random();
  }""" :: Eff (random :: Random) Number

main = Debug.Trace.print <$> random


comment

comment

module Web where

import Prelude
import Data.Foldable (class Foldable, intercalate)
import Data.Unfoldable (fromMaybe)
import Data.List (List(Nil, Cons), snoc, fromFoldable, (:), singleton)
import Data.Set (intersection, size)
import Data.Set as Set
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Tuple (Tuple(..))
import Data.Traversable (for, for_)
import Data.Array as Arr
import Data.String as Str

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST (Atom(..), Binding(..), MType, Op, QualTree(..), Tree(..), TypeTree, TypedBinding, Meta(..), Index,
            Type(..), TypeQual, DataConstr(..), pPrintOp, prettyPrintType, prettyPrintTypeError, getMetaMType)

import AST as AST

data RoseTree a = Node a (List (RoseTree a))

type Div = RoseTree { content :: String, classes :: (List String), zipper :: Maybe (Tuple TypeTree (TypeTree -> TypeTree)), exprType :: MType }

type DivHole = TypeTree -> (TypeTree -> TypeTree) -> Div

type OpTuple = Tuple Op Meta

-- Tells, which nodes are to be marked as clicked or evaluated, if any.
type Highlight = { clicked :: Maybe Index, evaluated :: Maybe Index }

-- Given a Highlight value and the Meta information of a node, generated additional classes to highlight the node
highlight :: Highlight -> Meta -> List String
highlight { clicked: mi, evaluated: mj } (Meta m) = case Tuple (cmp mi) (cmp mj) of
  Tuple (Just true) (Just true) -> "clicked" : "evaluated" : Nil
  Tuple (Just true) _           -> singleton "clicked"
  Tuple _           (Just true) -> singleton "evaluated"
  _                             -> Nil
 where
   cmp = map (\i -> m.index == i)

nodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> TypeTree -> (TypeTree -> TypeTree) -> Div
nodeHole content classes children expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: Nothing
    }
    (fromFoldable children)

typedNodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> TypeTree -> (TypeTree -> TypeTree) -> Div
typedNodeHole content classes children exprType expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: exprType
    }
    (fromFoldable children)

node :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> Div
node content classes children =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: Nothing
    }
    (fromFoldable children)

typedNode :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> Div
typedNode content classes children exprType =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: exprType
    }
    (fromFoldable children)

zipList :: forall a b z. ((a -> z) -> a -> b) -> (List a -> z) -> List a -> List b
zipList zipp hole Nil = Nil
zipList zipp hole (Cons a as) = Cons (zipp (\x -> hole $ Cons x as) a) (zipList zipp (hole <<< Cons a) as)

exprToDiv:: TypeTree -> Div
exprToDiv = go id
  where
    go :: (TypeTree -> TypeTree) -> TypeTree -> Div
    go hole      (Atom meta a)            = atom (getMetaMType meta) a
    go hole expr@(List meta ls)           = case toString ls of
                                           Nothing  -> list (getMetaMType meta) (zipList go (hole <<< List meta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple meta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary meta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary meta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary meta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL meta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR meta opTuple) e) expr hole
    go hole      (PrefixOp meta opTuple)  = prefixOp (getMetaMType meta) opTuple
    go hole expr@(IfExpr meta ce te ee)   = ifexpr (getMetaMType meta)
                                           (go (\ce -> hole $ IfExpr meta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr meta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr meta ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr meta bes body)  = letexpr (getMetaMType meta)
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr meta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr meta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda meta binds) body) expr hole

    go hole expr@(ArithmSeq meta start next end)
                                       = arithmseq (getMetaMType meta)
                                           (go (\x -> hole $ ArithmSeq meta x next end) start)
                                           (go (\x -> hole $ ArithmSeq meta start (Just x) end) <$> next)
                                           (go (\x -> hole $ ArithmSeq meta start next (Just x)) <$> end)
                                           expr hole

    go hole expr@(ListComp meta e qs)     = listcomp (getMetaMType meta)
                                           (go (\x -> hole $ ListComp meta x qs) e)
                                           (zipList qualToDiv (\xs -> hole $ ListComp meta e xs) qs)
                                           expr hole
      where
        qualToDiv :: (TypeQual -> TypeTree) -> TypeQual -> Div
        qualToDiv hole (Guard meta e) = guardQual (getMetaMType meta)           (go (\x -> hole $ Guard meta x) e)
        qualToDiv hole (Let meta b e) = letQual (getMetaMType meta) (binding b) (go (\x -> hole $ Let meta b x) e)
        qualToDiv hole (Gen meta b e) = genQual (getMetaMType meta) (binding b) (go (\x -> hole $ Gen meta b x) e)

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App meta func args
        argsDivs = zipList go (hole <<< App meta func) args

guardQual :: MType -> Div -> Div
guardQual t guard = typedNode "" ["guard"] [guard] t

letQual :: MType -> Div -> Div -> Div
letQual t bind expr = typedNode "" ["let"] [letDiv, bind, eqDiv, expr] t
  where
    letDiv = node "let" ["keyword"] []
    eqDiv  = node "=" ["comma"] []

genQual :: MType -> Div -> Div -> Div
genQual t bind expr = typedNode "" ["gen"] [bind, arrow, expr] t
  where
    arrow = node "<-" ["separator"] []

atom :: MType -> Atom -> Div
atom t (AInt n) = typedNode (show n) ["atom", "num"] [] t
atom t (Bool b) = typedNode (if b then "True" else "False") ["atom", "bool"] [] t
atom t (Char c) = typedNode ("'" <> c <> "'") ["atom", "char"] [] t
atom t (Name n) = typedNode n ["atom", "name"] [] t
atom t (Constr n) = typedNode n ["atom", "name", "dataConstructor"] [] t

interleave :: forall a. a -> List a -> List a
interleave _ Nil          = Nil
interleave _ (Cons x Nil) = Cons x Nil
interleave a (Cons x xs)  = Cons x $ Cons a $ interleave a xs

listify :: String -> String -> String -> List Div -> List Div
listify b s e ls = (Cons begin (snoc (interleave sep ls) end))
  where
    begin = node b ["brace", "left"] []
    sep = node s ["separator", "comma"] []
    end = node e ["brace", "right"] []

list :: MType -> List Div -> DivHole
list t Nil = typedNodeHole "[]" ["list empty"] [] t
list t ls  = typedNodeHole "" ["list"] (listify "[" "," "]" ls) t

ntuple :: MType -> List Div -> DivHole
ntuple t ls = typedNodeHole "" ["tuple"] (listify "(" "," ")" ls) t

unpackOp :: OpTuple -> Op
unpackOp (Tuple op _) = op

opToDiv :: OpTuple -> Div
opToDiv (Tuple op (Meta meta)) = typedNode (pPrintOp op) ["op"] [] meta.mtype

binary :: MType -> OpTuple -> Div -> Div -> DivHole
binary binType op d1 d2 = typedNodeHole "" ["binary"] [d1, opToDiv op, d2] binType

openBrace :: Div
openBrace = node "(" ["brace", "left"] []

closeBrace :: Div
closeBrace = node ")" ["brace", "right"] []

unary :: MType -> OpTuple -> Div -> DivHole
unary t op div = typedNodeHole "" ["unary"] [openBrace, opToDiv op, div, closeBrace] t

sectl :: MType -> Div -> OpTuple -> DivHole
sectl t div op = typedNodeHole "" ["section"] [openBrace, div, opToDiv op, closeBrace] t

sectr :: MType -> OpTuple -> Div -> DivHole
sectr t op div = typedNodeHole "" ["section"] [openBrace, opToDiv op, div, closeBrace] t

prefixOp :: MType -> OpTuple -> Div
prefixOp binType op = typedNode "" ["prefixOp"] [openBrace, opToDiv op, closeBrace] binType

ifexpr :: MType -> Div -> Div -> Div -> DivHole
ifexpr t cd td ed = typedNodeHole "" ["if"] [ifDiv, cd, thenDiv, td, elseDiv, ed] t
  where
    ifDiv = node "if" ["keyword"] []
    thenDiv = node "then" ["keyword"] []
    elseDiv = node "else" ["keyword"] []

intersperse :: forall a. a -> List a -> List a
intersperse _ Nil          = Nil
intersperse _ (Cons a Nil) = Cons a Nil
intersperse s (Cons a as)  = Cons a $ Cons s $ intersperse s as

letexpr :: MType -> List (Tuple Div Div) -> Div -> DivHole
letexpr t binds expr = typedNodeHole "" ["letexpr"] ([letDiv] <> (intercalate [semi] (bind <$> binds)) <> [inDiv, expr]) t
  where
    letDiv = node "let" ["keyword"] []
    inDiv  = node "in" ["keyword"] []
    semi   = node ";" ["comma"] []
    equal  = node "=" ["comma"] []
    bind :: Tuple Div Div -> Array Div
    bind (Tuple b e) = [node "" [] [b, equal, e]]

listcomp :: MType -> Div -> List Div -> DivHole
listcomp t expr quals = typedNodeHole "" ["listcomp", "list"] ([open, expr, pipe] <> Arr.fromFoldable (intersperse comma quals) <> [close]) t
  where
    open  = node "[" ["brace", "left"] []
    close = node "]" ["brace", "right"] []
    pipe  = node "|" ["brace"] []
    comma = node "," ["comma"] []

lambda :: MType -> List Div -> Div -> DivHole
lambda t params body = typedNodeHole "" ["lambda"] (open : bslash : params <> (arrow : body : close : Nil)) t
  where
    open = node "(" ["brace", "left"] []
    bslash = node "\\" ["backslash", "separator"] []
    arrow = node "->" ["arrow", "separator"] []
    close = node ")" ["brace", "right"] []

app :: MType -> Div -> List Div -> DivHole
app t func args = typedNodeHole "" ["app"] (Cons func args) t

arithmseq :: MType -> Div -> Maybe Div -> Maybe Div -> DivHole
arithmseq t start mnext mend = typedNodeHole "" ["arithmseq", "list"] ([open, start] <> commaNext <> [dots] <> end <> [close]) t
 where
    open      = node "[" ["brace", "left"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots", "comma"] []
    end       = fromMaybe mend
    close     = node "]" ["brace", "right"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom (getMetaMType t) a] (getMetaMType t)
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) (getMetaMType t)
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) (getMetaMType t)
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) (getMetaMType t)
binding (ConstrLit t constr) = case constr of
  PrefixDataConstr name _ ls -> typedNode ""
                                  ["binding", "constrlit"]
                                  (atom (getMetaMType t) (Name name) : (binding <$> ls))
                                  (getMetaMType t)
  InfixDataConstr name _ _ b1 b2 -> typedNode ""
                                      ["binding", "constrlit"]
                                      [binding b1, atom (getMetaMType t) (Name name), binding b2]
                                      (getMetaMType t)

type Callback = forall eff. TypeTree -> (TypeTree -> TypeTree) -> (J.JQueryEvent -> J.JQuery -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit)

-- | Create a type div with the pretty printed type as content.
createTypeDiv :: forall eff. MType -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
createTypeDiv (Just (TypeError typeError)) = makeDiv (prettyPrintTypeError typeError) ["typeContainer", "hasTypeError"]
createTypeDiv mType = makeDiv (" :: " <> maybe "" prettyPrintType mType) ["typeContainer"]

-- | Add a type tooltip to the given div.
addTypeTooltip :: forall eff. MType -> J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
addTypeTooltip (Just (TypeError typeError)) div = J.setAttr "title" (prettyPrintTypeError typeError) div
addTypeTooltip mType div = J.setAttr "title" (" :: " <> maybe "" prettyPrintType mType) div

-- | Return true, if the first list of classes contains a class from the second list.
oneOfClasses :: forall f1 f2. (Foldable f1, Foldable f2) => f1 String -> f2 String -> Boolean
oneOfClasses cs1 cs2 = size (set1 `intersection` set2) > 0
  where
  set1 = Set.fromFoldable cs1
  set2 = Set.fromFoldable cs2

-- | Given a list of classes as well as the expression type determine if the expression should have
-- | a type div.
needsTypeContainer :: forall f. Foldable f => f String -> MType -> Boolean
needsTypeContainer _ Nothing = false
needsTypeContainer classes (Just t) = decideByClass classes && decideByType t
    where
    decideByType _ = true
    decideByClass classes = if oneOfClasses ["op", "binding", "num", "char", "bool", "gen", "guard", "let"] classes then false else true

-- | Return true if the given `MType` represents a type error.
isTypeError :: MType -> Boolean
isTypeError (Just (TypeError _)) = true
isTypeError _ = false

divToJQuery :: forall eff. Boolean -> Callback -> Div -> Eff (dom :: DOM, console :: CONSOLE | eff) J.JQuery
divToJQuery isTopLevelDiv callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  let needsContainer = needsTypeContainer classes exprType || isTopLevelDiv || isTypeError exprType
  let isTyped = isJust exprType

  container <- makeDiv "" ["container"]
  div <- makeDiv content classes

  -- if needsContainer
  --   then do
  --     typeDiv <- createTypeDiv exprType
  --     J.append typeDiv container
  --     J.append div container
  --     J.addClass "hasTypeContainer" div
  --   else pure unit

  J.append div container

  -- if isTyped
  --   then addTypeTooltip exprType div
  --   else pure unit

  for children (divToJQuery false callback >=> flip J.append div)
  case zipper of
    Nothing                -> pure unit
    Just (Tuple expr hole) -> do
      J.on "click" (callback expr hole) div
      J.on "mouseover" (callback expr hole) div
      J.on "mouseout" (callback expr hole) div
      pure unit

  if needsContainer
    then pure container
    else pure div

toString :: List TypeTree -> Maybe String
toString ls = Str.fromCharArray <$> go [] ls
  where
    go :: Array Char -> List TypeTree -> Maybe (Array Char)
    go acc (Cons (Atom _ (Char c)) rs) = case Str.toChar c of
                                           Just char -> go (Arr.snoc acc char) rs
                                           Nothing   -> Nothing
    go []  Nil                         = Nothing
    go acc Nil                         = Just acc
    go _   _                           = Nothing

type Class = String

makeDiv :: forall f eff. Foldable f => String -> f Class -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for_ classes (flip J.addClass d)
  pure d

module Web where

import Prelude
import Data.Foldable (class Foldable, intercalate)
import Data.Unfoldable (fromMaybe)
import Data.List (List(Nil, Cons), snoc, fromFoldable, (:), singleton)
import Data.Set (intersection, size)
import Data.Set as Set
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Tuple (Tuple(..))
import Data.Traversable (for, for_)
import Data.Array as Arr
import Data.String as Str

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST (Atom(..), Binding(..), MType, Op, QualTree(..), Tree(..), TypeTree, TypedBinding, Meta(..), Index,
            Type(..), TypeQual, DataConstr(..), pPrintOp, prettyPrintType, prettyPrintTypeError, getMetaMType)

import AST as AST

data RoseTree a = Node a (List (RoseTree a))

type Div = RoseTree { content :: String, classes :: (List String), zipper :: Maybe (Tuple TypeTree (TypeTree -> TypeTree)), exprType :: MType }

type DivHole = TypeTree -> (TypeTree -> TypeTree) -> Div

type OpTuple = Tuple Op Meta

-- Tells, which nodes are to be marked as clicked or evaluated, if any.
type Highlight = { clicked :: Maybe Index, evaluated :: Maybe Index }

highlight :: Highlight -> Meta -> List String
highlight { clicked: mi, evaluated: mj } (Meta m) = case Tuple (cmp mi) (cmp mj) of
  Tuple (Just true) (Just true) -> "clicked" : "evaluated" : Nil
  Tuple (Just true) _           -> singleton "clicked"
  Tuple _           (Just true) -> singleton "evaluated"
  _                             -> Nil
 where
   cmp = map (\i -> m.index == i)

nodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> TypeTree -> (TypeTree -> TypeTree) -> Div
nodeHole content classes children expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: Nothing
    }
    (fromFoldable children)

typedNodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> TypeTree -> (TypeTree -> TypeTree) -> Div
typedNodeHole content classes children exprType expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: exprType
    }
    (fromFoldable children)

node :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> Div
node content classes children =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: Nothing
    }
    (fromFoldable children)

typedNode :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> Div
typedNode content classes children exprType =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: exprType
    }
    (fromFoldable children)

zipList :: forall a b z. ((a -> z) -> a -> b) -> (List a -> z) -> List a -> List b
zipList zipp hole Nil = Nil
zipList zipp hole (Cons a as) = Cons (zipp (\x -> hole $ Cons x as) a) (zipList zipp (hole <<< Cons a) as)

exprToDiv:: TypeTree -> Div
exprToDiv = go id
  where
    go :: (TypeTree -> TypeTree) -> TypeTree -> Div
    go hole      (Atom meta a)            = atom (getMetaMType meta) a
    go hole expr@(List meta ls)           = case toString ls of
                                           Nothing  -> list (getMetaMType meta) (zipList go (hole <<< List meta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple meta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary meta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary meta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary meta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL meta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR meta opTuple) e) expr hole
    go hole      (PrefixOp meta opTuple)  = prefixOp (getMetaMType meta) opTuple
    go hole expr@(IfExpr meta ce te ee)   = ifexpr (getMetaMType meta)
                                           (go (\ce -> hole $ IfExpr meta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr meta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr meta ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr meta bes body)  = letexpr (getMetaMType meta)
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr meta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr meta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda meta binds) body) expr hole

    go hole expr@(ArithmSeq meta start next end)
                                       = arithmseq (getMetaMType meta)
                                           (go (\x -> hole $ ArithmSeq meta x next end) start)
                                           (go (\x -> hole $ ArithmSeq meta start (Just x) end) <$> next)
                                           (go (\x -> hole $ ArithmSeq meta start next (Just x)) <$> end)
                                           expr hole

    go hole expr@(ListComp meta e qs)     = listcomp (getMetaMType meta)
                                           (go (\x -> hole $ ListComp meta x qs) e)
                                           (zipList qualToDiv (\xs -> hole $ ListComp meta e xs) qs)
                                           expr hole
      where
        qualToDiv :: (TypeQual -> TypeTree) -> TypeQual -> Div
        qualToDiv hole (Guard meta e) = guardQual (getMetaMType meta)           (go (\x -> hole $ Guard meta x) e)
        qualToDiv hole (Let meta b e) = letQual (getMetaMType meta) (binding b) (go (\x -> hole $ Let meta b x) e)
        qualToDiv hole (Gen meta b e) = genQual (getMetaMType meta) (binding b) (go (\x -> hole $ Gen meta b x) e)

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App meta func args
        argsDivs = zipList go (hole <<< App meta func) args

guardQual :: MType -> Div -> Div
guardQual t guard = typedNode "" ["guard"] [guard] t

letQual :: MType -> Div -> Div -> Div
letQual t bind expr = typedNode "" ["let"] [letDiv, bind, eqDiv, expr] t
  where
    letDiv = node "let" ["keyword"] []
    eqDiv  = node "=" ["comma"] []

genQual :: MType -> Div -> Div -> Div
genQual t bind expr = typedNode "" ["gen"] [bind, arrow, expr] t
  where
    arrow = node "<-" ["separator"] []

atom :: MType -> Atom -> Div
atom t (AInt n) = typedNode (show n) ["atom", "num"] [] t
atom t (Bool b) = typedNode (if b then "True" else "False") ["atom", "bool"] [] t
atom t (Char c) = typedNode ("'" <> c <> "'") ["atom", "char"] [] t
atom t (Name n) = typedNode n ["atom", "name"] [] t
atom t (Constr n) = typedNode n ["atom", "name", "dataConstructor"] [] t

interleave :: forall a. a -> List a -> List a
interleave _ Nil          = Nil
interleave _ (Cons x Nil) = Cons x Nil
interleave a (Cons x xs)  = Cons x $ Cons a $ interleave a xs

listify :: String -> String -> String -> List Div -> List Div
listify b s e ls = (Cons begin (snoc (interleave sep ls) end))
  where
    begin = node b ["brace", "left"] []
    sep = node s ["separator", "comma"] []
    end = node e ["brace", "right"] []

list :: MType -> List Div -> DivHole
list t Nil = typedNodeHole "[]" ["list empty"] [] t
list t ls  = typedNodeHole "" ["list"] (listify "[" "," "]" ls) t

ntuple :: MType -> List Div -> DivHole
ntuple t ls = typedNodeHole "" ["tuple"] (listify "(" "," ")" ls) t

unpackOp :: OpTuple -> Op
unpackOp (Tuple op _) = op

opToDiv :: OpTuple -> Div
opToDiv (Tuple op (Meta meta)) = typedNode (pPrintOp op) ["op"] [] meta.mtype

binary :: MType -> OpTuple -> Div -> Div -> DivHole
binary binType op d1 d2 = typedNodeHole "" ["binary"] [d1, opToDiv op, d2] binType

openBrace :: Div
openBrace = node "(" ["brace", "left"] []

closeBrace :: Div
closeBrace = node ")" ["brace", "right"] []

unary :: MType -> OpTuple -> Div -> DivHole
unary t op div = typedNodeHole "" ["unary"] [openBrace, opToDiv op, div, closeBrace] t

sectl :: MType -> Div -> OpTuple -> DivHole
sectl t div op = typedNodeHole "" ["section"] [openBrace, div, opToDiv op, closeBrace] t

sectr :: MType -> OpTuple -> Div -> DivHole
sectr t op div = typedNodeHole "" ["section"] [openBrace, opToDiv op, div, closeBrace] t

prefixOp :: MType -> OpTuple -> Div
prefixOp binType op = typedNode "" ["prefixOp"] [openBrace, opToDiv op, closeBrace] binType

ifexpr :: MType -> Div -> Div -> Div -> DivHole
ifexpr t cd td ed = typedNodeHole "" ["if"] [ifDiv, cd, thenDiv, td, elseDiv, ed] t
  where
    ifDiv = node "if" ["keyword"] []
    thenDiv = node "then" ["keyword"] []
    elseDiv = node "else" ["keyword"] []

intersperse :: forall a. a -> List a -> List a
intersperse _ Nil          = Nil
intersperse _ (Cons a Nil) = Cons a Nil
intersperse s (Cons a as)  = Cons a $ Cons s $ intersperse s as

letexpr :: MType -> List (Tuple Div Div) -> Div -> DivHole
letexpr t binds expr = typedNodeHole "" ["letexpr"] ([letDiv] <> (intercalate [semi] (bind <$> binds)) <> [inDiv, expr]) t
  where
    letDiv = node "let" ["keyword"] []
    inDiv  = node "in" ["keyword"] []
    semi   = node ";" ["comma"] []
    equal  = node "=" ["comma"] []
    bind :: Tuple Div Div -> Array Div
    bind (Tuple b e) = [node "" [] [b, equal, e]]

listcomp :: MType -> Div -> List Div -> DivHole
listcomp t expr quals = typedNodeHole "" ["listcomp", "list"] ([open, expr, pipe] <> Arr.fromFoldable (intersperse comma quals) <> [close]) t
  where
    open  = node "[" ["brace", "left"] []
    close = node "]" ["brace", "right"] []
    pipe  = node "|" ["brace"] []
    comma = node "," ["comma"] []

lambda :: MType -> List Div -> Div -> DivHole
lambda t params body = typedNodeHole "" ["lambda"] (open : bslash : params <> (arrow : body : close : Nil)) t
  where
    open = node "(" ["brace", "left"] []
    bslash = node "\\" ["backslash", "separator"] []
    arrow = node "->" ["arrow", "separator"] []
    close = node ")" ["brace", "right"] []

app :: MType -> Div -> List Div -> DivHole
app t func args = typedNodeHole "" ["app"] (Cons func args) t

arithmseq :: MType -> Div -> Maybe Div -> Maybe Div -> DivHole
arithmseq t start mnext mend = typedNodeHole "" ["arithmseq", "list"] ([open, start] <> commaNext <> [dots] <> end <> [close]) t
 where
    open      = node "[" ["brace", "left"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots", "comma"] []
    end       = fromMaybe mend
    close     = node "]" ["brace", "right"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom (getMetaMType t) a] (getMetaMType t)
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) (getMetaMType t)
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) (getMetaMType t)
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) (getMetaMType t)
binding (ConstrLit t constr) = case constr of
  PrefixDataConstr name _ ls -> typedNode ""
                                  ["binding", "constrlit"]
                                  (atom (getMetaMType t) (Name name) : (binding <$> ls))
                                  (getMetaMType t)
  InfixDataConstr name _ _ b1 b2 -> typedNode ""
                                      ["binding", "constrlit"]
                                      [binding b1, atom (getMetaMType t) (Name name), binding b2]
                                      (getMetaMType t)

type Callback = forall eff. TypeTree -> (TypeTree -> TypeTree) -> (J.JQueryEvent -> J.JQuery -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit)

-- | Create a type div with the pretty printed type as content.
createTypeDiv :: forall eff. MType -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
createTypeDiv (Just (TypeError typeError)) = makeDiv (prettyPrintTypeError typeError) ["typeContainer", "hasTypeError"]
createTypeDiv mType = makeDiv (" :: " <> maybe "" prettyPrintType mType) ["typeContainer"]

-- | Add a type tooltip to the given div.
addTypeTooltip :: forall eff. MType -> J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
addTypeTooltip (Just (TypeError typeError)) div = J.setAttr "title" (prettyPrintTypeError typeError) div
addTypeTooltip mType div = J.setAttr "title" (" :: " <> maybe "" prettyPrintType mType) div

-- | Return true, if the first list of classes contains a class from the second list.
oneOfClasses :: forall f1 f2. (Foldable f1, Foldable f2) => f1 String -> f2 String -> Boolean
oneOfClasses cs1 cs2 = size (set1 `intersection` set2) > 0
  where
  set1 = Set.fromFoldable cs1
  set2 = Set.fromFoldable cs2

-- | Given a list of classes as well as the expression type determine if the expression should have
-- | a type div.
needsTypeContainer :: forall f. Foldable f => f String -> MType -> Boolean
needsTypeContainer _ Nothing = false
needsTypeContainer classes (Just t) = decideByClass classes && decideByType t
    where
    decideByType _ = true
    decideByClass classes = if oneOfClasses ["op", "binding", "num", "char", "bool", "gen", "guard", "let"] classes then false else true

-- | Return true if the given `MType` represents a type error.
isTypeError :: MType -> Boolean
isTypeError (Just (TypeError _)) = true
isTypeError _ = false

divToJQuery :: forall eff. Boolean -> Callback -> Div -> Eff (dom :: DOM, console :: CONSOLE | eff) J.JQuery
divToJQuery isTopLevelDiv callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  let needsContainer = needsTypeContainer classes exprType || isTopLevelDiv || isTypeError exprType
  let isTyped = isJust exprType

  container <- makeDiv "" ["container"]
  div <- makeDiv content classes

  -- if needsContainer
  --   then do
  --     typeDiv <- createTypeDiv exprType
  --     J.append typeDiv container
  --     J.append div container
  --     J.addClass "hasTypeContainer" div
  --   else pure unit

  J.append div container

  -- if isTyped
  --   then addTypeTooltip exprType div
  --   else pure unit

  for children (divToJQuery false callback >=> flip J.append div)
  case zipper of
    Nothing                -> pure unit
    Just (Tuple expr hole) -> do
      J.on "click" (callback expr hole) div
      J.on "mouseover" (callback expr hole) div
      J.on "mouseout" (callback expr hole) div
      pure unit

  if needsContainer
    then pure container
    else pure div

toString :: List TypeTree -> Maybe String
toString ls = Str.fromCharArray <$> go [] ls
  where
    go :: Array Char -> List TypeTree -> Maybe (Array Char)
    go acc (Cons (Atom _ (Char c)) rs) = case Str.toChar c of
                                           Just char -> go (Arr.snoc acc char) rs
                                           Nothing   -> Nothing
    go []  Nil                         = Nothing
    go acc Nil                         = Just acc
    go _   _                           = Nothing

type Class = String

makeDiv :: forall f eff. Foldable f => String -> f Class -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for_ classes (flip J.addClass d)
  pure d