Restore cheap implementation of `coeRender`

module Halogen.Component
  ( Component
  , Component'
  , mkComponent
  , unComponent
  , ComponentSpec
  , ComponentHTML
  , ComponentDSL
  , component
  , LifecycleComponentSpec
  , lifecycleComponent
  , ParentComponentSpec
  , parentComponent
  , ParentHTML
  , ParentDSL
  , ParentLifecycleComponentSpec
  , lifecycleParentComponent
  , hoist
  , ComponentSlot
  , mkComponentSlot
  , unComponentSlot
  , hoistSlot
  ) where

import Prelude

import Data.Bifunctor (class Bifunctor, lmap)
import Data.Const (Const)
import Data.Maybe (Maybe(..))

import Halogen.Data.OrdBox (OrdBox, mkOrdBox)
import Halogen.HTML.Core (HTML)
import Halogen.Query.HalogenM (HalogenM)
import Halogen.Query.HalogenM as HM

import Unsafe.Coerce (unsafeCoerce)

-- | The "public" type for a component, with details of the component internals
-- | existentially hidden.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `f` is the query algebra
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
data Component (h :: * -> * -> *) (f :: * -> *) i o (m :: * -> *)

-- | Makes a `Component` from a `Component'`, existentially hiding details about
-- | the component's state and potential children.
mkComponent
  :: forall h s f g p i o m
   . Component' h s f g p i o m
  -> Component h f i o m
mkComponent = unsafeCoerce

-- | Exposes the inner details of a component to a function to produce a new
-- | result. The inner details will not be allowed to be revealed in the result
-- | of the function - the compiler will complain about an escaped skolem.
unComponent
  :: forall h f i o m r
   . (forall s g p. Component' h s f g p i o m -> r)
  -> Component h f i o m
  -> r
unComponent = unsafeCoerce

-- | The "private" type for a component.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra for the component itself
-- | - `g` is the query algebra for child components
-- | - `p` is the slot type for addressing child components
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type Component' h s f g p i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h g m p (f Unit)) (f Unit)
  , eval :: f ~> HalogenM s f g p o m
  , receiver :: i -> Maybe (f Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  , mkOrdBox :: p -> OrdBox p
  }

-- | A spec for a component with no possible children.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type ComponentSpec h s f i o m =
  { initialState :: i -> s
  , render :: s -> h Void (f Unit)
  , eval :: f ~> ComponentDSL s f o m
  , receiver :: i -> Maybe (f Unit)
  }

-- | A convenience synonym for the output type of a `render` function, for a
-- | childless component that renders HTML.
type ComponentHTML f = HTML Void (f Unit)

-- | A synonym for `HalogenM` with some type parameters populated that are not
-- | relevant for childless components.
type ComponentDSL s f = HalogenM s f (Const Void) Void

-- | Builds a component with no possible children.
component
  :: forall h s f i o m
   . Bifunctor h
  => ComponentSpec h s f i o m
  -> Component h f i o m
component spec =
  lifecycleComponent
    { initialState: spec.initialState
    , render: spec.render
    , eval: spec.eval
    , receiver: spec.receiver
    , initializer: Nothing
    , finalizer: Nothing
    }

-- | A spec for a component with no possible children, including lifecycle
-- | inputs.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type LifecycleComponentSpec h s f i o m =
  { initialState :: i -> s
  , render :: s -> h Void (f Unit)
  , eval :: f ~> ComponentDSL s f o m
  , receiver :: i -> Maybe (f Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component with lifecycle inputs and no possible children.
lifecycleComponent
  :: forall h s f i o m
   . Bifunctor h
  => LifecycleComponentSpec h s f i o m
  -> Component h f i o m
lifecycleComponent spec =
  mkComponent
    { initialState: spec.initialState
    , render: coeRender spec.render
    , eval: spec.eval
    , receiver: spec.receiver
    , initializer: spec.initializer
    , finalizer: spec.finalizer
    , mkOrdBox
    }
  where
  coeRender
    :: (s -> h Void (f Unit))
    -> s
    -> h (ComponentSlot h (Const Void) m Void (f Unit)) (f Unit)
  coeRender = unsafeCoerce -- ≅ map (lmap absurd)

-- | A spec for a component.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra for the component itself
-- | - `g` is the query algebra for child components
-- | - `p` is the slot type for addressing child components
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type ParentComponentSpec h s f g p i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h g m p (f Unit)) (f Unit)
  , eval :: f ~> HalogenM s f g p o m
  , receiver :: i -> Maybe (f Unit)
  }

-- | A convenience synonym for the output type of a `render` function, for a
-- | parent component that renders HTML.
type ParentHTML f g p m = HTML (ComponentSlot HTML g m p (f Unit)) (f Unit)

-- | A synonym for just `HalogenM`. Provided for consistency with `ComponentDSL`
-- | in the non-parent-component case.
type ParentDSL = HalogenM

-- | Builds a component that allows for children.
parentComponent
  :: forall h s f g p i o m
   . Ord p
  => ParentComponentSpec h s f g p i o m
  -> Component h f i o m
parentComponent spec =
  mkComponent
    { initialState: spec.initialState
    , render: spec.render
    , eval: spec.eval
    , receiver: spec.receiver
    , initializer: Nothing
    , finalizer: Nothing
    , mkOrdBox
    }

-- | A spec for a parent component, including lifecycle inputs.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra for the component itself
-- | - `g` is the query algebra for child components
-- | - `p` is the slot type for addressing child components
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type ParentLifecycleComponentSpec h s f g p i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h g m p (f Unit)) (f Unit)
  , eval :: f ~> HalogenM s f g p o m
  , receiver :: i -> Maybe (f Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component with lifecycle inputs that allows for children.
lifecycleParentComponent
  :: forall h s f g p i o m
   . Ord p
  => ParentLifecycleComponentSpec h s f g p i o m
  -> Component h f i o m
lifecycleParentComponent spec =
  mkComponent
    { initialState: spec.initialState
    , render: spec.render
    , eval: spec.eval
    , receiver: spec.receiver
    , initializer: spec.initializer
    , finalizer: spec.finalizer
    , mkOrdBox
    }

-- | Changes the component's `m` type. A use case for this would be to interpret
-- | some `Free` monad as `Aff` so the component can be used with `runUI`.
hoist
  :: forall h f i o m m'
   . (Bifunctor h, Functor m')
  => (m ~> m')
  -> Component h f i o m
  -> Component h f i o m'
hoist nat =
  unComponent \c ->
    mkComponent
      { initialState: c.initialState
      , render: lmap (hoistSlot nat) <<< c.render
      , eval: HM.hoist nat <<< c.eval
      , receiver: c.receiver
      , initializer: c.initializer
      , finalizer: c.finalizer
      , mkOrdBox: c.mkOrdBox
      }

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

data ComponentSlot' h z g m p j q o = ComponentSlot p (Component h z j o m) j (j -> Maybe (g Unit)) (o -> Maybe q) (forall x. g x -> Maybe (z x))

data ComponentSlot (h :: * -> * -> *) (g :: * -> *) (m :: * -> *) p q

instance bifunctorSlotF :: Bifunctor (ComponentSlot h g m) where
  bimap f g = unComponentSlot \p ctor input inputQuery outputQuery projQuery ->
    mkComponentSlot (f p) ctor input inputQuery (map g <<< outputQuery) projQuery

instance functorSlotF :: Functor (ComponentSlot h g m p) where
  map f = unComponentSlot \p ctor j g h i ->
    mkComponentSlot p ctor j g (map f <<< h) i

mkComponentSlot
  :: forall h g z m p j q o
   . p
  -> (Component h z j o m)
  -> j
  -> (j -> Maybe (g Unit))
  -> (o -> Maybe q)
  -> (forall x. g x -> Maybe (z x))
  -> ComponentSlot h g m p q
mkComponentSlot = unsafeCoerce ComponentSlot

unComponentSlot
  :: forall h g m p q r
   . (forall z j o. p -> Component h z j o m -> j -> (j -> Maybe (g Unit)) -> (o -> Maybe q) -> (forall x. g x -> Maybe (z x)) -> r)
  -> ComponentSlot h g m p q
  -> r
unComponentSlot f cs =
  case unsafeCoerce cs of
    ComponentSlot p ctor input inputQuery outputQuery projQuery ->
      f p ctor input inputQuery outputQuery projQuery

hoistSlot
  :: forall h g m m' p q
   . (Bifunctor h, Functor m')
  => (m ~> m')
  -> ComponentSlot h g m p q
  -> ComponentSlot h g m' p q
hoistSlot nat = unComponentSlot \p ctor input inputQuery outputQuery projQuery ->
  mkComponentSlot p (hoist nat ctor) input inputQuery outputQuery projQuery

module Halogen.Component
  ( Component
  , Component'
  , mkComponent
  , unComponent
  , ComponentSpec
  , ComponentHTML
  , ComponentDSL
  , component
  , LifecycleComponentSpec
  , lifecycleComponent
  , ParentComponentSpec
  , parentComponent
  , ParentHTML
  , ParentDSL
  , ParentLifecycleComponentSpec
  , lifecycleParentComponent
  , hoist
  , ComponentSlot
  , mkComponentSlot
  , unComponentSlot
  , hoistSlot
  ) where

import Prelude

import Data.Bifunctor (class Bifunctor, lmap)
import Data.Const (Const)
import Data.Maybe (Maybe(..))

import Halogen.Data.OrdBox (OrdBox, mkOrdBox)
import Halogen.HTML.Core (HTML)
import Halogen.Query.HalogenM (HalogenM)
import Halogen.Query.HalogenM as HM

import Unsafe.Coerce (unsafeCoerce)

-- | The "public" type for a component, with details of the component internals
-- | existentially hidden.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `f` is the query algebra
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
data Component (h :: * -> * -> *) (f :: * -> *) i o (m :: * -> *)

-- | Makes a `Component` from a `Component'`, existentially hiding details about
-- | the component's state and potential children.
mkComponent
  :: forall h s f g p i o m
   . Component' h s f g p i o m
  -> Component h f i o m
mkComponent = unsafeCoerce

-- | Exposes the inner details of a component to a function to produce a new
-- | result. The inner details will not be allowed to be revealed in the result
-- | of the function - the compiler will complain about an escaped skolem.
unComponent
  :: forall h f i o m r
   . (forall s g p. Component' h s f g p i o m -> r)
  -> Component h f i o m
  -> r
unComponent = unsafeCoerce

-- | The "private" type for a component.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra for the component itself
-- | - `g` is the query algebra for child components
-- | - `p` is the slot type for addressing child components
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type Component' h s f g p i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h g m p (f Unit)) (f Unit)
  , eval :: f ~> HalogenM s f g p o m
  , receiver :: i -> Maybe (f Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  , mkOrdBox :: p -> OrdBox p
  }

-- | A spec for a component with no possible children.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type ComponentSpec h s f i o m =
  { initialState :: i -> s
  , render :: s -> h Void (f Unit)
  , eval :: f ~> ComponentDSL s f o m
  , receiver :: i -> Maybe (f Unit)
  }

-- | A convenience synonym for the output type of a `render` function, for a
-- | childless component that renders HTML.
type ComponentHTML f = HTML Void (f Unit)

-- | A synonym for `HalogenM` with some type parameters populated that are not
-- | relevant for childless components.
type ComponentDSL s f = HalogenM s f (Const Void) Void

-- | Builds a component with no possible children.
component
  :: forall h s f i o m
   . Bifunctor h
  => ComponentSpec h s f i o m
  -> Component h f i o m
component spec =
  lifecycleComponent
    { initialState: spec.initialState
    , render: spec.render
    , eval: spec.eval
    , receiver: spec.receiver
    , initializer: Nothing
    , finalizer: Nothing
    }

-- | A spec for a component with no possible children, including lifecycle
-- | inputs.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra
-- | - `i` is the input value type that will be mapped to an `f` whenever the
-- |       parent of this component renders
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type LifecycleComponentSpec h s f i o m =
  { initialState :: i -> s
  , render :: s -> h Void (f Unit)
  , eval :: f ~> ComponentDSL s f o m
  , receiver :: i -> Maybe (f Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component with lifecycle inputs and no possible children.
lifecycleComponent
  :: forall h s f i o m
   . Bifunctor h
  => LifecycleComponentSpec h s f i o m
  -> Component h f i o m
lifecycleComponent spec =
  mkComponent
    { initialState: spec.initialState
    , render: coeRender spec.render
    , eval: spec.eval
    , receiver: spec.receiver
    , initializer: spec.initializer
    , finalizer: spec.finalizer
    , mkOrdBox
    }
  where
  coeRender
    :: (s -> h Void (f Unit))
    -> s
    -> h (ComponentSlot h (Const Void) m Void (f Unit)) (f Unit)
  coeRender = map (lmap absurd) -- unsafeCoerce -- ≅ map (lmap absurd id)

-- | A spec for a component.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra for the component itself
-- | - `g` is the query algebra for child components
-- | - `p` is the slot type for addressing child components
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type ParentComponentSpec h s f g p i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h g m p (f Unit)) (f Unit)
  , eval :: f ~> HalogenM s f g p o m
  , receiver :: i -> Maybe (f Unit)
  }

-- | A convenience synonym for the output type of a `render` function, for a
-- | parent component that renders HTML.
type ParentHTML f g p m = HTML (ComponentSlot HTML g m p (f Unit)) (f Unit)

-- | A synonym for just `HalogenM`. Provided for consistency with `ComponentDSL`
-- | in the non-parent-component case.
type ParentDSL = HalogenM

-- | Builds a component that allows for children.
parentComponent
  :: forall h s f g p i o m
   . Ord p
  => ParentComponentSpec h s f g p i o m
  -> Component h f i o m
parentComponent spec =
  mkComponent
    { initialState: spec.initialState
    , render: spec.render
    , eval: spec.eval
    , receiver: spec.receiver
    , initializer: Nothing
    , finalizer: Nothing
    , mkOrdBox
    }

-- | A spec for a parent component, including lifecycle inputs.
-- |
-- | - `h` is the type that will be rendered by the component, usually `HTML`
-- | - `s` is the component's state
-- | - `f` is the query algebra for the component itself
-- | - `g` is the query algebra for child components
-- | - `p` is the slot type for addressing child components
-- | - `o` is the type for the component's output messages
-- | - `m` is the monad used for non-component-state effects
type ParentLifecycleComponentSpec h s f g p i o m =
  { initialState :: i -> s
  , render :: s -> h (ComponentSlot h g m p (f Unit)) (f Unit)
  , eval :: f ~> HalogenM s f g p o m
  , receiver :: i -> Maybe (f Unit)
  , initializer :: Maybe (f Unit)
  , finalizer :: Maybe (f Unit)
  }

-- | Builds a component with lifecycle inputs that allows for children.
lifecycleParentComponent
  :: forall h s f g p i o m
   . Ord p
  => ParentLifecycleComponentSpec h s f g p i o m
  -> Component h f i o m
lifecycleParentComponent spec =
  mkComponent
    { initialState: spec.initialState
    , render: spec.render
    , eval: spec.eval
    , receiver: spec.receiver
    , initializer: spec.initializer
    , finalizer: spec.finalizer
    , mkOrdBox
    }

-- | Changes the component's `m` type. A use case for this would be to interpret
-- | some `Free` monad as `Aff` so the component can be used with `runUI`.
hoist
  :: forall h f i o m m'
   . (Bifunctor h, Functor m')
  => (m ~> m')
  -> Component h f i o m
  -> Component h f i o m'
hoist nat =
  unComponent \c ->
    mkComponent
      { initialState: c.initialState
      , render: lmap (hoistSlot nat) <<< c.render
      , eval: HM.hoist nat <<< c.eval
      , receiver: c.receiver
      , initializer: c.initializer
      , finalizer: c.finalizer
      , mkOrdBox: c.mkOrdBox
      }

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

data ComponentSlot' h z g m p j q o = ComponentSlot p (Component h z j o m) j (j -> Maybe (g Unit)) (o -> Maybe q) (forall x. g x -> Maybe (z x))

data ComponentSlot (h :: * -> * -> *) (g :: * -> *) (m :: * -> *) p q

instance bifunctorSlotF :: Bifunctor (ComponentSlot h g m) where
  bimap f g = unComponentSlot \p ctor input inputQuery outputQuery projQuery ->
    mkComponentSlot (f p) ctor input inputQuery (map g <<< outputQuery) projQuery

instance functorSlotF :: Functor (ComponentSlot h g m p) where
  map f = unComponentSlot \p ctor j g h i ->
    mkComponentSlot p ctor j g (map f <<< h) i

mkComponentSlot
  :: forall h g z m p j q o
   . p
  -> (Component h z j o m)
  -> j
  -> (j -> Maybe (g Unit))
  -> (o -> Maybe q)
  -> (forall x. g x -> Maybe (z x))
  -> ComponentSlot h g m p q
mkComponentSlot = unsafeCoerce ComponentSlot

unComponentSlot
  :: forall h g m p q r
   . (forall z j o. p -> Component h z j o m -> j -> (j -> Maybe (g Unit)) -> (o -> Maybe q) -> (forall x. g x -> Maybe (z x)) -> r)
  -> ComponentSlot h g m p q
  -> r
unComponentSlot f cs =
  case unsafeCoerce cs of
    ComponentSlot p ctor input inputQuery outputQuery projQuery ->
      f p ctor input inputQuery outputQuery projQuery

hoistSlot
  :: forall h g m m' p q
   . (Bifunctor h, Functor m')
  => (m ~> m')
  -> ComponentSlot h g m p q
  -> ComponentSlot h g m' p q
hoistSlot nat = unComponentSlot \p ctor input inputQuery outputQuery projQuery ->
  mkComponentSlot p (hoist nat ctor) input inputQuery outputQuery projQuery


Disable serializers option for C#, until we have tests for it

The use-list option at least I can test by changing the default
value and then running the test suite locally (it passes).

module Language.CSharp
    ( renderer
    ) where

import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getModuleName, getTypeNameForUnion, getUnionNames, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, getOptionValue)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, Named, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.String.Util (camelCase, legalizeCharacters, startWithLetter, stringEscape, isLetterOrLetterNumber)
import Options (booleanOption, Option)

forbiddenNames :: Array String
forbiddenNames = ["Convert", "JsonConverter", "Type"]

listOption :: Option Boolean
listOption = booleanOption "use-list" "Use List<T> instead of T[]" false

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , options: [listOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer csNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer nameForType
            , nameFromTypes: simpleNamer (unionNameIntercalated csNameStyle "Or")
            }
        }
    }

nameForType :: Named (Set String) -> String
nameForType = csNameStyle <<< combineNames

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = nameForType names

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

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

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

renderNullableToCSharp :: IRType -> Doc String
renderNullableToCSharp x = do
    rendered <- renderTypeToCSharp x
    pure if isValueType x then rendered <> "?" else rendered

renderUnionToCSharp :: IRUnionRep -> Doc String
renderUnionToCSharp ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToCSharp x
    Nothing -> lookupUnionName ur

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        useList <- getOptionValue listOption
        if useList
            then
                pure $ "List<" <> rendered <> ">"
            else
                pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion ur -> renderUnionToCSharp ur

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

csNameStyle :: String -> String
csNameStyle = legalize >>> camelCase >>> startWithLetter isStartCharacter true

getDecoderHelperPrefix :: String -> Doc String
getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

csharpDoc :: Doc Unit
csharpDoc = do
    module_ <- getModuleName csNameStyle
    oneOfThese <- getForSingleOrMultipleTopLevels "" " one of these"
    line $ "// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do" <> oneOfThese <> ":"
    forEachTopLevel_ \topLevelName topLevelType -> do
        prefix <- getDecoderHelperPrefix topLevelName
        line "//"
        line $ "//    var data = " <> module_ <> ".Convert." <> prefix <> "FromJson(jsonString);"
    line "//"
    line $ "namespace " <> module_
    line "{"
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;
"""
        renderRenderItems blank Nothing renderCSharpClass (Just renderCSharpUnion)
        blank
        renderJsonConverter
    line "}"

whenSerializers :: Doc Unit -> Doc Unit
whenSerializers = id

stringIfTrue :: Boolean -> String -> String
stringIfTrue true s = s
stringIfTrue false _ = ""

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Convert" <> stringIfTrue haveUnions " : JsonConverter"
    line "{"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderTypeToCSharp topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelName
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> fromJsonPrefix
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Settings);"
            whenSerializers do
                line
                    $ "public static string ToJson("
                    <> topLevelTypeRendered
                    <> " o) => JsonConvert.SerializeObject(o, Settings);"

        blank
        line "// JsonConverter stuff"

        when haveUnions do
            blank
            line "public override bool CanConvert(Type t)"
            line "{"
            indent $ line $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            line "}"
            blank
            line "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer)"
            line "{"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> "))"
                    indent $ line $ "return new " <> name <> "(reader, serializer);"
                line "throw new Exception(\"Unknown type\");"
            line "}"

            whenSerializers do
                blank
                line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
                line "{"
                indent do
                    line "var t = value.GetType();"
                    for_ names \name -> do
                        line $ "if (t == typeof(" <> name <> ")) {"
                        indent do
                            line $ "((" <> name <> ")value).WriteJson(writer, serializer);"
                            line "return;"
                        line "}"
                    line "throw new Exception(\"Unknown type\");"
                line "}"

        blank
        line "static JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Convert() },"
        line "};"
    line "}"

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Doc Unit
renderNullDeserializer = do
    tokenCase "Null"
    indent do
        line "break;"

unionFieldName :: IRType -> Doc String
unionFieldName t = csNameStyle <$> getTypeNameForUnion t

deserialize :: String -> String -> Doc Unit
deserialize fieldName typeName = do
    line $ fieldName <> " = serializer.Deserialize<" <> typeName <> ">(reader);"
    line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    fieldName <- unionFieldName t
    renderedType <- renderTypeToCSharp t
    deserialize fieldName renderedType

renderPrimitiveDeserializer :: List String -> IRType -> IRUnionRep -> Doc Unit
renderPrimitiveDeserializer tokenTypes t union =
    when (isUnionMember t union) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: IRUnionRep -> Doc Unit
renderDoubleDeserializer union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRUnionRep -> Maybe IRType) -> String -> IRUnionRep -> Doc Unit
renderGenericDeserializer predicate tokenType union =
    case predicate union of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: String -> IRUnionRep -> Doc Unit
renderCSharpUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "public struct " <> name
    line "{"
    indent do
        forUnion_ nonNullUnion \t -> do
            typeString <- renderNullableToCSharp t
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                when hasNull renderNullDeserializer
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger nonNullUnion
                renderDoubleDeserializer nonNullUnion
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool nonNullUnion
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString nonNullUnion
                renderGenericDeserializer unionHasArray "StartArray" nonNullUnion
                renderGenericDeserializer unionHasClass "StartObject" nonNullUnion
                renderGenericDeserializer unionHasMap "StartObject" nonNullUnion
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"

        whenSerializers do
            blank
            line $ "public void WriteJson(JsonWriter writer, JsonSerializer serializer)"
            line "{"
            indent do
                forUnion_ nonNullUnion \field -> do
                    fieldName <- unionFieldName field
                    line $ "if (" <> fieldName <> " != null) {"
                    indent do
                        line $ "serializer.Serialize(writer, " <> fieldName <> ");"
                        line "return;"
                    line "}"
                if hasNull
                    then
                        line "writer.WriteNull();"
                    else
                        line "throw new Exception(\"Union must not be null\");"
            line "}"
    line "}"

renderCSharpClass :: String -> Map String IRType -> Doc Unit
renderCSharpClass className properties = do
    let propertyNames = transformPropertyNames (simpleNamer csNameStyle) ("Other" <> _) [className] properties
    line $ "public class " <> className
    line "{"
    indent do
        forEachProperty_ properties propertyNames \pname ptype csPropName isLast -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            unless isLast blank
    line "}"

module Language.CSharp
    ( renderer
    ) where

import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getModuleName, getTypeNameForUnion, getUnionNames, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, getOptionValue)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, Named, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.String.Util (camelCase, legalizeCharacters, startWithLetter, stringEscape, isLetterOrLetterNumber)
import Options (booleanOption, Option)

forbiddenNames :: Array String
forbiddenNames = ["Convert", "JsonConverter", "Type"]

serializersOption :: Option Boolean
serializersOption = booleanOption "serializers" "Generate serializers" true

listOption :: Option Boolean
listOption = booleanOption "use-list" "Use List<T> instead of T[]" false

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , options: [serializersOption.specification, listOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer csNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer nameForType
            , nameFromTypes: simpleNamer (unionNameIntercalated csNameStyle "Or")
            }
        }
    }

nameForType :: Named (Set String) -> String
nameForType = csNameStyle <<< combineNames

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = nameForType names

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

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

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

renderNullableToCSharp :: IRType -> Doc String
renderNullableToCSharp x = do
    rendered <- renderTypeToCSharp x
    pure if isValueType x then rendered <> "?" else rendered

renderUnionToCSharp :: IRUnionRep -> Doc String
renderUnionToCSharp ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToCSharp x
    Nothing -> lookupUnionName ur

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        useList <- getOptionValue listOption
        if useList
            then
                pure $ "List<" <> rendered <> ">"
            else
                pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion ur -> renderUnionToCSharp ur

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

csNameStyle :: String -> String
csNameStyle = legalize >>> camelCase >>> startWithLetter isStartCharacter true

getDecoderHelperPrefix :: String -> Doc String
getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

csharpDoc :: Doc Unit
csharpDoc = do
    module_ <- getModuleName csNameStyle
    oneOfThese <- getForSingleOrMultipleTopLevels "" " one of these"
    line $ "// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do" <> oneOfThese <> ":"
    forEachTopLevel_ \topLevelName topLevelType -> do
        prefix <- getDecoderHelperPrefix topLevelName
        line "//"
        line $ "//    var data = " <> module_ <> ".Convert." <> prefix <> "FromJson(jsonString);"
    line "//"
    line $ "namespace " <> module_
    line "{"
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;
"""
        renderRenderItems blank Nothing renderCSharpClass (Just renderCSharpUnion)
        blank
        renderJsonConverter
    line "}"

whenSerializers :: Doc Unit -> Doc Unit
whenSerializers doc = do
    serializers <- getOptionValue serializersOption
    when serializers doc

stringIfTrue :: Boolean -> String -> String
stringIfTrue true s = s
stringIfTrue false _ = ""

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Convert" <> stringIfTrue haveUnions " : JsonConverter"
    line "{"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderTypeToCSharp topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelName
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> fromJsonPrefix
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Settings);"
            whenSerializers do
                line
                    $ "public static string ToJson("
                    <> topLevelTypeRendered
                    <> " o) => JsonConvert.SerializeObject(o, Settings);"

        blank
        line "// JsonConverter stuff"

        when haveUnions do
            blank
            line "public override bool CanConvert(Type t)"
            line "{"
            indent $ line $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            line "}"
            blank
            line "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer)"
            line "{"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> "))"
                    indent $ line $ "return new " <> name <> "(reader, serializer);"
                line "throw new Exception(\"Unknown type\");"
            line "}"

            whenSerializers do
                blank
                line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
                line "{"
                indent do
                    line "var t = value.GetType();"
                    for_ names \name -> do
                        line $ "if (t == typeof(" <> name <> ")) {"
                        indent do
                            line $ "((" <> name <> ")value).WriteJson(writer, serializer);"
                            line "return;"
                        line "}"
                    line "throw new Exception(\"Unknown type\");"
                line "}"

        blank
        line "static JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Convert() },"
        line "};"
    line "}"

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Doc Unit
renderNullDeserializer = do
    tokenCase "Null"
    indent do
        line "break;"

unionFieldName :: IRType -> Doc String
unionFieldName t = csNameStyle <$> getTypeNameForUnion t

deserialize :: String -> String -> Doc Unit
deserialize fieldName typeName = do
    line $ fieldName <> " = serializer.Deserialize<" <> typeName <> ">(reader);"
    line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    fieldName <- unionFieldName t
    renderedType <- renderTypeToCSharp t
    deserialize fieldName renderedType

renderPrimitiveDeserializer :: List String -> IRType -> IRUnionRep -> Doc Unit
renderPrimitiveDeserializer tokenTypes t union =
    when (isUnionMember t union) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: IRUnionRep -> Doc Unit
renderDoubleDeserializer union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRUnionRep -> Maybe IRType) -> String -> IRUnionRep -> Doc Unit
renderGenericDeserializer predicate tokenType union =
    case predicate union of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: String -> IRUnionRep -> Doc Unit
renderCSharpUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "public struct " <> name
    line "{"
    indent do
        forUnion_ nonNullUnion \t -> do
            typeString <- renderNullableToCSharp t
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                when hasNull renderNullDeserializer
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger nonNullUnion
                renderDoubleDeserializer nonNullUnion
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool nonNullUnion
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString nonNullUnion
                renderGenericDeserializer unionHasArray "StartArray" nonNullUnion
                renderGenericDeserializer unionHasClass "StartObject" nonNullUnion
                renderGenericDeserializer unionHasMap "StartObject" nonNullUnion
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"

        whenSerializers do
            blank
            line $ "public void WriteJson(JsonWriter writer, JsonSerializer serializer)"
            line "{"
            indent do
                forUnion_ nonNullUnion \field -> do
                    fieldName <- unionFieldName field
                    line $ "if (" <> fieldName <> " != null) {"
                    indent do
                        line $ "serializer.Serialize(writer, " <> fieldName <> ");"
                        line "return;"
                    line "}"
                if hasNull
                    then
                        line "writer.WriteNull();"
                    else
                        line "throw new Exception(\"Union must not be null\");"
            line "}"
    line "}"

renderCSharpClass :: String -> Map String IRType -> Doc Unit
renderCSharpClass className properties = do
    let propertyNames = transformPropertyNames (simpleNamer csNameStyle) ("Other" <> _) [className] properties
    line $ "public class " <> className
    line "{"
    indent do
        forEachProperty_ properties propertyNames \pname ptype csPropName isLast -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            unless isLast blank
    line "}"


Add missing mapMaybeT

Add missing mapMaybeT

module Control.Monad.Maybe.Trans where

import Prelude
import Data.Maybe
import Control.Monad
import Control.Monad.Trans

data MaybeT m a = MaybeT (m (Maybe a))

instance monadMaybeT :: (Monad m) => Monad (MaybeT m) where
  return x = MaybeT $ return $ Just x
  (>>=) x f = MaybeT $ do
    v <- runMaybeT x
    case v of
      Nothing -> return Nothing
      Just y  -> runMaybeT (f y)

instance monadTransMaybeT :: MonadTrans MaybeT where
  lift = MaybeT <<< (<$>) Just

runMaybeT :: forall m a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT x) = x

mapMaybeT :: forall m1 m2 a b. (m1 (Maybe a) -> m2 (Maybe b)) -> MaybeT m1 a -> MaybeT m2 b
mapMaybeT f = MaybeT <<< f <<< runMaybeT

liftCatchMaybe :: forall m e a. (m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)) -> MaybeT m a -> (e -> MaybeT m a) -> MaybeT m a
liftCatchMaybe catch m h = MaybeT $ catch (runMaybeT m) (runMaybeT <<< h)

module Control.Monad.Maybe.Trans where

import Prelude
import Data.Maybe
import Control.Monad
import Control.Monad.Trans

data MaybeT m a = MaybeT (m (Maybe a))

instance monadMaybeT :: (Monad m) => Monad (MaybeT m) where
  --return = lift <<< return -- TODO: doesn't type check?
  return x = MaybeT $ return $ Just x
  (>>=) x f = MaybeT $ do
    v <- runMaybeT x
    case v of
      Nothing -> return Nothing
      Just y  -> runMaybeT (f y)

instance monadTransMaybeT :: MonadTrans MaybeT where
  lift = MaybeT <<< (<$>) Just

runMaybeT :: forall m a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT x) = x

liftCatchMaybe :: forall m e a. (m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)) -> MaybeT m a -> (e -> MaybeT m a) -> MaybeT m a
liftCatchMaybe catch m h = MaybeT $ catch (runMaybeT m) (runMaybeT <<< h)


(hacky) test snp hitboxes in ui.purs

(hacky) test snp hitboxes in ui.purs

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Color.Scheme.Clrs (blue)
import Control.Coroutine (Consumer, Producer, connect, runProcess)
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, Milliseconds, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Foldable (class Foldable, foldMap, null)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Lens (Iso', iso, re, to, united, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List)
import Data.Map (Map)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Symbol (SProxy(..))
import Data.Traversable (for, traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import Genetics.Browser.Track.Backend (RenderedTrack, Rendered, browser, browser', bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Demo (Annot, BedFeature, GWASFeature, annotLegendTest, demoTracks, getAnnotations, getGWAS, getGenes, gwasDraw, produceAnnots, produceGWAS, produceGenes, renderGWAS)
import Genetics.Browser.Track.UI.Canvas (BrowserCanvas, TrackPadding, blankTrack, browserCanvas, browserOnClick, debugBrowserCanvas, drawOnTrack, flipTrack, renderBatchGlyphs, renderBrowser, renderBrowser', renderSingleGlyphs, renderTrack, subtractPadding, trackViewScale, transTrack, uiSlots)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (CoordSys, CoordSysView(CoordSysView), ViewScale, _TotalSize, coordSys, normalizeView, pairSize, pixelsView, scaleViewBy, showViewScale, translateViewBy)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (fillRect, setFillStyle)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Partial.Unsafe (unsafePartial)
import Simple.JSON (read)

foreign import windowInnerSize :: forall e.
                                  Eff e Canvas.Dimensions

-- | Set an event to fire on the given button id
foreign import buttonEvent :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (Pair BigInt -> Pair BigInt)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1)   (ZoomView s2)   = ZoomView   (s1 * s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView id

updateViewFold :: UpdateView
               -> CoordSysView
               -> CoordSysView
updateViewFold uv iv = case uv of
  ZoomView   x -> iv `scaleViewBy`     x
  ScrollView x -> iv `translateViewBy` x
  ModView f    -> over CoordSysView f iv

queueCmd :: AVar UpdateView -> UpdateView -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
  unsafePartial
  $ map (bimap ChrId (fromJust <<< BigInt.fromString))
      [ Tuple "1"   "195471971"
      , Tuple "2"   "182113224"
      , Tuple "3"   "160039680"
      , Tuple "4"   "156508116"
      , Tuple "5"   "151834684"
      , Tuple "6"   "149736546"
      , Tuple "7"   "145441459"
      , Tuple "8"   "129401213"
      , Tuple "9"   "124595110"
      , Tuple "10"  "130694993"
      , Tuple "11"  "122082543"
      , Tuple "12"  "120129022"
      , Tuple "13"  "120421639"
      , Tuple "14"  "124902244"
      , Tuple "15"  "104043685"
      , Tuple "16"  "98207768"
      , Tuple "17"  "94987271"
      , Tuple "18"  "90702639"
      , Tuple "19"  "61431566"
      , Tuple "X"   "171031299"
      , Tuple "Y"   "91744698"
      ]

-- runs console.time() with the provided string, returns the effect to stop the timer
foreign import timeEff :: forall eff. String -> Eff eff (Eff eff Unit)

type UIState e = { view :: AVar CoordSysView
                 , viewCmd :: AVar UpdateView
                 , viewReady :: AVar Unit
                 , renderFiber :: AVar (Fiber e Unit)
                 , cachedTracks :: AVar { cachedScale :: ViewScale
                                        , glyphs :: List (Array RenderedTrack) }
                 }

diffView :: CoordSysView -> CoordSysView -> CoordSysView
diffView v1 v2 =
  let (Pair l1 r1) = unwrap v1
      (Pair l2 r2) = unwrap v2
  in wrap $ Pair (l2 - l1) (r2 - r1)

showView :: CoordSysView -> String
showView (CoordSysView (Pair l r)) = BigInt.toString l <> " - " <> BigInt.toString r

_PairRec :: forall a. Iso' (Pair a) { l :: a, r :: a }
_PairRec = iso (\(Pair l r) -> {l, r}) (\ {l, r} -> Pair l r)

debugView :: UIState _
          -> Eff _ { get :: _
                   , set :: _ }
debugView s = do
  let get name = launchAff_ do
         view <- AVar.tryReadVar s.view
         liftEff case view of
           Nothing -> do
             log "CoordSysView state empty"
             setWindow name unit
           Just (v :: _)  -> do
             log $ "CoordSysView: " <> showView v
             setWindow name $ unwrap v ^. _PairRec

  let set lr = launchAff_ do
         view <- AVar.tryTakeVar s.view
         case view of
           Nothing -> pure unit
           Just _  -> do
             let v' = wrap $ lr ^. re _PairRec
             _ <- AVar.tryPutVar unit s.viewReady
             AVar.putVar v' s.view

  pure {get, set}

uiViewUpdate :: forall r.
                CoordSys _ BigInt
             -> Milliseconds
             -> { view :: AVar CoordSysView
                , viewCmd :: AVar UpdateView
                , viewReady :: AVar Unit| r }
             -> Aff _ Unit
uiViewUpdate cs timeout { view, viewCmd, viewReady } = do
  curCmdVar <- makeVar mempty

  let normView = normalizeView cs (BigInt.fromInt 200000)
      loop' updater = do
        cmd <- takeVar viewCmd

        killFiber (error "Resetting view update") updater
        liftEff $ log $ "forking view update"

        curCmd <- takeVar curCmdVar
        let cmd' = curCmd <> cmd
        putVar cmd' curCmdVar

        updater' <- forkAff do
            delay timeout
            liftEff $ log "Running view update"
            vr <- takeVar view

            let vr' = normView $ updateViewFold cmd' vr

            putVar vr' view

            putVar unit viewReady
            takeVar curCmdVar *> putVar mempty curCmdVar

        loop' updater'

  loop' (pure unit)

renderLoop :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> BrowserCanvas
           -> UIState _
           -> Aff _ Unit
renderLoop cSys browser canvas state = forever do

  _ <- takeVar state.viewReady

  csView <- readVar state.view
  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let uiScale = trackViewScale canvas csView

  -- if the view scale is unchanged, use the cached glyphs
  tracks' <- do
    cache <- AVar.tryTakeVar state.cachedTracks
    case cache of
      Just ct
        | ct.cachedScale == uiScale -> do
            AVar.putVar ct state.cachedTracks
            pure ct.glyphs
      _ -> do
        let cachedScale = uiScale
            glyphs = browser.tracks (unwrap csView)

        AVar.putVar {cachedScale, glyphs} state.cachedTracks
        pure glyphs

  -- fork a new renderFiber

  let (Pair offset _) = pixelsView uiScale csView

      relativeUI = browser.relativeUI (unwrap csView)
      fixedUI = browser.fixedUI

      ui ::  { tracks     :: List (Array RenderedTrack)
             , relativeUI :: Drawing
             , fixedUI :: Drawing }
      ui = { tracks: tracks'
           , relativeUI, fixedUI }

  renderFiber <- forkAff
                 $ renderBrowser (wrap 3.0) canvas offset ui

  putVar renderFiber state.renderFiber

renderLoop' :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> { gwas :: Map ChrId (Rendered (GWASFeature _)) }
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> BrowserCanvas
           -> UIState _
           -> Aff _ Unit
renderLoop' cSys browser canvas state = forever do

  _ <- takeVar state.viewReady

  csView <- readVar state.view
  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let uiScale = trackViewScale canvas csView

  liftEff $ log $ "view scale is: " <> showViewScale uiScale

  {-

  -- if the view scale is unchanged, use the cached glyphs
  tracks' <- do
    cache <- AVar.tryTakeVar state.cachedTracks
    case cache of
      Just ct
        | ct.cachedScale == uiScale -> do
            AVar.putVar ct state.cachedTracks
            pure ct.glyphs
      _ -> do
        let cachedScale = uiScale
            glyphs = browser.tracks (unwrap csView)

        AVar.putVar {cachedScale, glyphs} state.cachedTracks
        pure glyphs

  -}

  let tracks' = browser.tracks (unwrap csView)

  let overlaps' :: Number -> Point -> Array _
      overlaps' r p = foldMap (\s -> s.overlaps r p) tracks'.gwas

  liftEff $ setWindow "overlaps" overlaps'
  -- fork a new renderFiber

  let (Pair offset _) = pixelsView uiScale csView

      relativeUI = browser.relativeUI (unwrap csView)
      fixedUI = browser.fixedUI

      ui ::  { tracks     :: _
             , relativeUI :: Drawing
             , fixedUI :: Drawing }
      ui = { tracks: tracks'
           , relativeUI, fixedUI }

  renderFiber <- forkAff
                 $ renderBrowser' (wrap 2.0) canvas offset ui

  putVar renderFiber state.renderFiber

-- TODO configure UI widths
runBrowser :: Conf -> BrowserCanvas -> Eff _ _
runBrowser config bc = launchAff $ do

  let browserDimensions = (unwrap bc).dimensions
      trackDimensions = subtractPadding browserDimensions (unwrap bc).trackPadding

  {width} <- liftEff $ windowInnerSize

  let height = config.browserHeight
      browserDimensions = {width, height}
      vScaleWidth = 60.0
      legendWidth = 120.0
      trackWidth = width - (vScaleWidth + legendWidth)

  let cSys :: CoordSys ChrId BigInt
      cSys = coordSys mouseChrSizes

  trackData <- do
    genes <- traverse (getGenes cSys) config.urls.genes
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas
    rawAnnotations <-
      traverse (getAnnotations cSys) config.urls.annotations

    let annotations = zipMapsWith
                       (bumpFeatures (to _.feature.score) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: CoordSysView
      initialView = wrap $ Pair zero (cSys^._TotalSize)

  viewCmd <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmd
    btnZoom   0.10 viewCmd
    -- dragScroll trackWidth bCanvas viewCmd
    -- wheelZoom 0.02 viewCmd bCanvas.overlay

  view <- makeVar initialView
  viewReady <- makeVar unit
  renderFiber <- makeEmptyVar
  cachedTracks <- AVar.makeEmptyVar

  let initState :: UIState _
      initState = { view, viewCmd, viewReady, renderFiber, cachedTracks }

  let
      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: legendWidth, entries }

      s = config.score

      vscale = { width: vScaleWidth, color: black
               , min: s.min, max: s.max, sig: s.sig }

      tracks = demoTracks vscale trackData

      padding = { horizontal: config.trackPadding.left
                , vertical: config.trackPadding.top }

      mainBrowser = browser
                    cSys
                    trackDimensions
                    browserDimensions
                    (uiSlots bc) {legend, vscale} tracks

      mainBrowser' :: _
      mainBrowser' = browser' cSys
                     trackDimensions browserDimensions
                     (uiSlots bc) {legend, vscale}
                     { gwas: renderGWAS vscale  }
                     { gwas: fromMaybe mempty trackData.gwas }

      viewTimeout :: Milliseconds
      viewTimeout = wrap 100.0

  liftEff do
    setWindow "mainBrowser" mainBrowser
    setWindow "debugView" (debugView initState)

    browserOnClick bc
      { track:   \p -> log ("track: "   <> show p.x <> ", " <> show p.y)
      , overlay: \p -> log ("overlay: " <> show p.x <> ", " <> show p.y) }

  _ <- forkAff $ uiViewUpdate cSys viewTimeout initState
  -- _ <- forkAff $ renderLoop cSys mainBrowser bc initState
  _ <- forkAff $ renderLoop' cSys mainBrowser' bc initState

  pure unit

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , trackPadding :: TrackPadding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import setWindow :: forall e a. String -> a -> Eff e Unit

initBrowser :: Foreign -> Eff _ _
initBrowser rawConfig = do

  el' <- do
    doc <- DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    DOM.querySelector (wrap "#browser") (toParentNode doc)

  case read rawConfig :: Either MultipleErrors Conf of
    Left errs -> traverse_ (log <<< renderForeignError) errs
    Right c   -> do
      case el' of
        Nothing -> log "Could not find element '#browser'"
        Just el -> do

          {width} <- windowInnerSize
          let dimensions = { width, height: c.browserHeight }
          bc <- browserCanvas dimensions c.trackPadding el

          debugBrowserCanvas "debugBC" bc

          let drawR :: Number -> Number -> Eff _ Unit
              drawR x y = drawOnTrack bc \ctx -> do
                _ <- setFillStyle "red" ctx
                _ <- fillRect ctx { x, y, w: 20.0, h: 20.0 }
                pure unit

          setWindow "drawRect" drawR
          setWindow "flipTrack" (flipTrack bc)
          setWindow "blankTrack" (blankTrack bc)

          log $ unsafeStringify c
          void $ runBrowser c bc

-- TODO this could almost certainly be done better
chunkConsumer :: forall m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av
       putVar (sofar <> m) av
       delay (wrap 20.0)
       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))
type TrackProducer eff a = Producer (Map ChrId (Array a)) (Aff eff) Unit

-- Feels like this one takes care of a bit too much...
fetchLoop1 :: forall a.
              (Maybe (Aff _ (TrackProducer _ a)))
           -> Aff _ (TrackVar a)
fetchLoop1 Nothing = AVar.makeEmptyVar
fetchLoop1 (Just startProd) = do
  prod <- startProd
  avar <- makeVar mempty
  _ <- forkAff $ runProcess $ prod `connect` chunkConsumer avar
  pure avar

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwas <-        fetchLoop1 $ produceGWAS   cs <$> urls.gwas
  annotations <- fetchLoop1 $ produceAnnots cs <$> urls.annotations
  genes <-       fetchLoop1 $ produceGenes  cs <$> urls.genes
  pure { gwas, genes, annotations }

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Color.Scheme.Clrs (blue)
import Control.Coroutine (Consumer, Producer, connect, runProcess)
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, Milliseconds, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Foldable (class Foldable, foldMap, null)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Lens (Iso', iso, re, to, united, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List)
import Data.Map (Map)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Symbol (SProxy(..))
import Data.Traversable (for, traverse, traverse_)
import Data.Tuple (Tuple(Tuple))
import Genetics.Browser.Track.Backend (RenderedTrack, Rendered, browser, browser', bumpFeatures, zipMapsWith)
import Genetics.Browser.Track.Demo (Annot, BedFeature, GWASFeature, annotLegendTest, demoTracks, getAnnotations, getGWAS, getGenes, gwasDraw, produceAnnots, produceGWAS, produceGenes, renderGWAS)
import Genetics.Browser.Track.UI.Canvas (BrowserCanvas, TrackPadding, blankTrack, browserCanvas, browserOnClick, debugBrowserCanvas, drawOnTrack, flipTrack, renderBatchGlyphs, renderBrowser, renderBrowser', renderSingleGlyphs, renderTrack, subtractPadding, trackViewScale, transTrack, uiSlots)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (CoordSys, CoordSysView(CoordSysView), ViewScale, _TotalSize, coordSys, normalizeView, pairSize, pixelsView, scaleViewBy, showViewScale, translateViewBy)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (fillRect, setFillStyle)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing)
import Partial.Unsafe (unsafePartial)
import Simple.JSON (read)

foreign import windowInnerSize :: forall e.
                                  Eff e Canvas.Dimensions

-- | Set an event to fire on the given button id
foreign import buttonEvent :: forall eff.
                              String
                           -> Eff eff Unit
                           -> Eff eff Unit

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (Pair BigInt -> Pair BigInt)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1)   (ZoomView s2)   = ZoomView   (s1 * s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView id

updateViewFold :: UpdateView
               -> CoordSysView
               -> CoordSysView
updateViewFold uv iv = case uv of
  ZoomView   x -> iv `scaleViewBy`     x
  ScrollView x -> iv `translateViewBy` x
  ModView f    -> over CoordSysView f iv

queueCmd :: AVar UpdateView -> UpdateView -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
  unsafePartial
  $ map (bimap ChrId (fromJust <<< BigInt.fromString))
      [ Tuple "1"   "195471971"
      , Tuple "2"   "182113224"
      , Tuple "3"   "160039680"
      , Tuple "4"   "156508116"
      , Tuple "5"   "151834684"
      , Tuple "6"   "149736546"
      , Tuple "7"   "145441459"
      , Tuple "8"   "129401213"
      , Tuple "9"   "124595110"
      , Tuple "10"  "130694993"
      , Tuple "11"  "122082543"
      , Tuple "12"  "120129022"
      , Tuple "13"  "120421639"
      , Tuple "14"  "124902244"
      , Tuple "15"  "104043685"
      , Tuple "16"  "98207768"
      , Tuple "17"  "94987271"
      , Tuple "18"  "90702639"
      , Tuple "19"  "61431566"
      , Tuple "X"   "171031299"
      , Tuple "Y"   "91744698"
      ]

-- runs console.time() with the provided string, returns the effect to stop the timer
foreign import timeEff :: forall eff. String -> Eff eff (Eff eff Unit)

type UIState e = { view :: AVar CoordSysView
                 , viewCmd :: AVar UpdateView
                 , viewReady :: AVar Unit
                 , renderFiber :: AVar (Fiber e Unit)
                 , cachedTracks :: AVar { cachedScale :: ViewScale
                                        , glyphs :: List (Array RenderedTrack) }
                 }

diffView :: CoordSysView -> CoordSysView -> CoordSysView
diffView v1 v2 =
  let (Pair l1 r1) = unwrap v1
      (Pair l2 r2) = unwrap v2
  in wrap $ Pair (l2 - l1) (r2 - r1)

showView :: CoordSysView -> String
showView (CoordSysView (Pair l r)) = BigInt.toString l <> " - " <> BigInt.toString r

_PairRec :: forall a. Iso' (Pair a) { l :: a, r :: a }
_PairRec = iso (\(Pair l r) -> {l, r}) (\ {l, r} -> Pair l r)

debugView :: UIState _
          -> Eff _ { get :: _
                   , set :: _ }
debugView s = do
  let get name = launchAff_ do
         view <- AVar.tryReadVar s.view
         liftEff case view of
           Nothing -> do
             log "CoordSysView state empty"
             setWindow name unit
           Just (v :: _)  -> do
             log $ "CoordSysView: " <> showView v
             setWindow name $ unwrap v ^. _PairRec

  let set lr = launchAff_ do
         view <- AVar.tryTakeVar s.view
         case view of
           Nothing -> pure unit
           Just _  -> do
             let v' = wrap $ lr ^. re _PairRec
             _ <- AVar.tryPutVar unit s.viewReady
             AVar.putVar v' s.view

  pure {get, set}

uiViewUpdate :: forall r.
                CoordSys _ BigInt
             -> Milliseconds
             -> { view :: AVar CoordSysView
                , viewCmd :: AVar UpdateView
                , viewReady :: AVar Unit| r }
             -> Aff _ Unit
uiViewUpdate cs timeout { view, viewCmd, viewReady } = do
  curCmdVar <- makeVar mempty

  let normView = normalizeView cs (BigInt.fromInt 200000)
      loop' updater = do
        cmd <- takeVar viewCmd

        killFiber (error "Resetting view update") updater
        liftEff $ log $ "forking view update"

        curCmd <- takeVar curCmdVar
        let cmd' = curCmd <> cmd
        putVar cmd' curCmdVar

        updater' <- forkAff do
            delay timeout
            liftEff $ log "Running view update"
            vr <- takeVar view

            let vr' = normView $ updateViewFold cmd' vr

            putVar vr' view

            putVar unit viewReady
            takeVar curCmdVar *> putVar mempty curCmdVar

        loop' updater'

  loop' (pure unit)

renderLoop :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> List (Array RenderedTrack)
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> BrowserCanvas
           -> UIState _
           -> Aff _ Unit
renderLoop cSys browser canvas state = forever do

  _ <- takeVar state.viewReady

  csView <- readVar state.view
  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let uiScale = trackViewScale canvas csView

  -- if the view scale is unchanged, use the cached glyphs
  tracks' <- do
    cache <- AVar.tryTakeVar state.cachedTracks
    case cache of
      Just ct
        | ct.cachedScale == uiScale -> do
            AVar.putVar ct state.cachedTracks
            pure ct.glyphs
      _ -> do
        let cachedScale = uiScale
            glyphs = browser.tracks (unwrap csView)

        AVar.putVar {cachedScale, glyphs} state.cachedTracks
        pure glyphs

  -- fork a new renderFiber

  let (Pair offset _) = pixelsView uiScale csView

      relativeUI = browser.relativeUI (unwrap csView)
      fixedUI = browser.fixedUI

      ui ::  { tracks     :: List (Array RenderedTrack)
             , relativeUI :: Drawing
             , fixedUI :: Drawing }
      ui = { tracks: tracks'
           , relativeUI, fixedUI }

  renderFiber <- forkAff
                 $ renderBrowser (wrap 3.0) canvas offset ui

  putVar renderFiber state.renderFiber

renderLoop' :: CoordSys _ _
           -> { tracks     :: Pair BigInt -> { gwas :: Map ChrId (Rendered (GWASFeature _)) }
              , relativeUI :: Pair BigInt -> Drawing
              , fixedUI :: Drawing }
           -> BrowserCanvas
           -> UIState _
           -> Aff _ Unit
renderLoop' cSys browser canvas state = forever do

  _ <- takeVar state.viewReady

  csView <- readVar state.view
  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  let uiScale = trackViewScale canvas csView

  liftEff $ log $ "view scale is: " <> showViewScale uiScale

  {-

  -- if the view scale is unchanged, use the cached glyphs
  tracks' <- do
    cache <- AVar.tryTakeVar state.cachedTracks
    case cache of
      Just ct
        | ct.cachedScale == uiScale -> do
            AVar.putVar ct state.cachedTracks
            pure ct.glyphs
      _ -> do
        let cachedScale = uiScale
            glyphs = browser.tracks (unwrap csView)

        AVar.putVar {cachedScale, glyphs} state.cachedTracks
        pure glyphs

  -}

  let tracks' = browser.tracks (unwrap csView)

  -- fork a new renderFiber

  let (Pair offset _) = pixelsView uiScale csView

      relativeUI = browser.relativeUI (unwrap csView)
      fixedUI = browser.fixedUI

      ui ::  { tracks     :: _
             , relativeUI :: Drawing
             , fixedUI :: Drawing }
      ui = { tracks: tracks'
           , relativeUI, fixedUI }

  renderFiber <- forkAff
                 $ renderBrowser' (wrap 2.0) canvas offset ui

  putVar renderFiber state.renderFiber

-- TODO configure UI widths
runBrowser :: Conf -> BrowserCanvas -> Eff _ _
runBrowser config bc = launchAff $ do

  let browserDimensions = (unwrap bc).dimensions
      trackDimensions = subtractPadding browserDimensions (unwrap bc).trackPadding

  {width} <- liftEff $ windowInnerSize

  let height = config.browserHeight
      browserDimensions = {width, height}
      vScaleWidth = 60.0
      legendWidth = 120.0
      trackWidth = width - (vScaleWidth + legendWidth)

  let cSys :: CoordSys ChrId BigInt
      cSys = coordSys mouseChrSizes

  trackData <- do
    genes <- traverse (getGenes cSys) config.urls.genes
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas
    rawAnnotations <-
      traverse (getAnnotations cSys) config.urls.annotations

    let annotations = zipMapsWith
                       (bumpFeatures (to _.feature.score) (SProxy :: SProxy "score")
                         (Bp 1000000.0))
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: CoordSysView
      initialView = wrap $ Pair zero (cSys^._TotalSize)

  viewCmd <- makeEmptyVar
  liftEff $ do
    btnScroll 0.05 viewCmd
    btnZoom   0.10 viewCmd
    -- dragScroll trackWidth bCanvas viewCmd
    -- wheelZoom 0.02 viewCmd bCanvas.overlay

  view <- makeVar initialView
  viewReady <- makeVar unit
  renderFiber <- makeEmptyVar
  cachedTracks <- AVar.makeEmptyVar

  let initState :: UIState _
      initState = { view, viewCmd, viewReady, renderFiber, cachedTracks }

  let
      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: legendWidth, entries }

      s = config.score

      vscale = { width: vScaleWidth, color: black
               , min: s.min, max: s.max, sig: s.sig }

      tracks = demoTracks vscale trackData

      padding = { horizontal: config.trackPadding.left
                , vertical: config.trackPadding.top }

      mainBrowser = browser
                    cSys
                    trackDimensions
                    browserDimensions
                    (uiSlots bc) {legend, vscale} tracks

      mainBrowser' :: _
      mainBrowser' = browser' cSys
                     trackDimensions browserDimensions
                     (uiSlots bc) {legend, vscale}
                     { gwas: renderGWAS vscale  }
                     { gwas: fromMaybe mempty trackData.gwas }

      viewTimeout :: Milliseconds
      viewTimeout = wrap 100.0

  liftEff do
    setWindow "mainBrowser" mainBrowser
    setWindow "debugView" (debugView initState)

    browserOnClick bc
      { track:   \p -> log ("track: "   <> show p.x <> ", " <> show p.y)
      , overlay: \p -> log ("overlay: " <> show p.x <> ", " <> show p.y) }

  _ <- forkAff $ uiViewUpdate cSys viewTimeout initState
  -- _ <- forkAff $ renderLoop cSys mainBrowser bc initState
  _ <- forkAff $ renderLoop' cSys mainBrowser' bc initState

  pure unit

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , trackPadding :: TrackPadding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import setWindow :: forall e a. String -> a -> Eff e Unit

initBrowser :: Foreign -> Eff _ _
initBrowser rawConfig = do

  el' <- do
    doc <- DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    DOM.querySelector (wrap "#browser") (toParentNode doc)

  case read rawConfig :: Either MultipleErrors Conf of
    Left errs -> traverse_ (log <<< renderForeignError) errs
    Right c   -> do
      case el' of
        Nothing -> log "Could not find element '#browser'"
        Just el -> do

          {width} <- windowInnerSize
          let dimensions = { width, height: c.browserHeight }
          bc <- browserCanvas dimensions c.trackPadding el

          debugBrowserCanvas "debugBC" bc

          let drawR :: Number -> Number -> Eff _ Unit
              drawR x y = drawOnTrack bc \ctx -> do
                _ <- setFillStyle "red" ctx
                _ <- fillRect ctx { x, y, w: 20.0, h: 20.0 }
                pure unit

          setWindow "drawRect" drawR
          setWindow "flipTrack" (flipTrack bc)
          setWindow "blankTrack" (blankTrack bc)

          log $ unsafeStringify c
          void $ runBrowser c bc

-- TODO this could almost certainly be done better
chunkConsumer :: forall m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av
       putVar (sofar <> m) av
       delay (wrap 20.0)
       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))
type TrackProducer eff a = Producer (Map ChrId (Array a)) (Aff eff) Unit

-- Feels like this one takes care of a bit too much...
fetchLoop1 :: forall a.
              (Maybe (Aff _ (TrackProducer _ a)))
           -> Aff _ (TrackVar a)
fetchLoop1 Nothing = AVar.makeEmptyVar
fetchLoop1 (Just startProd) = do
  prod <- startProd
  avar <- makeVar mempty
  _ <- forkAff $ runProcess $ prod `connect` chunkConsumer avar
  pure avar

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwas <-        fetchLoop1 $ produceGWAS   cs <$> urls.gwas
  annotations <- fetchLoop1 $ produceAnnots cs <$> urls.annotations
  genes <-       fetchLoop1 $ produceGenes  cs <$> urls.genes
  pure { gwas, genes, annotations }


Tidy up & add Ord instance for Qualified

module Language.PureScript.Names where

import Data.Array (map)
import Data.Maybe
import Data.Tuple
import Data.String (joinWith, split)

-- |
-- Names for value identifiers
--
data Ident
  -- |
  -- An alphanumeric identifier
  --
  = Ident String
  -- |
  -- A symbolic name for an infix operator
  --
  | Op String

runIdent :: Ident -> String
runIdent (Ident i) = i
runIdent (Op op) = op

instance showIdent :: Show Ident where
  show (Ident i) = "Ident " ++ show i
  show (Op op) = "Op " ++ show op

instance eqIdent :: Eq Ident where
  (==) (Ident s1) (Ident s2) = s1 == s2
  (==) (Op s1)    (Op s2)    = s1 == s2
  (==) _          _          = false
  (/=) i1         i2         = not (i1 == i2)

instance ordIdent :: Ord Ident where
  compare (Ident i1) (Ident i2) = compare i1 i2
  compare (Ident _)  _          = LT
  compare (Op op1)   (Op op2)   = compare op1 op2
  compare (Op op1)   _          = GT

-- |
-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
--
data ProperName = ProperName String

runProperName :: ProperName -> String
runProperName (ProperName s) = s

instance showProperName :: Show ProperName where
  show = runProperName

instance eqProperName :: Eq ProperName where
  (==) (ProperName s1) (ProperName s2) = s1 == s2
  (/=) (ProperName s1) (ProperName s2) = s1 /= s2

instance ordProperName :: Ord ProperName where
  compare (ProperName s1) (ProperName s2) = compare s1 s2

-- |
-- Module names
--
data ModuleName = ModuleName [ProperName]

runModuleName :: ModuleName -> String
runModuleName (ModuleName pns) = joinWith "." (runProperName `map` pns)

instance showModuleName :: Show ModuleName where
  show = runModuleName

instance eqModuleName :: Eq ModuleName where
  (==) (ModuleName s1) (ModuleName s2) = s1 == s2
  (/=) (ModuleName s1) (ModuleName s2) = s1 /= s2

instance ordModuleName :: Ord ModuleName where
  compare (ModuleName s1) (ModuleName s2) = compare s1 s2

moduleNameFromString :: String -> ModuleName
moduleNameFromString = ModuleName <<< map ProperName <<< split "."

-- |
-- A qualified name, i.e. a name with an optional module name
--
data Qualified a = Qualified (Maybe ModuleName) a

instance showQualified :: (Show a) => Show (Qualified a) where
  show (Qualified Nothing a) = show a
  show (Qualified (Just name) a) = show name ++ "." ++ show a

instance eqQualified :: (Eq a) => Eq (Qualified a) where
  (==) (Qualified m1 a1) (Qualified m2 a2) = m1 == m2 && a1 == a2
  (/=) q1 q2 = not (q1 == q2)

instance ordQualified :: (Ord a) => Ord (Qualified a) where
  compare (Qualified m1 a1) (Qualified m2 a2) = case compare m1 m2 of
    EQ -> compare a1 a2
    other -> other

-- |
-- Provide a default module name, if a name is unqualified
--
qualify :: forall a. ModuleName -> Qualified a -> Tuple ModuleName a
qualify m (Qualified Nothing a) = Tuple m a
qualify _ (Qualified (Just m) a) = Tuple m a

module Language.PureScript.Names where

import Data.Array (map)
import Data.Maybe
import Data.Tuple
import Data.String (joinWith, split)

-- |
-- Names for value identifiers
--
data Ident
  -- |
  -- An alphanumeric identifier
  --
  = Ident String
  -- |
  -- A symbolic name for an infix operator
  --
  | Op String

instance showIdent :: Show Ident where
  show (Ident i) = "Ident " ++ show i
  show (Op op) = "Op " ++ show op

runIdent :: Ident -> String
runIdent (Ident i) = i
runIdent (Op op) = op

instance eqIdent :: Eq Ident where
  (==) (Ident s1) (Ident s2) = s1 == s2
  (==) (Op s1)    (Op s2)    = s1 == s2
  (==) _          _          = false
  (/=) i1         i2         = not (i1 == i2)

instance ordIdent :: Ord Ident where
  compare (Ident i1) (Ident i2) = compare i1 i2
  compare (Ident _)  _          = LT
  compare (Op op1)   (Op op2)   = compare op1 op2
  compare (Op op1)   _          = GT

-- |
-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
--
data ProperName = ProperName String

runProperName :: ProperName -> String
runProperName (ProperName s) = s

instance showProperName :: Show ProperName where
  show = runProperName

instance eqProperName :: Eq ProperName where
  (==) (ProperName s1) (ProperName s2) = s1 == s2
  (/=) (ProperName s1) (ProperName s2) = s1 /= s2

instance ordProperName :: Ord ProperName where
  compare (ProperName s1) (ProperName s2) = compare s1 s2

-- |
-- Module names
--
data ModuleName = ModuleName [ProperName]

instance showModuleName :: Show ModuleName where
  show = runModuleName

instance eqModuleName :: Eq ModuleName where
  (==) (ModuleName s1) (ModuleName s2) = s1 == s2
  (/=) (ModuleName s1) (ModuleName s2) = s1 /= s2

instance ordModuleName :: Ord ModuleName where
  compare (ModuleName s1) (ModuleName s2) = compare s1 s2

runModuleName :: ModuleName -> String
runModuleName (ModuleName pns) = joinWith "." (runProperName `map` pns)

moduleNameFromString :: String -> ModuleName
moduleNameFromString = ModuleName <<< map ProperName <<< split "."

-- |
-- A qualified name, i.e. a name with an optional module name
--
data Qualified a = Qualified (Maybe ModuleName) a

instance eqQualified :: (Eq a) => Eq (Qualified a) where
  (==) (Qualified m1 a1) (Qualified m2 a2) = m1 == m2 && a1 == a2
  (/=) q1 q2 = not (q1 == q2)

instance showQualified :: (Show a) => Show (Qualified a) where
  show (Qualified Nothing a) = show a
  show (Qualified (Just name) a) = show name ++ "." ++ show a

-- |
-- Provide a default module name, if a name is unqualified
--
qualify :: forall a. ModuleName -> Qualified a -> Tuple ModuleName a
qualify m (Qualified Nothing a) = Tuple m a
qualify _ (Qualified (Just m) a) = Tuple m a