Remove EffTest, s/eff/e

Remove EffTest, s/eff/e

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Bifoldable (class Bifoldable, bifoldl, bifoldr, bifoldMap, bifoldrDefault, bifoldlDefault, bifoldMapDefaultR, bifoldMapDefaultL)
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Bitraversable (class Bitraversable, bisequenceDefault, bitraverse, bisequence, bitraverseDefault)
import Data.Foldable (class Foldable, find, findMap, fold, foldMap, foldMapDefaultL, foldMapDefaultR, foldl, foldlDefault, foldr, foldrDefault, length, maximum, maximumBy, minimum, minimumBy, null, surroundMap)
import Data.FoldableWithIndex (class FoldableWithIndex, findWithIndex, foldMapWithIndex, foldMapWithIndexDefaultL, foldMapWithIndexDefaultR, foldlWithIndex, foldlWithIndexDefault, foldrWithIndex, foldrWithIndexDefault, surroundMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
import Data.Int (toNumber, pow)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Traversable (class Traversable, sequenceDefault, traverse, sequence, traverseDefault)
import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
import Math (abs)
import Test.Assert (ASSERT, assert, assert')
import Unsafe.Coerce (unsafeCoerce)

foreign import arrayFrom1UpTo :: Int -> Array Int
foreign import arrayReplicate :: forall a. Int -> a -> Array a

foldableLength :: forall f a. Foldable f => f a -> Int
foldableLength = unwrap <<< foldMap (const (Additive 1))

-- Ensure that a value is evaluated 'lazily' by treating it as an Eff action.
deferEff :: forall e a. (Unit -> a) -> Eff e a
deferEff = unsafeCoerce

main :: Eff (assert :: ASSERT, console :: CONSOLE) Unit
main = do
  log "Test foldableArray instance"
  testFoldableArrayWith 20

  assert $ foldMapDefaultL (\x -> [x]) [1, 2] == [1, 2]

  log "Test foldableArray instance is stack safe"
  testFoldableArrayWith 20000

  log "Test foldMapDefaultL"
  testFoldableFoldMapDefaultL 20

  log "Test foldMapDefaultR"
  testFoldableFoldMapDefaultR 20

  log "Test foldlDefault"
  testFoldableFoldlDefault 20

  log "Test foldrDefault"
  testFoldableFoldrDefault 20

  foreachE [1,2,3,4,5,10,20] \i -> do
    log $ "Test traversableArray instance with an array of size: " <> show i
    testTraversableArrayWith i

  log "Test traversableArray instance is stack safe"
  testTraversableArrayWith 20000

  log "Test traverseDefault"
  testTraverseDefault 20

  log "Test sequenceDefault"
  testSequenceDefault 20

  log "Test foldableWithIndexArray instance"
  testFoldableWithIndexArrayWith 20

  log "Test foldableWithIndexArray instance is stack safe"
  testFoldableWithIndexArrayWith 20000

  log "Test FoldableWithIndex laws for array instance"
  testFoldableWithIndexLawsOn
    ["a", "b", "c"]
    (\i x -> [Tuple i x])
    (\x -> [x])

  log "Test traversableArrayWithIndex instance"
  testTraversableWithIndexArrayWith 20

  log "Test Bifoldable on `inclusive or`"
  testBifoldableIOrWith id 10 100 42

  log "Test bifoldMapDefaultL"
  testBifoldableIOrWith BFML 10 100 42

  log "Test bifoldMapDefaultR"
  testBifoldableIOrWith BFMR 10 100 42

  log "Test bifoldlDefault"
  testBifoldableIOrWith BFLD 10 100 42

  log "Test bifoldrDefault"
  testBifoldableIOrWith BFRD 10 100 42

  log "Test Bitraversable on `inclusive or`"
  testBitraversableIOrWith id

  log "Test bitraverseDefault"
  testBitraversableIOrWith BTD

  log "Test bisequenceDefault"
  testBitraversableIOrWith BSD

  log "Test find"
  assert $ find (_ == 10) [1, 5, 10] == Just 10
  assert $ find (\x -> x `mod` 2 == 0) [1, 4, 10] == Just 4

  log "Test findWithIndex"
  assert $ findWithIndex (\i x -> i == 2 && x `mod` 2 == 0) [1, 2, 4, 6] == Just 4

  log "Test findMap" *> do
    let pred x = if x > 5 then Just (x * 100) else Nothing
    assert $ findMap pred [1, 5, 10, 20] == Just 1000

  log "Test maximum"
  assert $ maximum (arrayFrom1UpTo 10) == Just 10

  log "Test maximumBy"
  assert $
    maximumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-10.0)

  log "Test minimum"
  assert $ minimum (arrayFrom1UpTo 10) == Just 1

  log "Test minimumBy"
  assert $
    minimumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-1.0)

  log "Test null"
  assert $ null Nothing == true
  assert $ null (Just 1) == false
  assert $ null [] == true
  assert $ null [0] == false
  assert $ null [0,1] == false

  log "Test length"
  assert $ length Nothing == 0
  assert $ length (Just 1) == 1
  assert $ length [] == 0
  assert $ length [1] == 1
  assert $ length [1, 2] == 2

  log "Test surroundMap"
  assert $ "*" == surroundMap "*" show ([] :: Array Int)
  assert $ "*1*" == surroundMap "*" show [1]
  assert $ "*1*2*" == surroundMap "*" show [1, 2]
  assert $ "*1*2*3*" == surroundMap "*" show [1, 2, 3]

  log "Test surroundMapWithIndex"
  assert $ "*" == surroundMapWithIndex "*" (\i x -> show i <> x) []
  assert $ "*0a*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a"]
  assert $ "*0a*1b*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b"]
  assert $ "*0a*1b*2c*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b", "c"]

  log "All done!"

testFoldableFWith
  :: forall f e
   . Foldable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testFoldableFWith f n = do
  let dat = f n
  let expectedSum = (n / 2) * (n + 1)

  assert $ foldr (+) 0 dat == expectedSum
  assert $ foldl (+) 0 dat == expectedSum
  assert $ foldMap Additive dat == Additive expectedSum

testFoldableArrayWith :: forall e. Int -> Eff (assert :: ASSERT | e) Unit
testFoldableArrayWith = testFoldableFWith arrayFrom1UpTo

testFoldableWithIndexFWith
  :: forall f e
   . FoldableWithIndex Int f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexFWith f n = do
  let dat = f n
  -- expectedSum = \Sum_{1 <= i <= n} i * i
  let expectedSum = n * (n + 1) * (2 * n + 1) / 6

  assert $ foldrWithIndex (\i x y -> (i + 1) * x + y) 0 dat == expectedSum
  assert $ foldlWithIndex (\i y x -> y + (i + 1) * x) 0 dat == expectedSum
  assert $ foldMapWithIndex (\i x -> Additive $ (i + 1) * x) dat == Additive expectedSum

testFoldableWithIndexArrayWith :: forall e. Int -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexArrayWith = testFoldableWithIndexFWith arrayFrom1UpTo

data Tuple a b = Tuple a b
derive instance eqTuple :: (Eq a, Eq b) => Eq (Tuple a b)

-- test whether foldable laws hold, using foldMap and ifoldMap
testFoldableWithIndexLawsOn
  :: forall f i a m n e
   . FoldableWithIndex i f
  => FunctorWithIndex i f
  => Monoid m
  => Monoid n
  => Eq m
  => Eq n
  => f a
  -> (i -> a -> m)
  -> (a -> n)
  -> Eff (assert :: ASSERT | e) Unit
testFoldableWithIndexLawsOn c f g = do
  -- compatibility with FunctorWithIndex (not strictly necessary for a valid
  -- instance, but it's likely an error if this does not hold)
  assert $ foldMapWithIndex f c == fold (mapWithIndex f c)

  -- Compatiblity with Foldable
  assert $ foldMap g c == foldMapWithIndex (const g) c

  -- FoldableWithIndex laws
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultL f c
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultR f c

  -- These follow from the above laws, but they test whether ifoldlDefault and
  -- ifoldrDefault have been specified correctly.
  assert $ foldMapWithIndex f c == foldlWithIndexDefault (\i y x -> y <> f i x) mempty c
  assert $ foldMapWithIndex f c == foldrWithIndexDefault (\i x y -> f i x <> y) mempty c

testTraversableFWith
  :: forall f e
   . Traversable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testTraversableFWith f n = do
  let dat = f n
  let len = foldableLength dat

  _ <- traverse pure dat

  assert' "traverse Just == Just" $ traverse Just dat == Just dat
  assert' "traverse pure == pure (Array)" $ traverse pure dat == [dat]

  when (len <= 10) do
    result <- deferEff \_ -> traverse (\x -> [x,x]) dat == arrayReplicate (pow 2 len) dat
    assert' "traverse with Array as underlying applicative" result

  assert' "traverse (const Nothing) == const Nothing" $
    traverse (const Nothing :: Int -> Maybe Int) dat == Nothing

  assert' "sequence <<< map f == traverse f" $
    sequence (map Just dat) == traverse Just dat

  assert' "underlying applicative" $
    (traverse pure dat :: Unit -> f Int) unit == dat

testTraversableArrayWith :: forall e. Int -> Eff (assert :: ASSERT | e) Unit
testTraversableArrayWith = testTraversableFWith arrayFrom1UpTo

testTraversableWithIndexFWith
  :: forall f e
   . TraversableWithIndex Int f
  => Eq (f (Tuple Int Int))
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testTraversableWithIndexFWith f n = do
  let dat = f n

  assert $ traverseWithIndex (\i -> Just <<< Tuple i) dat == Just (mapWithIndex Tuple dat)
  assert $ traverseWithIndex (const Just) dat == traverse Just dat
  assert $ traverseWithIndex (\i -> pure <<< Tuple i) dat == [mapWithIndex Tuple dat]
  assert $
    traverseWithIndex (const pure :: Int -> Int -> Array Int) dat ==
    traverse pure dat

testTraversableWithIndexArrayWith
  :: forall e. Int -> Eff (assert :: ASSERT | e) Unit
testTraversableWithIndexArrayWith = testTraversableWithIndexFWith arrayFrom1UpTo

-- structures for testing default `Foldable` implementations

newtype FoldMapDefaultL a = FML (Array a)
newtype FoldMapDefaultR a = FMR (Array a)
newtype FoldlDefault    a = FLD (Array a)
newtype FoldrDefault    a = FRD (Array a)

instance eqFML :: (Eq a) => Eq (FoldMapDefaultL a) where eq (FML l) (FML r) = l == r
instance eqFMR :: (Eq a) => Eq (FoldMapDefaultR a) where eq (FMR l) (FMR r) = l == r
instance eqFLD :: (Eq a) => Eq (FoldlDefault a)    where eq (FLD l) (FLD r) = l == r
instance eqFRD :: (Eq a) => Eq (FoldrDefault a)    where eq (FRD l) (FRD r) = l == r

-- implemented `foldl` and `foldr`, but default `foldMap` using `foldl`
instance foldableFML :: Foldable FoldMapDefaultL where
  foldMap f         = foldMapDefaultL f
  foldl f u (FML a) = foldl f u a
  foldr f u (FML a) = foldr f u a

-- implemented `foldl` and `foldr`, but default `foldMap`, using `foldr`
instance foldableFMR :: Foldable FoldMapDefaultR where
  foldMap f         = foldMapDefaultR f
  foldl f u (FMR a) = foldl f u a
  foldr f u (FMR a) = foldr f u a

-- implemented `foldMap` and `foldr`, but default `foldMap`
instance foldableDFL :: Foldable FoldlDefault where
  foldMap f (FLD a) = foldMap f a
  foldl f u         = foldlDefault f u
  foldr f u (FLD a) = foldr f u a

-- implemented `foldMap` and `foldl`, but default `foldr`
instance foldableDFR :: Foldable FoldrDefault where
  foldMap f (FRD a) = foldMap f a
  foldl f u (FRD a) = foldl f u a
  foldr f u         = foldrDefault f u

testFoldableFoldMapDefaultL :: forall e. Int -> Eff (assert :: ASSERT | e) Unit
testFoldableFoldMapDefaultL = testFoldableFWith (FML <<< arrayFrom1UpTo)

testFoldableFoldMapDefaultR :: forall e. Int -> Eff (assert :: ASSERT | e) Unit
testFoldableFoldMapDefaultR = testFoldableFWith (FMR <<< arrayFrom1UpTo)

testFoldableFoldlDefault :: forall e. Int -> Eff (assert :: ASSERT | e) Unit
testFoldableFoldlDefault = testFoldableFWith (FLD <<< arrayFrom1UpTo)

testFoldableFoldrDefault :: forall e. Int -> Eff (assert :: ASSERT | e) Unit
testFoldableFoldrDefault = testFoldableFWith (FRD <<< arrayFrom1UpTo)

-- structures for testing default `Traversable` implementations

newtype TraverseDefault a = TD (Array a)
newtype SequenceDefault a = SD (Array a)

instance eqTD :: (Eq a) => Eq (TraverseDefault a) where eq (TD l) (TD r) = l == r
instance eqSD :: (Eq a) => Eq (SequenceDefault a) where eq (SD l) (SD r) = l == r

instance functorTD :: Functor TraverseDefault where map f (TD a) = TD (map f a)
instance functorSD :: Functor SequenceDefault where map f (SD a) = SD (map f a)

instance foldableTD :: Foldable TraverseDefault where
  foldMap f (TD a) = foldMap f a
  foldr f u (TD a) = foldr f u a
  foldl f u (TD a) = foldl f u a

instance foldableSD :: Foldable SequenceDefault where
  foldMap f (SD a) = foldMap f a
  foldr f u (SD a) = foldr f u a
  foldl f u (SD a) = foldl f u a

instance traversableTD :: Traversable TraverseDefault where
  traverse f      = traverseDefault f
  sequence (TD a) = map TD (sequence a)

instance traversableSD :: Traversable SequenceDefault where
  traverse f (SD a) = map SD (traverse f a)
  sequence m        = sequenceDefault m

testTraverseDefault :: forall e. Int -> Eff (assert :: ASSERT | e) Unit
testTraverseDefault = testTraversableFWith (TD <<< arrayFrom1UpTo)

testSequenceDefault :: forall e. Int -> Eff (assert :: ASSERT | e) Unit
testSequenceDefault = testTraversableFWith (SD <<< arrayFrom1UpTo)

-- structure for testing bifoldable, picked `inclusive or` as it has both products and sums

data IOr l r = Both l r | Fst l | Snd r

instance eqIOr :: (Eq l, Eq r) => Eq (IOr l r) where
  eq (Both lFst lSnd) (Both rFst rSnd) = (lFst == rFst) && (lSnd == rSnd)
  eq (Fst l)          (Fst r)          = l == r
  eq (Snd l)          (Snd r)          = l == r
  eq _                _                = false

instance bifoldableIOr :: Bifoldable IOr where
  bifoldr l r u (Both fst snd) = l fst (r snd u)
  bifoldr l r u (Fst fst)      = l fst u
  bifoldr l r u (Snd snd)      = r snd u

  bifoldl l r u (Both fst snd) = r (l u fst) snd
  bifoldl l r u (Fst fst)      = l u fst
  bifoldl l r u (Snd snd)      = r u snd

  bifoldMap l r (Both fst snd) = l fst <> r snd
  bifoldMap l r (Fst fst)      = l fst
  bifoldMap l r (Snd snd)      = r snd

instance bifunctorIOr :: Bifunctor IOr where
  bimap f g (Both fst snd) = Both (f fst) (g snd)
  bimap f g (Fst fst)      = Fst (f fst)
  bimap f g (Snd snd)      = Snd (g snd)

instance bitraversableIOr :: Bitraversable IOr where
  bitraverse f g (Both fst snd) = Both <$> f fst <*> g snd
  bitraverse f g (Fst fst)      = Fst <$> f fst
  bitraverse f g (Snd snd)      = Snd <$> g snd

  bisequence (Both fst snd) = Both <$> fst <*> snd
  bisequence (Fst fst)      = Fst <$> fst
  bisequence (Snd snd)      = Snd <$> snd

testBifoldableIOrWith
  :: forall t e
   . Bifoldable t
  => Eq (t Int Int)
  => (forall l r. IOr l r -> t l r)
  -> Int
  -> Int
  -> Int
  -> Eff (assert :: ASSERT | e) Unit
testBifoldableIOrWith lift fst snd u = do
  assert $ bifoldr (+) (*) u (lift $ Both fst snd) == fst + (snd * u)
  assert $ bifoldr (+) (*) u (lift $ Fst fst)      == fst + u
  assert $ bifoldr (+) (*) u (lift $ Snd snd)      == snd * u

  assert $ bifoldl (+) (*) u (lift $ Both fst snd) == (u + fst) * snd
  assert $ bifoldl (+) (*) u (lift $ Fst fst)      == u + fst
  assert $ bifoldl (+) (*) u (lift $ Snd snd)      == u * snd

  assert $ bifoldMap Additive Additive (lift $ Both fst snd) == Additive (fst + snd)
  assert $ bifoldMap Additive Additive (lift $ Fst fst)      == Additive fst
  assert $ bifoldMap Additive Additive (lift $ Snd snd)      == Additive snd

testBitraversableIOrWith
  :: forall t e
   . Bitraversable t
  => Eq (t Boolean Boolean)
  => (forall l r. IOr l r -> t l r)
  -> Eff (assert :: ASSERT | e) Unit
testBitraversableIOrWith lift = do
  let just a = Just (lift a)
  assert $ bisequence (lift (Both (Just true) (Just false))) == just (Both true false)
  assert $ bisequence (lift (Fst (Just true)))               == just (Fst true  :: IOr Boolean Boolean)
  assert $ bisequence (lift (Snd (Just false)))              == just (Snd false :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Both true false))     == just (Both true false)
  assert $ bitraverse Just Just (lift (Fst true))            == just (Fst true  :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Snd false))           == just (Snd false :: IOr Boolean Boolean)

-- structures for testing default `Bifoldable` implementations

newtype BifoldMapDefaultL l r = BFML (IOr l r)
newtype BifoldMapDefaultR l r = BFMR (IOr l r)
newtype BifoldlDefault    l r = BFLD (IOr l r)
newtype BifoldrDefault    l r = BFRD (IOr l r)

instance eqBFML :: (Eq l, Eq r) => Eq (BifoldMapDefaultL l r) where eq (BFML l) (BFML r) = l == r
instance eqBFMR :: (Eq l, Eq r) => Eq (BifoldMapDefaultR l r) where eq (BFMR l) (BFMR r) = l == r
instance eqBFLD :: (Eq l, Eq r) => Eq (BifoldlDefault l r)    where eq (BFLD l) (BFLD r) = l == r
instance eqBFRD :: (Eq l, Eq r) => Eq (BifoldrDefault l r)    where eq (BFRD l) (BFRD r) = l == r

instance bifoldableBFML :: Bifoldable BifoldMapDefaultL where
  bifoldMap f g m        = bifoldMapDefaultL f g m
  bifoldr f g u (BFML m) = bifoldr f g u m
  bifoldl f g u (BFML m) = bifoldl f g u m

instance bifoldableBFMR :: Bifoldable BifoldMapDefaultR where
  bifoldMap f g m        = bifoldMapDefaultR f g m
  bifoldr f g u (BFMR m) = bifoldr f g u m
  bifoldl f g u (BFMR m) = bifoldl f g u m

instance bifoldableBFLD :: Bifoldable BifoldlDefault where
  bifoldMap f g (BFLD m) = bifoldMap f g m
  bifoldr f g u (BFLD m) = bifoldr f g u m
  bifoldl f g u m        = bifoldlDefault f g u m

instance bifoldableBFRD :: Bifoldable BifoldrDefault where
  bifoldMap f g (BFRD m) = bifoldMap f g m
  bifoldr f g u m        = bifoldrDefault f g u m
  bifoldl f g u (BFRD m) = bifoldl f g u m

-- structures for testing default `Bitraversable` implementations

newtype BitraverseDefault l r = BTD (IOr l r)
newtype BisequenceDefault l r = BSD (IOr l r)

instance eqBTD :: (Eq l, Eq r) => Eq (BitraverseDefault l r) where eq (BTD l) (BTD r) = l == r
instance eqBSD :: (Eq l, Eq r) => Eq (BisequenceDefault l r) where eq (BSD l) (BSD r) = l == r

instance bifunctorBTD :: Bifunctor BitraverseDefault where bimap f g (BTD m) = BTD (bimap f g m)
instance bifunctorBSD :: Bifunctor BisequenceDefault where bimap f g (BSD m) = BSD (bimap f g m)

instance bifoldableBTD :: Bifoldable BitraverseDefault where
  bifoldMap f g (BTD m) = bifoldMap f g m
  bifoldr f g u (BTD m) = bifoldr f g u m
  bifoldl f g u (BTD m) = bifoldl f g u m

instance bifoldableBSD :: Bifoldable BisequenceDefault where
  bifoldMap f g (BSD m) = bifoldMap f g m
  bifoldr f g u (BSD m) = bifoldr f g u m
  bifoldl f g u (BSD m) = bifoldl f g u m

instance bitraversableBTD :: Bitraversable BitraverseDefault where
  bitraverse f g     = bitraverseDefault f g
  bisequence (BTD m) = map BTD (bisequence m)

instance bitraversableBSD :: Bitraversable BisequenceDefault where
  bitraverse f g (BSD m) = map BSD (bitraverse f g m)
  bisequence m           = bisequenceDefault m

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Bifoldable (class Bifoldable, bifoldl, bifoldr, bifoldMap, bifoldrDefault, bifoldlDefault, bifoldMapDefaultR, bifoldMapDefaultL)
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Bitraversable (class Bitraversable, bisequenceDefault, bitraverse, bisequence, bitraverseDefault)
import Data.Foldable (class Foldable, find, findMap, fold, foldMap, foldMapDefaultL, foldMapDefaultR, foldl, foldlDefault, foldr, foldrDefault, length, maximum, maximumBy, minimum, minimumBy, null, surroundMap)
import Data.FoldableWithIndex (class FoldableWithIndex, findWithIndex, foldMapWithIndex, foldMapWithIndexDefaultL, foldMapWithIndexDefaultR, foldlWithIndex, foldlWithIndexDefault, foldrWithIndex, foldrWithIndexDefault, surroundMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
import Data.Int (toNumber, pow)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Traversable (class Traversable, sequenceDefault, traverse, sequence, traverseDefault)
import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
import Math (abs)
import Test.Assert (ASSERT, assert, assert')
import Unsafe.Coerce (unsafeCoerce)

foreign import arrayFrom1UpTo :: Int -> Array Int
foreign import arrayReplicate :: forall a. Int -> a -> Array a

foldableLength :: forall f a. Foldable f => f a -> Int
foldableLength = unwrap <<< foldMap (const (Additive 1))

-- Ensure that a value is evaluated 'lazily' by treating it as an Eff action.
deferEff :: forall e a. (Unit -> a) -> Eff e a
deferEff = unsafeCoerce

type EffTest a = forall e. Eff (assert :: ASSERT | e) a

main :: Eff (assert :: ASSERT, console :: CONSOLE) Unit
main = do
  log "Test foldableArray instance"
  testFoldableArrayWith 20

  assert $ foldMapDefaultL (\x -> [x]) [1, 2] == [1, 2]

  log "Test foldableArray instance is stack safe"
  testFoldableArrayWith 20000

  log "Test foldMapDefaultL"
  testFoldableFoldMapDefaultL 20

  log "Test foldMapDefaultR"
  testFoldableFoldMapDefaultR 20

  log "Test foldlDefault"
  testFoldableFoldlDefault 20

  log "Test foldrDefault"
  testFoldableFoldlDefault 20

  foreachE [1,2,3,4,5,10,20] \i -> do
    log $ "Test traversableArray instance with an array of size: " <> show i
    testTraversableArrayWith i

  log "Test traversableArray instance is stack safe"
  testTraversableArrayWith 20000

  log "Test traverseDefault"
  testTraverseDefault 20

  log "Test sequenceDefault"
  testSequenceDefault 20

  log "Test foldableWithIndexArray instance"
  testFoldableWithIndexArrayWith 20

  log "Test foldableWithIndexArray instance is stack safe"
  testFoldableWithIndexArrayWith 20000

  log "Test FoldableWithIndex laws for array instance"
  testFoldableWithIndexLawsOn
    ["a", "b", "c"]
    (\i x -> [Tuple i x])
    (\x -> [x])

  log "Test traversableArrayWithIndex instance"
  testTraversableWithIndexArrayWith 20

  log "Test Bifoldable on `inclusive or`"
  testBifoldableIOrWith id 10 100 42

  log "Test bifoldMapDefaultL"
  testBifoldableIOrWith BFML 10 100 42

  log "Test bifoldMapDefaultR"
  testBifoldableIOrWith BFMR 10 100 42

  log "Test bifoldlDefault"
  testBifoldableIOrWith BFLD 10 100 42

  log "Test bifoldrDefault"
  testBifoldableIOrWith BFRD 10 100 42

  log "Test Bitraversable on `inclusive or`"
  testBitraversableIOrWith id

  log "Test bitraverseDefault"
  testBitraversableIOrWith BTD

  log "Test bisequenceDefault"
  testBitraversableIOrWith BSD

  log "Test find"
  assert $ find (_ == 10) [1, 5, 10] == Just 10
  assert $ find (\x -> x `mod` 2 == 0) [1, 4, 10] == Just 4

  log "Test findWithIndex"
  assert $ findWithIndex (\i x -> i == 2 && x `mod` 2 == 0) [1, 2, 4, 6] == Just 4

  log "Test findMap" *> do
    let pred x = if x > 5 then Just (x * 100) else Nothing
    assert $ findMap pred [1, 5, 10, 20] == Just 1000

  log "Test maximum"
  assert $ maximum (arrayFrom1UpTo 10) == Just 10

  log "Test maximumBy"
  assert $
    maximumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-10.0)

  log "Test minimum"
  assert $ minimum (arrayFrom1UpTo 10) == Just 1

  log "Test minimumBy"
  assert $
    minimumBy (compare `on` abs)
              (map (negate <<< toNumber) (arrayFrom1UpTo 10))
      == Just (-1.0)

  log "Test null"
  assert $ null Nothing == true
  assert $ null (Just 1) == false
  assert $ null [] == true
  assert $ null [0] == false
  assert $ null [0,1] == false

  log "Test length"
  assert $ length Nothing == 0
  assert $ length (Just 1) == 1
  assert $ length [] == 0
  assert $ length [1] == 1
  assert $ length [1, 2] == 2

  log "Test surroundMap"
  assert $ "*" == surroundMap "*" show ([] :: Array Int)
  assert $ "*1*" == surroundMap "*" show [1]
  assert $ "*1*2*" == surroundMap "*" show [1, 2]
  assert $ "*1*2*3*" == surroundMap "*" show [1, 2, 3]

  log "Test surroundMapWithIndex"
  assert $ "*" == surroundMapWithIndex "*" (\i x -> show i <> x) []
  assert $ "*0a*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a"]
  assert $ "*0a*1b*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b"]
  assert $ "*0a*1b*2c*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b", "c"]

  log "All done!"

testFoldableFWith
  :: forall f
   . Foldable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> EffTest Unit
testFoldableFWith f n = do
  let dat = f n
  let expectedSum = (n / 2) * (n + 1)

  assert $ foldr (+) 0 dat == expectedSum
  assert $ foldl (+) 0 dat == expectedSum
  assert $ foldMap Additive dat == Additive expectedSum

testFoldableArrayWith :: Int -> EffTest Unit
testFoldableArrayWith = testFoldableFWith arrayFrom1UpTo

testFoldableWithIndexFWith
  :: forall f
   . FoldableWithIndex Int f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> EffTest Unit
testFoldableWithIndexFWith f n = do
  let dat = f n
  -- expectedSum = \Sum_{1 <= i <= n} i * i
  let expectedSum = n * (n + 1) * (2 * n + 1) / 6

  assert $ foldrWithIndex (\i x y -> (i + 1) * x + y) 0 dat == expectedSum
  assert $ foldlWithIndex (\i y x -> y + (i + 1) * x) 0 dat == expectedSum
  assert $ foldMapWithIndex (\i x -> Additive $ (i + 1) * x) dat == Additive expectedSum

testFoldableWithIndexArrayWith :: Int -> EffTest Unit
testFoldableWithIndexArrayWith = testFoldableWithIndexFWith arrayFrom1UpTo

data Tuple a b = Tuple a b
derive instance eqTuple :: (Eq a, Eq b) => Eq (Tuple a b)

-- test whether foldable laws hold, using foldMap and ifoldMap
testFoldableWithIndexLawsOn
  :: forall f i a m n
   . FoldableWithIndex i f
  => FunctorWithIndex i f
  => Monoid m
  => Monoid n
  => Eq m
  => Eq n
  => f a
  -> (i -> a -> m)
  -> (a -> n)
  -> EffTest Unit
testFoldableWithIndexLawsOn c f g = do
  -- compatibility with FunctorWithIndex (not strictly necessary for a valid
  -- instance, but it's likely an error if this does not hold)
  assert $ foldMapWithIndex f c == fold (mapWithIndex f c)

  -- Compatiblity with Foldable
  assert $ foldMap g c == foldMapWithIndex (const g) c

  -- FoldableWithIndex laws
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultL f c
  assert $ foldMapWithIndex f c == foldMapWithIndexDefaultR f c

  -- These follow from the above laws, but they test whether ifoldlDefault and
  -- ifoldrDefault have been specified correctly.
  assert $ foldMapWithIndex f c == foldlWithIndexDefault (\i y x -> y <> f i x) mempty c
  assert $ foldMapWithIndex f c == foldrWithIndexDefault (\i x y -> f i x <> y) mempty c

testTraversableFWith
  :: forall f
   . Traversable f
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> EffTest Unit
testTraversableFWith f n = do
  let dat = f n
  let len = foldableLength dat

  _ <- traverse pure dat

  assert' "traverse Just == Just" $ traverse Just dat == Just dat
  assert' "traverse pure == pure (Array)" $ traverse pure dat == [dat]

  when (len <= 10) do
    result <- deferEff \_ -> traverse (\x -> [x,x]) dat == arrayReplicate (pow 2 len) dat
    assert' "traverse with Array as underlying applicative" result

  assert' "traverse (const Nothing) == const Nothing" $
    traverse (const Nothing :: Int -> Maybe Int) dat == Nothing

  assert' "sequence <<< map f == traverse f" $
    sequence (map Just dat) == traverse Just dat

  assert' "underlying applicative" $
    (traverse pure dat :: Unit -> f Int) unit == dat

testTraversableArrayWith :: Int -> EffTest Unit
testTraversableArrayWith = testTraversableFWith arrayFrom1UpTo

testTraversableWithIndexFWith
  :: forall f
   . TraversableWithIndex Int f
  => Eq (f (Tuple Int Int))
  => Eq (f Int)
  => (Int -> f Int)
  -> Int
  -> EffTest Unit
testTraversableWithIndexFWith f n = do
  let dat = f n

  assert $ traverseWithIndex (\i -> Just <<< Tuple i) dat == Just (mapWithIndex Tuple dat)
  assert $ traverseWithIndex (const Just) dat == traverse Just dat
  assert $ traverseWithIndex (\i -> pure <<< Tuple i) dat == [mapWithIndex Tuple dat]
  assert $
    traverseWithIndex (const pure :: Int -> Int -> Array Int) dat ==
    traverse pure dat

testTraversableWithIndexArrayWith
  :: Int -> EffTest Unit
testTraversableWithIndexArrayWith = testTraversableWithIndexFWith arrayFrom1UpTo

-- structures for testing default `Foldable` implementations

newtype FoldMapDefaultL a = FML (Array a)
newtype FoldMapDefaultR a = FMR (Array a)
newtype FoldlDefault    a = FLD (Array a)
newtype FoldrDefault    a = FRD (Array a)

instance eqFML :: (Eq a) => Eq (FoldMapDefaultL a) where eq (FML l) (FML r) = l == r
instance eqFMR :: (Eq a) => Eq (FoldMapDefaultR a) where eq (FMR l) (FMR r) = l == r
instance eqFLD :: (Eq a) => Eq (FoldlDefault a)    where eq (FLD l) (FLD r) = l == r
instance eqFRD :: (Eq a) => Eq (FoldrDefault a)    where eq (FRD l) (FRD r) = l == r

-- implemented `foldl` and `foldr`, but default `foldMap` using `foldl`
instance foldableFML :: Foldable FoldMapDefaultL where
  foldMap f         = foldMapDefaultL f
  foldl f u (FML a) = foldl f u a
  foldr f u (FML a) = foldr f u a

-- implemented `foldl` and `foldr`, but default `foldMap`, using `foldr`
instance foldableFMR :: Foldable FoldMapDefaultR where
  foldMap f         = foldMapDefaultR f
  foldl f u (FMR a) = foldl f u a
  foldr f u (FMR a) = foldr f u a

-- implemented `foldMap` and `foldr`, but default `foldMap`
instance foldableDFL :: Foldable FoldlDefault where
  foldMap f (FLD a) = foldMap f a
  foldl f u         = foldlDefault f u
  foldr f u (FLD a) = foldr f u a

-- implemented `foldMap` and `foldl`, but default `foldr`
instance foldableDFR :: Foldable FoldrDefault where
  foldMap f (FRD a) = foldMap f a
  foldl f u (FRD a) = foldl f u a
  foldr f u         = foldrDefault f u

testFoldableFoldMapDefaultL :: Int -> EffTest Unit
testFoldableFoldMapDefaultL = testFoldableFWith (FML <<< arrayFrom1UpTo)

testFoldableFoldMapDefaultR :: Int -> EffTest Unit
testFoldableFoldMapDefaultR = testFoldableFWith (FMR <<< arrayFrom1UpTo)

testFoldableFoldlDefault :: Int -> EffTest Unit
testFoldableFoldlDefault = testFoldableFWith (FLD <<< arrayFrom1UpTo)

testFoldableFoldrDefault :: Int -> EffTest Unit
testFoldableFoldrDefault = testFoldableFWith (FRD <<< arrayFrom1UpTo)

-- structures for testing default `Traversable` implementations

newtype TraverseDefault a = TD (Array a)
newtype SequenceDefault a = SD (Array a)

instance eqTD :: (Eq a) => Eq (TraverseDefault a) where eq (TD l) (TD r) = l == r
instance eqSD :: (Eq a) => Eq (SequenceDefault a) where eq (SD l) (SD r) = l == r

instance functorTD :: Functor TraverseDefault where map f (TD a) = TD (map f a)
instance functorSD :: Functor SequenceDefault where map f (SD a) = SD (map f a)

instance foldableTD :: Foldable TraverseDefault where
  foldMap f (TD a) = foldMap f a
  foldr f u (TD a) = foldr f u a
  foldl f u (TD a) = foldl f u a

instance foldableSD :: Foldable SequenceDefault where
  foldMap f (SD a) = foldMap f a
  foldr f u (SD a) = foldr f u a
  foldl f u (SD a) = foldl f u a

instance traversableTD :: Traversable TraverseDefault where
  traverse f      = traverseDefault f
  sequence (TD a) = map TD (sequence a)

instance traversableSD :: Traversable SequenceDefault where
  traverse f (SD a) = map SD (traverse f a)
  sequence m        = sequenceDefault m

testTraverseDefault :: Int -> EffTest Unit
testTraverseDefault = testTraversableFWith (TD <<< arrayFrom1UpTo)

testSequenceDefault :: Int -> EffTest Unit
testSequenceDefault = testTraversableFWith (SD <<< arrayFrom1UpTo)

-- structure for testing bifoldable, picked `inclusive or` as it has both products and sums

data IOr l r = Both l r | Fst l | Snd r

instance eqIOr :: (Eq l, Eq r) => Eq (IOr l r) where
  eq (Both lFst lSnd) (Both rFst rSnd) = (lFst == rFst) && (lSnd == rSnd)
  eq (Fst l)          (Fst r)          = l == r
  eq (Snd l)          (Snd r)          = l == r
  eq _                _                = false

instance bifoldableIOr :: Bifoldable IOr where
  bifoldr l r u (Both fst snd) = l fst (r snd u)
  bifoldr l r u (Fst fst)      = l fst u
  bifoldr l r u (Snd snd)      = r snd u

  bifoldl l r u (Both fst snd) = r (l u fst) snd
  bifoldl l r u (Fst fst)      = l u fst
  bifoldl l r u (Snd snd)      = r u snd

  bifoldMap l r (Both fst snd) = l fst <> r snd
  bifoldMap l r (Fst fst)      = l fst
  bifoldMap l r (Snd snd)      = r snd

instance bifunctorIOr :: Bifunctor IOr where
  bimap f g (Both fst snd) = Both (f fst) (g snd)
  bimap f g (Fst fst)      = Fst (f fst)
  bimap f g (Snd snd)      = Snd (g snd)

instance bitraversableIOr :: Bitraversable IOr where
  bitraverse f g (Both fst snd) = Both <$> f fst <*> g snd
  bitraverse f g (Fst fst)      = Fst <$> f fst
  bitraverse f g (Snd snd)      = Snd <$> g snd

  bisequence (Both fst snd) = Both <$> fst <*> snd
  bisequence (Fst fst)      = Fst <$> fst
  bisequence (Snd snd)      = Snd <$> snd

testBifoldableIOrWith
  :: forall t
   . Bifoldable t
  => Eq (t Int Int)
  => (forall l r. IOr l r -> t l r)
  -> Int
  -> Int
  -> Int
  -> EffTest Unit
testBifoldableIOrWith lift fst snd u = do
  assert $ bifoldr (+) (*) u (lift $ Both fst snd) == fst + (snd * u)
  assert $ bifoldr (+) (*) u (lift $ Fst fst)      == fst + u
  assert $ bifoldr (+) (*) u (lift $ Snd snd)      == snd * u

  assert $ bifoldl (+) (*) u (lift $ Both fst snd) == (u + fst) * snd
  assert $ bifoldl (+) (*) u (lift $ Fst fst)      == u + fst
  assert $ bifoldl (+) (*) u (lift $ Snd snd)      == u * snd

  assert $ bifoldMap Additive Additive (lift $ Both fst snd) == Additive (fst + snd)
  assert $ bifoldMap Additive Additive (lift $ Fst fst)      == Additive fst
  assert $ bifoldMap Additive Additive (lift $ Snd snd)      == Additive snd

testBitraversableIOrWith
  :: forall t
   . Bitraversable t
  => Eq (t Boolean Boolean)
  => (forall l r. IOr l r -> t l r)
  -> EffTest Unit
testBitraversableIOrWith lift = do
  let just a = Just (lift a)
  assert $ bisequence (lift (Both (Just true) (Just false))) == just (Both true false)
  assert $ bisequence (lift (Fst (Just true)))               == just (Fst true  :: IOr Boolean Boolean)
  assert $ bisequence (lift (Snd (Just false)))              == just (Snd false :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Both true false))     == just (Both true false)
  assert $ bitraverse Just Just (lift (Fst true))            == just (Fst true  :: IOr Boolean Boolean)
  assert $ bitraverse Just Just (lift (Snd false))           == just (Snd false :: IOr Boolean Boolean)

-- structures for testing default `Bifoldable` implementations

newtype BifoldMapDefaultL l r = BFML (IOr l r)
newtype BifoldMapDefaultR l r = BFMR (IOr l r)
newtype BifoldlDefault    l r = BFLD (IOr l r)
newtype BifoldrDefault    l r = BFRD (IOr l r)

instance eqBFML :: (Eq l, Eq r) => Eq (BifoldMapDefaultL l r) where eq (BFML l) (BFML r) = l == r
instance eqBFMR :: (Eq l, Eq r) => Eq (BifoldMapDefaultR l r) where eq (BFMR l) (BFMR r) = l == r
instance eqBFLD :: (Eq l, Eq r) => Eq (BifoldlDefault l r)    where eq (BFLD l) (BFLD r) = l == r
instance eqBFRD :: (Eq l, Eq r) => Eq (BifoldrDefault l r)    where eq (BFRD l) (BFRD r) = l == r

instance bifoldableBFML :: Bifoldable BifoldMapDefaultL where
  bifoldMap f g m        = bifoldMapDefaultL f g m
  bifoldr f g u (BFML m) = bifoldr f g u m
  bifoldl f g u (BFML m) = bifoldl f g u m

instance bifoldableBFMR :: Bifoldable BifoldMapDefaultR where
  bifoldMap f g m        = bifoldMapDefaultR f g m
  bifoldr f g u (BFMR m) = bifoldr f g u m
  bifoldl f g u (BFMR m) = bifoldl f g u m

instance bifoldableBFLD :: Bifoldable BifoldlDefault where
  bifoldMap f g (BFLD m) = bifoldMap f g m
  bifoldr f g u (BFLD m) = bifoldr f g u m
  bifoldl f g u m        = bifoldlDefault f g u m

instance bifoldableBFRD :: Bifoldable BifoldrDefault where
  bifoldMap f g (BFRD m) = bifoldMap f g m
  bifoldr f g u m        = bifoldrDefault f g u m
  bifoldl f g u (BFRD m) = bifoldl f g u m

-- structures for testing default `Bitraversable` implementations

newtype BitraverseDefault l r = BTD (IOr l r)
newtype BisequenceDefault l r = BSD (IOr l r)

instance eqBTD :: (Eq l, Eq r) => Eq (BitraverseDefault l r) where eq (BTD l) (BTD r) = l == r
instance eqBSD :: (Eq l, Eq r) => Eq (BisequenceDefault l r) where eq (BSD l) (BSD r) = l == r

instance bifunctorBTD :: Bifunctor BitraverseDefault where bimap f g (BTD m) = BTD (bimap f g m)
instance bifunctorBSD :: Bifunctor BisequenceDefault where bimap f g (BSD m) = BSD (bimap f g m)

instance bifoldableBTD :: Bifoldable BitraverseDefault where
  bifoldMap f g (BTD m) = bifoldMap f g m
  bifoldr f g u (BTD m) = bifoldr f g u m
  bifoldl f g u (BTD m) = bifoldl f g u m

instance bifoldableBSD :: Bifoldable BisequenceDefault where
  bifoldMap f g (BSD m) = bifoldMap f g m
  bifoldr f g u (BSD m) = bifoldr f g u m
  bifoldl f g u (BSD m) = bifoldl f g u m

instance bitraversableBTD :: Bitraversable BitraverseDefault where
  bitraverse f g     = bitraverseDefault f g
  bisequence (BTD m) = map BTD (bisequence m)

instance bitraversableBSD :: Bitraversable BisequenceDefault where
  bitraverse f g (BSD m) = map BSD (bitraverse f g m)
  bisequence m           = bisequenceDefault m


filter out period from name

filter out period from name

module FrontEnd where

import Prelude

import CSS (backgroundImage, url)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.Aff.Console (CONSOLE, errorShow, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (error)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Now (NOW)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Control.MonadPlus (guard)
import DOM (DOM)
import Data.Array (filter, fromFoldable, reverse, sort, sortWith)
import Data.Bifunctor (bimap)
import Data.Either (Either(..), either)
import Data.Foreign (ForeignError)
import Data.HTTP.Method (Method(..))
import Data.JSDate as JSDate
import Data.List (List)
import Data.List.NonEmpty (NonEmptyList)
import Data.Maybe (Maybe(Nothing, Just), isJust, isNothing, maybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Set (Set, insert, member)
import Data.String (Pattern(Pattern), contains, fromCharArray, toLower)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (find)
import Data.Tuple (Tuple(..))
import Data.Validation.Semigroup (V, invalid, unV)
import ECharts.Types as ET
import FrontEnd.Chart as Chart
import FrontEnd.Style as Styles
import Global (encodeURIComponent)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.CSS (style)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver as D
import Network.HTTP.Affjax (AJAX)
import Network.HTTP.Affjax as AJ
import Network.HTTP.RequestHeader (RequestHeader(..))
import Routes (GetRoute, PostRoute, files, getIcons, open, remove, update, watched)
import Simple.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)
import Text.Parsing.StringParser (Parser, runParser, try)
import Text.Parsing.StringParser.Combinators (many1Till)
import Text.Parsing.StringParser.String (anyChar, anyDigit, char, string)
import Types (FileData(..), GetIconsRequest(..), OpenRequest(..), Path(..), RemoveRequest(..), WatchedData(..))

nameParser :: Parser (List Char)
nameParser = do
    thingInBrackets
    _ <- char ' '
    title <- many1Till anyChar endSequence
    pure title
  where
    thingInBrackets = do
      _ <- char '['
      _ <- many1Till anyChar (char ']')
      pure unit
    endSequence = try do
      _ <- string " - "
      _ <- many1Till anyDigit (char ' ')
      thingInBrackets
      _ <- char '.'
      pure unit

extractNameKinda :: Path -> Either String String
extractNameKinda (Path s) =
  bimap show (fromCharArray <<< filter' <<< fromFoldable) $ runParser nameParser s
  where
    filter' =
      (=<<) case _ of
        '.' -> mempty
        x -> pure x

type VE a = V (NonEmptyList ForeignError) a

get :: forall res url m eff.
  MonadAff
    ( ajax :: AJAX
    | eff
    )
    m
  => ReadForeign res
  => IsSymbol url
  => GetRoute res url -> m (VE res)
get _ =
  H.liftAff $ either invalid pure <$> parseResponse <$> action
  where
    action = AJ.affjax $ AJ.defaultRequest
      { method = Left GET
      , url = reflectSymbol (SProxy :: SProxy url)
      , headers = [RequestHeader "Content-Type" "application/json"]
      }
    parseResponse response = readJSON response.response

post :: forall method req res url m eff.
  MonadAff
    ( ajax :: AJAX
    | eff
    )
    m
  => WriteForeign req
  => ReadForeign res
  => IsSymbol url
  => PostRoute req res url -> req -> m (VE res)
post _ body =
  H.liftAff $ either invalid pure <$> parseResponse <$> action
  where
    action = AJ.affjax $ AJ.defaultRequest
      { method = Left POST
      , url = reflectSymbol (SProxy :: SProxy url)
      , content = pure $ writeJSON body
      , headers = [RequestHeader "Content-Type" "application/json"]
      }
    parseResponse response = readJSON response.response

unV' :: forall e a m.
  MonadAff
    ( console :: CONSOLE
    | e
    )
    m
  => (a -> m Unit) -> VE a -> m Unit
unV' = unV (H.liftAff <<< errorShow)

data Dir = ASC | DSC
derive instance eqDir :: Eq Dir
data Col = Title | Status
derive instance eqCol :: Eq Col
data Sorting = Sorting Col Dir | NoSorting

newtype ChartSeries = ChartSeries (Array ChartSeriesData)
newtype ChartSeriesData = ChartSeriesData
  { date :: String
  , value :: Int
  }

type State =
  { files :: Array Path
  , watched :: Array WatchedData
  , filterWatched :: Boolean
  , sorting :: Sorting
  , search :: String
  , deleteConfirmations :: Set Path
  }

data Query a
  = Init a
  | FetchData a
  | GetIcons a
  | OpenFile Path a
  | SetWatched Path Boolean a
  | Filter Path a
  | ChangeSorting Col a
  | Search String a
  | ClearSearch a
  | ToggleFilterWatched Boolean a
  | ConfirmDeletion Path a
  | Delete Path a

type AppEffects eff =
  Aff
  ( ajax :: AJAX
  , console :: CONSOLE
  , dom :: DOM
  , echarts :: ET.ECHARTS
  , exception :: EXCEPTION
  , now :: NOW
  | eff )

data Slot = ChartSlot
derive instance eqSlot :: Eq Slot
derive instance ordSlot :: Ord Slot

ui :: forall eff. H.Component HH.HTML Query Unit Void (AppEffects eff)
ui =
  H.lifecycleParentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
    initialState :: State
    initialState =
      { files: mempty
      , watched: mempty
      , filterWatched: false
      , sorting: NoSorting
      , search: mempty
      , deleteConfirmations: mempty
      }

    render :: State -> H.ParentHTML Query Chart.Query Slot (AppEffects eff)
    render state =
      HH.div
        [ HP.class_ $ Styles.container ]
        $ [ HH.h1_ [ HH.text "Vidtracker" ]
          , heatmap
          , refreshButton
          , getIconsButton
          , filterCheckbox
          , search
          , header
          ] <> files
      where
        heatmap =
          HH.slot ChartSlot Chart.component state.watched absurd
        refreshButton =
          HH.button
            [ HP.classes $
              [ Styles.refreshFiles
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ FetchData
            ]
            [ HH.text "Refresh" ]
        getIconsButton =
          HH.button
            [ HP.classes $
              [ Styles.getIcons
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ GetIcons
            ]
            [ HH.text "Run Get Icons" ]
        filterCheckbox =
          HH.button
            [ HP.classes $
              [ Styles.filterWatched
              , wrap "pure-button"
              ] <> (guard state.filterWatched $> wrap "pure-button-primary")
            , HE.onClick <<< HE.input_ <<< ToggleFilterWatched <<< not $ state.filterWatched
            ]
            [ HH.text "Filter Watched" ]
        search =
          HH.div_
            $ [ HH.h4_ [ HH.text "Search" ]
              , HH.input
                  [ HP.value state.search
                  , HE.onValueInput (HE.input Search)
                  ]
              ] <> clear
        clear =
          guard (state.search /= "") $>
            HH.button
              [ HE.onClick $ HE.input_ ClearSearch ]
              [ HH.text "Clear" ]
        header =
          HH.div
            [ HP.class_ $ Styles.file]
            [ HH.h3
              [ HP.class_ $ Styles.dot
              ] []
            , HH.h3
              [ HP.class_ $ Styles.fileLink
              , HE.onClick $ HE.input_ (ChangeSorting Title)
              ] [ HH.text $ "Title" <> displayTicker Title ]
            , HH.h3
              [ HP.class_ $ Styles.fileButton
              , HE.onClick $ HE.input_ (ChangeSorting Status)
              ] [ HH.text $ "Status" <> displayTicker Status ]
            , HH.h3 [HP.class_ $ Styles.fileNote ] [ HH.text "Date" ]
            , HH.h3
              [ HP.class_ $ Styles.filterLink
              ] [ HH.text "" ]
            , HH.h3
              [ HP.class_ $ Styles.deleteLink
              ] [ HH.text "" ]
            ]
        files =
          file <$> applyTransforms state.files

        displayTicker col
          | Sorting col' dir <- state.sorting
          , asc <- dir == ASC
          , col' == col = if asc
            then " ASC"
            else " DSC"
          | otherwise = ""
        applyTransforms = applySorting <<< applySearchFiltering <<< applyWatchFiltering
        applyWatchFiltering = if state.filterWatched
          then filter $ isNothing <<< findWatched
          else id
        applySearchFiltering = case state.search of
            "" -> id
            x -> filter $ \(Path path) -> contains (Pattern $ toLower x) (toLower path)
        applySorting
          | Sorting col dir <- state.sorting
          , rev <- if dir == ASC
            then id
            else reverse
          , sort' <- case col of
            Title -> sort
            Status -> sortWith findWatched
          = rev <<< sort'
          | otherwise = id
        findWatched path = find (\(WatchedData fd) -> fd.path == path) state.watched
        file path =
          HH.div
            [ HP.class_ $ Styles.file ]
            [ HH.span
              [ HP.class_ $ Styles.dot
              , style do
                case extractNameKinda path of
                  Right name ->
                    backgroundImage (url $ "icons/" <> encodeURIComponent name)
                  Left e -> pure mempty
                -- borderColor $ fromMaybe (rgb 255 105 180) dotColor
              ] []
            , HH.a
              [ HP.class_ Styles.fileLink
              , HE.onClick $ HE.input_ (OpenFile path) ]
              [ HH.text $ unwrap path ]
            , HH.button
              [ HP.classes $
                [ Styles.fileButton
                , wrap "pure-button"
                , wrap $ maybe "" (const "pure-button-primary") watched
                ]
              , HE.onClick $ HE.input_ (SetWatched path (not $ isJust watched))
              ]
              [ HH.text $ maybe "not watched" (const "watched") watched ]
            , HH.span
              [ HP.class_ $ Styles.fileNote ]
              [ HH.text $ maybe "" id watched ]
            , HH.button
              [ HP.classes $
                [ Styles.filterLink
                , wrap "pure-button"
                ]
              , HE.onClick $ HE.input_ (Filter path)
              ]
              [ HH.text "set filter" ]
            , HH.button
              [ HP.classes $
                [ Styles.deleteLink
                , wrap "pure-button"
                , if deleteConfirmation
                    then Styles.deleteConfirmation
                    else wrap ""
                ]
              , HE.onClick $ HE.input_ $
                  if deleteConfirmation
                    then (Delete path)
                    else (ConfirmDeletion path)
              ]
              [ HH.text
                  if deleteConfirmation
                    then "Confirm"
                    else "Delete"
              ]
            ]
          where
            watched = getDate <$> findWatched path
            deleteConfirmation = member path state.deleteConfirmations
            getDate (WatchedData {created}) =
              -- parsing date is UTZ dependent (ergo effectful), but in our case, we really don't care
              JSDate.toDateString <<< unsafePerformEff <<< JSDate.parse $ created

    error' = H.liftEff <<< error

    eval :: Query ~> H.ParentDSL State Query Chart.Query Slot Void (AppEffects eff)
    eval (Init next) = do
      eval (FetchData next)

    eval (FetchData next) = do
      getResult >>= unV'
        \(Tuple f w) -> do
          H.modify _ {files = f, watched = w}
      pure next
      where
        getResult = do
          files <- get files
          watched <- get watched
          pure $ Tuple <$> files <*> watched

    eval (GetIcons next) = do
      _ <- post getIcons $ GetIconsRequest {}
      pure next

    eval (OpenFile path next) = do
      _ <- post open $ OpenRequest {path}
      pure next

    eval (SetWatched path flag next) = do
      post update (FileData {path, watched: flag})
        >>= unV' \w -> H.modify _ {watched = w}
      pure next

    eval (Filter path next) = do
      case extractNameKinda path of
        Left e -> error' e *> pure next
        Right s -> eval $ Search s next

    eval (Search str next) = do
      H.modify _ {search = str}
      pure next

    eval (ClearSearch next) = do
      H.modify _ {search = ""}
      pure next

    eval (ChangeSorting col next)= do
      H.modify $ \s -> case s.sorting of
        Sorting curr dir | curr == col ->
          s {sorting = case dir of
              ASC -> Sorting col DSC
              DSC -> NoSorting
            }
        _ -> s {sorting = Sorting col ASC}
      pure next

    eval (ToggleFilterWatched flag next) = do
      H.modify _ {filterWatched = flag}
      pure next

    eval (ConfirmDeletion path next) = do
      H.modify \s -> s {deleteConfirmations = insert path s.deleteConfirmations}
      pure next

    eval (Delete path next) = do
      _ <- post remove $ RemoveRequest {path}
      eval (FetchData next)

main :: forall e.
  Eff
    ( avar :: AVAR
    , ref :: REF
    , exception :: EXCEPTION
    , dom :: DOM
    , console :: CONSOLE
    , ajax :: AJAX
    , now :: NOW
    , echarts :: ET.ECHARTS
    | e
    )
    Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  io <- D.runUI ui unit body

  log "Running"

module FrontEnd where

import Prelude

import CSS (backgroundImage, url)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.Aff.Console (CONSOLE, errorShow, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (error)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Now (NOW)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Control.MonadPlus (guard)
import DOM (DOM)
import Data.Array (filter, fromFoldable, reverse, sort, sortWith)
import Data.Bifunctor (bimap)
import Data.Either (Either(..), either)
import Data.Foreign (ForeignError)
import Data.HTTP.Method (Method(..))
import Data.JSDate as JSDate
import Data.List (List)
import Data.List.NonEmpty (NonEmptyList)
import Data.Maybe (Maybe(Nothing, Just), isJust, isNothing, maybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap, wrap)
import Data.Set (Set, insert, member)
import Data.String (Pattern(Pattern), contains, fromCharArray, toLower)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (find)
import Data.Tuple (Tuple(..))
import Data.Validation.Semigroup (V, invalid, unV)
import ECharts.Types as ET
import FrontEnd.Chart as Chart
import FrontEnd.Style as Styles
import Global (encodeURIComponent)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.CSS (style)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver as D
import Network.HTTP.Affjax (AJAX)
import Network.HTTP.Affjax as AJ
import Network.HTTP.RequestHeader (RequestHeader(..))
import Routes (GetRoute, PostRoute, files, getIcons, open, remove, update, watched)
import Simple.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)
import Text.Parsing.StringParser (Parser, runParser, try)
import Text.Parsing.StringParser.Combinators (many1Till)
import Text.Parsing.StringParser.String (anyChar, anyDigit, char, string)
import Types (FileData(..), GetIconsRequest(..), OpenRequest(..), Path(..), RemoveRequest(..), WatchedData(..))

nameParser :: Parser (List Char)
nameParser = do
    thingInBrackets
    _ <- char ' '
    title <- many1Till anyChar endSequence
    pure title
  where
    thingInBrackets = do
      _ <- char '['
      _ <- many1Till anyChar (char ']')
      pure unit
    endSequence = try do
      _ <- string " - "
      _ <- many1Till anyDigit (char ' ')
      thingInBrackets
      _ <- char '.'
      pure unit

extractNameKinda :: Path -> Either String String
extractNameKinda (Path s) =
  bimap show (fromCharArray <<< fromFoldable) $ runParser nameParser s

type VE a = V (NonEmptyList ForeignError) a

get :: forall res url m eff.
  MonadAff
    ( ajax :: AJAX
    | eff
    )
    m
  => ReadForeign res
  => IsSymbol url
  => GetRoute res url -> m (VE res)
get _ =
  H.liftAff $ either invalid pure <$> parseResponse <$> action
  where
    action = AJ.affjax $ AJ.defaultRequest
      { method = Left GET
      , url = reflectSymbol (SProxy :: SProxy url)
      , headers = [RequestHeader "Content-Type" "application/json"]
      }
    parseResponse response = readJSON response.response

post :: forall method req res url m eff.
  MonadAff
    ( ajax :: AJAX
    | eff
    )
    m
  => WriteForeign req
  => ReadForeign res
  => IsSymbol url
  => PostRoute req res url -> req -> m (VE res)
post _ body =
  H.liftAff $ either invalid pure <$> parseResponse <$> action
  where
    action = AJ.affjax $ AJ.defaultRequest
      { method = Left POST
      , url = reflectSymbol (SProxy :: SProxy url)
      , content = pure $ writeJSON body
      , headers = [RequestHeader "Content-Type" "application/json"]
      }
    parseResponse response = readJSON response.response

unV' :: forall e a m.
  MonadAff
    ( console :: CONSOLE
    | e
    )
    m
  => (a -> m Unit) -> VE a -> m Unit
unV' = unV (H.liftAff <<< errorShow)

data Dir = ASC | DSC
derive instance eqDir :: Eq Dir
data Col = Title | Status
derive instance eqCol :: Eq Col
data Sorting = Sorting Col Dir | NoSorting

newtype ChartSeries = ChartSeries (Array ChartSeriesData)
newtype ChartSeriesData = ChartSeriesData
  { date :: String
  , value :: Int
  }

type State =
  { files :: Array Path
  , watched :: Array WatchedData
  , filterWatched :: Boolean
  , sorting :: Sorting
  , search :: String
  , deleteConfirmations :: Set Path
  }

data Query a
  = Init a
  | FetchData a
  | GetIcons a
  | OpenFile Path a
  | SetWatched Path Boolean a
  | Filter Path a
  | ChangeSorting Col a
  | Search String a
  | ClearSearch a
  | ToggleFilterWatched Boolean a
  | ConfirmDeletion Path a
  | Delete Path a

type AppEffects eff =
  Aff
  ( ajax :: AJAX
  , console :: CONSOLE
  , dom :: DOM
  , echarts :: ET.ECHARTS
  , exception :: EXCEPTION
  , now :: NOW
  | eff )

data Slot = ChartSlot
derive instance eqSlot :: Eq Slot
derive instance ordSlot :: Ord Slot

ui :: forall eff. H.Component HH.HTML Query Unit Void (AppEffects eff)
ui =
  H.lifecycleParentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }
  where
    initialState :: State
    initialState =
      { files: mempty
      , watched: mempty
      , filterWatched: false
      , sorting: NoSorting
      , search: mempty
      , deleteConfirmations: mempty
      }

    render :: State -> H.ParentHTML Query Chart.Query Slot (AppEffects eff)
    render state =
      HH.div
        [ HP.class_ $ Styles.container ]
        $ [ HH.h1_ [ HH.text "Vidtracker" ]
          , heatmap
          , refreshButton
          , getIconsButton
          , filterCheckbox
          , search
          , header
          ] <> files
      where
        heatmap =
          HH.slot ChartSlot Chart.component state.watched absurd
        refreshButton =
          HH.button
            [ HP.classes $
              [ Styles.refreshFiles
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ FetchData
            ]
            [ HH.text "Refresh" ]
        getIconsButton =
          HH.button
            [ HP.classes $
              [ Styles.getIcons
              , wrap "pure-button"
              ]
            , HE.onClick <<< HE.input_ $ GetIcons
            ]
            [ HH.text "Run Get Icons" ]
        filterCheckbox =
          HH.button
            [ HP.classes $
              [ Styles.filterWatched
              , wrap "pure-button"
              ] <> (guard state.filterWatched $> wrap "pure-button-primary")
            , HE.onClick <<< HE.input_ <<< ToggleFilterWatched <<< not $ state.filterWatched
            ]
            [ HH.text "Filter Watched" ]
        search =
          HH.div_
            $ [ HH.h4_ [ HH.text "Search" ]
              , HH.input
                  [ HP.value state.search
                  , HE.onValueInput (HE.input Search)
                  ]
              ] <> clear
        clear =
          guard (state.search /= "") $>
            HH.button
              [ HE.onClick $ HE.input_ ClearSearch ]
              [ HH.text "Clear" ]
        header =
          HH.div
            [ HP.class_ $ Styles.file]
            [ HH.h3
              [ HP.class_ $ Styles.dot
              ] []
            , HH.h3
              [ HP.class_ $ Styles.fileLink
              , HE.onClick $ HE.input_ (ChangeSorting Title)
              ] [ HH.text $ "Title" <> displayTicker Title ]
            , HH.h3
              [ HP.class_ $ Styles.fileButton
              , HE.onClick $ HE.input_ (ChangeSorting Status)
              ] [ HH.text $ "Status" <> displayTicker Status ]
            , HH.h3 [HP.class_ $ Styles.fileNote ] [ HH.text "Date" ]
            , HH.h3
              [ HP.class_ $ Styles.filterLink
              ] [ HH.text "" ]
            , HH.h3
              [ HP.class_ $ Styles.deleteLink
              ] [ HH.text "" ]
            ]
        files =
          file <$> applyTransforms state.files

        displayTicker col
          | Sorting col' dir <- state.sorting
          , asc <- dir == ASC
          , col' == col = if asc
            then " ASC"
            else " DSC"
          | otherwise = ""
        applyTransforms = applySorting <<< applySearchFiltering <<< applyWatchFiltering
        applyWatchFiltering = if state.filterWatched
          then filter $ isNothing <<< findWatched
          else id
        applySearchFiltering = case state.search of
            "" -> id
            x -> filter $ \(Path path) -> contains (Pattern $ toLower x) (toLower path)
        applySorting
          | Sorting col dir <- state.sorting
          , rev <- if dir == ASC
            then id
            else reverse
          , sort' <- case col of
            Title -> sort
            Status -> sortWith findWatched
          = rev <<< sort'
          | otherwise = id
        findWatched path = find (\(WatchedData fd) -> fd.path == path) state.watched
        file path =
          HH.div
            [ HP.class_ $ Styles.file ]
            [ HH.span
              [ HP.class_ $ Styles.dot
              , style do
                case extractNameKinda path of
                  Right name ->
                    backgroundImage (url $ "icons/" <> encodeURIComponent name)
                  Left e -> pure mempty
                -- borderColor $ fromMaybe (rgb 255 105 180) dotColor
              ] []
            , HH.a
              [ HP.class_ Styles.fileLink
              , HE.onClick $ HE.input_ (OpenFile path) ]
              [ HH.text $ unwrap path ]
            , HH.button
              [ HP.classes $
                [ Styles.fileButton
                , wrap "pure-button"
                , wrap $ maybe "" (const "pure-button-primary") watched
                ]
              , HE.onClick $ HE.input_ (SetWatched path (not $ isJust watched))
              ]
              [ HH.text $ maybe "not watched" (const "watched") watched ]
            , HH.span
              [ HP.class_ $ Styles.fileNote ]
              [ HH.text $ maybe "" id watched ]
            , HH.button
              [ HP.classes $
                [ Styles.filterLink
                , wrap "pure-button"
                ]
              , HE.onClick $ HE.input_ (Filter path)
              ]
              [ HH.text "set filter" ]
            , HH.button
              [ HP.classes $
                [ Styles.deleteLink
                , wrap "pure-button"
                , if deleteConfirmation
                    then Styles.deleteConfirmation
                    else wrap ""
                ]
              , HE.onClick $ HE.input_ $
                  if deleteConfirmation
                    then (Delete path)
                    else (ConfirmDeletion path)
              ]
              [ HH.text
                  if deleteConfirmation
                    then "Confirm"
                    else "Delete"
              ]
            ]
          where
            watched = getDate <$> findWatched path
            deleteConfirmation = member path state.deleteConfirmations
            getDate (WatchedData {created}) =
              -- parsing date is UTZ dependent (ergo effectful), but in our case, we really don't care
              JSDate.toDateString <<< unsafePerformEff <<< JSDate.parse $ created

    error' = H.liftEff <<< error

    eval :: Query ~> H.ParentDSL State Query Chart.Query Slot Void (AppEffects eff)
    eval (Init next) = do
      eval (FetchData next)

    eval (FetchData next) = do
      getResult >>= unV'
        \(Tuple f w) -> do
          H.modify _ {files = f, watched = w}
      pure next
      where
        getResult = do
          files <- get files
          watched <- get watched
          pure $ Tuple <$> files <*> watched

    eval (GetIcons next) = do
      _ <- post getIcons $ GetIconsRequest {}
      pure next

    eval (OpenFile path next) = do
      _ <- post open $ OpenRequest {path}
      pure next

    eval (SetWatched path flag next) = do
      post update (FileData {path, watched: flag})
        >>= unV' \w -> H.modify _ {watched = w}
      pure next

    eval (Filter path next) = do
      case extractNameKinda path of
        Left e -> error' e *> pure next
        Right s -> eval $ Search s next

    eval (Search str next) = do
      H.modify _ {search = str}
      pure next

    eval (ClearSearch next) = do
      H.modify _ {search = ""}
      pure next

    eval (ChangeSorting col next)= do
      H.modify $ \s -> case s.sorting of
        Sorting curr dir | curr == col ->
          s {sorting = case dir of
              ASC -> Sorting col DSC
              DSC -> NoSorting
            }
        _ -> s {sorting = Sorting col ASC}
      pure next

    eval (ToggleFilterWatched flag next) = do
      H.modify _ {filterWatched = flag}
      pure next

    eval (ConfirmDeletion path next) = do
      H.modify \s -> s {deleteConfirmations = insert path s.deleteConfirmations}
      pure next

    eval (Delete path next) = do
      _ <- post remove $ RemoveRequest {path}
      eval (FetchData next)

main :: forall e.
  Eff
    ( avar :: AVAR
    , ref :: REF
    , exception :: EXCEPTION
    , dom :: DOM
    , console :: CONSOLE
    , ajax :: AJAX
    , now :: NOW
    , echarts :: ET.ECHARTS
    | e
    )
    Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  io <- D.runUI ui unit body

  log "Running"


removed question comment from routing

removed question comment from routing

{-
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.Workspace.Routing
  ( routing
  , Routes(..)
  , mkWorkspaceHash
  , mkWorkspaceURL
  , varMapsForURL
  , getPath
  , getURLVarMaps
  ) where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Foldable as F
import Data.List as L
import Data.Map as Map
import Data.Maybe as M
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String.Regex as R
import Data.String.Regex.Flags as RXF
import Data.StrMap as SM

import Global (encodeURIComponent)

import Routing.Match (Match)
import Routing.Match (eitherMatch, list) as Match
import Routing.Match.Class (lit, str, param) as Match

import SlamData.Config as Config
import SlamData.Workspace.AccessType (AccessType(..))
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.Deck.DeckId as DID

import SqlSquare as Sql

import Utils.Path as UP

data Routes
  = WorkspaceRoute
      UP.DirPath
      (L.List DID.DeckId)
      WA.Action
      (SM.StrMap Port.URLVarMap)

getPath ∷ Routes → UP.DirPath
getPath (WorkspaceRoute p _ _ _) = p

getURLVarMaps ∷ Routes → SM.StrMap Port.URLVarMap
getURLVarMaps (WorkspaceRoute _ _ _ vm) = vm

routing ∷ Match Routes
routing
  = WorkspaceRoute <$> workspace <*> deckIds <*> action <*> optionalVarMap

  where
  optionalVarMap ∷ Match (SM.StrMap Port.URLVarMap)
  optionalVarMap = varMap <|> pure SM.empty

  varMap ∷ Match (SM.StrMap Port.URLVarMap)
  varMap = Match.eitherMatch $ decodeVarMaps <$> Match.param "vars"

  oneSlash ∷ Match Unit
  oneSlash = Match.lit ""

  explored ∷ Match UP.FilePath
  explored = Match.eitherMatch $ mkResource <$> Match.list Match.str

  mkResource ∷ L.List String → Either String UP.FilePath
  mkResource parts =
    case L.last parts of
      Just filename | filename /= "" →
        let dirParts = unsafePartial M.fromJust (L.init parts)
            filePart = P.file filename
            path = foldr (\part acc → P.dir part </> acc) filePart dirParts
        in Right $ P.rootDir </> path
      _ → Left "Expected non-empty explore path"

  workspace ∷ Match UP.DirPath
  workspace = workspaceFromParts <$> partsAndName

  workspaceFromParts ∷ Tuple (L.List String) String → UP.DirPath
  workspaceFromParts (Tuple ps nm) =
    foldl (</>) P.rootDir (map P.dir ps) </> P.dir nm

  partsAndName ∷ Match (Tuple (L.List String) String)
  partsAndName = Tuple <$> (oneSlash *> Match.list notName) <*> name

  name ∷ Match String
  name = Match.eitherMatch $ map workspaceName Match.str

  notName ∷ Match String
  notName = Match.eitherMatch $ map pathPart Match.str

  workspaceName ∷ String → Either String String
  workspaceName input
    | checkExtension input = Right input
    | otherwise = Left input

  pathPart ∷ String → Either String String
  pathPart input
    | input == "" || checkExtension input = Left "incorrect path part"
    | otherwise = Right input

  extensionRegex ∷ R.Regex
  extensionRegex =
    unsafePartial fromRight $
      R.regex ("\\." <> Config.workspaceExtension <> "$") RXF.noFlags

  checkExtension ∷ String → Boolean
  checkExtension = R.test extensionRegex

  deckIds ∷ Match (L.List DID.DeckId)
  deckIds = L.reverse <$> Match.list (Match.eitherMatch (DID.fromString' <$> Match.str))

  action ∷ Match WA.Action
  action
      = (WA.Exploring <$> (Match.lit "exploring" *> explored))
    <|> (Match.eitherMatch $ map WA.parseAction Match.str)
    <|> pure (WA.Load ReadOnly)

-- TODO: it would be nice if `purescript-routing` had a way to render a route
-- from a matcher, so that we could do away with the following brittle functions.

mkWorkspaceURL
  ∷ UP.DirPath    -- workspace path
  → WA.Action     -- workspace action
  → String
mkWorkspaceURL path action =
  Config.workspaceUrl
    <> mkWorkspaceHash path action SM.empty

mkWorkspaceHash
  ∷ UP.DirPath -- workspace path
  → WA.Action -- workspace action
  → SM.StrMap Port.URLVarMap -- varmaps introduced by variables cards in the workspace
  → String
mkWorkspaceHash path action varMap =
  "#"
    <> UP.encodeURIPath (P.printPath path)
    <> WA.printAction action
    <> maybe "" ("/" <> _) (renderVarMapQueryString varMap)

varMapsForURL ∷ Map.Map CID.CardId Port.VarMap → SM.StrMap Port.URLVarMap
varMapsForURL =
  SM.fromFoldable
  ∘ map (bimap CID.toString (map $ Sql.print ∘ unwrap))
  ∘ Map.toList

decodeVarMaps ∷ String → Either String (SM.StrMap Port.URLVarMap)
decodeVarMaps = J.jsonParser >=> J.decodeJson

renderVarMapQueryString ∷ SM.StrMap Port.URLVarMap → Maybe String
renderVarMapQueryString varMaps
  | F.all SM.isEmpty varMaps = Nothing
  | otherwise =
      let json = J.encodeJson varMaps
      in Just $ "?vars=" <> encodeURIComponent (show json)

{-
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.Workspace.Routing
  ( routing
  , Routes(..)
  , mkWorkspaceHash
  , mkWorkspaceURL
  , varMapsForURL
  , getPath
  , getURLVarMaps
  ) where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Foldable as F
import Data.List as L
import Data.Map as Map
import Data.Maybe as M
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String.Regex as R
import Data.String.Regex.Flags as RXF
import Data.StrMap as SM

import Global (encodeURIComponent)

import Routing.Match (Match)
import Routing.Match (eitherMatch, list) as Match
import Routing.Match.Class (lit, str, param) as Match

import SlamData.Config as Config
import SlamData.Workspace.AccessType (AccessType(..))
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.Deck.DeckId as DID

import SqlSquare as Sql

import Utils.Path as UP

data Routes
  = WorkspaceRoute
      UP.DirPath
      (L.List DID.DeckId)
      WA.Action
      (SM.StrMap Port.URLVarMap)

getPath ∷ Routes → UP.DirPath
getPath (WorkspaceRoute p _ _ _) = p

getURLVarMaps ∷ Routes → SM.StrMap Port.URLVarMap
getURLVarMaps (WorkspaceRoute _ _ _ vm) = vm

routing ∷ Match Routes
routing
  = WorkspaceRoute <$> workspace <*> deckIds <*> action <*> optionalVarMap

  where
  optionalVarMap ∷ Match (SM.StrMap Port.URLVarMap)
  optionalVarMap = varMap <|> pure SM.empty

  varMap ∷ Match (SM.StrMap Port.URLVarMap)
  varMap = Match.eitherMatch $ decodeVarMaps <$> Match.param "vars"

  oneSlash ∷ Match Unit
  oneSlash = Match.lit ""

  explored ∷ Match UP.FilePath
  explored = Match.eitherMatch $ mkResource <$> Match.list Match.str

  mkResource ∷ L.List String → Either String UP.FilePath
  mkResource parts =
    case L.last parts of
      Just filename | filename /= "" →
        let dirParts = unsafePartial M.fromJust (L.init parts)
            filePart = P.file filename
            path = foldr (\part acc → P.dir part </> acc) filePart dirParts
        in Right $ P.rootDir </> path
      _ → Left "Expected non-empty explore path"

  workspace ∷ Match UP.DirPath
  workspace = workspaceFromParts <$> partsAndName

  workspaceFromParts ∷ Tuple (L.List String) String → UP.DirPath
  workspaceFromParts (Tuple ps nm) =
    foldl (</>) P.rootDir (map P.dir ps) </> P.dir nm

  partsAndName ∷ Match (Tuple (L.List String) String)
  partsAndName = Tuple <$> (oneSlash *> Match.list notName) <*> name

  name ∷ Match String
  name = Match.eitherMatch $ map workspaceName Match.str

  notName ∷ Match String
  notName = Match.eitherMatch $ map pathPart Match.str

  workspaceName ∷ String → Either String String
  workspaceName input
    | checkExtension input = Right input
    | otherwise = Left input

  pathPart ∷ String → Either String String
  pathPart input
    | input == "" || checkExtension input = Left "incorrect path part"
    | otherwise = Right input

  extensionRegex ∷ R.Regex
  extensionRegex =
    unsafePartial fromRight $
      R.regex ("\\." <> Config.workspaceExtension <> "$") RXF.noFlags

  checkExtension ∷ String → Boolean
  checkExtension = R.test extensionRegex

  deckIds ∷ Match (L.List DID.DeckId)
  deckIds = L.reverse <$> Match.list (Match.eitherMatch (DID.fromString' <$> Match.str))

  action ∷ Match WA.Action
  action
      = (WA.Exploring <$> (Match.lit "exploring" *> explored))
    <|> (Match.eitherMatch $ map WA.parseAction Match.str)
    <|> pure (WA.Load ReadOnly)

-- TODO: it would be nice if `purescript-routing` had a way to render a route
-- from a matcher, so that we could do away with the following brittle functions.

mkWorkspaceURL
  ∷ UP.DirPath    -- workspace path
  → WA.Action     -- workspace action
  → String
mkWorkspaceURL path action =
  Config.workspaceUrl
    <> mkWorkspaceHash path action SM.empty

mkWorkspaceHash
  ∷ UP.DirPath -- workspace path
  → WA.Action -- workspace action
  → SM.StrMap Port.URLVarMap -- varmaps introduced by variables cards in the workspace
  → String
mkWorkspaceHash path action varMap =
  "#"
    <> UP.encodeURIPath (P.printPath path)
    <> WA.printAction action
    <> maybe "" ("/" <> _) (renderVarMapQueryString varMap)

varMapsForURL ∷ Map.Map CID.CardId Port.VarMap → SM.StrMap Port.URLVarMap
varMapsForURL =
  SM.fromFoldable
  -- I'm not very sure why there was stripping of backtics, just removed it @cryogenian
  ∘ map (bimap CID.toString (map $ Sql.print ∘ unwrap))
  ∘ Map.toList

decodeVarMaps ∷ String → Either String (SM.StrMap Port.URLVarMap)
decodeVarMaps = J.jsonParser >=> J.decodeJson

renderVarMapQueryString ∷ SM.StrMap Port.URLVarMap → Maybe String
renderVarMapQueryString varMaps
  | F.all SM.isEmpty varMaps = Nothing
  | otherwise =
      let json = J.encodeJson varMaps
      in Just $ "?vars=" <> encodeURIComponent (show json)


Update constraint for PS 0.11

Update constraint for PS 0.11

module Data.Foldable
  ( class Foldable, foldr, foldl, foldMap
  , foldrDefault, foldlDefault, foldMapDefaultL, foldMapDefaultR
  , fold
  , traverse_
  , for_
  , sequence_
  , oneOf
  , intercalate
  , and
  , or
  , all
  , any
  , sum
  , product
  , elem
  , notElem
  , find
  , findMap
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  , null
  , length
  ) where

import Prelude

import Control.Plus (class Plus, alt, empty)

import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Endo (Endo(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Newtype (alaF, unwrap)

-- | `Foldable` represents data structures which can be _folded_.
-- |
-- | - `foldr` folds a structure from the right
-- | - `foldl` folds a structure from the left
-- | - `foldMap` folds a structure by accumulating values in a `Monoid`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrDefault`
-- | - `foldlDefault`
-- | - `foldMapDefaultR`
-- | - `foldMapDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. Monoid m => (a -> m) -> f a -> m

-- | A default implementation of `foldr` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultR`.
foldrDefault
  :: forall f a b
   . Foldable f
  => (a -> b -> b)
  -> b
  -> f a
  -> b
foldrDefault c u xs = unwrap (foldMap (Endo <<< c) xs) u

-- | A default implementation of `foldl` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultL`.
foldlDefault
  :: forall f a b
   . Foldable f
  => (b -> a -> b)
  -> b
  -> f a
  -> b
foldlDefault c u xs = unwrap (unwrap (foldMap (Dual <<< Endo <<< flip c) xs)) u

-- | A default implementation of `foldMap` using `foldr`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldrDefault`.
foldMapDefaultR
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultR f = foldr (\x acc -> f x <> acc) mempty

-- | A default implementation of `foldMap` using `foldl`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldlDefault`.
foldMapDefaultL
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultL f = foldl (\acc x -> f x <> acc) mempty

instance foldableArray :: Foldable Array where
  foldr = foldrArray
  foldl = foldlArray
  foldMap = foldMapDefaultR

foreign import foldrArray :: forall a b. (a -> b -> b) -> b -> Array a -> b
foreign import foldlArray :: forall a b. (b -> a -> b) -> b -> Array a -> b

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z
  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x
  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableFirst :: Foldable First where
  foldr f z (First x) = foldr f z x
  foldl f z (First x) = foldl f z x
  foldMap f (First x) = foldMap f x

instance foldableLast :: Foldable Last where
  foldr f z (Last x) = foldr f z x
  foldl f z (Last x) = foldl f z x
  foldMap f (Last x) = foldMap f x

instance foldableAdditive :: Foldable Additive where
  foldr f z (Additive x) = x `f` z
  foldl f z (Additive x) = z `f` x
  foldMap f (Additive x) = f x

instance foldableDual :: Foldable Dual where
  foldr f z (Dual x) = x `f` z
  foldl f z (Dual x) = z `f` x
  foldMap f (Dual x) = f x

instance foldableDisj :: Foldable Disj where
  foldr f z (Disj x) = f x z
  foldl f z (Disj x) = f z x
  foldMap f (Disj x) = f x

instance foldableConj :: Foldable Conj where
  foldr f z (Conj x) = f x z
  foldl f z (Conj x) = f z x
  foldMap f (Conj x) = f x

instance foldableMultiplicative :: Foldable Multiplicative where
  foldr f z (Multiplicative x) = x `f` z
  foldl f z (Multiplicative x) = z `f` x
  foldMap f (Multiplicative x) = f x

-- | Fold a data structure, accumulating values in some `Monoid`.
fold :: forall f m. Foldable f => Monoid m => f m -> m
fold = foldMap id

-- | Traverse a data structure, performing some effects encoded by an
-- | `Applicative` functor at each value, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | traverse_ print [1, 2, 3]
-- | ```
traverse_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => (a -> m b)
  -> f a
  -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

-- | A version of `traverse_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for_ [1, 2, 3] \n -> do
-- |   print n
-- |   trace "squared is"
-- |   print (n * n)
-- | ```
for_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => f a
  -> (a -> m b)
  -> m Unit
for_ = flip traverse_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable` instance, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | sequence_ [ trace "Hello, ", trace " world!" ]
-- | ```
sequence_ :: forall a f m. Applicative m => Foldable f => f (m a) -> m Unit
sequence_ = traverse_ id

-- | Combines a collection of elements using the `Alt` operation.
oneOf :: forall f g a. Foldable f => Plus g => f (g a) -> g a
oneOf = foldr alt empty

-- | Fold a data structure, accumulating values in some `Monoid`,
-- | combining adjacent elements using the specified separator.
intercalate :: forall f m. Foldable f => Monoid m => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init: true } x = { init: false, acc: x }
  go { acc: acc }   x = { init: false, acc: acc <> sep <> x }

-- | The conjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether all of the values in a data
-- | structure are `true`.
and :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
and = all id

-- | The disjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether any of the values in a data
-- | structure is `true`.
or :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
or = any id

-- | `all f` is the same as `and <<< map f`; map a function over the structure,
-- | and then get the conjunction of the results.
all :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
all  = alaF Conj foldMap

-- | `any f` is the same as `or <<< map f`; map a function over the structure,
-- | and then get the disjunction of the results.
any :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
any = alaF Disj foldMap

-- | Find the sum of the numeric values in a data structure.
sum :: forall a f. Foldable f => Semiring a => f a -> a
sum = foldl (+) zero

-- | Find the product of the numeric values in a data structure.
product :: forall a f. Foldable f => Semiring a => f a -> a
product = foldl (*) one

-- | Test whether a value is an element of a data structure.
elem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
elem = any <<< (==)

-- | Test whether a value is not an element of a data structure.
notElem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
notElem x = not <<< elem x

-- | Try to find an element in a data structure which satisfies a predicate.
find :: forall a f. Foldable f => (a -> Boolean) -> f a -> Maybe a
find p = foldl go Nothing
  where
  go Nothing x | p x = Just x
  go r _ = r

-- | Try to find an element in a data structure which satisfies a predicate mapping.
findMap :: forall a b f. Foldable f => (a -> Maybe b) -> f a -> Maybe b
findMap p = foldl go Nothing
  where
  go Nothing x = p x
  go r _ = r

-- | Find the largest element of a structure, according to its `Ord` instance.
maximum :: forall a f. Ord a => Foldable f => f a -> Maybe a
maximum = maximumBy compare

-- | Find the largest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
maximumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
maximumBy cmp = foldl max' Nothing
  where
  max' Nothing x  = Just x
  max' (Just x) y = Just (if cmp x y == GT then x else y)

-- | Find the smallest element of a structure, according to its `Ord` instance.
minimum :: forall a f. Ord a => Foldable f => f a -> Maybe a
minimum = minimumBy compare

-- | Find the smallest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
minimumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
minimumBy cmp = foldl min' Nothing
  where
  min' Nothing x  = Just x
  min' (Just x) y = Just (if cmp x y == LT then x else y)

-- | Test whether the structure is empty.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
null :: forall a f. Foldable f => f a -> Boolean
null = foldr (\_ _ -> false) true

-- | Returns the size/length of a finite structure.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
length :: forall a b f. Foldable f => Semiring b => f a -> b
length = foldl (\c _ -> add one c) zero

module Data.Foldable
  ( class Foldable, foldr, foldl, foldMap
  , foldrDefault, foldlDefault, foldMapDefaultL, foldMapDefaultR
  , fold
  , traverse_
  , for_
  , sequence_
  , oneOf
  , intercalate
  , and
  , or
  , all
  , any
  , sum
  , product
  , elem
  , notElem
  , find
  , findMap
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  , null
  , length
  ) where

import Prelude

import Control.Plus (class Plus, alt, empty)

import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Endo (Endo(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Newtype (alaF, unwrap)

-- | `Foldable` represents data structures which can be _folded_.
-- |
-- | - `foldr` folds a structure from the right
-- | - `foldl` folds a structure from the left
-- | - `foldMap` folds a structure by accumulating values in a `Monoid`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrDefault`
-- | - `foldlDefault`
-- | - `foldMapDefaultR`
-- | - `foldMapDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. Monoid m => (a -> m) -> f a -> m

-- | A default implementation of `foldr` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultR`.
foldrDefault
  :: forall f a b
   . Foldable f
  => (a -> b -> b)
  -> b
  -> f a
  -> b
foldrDefault c u xs = unwrap (foldMap (Endo <<< c) xs) u

-- | A default implementation of `foldl` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultL`.
foldlDefault
  :: forall f a b
   . Foldable f
  => (b -> a -> b)
  -> b
  -> f a
  -> b
foldlDefault c u xs = unwrap (unwrap (foldMap (Dual <<< Endo <<< flip c) xs)) u

-- | A default implementation of `foldMap` using `foldr`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldrDefault`.
foldMapDefaultR
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultR f = foldr (\x acc -> f x <> acc) mempty

-- | A default implementation of `foldMap` using `foldl`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldlDefault`.
foldMapDefaultL
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultL f = foldl (\acc x -> f x <> acc) mempty

instance foldableArray :: Foldable Array where
  foldr = foldrArray
  foldl = foldlArray
  foldMap = foldMapDefaultR

foreign import foldrArray :: forall a b. (a -> b -> b) -> b -> Array a -> b
foreign import foldlArray :: forall a b. (b -> a -> b) -> b -> Array a -> b

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z
  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x
  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableFirst :: Foldable First where
  foldr f z (First x) = foldr f z x
  foldl f z (First x) = foldl f z x
  foldMap f (First x) = foldMap f x

instance foldableLast :: Foldable Last where
  foldr f z (Last x) = foldr f z x
  foldl f z (Last x) = foldl f z x
  foldMap f (Last x) = foldMap f x

instance foldableAdditive :: Foldable Additive where
  foldr f z (Additive x) = x `f` z
  foldl f z (Additive x) = z `f` x
  foldMap f (Additive x) = f x

instance foldableDual :: Foldable Dual where
  foldr f z (Dual x) = x `f` z
  foldl f z (Dual x) = z `f` x
  foldMap f (Dual x) = f x

instance foldableDisj :: Foldable Disj where
  foldr f z (Disj x) = f x z
  foldl f z (Disj x) = f z x
  foldMap f (Disj x) = f x

instance foldableConj :: Foldable Conj where
  foldr f z (Conj x) = f x z
  foldl f z (Conj x) = f z x
  foldMap f (Conj x) = f x

instance foldableMultiplicative :: Foldable Multiplicative where
  foldr f z (Multiplicative x) = x `f` z
  foldl f z (Multiplicative x) = z `f` x
  foldMap f (Multiplicative x) = f x

-- | Fold a data structure, accumulating values in some `Monoid`.
fold :: forall f m. Foldable f => Monoid m => f m -> m
fold = foldMap id

-- | Traverse a data structure, performing some effects encoded by an
-- | `Applicative` functor at each value, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | traverse_ print [1, 2, 3]
-- | ```
traverse_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => (a -> m b)
  -> f a
  -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

-- | A version of `traverse_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for_ [1, 2, 3] \n -> do
-- |   print n
-- |   trace "squared is"
-- |   print (n * n)
-- | ```
for_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => f a
  -> (a -> m b)
  -> m Unit
for_ = flip traverse_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable` instance, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | sequence_ [ trace "Hello, ", trace " world!" ]
-- | ```
sequence_ :: forall a f m. Applicative m => Foldable f => f (m a) -> m Unit
sequence_ = traverse_ id

-- | Combines a collection of elements using the `Alt` operation.
oneOf :: forall f g a. Foldable f => Plus g => f (g a) -> g a
oneOf = foldr alt empty

-- | Fold a data structure, accumulating values in some `Monoid`,
-- | combining adjacent elements using the specified separator.
intercalate :: forall f m. Foldable f => Monoid m => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init: true } x = { init: false, acc: x }
  go { acc: acc }   x = { init: false, acc: acc <> sep <> x }

-- | The conjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether all of the values in a data
-- | structure are `true`.
and :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
and = all id

-- | The disjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether any of the values in a data
-- | structure is `true`.
or :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
or = any id

-- | `all f` is the same as `and <<< map f`; map a function over the structure,
-- | and then get the conjunction of the results.
all :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
all  = alaF Conj foldMap

-- | `any f` is the same as `or <<< map f`; map a function over the structure,
-- | and then get the disjunction of the results.
any :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
any = alaF Disj foldMap

-- | Find the sum of the numeric values in a data structure.
sum :: forall a f. Foldable f => Semiring a => f a -> a
sum = foldl (+) zero

-- | Find the product of the numeric values in a data structure.
product :: forall a f. Foldable f => Semiring a => f a -> a
product = foldl (*) one

-- | Test whether a value is an element of a data structure.
elem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
elem = any <<< (==)

-- | Test whether a value is not an element of a data structure.
notElem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
notElem x = not <<< elem x

-- | Try to find an element in a data structure which satisfies a predicate.
find :: forall a f. Foldable f => (a -> Boolean) -> f a -> Maybe a
find p = foldl go Nothing
  where
  go Nothing x | p x = Just x
  go r _ = r

-- | Try to find an element in a data structure which satisfies a predicate mapping.
findMap :: forall a b f. Foldable f => (a -> Maybe b) -> f a -> Maybe b
findMap p = foldl go Nothing
  where
  go Nothing x = p x
  go r _ = r

-- | Find the largest element of a structure, according to its `Ord` instance.
maximum :: forall a f. Ord a => Foldable f => f a -> Maybe a
maximum = maximumBy compare

-- | Find the largest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
maximumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
maximumBy cmp = foldl max' Nothing
  where
  max' Nothing x  = Just x
  max' (Just x) y = Just (if cmp x y == GT then x else y)

-- | Find the smallest element of a structure, according to its `Ord` instance.
minimum :: forall a f. Ord a => Foldable f => f a -> Maybe a
minimum = minimumBy compare

-- | Find the smallest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
minimumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
minimumBy cmp = foldl min' Nothing
  where
  min' Nothing x  = Just x
  min' (Just x) y = Just (if cmp x y == LT then x else y)

-- | Test whether the structure is empty.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
null :: forall a f. Foldable f => f a -> Boolean
null = foldr (\_ _ -> false) true

-- | Returns the size/length of a finite structure.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
length :: forall a b f. (Foldable f, Semiring b) => f a -> b
length = foldl (\c _ -> add one c) zero