add perturb instance for boolean

add perturb instance for boolean

module Test.StrongCheck.Perturb
  ( Attempts(..)
  , Perturb
  , Perturber(..)
  , perturb
  , perterber2
  , perterber3
  , perterber4
  , perterber5
  , perterber6
  , perterber7
  , perterber8
  , perterber9
  , perterber10
  , dist
  , dims
  , searchIn'
  , searchIn
  ) where

  import Test.StrongCheck.Gen
  import Test.StrongCheck

  import Data.Traversable
  import Data.Foldable
  import Data.Char
  import Data.Tuple
  import Data.Monoid
  import Data.Either
  import Data.Maybe
  import Data.Maybe.Unsafe
  import Data.Monoid.Sum
  import Data.Enum
  import qualified Data.String as S
  import qualified Data.Array as A

  import Math

  import Data.Function

  newtype Attempts = Attempts Number

  newtype Perturber a = Perturber {
    perturb :: Number -> a -> Gen a,
    dist    :: a -> a -> Number,
    dims    :: a -> Number }

  -- | The class for things which can be perturbed.
  -- |
  -- | Laws:
  -- |   forall a, 0 >= n <= 1:
  -- |   ((>=) n) <<< dist a <$> (perturb n a) must be an infinite generator of `true` values.
  class Perturb a where
    perturb :: Number -> a -> Gen a

    dist :: a -> a -> Number

    dims :: a -> Number

  -- | Given one example, searches for other examples that satisfy a provided
  -- | boolean predicate.
  -- |
  -- | The search operates out-to-in, in an attempt to find examples that are
  -- | as far removed from the provided example as possible. The sampling size
  -- | parameter determines how many samples to take at every level of
  -- | searching, while the attempts parameter determines how many levels.
  searchIn' :: forall a. (Perturb a) => Attempts -> Number -> (a -> Boolean) -> a -> Gen a
  searchIn' (Attempts k) n f a = search0 k 1
    where search0 k d = ifThenElse (k <= 0) mempty
                        (do a' <- find f <$> (takeGen 1 $ chunked n (perturb d a))
                            fromMaybe mempty (pure <$> a') <> search0 (k - 1) (d / 2))

  -- | The same as search', but uses defaults for attempt count and sample size.
  -- | Will search a total of 10,000 examples before giving up.
  searchIn :: forall a. (Perturb a) => (a -> Boolean) -> a -> Gen a
  searchIn = searchIn' (Attempts 1000) 10

  perterber2 :: forall a b. (Perturb a, Perturb b) => Perturber (Tuple a b)
  perterber2 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a b) = let dx = delta 2 d in Tuple <$> perturb dx a <*> perturb dx b
          dist' (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]
          dims' (Tuple a b) = (dims a) * (dims b)

  perterber3 :: forall a b c. (Perturb a, Perturb b, Perturb c) => Perturber (Tuple a (Tuple b c))
  perterber3 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a (Tuple b c)) =
            let dx = delta 3 d
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> perturb dx c)

          dist' (Tuple a1 (Tuple b1 c1)) (Tuple a2 (Tuple b2 c2)) = toDist [dist a1 a2, dist b1 b2, dist c1 c2]

          dims' (Tuple a (Tuple b c)) = (dims a) * (dims b) * (dims c)

  perterber4 :: forall a b c d. (Perturb a, Perturb b, Perturb c, Perturb d) => Perturber (Tuple a (Tuple b (Tuple c d)))
  perterber4 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c d))) =
            let dx = delta 4 d0
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> (Tuple <$> perturb dx c <*> perturb dx d))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 d1)))
                (Tuple a2 (Tuple b2 (Tuple c2 d2))) = toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2]

          dims' (Tuple a (Tuple b (Tuple c d))) = (dims a) * (dims b) * (dims c) * (dims d)

  perterber5 :: forall a b c d e. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d e))))
  perterber5 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            let dx = delta 5 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*> perturb dx e)))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 e1))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 e2)))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e)

  perterber6 :: forall a b c d e f. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f)))))
  perterber6 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            let dx = delta 6 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*> perturb dx f))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 f1)))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 f2))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f)

  perterber7 :: forall a b c d e f g. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g))))))
  perterber7 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            let dx = delta 7 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*> perturb dx g)))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 g1))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 g2)))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g)

  perterber8 :: forall a b c d e f g h. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h)))))))
  perterber8 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            let dx = delta 8 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*> perturb dx h))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 h1)))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 h2))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2, dist h1 h2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h)

  perterber9 :: forall a b c d e f g h i. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i))))))))
  perterber9 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            let dx = delta 9 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*> perturb dx i)))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 i1))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 i2)))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i)

  perterber10 :: forall a b c d e f g h i j. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i, Perturb j) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j)))))))))
  perterber10 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            let dx = delta 10 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*>
                (Tuple <$> perturb dx i <*> perturb dx j))))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 (Tuple i1 j1)))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 (Tuple i2 j2))))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2, dist j1 j2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i) * (dims j)

  instance perturbArbEnum :: (Enum a) => Perturb (ArbEnum a) where
    perturb n e = cardPerturb1 (cardPerturb1F e n)

    dist a b = cardDist1 f a b where
      f (Cardinality sz) a b = if runArbEnum a == runArbEnum b then 0 else 1 / (2 * sz)

    dims e = enumDims f e where
      f (Cardinality sz) e = if sz <= 0 then 0 else 1

  instance perturbNumber :: Perturb Number where
    perturb 0 n = pure n
    perturb d n = do
      u <- uniform -- 'up to' d
      s <- runSignum <$> arbitrary
      return $ s * (Math.exp(k0 * (u * d)) - 1) + n

    dist a b =
      let from y = Math.log(y + 1) / k0
      in  (Math.min 1) <<< Math.abs <<< from $ Math.abs (a - b)

    dims = const 1

  instance perturbArray :: (Perturb a) => Perturb [a] where
    perturb d []  = pure $ []
    perturb 0 a   = sequence $ perturb 0 <$> a
    perturb d a   = let dx = delta (A.length a) d
                    in  sequence $ perturb dx <$> a

    dist a b = toDist $ A.zipWith dist a b

    dims = A.length

  instance perturbTuple :: (Perturb a, Perturb b) => Perturb (Tuple a b) where
    perturb d (Tuple a b) = let dx = delta 2 d
                            in  Tuple <$> (perturb dx a) <*> (perturb dx b)

    dist (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]

    dims (Tuple a b) = dims a + dims b

  instance perturbChar :: Perturb Char where
    perturb n e = if n < 1 / (2 * 65536) then pure e else arbitrary

    dist a b = if a == b then 0 else 1 / (2 * 65536)

    dims = const 1

  instance perturbBoolean :: Perturb Boolean where
    perturb n e = runArbEnum <$> perturb n (ArbEnum e)

    dist a b = dist (ArbEnum a) (ArbEnum b)

    dims = const 1

  instance perturbString :: Perturb String where
    perturb d s = S.fromCharArray <$> perturb d (S.toCharArray s)

    dist s1 s2 = dist (S.toCharArray s1) (S.toCharArray s2)

    dims = dims <<< S.toCharArray

  -- magical constants
  maxNumber :: Number
  maxNumber = 9007199254740992

  -- math
  k0 :: Number
  k0 = Math.log(maxNumber + 1)

  square :: Number -> Number
  square = flip Math.pow 2

  toDist :: [Number] -> Number
  toDist xs = Math.sqrt (sum $ square <$> xs)

  delta :: Number -> Number -> Number
  delta n d = Math.sqrt (d * d / n)

  -- FIXME: this workaround is still required as of psc 0.5.6.3
  ifThenElse p a b = if p then a else b

  -- ScopedTypeVariables
  enumDims :: forall a. (Enum a) => (Cardinality a -> a -> Number) -> a -> Number
  enumDims f = f cardinality

  -- ScopedTypeVariables
  cardPerturb1 :: forall f a. (Enum a) => (Cardinality a -> f a) -> f a
  cardPerturb1 f = f cardinality

  -- ScopedTypeVariables
  cardDist1 :: forall a. (Enum a) => (Cardinality a -> a -> a -> Number) -> a -> a -> Number
  cardDist1 f = f cardinality

  -- workaround to avoid:
  -- Attempted to unify a constrained type (Test.StrongCheck.Arbitrary u15286) =>
  -- Test.StrongCheck.Gen.Gen<u15286> with another type.
  cardPerturb1F :: forall a. (Enum a) => a -> Number -> Cardinality a -> Gen a
  cardPerturb1F a n (Cardinality sz) = if n < 1 / (2 * sz) then pure a else (runArbEnum <$> arbitrary)

module Test.StrongCheck.Perturb
  ( Attempts(..)
  , Perturb
  , Perturber(..)
  , perturb
  , perterber2
  , perterber3
  , perterber4
  , perterber5
  , perterber6
  , perterber7
  , perterber8
  , perterber9
  , perterber10
  , dist
  , dims
  , searchIn'
  , searchIn
  ) where

  import Test.StrongCheck.Gen
  import Test.StrongCheck

  import Data.Traversable
  import Data.Foldable
  import Data.Char
  import Data.Tuple
  import Data.Monoid
  import Data.Either
  import Data.Maybe
  import Data.Maybe.Unsafe
  import Data.Monoid.Sum
  import Data.Enum
  import qualified Data.String as S
  import qualified Data.Array as A

  import Math

  import Data.Function

  newtype Attempts = Attempts Number

  newtype Perturber a = Perturber {
    perturb :: Number -> a -> Gen a,
    dist    :: a -> a -> Number,
    dims    :: a -> Number }

  -- | The class for things which can be perturbed.
  -- |
  -- | Laws:
  -- |   forall a, 0 >= n <= 1:
  -- |   ((>=) n) <<< dist a <$> (perturb n a) must be an infinite generator of `true` values.
  class Perturb a where
    perturb :: Number -> a -> Gen a

    dist :: a -> a -> Number

    dims :: a -> Number

  -- | Given one example, searches for other examples that satisfy a provided
  -- | boolean predicate.
  -- |
  -- | The search operates out-to-in, in an attempt to find examples that are
  -- | as far removed from the provided example as possible. The sampling size
  -- | parameter determines how many samples to take at every level of
  -- | searching, while the attempts parameter determines how many levels.
  searchIn' :: forall a. (Perturb a) => Attempts -> Number -> (a -> Boolean) -> a -> Gen a
  searchIn' (Attempts k) n f a = search0 k 1
    where search0 k d = ifThenElse (k <= 0) mempty
                        (do a' <- find f <$> (takeGen 1 $ chunked n (perturb d a))
                            fromMaybe mempty (pure <$> a') <> search0 (k - 1) (d / 2))

  -- | The same as search', but uses defaults for attempt count and sample size.
  -- | Will search a total of 10,000 examples before giving up.
  searchIn :: forall a. (Perturb a) => (a -> Boolean) -> a -> Gen a
  searchIn = searchIn' (Attempts 1000) 10

  perterber2 :: forall a b. (Perturb a, Perturb b) => Perturber (Tuple a b)
  perterber2 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a b) = let dx = delta 2 d in Tuple <$> perturb dx a <*> perturb dx b
          dist' (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]
          dims' (Tuple a b) = (dims a) * (dims b)

  perterber3 :: forall a b c. (Perturb a, Perturb b, Perturb c) => Perturber (Tuple a (Tuple b c))
  perterber3 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d (Tuple a (Tuple b c)) =
            let dx = delta 3 d
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> perturb dx c)

          dist' (Tuple a1 (Tuple b1 c1)) (Tuple a2 (Tuple b2 c2)) = toDist [dist a1 a2, dist b1 b2, dist c1 c2]

          dims' (Tuple a (Tuple b c)) = (dims a) * (dims b) * (dims c)

  perterber4 :: forall a b c d. (Perturb a, Perturb b, Perturb c, Perturb d) => Perturber (Tuple a (Tuple b (Tuple c d)))
  perterber4 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c d))) =
            let dx = delta 4 d0
            in  Tuple <$> perturb dx a <*> (Tuple <$> perturb dx b <*> (Tuple <$> perturb dx c <*> perturb dx d))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 d1)))
                (Tuple a2 (Tuple b2 (Tuple c2 d2))) = toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2]

          dims' (Tuple a (Tuple b (Tuple c d))) = (dims a) * (dims b) * (dims c) * (dims d)

  perterber5 :: forall a b c d e. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d e))))
  perterber5 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            let dx = delta 5 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*> perturb dx e)))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 e1))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 e2)))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d e)))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e)

  perterber6 :: forall a b c d e f. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f)))))
  perterber6 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            let dx = delta 6 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*> perturb dx f))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 f1)))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 f2))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e f))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f)

  perterber7 :: forall a b c d e f g. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g))))))
  perterber7 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            let dx = delta 7 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*> perturb dx g)))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 g1))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 g2)))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f g)))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g)

  perterber8 :: forall a b c d e f g h. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h)))))))
  perterber8 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            let dx = delta 8 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*> perturb dx h))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 h1)))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 h2))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2, dist f1 f2, dist g1 g2, dist h1 h2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g h))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h)

  perterber9 :: forall a b c d e f g h i. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i))))))))
  perterber9 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            let dx = delta 9 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*> perturb dx i)))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 i1))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 i2)))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h i)))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i)

  perterber10 :: forall a b c d e f g h i j. (Perturb a, Perturb b, Perturb c, Perturb d, Perturb e, Perturb f, Perturb g, Perturb h, Perturb i, Perturb j) => Perturber (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j)))))))))
  perterber10 = Perturber { perturb : perturb', dist : dist', dims : dims' }
    where perturb' d0 (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            let dx = delta 10 d0
            in  Tuple <$> perturb dx a <*>
                (Tuple <$> perturb dx b <*>
                (Tuple <$> perturb dx c <*>
                (Tuple <$> perturb dx d <*>
                (Tuple <$> perturb dx e <*>
                (Tuple <$> perturb dx f <*>
                (Tuple <$> perturb dx g <*>
                (Tuple <$> perturb dx h <*>
                (Tuple <$> perturb dx i <*> perturb dx j))))))))

          dist' (Tuple a1 (Tuple b1 (Tuple c1 (Tuple d1 (Tuple e1 (Tuple f1 (Tuple g1 (Tuple h1 (Tuple i1 j1)))))))))
                (Tuple a2 (Tuple b2 (Tuple c2 (Tuple d2 (Tuple e2 (Tuple f2 (Tuple g2 (Tuple h2 (Tuple i2 j2))))))))) =
            toDist [dist a1 a2, dist b1 b2, dist c1 c2, dist d1 d2, dist e1 e2,
                    dist f1 f2, dist g1 g2, dist h1 h2, dist i1 i2, dist j1 j2]

          dims' (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e (Tuple f (Tuple g (Tuple h (Tuple i j))))))))) =
            (dims a) * (dims b) * (dims c) * (dims d) * (dims e) * (dims f) * (dims g) * (dims h) * (dims i) * (dims j)

  instance perturbArbEnum :: (Enum a) => Perturb (ArbEnum a) where
    perturb n e = cardPerturb1 (cardPerturb1F e n)

    dist a b = cardDist1 f a b where
      f (Cardinality sz) a b = if runArbEnum a == runArbEnum b then 0 else 1 / (2 * sz)

    dims e = enumDims f e where
      f (Cardinality sz) e = if sz <= 0 then 0 else 1

  instance perturbNumber :: Perturb Number where
    perturb 0 n = pure n
    perturb d n = do
      u <- uniform -- 'up to' d
      s <- runSignum <$> arbitrary
      return $ s * (Math.exp(k0 * (u * d)) - 1) + n

    dist a b =
      let from y = Math.log(y + 1) / k0
      in  (Math.min 1) <<< Math.abs <<< from $ Math.abs (a - b)

    dims = const 1

  instance perturbArray :: (Perturb a) => Perturb [a] where
    perturb d []  = pure $ []
    perturb 0 a   = sequence $ perturb 0 <$> a
    perturb d a   = let dx = delta (A.length a) d
                    in  sequence $ perturb dx <$> a

    dist a b = toDist $ A.zipWith dist a b

    dims = A.length

  instance perturbTuple :: (Perturb a, Perturb b) => Perturb (Tuple a b) where
    perturb d (Tuple a b) = let dx = delta 2 d
                            in  Tuple <$> (perturb dx a) <*> (perturb dx b)

    dist (Tuple a1 b1) (Tuple a2 b2) = toDist [dist a1 a2, dist b1 b2]

    dims (Tuple a b) = dims a + dims b

  instance perturbChar :: Perturb Char where
    perturb n e = if n < 1 / (2 * 65536) then pure e else arbitrary

    dist a b = if a == b then 0 else 1 / (2 * 65536)

    dims = const 1

  instance perturbString :: Perturb String where
    perturb d s = S.fromCharArray <$> perturb d (S.toCharArray s)

    dist s1 s2 = dist (S.toCharArray s1) (S.toCharArray s2)

    dims = dims <<< S.toCharArray

  -- magical constants
  maxNumber :: Number
  maxNumber = 9007199254740992

  -- math
  k0 :: Number
  k0 = Math.log(maxNumber + 1)

  square :: Number -> Number
  square = flip Math.pow 2

  toDist :: [Number] -> Number
  toDist xs = Math.sqrt (sum $ square <$> xs)

  delta :: Number -> Number -> Number
  delta n d = Math.sqrt (d * d / n)

  -- FIXME: this workaround is still required as of psc 0.5.6.3
  ifThenElse p a b = if p then a else b

  -- ScopedTypeVariables
  enumDims :: forall a. (Enum a) => (Cardinality a -> a -> Number) -> a -> Number
  enumDims f = f cardinality

  -- ScopedTypeVariables
  cardPerturb1 :: forall f a. (Enum a) => (Cardinality a -> f a) -> f a
  cardPerturb1 f = f cardinality

  -- ScopedTypeVariables
  cardDist1 :: forall a. (Enum a) => (Cardinality a -> a -> a -> Number) -> a -> a -> Number
  cardDist1 f = f cardinality

  -- workaround to avoid:
  -- Attempted to unify a constrained type (Test.StrongCheck.Arbitrary u15286) =>
  -- Test.StrongCheck.Gen.Gen<u15286> with another type.
  cardPerturb1F :: forall a. (Enum a) => a -> Number -> Cardinality a -> Gen a
  cardPerturb1F a n (Cardinality sz) = if n < 1 / (2 * sz) then pure a else (runArbEnum <$> arbitrary)


fix writer bug

fix writer bug

module TMDBMetadataLoader where

import Data.String
import Data.Function
import Data.Either
import Prelude
import Control.Bind
import Control.Monad.Eff
import Control.Monad.Trans
import Control.Monad.Cont.Trans
import Data.Foreign
import Data.Foreign.Class
import Data.Traversable
import Data.Foldable
import HttpClient
import Config
import Data.Array.Unsafe
import qualified Data.Array as Array
import qualified Data.Map as Map
import Data.Tuple
import Data.Maybe.Unsafe
import TMDBTypes

getState :: Url -> Http State
getState url = do myList <- getMyList url
                  genres <- fetchGenreList
                  mvs <- fetchMoviesDetails (myList.movies)
                  tvs <- fetchTVShowsDetails (myList.tvshows)
                  return ({ movies: (\m -> m { genre = joinWith ", " ((\k -> fromJust(Map.lookup k genres)) <$> m.genresIds) }) <$> mvs,
                            tvshows: tvs })

getMyList ::  String -> Http MyList
getMyList url = fetch url

fetchGenreList :: Http (Map.Map Number String)
fetchGenreList = do x <- (fetch ("http://api.themoviedb.org/3/genre/movie/list?api_key=" ++ apiKey) :: Http TMBMovieGenres)
                    return (Map.fromList ((\y -> Tuple (y.id) (y.name)) <$> x.genres))

fetchMoviesDetails :: [MovieSpec] -> Http [MovieDetails]
fetchMoviesDetails moviesSpecs = sequence (fetchMovie <$> moviesSpecs)

fetchTVShowsDetails :: [TVShowSpec] -> Http [TVShowDetails]
fetchTVShowsDetails tvShowsSpecs = sequence (f <$> tvShowsSpecs)
	where f x = do dt <- fetchTVShow x
	               sdt <- fetchTVShowsSeasonsDetails (x { seriesId = dt.seriesId })
 	               return (dt { seasons = sdt })

fetchTVShowsSeasonsDetails :: TVShowSpec -> Http [TVShowSeasonDetails]
fetchTVShowsSeasonsDetails tvshow = sequence (f <$> (tvshow.seasons))
    where f x = (\eps -> { season : x.season, episodes : eps }) <$>
                fetchTVShowEpisodesDetails ((\v -> v { seriesId = tvshow.seriesId }) <$> x.episodes)

fetchTVShowEpisodesDetails :: [TVShowEpisodeSpec] -> Http [TVShowEpisodeDetails]
fetchTVShowEpisodesDetails episodesSpecs = sequence (fetchTVShowEpisode <$> episodesSpecs)

fetchMovieExtraInfo :: Number -> Http MovieCredits
fetchMovieExtraInfo movieId = (\details -> {
		    movieId : details.id,
        director: joinWith "," ((\x -> x.name) <$> (Array.filter (\x-> x.job == "Director") details.credits.crew)),
        writer: joinWith "," ((\x -> x.name) <$> (Array.filter (\x-> x.job == "Writer" || x.job == "Screenplay") details.credits.crew)),
        actors: joinWith "," (Array.take 5 ((\x -> x.name) <$> details.credits.cast)),
        rated: (head (details.releases.countries)).certification,
        runtime: details.runtime
       }) <$> response
  where url = "http://api.themoviedb.org/3/movie/" ++ (show movieId) ++ "?api_key=" ++ apiKey ++ "&append_to_response=credits,releases"
        response = (fetch url) :: Http TMDBMovieCredits

fetchMovie :: MovieSpec -> Http MovieDetails
fetchMovie movie = do dt <- fetchMovie' movie
                      info <- fetchMovieExtraInfo (dt.movieId)
                      return dt { director = info.director,
                                  writer = info.writer,
                                  actors = info.actors,
                                  runtime = info.runtime,
                                  rated = info.rated }

fetchMovie' :: MovieSpec ->  Http MovieDetails
fetchMovie' movie = (\details -> {
		movieId : details.id,
        title : details.title,
        plot: details.overview,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.poster_path,
        year : movie.year,
        release: details.release_date,
        genresIds: details.genre_ids,
        genre:"",
		    source : movie.source,
		    director: "",
        writer:"",
        actors:"",
        runtime:0,
        popularity: details.popularity,
        rated:"" }) <$> ((\x -> head (x.results)) <$> response)
  where url = "http://api.themoviedb.org/3/search/movie?api_key=" ++ apiKey ++ query ++ year
        query = "&query=" ++ replaceSpaceWithPlus (movie.title)
        year = "&year=" ++ movie.year
        response = (fetch url) :: Http TMDBMovieDetails

fetchTVShow :: TVShowSpec ->  Http TVShowDetails
fetchTVShow tvshow = (\details -> {
		seriesId: details.id,
        title : details.name,
        year : details.first_air_date,
        plot: details.overview,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.poster_path,
		    seasons: [] }) <$> ((\x -> head (x.results)) <$> response)
  where url = "http://api.themoviedb.org/3/search/tv?api_key=" ++ apiKey ++ query ++ year
        query = "&query=" ++ replaceSpaceWithPlus (tvshow.title)
        year = "&year=" ++ tvshow.year
        response = (fetch url) :: Http TMDBTVShowDetails

fetchTVShowEpisode :: TVShowEpisodeSpec -> Http TVShowEpisodeDetails
fetchTVShowEpisode episode = (\details -> {
        title : details.name,
        season: show details.season_number,
        episode: show details.episode_number,
        plot: details.overview,
        released: details.air_date,
		    source : episode.source,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.still_path }) <$> response
  where url = "http://api.themoviedb.org/3/tv/" ++ (show episode.seriesId) ++
                "/season/" ++ episode.season ++
                "/episode/" ++ episode.episode ++
                "?api_key=" ++ apiKey
        response = (fetch url) :: Http TMDBTVShowEpisodeDetails

replaceSpaceWithPlus :: String -> String
replaceSpaceWithPlus =  (joinWith "+") <<< (split " ")

module TMDBMetadataLoader where

import Data.String
import Data.Function
import Data.Either
import Prelude
import Control.Bind
import Control.Monad.Eff
import Control.Monad.Trans
import Control.Monad.Cont.Trans
import Data.Foreign
import Data.Foreign.Class
import Data.Traversable
import Data.Foldable
import HttpClient
import Config
import Data.Array.Unsafe
import qualified Data.Array as Array
import qualified Data.Map as Map
import Data.Tuple
import Data.Maybe.Unsafe
import TMDBTypes

getState :: Url -> Http State
getState url = do myList <- getMyList url
                  genres <- fetchGenreList
                  mvs <- fetchMoviesDetails (myList.movies)
                  tvs <- fetchTVShowsDetails (myList.tvshows)
                  return ({ movies: (\m -> m { genre = joinWith ", " ((\k -> fromJust(Map.lookup k genres)) <$> m.genresIds) }) <$> mvs,
                            tvshows: tvs })

getMyList ::  String -> Http MyList
getMyList url = fetch url

fetchGenreList :: Http (Map.Map Number String)
fetchGenreList = do x <- (fetch ("http://api.themoviedb.org/3/genre/movie/list?api_key=" ++ apiKey) :: Http TMBMovieGenres)
                    return (Map.fromList ((\y -> Tuple (y.id) (y.name)) <$> x.genres))

fetchMoviesDetails :: [MovieSpec] -> Http [MovieDetails]
fetchMoviesDetails moviesSpecs = sequence (fetchMovie <$> moviesSpecs)

fetchTVShowsDetails :: [TVShowSpec] -> Http [TVShowDetails]
fetchTVShowsDetails tvShowsSpecs = sequence (f <$> tvShowsSpecs)
	where f x = do dt <- fetchTVShow x
	               sdt <- fetchTVShowsSeasonsDetails (x { seriesId = dt.seriesId })
 	               return (dt { seasons = sdt })

fetchTVShowsSeasonsDetails :: TVShowSpec -> Http [TVShowSeasonDetails]
fetchTVShowsSeasonsDetails tvshow = sequence (f <$> (tvshow.seasons))
    where f x = (\eps -> { season : x.season, episodes : eps }) <$>
                fetchTVShowEpisodesDetails ((\v -> v { seriesId = tvshow.seriesId }) <$> x.episodes)

fetchTVShowEpisodesDetails :: [TVShowEpisodeSpec] -> Http [TVShowEpisodeDetails]
fetchTVShowEpisodesDetails episodesSpecs = sequence (fetchTVShowEpisode <$> episodesSpecs)

fetchMovieExtraInfo :: Number -> Http MovieCredits
fetchMovieExtraInfo movieId = (\details -> {
		    movieId : details.id,
        director: joinWith "," ((\x -> x.name) <$> (Array.filter (\x-> x.job == "Director") details.credits.crew)),
        writer: joinWith "," ((\x -> x.name) <$> (Array.filter (\x-> x.job == "Writer" || x.job == "Writing") details.credits.crew)),
        actors: joinWith "," (Array.take 5 ((\x -> x.name) <$> details.credits.cast)),
        rated: (head (details.releases.countries)).certification,
        runtime: details.runtime
       }) <$> response
  where url = "http://api.themoviedb.org/3/movie/" ++ (show movieId) ++ "?api_key=" ++ apiKey ++ "&append_to_response=credits,releases"
        response = (fetch url) :: Http TMDBMovieCredits

fetchMovie :: MovieSpec -> Http MovieDetails
fetchMovie movie = do dt <- fetchMovie' movie
                      info <- fetchMovieExtraInfo (dt.movieId)
                      return dt { director = info.director,
                                  writer = info.writer,
                                  actors = info.actors,
                                  runtime = info.runtime,
                                  rated = info.rated }

fetchMovie' :: MovieSpec ->  Http MovieDetails
fetchMovie' movie = (\details -> {
		movieId : details.id,
        title : details.title,
        plot: details.overview,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.poster_path,
        year : movie.year,
        release: details.release_date,
        genresIds: details.genre_ids,
        genre:"",
		    source : movie.source,
		    director: "",
        writer:"",
        actors:"",
        runtime:0,
        popularity: details.popularity,
        rated:"" }) <$> ((\x -> head (x.results)) <$> response)
  where url = "http://api.themoviedb.org/3/search/movie?api_key=" ++ apiKey ++ query ++ year
        query = "&query=" ++ replaceSpaceWithPlus (movie.title)
        year = "&year=" ++ movie.year
        response = (fetch url) :: Http TMDBMovieDetails

fetchTVShow :: TVShowSpec ->  Http TVShowDetails
fetchTVShow tvshow = (\details -> {
		seriesId: details.id,
        title : details.name,
        year : details.first_air_date,
        plot: details.overview,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.poster_path,
		    seasons: [] }) <$> ((\x -> head (x.results)) <$> response)
  where url = "http://api.themoviedb.org/3/search/tv?api_key=" ++ apiKey ++ query ++ year
        query = "&query=" ++ replaceSpaceWithPlus (tvshow.title)
        year = "&year=" ++ tvshow.year
        response = (fetch url) :: Http TMDBTVShowDetails

fetchTVShowEpisode :: TVShowEpisodeSpec -> Http TVShowEpisodeDetails
fetchTVShowEpisode episode = (\details -> {
        title : details.name,
        season: show details.season_number,
        episode: show details.episode_number,
        plot: details.overview,
        released: details.air_date,
		    source : episode.source,
        poster: "http://image.tmdb.org/t/p/w500/" ++ details.still_path }) <$> response
  where url = "http://api.themoviedb.org/3/tv/" ++ (show episode.seriesId) ++
                "/season/" ++ episode.season ++
                "/episode/" ++ episode.episode ++
                "?api_key=" ++ apiKey
        response = (fetch url) :: Http TMDBTVShowEpisodeDetails

replaceSpaceWithPlus :: String -> String
replaceSpaceWithPlus =  (joinWith "+") <<< (split " ")


new swap for pux

new swap for pux

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, stack)
import Control.Monad.Eff.Random (RANDOM, randomInt)
import Control.Monad.Rec.Class (Step(..), tailRecM2)
import Control.Safely as Safe
import DOM (DOM)
import DOM.Event.Event (eventPhase, preventDefault)
import Data.Array (cons, deleteAt, filter, findIndex, index, length, mapWithIndex, modifyAt, unsafeIndex, updateAt, (!!))
import Data.Monoid (class Monoid, mempty)
import Data.Traversable (traverse_)
import Data.Maybe (Maybe(..), fromMaybe)
import Debug.Trace as DT
import Prelude hiding (div,id)
import Pux (EffModel, noEffects, start)
import Pux.DOM.Events (DOMEvent, onClick)
import Pux.DOM.HTML (HTML, memoize)
import Pux.Renderer.React (renderToDOM)
import Signal.Channel (CHANNEL)
import Text.Smolder.HTML (a, button, div, h1, span, table, tbody, td, tr)
import Text.Smolder.HTML.Attributes (className, href, selected, type', id)
import Text.Smolder.Markup (attribute, text, (!), (#!))

----------
-- Main Entry

-- | Start and render the app
main :: Eff (dom :: DOM, channel :: CHANNEL, exception :: EXCEPTION, random :: RANDOM, console :: CONSOLE) Unit
main = do
  app <- start
    { initialState: init
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input

----------
-- State

type State =
  { rows   :: Array Row
  , lastId :: Int }

type Row =
  { rid        :: Int
  , label      :: String
  , isSelected :: Boolean }

init :: State
init =
  { rows: [], lastId: 1 }

----------
-- Events

data Event
  = MergeRows MergeType (Array Row) Int
  | Create MergeType Int DOMEvent
  | UpdateEvery Int DOMEvent
  | Clear DOMEvent
  | Swap Int Int DOMEvent
  | Remove Int DOMEvent
  | Select Int DOMEvent

data MergeType
  = Replace
  | Append

----------
-- Updates

-- | Return a new state (and effects) from each event
foldp :: Event -> State -> EffModel State Event (dom :: DOM, random :: RANDOM, console :: CONSOLE)

-- Write the received N rows over the rows held by the state,
-- and update the last Id to the received index.
foldp (MergeRows Replace arr i) st =
  noEffects $ st { rows = arr, lastId = i }

-- Append the received N rows into the rows held by the state, and update
-- the last Id to the received index.
foldp (MergeRows Append arr i) st =
  noEffects $ st { rows = st.rows <> arr, lastId = i }

-- Clear all rows from the screen and reset the last id to 1
foldp (Clear ev) st =
  { state: st { rows = [], lastId = st.lastId }, effects: [ liftEff (preventDefault ev) *> pure Nothing] }

-- Create the specified number of rows and prevent the browser
-- from receiving the click event. Depending on the provided
-- merger type (append or replace), return the proper event.
foldp (Create merger i ev) st =
  { state: st
  , effects: [ liftEff $ do
                    preventDefault ev
                    rows <- createRandomNRows i st.lastId
                    pure $ Just $ MergeRows merger rows (st.lastId + i) ] }

-- Update every row at the specified interval by appending three
-- exclamation points.
foldp (UpdateEvery i ev) st =
  { state: st
  , effects: [ liftEff $ do
                    preventDefault ev
                    pure $ Just $ MergeRows Replace (mapWithIndex (updateRowLabel i) st.rows) st.lastId ] }

-- Swap two rows in the view array (standard set to index 4 and 9)
foldp (Swap i0 i1 ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  case swapRows st.rows i0 i1 of
                    Nothing  -> log "Failed to swap rows." *>
                                pure Nothing
                    Just arr -> pure $ Just $ MergeRows Replace arr st.lastId ] }

-- Toggle the selected status of the row at the given index
foldp (Select i ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  pure $ Just $ MergeRows Replace (fromMaybe st.rows $ updateRowSelected i st.rows) st.lastId ] }

-- Toggle the selected status of the row at the given index
foldp (Remove i ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  pure $ Just $ MergeRows Replace (deleteRow i st.rows) st.lastId ] }

-----
-- Update Helpers

-- | Create new batch of random rows
-- | Note: use `tailRecM` to ensure proper tail recursion in monadic code
createRandomNRows :: forall e. Int -> Int -> Eff ( random :: RANDOM | e) (Array Row)
createRandomNRows n lastId = tailRecM2 f [] n
  where
    f arr 0 = pure (Done arr)
    f arr n = do
      str <- selectConcatItems

      let str' = case str of
            Nothing -> ""
            Just s  -> s

      pure (Loop $ { a: (createAndAppendRow arr (n - 1) lastId str')
                   , b: (n - 1) })

-- | Create a single row
createAndAppendRow :: Array Row -> Int -> Int -> String -> Array Row
createAndAppendRow arr index lastId s =
  cons
  ({ rid: lastId + index
    , label: s
    , isSelected: false })
  arr

-- | Select a random element from each array of strings,
-- | and then concatenate them into a string value.
selectConcatItems :: forall e. Eff ( random :: RANDOM | e) (Maybe String)
selectConcatItems = do
  adj <- index adjectives <$> (randomInt 1 $ length adjectives - 1)
  clr <- index colours    <$> (randomInt 1 $ length colours - 1)
  non <- index nouns      <$> (randomInt 1 $ length nouns - 1)

  pure $ adj <> Just " " <> clr <> Just " " <> non

-- | For use in iterating through rows
updateRowLabel :: Int -> Int -> Row -> Row
updateRowLabel interval ix row =
  if ix `mod` interval == 0
  then row { label = row.label <> " !!!" }
  else row

-- | Update the status of a particular row.
--   Only one row is selected at any time
updateRowSelected :: Int -> Array Row -> Maybe (Array Row)
updateRowSelected pos arr = do
  let s' = findIndex (\x -> x.isSelected) arr
  case s' of
    Nothing -> do
      i <- findIndex (\x -> x.rid == pos) arr
      modifyAt i (\x -> x { isSelected = true }) arr
    Just s  -> do
      i <- findIndex (\x -> x.rid == pos) arr
      if s == i
         then pure arr
         else do
            deselect <- modifyAt s (\x -> x { isSelected = false }) arr
            modifyAt i (\x -> x { isSelected = true }) deselect

-- | Remove a status a particular row.
deleteRow :: Int -> Array Row -> Array Row
deleteRow pos arr =
  case rowIndex of
    Nothing -> arr
    Just i  ->
      case deleteAt i arr of
        Nothing   -> arr
        Just arr' -> arr'
  where
    rowIndex = findIndex (\x -> x.rid == pos) arr

-- | Swap two rows in an array, updating their ids
swapRows :: Array Row -> Int -> Int -> Maybe (Array Row)
swapRows arr index1 index2 = do
  rowA <- arr !! index1
  rowB <- arr !! index2

  let diff = index2 - index1
  arrA <- updateAt index1 rowB arr
  arrB <- updateAt index2 rowA arrA

  pure arrB

----------
-- View

-- | Return markup from the state
view :: State -> HTML Event
view = memoize \st ->
  div ! className "container" $ do

    div ! className "jumbotron" $ do
      div ! className "row" $ do
        div ! className "col-md-6" $ do
          h1 $ text "Pux 11.0.0"
        div ! className "col-md-6" $ do
          traverse_ viewButton buttons

    table ! className "table table-hover table-striped test-data" $ do
      tbody $ do
        Safe.traverse_ viewRow st.rows

viewRow :: Row -> HTML Event
viewRow { rid, label, isSelected } = do
  case isSelected of
    true  -> tr ! selected "true" ! className "danger"
    false -> tr ! selected ""

  $ do
      td ! className "col-md-1" $ text (show rid)
      td ! className "col-md-4" $
         a ! href "#" #! onClick (Select rid) $ text label
      td ! className "col-md-1" $ do
         a ! href "#" $ do
           span ! className "glyphicon glyphicon-remove"
                ! attribute "aria-hidden" "true"
                #! onClick (Remove rid)
                $ text ""
      td ! className "col-md-6" $ text ""

viewButton :: { bid :: String, str :: String, ev :: (DOMEvent -> Event) } -> HTML Event
viewButton { bid, str, ev } =
  div ! className "col-sm-6 smallpad" $ do
    button
      ! type' "button"
      ! className "btn btn-primary btn-block"
      ! id bid
      #! onClick ev
      $ text str

buttons :: Array { bid :: String, str :: String, ev :: (DOMEvent -> Event) }
buttons =
  [ { bid: "run",      str: "Create 1,000 Rows",     ev: Create Replace 1000  }
  , { bid: "runlots",  str: "Create 10,000 Rows",    ev: Create Replace 10000 }
  , { bid: "add",      str: "Append 1,000 Rows",     ev: Create Append  1000  }
  , { bid: "update",   str: "Update Every 10th Row", ev: UpdateEvery 10 }
  , { bid: "clear",    str: "Clear",                 ev: Clear }
  , { bid: "swaprows", str: "Swap Rows",             ev: Swap 1 998 } ]

----------
-- Supporting Data

adjectives :: Array String
adjectives =
    [ "pretty"
    , "large"
    , "big"
    , "small"
    , "tall"
    , "short"
    , "long"
    , "handsome"
    , "plain"
    , "quaint"
    , "clean"
    , "elegant"
    , "easy"
    , "angry"
    , "crazy"
    , "helpful"
    , "mushy"
    , "odd"
    , "unsightly"
    , "adorable"
    , "important"
    , "inexpensive"
    , "cheap"
    , "expensive"
    , "fancy"
    ]

colours :: Array String
colours =
    [ "red"
    , "yellow"
    , "blue"
    , "green"
    , "pink"
    , "brown"
    , "purple"
    , "brown"
    , "white"
    , "black"
    , "orange"
    ]

nouns :: Array String
nouns =
    [ "table"
    , "chair"
    , "house"
    , "bbq"
    , "desk"
    , "car"
    , "pony"
    , "cookie"
    , "sandwich"
    , "burger"
    , "pizza"
    , "mouse"
    , "keyboard"
    ]

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, stack)
import Control.Monad.Eff.Random (RANDOM, randomInt)
import Control.Monad.Rec.Class (Step(..), tailRecM2)
import Control.Safely as Safe
import DOM (DOM)
import DOM.Event.Event (eventPhase, preventDefault)
import Data.Array (cons, deleteAt, filter, findIndex, index, length, mapWithIndex, modifyAt, unsafeIndex, updateAt, (!!))
import Data.Monoid (class Monoid, mempty)
import Data.Traversable (traverse_)
import Data.Maybe (Maybe(..), fromMaybe)
import Debug.Trace as DT
import Prelude hiding (div,id)
import Pux (EffModel, noEffects, start)
import Pux.DOM.Events (DOMEvent, onClick)
import Pux.DOM.HTML (HTML, memoize)
import Pux.Renderer.React (renderToDOM)
import Signal.Channel (CHANNEL)
import Text.Smolder.HTML (a, button, div, h1, span, table, tbody, td, tr)
import Text.Smolder.HTML.Attributes (className, href, selected, type', id)
import Text.Smolder.Markup (attribute, text, (!), (#!))

----------
-- Main Entry

-- | Start and render the app
main :: Eff (dom :: DOM, channel :: CHANNEL, exception :: EXCEPTION, random :: RANDOM, console :: CONSOLE) Unit
main = do
  app <- start
    { initialState: init
    , view
    , foldp
    , inputs: []
    }

  renderToDOM "#app" app.markup app.input

----------
-- State

type State =
  { rows   :: Array Row
  , lastId :: Int }

type Row =
  { rid        :: Int
  , label      :: String
  , isSelected :: Boolean }

init :: State
init =
  { rows: [], lastId: 1 }

----------
-- Events

data Event
  = MergeRows MergeType (Array Row) Int
  | Create MergeType Int DOMEvent
  | UpdateEvery Int DOMEvent
  | Clear DOMEvent
  | Swap Int Int DOMEvent
  | Remove Int DOMEvent
  | Select Int DOMEvent

data MergeType
  = Replace
  | Append

----------
-- Updates

-- | Return a new state (and effects) from each event
foldp :: Event -> State -> EffModel State Event (dom :: DOM, random :: RANDOM, console :: CONSOLE)

-- Write the received N rows over the rows held by the state,
-- and update the last Id to the received index.
foldp (MergeRows Replace arr i) st =
  noEffects $ st { rows = arr, lastId = i }

-- Append the received N rows into the rows held by the state, and update
-- the last Id to the received index.
foldp (MergeRows Append arr i) st =
  noEffects $ st { rows = st.rows <> arr, lastId = i }

-- Clear all rows from the screen and reset the last id to 1
foldp (Clear ev) st =
  { state: st { rows = [], lastId = st.lastId }, effects: [ liftEff (preventDefault ev) *> pure Nothing] }

-- Create the specified number of rows and prevent the browser
-- from receiving the click event. Depending on the provided
-- merger type (append or replace), return the proper event.
foldp (Create merger i ev) st =
  { state: st
  , effects: [ liftEff $ do
                    preventDefault ev
                    rows <- createRandomNRows i st.lastId
                    pure $ Just $ MergeRows merger rows (st.lastId + i) ] }

-- Update every row at the specified interval by appending three
-- exclamation points.
foldp (UpdateEvery i ev) st =
  { state: st
  , effects: [ liftEff $ do
                    preventDefault ev
                    pure $ Just $ MergeRows Replace (mapWithIndex (updateRowLabel i) st.rows) st.lastId ] }

-- Swap two rows in the view array (standard set to index 4 and 9)
foldp (Swap i0 i1 ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  case swapRows st.rows i0 i1 of
                    Nothing  -> log "Failed to swap rows." *>
                                pure Nothing
                    Just arr -> pure $ Just $ MergeRows Replace arr st.lastId ] }

-- Toggle the selected status of the row at the given index
foldp (Select i ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  pure $ Just $ MergeRows Replace (fromMaybe st.rows $ updateRowSelected i st.rows) st.lastId ] }

-- Toggle the selected status of the row at the given index
foldp (Remove i ev) st =
  { state: st
  , effects: [ liftEff $ do
                  preventDefault ev
                  pure $ Just $ MergeRows Replace (deleteRow i st.rows) st.lastId ] }

-----
-- Update Helpers

-- | Create new batch of random rows
-- | Note: use `tailRecM` to ensure proper tail recursion in monadic code
createRandomNRows :: forall e. Int -> Int -> Eff ( random :: RANDOM | e) (Array Row)
createRandomNRows n lastId = tailRecM2 f [] n
  where
    f arr 0 = pure (Done arr)
    f arr n = do
      str <- selectConcatItems

      let str' = case str of
            Nothing -> ""
            Just s  -> s

      pure (Loop $ { a: (createAndAppendRow arr (n - 1) lastId str')
                   , b: (n - 1) })

-- | Create a single row
createAndAppendRow :: Array Row -> Int -> Int -> String -> Array Row
createAndAppendRow arr index lastId s =
  cons
  ({ rid: lastId + index
    , label: s
    , isSelected: false })
  arr

-- | Select a random element from each array of strings,
-- | and then concatenate them into a string value.
selectConcatItems :: forall e. Eff ( random :: RANDOM | e) (Maybe String)
selectConcatItems = do
  adj <- index adjectives <$> (randomInt 1 $ length adjectives - 1)
  clr <- index colours    <$> (randomInt 1 $ length colours - 1)
  non <- index nouns      <$> (randomInt 1 $ length nouns - 1)

  pure $ adj <> Just " " <> clr <> Just " " <> non

-- | For use in iterating through rows
updateRowLabel :: Int -> Int -> Row -> Row
updateRowLabel interval ix row =
  if ix `mod` interval == 0
  then row { label = row.label <> " !!!" }
  else row

-- | Update the status of a particular row.
--   Only one row is selected at any time
updateRowSelected :: Int -> Array Row -> Maybe (Array Row)
updateRowSelected pos arr = do
  let s' = findIndex (\x -> x.isSelected) arr
  case s' of
    Nothing -> do
      i <- findIndex (\x -> x.rid == pos) arr
      modifyAt i (\x -> x { isSelected = true }) arr
    Just s  -> do
      i <- findIndex (\x -> x.rid == pos) arr
      if s == i
         then pure arr
         else do
            deselect <- modifyAt s (\x -> x { isSelected = false }) arr
            modifyAt i (\x -> x { isSelected = true }) deselect

-- | Remove a status a particular row.
deleteRow :: Int -> Array Row -> Array Row
deleteRow pos arr =
  case rowIndex of
    Nothing -> arr
    Just i  ->
      case deleteAt i arr of
        Nothing   -> arr
        Just arr' -> arr'
  where
    rowIndex = findIndex (\x -> x.rid == pos) arr

-- | Swap two rows in an array, updating their ids
swapRows :: Array Row -> Int -> Int -> Maybe (Array Row)
swapRows arr index1 index2 = do
  rowA <- arr !! index1
  rowB <- arr !! index2

  let diff = index2 - index1
  arrA <- updateAt index1 rowB arr
  arrB <- updateAt index2 rowA arrA

  pure arrB

----------
-- View

-- | Return markup from the state
view :: State -> HTML Event
view = memoize \st ->
  div ! className "container" $ do

    div ! className "jumbotron" $ do
      div ! className "row" $ do
        div ! className "col-md-6" $ do
          h1 $ text "Pux 11.0.0"
        div ! className "col-md-6" $ do
          traverse_ viewButton buttons

    table ! className "table table-hover table-striped test-data" $ do
      tbody $ do
        Safe.traverse_ viewRow st.rows

viewRow :: Row -> HTML Event
viewRow { rid, label, isSelected } = do
  case isSelected of
    true  -> tr ! selected "true" ! className "danger"
    false -> tr ! selected ""

  $ do
      td ! className "col-md-1" $ text (show rid)
      td ! className "col-md-4" $
         a ! href "#" #! onClick (Select rid) $ text label
      td ! className "col-md-1" $ do
         a ! href "#" $ do
           span ! className "glyphicon glyphicon-remove"
                ! attribute "aria-hidden" "true"
                #! onClick (Remove rid)
                $ text ""
      td ! className "col-md-6" $ text ""

viewButton :: { bid :: String, str :: String, ev :: (DOMEvent -> Event) } -> HTML Event
viewButton { bid, str, ev } =
  div ! className "col-sm-6 smallpad" $ do
    button
      ! type' "button"
      ! className "btn btn-primary btn-block"
      ! id bid
      #! onClick ev
      $ text str

buttons :: Array { bid :: String, str :: String, ev :: (DOMEvent -> Event) }
buttons =
  [ { bid: "run",      str: "Create 1,000 Rows",     ev: Create Replace 1000  }
  , { bid: "runlots",  str: "Create 10,000 Rows",    ev: Create Replace 10000 }
  , { bid: "add",      str: "Append 1,000 Rows",     ev: Create Append  1000  }
  , { bid: "update",   str: "Update Every 10th Row", ev: UpdateEvery 10 }
  , { bid: "clear",    str: "Clear",                 ev: Clear }
  , { bid: "swaprows", str: "Swap Rows",             ev: Swap 4 9 } ]

----------
-- Supporting Data

adjectives :: Array String
adjectives =
    [ "pretty"
    , "large"
    , "big"
    , "small"
    , "tall"
    , "short"
    , "long"
    , "handsome"
    , "plain"
    , "quaint"
    , "clean"
    , "elegant"
    , "easy"
    , "angry"
    , "crazy"
    , "helpful"
    , "mushy"
    , "odd"
    , "unsightly"
    , "adorable"
    , "important"
    , "inexpensive"
    , "cheap"
    , "expensive"
    , "fancy"
    ]

colours :: Array String
colours =
    [ "red"
    , "yellow"
    , "blue"
    , "green"
    , "pink"
    , "brown"
    , "purple"
    , "brown"
    , "white"
    , "black"
    , "orange"
    ]

nouns :: Array String
nouns =
    [ "table"
    , "chair"
    , "house"
    , "bbq"
    , "desk"
    , "car"
    , "pony"
    , "cookie"
    , "sandwich"
    , "burger"
    , "pizza"
    , "mouse"
    , "keyboard"
    ]


Squash {object,element}Pixels constructors

-- | This module provides `Prop` values for some common HTML attributes.
module Halogen.HTML.Properties
  ( key
  , alt

  , charset
  , class_, classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , width
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title

  , type_

  , value
  , disabled
  , enabled

  , required
  , readonly
  , spellcheck
  , checked
  , selected
  , placeholder
  , autocomplete
  , autofocus
  , multiple

  , draggable
  , tabIndex

  , ref

  , LengthLiteral()
  , pixels
  , percent
  , Object()
  , Element()
  ) where

import Prelude

import Data.Maybe (Maybe(..))
import Data.String (joinWith)

import DOM.HTML.Types (HTMLElement)

import Halogen.HTML.Core (Prop(..), ClassName, prop, propName, attrName, runClassName)

data Object -- object, iframe, and embed elements
data Element -- any other element

data LengthLiteral et
  = Pixels Int
  | Percent Number

pixels :: forall a. Int -> LengthLiteral a
pixels = Pixels
percent :: Number -> LengthLiteral Object
percent = Percent

printLengthLiteral :: forall et. LengthLiteral et -> String
printLengthLiteral (Pixels n) = show n
printLengthLiteral (Percent n) = show n <> "%"

-- | The `key` property associates a unique key with a node, which can be used
-- | to implement a more efficient diff/patch.
key :: forall i. String -> Prop i
key = Key

alt :: forall i. String -> Prop i
alt = prop (propName "alt") (Just $ attrName "alt")

charset :: forall i. String -> Prop i
charset = prop (propName "charset") (Just $ attrName "charset")

class_ :: forall i. ClassName -> Prop i
class_ = prop (propName "className") (Just $ attrName "class") <<< runClassName

classes :: forall i. Array ClassName -> Prop i
classes = prop (propName "className") (Just $ attrName "class") <<< joinWith " " <<< map runClassName

cols :: forall i. Int -> Prop i
cols = prop (propName "cols") (Just $ attrName "cols")

rows :: forall i. Int -> Prop i
rows = prop (propName "rows") (Just $ attrName "rows")

colSpan :: forall i. Int -> Prop i
colSpan = prop (propName "colSpan") (Just $ attrName "colspan")

rowSpan :: forall i. Int -> Prop i
rowSpan = prop (propName "rowSpan") (Just $ attrName "rowspan")

for :: forall i. String -> Prop i
for = prop (propName "htmlFor") (Just $ attrName "for")

height :: forall i et. LengthLiteral et -> Prop i
height = prop (propName "height") (Just $ attrName "height") <<< printLengthLiteral

href :: forall i. String -> Prop i
href = prop (propName "href") (Just $ attrName "href")

id_ :: forall i. String -> Prop i
id_ = prop (propName "id") (Just $ attrName "id")

name :: forall i. String -> Prop i
name = prop (propName "name") (Just $ attrName "name")

rel :: forall i. String -> Prop i
rel = prop (propName "rel") (Just $ attrName "rel")

src :: forall i. String -> Prop i
src = prop (propName "src") (Just $ attrName "src")

target :: forall i. String -> Prop i
target = prop (propName "target") (Just $ attrName "target")

title :: forall i. String -> Prop i
title = prop (propName "title") (Just $ attrName "title")

type_ :: forall i. String -> Prop i
type_ = prop (propName "type") (Just $ attrName "type")

-- TODO: string rendering of `value` will need custom handling depending on element type
value :: forall i. String -> Prop i
value = prop (propName "value") (Just $ attrName "value")

width :: forall i et. LengthLiteral et -> Prop i
width = prop (propName "width") (Just $ attrName "width") <<< printLengthLiteral

disabled :: forall i. Boolean -> Prop i
disabled = prop (propName "disabled") (Just $ attrName "disabled")

required :: forall i. Boolean -> Prop i
required = prop (propName "required") (Just $ attrName "required")

readonly :: forall i. Boolean -> Prop i
readonly = prop (propName "readOnly") (Just $ attrName "readonly")

spellcheck :: forall i. Boolean -> Prop i
spellcheck = prop (propName "spellcheck") (Just $ attrName "spellcheck")

enabled :: forall i. Boolean -> Prop i
enabled = disabled <<< not

checked :: forall i. Boolean -> Prop i
checked = prop (propName "checked") (Just $ attrName "checked")

selected :: forall i. Boolean -> Prop i
selected = prop (propName "selected") (Just $ attrName "selected")

placeholder :: forall i. String -> Prop i
placeholder = prop (propName "placeholder") (Just $ attrName "placeholder")

autocomplete :: forall i. Boolean -> Prop i
autocomplete = prop (propName "autocomplete") (Just $ attrName "autocomplete") <<< (\b -> if b then "on" else "off")

autofocus :: forall i. Boolean -> Prop i
autofocus = prop (propName "autofocus") (Just $ attrName "autofocus")

multiple :: forall a. Boolean -> Prop a
multiple = prop (propName "multiple") (Just $ attrName "multiple")

draggable :: forall a. Boolean -> Prop a
draggable = prop (propName "draggable") (Just $ attrName "draggable")

tabIndex :: forall a. Int -> Prop a
tabIndex = prop (propName "tabIndex") (Just $ attrName "tabindex")

ref :: forall i. (Maybe HTMLElement -> i) -> Prop i
ref = Ref

-- | This module provides `Prop` values for some common HTML attributes.
module Halogen.HTML.Properties
  ( key
  , alt

  , charset
  , class_, classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , width
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title

  , type_

  , value
  , disabled
  , enabled

  , required
  , readonly
  , spellcheck
  , checked
  , selected
  , placeholder
  , autocomplete
  , autofocus
  , multiple

  , draggable
  , tabIndex

  , ref

  , LengthLiteral()
  , objectPixels
  , objectPercent
  , elementPixels
  , Object()
  , Element()
  ) where

import Prelude

import Data.Maybe (Maybe(..))
import Data.String (joinWith)

import DOM.HTML.Types (HTMLElement)

import Halogen.HTML.Core (Prop(..), ClassName, prop, propName, attrName, runClassName)

data Object -- object, iframe, and embed elements
data Element -- any other element

data LengthLiteral et
  = Pixels Int
  | Percent Number

objectPixels :: Int -> LengthLiteral Object
objectPixels = Pixels
objectPercent :: Number -> LengthLiteral Object
objectPercent = Percent
elementPixels :: Int -> LengthLiteral Element
elementPixels = Pixels

printLengthLiteral :: forall et. LengthLiteral et -> String
printLengthLiteral (Pixels n) = show n
printLengthLiteral (Percent n) = show n <> "%"

-- | The `key` property associates a unique key with a node, which can be used
-- | to implement a more efficient diff/patch.
key :: forall i. String -> Prop i
key = Key

alt :: forall i. String -> Prop i
alt = prop (propName "alt") (Just $ attrName "alt")

charset :: forall i. String -> Prop i
charset = prop (propName "charset") (Just $ attrName "charset")

class_ :: forall i. ClassName -> Prop i
class_ = prop (propName "className") (Just $ attrName "class") <<< runClassName

classes :: forall i. Array ClassName -> Prop i
classes = prop (propName "className") (Just $ attrName "class") <<< joinWith " " <<< map runClassName

cols :: forall i. Int -> Prop i
cols = prop (propName "cols") (Just $ attrName "cols")

rows :: forall i. Int -> Prop i
rows = prop (propName "rows") (Just $ attrName "rows")

colSpan :: forall i. Int -> Prop i
colSpan = prop (propName "colSpan") (Just $ attrName "colspan")

rowSpan :: forall i. Int -> Prop i
rowSpan = prop (propName "rowSpan") (Just $ attrName "rowspan")

for :: forall i. String -> Prop i
for = prop (propName "htmlFor") (Just $ attrName "for")

height :: forall i et. LengthLiteral et -> Prop i
height = prop (propName "height") (Just $ attrName "height") <<< printLengthLiteral

href :: forall i. String -> Prop i
href = prop (propName "href") (Just $ attrName "href")

id_ :: forall i. String -> Prop i
id_ = prop (propName "id") (Just $ attrName "id")

name :: forall i. String -> Prop i
name = prop (propName "name") (Just $ attrName "name")

rel :: forall i. String -> Prop i
rel = prop (propName "rel") (Just $ attrName "rel")

src :: forall i. String -> Prop i
src = prop (propName "src") (Just $ attrName "src")

target :: forall i. String -> Prop i
target = prop (propName "target") (Just $ attrName "target")

title :: forall i. String -> Prop i
title = prop (propName "title") (Just $ attrName "title")

type_ :: forall i. String -> Prop i
type_ = prop (propName "type") (Just $ attrName "type")

-- TODO: string rendering of `value` will need custom handling depending on element type
value :: forall i. String -> Prop i
value = prop (propName "value") (Just $ attrName "value")

width :: forall i et. LengthLiteral et -> Prop i
width = prop (propName "width") (Just $ attrName "width") <<< printLengthLiteral

disabled :: forall i. Boolean -> Prop i
disabled = prop (propName "disabled") (Just $ attrName "disabled")

required :: forall i. Boolean -> Prop i
required = prop (propName "required") (Just $ attrName "required")

readonly :: forall i. Boolean -> Prop i
readonly = prop (propName "readOnly") (Just $ attrName "readonly")

spellcheck :: forall i. Boolean -> Prop i
spellcheck = prop (propName "spellcheck") (Just $ attrName "spellcheck")

enabled :: forall i. Boolean -> Prop i
enabled = disabled <<< not

checked :: forall i. Boolean -> Prop i
checked = prop (propName "checked") (Just $ attrName "checked")

selected :: forall i. Boolean -> Prop i
selected = prop (propName "selected") (Just $ attrName "selected")

placeholder :: forall i. String -> Prop i
placeholder = prop (propName "placeholder") (Just $ attrName "placeholder")

autocomplete :: forall i. Boolean -> Prop i
autocomplete = prop (propName "autocomplete") (Just $ attrName "autocomplete") <<< (\b -> if b then "on" else "off")

autofocus :: forall i. Boolean -> Prop i
autofocus = prop (propName "autofocus") (Just $ attrName "autofocus")

multiple :: forall a. Boolean -> Prop a
multiple = prop (propName "multiple") (Just $ attrName "multiple")

draggable :: forall a. Boolean -> Prop a
draggable = prop (propName "draggable") (Just $ attrName "draggable")

tabIndex :: forall a. Int -> Prop a
tabIndex = prop (propName "tabIndex") (Just $ attrName "tabindex")

ref :: forall i. (Maybe HTMLElement -> i) -> Prop i
ref = Ref


Remove verbose, old comment

Remove verbose, old comment

-- | This module parses the options section of the Docopt source string.
-- |
-- | ```
-- |   -h --help     Show this screen.
-- |   --version     Show version.
-- |   --speed=<kn>  Speed in knots [default: 10].
-- |   --moored      Moored (anchored) mine.
-- |   --drifting    Drifting mine.
-- | ```
-- |
-- | XXX:
-- | Because of the structure of the string, lexing and parsing must be
-- | interwoven to some degree. It would be great, however to re-use the
-- | existing TokenParsers written for the usage section somehow. Maybe
-- | a `pre-lex -> lex -> parse` method is justified? Or just ignore all
-- | unknown tokens.
-- |
-- | Known tokens would be [ SOpt, LOpt, Comma, '--', ':', '[default', ']'
-- |                       , StringLiteral, NumericLiteral ]
-- |
-- | During parsing, we would look for either:
-- |
-- | [ Sopt, Comma, Lopt ]
-- | [ Sopt, Lopt ]
-- | [ Lopt ]
-- | [ -- ]
-- |
-- | All following tokens are then part of the description, mostly garbage.
-- | However, we keep an eye open for '[default' and ']' and the StringLiteral
-- | and NumericLiterals contained in it.

module Docopt.Parser.Options where

import Prelude
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.MonadPlus (guard)
import Data.List (
  List(..), some, (:), toList, length
, singleton, many, head, catMaybes)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Generic
import Data.String (toLower, fromChar)
import qualified Data.Array as A

import Docopt.Parser.Base
import Docopt.Parser.Common
import qualified Docopt.Parser.Lexer as L

type Argument    = String
type Default     = String
data ShortOption = ShortOption Char  (Maybe Argument)
data LongOption  = LongOption String (Maybe Argument)

-- XXX: Option should have a `Maybe Argument`, pulled
--      from it's short and long option.
--      Need to decide what happens if both options
--      specifiy a different argument!
data Option = Option (Maybe ShortOption)
                     (Maybe LongOption)
                     (Maybe Default)

type PartialOption = (Maybe Argument) -> Option

derive instance genericOptionSpec  :: Generic Option
derive instance genericShortOption :: Generic ShortOption
derive instance genericLongOption  :: Generic LongOption

instance showShortOption :: Show ShortOption where
  show (ShortOption c a) = "-" ++ (fromChar c)
                               ++ (case a of
                                        Just a -> "=" ++ a
                                        _      -> "")

instance showlongOption :: Show LongOption where
  show (LongOption s a) = "--" ++ s
                               ++ (case a of
                                        Just a -> "=" ++ a
                                        _      -> "")

instance showOptionSpec  :: Show Option where
  show (Option s l d) =
    let hasLong    = isJust l
        hasShort   = isJust s
        hasDefault = isJust d
        short      = maybe "" show s
        long       = maybe "" (\x -> (if hasShort then ", " else "") ++ show x) l
        default    = maybe "" (\x -> " [" ++ x ++ "]") d
     in show $ short ++ long ++ default

parse :: (List L.PositionedToken) -> Either P.ParseError (List Option)
parse = flip L.runTokenParser optionsParser

optionsParser :: L.TokenParser (List Option)
optionsParser = do

  many option

  where

    anyName :: L.TokenParser String
    anyName = L.angleName <|> L.shoutName <|> L.name

    defaults :: L.TokenParser String
    defaults = L.default

    option :: L.TokenParser Option
    option = sameIndent *> do
      f <- P.choice
        [ P.try shortAndLong
        , P.try onlyLong
        , P.try onlyShort
        ]

      -- Parse one token at a time towards the next option or the eof.
      -- If a `[default: ...]` token is met, list it.
      default <- head <<< catMaybes <$> do
        flip P.manyTill (L.eof <|> (P.try $ P.lookAhead $ void option)) do
          P.choice [
            P.try $ Just <$> defaults
          , L.anyToken *> pure Nothing
          ]
      pure $ f default

    onlyShort :: L.TokenParser PartialOption
    onlyShort = Option
        <$> (Just <$> shortOption)
        <*> (pure Nothing)

    onlyLong :: L.TokenParser PartialOption
    onlyLong = Option
        <$> (pure Nothing)
        <*> (Just <$> longOption)

    shortAndLong :: L.TokenParser PartialOption
    shortAndLong = markLine do
      Option
        <$> (Just <$> shortOption)
        <*> (Just <$> (sameLine *> P.choice
              [ P.try L.comma *> longOption
              , longOption
              ]))

    shortOption :: L.TokenParser ShortOption
    shortOption = do
      { flag: flag, stack: stack, arg: arg } <- L.sopt
      (guard $ (A.length stack == 0))
        P.<?> "No stacked options"
      return $ ShortOption flag arg

    longOption :: L.TokenParser LongOption
    longOption = do
      { name: name, arg: arg } <- L.lopt
      return $ LongOption name arg