Use Functor instead of Bind

Use Functor instead of Bind

Using functorGenT, decorateSeed can be made simpler and faster.

module Test.StrongCheck.Gen
  ( GenT(..)
  , Gen(..)
  , GenState(..)
  , GenOut(..)
  , Size
  , allInArray
  , allInRange
  , applyGen
  , arrayOf
  , arrayOf1
  , charGen
  , choose
  , chooseInt
  , chunked
  , collectAll
  , decorateSeed
  , dropGen
  , elements
  , extend
  , foldGen
  , foldGen'
  , frequency
  , infinite
  , interleave
  , nChooseK
  , oneOf
  , perms
  , perturbGen
  , repeatable
  , resize
  , runGen
  , sample
  , sample'
  , showSample
  , showSample'
  , shuffle
  , shuffle'
  , shuffleArray
  , sized
  , stateful
  , suchThat
  , suchThatMaybe
  , takeGen
  , toLazyList
  , transGen
  , uniform
  , unGen
  , unGenOut
  , unGenState
  , updateSeedState
  , variant
  , vectorOf
  , wrapEffect
  ) where

import Prelude

import Control.Alt (class Alt, (<|>))
import Control.Alternative (class Alternative)
import Control.Lazy as CL
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (logShow, CONSOLE)
import Control.Monad.List.Trans as ListT
import Control.Monad.Trampoline (runTrampoline, Trampoline)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)

import Data.Array as A
import Data.Array.Partial as AP
import Data.Char (fromCharCode)
import Data.Foldable (fold)
import Data.Int (toNumber)
import Data.Lazy (Lazy, defer)
import Data.List as L
import Data.Machine.Mealy as Mealy
import Data.Maybe (fromMaybe, maybe, Maybe(..), fromJust)
import Data.Monoid (mempty, class Monoid)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Profunctor (arr, lmap)
import Data.Profunctor.Strong ((&&&))
import Data.Tuple (Tuple(..), snd, fst)

import Math as M

import Partial.Unsafe (unsafePartial)

import Test.StrongCheck.LCG (Seed, mkSeed, runSeed, lcgPerturb, lcgNext, lcgN)

type Size = Int

newtype GenState = GenState { seed :: Seed, size :: Size }

unGenState :: GenState -> { seed :: Seed, size :: Size }
unGenState (GenState s) = s

stateM
  :: ({ seed :: Seed, size :: Size } -> { seed :: Seed, size :: Size })
  -> GenState
  -> GenState
stateM f = GenState <<< f <<< unGenState

newtype GenOut a = GenOut { state :: GenState, value :: a }

unGenOut :: forall a. GenOut a -> { state :: GenState, value :: a }
unGenOut (GenOut v) = v

newtype GenT f a = GenT (Mealy.MealyT f GenState (GenOut a))

type Gen a = GenT Trampoline a

unGen :: forall f a. GenT f a -> Mealy.MealyT f GenState (GenOut a)
unGen (GenT m) = m

decorateSeed :: forall f a. Monad f => GenT f a -> GenT f (Tuple Seed a)
decorateSeed gen = stateful \sIn -> Tuple (unGenState sIn).seed <$> gen

lcgStep :: forall f. Monad f => GenT f Int
lcgStep = GenT $ arr \s ->
  GenOut { state: updateSeedState s, value: runSeed (unGenState s).seed }

uniform :: forall f. Monad f => GenT f Number
uniform = (\n -> toNumber n / toNumber lcgN) <$> lcgStep

stepGen
  :: forall f a
   . Monad f
  => GenState
  -> GenT f a
  -> f (Maybe (GenOut (Tuple a (GenT f a))))
stepGen st (GenT m) = h <$> Mealy.stepMealy st m
  where
  h Mealy.Halt = Nothing
  h (Mealy.Emit a m') = Just $ flip Tuple (GenT m') <$> a

evalGen :: forall f a. Monad f => GenT f a -> GenState -> f (Maybe a)
evalGen g st = h <$> stepGen st g
  where
  h Nothing = Nothing
  h (Just (GenOut { value: Tuple a _ })) = Just a

pureGen :: forall f a. Monad f => (GenState -> GenOut a) -> GenT f a
pureGen f = GenT $ arr f

repeatable' :: forall f a b. Monad f => (a -> GenT f b) -> GenT f (a -> f b)
repeatable' = unsafePartial \f -> GenT $
  Mealy.pureMealy \s ->
    Mealy.Emit
      (GenOut { state: s, value: \a -> fromJust <$> evalGen (f a) s })
      Mealy.halt

-- | Creates a function generator that will always generate the same output
-- | for the same input.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = g <$> repeatable' f
  where
  g f' = \a -> runTrampoline $ f' a

-- | Creates a generator that depends on access to the generator state.
stateful :: forall f a. Monad f => (GenState -> GenT f a) -> GenT f a
stateful f = GenT $ unGen <<< f =<< Mealy.take 1 id

-- | Fixes a generator on a certain variant, given by the specified seed.
variant :: forall f a. Monad f => Seed -> GenT f a -> GenT f a
variant n g = GenT $ lmap (stateM (\s -> s { seed = n })) (unGen g)

-- | Creates a generator that depends on the size parameter.
sized :: forall f a. Monad f => (Size -> GenT f a) -> GenT f a
sized f = stateful \s -> f (unGenState s).size

-- | Resizes the generator so the size parameter passed into the generator
-- | will be equal to the specified size.
resize :: forall f a. Monad f => Size -> GenT f a -> GenT f a
resize sz g = GenT $ lmap (stateM (\s -> s { size = sz })) (unGen g)

-- | A generator for characters.
charGen :: forall f. Monad f => GenT f Char
charGen = fromCharCode <$> chooseInt 0 65535

-- | Creates a generator that generates real numbers between the specified
-- | inclusive range.
choose :: forall f. Monad f => Number -> Number -> GenT f Number
choose a b = (*) (max - min) >>> (+) min <$> uniform
  where
  min = M.min a b
  max = M.max a b

-- | Creates a generator that generates integers between the specified
-- | inclusive range.
chooseInt :: forall f. Monad f => Int -> Int -> GenT f Int
chooseInt a b = clamp <$> lcgStep
  where
  clamp :: Int -> Int
  clamp x = case x `mod` (b - a + one) of
              r | r >= 0 -> a + r
                | otherwise -> b + r + one

-- | Creates a generator that chooses another generator from the specified list
-- | at random, and then generates a value with that generator.
oneOf :: forall f a. Monad f => GenT f a -> Array (GenT f a) -> GenT f a
oneOf x xs = do
  n <- chooseInt 0 (A.length xs)
  if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

-- | Generates elements by the specified frequencies (which will be normalized).
frequency
  :: forall f a
   . Monad f
  => Tuple Number (GenT f a)
  -> L.List (Tuple Number (GenT f a))
  -> GenT f a
frequency x xs = do
  let xxs :: L.List (Tuple Number (GenT f a))
      xxs = L.Cons x xs

      total :: Number
      total = unwrap $ fold ((Additive <<< fst) <$> xxs)

      pick :: Number -> GenT f a -> L.List (Tuple Number (GenT f a)) -> GenT f a
      pick _ d L.Nil = d
      pick n d (L.Cons (Tuple k x') xs') = if n <= k then x' else pick (n - k) d xs'

  n <- choose 1.0 total
  pick n (snd x) xxs

-- | Creates a generator of elements ranging from 0 to the maximum size.
arrayOf :: forall f a. Monad f => GenT f a -> GenT f (Array a)
arrayOf g = sized \n -> do
  k <- chooseInt 0 n
  vectorOf k g

-- | Creates a generator of elements ranging from 1 to the maximum size.
arrayOf1 :: forall f a. Monad f => GenT f a -> GenT f (Tuple a (Array a))
arrayOf1 g = sized \n -> do
  k <- chooseInt 0 n
  x <- g
  xs <- vectorOf (k - 1) g
  pure $ Tuple x xs

-- | Creates a generator that generates arrays of some specified size.
vectorOf :: forall f a. Monad f => Int -> GenT f a -> GenT f (Array a)
vectorOf n g = transGen f [] (extend n g)
  where
  f b a =
    let b' = b <> [a]
    in if A.length b' >= n then Tuple [] (Just b') else Tuple b' Nothing

-- | Creates a generator that chooses an element from among a set of elements.
elements :: forall f a. Monad f => a -> L.List a -> GenT f a
elements x xs = do
  n <- chooseInt 0 (L.length xs)
  pure if n == 0 then x else fromMaybe x (xs L.!! (n - 1))

foreign import float32ToInt32 :: Number -> Int

perturbGen :: forall f a. Monad f => Number -> GenT f a -> GenT f a
perturbGen n (GenT m) =
  GenT $ lmap (stateM (\s -> s { seed = lcgPerturb (toNumber (float32ToInt32 n)) s.seed })) m

updateSeedState :: GenState -> GenState
updateSeedState (GenState s) = GenState { seed: lcgNext s.seed, size: s.size }

updateSeedGen :: forall f a. Monad f => GenT f a -> GenT f a
updateSeedGen (GenT m) = GenT $ lmap updateSeedState m

liftMealy
  :: forall f a
   . Monad f
   => (Mealy.MealyT f GenState (GenOut a) -> Mealy.MealyT f GenState (GenOut a))
   -> GenT f a
   -> GenT f a
liftMealy f = \g -> GenT $ f (unGen g)

-- | Takes the first number of values from the generator. Will turn an infinite
-- | generator into a finite generator.
takeGen :: forall f a. Monad f => Int -> GenT f a -> GenT f a
takeGen n = liftMealy $ Mealy.take n

-- | Drops a certain number of values from the generator. May produce
-- | an empty generator if called on a finite generator.
dropGen :: forall f a. Monad f => Int -> GenT f a -> GenT f a
dropGen n = liftMealy $ Mealy.drop n

-- | Extends a generator to produce *at least* the specified number of values.
-- | Will not turn a finite generator into an infinite one.
extend :: forall f a. Monad f => Int -> GenT f a -> GenT f a
extend n (GenT m) = (GenT $ loop 0 m) <> (GenT m)
  where
  loop i m' = Mealy.mealy \st ->
    let
      f (Mealy.Emit s m'') = pure $ Mealy.Emit s (loop (i + 1) m'')
      f Mealy.Halt =
        if i >= n then pure Mealy.Halt else Mealy.stepMealy st (loop i m)
    in Mealy.stepMealy st m' >>= f

-- | Fairly interleaves two generators.
interleave :: forall f a. Monad f => GenT f a -> GenT f a -> GenT f a
interleave (GenT g1) (GenT g2) = GenT $ Mealy.interleave g1 g2

-- | Ensures that a given generator can produce an infinite number of values,
-- | assuming it can produce at least one.
infinite :: forall f a. Monad f => GenT f a -> GenT f a
infinite = liftMealy $ Mealy.loop

-- | Folds over a generator to produce a value. Either the generator or the
-- | user-defined function may halt the fold. Returns not just the value
-- | created through folding, but also the successor generator.
foldGen'
  :: forall f a b
   . Monad f
  => (b -> a -> Maybe b)
  -> b
  -> GenState
  -> GenT f a -> f (Tuple b (GenT f a))
foldGen' f b s (GenT m) = loop s m b
  where
  loop st m' b' = Mealy.stepMealy st m' >>= g
    where
    g Mealy.Halt = pure $ Tuple b' (GenT Mealy.halt)
    g (Mealy.Emit (GenOut { value: a, state: st' }) m'') =
      let b'' = f b' a in maybe (pure $ Tuple b' (GenT m'')) (loop st' m'') b''

-- | Folds over a generator to produce a value. Either the generator or the
-- | user-defined function may halt the fold.
foldGen
  :: forall f a b
   . Monad f
  => (b -> a -> Maybe b)
  -> b
  -> GenState
  -> GenT f a
  -> f b
foldGen f b s g = fst <$> foldGen' f b s g

-- | Transforms one gen into another, passing along user-supplied state.
-- | Either the generator being transformed or the transforming function may
-- | halt the transformation.
transGen
  :: forall f a b c
   . Monad f
  => (b -> a -> Tuple b (Maybe c))
  -> b
  -> GenT f a
  -> GenT f c
transGen f b (GenT m) = GenT $ loop m b
  where
  loop m' b' = Mealy.mealy \st -> Mealy.stepMealy st m' >>= g
    where
    g Mealy.Halt = pure Mealy.Halt
    g (Mealy.Emit (GenOut { value: a, state: st }) m'') =
      case f b' a of
        Tuple b'' Nothing  -> Mealy.stepMealy st (loop m'' b'')
        Tuple b'' (Just c) ->
          let c' = GenOut { value: c, state: st }
          in  pure $ Mealy.Emit c' (loop m'' b'')

-- | A deterministic generator that produces all possible permutations of
-- | the specified array.
perms :: forall f a. Monad f => Array a -> GenT f (Array a)
perms = unsafePartial \arr ->
  if A.length arr == 0
  then pure [ ]
  else do
    let hd = AP.head arr
        tl = AP.tail arr
    xs <- perms tl
    let f n = let prefix = A.take n xs
                  suffix = A.drop n xs
              in prefix <> [hd] <> suffix
    allInArray $ f <$> A.range 0 (A.length xs)

-- | A deterministic generator that produces all possible combinations of
-- | choosing exactly k elements from the specified array.
nChooseK :: forall f a. Monad f => Int -> Array a -> GenT f (Array a)
nChooseK = unsafePartial \k arr ->
  if k == 0 then pure []
  else if A.length arr == 0
       then mempty
       else
         let tl = A.drop 1 arr
             hd = A.singleton $ A.unsafeIndex arr 0
         in ((hd <> _) <$> (nChooseK (k - 1) tl)) <> nChooseK k tl

-- | Same as `nChooseK` but for `List`
nChooseKL :: forall f a. Monad f => Int -> L.List a -> GenT f (L.List a)
nChooseKL 0 _ = pure L.Nil
nChooseKL _ L.Nil = mempty
nChooseKL k (L.Cons x xs) =
  (((L.singleton x) <> _) <$> (nChooseKL (k - 1) xs)) <> nChooseKL k xs

-- | Filters a generator to produce only values satisfying the specified
-- | predicate.
suchThat :: forall f a. Monad f => GenT f a -> (a -> Boolean) -> GenT f a
suchThat g p = g `suchThatMaybe` p >>= maybe (sized next) pure
  where
  next n = resize (n + 1) (g `suchThat` p)

-- | Tries to filter a generator such that it only produces values satisfying
-- | the specified predicate.
suchThatMaybe
  :: forall f a
   . Monad f
  => GenT f a
  -> (a -> Boolean)
  -> GenT f (Maybe a)
suchThatMaybe g p = sized $ try 0
  where
  try _ 0 = pure Nothing
  try k n = do
    x <- resize (2 * k + n) g
    if p x then pure (Just x) else try (k + 1) (n - 1)

-- | A deterministic generator that produces integers from the specified
-- | inclusive range, in sequence.
allInRange :: forall f. Monad f => Int -> Int -> GenT f Int
allInRange min max = GenT $ go min
  where
  go cur = Mealy.pureMealy \s ->
    if cur > max
    then Mealy.Halt
    else Mealy.Emit (GenOut {state:s, value:cur}) (go (cur + 1))

-- | A deterministic generator that produces values from the specified array,
-- | in sequence.
allInArray :: forall f a. Monad f => Array a -> GenT f a
allInArray a = GenT $ go 0
  where
  go i = Mealy.pureMealy \s ->
    maybe
      Mealy.Halt
      (\a' -> Mealy.Emit (GenOut { state: s, value: a' }) (go (i + 1)))
      (a A.!! i)

-- | Drains a finite generator of all values. Or blows up if you called it on
-- | an infinite generator.
collectAll :: forall f a. Monad f => GenState -> GenT f a -> f (Array a)
collectAll = foldGen f []
  where
  f v a = Just $ v <> [a]

-- | Applies a state to a generator to possibly produce the next state,
-- | a value, and the next generator.
applyGen
  :: forall f a
   . Monad f
  => GenState
  -> GenT f a
  -> f (Maybe (GenOut (Tuple a (GenT f a))))
applyGen s (GenT m) = f <$> Mealy.stepMealy s m
  where
  f Mealy.Halt = Nothing
  f (Mealy.Emit (GenOut { state, value: a }) m') =
    Just $ GenOut { state, value: Tuple a (GenT m')}

-- | Samples a generator, producing the specified number of values.
sample' :: forall f a. Monad f => Int -> GenState -> GenT f a -> f (Array a)
sample' n st g = fst <$> runGen n st g

-- | Samples a generator, producing the specified number of values. Uses
-- | default settings for the initial generator state.
sample :: forall f a. Monad f => Int -> GenT f a -> f (Array a)
sample n = sample' n (GenState { size: 10, seed: mkSeed 445645874 })

-- | Shows a sample of values generated from the specified generator.
showSample'
  :: forall r a
   . Show a
  => Int
  -> Gen a
  -> Eff (console :: CONSOLE | r) Unit
showSample' n g = logShow $ runTrampoline $ sample n g

-- | Shows a sample of values generated from the specified generator.
showSample :: forall r a. Show a => Gen a -> Eff (console :: CONSOLE | r) Unit
showSample = showSample' 10

-- | Runs a generator to produce a specified number of values, returning both
-- | an array containing the values and the successor Gen that can be used to
-- | continue the generation process at a later time.
runGen
  :: forall f a
   . Monad f
  => Int
  -> GenState
  -> GenT f a -> f (Tuple (Array a) (GenT f a))
runGen n st g = foldGen' f [] st (extend n g)
  where
  f v a = if A.length v < n then Just $ v <> [a] else Nothing

-- | Creates a generator that produces chunks of values in the specified size.
-- | Will extend the generator if necessary to produce a chunk of the specified
-- | size, but will not turn a finite generator into an infinite generator.
chunked :: forall f a. Monad f => Int -> GenT f a -> GenT f (Array a)
chunked n g = transGen f [] (extend n g)
  where
  f xs a =
    let xs' = a A.: xs
    in if A.length xs' >= n then Tuple [] (Just xs') else Tuple xs' Nothing

-- | Wraps an effect in a generator that ignores the input state.
wrapEffect :: forall f a. Monad f => f a -> GenT f a
wrapEffect fa = GenT $ g <$> (id &&& (Mealy.wrapEffect fa))
  where
  g (Tuple l r) = GenOut { state: l, value: r }

-- | Creates a generator that mixes up the order of the specified generator.
-- | This is achieved by chunking the generator with the specified size
-- | and then shuffling each chunk before continuing to the next.
shuffle' :: forall f a. Monad f => Int -> GenT f a -> GenT f a
shuffle' n g = do
  chunks <- chunked n g
  shuffled <- shuffleArray chunks
  allInArray shuffled

-- | Same as shuffle' but with default for the chunk size.
shuffle :: forall f a. Monad f => GenT f a -> GenT f a
shuffle = shuffle' 100

-- | Creates a generator that produces shuffled versions of the provided array.
shuffleArray :: forall f a. Monad f => Array a -> GenT f (Array a)
shuffleArray = shuffle0 []
  where
  shuffle0 acc [] = pure $ acc
  shuffle0 acc xs = do
    i <- chooseInt 0 (A.length xs - 1)
    let acc' = acc <> (maybe [] A.singleton (xs A.!! i))
        xs' = fromMaybe xs $ A.deleteAt i xs
    shuffle0 acc' xs'

-- | Converts the generator into a function that, given the initial state,
-- | returns a lazy list.
toLazyList :: forall a. Gen a -> GenState -> ListT.ListT Lazy a
toLazyList (GenT m) s = ListT.wrapLazy $ defer \_ -> loop m s
  where
  loop m' s' =
    case runTrampoline (Mealy.stepMealy s' m') of
      Mealy.Halt -> ListT.nil
      Mealy.Emit (GenOut { value, state }) m'' ->
        ListT.prepend' value (defer \_ -> loop m'' state)

instance semigroupGenState :: Semigroup GenState where
  append (GenState a) (GenState b) =
    GenState { seed: lcgPerturb (toNumber (runSeed a.seed)) b.seed, size: b.size }

instance monoidGenState :: Monoid GenState where
  mempty = GenState { seed: mkSeed 85734629, size: 10 }

instance semigroupGenOut :: Semigroup a => Semigroup (GenOut a) where
  append (GenOut a) (GenOut b) =
    GenOut { state: a.state <> b.state, value: a.value <> b.value }

instance monoidGenOut :: Monoid a => Monoid (GenOut a) where
  mempty = GenOut { state: mempty, value: mempty }

instance functorGenOut :: Functor GenOut where
  map f (GenOut m) = GenOut { state: m.state, value: f m.value }

instance applyGenOut :: Apply GenOut where
  apply (GenOut f) (GenOut x) =
    GenOut { state: x.state, value: f.value x.value }

-- GenT instances
instance functorGenT :: Monad f => Functor (GenT f) where
  map f (GenT m) = GenT $ map f <$> m

instance applyGenT :: Monad f => Apply (GenT f) where
  apply f x = GenT $ apply <$> unGen f <*> unGen (updateSeedGen x)

instance applicativeGenT :: Monad f => Applicative (GenT f) where
  pure t = GenT $ arr (\s -> GenOut { state: updateSeedState s, value: t })

instance semigroupGenT :: Monad f => Semigroup (GenT f a) where
  append (GenT a) (GenT b) = GenT (a <> b)

instance monoidGenT :: Monad f => Monoid (GenT f a) where
  mempty = GenT mempty

instance bindGenT :: Monad f => Bind (GenT f) where
  bind (GenT m) f = GenT do
    a <- m
    unGen $ updateSeedGen (f (unGenOut a).value)

instance monadGenT :: Monad f => Monad (GenT f)

instance altGenT :: Monad f => Alt (GenT f) where
  alt (GenT x) (GenT y) = GenT $ x <|> y

instance plusGenT :: Monad f => Plus (GenT f) where
  empty = mempty

instance alternativeGenT :: Monad f => Alternative (GenT f)

instance monadZeroGenT :: Monad f => MonadZero (GenT f)

instance monadPlusGenT :: Monad f => MonadPlus (GenT f)

instance lazyGenT :: Monad f => CL.Lazy (GenT f a) where
  defer f = GenT $ CL.defer (unGen <<< f)

module Test.StrongCheck.Gen
  ( GenT(..)
  , Gen(..)
  , GenState(..)
  , GenOut(..)
  , Size
  , allInArray
  , allInRange
  , applyGen
  , arrayOf
  , arrayOf1
  , charGen
  , choose
  , chooseInt
  , chunked
  , collectAll
  , decorateSeed
  , dropGen
  , elements
  , extend
  , foldGen
  , foldGen'
  , frequency
  , infinite
  , interleave
  , nChooseK
  , oneOf
  , perms
  , perturbGen
  , repeatable
  , resize
  , runGen
  , sample
  , sample'
  , showSample
  , showSample'
  , shuffle
  , shuffle'
  , shuffleArray
  , sized
  , stateful
  , suchThat
  , suchThatMaybe
  , takeGen
  , toLazyList
  , transGen
  , uniform
  , unGen
  , unGenOut
  , unGenState
  , updateSeedState
  , variant
  , vectorOf
  , wrapEffect
  ) where

import Prelude

import Control.Alt (class Alt, (<|>))
import Control.Alternative (class Alternative)
import Control.Lazy as CL
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (logShow, CONSOLE)
import Control.Monad.List.Trans as ListT
import Control.Monad.Trampoline (runTrampoline, Trampoline)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)

import Data.Array as A
import Data.Array.Partial as AP
import Data.Char (fromCharCode)
import Data.Foldable (fold)
import Data.Int (toNumber)
import Data.Lazy (Lazy, defer)
import Data.List as L
import Data.Machine.Mealy as Mealy
import Data.Maybe (fromMaybe, maybe, Maybe(..), fromJust)
import Data.Monoid (mempty, class Monoid)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Profunctor (arr, lmap)
import Data.Profunctor.Strong ((&&&))
import Data.Tuple (Tuple(..), snd, fst)

import Math as M

import Partial.Unsafe (unsafePartial)

import Test.StrongCheck.LCG (Seed, mkSeed, runSeed, lcgPerturb, lcgNext, lcgN)

type Size = Int

newtype GenState = GenState { seed :: Seed, size :: Size }

unGenState :: GenState -> { seed :: Seed, size :: Size }
unGenState (GenState s) = s

stateM
  :: ({ seed :: Seed, size :: Size } -> { seed :: Seed, size :: Size })
  -> GenState
  -> GenState
stateM f = GenState <<< f <<< unGenState

newtype GenOut a = GenOut { state :: GenState, value :: a }

unGenOut :: forall a. GenOut a -> { state :: GenState, value :: a }
unGenOut (GenOut v) = v

newtype GenT f a = GenT (Mealy.MealyT f GenState (GenOut a))

type Gen a = GenT Trampoline a

unGen :: forall f a. GenT f a -> Mealy.MealyT f GenState (GenOut a)
unGen (GenT m) = m

decorateSeed :: forall f a. Monad f => GenT f a -> GenT f (Tuple Seed a)
decorateSeed (GenT orig) = stateful \sIn ->
  GenT $ do
    GenOut x <- orig
    pure $ GenOut $ x { value = Tuple (unGenState sIn).seed x.value }

lcgStep :: forall f. Monad f => GenT f Int
lcgStep = GenT $ arr \s ->
  GenOut { state: updateSeedState s, value: runSeed (unGenState s).seed }

uniform :: forall f. Monad f => GenT f Number
uniform = (\n -> toNumber n / toNumber lcgN) <$> lcgStep

stepGen
  :: forall f a
   . Monad f
  => GenState
  -> GenT f a
  -> f (Maybe (GenOut (Tuple a (GenT f a))))
stepGen st (GenT m) = h <$> Mealy.stepMealy st m
  where
  h Mealy.Halt = Nothing
  h (Mealy.Emit a m') = Just $ flip Tuple (GenT m') <$> a

evalGen :: forall f a. Monad f => GenT f a -> GenState -> f (Maybe a)
evalGen g st = h <$> stepGen st g
  where
  h Nothing = Nothing
  h (Just (GenOut { value: Tuple a _ })) = Just a

pureGen :: forall f a. Monad f => (GenState -> GenOut a) -> GenT f a
pureGen f = GenT $ arr f

repeatable' :: forall f a b. Monad f => (a -> GenT f b) -> GenT f (a -> f b)
repeatable' = unsafePartial \f -> GenT $
  Mealy.pureMealy \s ->
    Mealy.Emit
      (GenOut { state: s, value: \a -> fromJust <$> evalGen (f a) s })
      Mealy.halt

-- | Creates a function generator that will always generate the same output
-- | for the same input.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = g <$> repeatable' f
  where
  g f' = \a -> runTrampoline $ f' a

-- | Creates a generator that depends on access to the generator state.
stateful :: forall f a. Monad f => (GenState -> GenT f a) -> GenT f a
stateful f = GenT $ unGen <<< f =<< Mealy.take 1 id

-- | Fixes a generator on a certain variant, given by the specified seed.
variant :: forall f a. Monad f => Seed -> GenT f a -> GenT f a
variant n g = GenT $ lmap (stateM (\s -> s { seed = n })) (unGen g)

-- | Creates a generator that depends on the size parameter.
sized :: forall f a. Monad f => (Size -> GenT f a) -> GenT f a
sized f = stateful \s -> f (unGenState s).size

-- | Resizes the generator so the size parameter passed into the generator
-- | will be equal to the specified size.
resize :: forall f a. Monad f => Size -> GenT f a -> GenT f a
resize sz g = GenT $ lmap (stateM (\s -> s { size = sz })) (unGen g)

-- | A generator for characters.
charGen :: forall f. Monad f => GenT f Char
charGen = fromCharCode <$> chooseInt 0 65535

-- | Creates a generator that generates real numbers between the specified
-- | inclusive range.
choose :: forall f. Monad f => Number -> Number -> GenT f Number
choose a b = (*) (max - min) >>> (+) min <$> uniform
  where
  min = M.min a b
  max = M.max a b

-- | Creates a generator that generates integers between the specified
-- | inclusive range.
chooseInt :: forall f. Monad f => Int -> Int -> GenT f Int
chooseInt a b = clamp <$> lcgStep
  where
  clamp :: Int -> Int
  clamp x = case x `mod` (b - a + one) of
              r | r >= 0 -> a + r
                | otherwise -> b + r + one

-- | Creates a generator that chooses another generator from the specified list
-- | at random, and then generates a value with that generator.
oneOf :: forall f a. Monad f => GenT f a -> Array (GenT f a) -> GenT f a
oneOf x xs = do
  n <- chooseInt 0 (A.length xs)
  if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

-- | Generates elements by the specified frequencies (which will be normalized).
frequency
  :: forall f a
   . Monad f
  => Tuple Number (GenT f a)
  -> L.List (Tuple Number (GenT f a))
  -> GenT f a
frequency x xs = do
  let xxs :: L.List (Tuple Number (GenT f a))
      xxs = L.Cons x xs

      total :: Number
      total = unwrap $ fold ((Additive <<< fst) <$> xxs)

      pick :: Number -> GenT f a -> L.List (Tuple Number (GenT f a)) -> GenT f a
      pick _ d L.Nil = d
      pick n d (L.Cons (Tuple k x') xs') = if n <= k then x' else pick (n - k) d xs'

  n <- choose 1.0 total
  pick n (snd x) xxs

-- | Creates a generator of elements ranging from 0 to the maximum size.
arrayOf :: forall f a. Monad f => GenT f a -> GenT f (Array a)
arrayOf g = sized \n -> do
  k <- chooseInt 0 n
  vectorOf k g

-- | Creates a generator of elements ranging from 1 to the maximum size.
arrayOf1 :: forall f a. Monad f => GenT f a -> GenT f (Tuple a (Array a))
arrayOf1 g = sized \n -> do
  k <- chooseInt 0 n
  x <- g
  xs <- vectorOf (k - 1) g
  pure $ Tuple x xs

-- | Creates a generator that generates arrays of some specified size.
vectorOf :: forall f a. Monad f => Int -> GenT f a -> GenT f (Array a)
vectorOf n g = transGen f [] (extend n g)
  where
  f b a =
    let b' = b <> [a]
    in if A.length b' >= n then Tuple [] (Just b') else Tuple b' Nothing

-- | Creates a generator that chooses an element from among a set of elements.
elements :: forall f a. Monad f => a -> L.List a -> GenT f a
elements x xs = do
  n <- chooseInt 0 (L.length xs)
  pure if n == 0 then x else fromMaybe x (xs L.!! (n - 1))

foreign import float32ToInt32 :: Number -> Int

perturbGen :: forall f a. Monad f => Number -> GenT f a -> GenT f a
perturbGen n (GenT m) =
  GenT $ lmap (stateM (\s -> s { seed = lcgPerturb (toNumber (float32ToInt32 n)) s.seed })) m

updateSeedState :: GenState -> GenState
updateSeedState (GenState s) = GenState { seed: lcgNext s.seed, size: s.size }

updateSeedGen :: forall f a. Monad f => GenT f a -> GenT f a
updateSeedGen (GenT m) = GenT $ lmap updateSeedState m

liftMealy
  :: forall f a
   . Monad f
   => (Mealy.MealyT f GenState (GenOut a) -> Mealy.MealyT f GenState (GenOut a))
   -> GenT f a
   -> GenT f a
liftMealy f = \g -> GenT $ f (unGen g)

-- | Takes the first number of values from the generator. Will turn an infinite
-- | generator into a finite generator.
takeGen :: forall f a. Monad f => Int -> GenT f a -> GenT f a
takeGen n = liftMealy $ Mealy.take n

-- | Drops a certain number of values from the generator. May produce
-- | an empty generator if called on a finite generator.
dropGen :: forall f a. Monad f => Int -> GenT f a -> GenT f a
dropGen n = liftMealy $ Mealy.drop n

-- | Extends a generator to produce *at least* the specified number of values.
-- | Will not turn a finite generator into an infinite one.
extend :: forall f a. Monad f => Int -> GenT f a -> GenT f a
extend n (GenT m) = (GenT $ loop 0 m) <> (GenT m)
  where
  loop i m' = Mealy.mealy \st ->
    let
      f (Mealy.Emit s m'') = pure $ Mealy.Emit s (loop (i + 1) m'')
      f Mealy.Halt =
        if i >= n then pure Mealy.Halt else Mealy.stepMealy st (loop i m)
    in Mealy.stepMealy st m' >>= f

-- | Fairly interleaves two generators.
interleave :: forall f a. Monad f => GenT f a -> GenT f a -> GenT f a
interleave (GenT g1) (GenT g2) = GenT $ Mealy.interleave g1 g2

-- | Ensures that a given generator can produce an infinite number of values,
-- | assuming it can produce at least one.
infinite :: forall f a. Monad f => GenT f a -> GenT f a
infinite = liftMealy $ Mealy.loop

-- | Folds over a generator to produce a value. Either the generator or the
-- | user-defined function may halt the fold. Returns not just the value
-- | created through folding, but also the successor generator.
foldGen'
  :: forall f a b
   . Monad f
  => (b -> a -> Maybe b)
  -> b
  -> GenState
  -> GenT f a -> f (Tuple b (GenT f a))
foldGen' f b s (GenT m) = loop s m b
  where
  loop st m' b' = Mealy.stepMealy st m' >>= g
    where
    g Mealy.Halt = pure $ Tuple b' (GenT Mealy.halt)
    g (Mealy.Emit (GenOut { value: a, state: st' }) m'') =
      let b'' = f b' a in maybe (pure $ Tuple b' (GenT m'')) (loop st' m'') b''

-- | Folds over a generator to produce a value. Either the generator or the
-- | user-defined function may halt the fold.
foldGen
  :: forall f a b
   . Monad f
  => (b -> a -> Maybe b)
  -> b
  -> GenState
  -> GenT f a
  -> f b
foldGen f b s g = fst <$> foldGen' f b s g

-- | Transforms one gen into another, passing along user-supplied state.
-- | Either the generator being transformed or the transforming function may
-- | halt the transformation.
transGen
  :: forall f a b c
   . Monad f
  => (b -> a -> Tuple b (Maybe c))
  -> b
  -> GenT f a
  -> GenT f c
transGen f b (GenT m) = GenT $ loop m b
  where
  loop m' b' = Mealy.mealy \st -> Mealy.stepMealy st m' >>= g
    where
    g Mealy.Halt = pure Mealy.Halt
    g (Mealy.Emit (GenOut { value: a, state: st }) m'') =
      case f b' a of
        Tuple b'' Nothing  -> Mealy.stepMealy st (loop m'' b'')
        Tuple b'' (Just c) ->
          let c' = GenOut { value: c, state: st }
          in  pure $ Mealy.Emit c' (loop m'' b'')

-- | A deterministic generator that produces all possible permutations of
-- | the specified array.
perms :: forall f a. Monad f => Array a -> GenT f (Array a)
perms = unsafePartial \arr ->
  if A.length arr == 0
  then pure [ ]
  else do
    let hd = AP.head arr
        tl = AP.tail arr
    xs <- perms tl
    let f n = let prefix = A.take n xs
                  suffix = A.drop n xs
              in prefix <> [hd] <> suffix
    allInArray $ f <$> A.range 0 (A.length xs)

-- | A deterministic generator that produces all possible combinations of
-- | choosing exactly k elements from the specified array.
nChooseK :: forall f a. Monad f => Int -> Array a -> GenT f (Array a)
nChooseK = unsafePartial \k arr ->
  if k == 0 then pure []
  else if A.length arr == 0
       then mempty
       else
         let tl = A.drop 1 arr
             hd = A.singleton $ A.unsafeIndex arr 0
         in ((hd <> _) <$> (nChooseK (k - 1) tl)) <> nChooseK k tl

-- | Same as `nChooseK` but for `List`
nChooseKL :: forall f a. Monad f => Int -> L.List a -> GenT f (L.List a)
nChooseKL 0 _ = pure L.Nil
nChooseKL _ L.Nil = mempty
nChooseKL k (L.Cons x xs) =
  (((L.singleton x) <> _) <$> (nChooseKL (k - 1) xs)) <> nChooseKL k xs

-- | Filters a generator to produce only values satisfying the specified
-- | predicate.
suchThat :: forall f a. Monad f => GenT f a -> (a -> Boolean) -> GenT f a
suchThat g p = g `suchThatMaybe` p >>= maybe (sized next) pure
  where
  next n = resize (n + 1) (g `suchThat` p)

-- | Tries to filter a generator such that it only produces values satisfying
-- | the specified predicate.
suchThatMaybe
  :: forall f a
   . Monad f
  => GenT f a
  -> (a -> Boolean)
  -> GenT f (Maybe a)
suchThatMaybe g p = sized $ try 0
  where
  try _ 0 = pure Nothing
  try k n = do
    x <- resize (2 * k + n) g
    if p x then pure (Just x) else try (k + 1) (n - 1)

-- | A deterministic generator that produces integers from the specified
-- | inclusive range, in sequence.
allInRange :: forall f. Monad f => Int -> Int -> GenT f Int
allInRange min max = GenT $ go min
  where
  go cur = Mealy.pureMealy \s ->
    if cur > max
    then Mealy.Halt
    else Mealy.Emit (GenOut {state:s, value:cur}) (go (cur + 1))

-- | A deterministic generator that produces values from the specified array,
-- | in sequence.
allInArray :: forall f a. Monad f => Array a -> GenT f a
allInArray a = GenT $ go 0
  where
  go i = Mealy.pureMealy \s ->
    maybe
      Mealy.Halt
      (\a' -> Mealy.Emit (GenOut { state: s, value: a' }) (go (i + 1)))
      (a A.!! i)

-- | Drains a finite generator of all values. Or blows up if you called it on
-- | an infinite generator.
collectAll :: forall f a. Monad f => GenState -> GenT f a -> f (Array a)
collectAll = foldGen f []
  where
  f v a = Just $ v <> [a]

-- | Applies a state to a generator to possibly produce the next state,
-- | a value, and the next generator.
applyGen
  :: forall f a
   . Monad f
  => GenState
  -> GenT f a
  -> f (Maybe (GenOut (Tuple a (GenT f a))))
applyGen s (GenT m) = f <$> Mealy.stepMealy s m
  where
  f Mealy.Halt = Nothing
  f (Mealy.Emit (GenOut { state, value: a }) m') =
    Just $ GenOut { state, value: Tuple a (GenT m')}

-- | Samples a generator, producing the specified number of values.
sample' :: forall f a. Monad f => Int -> GenState -> GenT f a -> f (Array a)
sample' n st g = fst <$> runGen n st g

-- | Samples a generator, producing the specified number of values. Uses
-- | default settings for the initial generator state.
sample :: forall f a. Monad f => Int -> GenT f a -> f (Array a)
sample n = sample' n (GenState { size: 10, seed: mkSeed 445645874 })

-- | Shows a sample of values generated from the specified generator.
showSample'
  :: forall r a
   . Show a
  => Int
  -> Gen a
  -> Eff (console :: CONSOLE | r) Unit
showSample' n g = logShow $ runTrampoline $ sample n g

-- | Shows a sample of values generated from the specified generator.
showSample :: forall r a. Show a => Gen a -> Eff (console :: CONSOLE | r) Unit
showSample = showSample' 10

-- | Runs a generator to produce a specified number of values, returning both
-- | an array containing the values and the successor Gen that can be used to
-- | continue the generation process at a later time.
runGen
  :: forall f a
   . Monad f
  => Int
  -> GenState
  -> GenT f a -> f (Tuple (Array a) (GenT f a))
runGen n st g = foldGen' f [] st (extend n g)
  where
  f v a = if A.length v < n then Just $ v <> [a] else Nothing

-- | Creates a generator that produces chunks of values in the specified size.
-- | Will extend the generator if necessary to produce a chunk of the specified
-- | size, but will not turn a finite generator into an infinite generator.
chunked :: forall f a. Monad f => Int -> GenT f a -> GenT f (Array a)
chunked n g = transGen f [] (extend n g)
  where
  f xs a =
    let xs' = a A.: xs
    in if A.length xs' >= n then Tuple [] (Just xs') else Tuple xs' Nothing

-- | Wraps an effect in a generator that ignores the input state.
wrapEffect :: forall f a. Monad f => f a -> GenT f a
wrapEffect fa = GenT $ g <$> (id &&& (Mealy.wrapEffect fa))
  where
  g (Tuple l r) = GenOut { state: l, value: r }

-- | Creates a generator that mixes up the order of the specified generator.
-- | This is achieved by chunking the generator with the specified size
-- | and then shuffling each chunk before continuing to the next.
shuffle' :: forall f a. Monad f => Int -> GenT f a -> GenT f a
shuffle' n g = do
  chunks <- chunked n g
  shuffled <- shuffleArray chunks
  allInArray shuffled

-- | Same as shuffle' but with default for the chunk size.
shuffle :: forall f a. Monad f => GenT f a -> GenT f a
shuffle = shuffle' 100

-- | Creates a generator that produces shuffled versions of the provided array.
shuffleArray :: forall f a. Monad f => Array a -> GenT f (Array a)
shuffleArray = shuffle0 []
  where
  shuffle0 acc [] = pure $ acc
  shuffle0 acc xs = do
    i <- chooseInt 0 (A.length xs - 1)
    let acc' = acc <> (maybe [] A.singleton (xs A.!! i))
        xs' = fromMaybe xs $ A.deleteAt i xs
    shuffle0 acc' xs'

-- | Converts the generator into a function that, given the initial state,
-- | returns a lazy list.
toLazyList :: forall a. Gen a -> GenState -> ListT.ListT Lazy a
toLazyList (GenT m) s = ListT.wrapLazy $ defer \_ -> loop m s
  where
  loop m' s' =
    case runTrampoline (Mealy.stepMealy s' m') of
      Mealy.Halt -> ListT.nil
      Mealy.Emit (GenOut { value, state }) m'' ->
        ListT.prepend' value (defer \_ -> loop m'' state)

instance semigroupGenState :: Semigroup GenState where
  append (GenState a) (GenState b) =
    GenState { seed: lcgPerturb (toNumber (runSeed a.seed)) b.seed, size: b.size }

instance monoidGenState :: Monoid GenState where
  mempty = GenState { seed: mkSeed 85734629, size: 10 }

instance semigroupGenOut :: Semigroup a => Semigroup (GenOut a) where
  append (GenOut a) (GenOut b) =
    GenOut { state: a.state <> b.state, value: a.value <> b.value }

instance monoidGenOut :: Monoid a => Monoid (GenOut a) where
  mempty = GenOut { state: mempty, value: mempty }

instance functorGenOut :: Functor GenOut where
  map f (GenOut m) = GenOut { state: m.state, value: f m.value }

instance applyGenOut :: Apply GenOut where
  apply (GenOut f) (GenOut x) =
    GenOut { state: x.state, value: f.value x.value }

-- GenT instances
instance functorGenT :: Monad f => Functor (GenT f) where
  map f (GenT m) = GenT $ map f <$> m

instance applyGenT :: Monad f => Apply (GenT f) where
  apply f x = GenT $ apply <$> unGen f <*> unGen (updateSeedGen x)

instance applicativeGenT :: Monad f => Applicative (GenT f) where
  pure t = GenT $ arr (\s -> GenOut { state: updateSeedState s, value: t })

instance semigroupGenT :: Monad f => Semigroup (GenT f a) where
  append (GenT a) (GenT b) = GenT (a <> b)

instance monoidGenT :: Monad f => Monoid (GenT f a) where
  mempty = GenT mempty

instance bindGenT :: Monad f => Bind (GenT f) where
  bind (GenT m) f = GenT do
    a <- m
    unGen $ updateSeedGen (f (unGenOut a).value)

instance monadGenT :: Monad f => Monad (GenT f)

instance altGenT :: Monad f => Alt (GenT f) where
  alt (GenT x) (GenT y) = GenT $ x <|> y

instance plusGenT :: Monad f => Plus (GenT f) where
  empty = mempty

instance alternativeGenT :: Monad f => Alternative (GenT f)

instance monadZeroGenT :: Monad f => MonadZero (GenT f)

instance monadPlusGenT :: Monad f => MonadPlus (GenT f)

instance lazyGenT :: Monad f => CL.Lazy (GenT f a) where
  defer f = GenT $ CL.defer (unGen <<< f)


Use functional builder to associate Appends to the right by construction

module Lambda.Language.Pretty
  ( class Pretty
  , pretty
  , Rep(..)
  , parensIf
  , select
  , toggle
  , Builder
  , text
  , style
  , toJSX
  , toString
  )
  where

import Lambda.Prelude

import React.Basic (JSX)
import React.Basic.DOM as R

data Rep = Raw | Sugar

derive instance genericRep :: Generic Rep _
derive instance eqRep :: Eq Rep

-- | Pretty-print some structure to a Builder
class Pretty a where
  pretty :: Rep -> a -> Builder

-- | Wrap with parentheses if condition is true
parensIf :: Boolean -> Builder -> Builder
parensIf cond body
  | cond = text "(" <> body <> text ")"
  | otherwise = body

-- | Select from object based on 'Rep'
select :: forall a. Rep -> { sugar :: a, raw :: a } -> a
select rep {sugar, raw} = case rep of
  Sugar -> sugar
  Raw -> raw

-- | Toggle 'Rep'
toggle :: Rep -> Rep
toggle = case _ of
  Sugar -> Raw
  Raw -> Sugar

-- | (<>) for JSX is really slow if you have lots of text fragments.
-- | By combining adjacent text, and _then_ going to JSX, we create
-- | way fewer DOM nodes.
newtype Builder = Builder (Node -> Node)

instance semigroupBuilder :: Semigroup Builder where
  append (Builder lhs) (Builder rhs) = Builder $ lhs <<< rhs

instance monoidBuilder :: Monoid Builder where
  mempty  = Builder identity

-- | Appends are right-associated by construction since
-- | Nodes cannot appear as their left operand
data Node
  = Leaf Leaf
  | Append Leaf Node

-- | Technically Style is a "node", but it acts like a leaf for Append
data Leaf
  = Empty
  | Text String
  | Style String Node

-- | Text node automatically coalesces adjacent text
text :: String -> Builder
text s = Builder $ case _ of
  Leaf Empty -> Leaf $ Text s
  Leaf (Text t) -> Leaf $ Text $ s <> t
  Append (Text t) rhs -> Append (Text $ s <> t) rhs
  node -> Append (Text s) node

-- | Style node using CSS classname
style :: String -> Builder -> Builder
style cls (Builder f) = Builder $ Append $ Style cls $ f $ Leaf Empty

-- | Render builder to JSX
toJSX :: Builder -> JSX
toJSX = buildWith R.text \className node -> R.span
  { className
  , children: [node]
  }

-- | Render builder to text
toString :: Builder -> String
toString = buildWith identity \_ -> identity

-- | Convert Builder to actual representation
buildWith
  :: forall r
   . Monoid r
  => (String -> r)
  -- ^ Generate text representation
  -> (String -> r -> r)
  -- ^ Generate styled representation
  -> Builder
  -> r
buildWith onText onStyle (Builder f) = onNode $ f $ Leaf Empty
 where
  onNode = case _ of
    Leaf leaf -> onLeaf leaf
    Append leaf node -> onLeaf leaf <> onNode node

  onLeaf = case _ of
    Empty -> mempty
    Text t -> onText t
    Style className node -> onStyle className $ onNode node

module Lambda.Language.Pretty
  ( class Pretty
  , pretty
  , Rep(..)
  , parensIf
  , select
  , toggle
  , Builder
  , text
  , style
  , toJSX
  , toString
  )
  where

import Lambda.Prelude

import React.Basic (JSX)
import React.Basic.DOM as R

data Rep = Raw | Sugar

derive instance genericRep :: Generic Rep _
derive instance eqRep :: Eq Rep

-- | Pretty-print some structure to a Builder
class Pretty a where
  pretty :: Rep -> a -> Builder

-- | Wrap with parentheses if condition is true
parensIf :: Boolean -> Builder -> Builder
parensIf cond body
  | cond = text "(" <> body <> text ")"
  | otherwise = body

-- | Select from object based on 'Rep'
select :: forall a. Rep -> { sugar :: a, raw :: a } -> a
select rep {sugar, raw} = case rep of
  Sugar -> sugar
  Raw -> raw

toggle :: Rep -> Rep
toggle = case _ of
  Sugar -> Raw
  Raw -> Sugar

-- | (<>) for JSX is really slow if you have lots of text fragments.
-- | By combining adjacent text, and _then_ going to JSX, we create
-- | way fewer DOM nodes.
data Builder
  = Empty
  | Text String
  | Style String Builder
  | Append Builder Builder

instance semigroupBuilder :: Semigroup Builder where
  append = Append

instance monoidBuilder :: Monoid Builder where
  mempty = Empty

-- | Text node
text :: String -> Builder
text = Text

-- | Style node using CSS classname
style :: String -> Builder -> Builder
style = Style

-- | Render builder to JSX
toJSX :: Builder -> JSX
toJSX = buildWith R.text \className node -> R.span
  { className
  , children: [node]
  }

-- | Render builder to text
toString :: Builder -> String
toString = buildWith identity \_ -> identity

-- | Reassociate appends to the right and pre-concatentate strings
buildWith
  :: forall r
   . Monoid r
  => (String -> r)
  -- ^ Generate text representation
  -> (String -> r -> r)
  -- ^ Generate styled representation
  -> Builder
  -> r
buildWith fromText fromStyle = search
 where
  -- Look for text and reassociate appends
  search = case _ of
    Text s -> fromText s
    Style cls node -> fromStyle cls $ search node
    Append (Text s) rhs -> collect s rhs
    Append (Append s t) u -> search $ Append s $ Append t u
    Append s t -> search s <> search t
    Empty -> mempty

  -- Accumulate text and reassociate appends
  collect acc = case _ of
    Text s -> fromText $ acc <> s
    Append (Text s) rhs -> collect (acc <> s) rhs
    Append (Append s t) u -> collect acc $ Append s $ Append t u
    node -> fromText acc <> search node


Update Types.purs

Update Types.purs

module Openspace.Types where

import Data.Tuple
import Data.Maybe
import qualified Data.Map as M
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Foreign.Index

-----------------
--| TopicType |--
-----------------

data TopicType = Discussion
               | Presentation
               | Workshop

instance eqTopicType :: Eq TopicType where
(==) tt1 tt2 = show tt1 == show tt2
(/=) tt1 tt2 = show tt1 /= show tt2

instance showTopicType :: Show TopicType where
  show Discussion = "Discussion"
  show Presentation = "Presentation"
  show Workshop = "Workshop"

instance foreignTopicType :: IsForeign TopicType where
  read val = case readString val of
    Right "Discussion"   -> Right Discussion
    Right "Presentation" -> Right Presentation
    Right "Workshop"     -> Right Workshop
    _                    -> Left $ JSONError "Cant read TopicType"

-- Used to fill Dropdowns etc.
-- TODO: Find a proper way to enumerate Union Datatypes
topicTypes = [Discussion, Presentation, Workshop]

--------------
--| Topics |--
--------------

newtype Topic = Topic { topic :: String
                      , typ   :: TopicType }

instance eqTopic :: Eq Topic where
  (==) (Topic t1) (Topic t2) = t1.topic == t2.topic && t1.typ == t2.typ
  (/=) t1 t2 = not (t1 == t2)

instance foreignTopic :: IsForeign Topic where
    read val = do
      topic <- readProp "topic" val :: F String
      typ   <- readProp "typ"   val :: F TopicType
      return $ Topic { topic: topic, typ: typ }

------------
--| Slot |--
------------

newtype Slot = Slot { room :: Room, block :: Block }

instance eqSlot :: Eq Slot where
  (==) (Slot s1) (Slot s2) = s1.room == s2.room && s1.block == s2.block
  (/=) (Slot s1) (Slot s2) = s1.room /= s2.room || s1.block /= s2.block

instance ordSlot :: Ord Slot where
  compare (Slot s1) (Slot s2) = (show s1.room ++ show s1.block) `compare` (show s2.room ++ show s2.block)

instance showSlot :: Show Slot where
  show (Slot s) = "{ room: " ++ show s.room ++" block: " ++ show s.block ++ "}"

instance foreignSlot :: IsForeign Slot where
  read val = do
    room <- readProp "room" val :: F Room
    block <- readProp "block" val :: F Block
    return $ Slot {room: room, block: block}

------------
--| Room |--
------------

newtype Room = Room { name :: String, capacity :: Number }

instance showRoom :: Show Room where
  show (Room r) = r.name

instance eqRoom :: Eq Room where
  (==) (Room r1) (Room r2) = r1.name == r2.name
  (/=) (Room r1) (Room r2) = r1.name /= r2.name

instance foreignRoom :: IsForeign Room where
  read val = do
    name     <- readProp "name" val     :: F String
    capacity <- readProp "capacity" val :: F Number
    return $ Room {name: name, capacity: capacity}

-------------
--| Block |--
-------------
type Timerange = { start :: String, end :: String }

newtype Block = Block { description :: String
                      , range       :: Timerange }

instance showBlock :: Show Block where
  show (Block b) = b.description

instance eqBlock :: Eq Block where
  (==) (Block b1) (Block b2) = b1.description == b2.description
                               && b1.range.start == b2.range.start
                               && b1.range.end == b2.range.end
  (/=) b1 b2 = not (b1 == b2)

instance foreignBlock :: IsForeign Block where
  read val = do
    description <- readProp "description" val
    start <- prop "range" val >>= readProp "start"
    end <- prop "range" val >>= readProp "end"
    return $ Block {description: description
                   , range:{ start: start
                           , end: end }
                   }

---------------
--| Actions |--
---------------

data Action = AddTopic Topic
            | DeleteTopic Topic
            | AddRoom Room
            | DeleteRoom Room
            | AddBlock Block
            | DeleteBlock Block
            | AssignTopic Slot Topic
            | UnassignTopic Topic
            | ShowError String
            | NOP

instance foreignAction :: IsForeign Action where
read val = case readProp "tag" val of
  Right "AddTopic" -> do
    t <- readProp "contents" val :: F Topic
    return $ AddTopic t
  Right "DeleteTopic" -> do
    t <- readProp "contents" val :: F Topic
    return $ DeleteTopic t
  Right "AddRoom" -> do
    r <- readProp "contents" val :: F Room
    return $ AddRoom r
  Right "DeleteRoom" -> do
    r <- readProp "contents" val :: F Room
    return $ DeleteRoom r
  Right "AddBlock" -> do
    b <- readProp "contents" val :: F Block
    return $ AddBlock b
  Right "DeleteBlock" -> do
    b <- readProp "contents" val :: F Block
    return $ DeleteBlock b
  Right "AssignTopic" -> do
    let val' = parseAssignTopic val
    s <- readProp "slot" val' :: F Slot
    t <- readProp "topic" val' :: F Topic
    return $ AssignTopic s t
  Right "UnassignTopic" -> do
    t <- readProp "contents" val :: F Topic
    return $ UnassignTopic t
  Right "ShowError" -> do
    m <- readProp "message" val :: F String
    return $ ShowError m
  Left e -> Right $ ShowError (show e)

class AsForeign a where
  serialize :: a -> Foreign

instance actionAsForeign :: AsForeign Action where
  serialize (AddTopic (Topic t)) =
    toForeign { tag: "AddTopic"
              , contents: { topic: t.topic
                          , typ: show t.typ
                          }
              }

  serialize (DeleteTopic (Topic t)) =
    toForeign { tag: "DeleteTopic"
              , contents: { topic: t.topic
                          , typ: show t.typ
                          }
              }
  serialize (AddRoom (Room r)) =
    toForeign { tag: "AddRoom"
              , contents: r }

  serialize (DeleteRoom (Room r)) =
    toForeign { tag: "DeleteRoom"
              , contents: r }

  serialize (AddBlock (Block b)) =
    toForeign { tag: "AddBlock"
              , contents: b }

  serialize (DeleteBlock (Block b)) =
    toForeign { tag: "DeleteBlock"
              , contents: b }

  serialize (AssignTopic s t) = serializeAssignTopic s t
  serialize (UnassignTopic (Topic t)) =
    toForeign { tag: "UnassignTopic"
              , contents: { topic: t.topic
                          , typ: show t.typ
                          }
              }

foreign import parseAssignTopic
"""
function parseAssignTopic(foreign) {
  return {
    topic : foreign.contents[1],
    slot : foreign.contents[0]
    }
  }
  """ :: Foreign -> Foreign

foreign import serializeAssignTopic
"""
function serializeAssignTopic(slot) {
  return function(topic){
    return { tag: "AssignTopic",
             contents:[
               slot,
               {
                 topic: topic.topic
                 , typ: Prelude.show(showTopicType)(topic.typ)
               }
             ]
           }
  }
}
""" :: Slot -> Topic -> Foreign

-------------------------
--| Entire AppState |--
-------------------------

type Timeslot = Tuple Slot Topic

type AppState = { topics :: [Topic]
                , rooms :: [Room]
                , blocks :: [Block]
                , timeslots :: M.Map Slot Topic
                }

type SanitizedTopic = { topic :: String, typ :: String }
type SanitizedSlot =  { room :: String, block :: String }
type SanitizedTimeslot = Tuple SanitizedSlot SanitizedTopic

type SanitizedAppState = { topics :: [SanitizedTopic]
                         , rooms :: [Room]
                         , blocks :: [String]
                         , timeslots :: [SanitizedTimeslot]
                         }

 --------------------
 --| Dummy Values |--
 --------------------

emptyState = {topics: [], rooms:[], blocks:[], timeslots: (M.empty) :: M.Map Slot Topic }

myRoom = Room {name: "Berlin", capacity: 100}
myRoom1 = Room {name: "Hamburg", capacity: 80}
myRoom2 = Room {name: "Köln", capacity: 30}

myBlock = Block { description:"First", range:{ start: "8:00am", end: "10:00am"} }
myBlock1 = Block { description:"Second", range:{ start: "10:00am", end: "12:00am"} }

mySlot = Slot {room:myRoom, block:myBlock}
mySlot1 = Slot {room:myRoom1, block:myBlock1}

myTopic = Topic  {topic:"Purescript is great", typ:Workshop}
myTopic1 = Topic {topic:"Reactive Design", typ:Presentation}
myTopic2 = Topic {topic:"Functional Javascript", typ:Discussion}
myTopic3 = Topic {topic:"Enemy of the State", typ:Presentation}
myTopic4 = Topic {topic:"Wayyyyyyy too long name for a Topic.", typ:Workshop}
myTopic5 = Topic {topic:"fix", typ:Discussion}

myState1 = { topics: [myTopic, myTopic1, myTopic2, myTopic3, myTopic4, myTopic5]
           , rooms : [myRoom, myRoom1, myRoom2]
           , blocks : [myBlock, myBlock1]
           , timeslots: M.fromList [Tuple mySlot myTopic, Tuple mySlot1 myTopic1]
           }


removed todo from fs dialog wrapper

removed todo from fs dialog wrapper

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Dialog.Render where

import SlamData.Prelude

import Halogen.HTML as H

import SlamData.Render.Common (classedDiv)

modalDialog :: forall f p. Array (H.HTML p (f Unit)) -> H.HTML p (f Unit)
modalDialog children =
  -- I think we don't need stopPropagation and preventDefault anymore
  (classedDiv $ H.ClassName "deck-dialog")
  [ H.div_
    children
  ]

modalHeader :: forall f p. String -> H.HTML p (f Unit)
modalHeader message =
  H.h4_ [ H.text message ]

modalBody :: forall f p. H.HTML p (f Unit) -> H.HTML p (f Unit)
modalBody = classedDiv (H.ClassName "deck-dialog-body") <<< pure

modalFooter :: forall f p. Array (H.HTML p (f Unit)) -> H.HTML p (f Unit)
modalFooter = classedDiv (H.ClassName "deck-dialog-footer")

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Dialog.Render where

import SlamData.Prelude

--import Halogen.HTML.Events as HE
-- TODO : stopPropagation
--import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML as H

import SlamData.Render.Common (classedDiv)

modalDialog :: forall f p. Array (H.HTML p (f Unit)) -> H.HTML p (f Unit)
modalDialog children =
  (classedDiv $ H.ClassName "deck-dialog")
  [ H.div
    [ ]
--    [ HE.onClick (\_ -> HEH.stopPropagation $> Nothing)
--    , HE.onMouseDown (\_ -> HEH.stopPropagation $> Nothing)
--    ]
    children
  ]

modalHeader :: forall f p. String -> H.HTML p (f Unit)
modalHeader message =
  H.h4_ [ H.text message ]

modalBody :: forall f p. H.HTML p (f Unit) -> H.HTML p (f Unit)
modalBody = classedDiv (H.ClassName "deck-dialog-body") <<< pure

modalFooter :: forall f p. Array (H.HTML p (f Unit)) -> H.HTML p (f Unit)
modalFooter = classedDiv (H.ClassName "deck-dialog-footer")


fix unsafeTrace

fix unsafeTrace

module Control.Monad.Aff.Unsafe where
  import Control.Monad.Aff

  foreign import unsafeTrace """
    function unsafeTrace(v) {
      return function(success, error) {
        console.log(v);

        try {
          success(v);
        } catch (e) {
          error(e);
        }

        var nonCanceler;

        nonCanceler = function(e) {
          return function(sucess, error) {
            success(false);

            return nonCanceler;
          }
        };

        return nonCanceler;
      };
    }
  """ :: forall e a. a -> Aff e Unit

  foreign import unsafeInterleaveAff """
    function unsafeInterleaveAff(aff) {
      return aff;
    }
  """ :: forall e1 e2 a. Aff e1 a -> Aff e2 a

module Control.Monad.Aff.Unsafe where
  import Control.Monad.Aff

  foreign import unsafeTrace """
    function unsafeTrace(v) {
      return function(error) {
        return function(success) {
          return function() {
            console.log(v);

            success({})();
          }
        }
      }
    }
  """ :: forall e a. a -> Aff e Unit

  foreign import unsafeInterleaveAff """
    function unsafeInterleaveAff(aff) {
      return aff;
    }
  """ :: forall e1 e2 a. Aff e1 a -> Aff e2 a


Render colored chromosomes

Render colored chromosomes

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((!!), (..))
import Data.Array as Array
import Data.Foldable (foldMap, for_, length)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(..), fromJust, fromMaybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap, wrap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

posPixelsX :: XPosInfo
           -> Bp
           -> Pixels
posPixelsX { scale } pos = bpToPixels scale pos

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

type Renderer eff a =
  { hPos :: a -> XPosInfo -> Pixels
  , vPos :: a -> YPosInfo -> Pixels
  , render :: a -> Context2D -> Eff eff Unit
  , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
  }

gwasRenderer :: {min :: Number, max :: Number}
             -> Renderer _ {score :: Number, pos :: Bp}
gwasRenderer {min, max} = { hPos, vPos, render, hit: Nothing }
  where hPos a xInfo = posPixelsX xInfo a.pos
        nScore s = (s - min) / (max - min)
        vPos a yInfo = posPixelsY yInfo (nScore a.score)
        render _ ctx = renderGlyph ctx $ circle { x: 0.0, y: 0.0 } 5.0

-- profunctors/arrows could come in here
-- or polymorphic records, maybe? would have to be (Tuple r1 a) -> (Tuple r2 a) tho
strokeRenderer :: forall a.
                  Renderer _ a
               -> Renderer _ (Tuple String a)
strokeRenderer r = {hPos, vPos, render, hit}
  where hPos (Tuple _ a) = r.hPos a
        vPos (Tuple _ a) = r.vPos a
        hit = Nothing -- TODO fix this
        render (Tuple col a) ctx = C.withContext ctx do
          _ <- C.setStrokeStyle col ctx
          r.render a ctx

fillRenderer :: forall a.
                Renderer _ a
             -> Renderer _ (Tuple String a)
fillRenderer r = {hPos, vPos, render, hit}
  where hPos (Tuple _ a) = r.hPos a
        vPos (Tuple _ a) = r.vPos a
        hit = Nothing -- TODO fix this
        render (Tuple col a) ctx = C.withContext ctx do
          _ <- C.setFillStyle col ctx
          r.render a ctx

runRenderer :: forall a.
               a
            -> Renderer _ a
            -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
            -> Context2D
            -> Eff _ Unit
runRenderer a { hPos, vPos, render, hit } { xInfo, yInfo } ctx = C.withContext ctx do
  let translateX = hPos a xInfo
      translateY = vPos a yInfo
  _ <- C.translate {translateX, translateY} ctx
  render a ctx

runRendererN :: forall a.
                Renderer _ a
             -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
             -> Array a
             -> Context2D
             -> Eff _ Unit
runRendererN r p as ctx =
  for_ as (\a -> runRenderer a r p ctx)

-- TODO the `offset` should probably be in XPosInfo,
-- and be the actual pixel offset for that bit on the canvas...
-- type Frames a = { offset :: Pixels, frames :: Array (Tuple {xInfo :: XPosInfo} a) }

type Frames f a = { offset :: Pixels
                  , frames :: Array { xInfo :: XPosInfo
                                    , context :: f
                                    , contents :: a
                                    } }

frames :: forall f a.
          Pixels
       -> Pixels
       -> (a -> Bp)
       -> Array (Tuple f a)
       -> Frames f a
frames width offset f chrs = { offset
                             , frames: g <$> chrs}
  where n = length chrs
        -- TODO the scale should depend on the current size; that needs more work
        totalSize = alaF Additive foldMap (f <<< snd) chrs
        width' = width - offset * n
        g (Tuple b a) = let size = f a
                            xInfo = { size, scale: BpPerPixel (unwrap totalSize / width' ) }
                            context = b
                            contents = a
                        in { xInfo, context, contents }

-- mapFrames :: forall a b.
--              (a -> b)
--           -> Frames a
--           -> Frames b
-- mapFrames f fs = fs { frames = map f <$> fs.frames }

-- zipWithFrames :: forall a b.
--              Array (a -> b)
--           -> Frames a
--           -> Frames b
-- zipWithFrames funs fs = fs { frames = frames }
--   where frames = Array.zipWith (\fun frame -> fun <$> frame) funs fs.frames

renderFrames :: forall f a.
                YPosInfo
             -> Frames f a
             -> Renderer _ a
             -> (f -> Context2D -> Eff _ Unit)
             -> Context2D
             -> Eff _ Unit
renderFrames yInfo {offset, frames} r pre ctx = C.withContext ctx (foreachE frames f)
  where f {xInfo, context, contents} = do
            void $ C.translate {translateX: offset, translateY: 0.0} ctx
            r.render contents ctx
            let len = bpToPixels xInfo.scale xInfo.size
            void $ C.translate {translateX: len, translateY: 0.0} ctx

renderFramesN :: forall f a.
                 YPosInfo
              -> Frames f (Array a)
              -> Renderer _ a
              -> (f -> Context2D -> Eff _ Unit)
              -> Context2D
              -> Eff _ Unit
renderFramesN yInfo {offset, frames} r pre ctx = C.withContext ctx (foreachE frames f)
  where f {xInfo, context, contents} = do
            pre context ctx
            runRendererN r {xInfo, yInfo} contents ctx
            log $ "scale: " <> show (unwrap xInfo.scale)
            let len = bpToPixels xInfo.scale xInfo.size
            void $ C.translate {translateX: len+offset, translateY: 0.0} ctx

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

(         a -> (Translation, Eff _ Unit))
(Identity a -> (Translation, Eff _ Unit))

(       f a ->  g           (Eff _ Unit))
(       f a ->  Identity    (Eff _ Unit))
-}

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }
{-
renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit
-}

testFetch :: String
          -> Aff _ (Array { score :: Number, pos :: Bp })
testFetch url = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe {score :: Number, pos :: Bp}
      f j = do
            obj <- j ^? _Object
            pos <- Bp <$> obj ^? ix "min" <<< _Number
            pValue <- readFloat <$> obj ^? ix "pValue" <<< _String
            let score = (-1.0) * (Math.log pValue / Math.log 10.0)
            pure {pos, score}

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

testRender :: forall a.
              Renderer _ a
           -> Array a
           -> Aff _ Unit
testRender r as = do
  liftEff $ log "running"
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let size = Bp 122030190.0
      n = 10
      scale = BpPerPixel (unwrap size / (w / 10.0))
      xInfo = { size, scale }
      height = h
      offset = 0.0
      yInfo = { height, offset }
      colors = ["yellow", "orange", "red", "purple", "blue"]

      fs :: Frames _ (Array _)
      fs = frames w 20.0 (const size) $ Array.zip (1..5) (Array.replicate 5 as)

      pre :: Int -> Context2D -> Eff _ Unit
      pre i ctx = do
        let color = fromMaybe "black" (colors !! i `mod` 5)
        void $ C.setStrokeStyle color ctx
        void $ C.setFillStyle color ctx

  liftEff $ renderFramesN yInfo fs r pre ctx

main = launchAff $ do
  dat <- testFetch "./gwas.json"
  let min = 0.0
      max = 50.0
  testRender (gwasRenderer {min, max}) dat

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

-- runTrack :: forall a r.
--             View
--          -> Track _ _ a
--          -> Aff _ Unit
-- runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

  -- {w,h} <- liftEff do
  --   {w} <- getScreenSize
  --   h <- getCanvasHeight opts.canvas
  --   _ <- setCanvasWidth (w-2.0) opts.canvas
  --   pure {w, h}

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  -- pure unit

{-

browser :: Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}

module Genetics.Browser.Track where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (AVar, makeVar, takeVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (StateT(..))
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array as Array
import Data.Foldable (foldMap, for_, length)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(..), fromJust)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (ala, alaF, unwrap, wrap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..))
import Debug.Trace (trace)
import Genetics.Browser.DataSource (DataSource)
import Genetics.Browser.Glyph (Glyph, circle)
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, ChrId(..), Point, Range, bpToPixels)
import Genetics.Browser.UI.Native (getScreenSize)
import Genetics.Browser.UI.Native.View as View
import Genetics.Browser.View (View, Pixels)
import Global (readFloat)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Graphics.Canvas as C
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)

type Track aff eff a = { source :: DataSource aff a
                       , render :: Array a -> Eff eff Unit
                       , getPoint :: Point -> Array a
                       , chrSize :: Chr -> Bp
                       }

{-

Have a way to "prepare" data per-chromosome for rendering.

Then have a way to actually render that prepared data,
given some extra information such as offset, height scaling, etc.

Also need to map clicks backward, but that should be doable.

Maybe render to an offscreen canvas and copyImage.
Not sure that makes sense either
-}

-- given a size on the chromosome,
-- the position of the chromosome,
-- return a function from scale to ncanvas X-coordinate
type XPosInfo = { size :: Bp, scale :: BpPerPixel }

posPixelsX :: XPosInfo
           -> Bp
           -> Pixels
posPixelsX { scale } pos = bpToPixels scale pos

-- given a position relative to the track where 0.0 = bottom, 1.0 = top,
-- information about where the track will be drawn and how,
-- return the canvas Y-coordinate
type YPosInfo = { offset :: Pixels, height :: Pixels }

posPixelsY :: YPosInfo
           -> Number
           -> Pixels
posPixelsY { offset, height } rel = height - (rel * height + offset)

type Renderer eff a =
  { hPos :: a -> XPosInfo -> Pixels
  , vPos :: a -> YPosInfo -> Pixels
  , render :: a -> Context2D -> Eff eff Unit
  , hit :: Maybe (a -> { x :: Pixels, y :: Pixels } -> a)
  }

gwasRenderer :: {min :: Number, max :: Number}
             -> Renderer _ {score :: Number, pos :: Bp}
gwasRenderer {min, max} = { hPos, vPos, render, hit: Nothing }
  where hPos a xInfo = posPixelsX xInfo a.pos
        nScore s = (s - min) / (max - min)
        vPos a yInfo = posPixelsY yInfo (nScore a.score)
        render _ ctx = renderGlyph ctx $ circle { x: 0.0, y: 0.0 } 5.0

-- profunctors/arrows could come in here
-- or polymorphic records, maybe? would have to be (Tuple r1 a) -> (Tuple r2 a) tho
strokeRenderer :: forall a.
                  Renderer _ a
               -> Renderer _ (Tuple String a)
strokeRenderer r = {hPos, vPos, render, hit}
  where hPos (Tuple _ a) = r.hPos a
        vPos (Tuple _ a) = r.vPos a
        hit = Nothing -- TODO fix this
        render (Tuple col a) ctx = C.withContext ctx do
          _ <- C.setStrokeStyle col ctx
          r.render a ctx

fillRenderer :: forall a.
                Renderer _ a
             -> Renderer _ (Tuple String a)
fillRenderer r = {hPos, vPos, render, hit}
  where hPos (Tuple _ a) = r.hPos a
        vPos (Tuple _ a) = r.vPos a
        hit = Nothing -- TODO fix this
        render (Tuple col a) ctx = C.withContext ctx do
          _ <- C.setFillStyle col ctx
          r.render a ctx

runRenderer :: forall a.
               a
            -> Renderer _ a
            -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
            -> Context2D
            -> Eff _ Unit
runRenderer a { hPos, vPos, render, hit } { xInfo, yInfo } ctx = C.withContext ctx do
  let translateX = hPos a xInfo
      translateY = vPos a yInfo
  _ <- C.translate {translateX, translateY} ctx
  render a ctx

runRendererN :: forall a.
                Renderer _ a
             -> { xInfo :: XPosInfo, yInfo :: YPosInfo }
             -> Array a
             -> Context2D
             -> Eff _ Unit
runRendererN r p as ctx =
  for_ as (\a -> runRenderer a r p ctx)

-- TODO the `offset` should probably be in XPosInfo,
-- and be the actual pixel offset for that bit on the canvas...
type Frames a = { offset :: Pixels, frames :: Array (Tuple XPosInfo a) }

frames :: forall a.
          Pixels
       -> Pixels
       -> (a -> Bp)
       -> Array a
       -> Frames a
frames width offset f chrs = {offset, frames: g <$> chrs}
  where n = length chrs
        -- TODO the scale should depend on the current size; that needs more work
        totalSize = alaF Additive foldMap f chrs
        width' = width - offset * n
        g chr = let size = f chr
                in Tuple { size, scale: BpPerPixel (unwrap totalSize / width') } chr

mapFrames :: forall a b.
             (a -> b)
          -> Frames a
          -> Frames b
mapFrames f fs = fs { frames = map f <$> fs.frames }

zipWithFrames :: forall a b.
             Array (a -> b)
          -> Frames a
          -> Frames b
zipWithFrames funs fs = fs { frames = frames }
  where frames = Array.zipWith (\fun frame -> fun <$> frame) funs fs.frames

renderFrames :: forall a.
                YPosInfo
             -> Frames a
             -> Renderer _ a
             -> Context2D
             -> Eff _ Unit
renderFrames yInfo {offset, frames} r ctx = C.withContext ctx (foreachE frames f)
  where f (Tuple {scale, size} a) = do
            void $ C.translate {translateX: offset, translateY: 0.0} ctx
            r.render a ctx
            let len = bpToPixels scale size
            void $ C.translate {translateX: len, translateY: 0.0} ctx

renderFramesN :: forall a.
                 YPosInfo
              -> Frames (Array a)
              -> Renderer _ a
              -> Context2D
              -> Eff _ Unit
renderFramesN yInfo {offset, frames} r ctx = C.withContext ctx (foreachE frames f)
  where f (Tuple xInfo@{scale, size} as) = do
            runRendererN r {xInfo, yInfo} as ctx
            log $ "scale: " <> show (unwrap scale)
            let len = bpToPixels scale size
            void $ C.translate {translateX: len+offset, translateY: 0.0} ctx

{- note:
  check purescript-drawings out.

wait, aren't these basically the same

(         a -> (Translation, Eff _ Unit))
(Identity a -> (Translation, Eff _ Unit))

(       f a ->  g           (Eff _ Unit))
(       f a ->  Identity    (Eff _ Unit))
-}

-- Commands the renderer thread can receive
data RenderCmds a =
    Render (Array { chrId :: ChrId, features :: Array a})
  | SetView View
  | Scroll Pixels

type RenderBackend = { canvas :: CanvasElement
                     , backCanvas :: CanvasElement
                     }
{-
renderer :: forall eff a.
            RenderBackend
         -> Renderer eff a
         -> AVar (RenderCmds a)
         -> StateT View (Aff _) Unit
renderer cvs r cmdVar = forever do
  cmd <- lift $ takeVar cmdVar
  case cmd of
    Render fs -> do
      -- let toRender :: Array (RenderParams -> Eff _ Unit)
      --     toRender = map r fs
      -- Use current (or provided?) View to derive RenderParams for each
      pure unit

    Scroll n -> do
      pure unit

    SetView v -> do
      State.put v
      pure unit
-}

testFetch :: String
          -> Aff _ (Array { score :: Number, pos :: Bp })
testFetch url = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe {score :: Number, pos :: Bp}
      f j = do
            obj <- j ^? _Object
            pos <- Bp <$> obj ^? ix "min" <<< _Number
            pValue <- readFloat <$> obj ^? ix "pValue" <<< _String
            let score = (-1.0) * (Math.log pValue / Math.log 10.0)
            pure {pos, score}

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

testRender :: forall a.
              Renderer _ a
           -> Array a
           -> Aff _ Unit
testRender r as = do
  liftEff $ log "running"
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let size = Bp 122030190.0
      n = 10
      scale = BpPerPixel (unwrap size / (w / 10.0))
      xInfo = { size, scale }
      height = h
      offset = 0.0
      yInfo = { height, offset }
      colors = Tuple <$> ["yellow", "orange", "red", "purple", "blue"]

      fs :: Frames (Array _)
      fs = frames w 20.0 (const size) (Array.replicate 5 as)

      fs' :: Frames (Tuple String (Array _))
      fs' = zipWithFrames colors fs

      r' :: Renderer _ (Tuple String a)
      r' = strokeRenderer r

  liftEff $ renderFramesN yInfo fs r ctx

main = launchAff $ do
  dat <- testFetch "./gwas.json"
  let min = 0.0
      max = 50.0
  testRender (gwasRenderer {min, max}) dat

{-
trackEvents :: _
trackEvents = viewB
  where cDrag = canvasDrag canvas
        lefts = case _ of
          Left x -> Just x
          Right _ -> Nothing
        -- the alt operator <|> combines the two event streams,
        -- resulting in an event of both button-click scrolls
        -- and canvas-drag scrolls

        dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
        updateViews = btnScroll (Bp 500.0)
                  <|> dragScroll
                  <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                              (wrap <<< (_ * 1.2) <<< unwrap)
                  <|> scrollZoom canvas
        viewB = FRP.fold foldView updateViews v
-}

-- a `Track` is the more or less abstract representation of the track;
-- it needs to be run to do anything.

-- TODO it also needs to be able to receive messages and send messages

-- runTrack :: forall a r.
--             View
--          -> Track _ _ a
--          -> Aff _ Unit
-- runTrack opts { source, render, getPoint, chrSize } = do
  -- ctx <- liftEff $ getContext2D opts.canvas

  -- {w,h} <- liftEff do
  --   {w} <- getScreenSize
  --   h <- getCanvasHeight opts.canvas
  --   _ <- setCanvasWidth (w-2.0) opts.canvas
  --   pure {w, h}

  -- trackState <- makeVar

  -- -- TODO handle resize
  -- let v = View.fromCanvasWidth chrSize opts

  -- feats <- fetch
  -- pure unit

{-

browser :: Aff _ Unit
browser uri = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}
  browserState <- makeVar

  let minView = Bp 0.0
      maxView = Bp 15000000.0
      v = View.fromCanvasWidth w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch uri

  fs <- f v

  let renderer :: View -> Array _ -> _
      renderer = renderGlyphs (browserTransform h) ctx
      fetch :: View -> Aff _ _
      fetch v = do

        let gs = glyphifyFeatures fs v
            annGs = zip fs gs
        let gs' = filterFeatures v annGs

        putVar browserState { annotatedGlyphs: annGs
                            , view: v }
        liftEff do
          clearCanvas canvas
          renderer v gs'

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls

      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = FRP.fold foldView updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    _ <- launchAff $ fetch v'

  fetch v
  -}