Add unit :: forall a. a -> Unit

Add unit :: forall a. a -> Unit

module Prelude
  ( flip
  , const
  , asTypeOf
  , Semigroupoid, (<<<), (>>>)
  , Category, id
  , ($), (#)
  , (:), cons
  , Show, show
  , Functor, (<$>)
  , Apply, (<*>)
  , Applicative, pure, liftA1
  , Alternative, empty, (<|>)
  , Bind, (>>=)
  , Monad, return, liftM1, ap
  , Num, (+), (-), (*), (/), (%)
  , negate
  , Eq, (==), (/=), refEq, refIneq
  , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
  , Bits, (&), (|), (^), shl, shr, zshr, complement
  , BoolLike, (&&), (||)
  , not
  , Semigroup, (<>), (++)
  , Unit(..), unit
  ) where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

  class (Semigroupoid a) <= Category a where
    id :: forall t. a t t

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

  ($) :: forall a b. (a -> b) -> a -> b
  ($) f x = f x

  (#) :: forall a b. a -> (a -> b) -> b
  (#) x f = f x

  infixr 6 :

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

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

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showUnit :: Show Unit where
    show (Unit {}) = "Unit {}"

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  foreign import showArrayImpl
    "function showArrayImpl (f) {\
    \  return function (xs) {\
    \    var ss = [];\
    \    for (var i = 0, l = xs.length; i < l; i++) {\
    \      ss[i] = f(xs[i]);\
    \    }\
    \    return '[' + ss.join(',') + ']';\
    \  };\
    \}" :: forall a. (a -> String) -> [a] -> String

  instance showArray :: (Show a) => Show [a] where
    show = showArrayImpl show

  infixl 4 <$>

  class Functor f where
    (<$>) :: forall a b. (a -> b) -> f a -> f b

  infixl 4 <*>

  class (Functor f) <= Apply f where
    (<*>) :: forall a b. f (a -> b) -> f a -> f b

  class (Apply f) <= Applicative f where
    pure :: forall a. a -> f a

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

  class (Apply m) <= Bind m where
    (>>=) :: forall a b. m a -> (a -> m b) -> m b

  class (Applicative m, Bind m) <= Monad m

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  data Unit = Unit {}

  unit :: forall a. a -> Unit
  unit = const (Unit {})

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqUnit :: Eq Unit where
    (==) (Unit {}) (Unit {}) = true
    (/=) (Unit {}) (Unit {}) = false

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  instance eqArray :: (Eq a) => Eq [a] where
    (==) [] [] = true
    (==) (x:xs) (y:ys) = x == y && xs == ys
    (==) _ _ = false
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

  class (Eq a) <= Ord a where
    compare :: a -> a -> Ordering

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import unsafeCompare
    "function unsafeCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
    \  };\
    \}" :: forall a. a -> a -> Ordering

  instance ordUnit :: Ord Unit where
    compare (Unit {}) (Unit {}) = EQ

  instance ordBoolean :: Ord Boolean where
    compare false false = EQ
    compare false true  = LT
    compare true  true  = EQ
    compare true  false = GT

  instance ordNumber :: Ord Number where
    compare = unsafeCompare

  instance ordString :: Ord String where
    compare = unsafeCompare

  instance ordArray :: (Ord a) => Ord [a] where
    compare [] [] = EQ
    compare [] _ = LT
    compare _ [] = GT
    compare (x:xs) (y:ys) = case compare x y of
      EQ -> compare xs ys
      other -> other

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupUnit :: Semigroup Unit where
    (<>) (Unit {}) (Unit {}) = Unit {}

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Function where

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

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

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e {}

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e {}) -> Eff e {}

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) {}

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]

module Prelude
  ( flip
  , const
  , asTypeOf
  , Semigroupoid, (<<<), (>>>)
  , Category, id
  , ($), (#)
  , (:), cons
  , Show, show
  , Functor, (<$>)
  , Apply, (<*>)
  , Applicative, pure, liftA1
  , Alternative, empty, (<|>)
  , Bind, (>>=)
  , Monad, return, liftM1, ap
  , Num, (+), (-), (*), (/), (%)
  , negate
  , Eq, (==), (/=), refEq, refIneq
  , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
  , Bits, (&), (|), (^), shl, shr, zshr, complement
  , BoolLike, (&&), (||)
  , not
  , Semigroup, (<>), (++)
  , Unit(..)
  ) where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

  class (Semigroupoid a) <= Category a where
    id :: forall t. a t t

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

  ($) :: forall a b. (a -> b) -> a -> b
  ($) f x = f x

  (#) :: forall a b. a -> (a -> b) -> b
  (#) x f = f x

  infixr 6 :

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

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

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showUnit :: Show Unit where
    show (Unit {}) = "Unit {}"

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  foreign import showArrayImpl
    "function showArrayImpl (f) {\
    \  return function (xs) {\
    \    var ss = [];\
    \    for (var i = 0, l = xs.length; i < l; i++) {\
    \      ss[i] = f(xs[i]);\
    \    }\
    \    return '[' + ss.join(',') + ']';\
    \  };\
    \}" :: forall a. (a -> String) -> [a] -> String

  instance showArray :: (Show a) => Show [a] where
    show = showArrayImpl show

  infixl 4 <$>

  class Functor f where
    (<$>) :: forall a b. (a -> b) -> f a -> f b

  infixl 4 <*>

  class (Functor f) <= Apply f where
    (<*>) :: forall a b. f (a -> b) -> f a -> f b

  class (Apply f) <= Applicative f where
    pure :: forall a. a -> f a

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

  class (Apply m) <= Bind m where
    (>>=) :: forall a b. m a -> (a -> m b) -> m b

  class (Applicative m, Bind m) <= Monad m

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  data Unit = Unit {}

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqUnit :: Eq Unit where
    (==) (Unit {}) (Unit {}) = true
    (/=) (Unit {}) (Unit {}) = false

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  instance eqArray :: (Eq a) => Eq [a] where
    (==) [] [] = true
    (==) (x:xs) (y:ys) = x == y && xs == ys
    (==) _ _ = false
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

  class (Eq a) <= Ord a where
    compare :: a -> a -> Ordering

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import unsafeCompare
    "function unsafeCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
    \  };\
    \}" :: forall a. a -> a -> Ordering

  instance ordUnit :: Ord Unit where
    compare (Unit {}) (Unit {}) = EQ

  instance ordBoolean :: Ord Boolean where
    compare false false = EQ
    compare false true  = LT
    compare true  true  = EQ
    compare true  false = GT

  instance ordNumber :: Ord Number where
    compare = unsafeCompare

  instance ordString :: Ord String where
    compare = unsafeCompare

  instance ordArray :: (Ord a) => Ord [a] where
    compare [] [] = EQ
    compare [] _ = LT
    compare _ [] = GT
    compare (x:xs) (y:ys) = case compare x y of
      EQ -> compare xs ys
      other -> other

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupUnit :: Semigroup Unit where
    (<>) (Unit {}) (Unit {}) = Unit {}

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Function where

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

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

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e {}

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e {}) -> Eff e {}

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) {}

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]


smarter gene rendering, use hitbox-aware labels

module Genetics.Browser.Demo where

import Prelude

import Color (black, white)
import Color.Scheme.Clrs (blue, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgray, lightgrey)
import Control.Monad.Except (runExcept, throwError)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Filterable (filter, filterMap, partition, partitionMap)
import Data.Foldable (class Foldable, foldMap, foldr, length, minimumBy, sequence_, traverse_)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (re, view, (^.), (^?))
import Data.Lens.Index (ix)
import Data.Lens.Lens.Tuple (_2)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.Traversable (for)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple as Tuple
import Data.Unfoldable (unfoldr)
import Data.Variant (inj)
import Debug.Trace as Debug
import Effect (Effect)
import Effect.Aff (Aff, error)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Foreign (F, Foreign, ForeignError(ForeignError))
import Foreign (readArray) as Foreign
import Foreign.Index (readProp) as Foreign
import Foreign.Keys (keys) as Foreign
import Genetics.Browser (Feature, HexColor(..), LegendConfig, LegendEntry, Peak, Threshold, VScale, VScaleRow, chrBackgroundLayer, chrLabels, drawLegendInSlot, drawVScaleInSlot, featureNormX, groupToMap, renderFixedUI, renderTrackLike, thresholdRuler, trackLegend)
import Genetics.Browser.Bed (ParsedLine, fetchBed)
import Genetics.Browser.Canvas (BatchDrawing, Label, LabelPlace(LLeft, LCenter), Renderable, RenderableLayer, RenderableLayerHotspots, TrackContainer, _drawing, _drawingBatch, _labels, createAndAddLayer, createAndAddLayer_, renderLayer)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView, _Segments, aroundPair, normalize, pairSize, pairsOverlap)
import Genetics.Browser.Layer (Component(Center, CRight, CLeft), Layer(..), LayerMask(..), LayerType(..))
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), NegLog10(..), _NegLog10)
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 (get) as Affjax
import Network.HTTP.Affjax.Response (json) as Affjax
import Record (insert) as Record
import Record.Builder (build, insert, merge, modify)
import Record.Extra (class Keys)
import Record.Extra (keys) as Record
import Simple.JSON as Simple
import Type.Prelude (class RowToList, SProxy(SProxy))
import Unsafe.Coerce (unsafeCoerce)

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

  let n = 10000
      fs = Debug.trace ("Using genes #" <> show n)
           \_ -> filterMap (bedToFeature cs) $ Array.take n ls

  pure $ groupToMap _.feature.chrId $ fs

renderGenes :: Map ChrId (Array BedFeature)
            -> _
            -> Map ChrId (Pair Number)
            -> Canvas.Dimensions
            -> List Renderable
renderGenes geneData _ segs size =
  let
      output = foldMapWithIndex f geneData
        where f :: ChrId -> Array BedFeature -> _
              f chr genes = fromMaybe mempty do
                  seg <- Map.lookup chr segs
                  pure $ foldMap (drawGene size seg) genes

  in  (inj _drawing <$> output.drawing)
   <> (inj _labels  <$> (pure $ Array.fromFoldable output.label))

drawGene :: Canvas.Dimensions
         -> Pair Number
         -> BedFeature
         -> { drawing :: List Drawing, label :: List Label }
drawGene size seg gene =
  let (Pair l r) = gene.position
      segWidth = pairSize seg
      toLocal x = segWidth * (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 _ =
        if width < one
        then mempty
        else Drawing.text
               (font sansSerif 12 mempty)
                  (2.5) (35.0)
                  (fillColor black) gene.feature.geneName

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

      point :: Point
      point =
        let (Pair offset _) = seg
        in { x: offset + (pairSize seg) * (unwrap $ featureNormX gene)
           , y: size.height * 0.5 }

  in { drawing: pure (Drawing.translate point.x point.y drawing)
     , label:  pure { text: gene.feature.geneName
                      , point
                      , gravity: LCenter }  }

type SNPRow chr score r =
  ( "chrId"  :: chr
  , "name" :: String
  , "score" :: score
  | r )

type SNP r =
  Feature (Record (SNPRow ChrId Number r))

parseSNP :: CoordSys ChrId BigInt
         -> Foreign
         -> F (SNP ())
parseSNP cSys a = do
  raw <- Simple.read' a

  let
      snp :: { chr :: String, ps :: Number, p_wald :: Number, rs :: String }
      snp = raw

      feature :: Record (SNPRow ChrId Number ())
      feature =
        { score:      snp.p_wald
        , chrId: wrap snp.chr
        , name:       snp.rs }

      position = (\p -> wrap <$> Pair p p) $ snp.ps

  frameSize <- case Map.lookup feature.chrId (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

type AnnotationRow chr pos r =
  ( "chr"  :: chr
  , "pos"  :: pos
  , "name" :: String
  , "url"  :: Maybe String
  , "gene" :: Maybe String
  | r )

type AnnotationField = { field :: String, value :: Foreign }

type Annotation r =
  Feature (Record (AnnotationRow ChrId Bp
                     ( rest :: List AnnotationField | r )))

annotationFields :: ∀ a b rl.
                    Keys rl
                 => RowToList (AnnotationRow a b ()) rl
                 => List String
annotationFields =
  Record.keys (unsafeCoerce unit :: Record (AnnotationRow a b ()))

parseAnnotation :: CoordSys ChrId BigInt
                -> Foreign
                -> F (Annotation ())
parseAnnotation cSys a = do
  raw <- Simple.read' a
  rest <- parseAnnotationRest a

  let
      feature =
        build
         (insert    (SProxy :: SProxy "rest") rest
         >>> modify (SProxy :: SProxy "chr") ChrId
         >>> modify (SProxy :: SProxy "pos") Bp) raw

      position = (\p -> Pair p p) $ feature.pos

  frameSize <- case Map.lookup feature.chr (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

-- | Partially parse the parts of the annotation record that are *not* in the Annotation type
parseAnnotationRest :: Foreign
                    -> F (List AnnotationField)
parseAnnotationRest a = do
  allFields <- List.fromFoldable <$> Foreign.keys a

  let restFields = allFields `List.difference` annotationFields

  for restFields \field ->
     { field, value: _ } <$> Foreign.readProp field a

-- | A completely dumb default way of rendering arbitrary annotation fields
showAnnotationField :: AnnotationField -> String
showAnnotationField fv = fv.field <> ": " <> unsafeCoerce fv.value

showAnnotation :: Annotation ()
               -> List String
showAnnotation a = (List.fromFoldable
                    [ name, chr, pos ]) <> (map showAnnotationField annot.rest)
  where annot = a.feature
        name = fromMaybe ("SNP: " <> annot.name)
                         (("Gene: " <> _) <$> annot.gene)
        chr = "Chr: " <> show annot.chr
        pos = "Pos: " <> show annot.pos

getSNPs :: CoordSys ChrId BigInt
        -> String
        -> Aff (Map ChrId (Array (SNP ())))
getSNPs cs url = do
  resp <- Affjax.get Affjax.json url

  rawSNPs <-
    case runExcept $ Foreign.readArray $ unsafeCoerce resp.response of
           Left err -> throwError $ error "SNP data is not an array"
           Right as -> pure as

  let parsed =
        partitionMap (runExcept <<< parseSNP cs) rawSNPs

  pure $ groupToMap _.feature.chrId
         $ filter (\f -> Pair.fst (f.position) >= wrap zero)
         $ parsed.right

getAnnotations :: CoordSys ChrId BigInt
               -> String
               -> Aff (Map ChrId (Array (Annotation ())))
getAnnotations cs url = do
  resp <- Affjax.get Affjax.json url

  rawAnnots <- case runExcept
                    $ Foreign.readArray $ unsafeCoerce resp.response of
                 Left err -> throwError $ error "Annotations data is not an array"
                 Right as -> pure as

  let parsed = partitionMap
               (runExcept <<< parseAnnotation cs) rawAnnots

  -- debug/testing stuff
  liftEffect do
    log $ "Raw annotations array length: " <> show (Array.length rawAnnots)
    log $ "Could not parse "
        <> show (length parsed.left :: Int)
        <> " annotations."
    log $ "Successfully parsed "
        <> show (length parsed.right :: Int)
        <> " annotations."

    -- logging with unsafeCoerce lets us examine the raw JS object in the console!
    log $ unsafeCoerce (parsed.right)
  case Array.head parsed.right of
    Nothing -> pure unit
    Just an -> liftEffect do
      log "first annotation: "
      sequence_ (log <$> (("> " <> _) <$> showAnnotation an))

  pure $ groupToMap _.feature.chr parsed.right

peak1 :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Maybe (Tuple (Peak Bp Number (SNP rS))
                      (Array (SNP rS)))
peak1 radius snps = do
  top <- minimumBy (compare `on` _.feature.score) snps

  let covers = radius `aroundPair` top.position
      y = top.feature.score
      {no, yes} = partition (\p -> p.position `pairsOverlap` covers) snps

  pure $ Tuple {covers, y, elements: yes} no

peaks :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Array (Peak Bp Number (SNP rS))
peaks r snps = unfoldr (peak1 r) snps

type AnnotationsConfig =
  { radius    :: Number
  , outline   :: HexColor
  , snpColor  :: HexColor
  , geneColor :: HexColor }

defaultAnnotationsConfig :: AnnotationsConfig
defaultAnnotationsConfig =
  { radius:    5.5
  , outline:   wrap black
  , snpColor:  wrap blue
  , geneColor: wrap red }

annotationLegendEntry :: ∀ r. AnnotationsConfig -> Annotation r -> LegendEntry
annotationLegendEntry conf a =
  let mkIcon color = outlined (outlineColor (unwrap conf.outline) <> lineWidth 2.0)
                  <> filled (fillColor $ unwrap color)
                   $ circle 0.0 0.0 conf.radius
  in case a.feature.gene of
       Nothing -> { text: "SNP name",  icon: mkIcon conf.snpColor  }
       Just gn -> { text: "Gene name", icon: mkIcon conf.geneColor }

annotationLegendTest :: ∀ f r.
                   Foldable f
                => Functor f
                => AnnotationsConfig
                -> Map ChrId (f (Annotation r))
                -> Array LegendEntry
annotationLegendTest config fs = trackLegend (annotationLegendEntry config) as
  where as = Array.concat
             $ Array.fromFoldable
             $ Array.fromFoldable <$> Map.values fs

normYLogScore :: ∀ r.
                 { min :: Number
                 , max :: Number
                 | r }
              -> Number
              -> Number
normYLogScore s =
  normalize s.min s.max <<< unwrap <<< view _NegLog10

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 (SNP r2))
          -> Map ChrId (Array (SNP r2))
filterSig {sig} = map (filter
  (\snp -> snp.feature.score <= (NegLog10 sig ^. re _NegLog10)))

snpsUI :: ∀ c.
          VScale (VScaleRow ())
       -> RenderableLayer c
snpsUI vscale = renderFixedUI (CLeft $ drawVScaleInSlot vscale)

annotationsUI :: ∀ r c.
                 LegendConfig (entries :: Array LegendEntry | r)
              -> RenderableLayer c
annotationsUI legend = renderFixedUI (CRight $ drawLegendInSlot legend)

type SNPConfig
  = { radius :: Number
    , lineWidth :: Number
    , color :: { outline :: HexColor
               , fill    :: HexColor }
    , pixelOffset :: Point }

defaultSNPConfig :: SNPConfig
defaultSNPConfig =
  { radius: 3.75
  , lineWidth: 1.0
  , color: { outline: wrap darkblue, fill: wrap darkblue }
  , pixelOffset: {x: 0.0, y: 0.0}
  }

renderSNPs :: ∀ r1.
              Map ChrId (Array (SNP ()))
           -> { threshold  :: { min  :: Number, max :: Number | r1 }
              , render :: SNPConfig }
           -> Map ChrId (Pair Number)
           -> Canvas.Dimensions
           -> { renderables :: List Renderable
              , hotspots :: Number -> Point -> Array (SNP ()) }
renderSNPs snpData { render, threshold } =
  let radius = render.radius

      drawing =
          let {x,y} = render.pixelOffset
              c     = circle x y radius
              out   = outlined (outlineColor (unwrap render.color.outline) <>
                                lineWidth render.lineWidth) c
              fill  = filled   (fillColor    $ unwrap render.color.fill)    c
          in out <> fill

      drawings :: Array (Tuple (SNP ()) Point) -> Array BatchDrawing
      drawings pts = [{ drawing, points: view _2 <$> pts }]

      pointed :: Canvas.Dimensions
              -> Map ChrId (Pair Number)
              -> Array (Tuple (SNP ()) Point)
      pointed size = foldMapWithIndex placeSeg
        where
              place :: Pair Number -> SNP () -> Point
              place seg@(Pair offset _) s =
                { x: offset + (pairSize seg) * (unwrap $ featureNormX s)
                , y: size.height * (one - normYLogScore threshold s.feature.score) }

              placeSeg :: ChrId -> Pair Number -> Array (Tuple (SNP ()) Point)
              placeSeg chrId seg = foldMap (map $ fanout identity (place seg))
                                    $ Map.lookup chrId snpData

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

  in \seg size ->
        let pts = pointed size seg
        in { renderables: pure $ inj _drawingBatch $ drawings pts
           , hotspots: hotspots pts }

annotationsForScale :: ∀ r1 r2 i c.
                       CoordSys i c
                    -> Map ChrId (Array (SNP r1))
                    -> Map ChrId (Array (Annotation r2))
                    -> Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
annotationsForScale cSys snps annots =
  mapWithIndex \chr seg -> fromMaybe [] do
    segSnps      <- Map.lookup chr snps
    segAnnots    <- Map.lookup chr annots
    frameSize <- _.frameSize <$> Array.head segSnps

    let rad = (wrap 3.75 * frameSize) / (wrap $ pairSize seg)
        f pk = pk { elements = filter
                          (pairsOverlap pk.covers <<< _.position) segAnnots }

    pure $ f <$> peaks rad segSnps

renderAnnotationPeaks :: ∀ r1 r2.
                         CoordSys ChrId BigInt
                      -> { min :: Number, max :: Number | r1 }
                      -> AnnotationsConfig
                      -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
                      -> Canvas.Dimensions
                      -> Map ChrId (Pair Number)
                      -> { drawingBatch :: Array BatchDrawing, labels :: Array Label }
renderAnnotationPeaks cSys vScale conf annoPks cdim =
  let

      curAnnotPeaks :: Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Number Number (Annotation r2)))
      curAnnotPeaks segs = mapWithIndex f annoPks
        where f chr pks = fromMaybe [] do
                  frameSize <- (wrap <<< BigInt.toNumber <<< pairSize)
                             <$> (Map.lookup chr $ cSys ^. _Segments)
                  pxSeg@(Pair l _) <- Map.lookup chr segs

                  let rescale pk = pk { covers = (\x -> l + pairSize pxSeg *
                                          (unwrap $ x / frameSize)) <$> pk.covers
                                      , y = cdim.height * (one - normYLogScore vScale pk.y) }

                  pure $ map rescale pks

      tailHeight = 0.06
      tailPixels = tailHeight * cdim.height
      iconYOffset = 6.5
      labelOffset = 8.0

      -- part of the canvas that a given peak will cover when rendered
      drawingCovers :: ∀ a.
                       Peak Number Number a
                    -> Canvas.Rectangle
      drawingCovers aPeak = {x, y, width: w, height: h}
        where (Pair x _) = aPeak.covers
              w = 14.0  -- hardcoded glyph width in pixels
              gH = (11.0 - iconYOffset) -- hardcoded height
              h = tailPixels + gH * length aPeak.elements
              y = aPeak.y - h

      drawAndLabel :: Peak Number Number (Annotation r2)
                   -> Tuple (Array BatchDrawing) (Array Label)
      drawAndLabel aPeak = Tuple [drawing] label
        where
              (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)

              icons = Drawing.translate 0.0 (-tailPixels)
                      $ foldr (\a d -> Drawing.translate 0.0 (-iconYOffset)
                                     $ (annotationLegendEntry conf a).icon <> d)
                          mempty aPeak.elements

              tail = if Array.null aPeak.elements
                then mempty
                else Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                       $ Drawing.path [ {x: 0.0, y: 0.0 }, {x: 0.0, y: -tailPixels }]

              drawing = { drawing: tail <> icons, points: [{x, y: aPeak.y }] }

              -- hardcoded font size because this will be handled by UI.Canvas later
              fontHeight = 14.0
              labelsHeight = length aPeak.elements * fontHeight

              dC = drawingCovers aPeak
                -- if all the labels fit above the icons, they're centered;
                -- otherwise just place them to the left and hope for the best
              {g, y0} = if dC.y > labelsHeight
                then { g: LCenter, y0: dC.y  }
                else { g: LLeft, y0: aPeak.y }

              label = Tuple.snd $ foldr f (Tuple y0 mempty) aPeak.elements
              f a (Tuple y ls) = Tuple (y - labelOffset)
                                    $ Array.snoc ls
                                         { text: fromMaybe a.feature.name a.feature.gene
                                         , point: { x, y }
                                         , gravity: g
                                         }

      drawAndLabelAll :: Map ChrId (Array (Peak _ _ _))
                      -> Tuple (Array BatchDrawing) (Array Label)
      drawAndLabelAll pks = foldMap (foldMap drawAndLabel) pks

  in \segs -> let (Tuple drawingBatch labels) =
                    drawAndLabelAll $ curAnnotPeaks segs
              in { drawingBatch, labels }

renderAnnotations :: ∀ r1 r2 rC.
                    CoordSys ChrId BigInt
                 -> Map ChrId (Array (SNP ()))
                 -> Map ChrId (Array (Annotation r1))
                 -> { threshold :: { min :: Number, max :: Number | r2 }
                    , render :: AnnotationsConfig | rC }
                 -> Map ChrId (Pair Number)
                 -> Canvas.Dimensions
                 -> List Renderable
renderAnnotations cSys sigSnps allAnnots conf =
  let annoPeaks = annotationsForScale cSys sigSnps allAnnots

  in \seg size ->
        let {drawingBatch, labels} =
              renderAnnotationPeaks cSys conf.threshold conf.render (annoPeaks seg) size seg
        in List.fromFoldable
           [ inj _drawingBatch $ drawingBatch
           , inj _labels   $ labels ]

_snps = SProxy :: SProxy "snps"
_annotations = SProxy :: SProxy "annotations"

addGWASLayers :: ∀ r r2.
                 { score :: { min :: Number, max :: Number, sig :: Number }
                 , legend :: LegendConfig ()
                 , vscale :: VScale ()
                 , chrLabels :: { fontSize :: Int }
                 , snps :: SNPConfig
                 , annotations :: AnnotationsConfig
                 , coordinateSystem :: CoordSys ChrId BigInt | r }
              -> { snps        :: Map ChrId (Array (SNP ()))
                 , annotations :: Map ChrId (Array (Annotation ())) | r2 }
              -> TrackContainer
              -> Effect { snps        :: Pair Number -> CoordSysView -> Effect Unit
                        , annotations :: Pair Number -> CoordSysView -> Effect Unit
                        , chrs        :: Pair Number -> CoordSysView -> Effect Unit
                        , hotspots    :: Effect (Number -> Point -> Array (SNP ()))
                        , fixedUI     :: Effect Unit }
addGWASLayers config trackData =
  let threshold = config.score
      vscale = build (merge config.vscale) threshold

      sigSnps = filterSig config.score trackData.snps
      legend = Record.insert (SProxy :: SProxy "entries")
               (annotationLegendTest
                 config.annotations
                 trackData.annotations) config.legend

      segmentPadding = 12.0
      conf = { segmentPadding }
      cSys = config.coordinateSystem

      bgLayer :: ∀ r'.
                 RenderableLayer { background :: { bg1 :: HexColor
                                                 , bg2 :: HexColor
                                                 , segmentPadding :: Number }
                                 , view :: CoordSysView | r' }
      bgLayer =
        renderTrackLike conf cSys (SProxy :: SProxy "background")
          (Center chrBackgroundLayer)

      snpLayer :: RenderableLayerHotspots _ _
      snpLayer =
        renderTrackLike conf cSys _snps
          (Center $ renderSNPs trackData.snps)

      annotationLayer :: RenderableLayer
                         { annotations
                           :: { threshold :: Threshold
                              , render :: AnnotationsConfig }
                         , view :: CoordSysView }
      annotationLayer =
        renderTrackLike conf cSys _annotations
          (Center $ renderAnnotations cSys sigSnps trackData.annotations)

  in \bc -> do

    rBG  <-
      createAndAddLayer_ bc "chrBackground" bgLayer

    rRuler <-
      createAndAddLayer_ bc "ruler"
        $ Layer Fixed NoMask (Center thresholdRuler)

    rSNPs  <-
      createAndAddLayer  bc "snps" snpLayer

    rAnnos <-
      createAndAddLayer_ bc "annotations" annotationLayer

    rVScale <-
      createAndAddLayer_ bc "vscale" $ snpsUI vscale

    rLegend <-
      createAndAddLayer_ bc "legend" $ annotationsUI legend

    rChrLabels <-
      createAndAddLayer_ bc "chrLabels"
        $ chrLabels { segmentPadding
                    , fontSize: config.chrLabels.fontSize }  cSys

    let fixedUI = do
          let uiConf = { rulerColor: wrap red, threshold }

          traverse_ (renderLayer (Pair 0.0 0.0) uiConf)
                      [ rVScale, rLegend, rRuler ]

        snps o v = do
          renderLayer o { snps: { threshold, render: config.snps }
                        , view: v } rSNPs

        hotspots = rSNPs.lastHotspots

        annotations o v =
          renderLayer o { annotations: { threshold, render: config.annotations }
                        , view: v } rAnnos

        chrs o v = do
          let bgConf = { background: { bg1: HexColor white
                                     , bg2: HexColor lightgray
                                     , segmentPadding }
                       , view: v }
          traverse_ (renderLayer o bgConf)
                      [rBG, rChrLabels]

    pure { snps
         , annotations
         , hotspots
         , fixedUI
         , chrs
         }

addGeneLayers :: ∀ r r2.
                 _
              -> { genes        :: Map ChrId (Array BedFeature) | r2 }
              -> TrackContainer
              -> Effect { genes :: Pair Number -> CoordSysView -> Effect Unit
                        , chrs  :: Pair Number -> CoordSysView -> Effect Unit }
addGeneLayers config trackData tcont = do

  let
      segmentPadding = 12.0
      conf = { segmentPadding }

      bgLayer :: ∀ r'.
                 RenderableLayer { background :: { bg1 :: HexColor
                                                 , bg2 :: HexColor
                                                 , segmentPadding :: Number }
                                 , view :: CoordSysView | r' }
      bgLayer =
        renderTrackLike conf config.coordinateSystem (SProxy :: SProxy "background")
          (Center chrBackgroundLayer)

      geneLayer :: _
      geneLayer =
        renderTrackLike conf config.coordinateSystem (SProxy :: SProxy "genes")
          (Center $ renderGenes trackData.genes)

  rBG  <-
    createAndAddLayer_ tcont "background" bgLayer

  rChrLabels <-
    createAndAddLayer_ tcont "chrLabels"
      $ chrLabels { segmentPadding
                  , fontSize: config.chrLabels.fontSize } config.coordinateSystem

  rGenes <-
    createAndAddLayer_ tcont "genes" geneLayer

  let genes o v =
        renderLayer o { genes: {}, view: v } rGenes

      chrs o v = do
        let bgConf = { background: { bg1: HexColor white
                                   , bg2: HexColor lightgray
                                   , segmentPadding }
                     , view: v }
        traverse_ (renderLayer o bgConf)
                    [rBG, rChrLabels]

  pure { genes
       , chrs }

module Genetics.Browser.Demo where

import Prelude

import Color (black, white)
import Color.Scheme.Clrs (blue, red)
import Color.Scheme.X11 (darkblue, darkgrey, lightgray, lightgrey)
import Control.Monad.Except (runExcept, throwError)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Filterable (filter, filterMap, partition, partitionMap)
import Data.Foldable (class Foldable, foldMap, foldr, length, minimumBy, sequence_, traverse_)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (re, view, (^.), (^?))
import Data.Lens.Index (ix)
import Data.Lens.Lens.Tuple (_2)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Strong (fanout)
import Data.Traversable (for)
import Data.Tuple (Tuple(Tuple))
import Data.Tuple as Tuple
import Data.Unfoldable (unfoldr)
import Data.Variant (inj)
import Debug.Trace as Debug
import Effect (Effect)
import Effect.Aff (Aff, error)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Foreign (F, Foreign, ForeignError(ForeignError))
import Foreign (readArray) as Foreign
import Foreign.Index (readProp) as Foreign
import Foreign.Keys (keys) as Foreign
import Genetics.Browser (Feature, HexColor(..), LegendConfig, LegendEntry, Peak, Threshold, VScale, VScaleRow, chrBackgroundLayer, chrLabels, drawLegendInSlot, drawVScaleInSlot, featureNormX, groupToMap, renderFixedUI, renderTrackLike, thresholdRuler, trackLegend)
import Genetics.Browser.Bed (ParsedLine, fetchBed)
import Genetics.Browser.Canvas (BatchDrawing, Label, LabelPlace(LLeft, LCenter), Renderable, RenderableLayer, RenderableLayerHotspots, TrackContainer, _drawing, _drawingBatch, _labels, createAndAddLayer, createAndAddLayer_, renderLayer)
import Genetics.Browser.Coordinates (CoordSys, CoordSysView, _Segments, aroundPair, normalize, pairSize, pairsOverlap)
import Genetics.Browser.Layer (Component(Center, CRight, CLeft), Layer(..), LayerMask(..), LayerType(..))
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId), NegLog10(..), _NegLog10)
import Graphics.Canvas as Canvas
import Graphics.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 (get) as Affjax
import Network.HTTP.Affjax.Response (json) as Affjax
import Record (insert) as Record
import Record.Builder (build, insert, merge, modify)
import Record.Extra (class Keys)
import Record.Extra (keys) as Record
import Simple.JSON as Simple
import Type.Prelude (class RowToList, SProxy(SProxy))
import Unsafe.Coerce (unsafeCoerce)

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

  let n = 1000
      fs = Debug.trace ("Using genes #" <> show n)
           \_ -> filterMap (bedToFeature cs) $ Array.take n ls

  pure $ groupToMap _.feature.chrId $ fs

renderGenes :: Map ChrId (Array BedFeature)
            -> _
            -> Map ChrId (Pair Number)
            -> Canvas.Dimensions
            -- -> { renderables :: List Renderable }
            -> List Renderable
renderGenes geneData _ segs size =
  let
      drawings = foldMapWithIndex f geneData
        where f :: ChrId -> Array BedFeature -> List Renderable
              f chr genes = fromMaybe mempty do
                  -- 1. get segment pair
                  seg <- Map.lookup chr segs
                  -- let width = pairSize seg
                  pure $ foldMap (pure <<< drawGene size seg) genes

  in Debug.trace ("gene renders: " <> show (length drawings :: Int)) \_ -> drawings

drawGene :: Canvas.Dimensions
         -> Pair Number
         -> BedFeature
         -> Renderable
drawGene size seg gene =
  let (Pair l r) = gene.position
      segWidth = pairSize seg
      toLocal x = segWidth * (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
      drawing = introns unit
             <> foldMap exon gene.feature.blocks
             <> label unit

      point :: Point
      point =
        let (Pair offset _) = seg
        in { x: offset + (pairSize seg) * (unwrap $ featureNormX gene)
           , y: size.height * 0.5 }

  in inj _drawing $ Drawing.translate point.x point.y drawing

type SNPRow chr score r =
  ( "chrId"  :: chr
  , "name" :: String
  , "score" :: score
  | r )

type SNP r =
  Feature (Record (SNPRow ChrId Number r))

parseSNP :: CoordSys ChrId BigInt
         -> Foreign
         -> F (SNP ())
parseSNP cSys a = do
  raw <- Simple.read' a

  let
      snp :: { chr :: String, ps :: Number, p_wald :: Number, rs :: String }
      snp = raw

      feature :: Record (SNPRow ChrId Number ())
      feature =
        { score:      snp.p_wald
        , chrId: wrap snp.chr
        , name:       snp.rs }

      position = (\p -> wrap <$> Pair p p) $ snp.ps

  frameSize <- case Map.lookup feature.chrId (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

type AnnotationRow chr pos r =
  ( "chr"  :: chr
  , "pos"  :: pos
  , "name" :: String
  , "url"  :: Maybe String
  , "gene" :: Maybe String
  | r )

type AnnotationField = { field :: String, value :: Foreign }

type Annotation r =
  Feature (Record (AnnotationRow ChrId Bp
                     ( rest :: List AnnotationField | r )))

annotationFields :: ∀ a b rl.
                    Keys rl
                 => RowToList (AnnotationRow a b ()) rl
                 => List String
annotationFields =
  Record.keys (unsafeCoerce unit :: Record (AnnotationRow a b ()))

parseAnnotation :: CoordSys ChrId BigInt
                -> Foreign
                -> F (Annotation ())
parseAnnotation cSys a = do
  raw <- Simple.read' a
  rest <- parseAnnotationRest a

  let
      feature =
        build
         (insert    (SProxy :: SProxy "rest") rest
         >>> modify (SProxy :: SProxy "chr") ChrId
         >>> modify (SProxy :: SProxy "pos") Bp) raw

      position = (\p -> Pair p p) $ feature.pos

  frameSize <- case Map.lookup feature.chr (view _Segments cSys) of

    Nothing ->
      throwError $ pure $ ForeignError
                     "Annotation chr not found in coordinate system!"
    Just seg ->
      pure $ Bp $ BigInt.toNumber $ pairSize seg

  pure $ { position
         , frameSize
         , feature }

-- | Partially parse the parts of the annotation record that are *not* in the Annotation type
parseAnnotationRest :: Foreign
                    -> F (List AnnotationField)
parseAnnotationRest a = do
  allFields <- List.fromFoldable <$> Foreign.keys a

  let restFields = allFields `List.difference` annotationFields

  for restFields \field ->
     { field, value: _ } <$> Foreign.readProp field a

-- | A completely dumb default way of rendering arbitrary annotation fields
showAnnotationField :: AnnotationField -> String
showAnnotationField fv = fv.field <> ": " <> unsafeCoerce fv.value

showAnnotation :: Annotation ()
               -> List String
showAnnotation a = (List.fromFoldable
                    [ name, chr, pos ]) <> (map showAnnotationField annot.rest)
  where annot = a.feature
        name = fromMaybe ("SNP: " <> annot.name)
                         (("Gene: " <> _) <$> annot.gene)
        chr = "Chr: " <> show annot.chr
        pos = "Pos: " <> show annot.pos

getSNPs :: CoordSys ChrId BigInt
        -> String
        -> Aff (Map ChrId (Array (SNP ())))
getSNPs cs url = do
  resp <- Affjax.get Affjax.json url

  rawSNPs <-
    case runExcept $ Foreign.readArray $ unsafeCoerce resp.response of
           Left err -> throwError $ error "SNP data is not an array"
           Right as -> pure as

  let parsed =
        partitionMap (runExcept <<< parseSNP cs) rawSNPs

  pure $ groupToMap _.feature.chrId
         $ filter (\f -> Pair.fst (f.position) >= wrap zero)
         $ parsed.right

getAnnotations :: CoordSys ChrId BigInt
               -> String
               -> Aff (Map ChrId (Array (Annotation ())))
getAnnotations cs url = do
  resp <- Affjax.get Affjax.json url

  rawAnnots <- case runExcept
                    $ Foreign.readArray $ unsafeCoerce resp.response of
                 Left err -> throwError $ error "Annotations data is not an array"
                 Right as -> pure as

  let parsed = partitionMap
               (runExcept <<< parseAnnotation cs) rawAnnots

  -- debug/testing stuff
  liftEffect do
    log $ "Raw annotations array length: " <> show (Array.length rawAnnots)
    log $ "Could not parse "
        <> show (length parsed.left :: Int)
        <> " annotations."
    log $ "Successfully parsed "
        <> show (length parsed.right :: Int)
        <> " annotations."

    -- logging with unsafeCoerce lets us examine the raw JS object in the console!
    log $ unsafeCoerce (parsed.right)
  case Array.head parsed.right of
    Nothing -> pure unit
    Just an -> liftEffect do
      log "first annotation: "
      sequence_ (log <$> (("> " <> _) <$> showAnnotation an))

  pure $ groupToMap _.feature.chr parsed.right

peak1 :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Maybe (Tuple (Peak Bp Number (SNP rS))
                      (Array (SNP rS)))
peak1 radius snps = do
  top <- minimumBy (compare `on` _.feature.score) snps

  let covers = radius `aroundPair` top.position
      y = top.feature.score
      {no, yes} = partition (\p -> p.position `pairsOverlap` covers) snps

  pure $ Tuple {covers, y, elements: yes} no

peaks :: ∀ rS.
         Bp
      -> Array (SNP rS)
      -> Array (Peak Bp Number (SNP rS))
peaks r snps = unfoldr (peak1 r) snps

type AnnotationsConfig =
  { radius    :: Number
  , outline   :: HexColor
  , snpColor  :: HexColor
  , geneColor :: HexColor }

defaultAnnotationsConfig :: AnnotationsConfig
defaultAnnotationsConfig =
  { radius:    5.5
  , outline:   wrap black
  , snpColor:  wrap blue
  , geneColor: wrap red }

annotationLegendEntry :: ∀ r. AnnotationsConfig -> Annotation r -> LegendEntry
annotationLegendEntry conf a =
  let mkIcon color = outlined (outlineColor (unwrap conf.outline) <> lineWidth 2.0)
                  <> filled (fillColor $ unwrap color)
                   $ circle 0.0 0.0 conf.radius
  in case a.feature.gene of
       Nothing -> { text: "SNP name",  icon: mkIcon conf.snpColor  }
       Just gn -> { text: "Gene name", icon: mkIcon conf.geneColor }

annotationLegendTest :: ∀ f r.
                   Foldable f
                => Functor f
                => AnnotationsConfig
                -> Map ChrId (f (Annotation r))
                -> Array LegendEntry
annotationLegendTest config fs = trackLegend (annotationLegendEntry config) as
  where as = Array.concat
             $ Array.fromFoldable
             $ Array.fromFoldable <$> Map.values fs

normYLogScore :: ∀ r.
                 { min :: Number
                 , max :: Number
                 | r }
              -> Number
              -> Number
normYLogScore s =
  normalize s.min s.max <<< unwrap <<< view _NegLog10

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 (SNP r2))
          -> Map ChrId (Array (SNP r2))
filterSig {sig} = map (filter
  (\snp -> snp.feature.score <= (NegLog10 sig ^. re _NegLog10)))

snpsUI :: ∀ c.
          VScale (VScaleRow ())
       -> RenderableLayer c
snpsUI vscale = renderFixedUI (CLeft $ drawVScaleInSlot vscale)

annotationsUI :: ∀ r c.
                 LegendConfig (entries :: Array LegendEntry | r)
              -> RenderableLayer c
annotationsUI legend = renderFixedUI (CRight $ drawLegendInSlot legend)

type SNPConfig
  = { radius :: Number
    , lineWidth :: Number
    , color :: { outline :: HexColor
               , fill    :: HexColor }
    , pixelOffset :: Point }

defaultSNPConfig :: SNPConfig
defaultSNPConfig =
  { radius: 3.75
  , lineWidth: 1.0
  , color: { outline: wrap darkblue, fill: wrap darkblue }
  , pixelOffset: {x: 0.0, y: 0.0}
  }

renderSNPs :: ∀ r1.
              Map ChrId (Array (SNP ()))
           -> { threshold  :: { min  :: Number, max :: Number | r1 }
              , render :: SNPConfig }
           -> Map ChrId (Pair Number)
           -> Canvas.Dimensions
           -> { renderables :: List Renderable
              , hotspots :: Number -> Point -> Array (SNP ()) }
renderSNPs snpData { render, threshold } =
  let radius = render.radius

      drawing =
          let {x,y} = render.pixelOffset
              c     = circle x y radius
              out   = outlined (outlineColor (unwrap render.color.outline) <>
                                lineWidth render.lineWidth) c
              fill  = filled   (fillColor    $ unwrap render.color.fill)    c
          in out <> fill

      drawings :: Array (Tuple (SNP ()) Point) -> Array BatchDrawing
      drawings pts = [{ drawing, points: view _2 <$> pts }]

      pointed :: Canvas.Dimensions
              -> Map ChrId (Pair Number)
              -> Array (Tuple (SNP ()) Point)
      pointed size = foldMapWithIndex placeSeg
        where
              place :: Pair Number -> SNP () -> Point
              place seg@(Pair offset _) s =
                { x: offset + (pairSize seg) * (unwrap $ featureNormX s)
                , y: size.height * (one - normYLogScore threshold s.feature.score) }

              placeSeg :: ChrId -> Pair Number -> Array (Tuple (SNP ()) Point)
              placeSeg chrId seg = foldMap (map $ fanout identity (place seg))
                                    $ Map.lookup chrId snpData

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

  in \seg size ->
        let pts = pointed size seg
        in { renderables: pure $ inj _drawingBatch $ drawings pts
           , hotspots: hotspots pts }

annotationsForScale :: ∀ r1 r2 i c.
                       CoordSys i c
                    -> Map ChrId (Array (SNP r1))
                    -> Map ChrId (Array (Annotation r2))
                    -> Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
annotationsForScale cSys snps annots =
  mapWithIndex \chr seg -> fromMaybe [] do
    segSnps      <- Map.lookup chr snps
    segAnnots    <- Map.lookup chr annots
    frameSize <- _.frameSize <$> Array.head segSnps

    let rad = (wrap 3.75 * frameSize) / (wrap $ pairSize seg)
        f pk = pk { elements = filter
                          (pairsOverlap pk.covers <<< _.position) segAnnots }

    pure $ f <$> peaks rad segSnps

renderAnnotationPeaks :: ∀ r1 r2.
                         CoordSys ChrId BigInt
                      -> { min :: Number, max :: Number | r1 }
                      -> AnnotationsConfig
                      -> Map ChrId (Array (Peak Bp Number (Annotation r2)))
                      -> Canvas.Dimensions
                      -> Map ChrId (Pair Number)
                      -> { drawingBatch :: Array BatchDrawing, labels :: Array Label }
renderAnnotationPeaks cSys vScale conf annoPks cdim =
  let

      curAnnotPeaks :: Map ChrId (Pair Number)
                    -> Map ChrId (Array (Peak Number Number (Annotation r2)))
      curAnnotPeaks segs = mapWithIndex f annoPks
        where f chr pks = fromMaybe [] do
                  frameSize <- (wrap <<< BigInt.toNumber <<< pairSize)
                             <$> (Map.lookup chr $ cSys ^. _Segments)
                  pxSeg@(Pair l _) <- Map.lookup chr segs

                  let rescale pk = pk { covers = (\x -> l + pairSize pxSeg *
                                          (unwrap $ x / frameSize)) <$> pk.covers
                                      , y = cdim.height * (one - normYLogScore vScale pk.y) }

                  pure $ map rescale pks

      tailHeight = 0.06
      tailPixels = tailHeight * cdim.height
      iconYOffset = 6.5
      labelOffset = 8.0

      -- part of the canvas that a given peak will cover when rendered
      drawingCovers :: ∀ a.
                       Peak Number Number a
                    -> Canvas.Rectangle
      drawingCovers aPeak = {x, y, width: w, height: h}
        where (Pair x _) = aPeak.covers
              w = 14.0  -- hardcoded glyph width in pixels
              gH = (11.0 - iconYOffset) -- hardcoded height
              h = tailPixels + gH * length aPeak.elements
              y = aPeak.y - h

      drawAndLabel :: Peak Number Number (Annotation r2)
                   -> Tuple (Array BatchDrawing) (Array Label)
      drawAndLabel aPeak = Tuple [drawing] label
        where
              (Pair l r) = aPeak.covers
              x = l + 0.5 * (r - l)

              icons = Drawing.translate 0.0 (-tailPixels)
                      $ foldr (\a d -> Drawing.translate 0.0 (-iconYOffset)
                                     $ (annotationLegendEntry conf a).icon <> d)
                          mempty aPeak.elements

              tail = if Array.null aPeak.elements
                then mempty
                else Drawing.outlined (lineWidth 1.3 <> outlineColor black)
                       $ Drawing.path [ {x: 0.0, y: 0.0 }, {x: 0.0, y: -tailPixels }]

              drawing = { drawing: tail <> icons, points: [{x, y: aPeak.y }] }

              -- hardcoded font size because this will be handled by UI.Canvas later
              fontHeight = 14.0
              labelsHeight = length aPeak.elements * fontHeight

              dC = drawingCovers aPeak
                -- if all the labels fit above the icons, they're centered;
                -- otherwise just place them to the left and hope for the best
              {g, y0} = if dC.y > labelsHeight
                then { g: LCenter, y0: dC.y  }
                else { g: LLeft, y0: aPeak.y }

              label = Tuple.snd $ foldr f (Tuple y0 mempty) aPeak.elements
              f a (Tuple y ls) = Tuple (y - labelOffset)
                                    $ Array.snoc ls
                                         { text: fromMaybe a.feature.name a.feature.gene
                                         , point: { x, y }
                                         , gravity: g
                                         }

      drawAndLabelAll :: Map ChrId (Array (Peak _ _ _))
                      -> Tuple (Array BatchDrawing) (Array Label)
      drawAndLabelAll pks = foldMap (foldMap drawAndLabel) pks

  in \segs -> let (Tuple drawingBatch labels) =
                    drawAndLabelAll $ curAnnotPeaks segs
              in { drawingBatch, labels }

renderAnnotations :: ∀ r1 r2 rC.
                    CoordSys ChrId BigInt
                 -> Map ChrId (Array (SNP ()))
                 -> Map ChrId (Array (Annotation r1))
                 -> { threshold :: { min :: Number, max :: Number | r2 }
                    , render :: AnnotationsConfig | rC }
                 -> Map ChrId (Pair Number)
                 -> Canvas.Dimensions
                 -> List Renderable
renderAnnotations cSys sigSnps allAnnots conf =
  let annoPeaks = annotationsForScale cSys sigSnps allAnnots

  in \seg size ->
        let {drawingBatch, labels} =
              renderAnnotationPeaks cSys conf.threshold conf.render (annoPeaks seg) size seg
        in List.fromFoldable
           [ inj _drawingBatch $ drawingBatch
           , inj _labels   $ labels ]

_snps = SProxy :: SProxy "snps"
_annotations = SProxy :: SProxy "annotations"

addGWASLayers :: ∀ r r2.
                 { score :: { min :: Number, max :: Number, sig :: Number }
                 , legend :: LegendConfig ()
                 , vscale :: VScale ()
                 , chrLabels :: { fontSize :: Int }
                 , snps :: SNPConfig
                 , annotations :: AnnotationsConfig
                 , coordinateSystem :: CoordSys ChrId BigInt | r }
              -> { snps        :: Map ChrId (Array (SNP ()))
                 , annotations :: Map ChrId (Array (Annotation ())) | r2 }
              -> TrackContainer
              -> Effect { snps        :: Pair Number -> CoordSysView -> Effect Unit
                        , annotations :: Pair Number -> CoordSysView -> Effect Unit
                        , chrs        :: Pair Number -> CoordSysView -> Effect Unit
                        , hotspots    :: Effect (Number -> Point -> Array (SNP ()))
                        , fixedUI     :: Effect Unit }
addGWASLayers config trackData =
  let threshold = config.score
      vscale = build (merge config.vscale) threshold

      sigSnps = filterSig config.score trackData.snps
      legend = Record.insert (SProxy :: SProxy "entries")
               (annotationLegendTest
                 config.annotations
                 trackData.annotations) config.legend

      segmentPadding = 12.0
      conf = { segmentPadding }
      cSys = config.coordinateSystem

      bgLayer :: ∀ r'.
                 RenderableLayer { background :: { bg1 :: HexColor
                                                 , bg2 :: HexColor
                                                 , segmentPadding :: Number }
                                 , view :: CoordSysView | r' }
      bgLayer =
        renderTrackLike conf cSys (SProxy :: SProxy "background")
          (Center chrBackgroundLayer)

      snpLayer :: RenderableLayerHotspots _ _
      snpLayer =
        renderTrackLike conf cSys _snps
          (Center $ renderSNPs trackData.snps)

      annotationLayer :: RenderableLayer
                         { annotations
                           :: { threshold :: Threshold
                              , render :: AnnotationsConfig }
                         , view :: CoordSysView }
      annotationLayer =
        renderTrackLike conf cSys _annotations
          (Center $ renderAnnotations cSys sigSnps trackData.annotations)

  in \bc -> do

    rBG  <-
      createAndAddLayer_ bc "chrBackground" bgLayer

    rRuler <-
      createAndAddLayer_ bc "ruler"
        $ Layer Fixed NoMask (Center thresholdRuler)

    rSNPs  <-
      createAndAddLayer  bc "snps" snpLayer

    rAnnos <-
      createAndAddLayer_ bc "annotations" annotationLayer

    rVScale <-
      createAndAddLayer_ bc "vscale" $ snpsUI vscale

    rLegend <-
      createAndAddLayer_ bc "legend" $ annotationsUI legend

    rChrLabels <-
      createAndAddLayer_ bc "chrLabels"
        $ chrLabels { segmentPadding
                    , fontSize: config.chrLabels.fontSize }  cSys

    let fixedUI = do
          let uiConf = { rulerColor: wrap red, threshold }

          traverse_ (renderLayer (Pair 0.0 0.0) uiConf)
                      [ rVScale, rLegend, rRuler ]

        snps o v = do
          renderLayer o { snps: { threshold, render: config.snps }
                        , view: v } rSNPs

        hotspots = rSNPs.lastHotspots

        annotations o v =
          renderLayer o { annotations: { threshold, render: config.annotations }
                        , view: v } rAnnos

        chrs o v = do
          let bgConf = { background: { bg1: HexColor white
                                     , bg2: HexColor lightgray
                                     , segmentPadding }
                       , view: v }
          traverse_ (renderLayer o bgConf)
                      [rBG, rChrLabels]

    pure { snps
         , annotations
         , hotspots
         , fixedUI
         , chrs
         }

addGeneLayers :: ∀ r r2.
                 _
              -> { genes        :: Map ChrId (Array BedFeature) | r2 }
              -> TrackContainer
              -> Effect { genes :: Pair Number -> CoordSysView -> Effect Unit
                        , chrs  :: Pair Number -> CoordSysView -> Effect Unit }
addGeneLayers config trackData tcont = do

  let
      segmentPadding = 12.0
      conf = { segmentPadding }

      bgLayer :: ∀ r'.
                 RenderableLayer { background :: { bg1 :: HexColor
                                                 , bg2 :: HexColor
                                                 , segmentPadding :: Number }
                                 , view :: CoordSysView | r' }
      bgLayer =
        renderTrackLike conf config.coordinateSystem (SProxy :: SProxy "background")
          (Center chrBackgroundLayer)

      geneLayer :: _
      geneLayer =
        renderTrackLike conf config.coordinateSystem (SProxy :: SProxy "genes")
          (Center $ renderGenes trackData.genes)

  rBG  <-
    createAndAddLayer_ tcont "background" bgLayer

  rChrLabels <-
    createAndAddLayer_ tcont "chrLabels"
      $ chrLabels { segmentPadding
                  , fontSize: config.chrLabels.fontSize } config.coordinateSystem

  rGenes <-
    createAndAddLayer_ tcont "genes" geneLayer

  let genes o v =
        renderLayer o { genes: {}, view: v } rGenes

      chrs o v = do
        let bgConf = { background: { bg1: HexColor white
                                   , bg2: HexColor lightgray
                                   , segmentPadding }
                     , view: v }
        traverse_ (renderLayer o bgConf)
                    [rBG, rChrLabels]

  pure { genes
       , chrs }