created examples for `String` functions and refactored existing ones (#90)

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( Pattern(..)
  , Replacement(..)
  , charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , replaceAll
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , stripSuffix
  , count
  , split
  , splitAt
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype)
import Data.String.Unsafe as U

-- | A newtype used in cases where there is a string to be matched.
-- |
-- | ```purescript
-- | pursPattern = Pattern ".purs"
-- | --can be used like this:
-- | contains pursPattern "Test.purs"
-- |    == true
-- | ```
-- |
newtype Pattern = Pattern String

derive instance eqPattern :: Eq Pattern
derive instance ordPattern :: Ord Pattern
derive instance newtypePattern :: Newtype Pattern _

instance showPattern :: Show Pattern where
  show (Pattern s) = "(Pattern " <> show s <> ")"

-- | A newtype used in cases to specify a replacement for a pattern.
newtype Replacement = Replacement String

derive instance eqReplacement :: Eq Replacement
derive instance ordReplacement :: Ord Replacement
derive instance newtypeReplacement :: Newtype Replacement _

instance showReplacement :: Show Replacement where
  show (Replacement s) = "(Replacement " <> show s <> ")"

-- | Returns the character at the given index, if the index is within bounds.
-- |
-- | ```purescript
-- | charAt 2 "Hello" == Just 'l'
-- | charAt 10 "Hello" == Nothing
-- | ```
-- |
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Char

-- | Returns a string of length `1` containing the given character.
-- |
-- | ```purescript
-- | singleton 'l' == "l"
-- | ```
-- |
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
-- | ```purescript
-- | charCodeAt 2 "5 €" == Just 0x20AC
-- | charCodeAt 10 "5 €" == Nothing
-- | ```
-- |
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

foreign import _charCodeAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Int

-- | Converts the string to a character, if the length of the string is
-- | exactly `1`.
-- |
-- | ```purescript
-- | toChar "l" == Just 'l'
-- | toChar "Hi" == Nothing -- since length is not 1
-- | ```
-- |
toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> String
  -> Maybe Char

-- | Returns `true` if the given string is empty.
-- |
-- | ```purescript
-- | null "" == true
-- | null "Hi" == false
-- | ```
-- |
null :: String -> Boolean
null s = s == ""

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
-- |
-- | ```purescript
-- | uncons "" == Nothing
-- | uncons "Hello World" == Just { head: 'H', tail: "ello World" }
-- | ```
-- |
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate.
-- |
-- | ```purescript
-- | takeWhile (_ /= ':') "http://purescript.org" == "http"
-- | ```
-- |
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
-- |
-- | ```purescript
-- | dropWhile (_ /= '.') "Test.purs" == ".purs"
-- | ```
-- |
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- |
-- | ```purescript
-- | stripPrefix (Pattern "http:") "http://purescript.org" == Just "//purescript.org"
-- | stripPrefix (Pattern "http:") "https://purescript.org" == Nothing
-- | ```
-- |
stripPrefix :: Pattern -> String -> Maybe String
stripPrefix prefix@(Pattern prefixS) str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefixS) str
    _ -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a `Just` value. Otherwise, return
-- | `Nothing`.
-- |
-- | ```purescript
-- | stripSuffix (Pattern ".exe") "psc.exe" == Just "psc"
-- | stripSuffix (Pattern ".exe") "psc" == Nothing
-- | ```
-- |
stripSuffix :: Pattern -> String -> Maybe String
stripSuffix suffix@(Pattern suffixS) str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffixS -> Just $ take x str
    _ -> Nothing

-- | Converts an array of characters into a string.
-- |
-- | ```purescript
-- | fromCharArray ['H', 'e', 'l', 'l', 'o'] == "Hello"
-- | ```
-- |
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the pattern appears in the given string.
-- |
-- | ```purescript
-- | contains (Pattern "needle") "haystack with needle" == true
-- | contains (Pattern "needle") "haystack" == false
-- | ```
-- |
contains :: Pattern -> String -> Boolean
contains pat = isJust <<< indexOf pat

-- | Returns the index of the first occurrence of the pattern in the
-- | given string. Returns `Nothing` if there is no match.
-- |
-- | ```purescript
-- | indexOf (Pattern "c") "abcdc" == Just 2
-- | indexOf (Pattern "c") "aaa" == Nothing
-- | ```
-- |
indexOf :: Pattern -> String -> Maybe Int
indexOf = _indexOf Just Nothing

foreign import _indexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the first occurrence of the pattern in the
-- | given string, starting at the specified index. Returns `Nothing` if there is
-- | no match.
-- |
-- | ```purescript
-- | indexOf' (Pattern "a") 2 "ababa" == Just 2
-- | indexOf' (Pattern "a") 3 "ababa" == Just 4
-- | ```
-- |
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the pattern in the
-- | given string. Returns `Nothing` if there is no match.
-- |
-- | ```purescript
-- | lastIndexOf (Pattern "c") "abcdc" == Just 4
-- | lastIndexOf (Pattern "c") "aaa" == Nothing
-- | ```
-- |
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

foreign import _lastIndexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the pattern in the
-- | given string, starting at the specified index
-- | and searching backwards towards the beginning of the string.
-- | Returns `Nothing` if there is no match.
-- |
-- | ```purescript
-- | lastIndexOf' (Pattern "a") 1 "ababa" == Just 0
-- | lastIndexOf' (Pattern "a") 3 "ababa" == Just 2
-- | lastIndexOf' (Pattern "a") 4 "ababa" == Just 4
-- | ```
-- |
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the number of characters the string is composed of.
-- |
-- | ```purescript
-- | length "Hello World" == 11
-- | ```
-- |
foreign import length :: String -> Int

-- | Compare two strings in a locale-aware fashion. This is in contrast to
-- | the `Ord` instance on `String` which treats strings as arrays of code
-- | units:
-- |
-- | ```purescript
-- | "ä" `localeCompare` "b" == LT
-- | "ä" `compare` "b" == GT
-- | ```
-- |
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare
  :: Ordering
  -> Ordering
  -> Ordering
  -> String
  -> String
  -> Ordering

-- | Replaces the first occurence of the pattern with the replacement string.
-- |
-- | ```purescript
-- | replace (Pattern "<=") (Replacement "≤") "a <= b <= c" == "a ≤ b <= c"
-- | ```
-- |
foreign import replace :: Pattern -> Replacement -> String -> String

-- | Replaces all occurences of the pattern with the replacement string.
-- |
-- | ```purescript
-- | replaceAll (Pattern "<=") (Replacement "≤") "a <= b <= c" == "a ≤ b ≤ c"
-- | ```
-- |
foreign import replaceAll :: Pattern -> Replacement -> String -> String

-- | Returns the first `n` characters of the string.
-- |
-- | ```purescript
-- | take 5 "Hello World" == "Hello"
-- | ```
-- |
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
-- |
-- | ```purescript
-- | drop 6 "Hello World" == "World"
-- | ```
-- |
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
-- |
-- | ```purescript
-- | count (_ /= ' ') "Hello World" == 5 -- since length "Hello" == 5
-- | ```
-- |
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- |
-- | ```purescript
-- | split (Pattern " ") "hello world" == ["hello", "world"]
-- | ```
-- |
foreign import split :: Pattern -> String -> Array String

-- | Returns the substrings of a split at the given index, if the index is within bounds.
-- |
-- | ```purescript
-- | splitAt 2 "Hello World" == Just { before: "He", after: "llo World"}
-- | splitAt 10 "Hi" == Nothing
-- | ```
-- |
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt = _splitAt Just Nothing

foreign import _splitAt :: (forall a. a -> Maybe a)
                        -> (forall a. Maybe a)
                        -> Int
                        -> String
                        -> Maybe { before :: String, after :: String }

-- | Converts the string into an array of characters.
-- |
-- | ```purescript
-- | toCharArray "Hello☺\n" == ['H','e','l','l','o','☺','\n']
-- | ```
-- |
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
-- |
-- | ```purescript
-- | toLower "hElLo" == "hello"
-- | ```
-- |
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
-- |
-- | ```purescript
-- | toUpper "Hello" == "HELLO"
-- | ```
-- |
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
-- |
-- | ```purescript
-- | trim "   Hello  \n World\n\t    " == "Hello  \n World"
-- | ```
-- |
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
-- |
-- | ```purescript
-- | joinWith ", " ["apple", "banana", "orange"] == "apple, banana, orange"
-- | ```
-- |
foreign import joinWith :: String -> Array String -> String

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( Pattern(..)
  , Replacement(..)
  , charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , replaceAll
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , stripSuffix
  , count
  , split
  , splitAt
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype)
import Data.String.Unsafe as U

-- | A newtype used in cases where there is a string to be matched.
newtype Pattern = Pattern String

derive instance eqPattern :: Eq Pattern
derive instance ordPattern :: Ord Pattern
derive instance newtypePattern :: Newtype Pattern _

instance showPattern :: Show Pattern where
  show (Pattern s) = "(Pattern " <> show s <> ")"

-- | A newtype used in cases to specify a replacement for a pattern.
newtype Replacement = Replacement String

derive instance eqReplacement :: Eq Replacement
derive instance ordReplacement :: Ord Replacement
derive instance newtypeReplacement :: Newtype Replacement _

instance showReplacement :: Show Replacement where
  show (Replacement s) = "(Replacement " <> show s <> ")"

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Char

-- | Returns a string of length `1` containing the given character.
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
-- | - `charCodeAt 2 "5 €" == Just 0x20AC`
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

foreign import _charCodeAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Int

-- | Converts the string to a character, if the length of the string is
-- | exactly `1`.
toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> String
  -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = s == ""

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate.
-- | * `takeWhile (_ /= ':') "http://purescript.org" == "http"`
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix (Pattern "http:") "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix (Pattern "http:") "https://purescript.org" == Nothing`
stripPrefix :: Pattern -> String -> Maybe String
stripPrefix prefix@(Pattern prefixS) str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefixS) str
    _ -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a `Just` value. Otherwise, return
-- | `Nothing`.
-- | * `stripSuffix (Pattern ".exe") "psc.exe" == Just "psc"`
-- | * `stripSuffix (Pattern ".exe") "psc" == Nothing`
stripSuffix :: Pattern -> String -> Maybe String
stripSuffix suffix@(Pattern suffixS) str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffixS -> Just $ take x str
    _ -> Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the pattern appears in the given string.
-- | * `contains (Pattern "needle") "haystack with needle" == true`
-- | * `contains (Pattern "needle") "haystack" == false`
contains :: Pattern -> String -> Boolean
contains pat = isJust <<< indexOf pat

-- | Returns the index of the first occurrence of the pattern in the
-- | given string. Returns `Nothing` if there is no match.
-- | * `indexOf (Pattern "c") "abcde" == Just 2`
indexOf :: Pattern -> String -> Maybe Int
indexOf = _indexOf Just Nothing

foreign import _indexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the first occurrence of the pattern in the
-- | given string, starting at the specified index. Returns `Nothing` if there is
-- | no match.
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the pattern in the
-- | given string. Returns `Nothing` if there is no match.
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

foreign import _lastIndexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the pattern in the
-- | given string, starting at the specified index. Returns `Nothing`
-- | if there is no match.
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Compare two strings in a locale-aware fashion. This is in contrast to
-- | the `Ord` instance on `String` which treats strings as arrays of code
-- | units:
-- | - `"ä" `localeCompare` "b" == LT`
-- | - `"ä" `compare` "b" == GT`
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare
  :: Ordering
  -> Ordering
  -> Ordering
  -> String
  -> String
  -> Ordering

-- | Replaces the first occurence of the pattern with the replacement string.
-- | * `replace (Pattern "http") (Replacement "https") "http://purescript.org" == "https://purescript.org"`
foreign import replace :: Pattern -> Replacement -> String -> String

-- | Replaces all occurences of the pattern with the replacement string.
foreign import replaceAll :: Pattern -> Replacement -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- | * `split (Pattern " ") "hello world" == ["hello", "world"]`
foreign import split :: Pattern -> String -> Array String

-- | Returns the substrings of a split at the given index, if the index is within bounds.
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt = _splitAt Just Nothing

foreign import _splitAt :: (forall a. a -> Maybe a)
                        -> (forall a. Maybe a)
                        -> Int
                        -> String
                        -> Maybe { before :: String, after :: String }

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
-- | * `joinWith ", " ["apple", "banana", "orange"] == "apple, banana, orange"`
foreign import joinWith :: String -> Array String -> String


filter out SNPs whose pos < zero

filter out SNPs whose pos < zero

module Genetics.Browser.Track.Demo where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (blue, navy, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgrey)
import Control.Coroutine (Producer, transform, ($~), (~~))
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.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Foldable (class Foldable, any, fold, foldMap, or)
import Data.Lens (view, (^?))
import Data.Lens.Index (ix)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing))
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.String as String
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Data.Variant (inj)
import Genetics.Browser.Track.Backend (DrawingN, DrawingV, Feature, LegendEntry, NPoint, OldRenderer, RenderedTrack, Label, _range, _single, groupToMap, mkIcon, negLog10, trackLegend, zipMapsWith)
import Genetics.Browser.Track.Bed (ParsedLine, chunkProducer, fetchBed, fetchForeignChunks, parsedLineTransformer)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), _Segments, aroundPair, pairSize, pairsOverlap)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Network.HTTP.Affjax as Affjax

type BedFeature = Feature { thickRange :: Pair Bp
                          , blocks :: Array (Pair Bp)
                          , geneId :: String
                          , geneName :: String
                          , chrId :: ChrId }

bedToFeature :: CoordSys ChrId BigInt -> ParsedLine -> Maybe BedFeature
bedToFeature cs pl = do
  seg@(Pair offset _ ) <- cs ^? _Segments <<< ix pl.chrom

  -- TODO validate ranges maybe, idk
  let toBp :: BigInt -> Bp
      toBp = wrap <<< BigInt.toNumber

      frameSize = toBp $ pairSize seg
      position = toBp  <$> Pair pl.chromStart pl.chromEnd
      thickRange = toBp  <$> Pair pl.thickStart pl.thickEnd

      blocks = Array.zipWith
                 (\start size -> map toBp (Pair start size))
                 pl.blockStarts pl.blockSizes

  pure { position
       , frameSize
       , feature: { thickRange
                  , blocks
                  , geneId: pl.geneId
                  , geneName: pl.geneName
                  , chrId: pl.chrom
                  }
       }

getGenes :: CoordSys ChrId BigInt
         -> String
         -> Aff _ (Map ChrId (Array BedFeature))
getGenes cs url = do
  ls <- fetchBed url

  let fs = filterMap (bedToFeature cs) ls

  pure $ groupToMap _.feature.chrId $ fs

produceGenes :: CoordSys ChrId BigInt -> String
             -> Aff _
                (Producer
                 (Map ChrId (Array BedFeature))
                 (Aff _) Unit)
produceGenes cs url = do
  prod <- fetchForeignChunks url

  pure
    $ prod
    $~ parsedLineTransformer
    ~~ transform
       (groupToMap _.feature.chrId <<< filterMap (bedToFeature cs))

bedDraw :: BedFeature
        -> DrawingV
bedDraw gene = inj _range \w ->
  let (Pair l r) = gene.position
      toLocal x = w * (unwrap $ x / gene.frameSize)

      width = toLocal (r - l)

      exon block =
        let p@(Pair exL' size') = toLocal <$> block
            s = rectangle exL' zero size' 30.0
        in (outlined (outlineColor darkgrey <> lineWidth 1.0) s)
        <> (filled (fillColor lightgrey) s)

      introns _ =
        let s = rectangle 1.5 14.0 (width-1.5) 2.0
        in outlined (outlineColor black <> lineWidth 3.0) s
        <> filled   (fillColor black) s

      label _ =
        Drawing.text
          (font sansSerif 12 mempty)
             (2.5) (35.0)
             (fillColor black) gene.feature.geneName

      drawing =
        if width < one
        then mempty
        else \_ -> introns unit
                <> foldMap exon gene.feature.blocks
                <> label unit

  in { drawing, width }

geneRenderer :: OldRenderer BedFeature
geneRenderer = inj _single { draw: bedDraw, horPlace, verPlace: const (Normalized 0.10) }
  where horPlace {position, frameSize} =
          let f p = Normalized (unwrap $ p / frameSize)
          in inj _range $ map f position

fetchJsonChunks :: String
                -> Aff _ (Producer (Array Json) (Aff _) Unit)
fetchJsonChunks url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just ls -> pure $ chunkProducer 512 ls

featureProd :: ∀ r1 r2.
               String
            -> (Json -> Maybe { feature :: { chrId :: ChrId | r1 } | r2 })
            -> Aff _
                 (Producer
                 (Map ChrId (Array { feature :: { chrId :: ChrId | r1 } | r2 }))
                 (Aff _) Unit)
featureProd url parse = do
  prod <- fetchJsonChunks url
  pure $ prod $~ (transform $ groupToMap _.feature.chrId <<< filterMap parse)

-- TODO bundle up all the producers into one function on a record of URLs
--      to a record of producers (maprecord? applyrecord?)
produceGWAS :: CoordSys ChrId _
            -> String
            -> Aff _
               (Producer
                (Map ChrId
                 (Array (GWASFeature ())))
                 (Aff _) Unit)
produceGWAS cs url = featureProd url $ gemmaJSONParse cs

produceAnnots :: CoordSys ChrId _
              -> String
              -> Aff _
                 (Producer
                  (Map ChrId
                   (Array (Annot ())))
                   (Aff _) Unit)
produceAnnots cs url = featureProd url $ (annotJSONParse cs)

fetchJSON :: ∀ 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

type GWASFeature r = Feature { score :: Number
                             , chrId :: ChrId
                             , name  :: String | r }

gemmaJSONParse :: CoordSys ChrId BigInt
               -> 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 "p_wald"  <<< _Number
  name  <-           obj ^? ix "rs"  <<< _String

  chrSize <- (Bp <<< BigInt.toNumber <<< pairSize) <$> Map.lookup chrId (view _Segments cs)

  pure { position: Pair pos pos
       , frameSize: chrSize
       , feature: { score, chrId, name }
       }

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

annotJSONParse :: CoordSys ChrId BigInt
              -> Json
              -> Maybe (Annot ())
annotJSONParse 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 <- (Bp <<< BigInt.toNumber <<< pairSize) <$> Map.lookup chrId (view _Segments cs)

  pure { position: Pair start end
       , frameSize: chrSize
       , feature: { geneID, desc, name, chrId }
       }

fetchAnnotJSON :: CoordSys ChrId BigInt -> String
               -> Aff _ (Array (Annot ()))
fetchAnnotJSON cs str = fetchJSON (annotJSONParse cs) str

getGWAS :: CoordSys ChrId BigInt -> String
        -> Aff _ (Map ChrId (Array (GWASFeature ())))
getGWAS cs url = groupToMap _.feature.chrId
                  <$> filter (\f -> Pair.fst (f.position) >= wrap zero)
                  <$> fetchJSON (gemmaJSONParse cs) url

getAnnotations :: CoordSys ChrId BigInt -> String
               -> Aff _ (Map ChrId (Array (Annot ())))
getAnnotations cs url = groupToMap _.feature.chrId
                        <$> fetchAnnotJSON cs url

getAnnotations' :: CoordSys ChrId BigInt
                -> String
                -> Aff _ (Array (Annot ()))
getAnnotations' = fetchAnnotJSON

inRangeOf :: ∀ rA rB.
             Bp
          -> { position :: Pair Bp | rA }
          -> { position :: Pair Bp | rB }
          -> Boolean
inRangeOf r a b = pairsOverlap a.position
                             $ r `aroundPair` b.position

interestingAnnots :: ∀ rA rS f.
                     Filterable f
                  => Bp
                  -> Map ChrId (Array (GWASFeature rS))
                  -> f (Annot rA)
                  -> f (Annot rA)
interestingAnnots radius snps = filter (any (any (inRangeOf radius)) snps)

-- TODO Configgable Annotation -> LegendEntry function (somehow?!)
annotLegendEntry :: ∀ r. Annot r -> LegendEntry
annotLegendEntry a =
  if (String.length a.feature.name) `mod` 2 == 0
    then mkIcon blue "even name"
    else mkIcon red  "odd name"

annotLegendTest :: ∀ 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

------------ new renderers~~~~~~~~~

placeScored :: ∀ r1 r2.
            { min :: Number, max :: Number | r1 }
         -> Feature { score :: Number | r2 }
         -> NPoint
placeScored {min, max} { frameSize, position: (Pair l _), feature } = {x, y}
  where x = Normalized $ unwrap $ l / frameSize
        y = Normalized $ ((negLog10 feature.score) - min) / (max - min)

dist :: Point -> Point -> Number
dist p1 p2 = Math.sqrt $ x' `Math.pow` 2.0 + y' `Math.pow` 2.0
  where x' = p1.x - p2.x
        y' = p1.y - p2.y

filterSig :: ∀ r1 r2.
             { sig :: Number | r1 }
          -> Map ChrId (Array (GWASFeature r2))
          -> Map ChrId (Array (GWASFeature r2))
filterSig {sig} = map (filter isSignificant)
  where sig' = 10.0 `Math.pow` (-sig)
        isSignificant {feature} = feature.score <= sig'

renderGWAS :: ∀ r.
              { min :: Number, max :: Number | r }
           -> Canvas.Dimensions
           -> Map ChrId (Array (GWASFeature ()))
           -> Map ChrId (Pair Number)
           -> RenderedTrack (GWASFeature ())
renderGWAS verscale cdim snps =
  let features :: Array (GWASFeature ())
      features = fold snps

      radius = 3.75

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

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

      npointed :: Map ChrId (Array (Tuple (GWASFeature ()) NPoint))
      npointed = (map <<< map) (fanout id (placeScored verscale)) snps

      rescale :: Pair Number -> NPoint -> Point
      rescale seg npoint =
        let (Pair offset _) = seg
            x = offset + (pairSize seg) * (unwrap npoint.x)
            y = cdim.height * (one - unwrap npoint.y)
        in {x, y}

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (GWASFeature ()) Point)
      pointed segs = fold $ zipMapsWith (\s p -> (map <<< map) (rescale s) p) segs npointed

      overlaps :: Array (Tuple (GWASFeature ()) Point)
               -> Number -> Point
               -> Array (GWASFeature ())
      overlaps pts radius' pt = filterMap covers pts
        where covers :: Tuple (GWASFeature ()) Point -> Maybe (GWASFeature ())
              covers (Tuple f fPt)
                | dist fPt pt <= radius + radius'   = Just f
                | otherwise = Nothing

  in \seg -> let pts = pointed seg
             in { features
                , drawings: drawings pts
                , labels: mempty
                , overlaps: overlaps pts }

renderAnnot :: ∀ r.
               { min :: Number, max :: Number | r }
            -> Canvas.Dimensions
            -> Map ChrId (Array (Annot (score :: Number)))
            -> Map ChrId (Pair Number)
            -> RenderedTrack (Annot (score :: Number))
renderAnnot verscale cdim annots =
  let features :: Array (Annot (score :: Number))
      features = fold annots

      tailHeight = 0.15

      drawing :: Tuple (Annot (score :: Number)) Point -> DrawingN
      drawing (Tuple an pt) = { drawing: tail <> lg.icon , points: [pt] }
        where lg = annotLegendEntry an
              tail = Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                     $ Drawing.path
                       [ {x: 0.0, y: 0.0 }
                       , {x: 0.0, y: tailHeight * cdim.height }]

      drawings :: Array (Tuple (Annot (score :: Number)) Point) -> Array DrawingN
      drawings = map drawing

      label :: Tuple (Annot (score :: Number)) Point -> Label
      label (Tuple an {x,y}) =
        { text: an.feature.name
        , point: { x, y: y - 12.0 }  }

      labels :: Array (Tuple (Annot (score :: Number)) Point) -> Array Label
      labels = map label

      npointed :: Map ChrId (Array (Tuple (Annot (score :: Number)) NPoint))
      npointed = (map <<< map) (fanout id place) annots
        where place p = let p' = placeScored verscale p
                        in { x: p'.x
                           , y: Normalized $ min 1.0 (unwrap p'.y + tailHeight) }

      rescale :: Pair Number -> NPoint -> Point
      rescale seg npoint =
        let (Pair offset _) = seg
            x = offset + (pairSize seg) * (unwrap npoint.x)
            y = cdim.height * (one - unwrap npoint.y)
        in {x, y}

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (Annot (score :: Number)) Point)
      pointed segs = fold $ zipMapsWith (\s p -> (map <<< map) (rescale s) p) segs npointed

      overlaps :: Number -> Point -> Array (Annot (score :: Number))
      overlaps r p = mempty

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

module Genetics.Browser.Track.Demo where

import Prelude

import Color (Color, black)
import Color.Scheme.Clrs (blue, navy, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgrey)
import Control.Coroutine (Producer, transform, ($~), (~~))
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.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Foldable (class Foldable, any, fold, foldMap, or)
import Data.Lens (view, (^?))
import Data.Lens.Index (ix)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing))
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Strong (fanout)
import Data.String as String
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Data.Variant (inj)
import Genetics.Browser.Track.Backend (DrawingN, DrawingV, Feature, LegendEntry, NPoint, OldRenderer, RenderedTrack, Label, _range, _single, groupToMap, mkIcon, negLog10, trackLegend, zipMapsWith)
import Genetics.Browser.Track.Bed (ParsedLine, chunkProducer, fetchBed, fetchForeignChunks, parsedLineTransformer)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), _Segments, aroundPair, pairSize, pairsOverlap)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math as Math
import Network.HTTP.Affjax as Affjax

type BedFeature = Feature { thickRange :: Pair Bp
                          , blocks :: Array (Pair Bp)
                          , geneId :: String
                          , geneName :: String
                          , chrId :: ChrId }

bedToFeature :: CoordSys ChrId BigInt -> ParsedLine -> Maybe BedFeature
bedToFeature cs pl = do
  seg@(Pair offset _ ) <- cs ^? _Segments <<< ix pl.chrom

  -- TODO validate ranges maybe, idk
  let toBp :: BigInt -> Bp
      toBp = wrap <<< BigInt.toNumber

      frameSize = toBp $ pairSize seg
      position = toBp  <$> Pair pl.chromStart pl.chromEnd
      thickRange = toBp  <$> Pair pl.thickStart pl.thickEnd

      blocks = Array.zipWith
                 (\start size -> map toBp (Pair start size))
                 pl.blockStarts pl.blockSizes

  pure { position
       , frameSize
       , feature: { thickRange
                  , blocks
                  , geneId: pl.geneId
                  , geneName: pl.geneName
                  , chrId: pl.chrom
                  }
       }

getGenes :: CoordSys ChrId BigInt
         -> String
         -> Aff _ (Map ChrId (Array BedFeature))
getGenes cs url = do
  ls <- fetchBed url

  let fs = filterMap (bedToFeature cs) ls

  pure $ groupToMap _.feature.chrId $ fs

produceGenes :: CoordSys ChrId BigInt -> String
             -> Aff _
                (Producer
                 (Map ChrId (Array BedFeature))
                 (Aff _) Unit)
produceGenes cs url = do
  prod <- fetchForeignChunks url

  pure
    $ prod
    $~ parsedLineTransformer
    ~~ transform
       (groupToMap _.feature.chrId <<< filterMap (bedToFeature cs))

bedDraw :: BedFeature
        -> DrawingV
bedDraw gene = inj _range \w ->
  let (Pair l r) = gene.position
      toLocal x = w * (unwrap $ x / gene.frameSize)

      width = toLocal (r - l)

      exon block =
        let p@(Pair exL' size') = toLocal <$> block
            s = rectangle exL' zero size' 30.0
        in (outlined (outlineColor darkgrey <> lineWidth 1.0) s)
        <> (filled (fillColor lightgrey) s)

      introns _ =
        let s = rectangle 1.5 14.0 (width-1.5) 2.0
        in outlined (outlineColor black <> lineWidth 3.0) s
        <> filled   (fillColor black) s

      label _ =
        Drawing.text
          (font sansSerif 12 mempty)
             (2.5) (35.0)
             (fillColor black) gene.feature.geneName

      drawing =
        if width < one
        then mempty
        else \_ -> introns unit
                <> foldMap exon gene.feature.blocks
                <> label unit

  in { drawing, width }

geneRenderer :: OldRenderer BedFeature
geneRenderer = inj _single { draw: bedDraw, horPlace, verPlace: const (Normalized 0.10) }
  where horPlace {position, frameSize} =
          let f p = Normalized (unwrap $ p / frameSize)
          in inj _range $ map f position

fetchJsonChunks :: String
                -> Aff _ (Producer (Array Json) (Aff _) Unit)
fetchJsonChunks url = do
  json <- _.response <$> Affjax.get url

  case json ^? _Array of
    Nothing -> throwError $ error "Parse error: JSON is not an array"
    Just ls -> pure $ chunkProducer 512 ls

featureProd :: ∀ r1 r2.
               String
            -> (Json -> Maybe { feature :: { chrId :: ChrId | r1 } | r2 })
            -> Aff _
                 (Producer
                 (Map ChrId (Array { feature :: { chrId :: ChrId | r1 } | r2 }))
                 (Aff _) Unit)
featureProd url parse = do
  prod <- fetchJsonChunks url
  pure $ prod $~ (transform $ groupToMap _.feature.chrId <<< filterMap parse)

-- TODO bundle up all the producers into one function on a record of URLs
--      to a record of producers (maprecord? applyrecord?)
produceGWAS :: CoordSys ChrId _
            -> String
            -> Aff _
               (Producer
                (Map ChrId
                 (Array (GWASFeature ())))
                 (Aff _) Unit)
produceGWAS cs url = featureProd url $ gemmaJSONParse cs

produceAnnots :: CoordSys ChrId _
              -> String
              -> Aff _
                 (Producer
                  (Map ChrId
                   (Array (Annot ())))
                   (Aff _) Unit)
produceAnnots cs url = featureProd url $ (annotJSONParse cs)

fetchJSON :: ∀ 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

type GWASFeature r = Feature { score :: Number
                             , chrId :: ChrId
                             , name  :: String | r }

gemmaJSONParse :: CoordSys ChrId BigInt
               -> 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 "p_wald"  <<< _Number
  name  <-           obj ^? ix "rs"  <<< _String

  chrSize <- (Bp <<< BigInt.toNumber <<< pairSize) <$> Map.lookup chrId (view _Segments cs)

  pure { position: Pair pos pos
       , frameSize: chrSize
       , feature: { score, chrId, name }
       }

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

annotJSONParse :: CoordSys ChrId BigInt
              -> Json
              -> Maybe (Annot ())
annotJSONParse 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 <- (Bp <<< BigInt.toNumber <<< pairSize) <$> Map.lookup chrId (view _Segments cs)

  pure { position: Pair start end
       , frameSize: chrSize
       , feature: { geneID, desc, name, chrId }
       }

fetchAnnotJSON :: CoordSys ChrId BigInt -> String
               -> Aff _ (Array (Annot ()))
fetchAnnotJSON cs str = fetchJSON (annotJSONParse cs) str

getGWAS :: CoordSys ChrId BigInt -> String
        -> Aff _ (Map ChrId (Array (GWASFeature ())))
getGWAS cs url = groupToMap _.feature.chrId
                  <$> fetchJSON (gemmaJSONParse cs) url

getAnnotations :: CoordSys ChrId BigInt -> String
               -> Aff _ (Map ChrId (Array (Annot ())))
getAnnotations cs url = groupToMap _.feature.chrId
                        <$> fetchAnnotJSON cs url

getAnnotations' :: CoordSys ChrId BigInt
                -> String
                -> Aff _ (Array (Annot ()))
getAnnotations' = fetchAnnotJSON

inRangeOf :: ∀ rA rB.
             Bp
          -> { position :: Pair Bp | rA }
          -> { position :: Pair Bp | rB }
          -> Boolean
inRangeOf r a b = pairsOverlap a.position
                             $ r `aroundPair` b.position

interestingAnnots :: ∀ rA rS f.
                     Filterable f
                  => Bp
                  -> Map ChrId (Array (GWASFeature rS))
                  -> f (Annot rA)
                  -> f (Annot rA)
interestingAnnots radius snps = filter (any (any (inRangeOf radius)) snps)

-- TODO Configgable Annotation -> LegendEntry function (somehow?!)
annotLegendEntry :: ∀ r. Annot r -> LegendEntry
annotLegendEntry a =
  if (String.length a.feature.name) `mod` 2 == 0
    then mkIcon blue "even name"
    else mkIcon red  "odd name"

annotLegendTest :: ∀ 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

------------ new renderers~~~~~~~~~

placeScored :: ∀ r1 r2.
            { min :: Number, max :: Number | r1 }
         -> Feature { score :: Number | r2 }
         -> NPoint
placeScored {min, max} { frameSize, position: (Pair l _), feature } = {x, y}
  where x = Normalized $ unwrap $ l / frameSize
        y = Normalized $ ((negLog10 feature.score) - min) / (max - min)

dist :: Point -> Point -> Number
dist p1 p2 = Math.sqrt $ x' `Math.pow` 2.0 + y' `Math.pow` 2.0
  where x' = p1.x - p2.x
        y' = p1.y - p2.y

filterSig :: ∀ r1 r2.
             { sig :: Number | r1 }
          -> Map ChrId (Array (GWASFeature r2))
          -> Map ChrId (Array (GWASFeature r2))
filterSig {sig} = map (filter isSignificant)
  where sig' = 10.0 `Math.pow` (-sig)
        isSignificant {feature} = feature.score <= sig'

renderGWAS :: ∀ r.
              { min :: Number, max :: Number | r }
           -> Canvas.Dimensions
           -> Map ChrId (Array (GWASFeature ()))
           -> Map ChrId (Pair Number)
           -> RenderedTrack (GWASFeature ())
renderGWAS verscale cdim snps =
  let features :: Array (GWASFeature ())
      features = fold snps

      radius = 3.75

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

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

      npointed :: Map ChrId (Array (Tuple (GWASFeature ()) NPoint))
      npointed = (map <<< map) (fanout id (placeScored verscale)) snps

      rescale :: Pair Number -> NPoint -> Point
      rescale seg npoint =
        let (Pair offset _) = seg
            x = offset + (pairSize seg) * (unwrap npoint.x)
            y = cdim.height * (one - unwrap npoint.y)
        in {x, y}

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (GWASFeature ()) Point)
      pointed segs = fold $ zipMapsWith (\s p -> (map <<< map) (rescale s) p) segs npointed

      overlaps :: Array (Tuple (GWASFeature ()) Point)
               -> Number -> Point
               -> Array (GWASFeature ())
      overlaps pts radius' pt = filterMap covers pts
        where covers :: Tuple (GWASFeature ()) Point -> Maybe (GWASFeature ())
              covers (Tuple f fPt) =
                if dist fPt pt <= radius + radius' then Just f else Nothing

  in \seg -> let pts = pointed seg
             in { features
                , drawings: drawings pts
                , labels: mempty
                , overlaps: overlaps pts }

renderAnnot :: ∀ r.
               { min :: Number, max :: Number | r }
            -> Canvas.Dimensions
            -> Map ChrId (Array (Annot (score :: Number)))
            -> Map ChrId (Pair Number)
            -> RenderedTrack (Annot (score :: Number))
renderAnnot verscale cdim annots =
  let features :: Array (Annot (score :: Number))
      features = fold annots

      tailHeight = 0.15

      drawing :: Tuple (Annot (score :: Number)) Point -> DrawingN
      drawing (Tuple an pt) = { drawing: tail <> lg.icon , points: [pt] }
        where lg = annotLegendEntry an
              tail = Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                     $ Drawing.path
                       [ {x: 0.0, y: 0.0 }
                       , {x: 0.0, y: tailHeight * cdim.height }]

      drawings :: Array (Tuple (Annot (score :: Number)) Point) -> Array DrawingN
      drawings = map drawing

      label :: Tuple (Annot (score :: Number)) Point -> Label
      label (Tuple an {x,y}) =
        { text: an.feature.name
        , point: { x, y: y - 12.0 }  }

      labels :: Array (Tuple (Annot (score :: Number)) Point) -> Array Label
      labels = map label

      npointed :: Map ChrId (Array (Tuple (Annot (score :: Number)) NPoint))
      npointed = (map <<< map) (fanout id place) annots
        where place p = let p' = placeScored verscale p
                        in { x: p'.x
                           , y: Normalized $ min 1.0 (unwrap p'.y + tailHeight) }

      rescale :: Pair Number -> NPoint -> Point
      rescale seg npoint =
        let (Pair offset _) = seg
            x = offset + (pairSize seg) * (unwrap npoint.x)
            y = cdim.height * (one - unwrap npoint.y)
        in {x, y}

      pointed :: Map ChrId (Pair Number)
              -> Array (Tuple (Annot (score :: Number)) Point)
      pointed segs = fold $ zipMapsWith (\s p -> (map <<< map) (rescale s) p) segs npointed

      overlaps :: Number -> Point -> Array (Annot (score :: Number))
      overlaps r p = mempty

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


Refactor to add extra data to result

Refactor to add extra data to result

module Benchotron
  ( Benchmark()
  , runBenchmark
  , benchmarkToFile
  , benchmarkToStdout
  , BenchEffects()
  , BenchmarkResult()
  , ResultSeries()
  , DataPoint()
  , Stats()
  , Any()
  , toAny
  ) where

import Data.Exists
import Data.Identity
import Data.Tuple
import Data.Array (map, filter, (..), length)
import Data.Array.Unsafe (head)
import Data.String (joinWith)
import Data.Traversable (for)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (Exception())
import Node.FS (FS())
import Node.FS.Sync (writeTextFile)
import Node.Encoding (Encoding(..))

type Benchmark e a =
  { name               :: String
  , sizes              :: Array Number
  , sizeInterpretation :: String
  , inputsPerSize      :: Number
  , gen                :: Number -> Eff (BenchEffects e) a
  , functions          :: Array { name                     :: String, fn :: a -> Any }
  }

runBenchmark :: forall e a. Benchmark e a -> Eff (BenchEffects e) BenchmarkResult
runBenchmark benchmark = do
  let countSizes = length benchmark.sizes
  results <- for (withIndices benchmark.sizes) $ \(Tuple idx size) -> do
    stderrWrite $ joinWith "" [" Benchmarking... n="
                              , show size
                              , " ("
                              , show idx
                              , "/"
                              , show countSizes
                              , ") \r"
                              ]

    inputs <- for (1..benchmark.inputsPerSize) (const (benchmark.gen size))
    allStats <- for benchmark.functions $ \function -> do
      let f _ = map function.fn inputs
      stats <- runBenchmarkImpl f
      return { name: function.name, stats: stats }

    return { size: size, allStats: allStats }

  let series = rejig results
  return
    { name: benchmark.name
    , sizeInterpretation: benchmark.sizeInterpretation
    , series: series
    }

  where
  withIndices arr = zip (1..(length arr)) arr

benchmarkToFile :: forall e a. Benchmark e a -> String -> Eff (BenchEffects e) Unit
benchmarkToFile bench path = do
  results <- runBenchmark bench
  writeTextFile UTF8 path $ jsonStringify results

benchmarkToStdout :: forall e a. Benchmark e a -> Eff (BenchEffects e) Unit
benchmarkToStdout bench = do
  results <- runBenchmark bench
  stdoutWrite $ jsonStringify results

type BenchEffects e
  = ( err :: Exception
    , fs :: FS
    | e
    )

type BenchmarkResult =
  { name               :: String
  , sizeInterpretation :: String
  , series             :: Array ResultSeries
  }

type ResultSeries =
  { name    :: String
  , results :: Array DataPoint
  }

type DataPoint =
  { size  :: Number
  , stats :: Stats
  }

type Stats =
  { deviation :: Number
  , mean      :: Number
  , moe       :: Number
  , rme       :: Number
  , sample    :: Array Number
  , sem       :: Number
  , variance  :: Number
  }

type Any = Exists Identity

toAny :: forall a. a -> Any
toAny = mkExists <<< Identity

type IntermediateResult =
  Array { size :: Number, allStats :: Array { name :: String, stats :: Stats } }

rejig :: IntermediateResult -> Array ResultSeries
rejig [] = []
rejig results = map toSeries names
  where
  r = head results
  names = map _.name r.allStats
  toSeries name =
    { name: name
    , results: map (\o -> { size: o.size
                          , stats: _.stats $ the $ filter ((==) name <<< _.name) o.allStats
                          }) results
    }
  the [x] = x

foreign import runBenchmarkImpl
  """
  function runBenchmarkImpl(fn) {
    var Benchmark = require('benchmark')
    return function() {
      return Benchmark(fn).run().stats
    }
  }
  """ :: forall e r. (Unit -> r) -> Eff e Stats

foreign import jsonStringify
  """
  function jsonStringify(obj) {
    return JSON.stringify(obj)
  }
  """ :: BenchmarkResult -> String

foreign import stdoutWrite
  """
  function stdoutWrite(str) {
    return function() {
      process.stdout.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit

foreign import stderrWrite
  """
  function stderrWrite(str) {
    return function() {
      process.stderr.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit

module Benchotron
  ( Benchmark()
  , BenchEffects()
  , Stats()
  , ResultSeries()
  , Result()
  , runBenchmark
  , Any()
  , toAny
  , benchmarkToFile
  , benchmarkToStdout
  ) where

import Data.Exists
import Data.Identity
import Data.Tuple
import Data.Array (map, filter, (..), length)
import Data.Array.Unsafe (head)
import Data.String (joinWith)
import Data.Traversable (for)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (Exception())
import Node.FS (FS())
import Node.FS.Sync (writeTextFile)
import Node.Encoding (Encoding(..))

type Benchmark e a =
  { name          :: String
  , sizes         :: Array Number
  , inputsPerSize :: Number
  , gen           :: Number -> Eff (BenchEffects e) a
  , functions     :: Array { name :: String, fn :: a -> Any }
  }

type BenchEffects e
  = ( err :: Exception
    , fs :: FS
    | e
    )

type Stats =
  { deviation :: Number
  , mean      :: Number
  , moe       :: Number
  , rme       :: Number
  , sample    :: Array Number
  , sem       :: Number
  , variance  :: Number
  }

type ResultSeries =
  { name    :: String
  , results :: Array Result
  }

type Result =
  { size  :: Number
  , stats :: Stats
  }

runBenchmark :: forall e a. Benchmark e a -> Eff (BenchEffects e) (Array ResultSeries)
runBenchmark benchmark = do
  let countSizes = length benchmark.sizes
  results <- for (withIndices benchmark.sizes) $ \(Tuple idx size) -> do
    stderrWrite $ joinWith "" [" Benchmarking... n="
                              , show size
                              , " ("
                              , show idx
                              , "/"
                              , show countSizes
                              , ") \r"
                              ]

    inputs <- for (1..benchmark.inputsPerSize) (const (benchmark.gen size))
    allStats <- for benchmark.functions $ \function -> do
      let f _ = map function.fn inputs
      stats <- runBenchmarkImpl f
      return { name: function.name, stats: stats }

    return { size: size, allStats: allStats }

  return $ rejig results

  where
  withIndices arr = zip (1..(length arr)) arr

type Any = Exists Identity

toAny :: forall a. a -> Any
toAny = mkExists <<< Identity

type IntermediateResult =
  Array { size :: Number, allStats :: Array { name :: String, stats :: Stats } }

rejig :: IntermediateResult -> Array ResultSeries
rejig [] = []
rejig results = map toSeries names
  where
  r = head results
  names = map _.name r.allStats
  toSeries name =
    { name: name
    , results: map (\o -> { size: o.size
                          , stats: _.stats $ the $ filter ((==) name <<< _.name) o.allStats
                          }) results
    }
  the [x] = x

benchmarkToFile :: forall e a. Benchmark e a -> String -> Eff (BenchEffects e) Unit
benchmarkToFile bench path = do
  results <- runBenchmark bench
  writeTextFile UTF8 path $ jsonStringify results

benchmarkToStdout :: forall e a. Benchmark e a -> Eff (BenchEffects e) Unit
benchmarkToStdout bench = do
  results <- runBenchmark bench
  stdoutWrite $ jsonStringify results

foreign import runBenchmarkImpl
  """
  function runBenchmarkImpl(fn) {
    var Benchmark = require('benchmark')
    return function() {
      return Benchmark(fn).run().stats
    }
  }
  """ :: forall e r. (Unit -> r) -> Eff e Stats

foreign import jsonStringify
  """
  function jsonStringify(obj) {
    return JSON.stringify(obj)
  }
  """ :: Array ResultSeries -> String

foreign import stdoutWrite
  """
  function stdoutWrite(str) {
    return function() {
      process.stdout.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit

foreign import stderrWrite
  """
  function stderrWrite(str) {
    return function() {
      process.stderr.write(str)
    }
  } """ :: forall e. String -> Eff (BenchEffects e) Unit


making the input not disappear on parse failure

module Component.App
  ( appClass
  , AppProps(..)
  ) where

import Prelude

import Data.Maybe
import Data.Either
import Data.Tuple
import Data.Array (uncons, cons, snoc, filter, singleton, reverse, null)
import Data.List (toList)
import Data.Foldable (intercalate)
import qualified Data.Map as Map
import qualified Data.Set as Set

import Data.Syntax
import Data.Expr
import Data.Parse
import Data.PrettyPrint

import Text.Parsing.Parser (ParseError(..))

import Control.Monad.Eff
import Control.Monad.Eff.Save

import qualified Thermite as T
import qualified Thermite.Action as T

import qualified React as R
import qualified React.DOM as RD
import qualified React.DOM.Props as RP

import Component.Event

data Level = Warning | Danger

instance showLevel :: Show Level where
  show Warning = "warning"
  show Danger  = "danger"

type AppState =
  { text    :: String
  , expr    :: Maybe Expr
  , history :: Array String
  , defs    :: Array Definition
  , env     :: Environment
  , error   :: Maybe (Tuple Level String)
  }

data AppAction
  = DoNothing
  | NewText String
  | ParseText
  | Reduce Expr
  | DismissAlert
  | Remove Name
  | Clear
  | Save

type AppProps = Unit

appClass :: R.ReactClass AppProps
appClass = T.createClass (T.simpleSpec initialState update render)

initialDefs :: Array Definition
initialDefs =
  [ { name: "i"
    , syntax: unsafeParse parseSyntax "λx. x"
    }
  , { name: "k"
    , syntax: unsafeParse parseSyntax "λx. λy. x"
    }
  , { name: "fix"
    , syntax: unsafeParse parseSyntax "λf. (λx. f (x x)) (λy. f (y y))"
    }
  ]

initialEnv :: Environment
initialEnv = Map.fromList (toList (map fromDef initialDefs))
 where
  fromDef def = Tuple def.name (syntaxToExpr def.syntax)

initialState :: AppState
initialState =
  { text: ""
  , expr: Nothing
  , history: []
  , defs: initialDefs
  , env: initialEnv
  , error: Nothing
  }

update :: T.PerformAction _ AppState _ AppAction
update props action =
  case action of
    DoNothing ->
      return unit
    NewText text ->
      T.modifyState (\s -> s { text = text, error = Nothing })
    DismissAlert ->
      T.modifyState (\s -> s { error = Nothing })
    Remove name ->
      T.modifyState (remove name)
    ParseText ->
      T.modifyState parse
    Reduce expr ->
      T.modifyState (reduce expr)
    Clear ->
      T.modifyState clear
    Save -> do
      s <- T.getState
      T.async \k -> do
        let text = intercalate "\n" (map defToString s.defs <> reverse s.history)
        saveTextAs text "evaluation.txt"
        k unit
     where
      defToString def = def.name <> " = " <> prettyPrint def.syntax

fail :: String -> AppState -> AppState
fail message s =
  s { error = Just (Tuple Danger message) }

parse :: AppState -> AppState
parse s
  | s.text == "" = s
parse s =
  case parseAll parseEither s.text of
    Left error   ->
      fail (formatParseError s.text error) s
    Right (Left def) ->
      addDef def s
    Right (Right syntax) ->
      addExpr syntax s

remove :: String -> AppState -> AppState
remove name s =
  s { defs = deleteByName name s.defs, env = env', error = error }
 where
  env' = Map.delete name s.env
  names = namesReferencing name env'
  error = if Set.size names == 0
             then Nothing
             else Just (Tuple Warning (formatUndefinedWarning name names))

deleteByName :: Name -> Array Definition -> Array Definition
deleteByName name = filter (_.name >>> (/= name))

addDef :: Definition -> AppState -> AppState
addDef def s =
  if Set.size missing == 0
    then
      s { text = "", defs = defs, env = env }
    else
      fail (formatUndefinedError s.text missing) s
 where
  defs = deleteByName def.name s.defs `snoc` def
  expr = syntaxToExpr def.syntax
  env = Map.insert def.name expr s.env
  missing = undefinedNames expr (Map.delete def.name s.env)

addExpr :: Syntax -> AppState -> AppState
addExpr syntax s =
  s { text = "", history = history, expr = expr }
 where
  history = [prettyPrint syntax]
  expr = Just (syntaxToExpr syntax)

reduce :: Expr -> AppState -> AppState
reduce expr s =
  case step s.env expr of
    Nothing -> s
    Just expr' ->
      s { history = prettyPrint (exprToSyntax expr') `cons` s.history, expr = Just expr' }

clear :: AppState -> AppState
clear s = s { history = maybe [] (exprToSyntax >>> prettyPrint >>> singleton) s.expr }

render :: T.Render _ AppState _ AppAction
render send state props _ =
  RD.div
    [ RP.className "container" ]
    [ RD.div
      [ RP.className "row" ]
      [ header ]
    , RD.div
      [ RP.className "row" ]
      (alert send state.error)
    , RD.div
      [ RP.className "row" ]
      [ input send state.text ]
    , RD.div
      [ RP.className "row" ]
      (renderDefs send state.defs)
    , RD.div
      [ RP.className "row" ]
      (renderExprs send state.history state.expr)
    , RD.div
      [ RP.className "row" ]
      [ footer ]
    ]

header :: R.ReactElement
header = RD.div
  [ RP.className "page-header" ]
  [ RD.h2'
    [ RD.text "Lambda Machine" ]
  ]

footer :: R.ReactElement
footer = RD.div'
  [ RD.hr' []
  , RD.a
    [ RP.href "https://github.com/cdparks/lambda-machine"
    , RP.className "pull-right"
    ]
    [ RD.text "Source on GitHub" ]
  ]

alert :: _ -> Maybe (Tuple Level String) -> Array R.ReactElement
alert send Nothing = []
alert send (Just (Tuple level error)) =
  [ RD.div
    [ RP.className "col-sm-12" ]
    [ RD.pre
      [ RP.className ("alert alert-" <> show level) ]
      [ RD.span
        [ RP.className "glyphicon glyphicon-remove pull-right"
        , RP.onClick \_ -> send DismissAlert
        ]
        []
      , RD.text error
      ]
    ]
  ]

input :: _ -> String -> R.ReactElement
input send value = RD.div
  [ RP.className "col-sm-12" ]
  [ RD.div
    [ RP.className "input-group" ]
    [ RD.input
      [ RP.className "form-control monospace-font"
      , RP.placeholder "<definition> or <expression>"
      , RP.value value
      , RP.onKeyUp (handleKeyPress >>> send)
      , RP.onChange (handleChangeEvent >>> send)
      ]
      []
    , RD.span
      [ RP.className "input-group-btn" ]
      [ RD.button
        [ RP.className "btn btn-default"
        , RP.onClick \_ -> send ParseText
        ]
        [ RD.text "Parse" ]
      ]
    ]
  ]

renderDefs :: _ -> Array Definition -> Array R.ReactElement
renderDefs send definitions =
  [ RD.h3' [ RD.text "Definitions" ]
  , RD.div
    [ RP.className "monospace-font col-sm-12" ]
    (map (renderDef send) definitions)
  ]

renderDef :: _ -> Definition -> R.ReactElement
renderDef send def = RD.h4'
  [ RD.div
    [ RP.className "glyphicon glyphicon-remove"
    , RP.onClick \_ -> send (Remove def.name)
    ]
    []
  , RD.text (" " <> def.name <> " = " <> prettyPrint def.syntax)
  ]

renderExprs :: _ -> Array String -> Maybe Expr -> Array R.ReactElement
renderExprs send history Nothing = []
renderExprs send history (Just expr) =
  [ RD.h3' [ RD.text "Evaluation" ]
  , RD.div
    [ RP.className "col-sm-12" ]
    [ RD.div
      [ RP.className "btn-group pull-right" ]
      [ RD.button
        [ RP.className "btn btn-default"
        , RP.onClick \_ -> send (Reduce expr)
        ]
        [ RD.text "Step" ]
      , RD.button
        [ RP.className "btn btn-default"
        , RP.onClick \_ -> send Clear
        ]
        [ RD.text "Clear" ]
      , RD.button
        [ RP.className "btn btn-default"
        , RP.onClick \_ -> send Save
        ]
        [ RD.text "Save" ]
      ]
    , RD.div
      [ RP.className "hide-overflow" ]
      [ RD.div
        [ RP.className "scroll-overflow monospace-font" ]
        (renderHistory history)
      ]
    ]
  ]

renderHistory :: Array String -> Array R.ReactElement
renderHistory hs =
  case uncons hs of
    Nothing -> []
    Just { head = head, tail = tail } ->
      RD.h4' [ RD.text head ] `cons` map renderSyntax tail

renderSyntax :: String -> R.ReactElement
renderSyntax syntax = RD.h4
  [ RP.className "text-muted" ]
  [ RD.text syntax]

handleKeyPress :: forall event. event -> AppAction
handleKeyPress e =
  case getKeyCode e of
    13 ->
      ParseText
    _  ->
      DoNothing

handleChangeEvent :: forall event. event -> AppAction
handleChangeEvent = getValue >>> NewText

module Component.App
  ( appClass
  , AppProps(..)
  ) where

import Prelude

import Data.Maybe
import Data.Either
import Data.Tuple
import Data.Array (uncons, cons, snoc, filter, singleton, reverse, null)
import Data.List (toList)
import Data.Foldable (intercalate)
import qualified Data.Map as Map
import qualified Data.Set as Set

import Data.Syntax
import Data.Expr
import Data.Parse
import Data.PrettyPrint

import Text.Parsing.Parser (ParseError(..))

import Control.Monad.Eff
import Control.Monad.Eff.Save

import qualified Thermite as T
import qualified Thermite.Action as T

import qualified React as R
import qualified React.DOM as RD
import qualified React.DOM.Props as RP

import Component.Event

data Level = Warning | Danger

instance showLevel :: Show Level where
  show Warning = "warning"
  show Danger  = "danger"

type AppState =
  { text    :: String
  , expr    :: Maybe Expr
  , history :: Array String
  , defs    :: Array Definition
  , env     :: Environment
  , error   :: Maybe (Tuple Level String)
  }

data AppAction
  = DoNothing
  | NewText String
  | ParseText
  | Reduce Expr
  | DismissAlert
  | Remove Name
  | Clear
  | Save

type AppProps = Unit

appClass :: R.ReactClass AppProps
appClass = T.createClass (T.simpleSpec initialState update render)

initialDefs :: Array Definition
initialDefs =
  [ { name: "i"
    , syntax: unsafeParse parseSyntax "λx. x"
    }
  , { name: "k"
    , syntax: unsafeParse parseSyntax "λx. λy. x"
    }
  , { name: "fix"
    , syntax: unsafeParse parseSyntax "λf. (λx. f (x x)) (λy. f (y y))"
    }
  ]

initialEnv :: Environment
initialEnv = Map.fromList (toList (map fromDef initialDefs))
 where
  fromDef def = Tuple def.name (syntaxToExpr def.syntax)

initialState :: AppState
initialState =
  { text: ""
  , expr: Nothing
  , history: []
  , defs: initialDefs
  , env: initialEnv
  , error: Nothing
  }

update :: T.PerformAction _ AppState _ AppAction
update props action =
  case action of
    DoNothing ->
      return unit
    NewText text ->
      T.modifyState (\s -> s { text = text, error = Nothing })
    DismissAlert ->
      T.modifyState (\s -> s { error = Nothing })
    Remove name ->
      T.modifyState (remove name)
    ParseText ->
      T.modifyState parse
    Reduce expr ->
      T.modifyState (reduce expr)
    Clear ->
      T.modifyState clear
    Save -> do
      s <- T.getState
      T.async \k -> do
        let text = intercalate "\n" (map defToString s.defs <> reverse s.history)
        saveTextAs text "evaluation.txt"
        k unit
     where
      defToString def = def.name <> " = " <> prettyPrint def.syntax

fail :: String -> AppState -> AppState
fail message s =
  s { text = "", error = Just (Tuple Danger message) }

parse :: AppState -> AppState
parse s
  | s.text == "" = s
parse s =
  case parseAll parseEither s.text of
    Left error   ->
      fail (formatParseError s.text error) s
    Right (Left def) ->
      addDef def s
    Right (Right syntax) ->
      addExpr syntax s

remove :: String -> AppState -> AppState
remove name s =
  s { defs = deleteByName name s.defs, env = env', error = error }
 where
  env' = Map.delete name s.env
  names = namesReferencing name env'
  error = if Set.size names == 0
             then Nothing
             else Just (Tuple Warning (formatUndefinedWarning name names))

deleteByName :: Name -> Array Definition -> Array Definition
deleteByName name = filter (_.name >>> (/= name))

addDef :: Definition -> AppState -> AppState
addDef def s =
  if Set.size missing == 0
    then
      s { text = "", defs = defs, env = env }
    else
      fail (formatUndefinedError s.text missing) s
 where
  defs = deleteByName def.name s.defs `snoc` def
  expr = syntaxToExpr def.syntax
  env = Map.insert def.name expr s.env
  missing = undefinedNames expr (Map.delete def.name s.env)

addExpr :: Syntax -> AppState -> AppState
addExpr syntax s =
  s { text = "", history = history, expr = expr }
 where
  history = [prettyPrint syntax]
  expr = Just (syntaxToExpr syntax)

reduce :: Expr -> AppState -> AppState
reduce expr s =
  case step s.env expr of
    Nothing -> s
    Just expr' ->
      s { history = prettyPrint (exprToSyntax expr') `cons` s.history, expr = Just expr' }

clear :: AppState -> AppState
clear s = s { history = maybe [] (exprToSyntax >>> prettyPrint >>> singleton) s.expr }

render :: T.Render _ AppState _ AppAction
render send state props _ =
  RD.div
    [ RP.className "container" ]
    [ RD.div
      [ RP.className "row" ]
      [ header ]
    , RD.div
      [ RP.className "row" ]
      (alert send state.error)
    , RD.div
      [ RP.className "row" ]
      [ input send state.text ]
    , RD.div
      [ RP.className "row" ]
      (renderDefs send state.defs)
    , RD.div
      [ RP.className "row" ]
      (renderExprs send state.history state.expr)
    , RD.div
      [ RP.className "row" ]
      [ footer ]
    ]

header :: R.ReactElement
header = RD.div
  [ RP.className "page-header" ]
  [ RD.h2'
    [ RD.text "Lambda Machine" ]
  ]

footer :: R.ReactElement
footer = RD.div'
  [ RD.hr' []
  , RD.a
    [ RP.href "https://github.com/cdparks/lambda-machine"
    , RP.className "pull-right"
    ]
    [ RD.text "Source on GitHub" ]
  ]

alert :: _ -> Maybe (Tuple Level String) -> Array R.ReactElement
alert send Nothing = []
alert send (Just (Tuple level error)) =
  [ RD.div
    [ RP.className "col-sm-12" ]
    [ RD.pre
      [ RP.className ("alert alert-" <> show level) ]
      [ RD.span
        [ RP.className "glyphicon glyphicon-remove pull-right"
        , RP.onClick \_ -> send DismissAlert
        ]
        []
      , RD.text error
      ]
    ]
  ]

input :: _ -> String -> R.ReactElement
input send value = RD.div
  [ RP.className "col-sm-12" ]
  [ RD.div
    [ RP.className "input-group" ]
    [ RD.input
      [ RP.className "form-control monospace-font"
      , RP.placeholder "<definition> or <expression>"
      , RP.value value
      , RP.onKeyUp (handleKeyPress >>> send)
      , RP.onChange (handleChangeEvent >>> send)
      ]
      []
    , RD.span
      [ RP.className "input-group-btn" ]
      [ RD.button
        [ RP.className "btn btn-default"
        , RP.onClick \_ -> send ParseText
        ]
        [ RD.text "Parse" ]
      ]
    ]
  ]

renderDefs :: _ -> Array Definition -> Array R.ReactElement
renderDefs send definitions =
  [ RD.h3' [ RD.text "Definitions" ]
  , RD.div
    [ RP.className "monospace-font col-sm-12" ]
    (map (renderDef send) definitions)
  ]

renderDef :: _ -> Definition -> R.ReactElement
renderDef send def = RD.h4'
  [ RD.div
    [ RP.className "glyphicon glyphicon-remove"
    , RP.onClick \_ -> send (Remove def.name)
    ]
    []
  , RD.text (" " <> def.name <> " = " <> prettyPrint def.syntax)
  ]

renderExprs :: _ -> Array String -> Maybe Expr -> Array R.ReactElement
renderExprs send history Nothing = []
renderExprs send history (Just expr) =
  [ RD.h3' [ RD.text "Evaluation" ]
  , RD.div
    [ RP.className "col-sm-12" ]
    [ RD.div
      [ RP.className "btn-group pull-right" ]
      [ RD.button
        [ RP.className "btn btn-default"
        , RP.onClick \_ -> send (Reduce expr)
        ]
        [ RD.text "Step" ]
      , RD.button
        [ RP.className "btn btn-default"
        , RP.onClick \_ -> send Clear
        ]
        [ RD.text "Clear" ]
      , RD.button
        [ RP.className "btn btn-default"
        , RP.onClick \_ -> send Save
        ]
        [ RD.text "Save" ]
      ]
    , RD.div
      [ RP.className "hide-overflow" ]
      [ RD.div
        [ RP.className "scroll-overflow monospace-font" ]
        (renderHistory history)
      ]
    ]
  ]

renderHistory :: Array String -> Array R.ReactElement
renderHistory hs =
  case uncons hs of
    Nothing -> []
    Just { head = head, tail = tail } ->
      RD.h4' [ RD.text head ] `cons` map renderSyntax tail

renderSyntax :: String -> R.ReactElement
renderSyntax syntax = RD.h4
  [ RP.className "text-muted" ]
  [ RD.text syntax]

handleKeyPress :: forall event. event -> AppAction
handleKeyPress e =
  case getKeyCode e of
    13 ->
      ParseText
    _  ->
      DoNothing

handleChangeEvent :: forall event. event -> AppAction
handleChangeEvent = getValue >>> NewText