Fix #374

Fix #374

module Prelude where

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

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

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

  infixr 9 >>>
  infixr 9 <<<

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

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

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

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

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

  infixr 0 $
  infixl 0 #

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

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

  infixr 6 :

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

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

  class Show a where
    show :: a -> String

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

  instance showString :: Show String where
    show = showStringImpl

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

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

  instance showNumber :: Show Number where
    show = showNumberImpl

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

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

  infixl 4 <$>

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

  infixl 4 <*>

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

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

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

  infixl 3 <|>

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

  infixl 1 >>=

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

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

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

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

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

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

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

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

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

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

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

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

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

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

  infix 4 ==
  infix 4 /=

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

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

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

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

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

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

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

  data Ordering = LT | GT | EQ

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

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

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

  infixl 4 <

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

  infixl 4 >

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

  infixl 4 <=

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

  infixl 4 >=

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

  foreign import numCompare
    "function numCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? module.LT : n1 > n2 ? module.GT : module.EQ;\
    \  };\
    \}" :: Number -> Number -> Ordering

  instance ordNumber :: Ord Number where
    compare = numCompare

  infixl 10 &
  infixl 10 |
  infixl 10 ^

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

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

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

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

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

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

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

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

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

  infixr 2 ||
  infixr 3 &&

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

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

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

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

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

  infixr 5 <>

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

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

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

  infixr 5 ++

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

module Data.Function where

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

module Data.Eq where

  data Ref a = Ref a

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

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

module Prelude.Unsafe where

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

module Control.Monad.Eff where

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

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

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

  type Pure a = forall e. Eff e a

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

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

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

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

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

  instance monadEff :: Monad (Eff e)

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

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

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

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

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

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

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

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

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

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

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

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

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

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

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

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

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

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

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

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

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

module Prelude where

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

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

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

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

  infixr 9 >>>
  infixr 9 <<<

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

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

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

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

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

  infixr 0 $
  infixl 0 #

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

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

  infixr 6 :

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

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

  class Show a where
    show :: a -> String

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

  instance showString :: Show String where
    show = showStringImpl

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

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

  instance showNumber :: Show Number where
    show = showNumberImpl

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

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

  infixl 4 <$>

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

  infixl 4 <*>

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

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

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

  infixl 3 <|>

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

  infixl 1 >>=

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

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

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

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

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

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

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

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

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

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

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

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

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

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

  infix 4 ==
  infix 4 /=

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

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

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

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

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

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

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

  data Ordering = LT | GT | EQ

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

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

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

  infixl 4 <

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

  infixl 4 >

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

  infixl 4 <=

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

  infixl 4 >=

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

  foreign import numCompare
    "function numCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? module.LT : n1 > n2 ? module.GT : module.EQ;\
    \  };\
    \}" :: Number -> Number -> Ordering

  instance ordNumber :: Ord Number where
    compare = numCompare

  infixl 10 &
  infixl 10 |
  infixl 10 ^

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

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

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

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

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

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

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

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

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

  infixr 2 ||
  infixr 3 &&

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

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

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

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

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

  infixr 5 <>

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

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

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

  infixr 5 ++

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

module Data.Eq where

  data Ref a = Ref a

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

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

module Prelude.Unsafe where

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

module Control.Monad.Eff where

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

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

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

  type Pure a = forall e. Eff e a

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

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

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

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

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

  instance monadEff :: Monad (Eff e)

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

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

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

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

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

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

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

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

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

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

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

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

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

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

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

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

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

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

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

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

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


get rid of ugly nesting

get rid of ugly nesting

module GetIcons where

import Prelude

import Control.Bind (bindFlipped)
import Control.Monad.Aff (Aff, launchAff, makeAff)
import Control.Monad.Aff.Console (error, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception as Exc
import Control.Monad.Except (runExcept)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), either)
import Data.List (find, (:))
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Data.Set (Set, fromFoldable, member)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import FrontEnd (extractNameKinda)
import Global (encodeURIComponent)
import Global.Unsafe (unsafeStringify)
import LenientHtmlParser (Attribute(..), Name(..), Tag(..), TagName(..), Value(..), parseTags)
import Network.HTTP.Affjax (get)
import Node.ChildProcess (defaultSpawnOptions, onClose, onError, spawn)
import Node.Encoding (Encoding(..))
import Node.FS.Aff (readTextFile, readdir)
import Node.Process (lookupEnv)
import Simple.JSON (readJSON)
import Types (Path(..))

type Config =
  { queryUrl :: String
  }

readConfig :: Aff _ (Either _ Config)
readConfig = do
  contents <- readTextFile UTF8 "./icons-config.json"
  pure $ runExcept $ readJSON contents

iconsPath :: String
iconsPath = "./dist/icons"

curl :: forall e.
  String
  -> String
  -> Aff
      _
      Unit
curl url path = do
  cp <- liftEff $ spawn "curl" [url, "-o", path] defaultSpawnOptions
  makeAff \e s -> do
    onError cp (e <<< Exc.error <<< unsafeStringify)
    onClose cp (s <<< const unit)

downloadIconIfNotExist :: Config -> Set String -> String -> Aff _ Unit
downloadIconIfNotExist config existing name =
  unless (member name existing) do
    log $ "gonna get " <> name
    html <- _.response <$> get (config.queryUrl <> name)
    case extractFirstImage =<<
      (lmap (append "couldn't get tags " <<< show) (parseTags html)) of
      Right url -> do
        log $ "downloading from " <> url
        curl url (iconsPath <> "/" <> encodeURIComponent name)
        pure unit
      Left e ->
        error e
  where
    matchSrc (Attribute (Name name) _) = name == "src"
    extractFirstImage tags =
      case tags of
        -- $('article > div > div > a > img')
        (TagOpen (TagName "article") _)
          : (TagOpen (TagName "div") _)
          : (TagOpen (TagName "div") _)
          : (TagOpen (TagName "a") _)
          : (TagOpen (TagName "img") attrs)
          : xs
          | Just (Attribute _ (Value src)) <- find matchSrc attrs
          -> Right src
        (_ : xs) -> extractFirstImage xs
        mempty -> Left "couldn't find image???"

main :: Eff _ _
main = launchAff do
  dir <- liftEff $ lookupEnv "FILETRACKER_DIR"
  config <- readConfig

  case Tuple dir config of
    Tuple (Just dir') (Right config') -> do
      names :: Set String <- fromFoldable <$>
        bindFlipped (either (const mempty) pure <<< extractNameKinda <<< Path) <$>
        readdir dir'
      existing <- fromFoldable <$> readdir iconsPath
      for_ names $ downloadIconIfNotExist config' existing
      pure unit
    Tuple Nothing _ -> error "env var not set?"
    Tuple _ (Left e) -> error $ show e

module GetIcons where

import Prelude

import Control.Bind (bindFlipped)
import Control.Monad.Aff (Aff, launchAff, makeAff)
import Control.Monad.Aff.Console (error, log)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception as Exc
import Control.Monad.Except (runExcept)
import Data.Either (Either(..), either)
import Data.List (find, (:))
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Data.Set (Set, fromFoldable, member)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import FrontEnd (extractNameKinda)
import Global (encodeURIComponent)
import Global.Unsafe (unsafeStringify)
import LenientHtmlParser (Attribute(..), Name(..), Tag(..), TagName(..), Value(..), parseTags)
import Network.HTTP.Affjax (get)
import Node.ChildProcess (defaultSpawnOptions, onClose, onError, spawn)
import Node.Encoding (Encoding(..))
import Node.FS.Aff (readTextFile, readdir)
import Node.Process (lookupEnv)
import Simple.JSON (readJSON)
import Types (Path(..))

type Config =
  { queryUrl :: String
  }

readConfig :: Aff _ (Either _ Config)
readConfig = do
  contents <- readTextFile UTF8 "./icons-config.json"
  pure $ runExcept $ readJSON contents

iconsPath :: String
iconsPath = "./dist/icons"

curl :: forall e.
  String
  -> String
  -> Aff
      _
      Unit
curl url path = do
  cp <- liftEff $ spawn "curl" [url, "-o", path] defaultSpawnOptions
  makeAff \e s -> do
    onError cp (e <<< Exc.error <<< unsafeStringify)
    onClose cp (s <<< const unit)

downloadIconIfNotExist :: Config -> Set String -> String -> Aff _ Unit
downloadIconIfNotExist config existing name =
  unless (member name existing) do
    log $ "gonna get " <> name
    html :: String <- _.response <$> get (config.queryUrl <> name)
    case parseTags html of
      Right tags -> do
        case extractFirstImage tags of
          Right imageUrl -> do
            log $ "downloading from " <> imageUrl
            curl imageUrl (iconsPath <> "/" <> encodeURIComponent name)
            pure unit
          Left e ->
            error e
        pure unit
      Left e ->
        error $ "couldn't get tags " <> show e
  where
    matchSrc (Attribute (Name name) _) = name == "src"
    extractFirstImage tags =
      case tags of
        -- $('article > div > div > a > img')
        (TagOpen (TagName "article") _)
          : (TagOpen (TagName "div") _)
          : (TagOpen (TagName "div") _)
          : (TagOpen (TagName "a") _)
          : (TagOpen (TagName "img") attrs)
          : xs
          | Just (Attribute _ (Value src)) <- find matchSrc attrs
          -> Right src
        (_ : xs) -> extractFirstImage xs
        mempty -> Left "couldn't find image???"

main :: Eff _ _
main = launchAff do
  dir <- liftEff $ lookupEnv "FILETRACKER_DIR"
  config <- readConfig

  case Tuple dir config of
    Tuple (Just dir') (Right config') -> do
      names :: Set String <- fromFoldable <$>
        bindFlipped (either (const mempty) pure <<< extractNameKinda <<< Path) <$>
        readdir dir'
      existing <- fromFoldable <$> readdir iconsPath
      for_ names $ downloadIconIfNotExist config' existing
      pure unit
    Tuple Nothing _ -> error "env var not set?"
    Tuple _ (Left e) -> error $ show e


cleaned up Cells.Update a bit

cleaned up Cells.Update a bit

module Cells.State where

import Prelude
import Pux
import Cells.Types
import Cells.Foreign
import Data.Lens
import DOM
import Signal.Channel
import Control.Monad.Eff.Class (liftEff)
import Global.Effects
import Debug.Trace
import Data.Array
import Data.Maybe

initialState :: Channel Action -> State
initialState chan =
    { currentCell   : 0
    , cells         : [] :: Array Cell
    , editorChanges : chan
    }

addCodeCell :: State -> State
addCodeCell s = insertAtEnd (newCodeCell $ totalCells s) s

addTextCell :: State -> State
addTextCell s = insertAtEnd (newTextCell $ totalCells s) s

saveContent :: CellId -> String -> State -> State
saveContent cId newContent s = s { cells = map updateCell s.cells }
  where
    isCorrectCell (Cell c) = c.cellId == cId
    updateCell (Cell c) =
        if isCorrectCell (Cell c)
            then Cell c { cellContent = newContent }
            else Cell c

update :: Update State Action GlobalEffects
update AddCodeCell s =
    { state : newState
    , effects : [ pure $ RenderCodeCell ( totalCells s) ]
    }
  where
    newState = addCodeCell s

update AddTextCell s =
    { state : newState
    , effects : [ pure $ RenderTextCell $ totalCells s ]
    }
  where
    newState = addTextCell s

update (RenderCodeCell i) s =
    s `onlyEffects`
    [ liftEff
      $ makeCodeEditor s.editorChanges i
    ]

update (RenderTextCell i) s =
    s `onlyEffects`
    [ liftEff
      $ makeTextEditor s.editorChanges i
    ]

update RenderAllCells s =
  {state : s, effects: map render s.cells}
  where
    render cell = case cell of
      Cell {cellType : TextCell, cellId : i, cellContent : _ } ->
        liftEff $ makeTextEditor s.editorChanges i
      Cell {cellType : CodeCell, cellId : i, cellContent : _} ->
        liftEff $ makeCodeEditor s.editorChanges i

update (SaveContent cId newContent) s =
    noEffects
    $ saveContent cId (spy newContent) s

update (RemoveCell cId) s =
    noEffects
    $ removeCell cId s

update (SetCurrentCell cId) s =
    noEffects
    $ s { currentCell = cId }

update NoOp s =
    noEffects
    $ s

module Cells.State where

import Prelude
import Pux
import Cells.Types
import Cells.Foreign
import Data.Lens
import DOM
import Signal.Channel
import Control.Monad.Eff.Class (liftEff)
import Global.Effects
import Debug.Trace
import Data.Array
import Data.Maybe

initialState :: Channel Action -> State
initialState chan =
    { currentCell   : 0
    , cells         : [] :: Array Cell
    , editorChanges : chan
    }

addCodeCell :: State -> State
addCodeCell s = insertAtEnd (newCodeCell $ totalCells s) s

addTextCell :: State -> State
addTextCell s = insertAtEnd (newTextCell $ totalCells s) s

saveContent :: CellId -> String -> State -> State
saveContent cId newContent s = s { cells = map updateCell s.cells }
  where
    isCorrectCell (Cell c) = c.cellId == cId
    updateCell (Cell c) =
        if isCorrectCell (Cell c)
            then Cell c { cellContent = newContent }
            else Cell c

update :: Update State Action GlobalEffects
update AddCodeCell s =
    { state : newState
    , effects : [ pure $ RenderCodeCell ( totalCells s) ]
    }
  where
    newState = addCodeCell s

update AddTextCell s =
    { state : newState
    , effects : [ pure $ RenderTextCell $ totalCells s ]
    }
  where
    newState = addTextCell s

update (RenderCodeCell i) s =
    s `onlyEffects`
    [ liftEff
      $ makeCodeEditor s.editorChanges i
    ]

update (RenderTextCell i) s =
    s `onlyEffects`
    [ liftEff
      $ makeTextEditor s.editorChanges i
    ]

update RenderAllCells s =
  map' s.cells []
  where
    render cell = case cell of
      Cell {cellType : TextCell, cellId : i, cellContent : _ } ->
        pure $ liftEff $ makeTextEditor s.editorChanges i
      Cell {cellType : CodeCell, cellId : i, cellContent : _} ->
        pure $ liftEff $ makeCodeEditor s.editorChanges i
    map' cells ef = case uncons cells of
      Just { head: x, tail: xs } -> map' xs (ef <> (render x))
      Nothing -> { state : s, effects : ef }

update (SaveContent cId newContent) s =
    noEffects
    $ saveContent cId (spy newContent) s

update (RemoveCell cId) s =
    noEffects
    $ removeCell cId s

update (SetCurrentCell cId) s =
    noEffects
    $ s { currentCell = cId }

update NoOp s =
    noEffects
    $ s


parse json file or check if its content has brackets in first and last position of trimed content

{-
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.FileSystem.Component
  ( module SlamData.FileSystem.Component.State
  , module SlamData.FileSystem.Component.Query
  , module SlamData.FileSystem.Component.Install
  , comp
  ) where

import Prelude

import Control.Apply ((*>))
import Control.Bind (join, (=<<))
import Control.Monad (when)
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Exception (error, message)
import Control.Monad.Error.Class (throwError)
import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import Data.Array (head, last, mapMaybe, filter)
import Data.Argonaut.Parser (jsonParser)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), either, isRight)
import Data.Foldable (traverse_, for_)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Functor.Coproduct (left, right, coproduct)
import Data.Functor.Coproduct.Nested (coproduct5)
import Data.Functor.Eff (liftEff)
import Data.Lens ((.~))
import Data.Maybe (Maybe(..), fromMaybe, isJust)
import Data.Path.Pathy (rootDir, (</>), dir, file, parentDir)
import Data.String as S
import Data.URI (runParseAbsoluteURI)

import Halogen.Component
import Halogen.Component.ChildPath (ChildPath(), injSlot, prjQuery, injQuery)
import Halogen.Component.Utils (forceRerender')
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.Query (action, request, get, modify, gets)
import Halogen.Themes.Bootstrap3 as B

import Network.HTTP.MimeType.Common (textCSV, applicationJSON)

import Quasar.Aff as API
import Quasar.Auth as Auth

import SlamData.Config as Config
import SlamData.Effects (Slam())
import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Component.Install
import SlamData.FileSystem.Component.Query
import SlamData.FileSystem.Component.Render
import SlamData.FileSystem.Component.State
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Dialog.Download.Component as Download
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as SQL2
import SlamData.FileSystem.Dialog.Rename.Component as Rename
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..), itemResource, itemURL, openItem, sortItem)
import SlamData.FileSystem.Listing.Item.Component as Item
import SlamData.FileSystem.Listing.Sort (notSort)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (newSalt)
import SlamData.FileSystem.Search.Component as Search
import SlamData.Notebook.Action (Action(..), AccessType(..))
import SlamData.Notebook.Routing (mkNotebookURL)
import SlamData.Render.Common
import SlamData.Render.CSS as Rc
import SlamData.SignIn.Component as SignIn

import Utils.DOM as D
import Utils.Path (DirPath(), getNameStr)

comp :: Component StateP QueryP Slam
comp = parentComponent' render eval (peek <<< runChildF)

render :: RenderParent State ChildState Query ChildQuery Slam ChildSlot
render state@{ version, sort, salt, path } =
  H.div
    [ P.classes [ Rc.filesystem ]
    , E.onClick (E.input_ DismissSignInSubmenu)
    ]
    [ navbar
        [ H.div
            [ P.classes [ Rc.header, B.clearfix ] ]
            [ icon B.glyphiconFolderOpen Config.homeHash
            , logo version
            , H.slot' cpSearch unit \_ ->
                { component: Search.comp
                , initialState: Search.initialState sort salt
                }
            , H.slot' cpSignIn unit \_ ->
                { component: SignIn.comp
                , initialState: installedState SignIn.initialState
                }
            ]
        ]
    , content
        [ H.div
            [ P.class_ B.clearfix ]
            [ H.slot' cpBreadcrumbs unit \_ ->
                { component: Breadcrumbs.comp
                , initialState: Breadcrumbs.mkBreadcrumbs path sort salt
                }
            , toolbar state
            ]
        , row [ sorting state ]
        , H.slot' cpListing unit \_ ->
            { component: Listing.comp
            , initialState: installedState Listing.initialState
            }
        ]
    , H.slot' cpDialog unit \_ ->
        { component: Dialog.comp
        , initialState: installedState Dialog.initialState
        }
    ]

eval :: EvalParent Query State ChildState Query ChildQuery Slam ChildSlot
eval (Resort next) = do
  { sort, salt, path } <- get
  searchValue <- query' cpSearch unit (request Search.GetValue)
  liftEff $ setLocation $ browseURL (join searchValue) (notSort sort) salt path
  pure next
eval (SetPath path next) = modify (_path .~ path) *> updateBreadcrumbs $> next
eval (SetSort sort next) = do
  modify (_sort .~ sort)
  updateBreadcrumbs
  resort
  pure next
eval (SetSalt salt next) = modify (_salt .~ salt) *> updateBreadcrumbs $> next
eval (SetIsMount isMount next) = modify (_isMount .~ isMount) $> next
eval (ShowHiddenFiles next) = do
  modify (_showHiddenFiles .~ true)
  queryListing $ action (Listing.SetIsHidden false)
  pure next
eval (HideHiddenFiles next) = do
  modify (_showHiddenFiles .~ false)
  queryListing $ action (Listing.SetIsHidden true)
  pure next
eval (Configure next) = do
  path <- gets _.path
  configure (R.Database path)
  pure next
eval (MakeMount next) = do
  path <- gets _.path
  showDialog (Dialog.Mount path "" Nothing)
  pure next
eval (MakeFolder next) = do
  path <- gets _.path
  dirName <- liftAff $ Auth.authed $ API.getNewName path Config.newFolderName
  let dirPath = path </> dir dirName
      dirRes = R.Directory dirPath
      dirItem = PhantomItem dirRes
      hiddenFile = dirPath </> file (Config.folderMark)
  queryListing $ action (Listing.Add dirItem)
  added <- liftAff $ attempt $
    Auth.authed $ API.makeFile hiddenFile API.ldJSON "{}"
  queryListing $ action (Listing.Filter (/= dirItem))
  case added of
    Left err ->
      showDialog $
        Dialog.Error
          $ "There was a problem creating the directory: "
          <> message err
    Right _ -> do
      void $ queryListing $ action $ Listing.Add (Item dirRes)
  pure next

eval (MakeNotebook next) = do
  path <- gets _.path
  let newNotebookName = Config.newNotebookName <> "." <> Config.notebookExtension
  name <- liftAff $ Auth.authed $ API.getNewName path newNotebookName
  let uri = mkNotebookURL (path </> dir name) New
  liftEff $ setLocation uri
  pure next

eval (UploadFile el next) = do
  mbInput <- liftEff $ D.querySelector "input" el
  for_ mbInput \input ->
    void $ liftEff $ Be.raiseEvent "click" input
  pure next

eval (FileListChanged el next) = do
  fileArr <- map Cf.fileListToArray $ (liftAff $ Cf.files el)
  liftEff $ clearValue el
  case head fileArr of
    Nothing ->
      let err :: Slam Unit
          err = throwError $ error "empty filelist"
      in liftAff err
    Just f -> do
      { path, sort, salt } <- get
      name <- liftAff $ liftEff (Cf.name f)
                >>= Auth.authed <<< API.getNewName path

      reader <- liftEff Cf.newReaderEff
      content <- liftAff $ Cf.readAsBinaryString f reader

      let fileName = path </> file name
          res = R.File fileName
          fileItem = PhantomItem res
          ext = last (S.split "." name)
          mime = if ext == Just "csv"
                 then textCSV
                 else if isApplicationJSON content
                      then applicationJSON
                      else API.ldJSON
      queryListing $ action (Listing.Add fileItem)
      f <- liftAff $ attempt $ Auth.authed $ API.makeFile fileName mime content
      case f of
        Left err -> do
          queryListing $ action $
            Listing.Filter (not <<< eq (R.File fileName) <<< itemResource)
          showDialog $ Dialog.Error (message err)
        Right _ -> liftEff $ openItem res sort salt

  pure next
  where
  isApplicationJSON :: String -> Boolean
  isApplicationJSON content
    -- Parse if content is small enough
    | S.length content < 1048576 =
        isRight $ jsonParser content
    -- Or check if its first/last characters are [/]
    | otherwise =
        let
          trimedContent = S.trim content
        in
             (isJust $ S.stripPrefix "[" trimedContent)
          && (isJust $ S.stripSuffix "]" trimedContent)

eval (Download next) = do
  path <- gets _.path
  download (R.Directory path)
  pure next

eval (SetVersion version next) = modify (_version .~ Just version) $> next
eval (DismissSignInSubmenu next) = dismissSignInSubmenu $> next

peek :: forall a. ChildQuery a -> Algebra Unit
peek =
  coproduct5
    listingPeek
    searchPeek
    (const (pure unit))
    dialogPeek
    (const (pure unit))

listingPeek :: forall a. Listing.QueryP a -> Algebra Unit
listingPeek = coproduct go (itemPeek <<< runChildF)
  where
  go (Listing.Add _ _) = resort
  go (Listing.Adds _ _) = resort
  go _ = pure unit

itemPeek :: forall a. Item.Query a -> Algebra Unit
itemPeek (Item.Open res _) = do
  { sort, salt } <- get
  liftEff $ openItem res sort salt
itemPeek (Item.Configure (R.Mount mount) _) = configure mount
itemPeek (Item.Move res _) = do
  showDialog $ Dialog.Rename res
  flip getDirectories rootDir \x ->
    void $ queryDialog Dialog.cpRename $ action (Rename.AddDirs x)
itemPeek (Item.Remove res _) = do
  mbTrashFolder <- liftAff $ Auth.authed $ API.delete res
  queryListing $ action $ Listing.Filter (not <<< eq res <<< itemResource)
  case mbTrashFolder of
    Nothing -> pure unit
    Just res' -> void $ queryListing $ action $ Listing.Add (Item res')
itemPeek (Item.Share res _) = do
  { sort, salt } <- get
  loc <- liftEff locationString
  let url = loc <> "/" <> itemURL sort salt ReadOnly res
  showDialog (Dialog.Share url)
itemPeek (Item.Download res _) = download res
itemPeek _ = pure unit

searchPeek :: forall a. Search.Query a -> Algebra Unit
searchPeek (Search.Clear _) = do
  salt <- liftEff newSalt
  { sort, path } <- get
  liftEff $ setLocation $ browseURL Nothing sort salt path
searchPeek _ = pure unit

dialogPeek :: forall a. Dialog.QueryP a -> Algebra Unit
dialogPeek = coproduct (const (pure unit)) (dialogChildrenPeek <<< runChildF)

dialogChildrenPeek :: forall a. Dialog.ChildQuery a -> Algebra Unit
dialogChildrenPeek q =
  fromMaybe (pure unit) (mountPeek <$> prjQuery Dialog.cpMount q)

mountPeek :: forall a. Mount.QueryP a -> Algebra Unit
mountPeek = coproduct go (const (pure unit))
  where
  go :: Mount.Query a -> Algebra Unit
  go (Mount.NotifySave _) = do
    mount <- queryDialog Dialog.cpMount $ left (request Mount.Save)
    case join mount of
      Nothing -> pure unit
      Just m -> do
        hideDialog
        -- check if we just edited the mount for the current directory, as if
        -- so, we don't want to add an item to the list for it
        isCurrentMount <- case m of
          R.Database path' -> (\p -> path' == (p </> dir "")) <$> gets _.path
          _ -> pure false
        when (not isCurrentMount) do
          queryListing $ action $ Listing.Add $ Item (R.Mount m)
          resort
  go _ = pure unit

dismissSignInSubmenu :: Algebra Unit
dismissSignInSubmenu = querySignIn $ action SignIn.DismissSubmenu
  where
  querySignIn :: forall a. SignIn.Query a -> Algebra Unit
  querySignIn q = query' cpSignIn unit (left q) $> unit

updateBreadcrumbs :: Algebra Unit
updateBreadcrumbs = do
  { path, sort, salt } <- get
  void $ query' cpBreadcrumbs unit $ action (Breadcrumbs.Update path sort salt)

resort :: Algebra Unit
resort = do
  sort <- gets _.sort
  mbIsSearching <- query' cpSearch unit (request Search.IsSearching)
  case mbIsSearching of
    Nothing -> pure unit
    Just isSearching ->
      void $ queryListing $ action $ Listing.SortBy (sortItem isSearching sort)

configure :: R.Mount -> Algebra Unit
configure (R.View path) = do
  viewInfo <- liftAff $ attempt $ Auth.authed $ API.viewInfo path
  showDialog
    case viewInfo of
      Left err ->
        Dialog.Error
          $ "There was a problem reading the mount settings: "
          <> show err
      Right info ->
        Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Left path))
          (Just (Right (SQL2.stateFromViewInfo info)))

configure (R.Database path) = do
  viewInfo <- liftAff $ attempt $ Auth.authed $ API.mountInfo path
  showDialog
    case map (lmap show) runParseAbsoluteURI =<< lmap show viewInfo of
      Left err ->
        Dialog.Error
          $ "There was a problem reading the mount settings: " <> err
      Right uri ->
        Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Right path))
          (Just (Left (MongoDB.stateFromURI uri)))

download :: R.Resource -> Algebra Unit
download res = do
  showDialog (Dialog.Download res)
  getChildren
    (const true)
    (void <<< queryDialog Dialog.cpDownload <<< action <<< Download.AddSources)
    rootDir
  pure unit

getChildren
  :: (R.Resource -> Boolean)
  -> (Array R.Resource -> Algebra Unit)
  -> DirPath
  -> Algebra Unit
getChildren pred cont start = do
  forceRerender'
  ei <- liftAff $ attempt $ Auth.authed $ API.children start
  case ei of
    Right items -> do
      let items' = filter pred items
          parents = mapMaybe (either (const Nothing) Just <<< R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ -> pure unit

getDirectories :: (Array R.Resource -> Algebra Unit) -> DirPath -> Algebra Unit
getDirectories = getChildren (R.isDirectory || R.isDatabaseMount)

showDialog :: Dialog.Dialog -> Algebra Unit
showDialog = void <<< query' cpDialog unit <<< left <<< action <<< Dialog.Show

hideDialog :: Algebra Unit
hideDialog = void $ query' cpDialog unit $ left (action Dialog.Dismiss)

queryListing :: forall a. Listing.Query a -> Algebra (Maybe a)
queryListing = query' cpListing unit <<< left

queryItem :: forall a. Listing.ItemSlot -> Item.Query a -> Algebra (Maybe a)
queryItem slot = query' cpListing unit <<< right <<< ChildF slot

queryDialog
  :: forall s f a
   . ChildPath s Dialog.ChildState f Dialog.ChildQuery Unit Dialog.ChildSlot
  -> f a
  -> Algebra (Maybe a)
queryDialog cp =
  query' cpDialog unit <<< right <<< ChildF (injSlot cp unit) <<< injQuery cp

{-
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.FileSystem.Component
  ( module SlamData.FileSystem.Component.State
  , module SlamData.FileSystem.Component.Query
  , module SlamData.FileSystem.Component.Install
  , comp
  ) where

import Prelude

import Control.Apply ((*>))
import Control.Bind (join, (=<<))
import Control.Monad (when)
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Exception (error, message)
import Control.Monad.Error.Class (throwError)
import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import Data.Array (head, last, mapMaybe, filter)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), either)
import Data.Foldable (traverse_)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Functor.Coproduct (left, right, coproduct)
import Data.Functor.Coproduct.Nested (coproduct5)
import Data.Functor.Eff (liftEff)
import Data.Lens ((.~))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Path.Pathy (rootDir, (</>), dir, file, parentDir)
import Data.String as S
import Data.URI (runParseAbsoluteURI)

import Halogen.Component
import Halogen.Component.ChildPath (ChildPath(), injSlot, prjQuery, injQuery)
import Halogen.Component.Utils (forceRerender')
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.Query (action, request, get, modify, gets)
import Halogen.Themes.Bootstrap3 as B

import Network.HTTP.MimeType.Common (textCSV)

import Quasar.Aff as API
import Quasar.Auth as Auth

import SlamData.Config as Config
import SlamData.Effects (Slam())
import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Component.Install
import SlamData.FileSystem.Component.Query
import SlamData.FileSystem.Component.Render
import SlamData.FileSystem.Component.State
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Dialog.Download.Component as Download
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as SQL2
import SlamData.FileSystem.Dialog.Rename.Component as Rename
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..), itemResource, itemURL, openItem, sortItem)
import SlamData.FileSystem.Listing.Item.Component as Item
import SlamData.FileSystem.Listing.Sort (notSort)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (newSalt)
import SlamData.FileSystem.Search.Component as Search
import SlamData.Notebook.Action (Action(..), AccessType(..))
import SlamData.Notebook.Routing (mkNotebookURL)
import SlamData.Render.Common
import SlamData.Render.CSS as Rc
import SlamData.SignIn.Component as SignIn

import Utils.DOM as D
import Utils.Path (DirPath(), getNameStr)

comp :: Component StateP QueryP Slam
comp = parentComponent' render eval (peek <<< runChildF)

render :: RenderParent State ChildState Query ChildQuery Slam ChildSlot
render state@{ version, sort, salt, path } =
  H.div
    [ P.classes [ Rc.filesystem ]
    , E.onClick (E.input_ DismissSignInSubmenu)
    ]
    [ navbar
        [ H.div
            [ P.classes [ Rc.header, B.clearfix ] ]
            [ icon B.glyphiconFolderOpen Config.homeHash
            , logo version
            , H.slot' cpSearch unit \_ ->
                { component: Search.comp
                , initialState: Search.initialState sort salt
                }
            , H.slot' cpSignIn unit \_ ->
                { component: SignIn.comp
                , initialState: installedState SignIn.initialState
                }
            ]
        ]
    , content
        [ H.div
            [ P.class_ B.clearfix ]
            [ H.slot' cpBreadcrumbs unit \_ ->
                { component: Breadcrumbs.comp
                , initialState: Breadcrumbs.mkBreadcrumbs path sort salt
                }
            , toolbar state
            ]
        , row [ sorting state ]
        , H.slot' cpListing unit \_ ->
            { component: Listing.comp
            , initialState: installedState Listing.initialState
            }
        ]
    , H.slot' cpDialog unit \_ ->
        { component: Dialog.comp
        , initialState: installedState Dialog.initialState
        }
    ]

eval :: EvalParent Query State ChildState Query ChildQuery Slam ChildSlot
eval (Resort next) = do
  { sort, salt, path } <- get
  searchValue <- query' cpSearch unit (request Search.GetValue)
  liftEff $ setLocation $ browseURL (join searchValue) (notSort sort) salt path
  pure next
eval (SetPath path next) = modify (_path .~ path) *> updateBreadcrumbs $> next
eval (SetSort sort next) = do
  modify (_sort .~ sort)
  updateBreadcrumbs
  resort
  pure next
eval (SetSalt salt next) = modify (_salt .~ salt) *> updateBreadcrumbs $> next
eval (SetIsMount isMount next) = modify (_isMount .~ isMount) $> next
eval (ShowHiddenFiles next) = do
  modify (_showHiddenFiles .~ true)
  queryListing $ action (Listing.SetIsHidden false)
  pure next
eval (HideHiddenFiles next) = do
  modify (_showHiddenFiles .~ false)
  queryListing $ action (Listing.SetIsHidden true)
  pure next
eval (Configure next) = do
  path <- gets _.path
  configure (R.Database path)
  pure next
eval (MakeMount next) = do
  path <- gets _.path
  showDialog (Dialog.Mount path "" Nothing)
  pure next
eval (MakeFolder next) = do
  path <- gets _.path
  dirName <- liftAff $ Auth.authed $ API.getNewName path Config.newFolderName
  let dirPath = path </> dir dirName
      dirRes = R.Directory dirPath
      dirItem = PhantomItem dirRes
      hiddenFile = dirPath </> file (Config.folderMark)
  queryListing $ action (Listing.Add dirItem)
  added <- liftAff $ attempt $
    Auth.authed $ API.makeFile hiddenFile API.ldJSON "{}"
  queryListing $ action (Listing.Filter (/= dirItem))
  case added of
    Left err ->
      showDialog $
        Dialog.Error
          $ "There was a problem creating the directory: "
          <> message err
    Right _ -> do
      void $ queryListing $ action $ Listing.Add (Item dirRes)
  pure next

eval (MakeNotebook next) = do
  path <- gets _.path
  let newNotebookName = Config.newNotebookName <> "." <> Config.notebookExtension
  name <- liftAff $ Auth.authed $ API.getNewName path newNotebookName
  let uri = mkNotebookURL (path </> dir name) New
  liftEff $ setLocation uri
  pure next

eval (UploadFile el next) = do
  mbInput <- liftEff $ D.querySelector "input" el
  case mbInput of
    Nothing -> pure unit
    Just input -> void $ liftEff $ Be.raiseEvent "click" input
  pure next

eval (FileListChanged el next) = do
  fileArr <- map Cf.fileListToArray $ (liftAff $ Cf.files el)
  liftEff $ clearValue el
  case head fileArr of
    Nothing ->
      let err :: Slam Unit
          err = throwError $ error "empty filelist"
      in liftAff err
    Just f -> do
      { path, sort, salt } <- get
      name <- liftAff $ liftEff (Cf.name f)
                >>= Auth.authed <<< API.getNewName path

      let fileName = path </> file name
          res = R.File fileName
          fileItem = PhantomItem res
          ext = last (S.split "." name)
          mime = if ext == Just "csv"
                 then textCSV
                 else API.ldJSON
      reader <- liftEff Cf.newReaderEff
      content <- liftAff $ Cf.readAsBinaryString f reader
      queryListing $ action (Listing.Add fileItem)
      f <- liftAff $ attempt $ Auth.authed $ API.makeFile fileName mime content
      case f of
        Left err -> do
          queryListing $ action $
            Listing.Filter (not <<< eq (R.File fileName) <<< itemResource)
          showDialog $ Dialog.Error (message err)
        Right _ -> liftEff $ openItem res sort salt

  pure next

eval (Download next) = do
  path <- gets _.path
  download (R.Directory path)
  pure next

eval (SetVersion version next) = modify (_version .~ Just version) $> next
eval (DismissSignInSubmenu next) = dismissSignInSubmenu $> next

peek :: forall a. ChildQuery a -> Algebra Unit
peek =
  coproduct5
    listingPeek
    searchPeek
    (const (pure unit))
    dialogPeek
    (const (pure unit))

listingPeek :: forall a. Listing.QueryP a -> Algebra Unit
listingPeek = coproduct go (itemPeek <<< runChildF)
  where
  go (Listing.Add _ _) = resort
  go (Listing.Adds _ _) = resort
  go _ = pure unit

itemPeek :: forall a. Item.Query a -> Algebra Unit
itemPeek (Item.Open res _) = do
  { sort, salt } <- get
  liftEff $ openItem res sort salt
itemPeek (Item.Configure (R.Mount mount) _) = configure mount
itemPeek (Item.Move res _) = do
  showDialog $ Dialog.Rename res
  flip getDirectories rootDir \x ->
    void $ queryDialog Dialog.cpRename $ action (Rename.AddDirs x)
itemPeek (Item.Remove res _) = do
  mbTrashFolder <- liftAff $ Auth.authed $ API.delete res
  queryListing $ action $ Listing.Filter (not <<< eq res <<< itemResource)
  case mbTrashFolder of
    Nothing -> pure unit
    Just res' -> void $ queryListing $ action $ Listing.Add (Item res')
itemPeek (Item.Share res _) = do
  { sort, salt } <- get
  loc <- liftEff locationString
  let url = loc <> "/" <> itemURL sort salt ReadOnly res
  showDialog (Dialog.Share url)
itemPeek (Item.Download res _) = download res
itemPeek _ = pure unit

searchPeek :: forall a. Search.Query a -> Algebra Unit
searchPeek (Search.Clear _) = do
  salt <- liftEff newSalt
  { sort, path } <- get
  liftEff $ setLocation $ browseURL Nothing sort salt path
searchPeek _ = pure unit

dialogPeek :: forall a. Dialog.QueryP a -> Algebra Unit
dialogPeek = coproduct (const (pure unit)) (dialogChildrenPeek <<< runChildF)

dialogChildrenPeek :: forall a. Dialog.ChildQuery a -> Algebra Unit
dialogChildrenPeek q =
  fromMaybe (pure unit) (mountPeek <$> prjQuery Dialog.cpMount q)

mountPeek :: forall a. Mount.QueryP a -> Algebra Unit
mountPeek = coproduct go (const (pure unit))
  where
  go :: Mount.Query a -> Algebra Unit
  go (Mount.NotifySave _) = do
    mount <- queryDialog Dialog.cpMount $ left (request Mount.Save)
    case join mount of
      Nothing -> pure unit
      Just m -> do
        hideDialog
        -- check if we just edited the mount for the current directory, as if
        -- so, we don't want to add an item to the list for it
        isCurrentMount <- case m of
          R.Database path' -> (\p -> path' == (p </> dir "")) <$> gets _.path
          _ -> pure false
        when (not isCurrentMount) do
          queryListing $ action $ Listing.Add $ Item (R.Mount m)
          resort
  go _ = pure unit

dismissSignInSubmenu :: Algebra Unit
dismissSignInSubmenu = querySignIn $ action SignIn.DismissSubmenu
  where
  querySignIn :: forall a. SignIn.Query a -> Algebra Unit
  querySignIn q = query' cpSignIn unit (left q) $> unit

updateBreadcrumbs :: Algebra Unit
updateBreadcrumbs = do
  { path, sort, salt } <- get
  void $ query' cpBreadcrumbs unit $ action (Breadcrumbs.Update path sort salt)

resort :: Algebra Unit
resort = do
  sort <- gets _.sort
  mbIsSearching <- query' cpSearch unit (request Search.IsSearching)
  case mbIsSearching of
    Nothing -> pure unit
    Just isSearching ->
      void $ queryListing $ action $ Listing.SortBy (sortItem isSearching sort)

configure :: R.Mount -> Algebra Unit
configure (R.View path) = do
  viewInfo <- liftAff $ attempt $ Auth.authed $ API.viewInfo path
  showDialog
    case viewInfo of
      Left err ->
        Dialog.Error
          $ "There was a problem reading the mount settings: "
          <> show err
      Right info ->
        Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Left path))
          (Just (Right (SQL2.stateFromViewInfo info)))

configure (R.Database path) = do
  viewInfo <- liftAff $ attempt $ Auth.authed $ API.mountInfo path
  showDialog
    case map (lmap show) runParseAbsoluteURI =<< lmap show viewInfo of
      Left err ->
        Dialog.Error
          $ "There was a problem reading the mount settings: " <> err
      Right uri ->
        Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Right path))
          (Just (Left (MongoDB.stateFromURI uri)))

download :: R.Resource -> Algebra Unit
download res = do
  showDialog (Dialog.Download res)
  getChildren
    (const true)
    (void <<< queryDialog Dialog.cpDownload <<< action <<< Download.AddSources)
    rootDir
  pure unit

getChildren
  :: (R.Resource -> Boolean)
  -> (Array R.Resource -> Algebra Unit)
  -> DirPath
  -> Algebra Unit
getChildren pred cont start = do
  forceRerender'
  ei <- liftAff $ attempt $ Auth.authed $ API.children start
  case ei of
    Right items -> do
      let items' = filter pred items
          parents = mapMaybe (either (const Nothing) Just <<< R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ -> pure unit

getDirectories :: (Array R.Resource -> Algebra Unit) -> DirPath -> Algebra Unit
getDirectories = getChildren (R.isDirectory || R.isDatabaseMount)

showDialog :: Dialog.Dialog -> Algebra Unit
showDialog = void <<< query' cpDialog unit <<< left <<< action <<< Dialog.Show

hideDialog :: Algebra Unit
hideDialog = void $ query' cpDialog unit $ left (action Dialog.Dismiss)

queryListing :: forall a. Listing.Query a -> Algebra (Maybe a)
queryListing = query' cpListing unit <<< left

queryItem :: forall a. Listing.ItemSlot -> Item.Query a -> Algebra (Maybe a)
queryItem slot = query' cpListing unit <<< right <<< ChildF slot

queryDialog
  :: forall s f a
   . ChildPath s Dialog.ChildState f Dialog.ChildQuery Unit Dialog.ChildSlot
  -> f a
  -> Algebra (Maybe a)
queryDialog cp =
  query' cpDialog unit <<< right <<< ChildF (injSlot cp unit) <<< injQuery cp