Add basic test case for mapMaybe

Add basic test case for mapMaybe

module Test.Data.Array where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Array
import Data.Maybe
import Data.Tuple
import Data.Foldable (sum)
import Debug.Trace
import Global (nan, infinity)
import Test.QuickCheck
import Test.Classes

double :: Number -> Number
double x = x * 2

one :: forall a. a -> Number
one _ = 1

doubleAndOrig :: Number -> [Number]
doubleAndOrig x = [x * 2, x]

nil :: [Number]
nil = []

odd :: Number -> Boolean
odd n = n % 2 /= 0

main = do

  trace "test equality"
  check1 $ \n -> [n] == [n]

  trace "test inequality"
  check1 $ \n -> [n] /= [n + 1]

  trace "(!!) should return Just x when the index is within the bounds of the array"
  assert $ [1, 2, 3] !! 0 == (Just 1)
  assert $ [1, 2, 3] !! 1 == (Just 2)
  assert $ [1, 2, 3] !! 2 == (Just 3)

  trace "(!!) should return Nothing when the index is outside of the bounds of the array"
  assert $ [1, 2, 3] !! 6 == Nothing
  assert $ [1, 2, 3] !! -1 == Nothing

  trace "(!!) should return Nothing when the index not an integer"
  assert $ [1, 2, 3] !! 0.2 == Nothing
  assert $ [1, 2, 3] !! nan == Nothing
  assert $ [1, 2, 3] !! infinity == Nothing
  assert $ [1, 2, 3] !! -infinity == Nothing

  trace "snoc should add an item to the end of an array"
  assert $ [1, 2, 3] `snoc` 4 == [1, 2, 3, 4]
  assert $ nil `snoc` 1 == [1]

  trace "singleton should construct an array with a single value"
  check1 $ \x -> singleton x == [x]

  trace "head should return a Just-wrapped first value of a non-empty array"
  quickCheck $ \xs n -> head (n : xs) == Just (n :: Number)

  trace "head should return Nothing for an empty array"
  assert $ head nil == Nothing

  trace "last should return a Just-wrapped first value of a non-empty array"
  quickCheck $ \xs n -> last (xs `snoc` n) == Just (n :: Number)

  trace "last should return Nothing for an empty array"
  assert $ last nil == Nothing

  trace "tail should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array"
  quickCheck $ \xs n -> tail (n : xs) == Just (xs :: [Number])

  trace "tail should return Nothing for an empty array"
  assert $ tail nil == Nothing

  trace "init should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array"
  quickCheck $ \xs n -> init (xs `snoc` n) == Just (xs :: [Number])

  trace "init should return Nothing for an empty array"
  assert $ init nil == Nothing

  trace "null should return false for non-empty arrays"
  checkA1 $ \xs -> case xs of
    [] -> true
    xs -> null xs == false

  trace "null should return true for an empty array"
  assert $ null nil == true

  trace "map should transform every item in an array"
  checkA1 $ \xs -> sum (map double xs) == double (sum xs)

  trace "mapMaybe should transform every item in an array, throwing out Nothing values"
  assert $ mapMaybe (\x -> if x % 2 == 0 then Just x else Nothing) [0, 1, 2, 3, 4, 5] == [0, 2, 4]

  trace "length should return the number of items in an array"
  checkA1 $ \xs -> length xs == sum (map one xs)

  trace "elem should return true when the item is present in an array"
  assert $ elem 1 [1, 2, 3]
  assert $ elem 2 [1, 2, 3]
  assert $ elem 3 [1, 2, 3]

  trace "elem should return true when the item is not present in an array"
  assert $ elem 4 [1, 2, 3] == false
  assert $ elem 4 nil == false

  trace "elemIndex should return the index of an item in an array"
  assert $ (elemIndex 1 [1, 2, 1]) == 0
  assert $ (elemIndex 4 [1, 2, 1]) == -1

  trace "elemIndex should return the last index of an item in an array"
  assert $ (elemLastIndex 1 [1, 2, 1]) == 2
  assert $ (elemLastIndex 4 [1, 2, 1]) == -1

  trace "concat should join a list of lists"
  assert $ (concat [[1, 2], [3, 4]]) == [1, 2, 3, 4]
  assert $ (concat [[1], nil]) == [1]
  assert $ (concat [nil, nil]) == nil

  trace "reverse should reverse the order of items in an array"
  assert $ (reverse [1, 2, 3]) == [3, 2, 1]
  assert $ (reverse nil) == nil

  trace "reverse should remove the specified number of items from the front of an array"
  assert $ (drop 1 [1, 2, 3]) == [2, 3]
  assert $ (drop 2 [1, 2, 3]) == [3]
  assert $ (drop 1 nil) == nil

  trace "reverse should keep the specified number of items from the front of an array, discarding the rest"
  assert $ (take 1 [1, 2, 3]) == [1]
  assert $ (take 2 [1, 2, 3]) == [1, 2]
  assert $ (take 1 nil) == nil

  trace "insertAt should add an item at the specified index"
  assert $ (insertAt 0 1 [2, 3]) == [1, 2, 3]
  assert $ (insertAt 1 1 [2, 3]) == [2, 1, 3]

  trace "deleteAt should remove an item at the specified index"
  assert $ (deleteAt 0 1 [1, 2, 3]) == [2, 3]
  assert $ (deleteAt 1 1 [1, 2, 3]) == [1, 3]

  trace "updateAt should replace an item at the specified index"
  assert $ (updateAt 0 9 [1, 2, 3]) == [9, 2, 3]
  assert $ (updateAt 1 9 [1, 2, 3]) == [1, 9, 3]
  assert $ (updateAt 1 9 nil) == nil

  trace "concatMap should be equivalent to concat . map"
  checkA1 $ \xs -> concatMap doubleAndOrig xs == concat (map doubleAndOrig xs)

  trace "filter should remove items that don't match a predicate"
  assert $ filter odd (range 0 10) == [1, 3, 5, 7, 9]

  trace "range should create an inclusive array of integers for the specified start and end"
  assert $ range 0 5 == [0, 1, 2, 3, 4, 5]
  assert $ range 2 (-3) == [2, 1, 0, -1, -2, -3]

  trace "zipWith should use the specified function to zip two lists together"
  assert $ zipWith Tuple [1, 2, 3] ["a", "b", "c"] == [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"]

  trace "nub should remove duplicate items from the list"
  assert $ nub [1, 2, 2, 3, 4, 1] == [1, 2, 3, 4]

  trace "nubBy should remove duplicate items from the list using a supplied predicate"
  let nubPred = \x y -> if odd x then false else x == y
  assert $ nubBy nubPred [1, 2, 2, 3, 3, 4, 4, 1] == [1, 2, 3, 3, 4, 1]

  trace "sort should reorder a list into ascending order based on the result of compare"
  assert $ sort [1, 3, 2, 5, 6, 4] == [1, 2, 3, 4, 5, 6]

  let ty = [0]

  trace "test functor laws"
  checkFunctor ty

  trace "test applicative laws"
  checkApplicative ty ty ty

  trace "test monad laws"
  checkMonad ty

assert :: Boolean -> QC {}
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC {}
check1 = quickCheck

checkA1 :: ([Number] -> Boolean) -> QC {}
checkA1 = quickCheck

module Test.Data.Array where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Array
import Data.Maybe
import Data.Tuple
import Data.Foldable (sum)
import Debug.Trace
import Global (nan, infinity)
import Test.QuickCheck
import Test.Classes

double :: Number -> Number
double x = x * 2

one :: forall a. a -> Number
one _ = 1

doubleAndOrig :: Number -> [Number]
doubleAndOrig x = [x * 2, x]

nil :: [Number]
nil = []

odd :: Number -> Boolean
odd n = n % 2 /= 0

main = do

  trace "test equality"
  check1 $ \n -> [n] == [n]

  trace "test inequality"
  check1 $ \n -> [n] /= [n + 1]

  trace "(!!) should return Just x when the index is within the bounds of the array"
  assert $ [1, 2, 3] !! 0 == (Just 1)
  assert $ [1, 2, 3] !! 1 == (Just 2)
  assert $ [1, 2, 3] !! 2 == (Just 3)

  trace "(!!) should return Nothing when the index is outside of the bounds of the array"
  assert $ [1, 2, 3] !! 6 == Nothing
  assert $ [1, 2, 3] !! -1 == Nothing

  trace "(!!) should return Nothing when the index not an integer"
  assert $ [1, 2, 3] !! 0.2 == Nothing
  assert $ [1, 2, 3] !! nan == Nothing
  assert $ [1, 2, 3] !! infinity == Nothing
  assert $ [1, 2, 3] !! -infinity == Nothing

  trace "snoc should add an item to the end of an array"
  assert $ [1, 2, 3] `snoc` 4 == [1, 2, 3, 4]
  assert $ nil `snoc` 1 == [1]

  trace "singleton should construct an array with a single value"
  check1 $ \x -> singleton x == [x]

  trace "head should return a Just-wrapped first value of a non-empty array"
  quickCheck $ \xs n -> head (n : xs) == Just (n :: Number)

  trace "head should return Nothing for an empty array"
  assert $ head nil == Nothing

  trace "last should return a Just-wrapped first value of a non-empty array"
  quickCheck $ \xs n -> last (xs `snoc` n) == Just (n :: Number)

  trace "last should return Nothing for an empty array"
  assert $ last nil == Nothing

  trace "tail should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array"
  quickCheck $ \xs n -> tail (n : xs) == Just (xs :: [Number])

  trace "tail should return Nothing for an empty array"
  assert $ tail nil == Nothing

  trace "init should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array"
  quickCheck $ \xs n -> init (xs `snoc` n) == Just (xs :: [Number])

  trace "init should return Nothing for an empty array"
  assert $ init nil == Nothing

  trace "null should return false for non-empty arrays"
  checkA1 $ \xs -> case xs of
    [] -> true
    xs -> null xs == false

  trace "null should return true for an empty array"
  assert $ null nil == true

  trace "map should transform every item in an array"
  checkA1 $ \xs -> sum (map double xs) == double (sum xs)

  trace "length should return the number of items in an array"
  checkA1 $ \xs -> length xs == sum (map one xs)

  trace "elem should return true when the item is present in an array"
  assert $ elem 1 [1, 2, 3]
  assert $ elem 2 [1, 2, 3]
  assert $ elem 3 [1, 2, 3]

  trace "elem should return true when the item is not present in an array"
  assert $ elem 4 [1, 2, 3] == false
  assert $ elem 4 nil == false

  trace "elemIndex should return the index of an item in an array"
  assert $ (elemIndex 1 [1, 2, 1]) == 0
  assert $ (elemIndex 4 [1, 2, 1]) == -1

  trace "elemIndex should return the last index of an item in an array"
  assert $ (elemLastIndex 1 [1, 2, 1]) == 2
  assert $ (elemLastIndex 4 [1, 2, 1]) == -1

  trace "concat should join a list of lists"
  assert $ (concat [[1, 2], [3, 4]]) == [1, 2, 3, 4]
  assert $ (concat [[1], nil]) == [1]
  assert $ (concat [nil, nil]) == nil

  trace "reverse should reverse the order of items in an array"
  assert $ (reverse [1, 2, 3]) == [3, 2, 1]
  assert $ (reverse nil) == nil

  trace "reverse should remove the specified number of items from the front of an array"
  assert $ (drop 1 [1, 2, 3]) == [2, 3]
  assert $ (drop 2 [1, 2, 3]) == [3]
  assert $ (drop 1 nil) == nil

  trace "reverse should keep the specified number of items from the front of an array, discarding the rest"
  assert $ (take 1 [1, 2, 3]) == [1]
  assert $ (take 2 [1, 2, 3]) == [1, 2]
  assert $ (take 1 nil) == nil

  trace "insertAt should add an item at the specified index"
  assert $ (insertAt 0 1 [2, 3]) == [1, 2, 3]
  assert $ (insertAt 1 1 [2, 3]) == [2, 1, 3]

  trace "deleteAt should remove an item at the specified index"
  assert $ (deleteAt 0 1 [1, 2, 3]) == [2, 3]
  assert $ (deleteAt 1 1 [1, 2, 3]) == [1, 3]

  trace "updateAt should replace an item at the specified index"
  assert $ (updateAt 0 9 [1, 2, 3]) == [9, 2, 3]
  assert $ (updateAt 1 9 [1, 2, 3]) == [1, 9, 3]
  assert $ (updateAt 1 9 nil) == nil

  trace "concatMap should be equivalent to concat . map"
  checkA1 $ \xs -> concatMap doubleAndOrig xs == concat (map doubleAndOrig xs)

  trace "filter should remove items that don't match a predicate"
  assert $ filter odd (range 0 10) == [1, 3, 5, 7, 9]

  trace "range should create an inclusive array of integers for the specified start and end"
  assert $ range 0 5 == [0, 1, 2, 3, 4, 5]
  assert $ range 2 (-3) == [2, 1, 0, -1, -2, -3]

  trace "zipWith should use the specified function to zip two lists together"
  assert $ zipWith Tuple [1, 2, 3] ["a", "b", "c"] == [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"]

  trace "nub should remove duplicate items from the list"
  assert $ nub [1, 2, 2, 3, 4, 1] == [1, 2, 3, 4]

  trace "nubBy should remove duplicate items from the list using a supplied predicate"
  let nubPred = \x y -> if odd x then false else x == y
  assert $ nubBy nubPred [1, 2, 2, 3, 3, 4, 4, 1] == [1, 2, 3, 3, 4, 1]

  trace "sort should reorder a list into ascending order based on the result of compare"
  assert $ sort [1, 3, 2, 5, 6, 4] == [1, 2, 3, 4, 5, 6]

  let ty = [0]

  trace "test functor laws"
  checkFunctor ty

  trace "test applicative laws"
  checkApplicative ty ty ty

  trace "test monad laws"
  checkMonad ty

assert :: Boolean -> QC {}
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC {}
check1 = quickCheck

checkA1 :: ([Number] -> Boolean) -> QC {}
checkA1 = quickCheck


fixed up some wording in one of the tests

module Test.Main where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either(..), either, fromLeft, isRight)
import Data.Foreign (ForeignError(..), MultipleErrors)
import Data.Foreign.NullOrUndefined (NullOrUndefined)
import Data.List (List(..))
import Data.List.NonEmpty (NonEmptyList(..))
import Data.Maybe (Maybe)
import Data.NonEmpty (NonEmpty(..))
import Data.StrMap (StrMap)
import Partial.Unsafe (unsafePartial)
import Simple.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)
import Test.Spec (describe, it)
import Test.Spec.Assertions (fail, shouldEqual)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)
import Type.Proxy (Proxy(..))

type E a = Either MultipleErrors a

handleJSON :: forall a. ReadForeign a => String -> E a
handleJSON json = runExcept $ readJSON json

type MyTest =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  }

type MyTestNull =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  , e :: NullOrUndefined (Array String)
  }

type MyTestStrMap =
  { a :: Int
  , b :: StrMap Int
  }

type MyTestMaybe =
  { a :: Maybe String
  }

type MyTestManyMaybe =
  { a         :: Maybe String
  , aNull     :: Maybe String
  , b         :: Maybe Int
  , bNull     :: Maybe Int
  , c         :: Maybe Boolean
  , cNull     :: Maybe Boolean
  , d         :: Maybe Number
  , dNull     :: Maybe Number
  , e         :: Maybe (Array (Maybe String))
  , eNull     :: Maybe (Array (Maybe String))
  }

roundtrips :: forall a. ReadForeign a => WriteForeign a => Proxy a -> String -> Aff (RunnerEffects ()) Unit
roundtrips _ enc0 = do
  let dec0 :: E a
      dec0 = handleJSON $ enc0
      enc1 = either (const "bad1") writeJSON $ dec0
      json0 :: Either String Json
      json0 = jsonParser enc0
      json1 :: Either String Json
      json1 = jsonParser enc1
      dec1 :: E a
      dec1 = handleJSON enc1
      enc2 = either (const "bad2") writeJSON dec1
  when (json0 /= json1) $ fail $ "\n\torig: " <> show json0 <> "\n\tenc: " <> show json1
  when (enc1 /= enc2) $ fail enc0

main :: Eff (RunnerEffects ()) Unit
main = run [consoleReporter] do
  describe "readJSON" do
    it "fails with invalid JSON" do
      let result = handleJSON """
        { "c": 1, "d": 2}
      """
      (unsafePartial $ fromLeft result) `shouldEqual`
        (NonEmptyList (NonEmpty (ErrorAtProperty "a" (TypeMismatch "Int" "Undefined")) Nil))
      isRight (result :: E MyTest) `shouldEqual` false

    it "works with missing Maybe fields by setting them to Nothing" do
      let result = handleJSON "{}"
      (writeJSON <$> (result :: E MyTestMaybe)) `shouldEqual` (Right """{"a":null}""")

  describe "roundtrips" do
    it "works with proper JSON" $ roundtrips (Proxy :: Proxy MyTest) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON lacking NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTestNull) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON containing NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTestNull) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"], "e": ["C", "D"]}
      """
    it "works with JSON containing StrMap field" $ roundtrips (Proxy :: Proxy MyTestStrMap) """
        { "a": 1, "b": {"asdf": 1, "c": 2} }
      """
    it "works with Maybe field and existing value" $ roundtrips (Proxy :: Proxy MyTestMaybe) """
        { "a": "foo" }
      """
    it "works with Maybe field and null value" $ roundtrips (Proxy :: Proxy MyTestMaybe) """
        { "a": null }
      """
    it "works with many Maybe fields" $ roundtrips (Proxy :: Proxy MyTestManyMaybe) """
      { "a": "str", "aNull": null, "b":1, "bNull": null, "c":true, "cNull":null, "d":1.1, "dNull":null, "e":["str1", "str2", null], "eNull": null }
    """

module Test.Main where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either(..), either, fromLeft, isRight)
import Data.Foreign (ForeignError(..), MultipleErrors)
import Data.Foreign.NullOrUndefined (NullOrUndefined)
import Data.Generic (class Generic)
import Data.List (List(..))
import Data.List.NonEmpty (NonEmptyList(..))
import Data.Maybe (Maybe(..))
import Data.NonEmpty (NonEmpty(..))
import Data.StrMap (StrMap)
import Debug.Trace (spy)
import Partial.Unsafe (unsafePartial)
import Simple.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)
import Test.Spec (describe, it)
import Test.Spec.Assertions (fail, shouldEqual)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)
import Type.Proxy (Proxy(..))

type E a = Either MultipleErrors a

handleJSON :: forall a. ReadForeign a => String -> E a
handleJSON json = runExcept $ readJSON json

type MyTest =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  }

type MyTestNull =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  , e :: NullOrUndefined (Array String)
  }

type MyTestStrMap =
  { a :: Int
  , b :: StrMap Int
  }

type MyTestMaybe =
  { a :: Maybe String
  }

type MyTestManyMaybe =
  { a         :: Maybe String
  , aNull     :: Maybe String
  , b         :: Maybe Int
  , bNull     :: Maybe Int
  , c         :: Maybe Boolean
  , cNull     :: Maybe Boolean
  , d         :: Maybe Number
  , dNull     :: Maybe Number
  , e         :: Maybe (Array (Maybe String))
  , eNull     :: Maybe (Array (Maybe String))
  }

roundtrips :: forall a. ReadForeign a => WriteForeign a => Proxy a -> String -> Aff (RunnerEffects ()) Unit
roundtrips _ enc0 = do
  let dec0 :: E a
      dec0 = handleJSON $ enc0
      enc1 = either (const "bad1") writeJSON $ dec0
      json0 :: Either String Json
      json0 = jsonParser enc0
      json1 :: Either String Json
      json1 = jsonParser enc1
      dec1 :: E a
      dec1 = handleJSON enc1
      enc2 = either (const "bad2") writeJSON dec1
  when (json0 /= json1) $ fail $ "\n\torig: " <> show json0 <> "\n\tenc: " <> show json1
  when (enc1 /= enc2) $ fail enc0

main :: Eff (RunnerEffects ()) Unit
main = run [consoleReporter] do
  describe "readJSON" do
    it "fails with invalid JSON" do
      let result = handleJSON """
        { "c": 1, "d": 2}
      """
      (unsafePartial $ fromLeft result) `shouldEqual`
        (NonEmptyList (NonEmpty (ErrorAtProperty "a" (TypeMismatch "Int" "Undefined")) Nil))
      isRight (result :: E MyTest) `shouldEqual` false

    it "works with missing Maybe fields by setting them to Nothing" do
      let result = handleJSON "{}"
      (writeJSON <$> (result :: E MyTestMaybe)) `shouldEqual` (Right """{"a":null}""")

  describe "roundtrips" do
    it "works with proper JSON" $ roundtrips (Proxy :: Proxy MyTest) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON lacking NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTestNull) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON containing NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTestNull) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"], "e": ["C", "D"]}
      """
    it "works with JSON containing StrMap field" $ roundtrips (Proxy :: Proxy MyTestStrMap) """
        { "a": 1, "b": {"asdf": 1, "c": 2} }
      """
    it "works with Maybe field and existing value" $ roundtrips (Proxy :: Proxy MyTestMaybe) """
        { "a": "foo" }
      """
    it "works with Maybe field and null value" $ roundtrips (Proxy :: Proxy MyTestMaybe) """
        { "a": null }
      """
    it "works with a several Maybe fields" $ roundtrips (Proxy :: Proxy MyTestManyMaybe) """
      { "a": "str", "aNull": null, "b":1, "bNull": null, "c":true, "cNull":null, "d":1.1, "dNull":null, "e":["str1", "str2", null], "eNull": null }
    """


generalise messageIfFileNotFound

generalise messageIfFileNotFound

{-
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.Quasar.FS
  ( children
  , getNewName
  , move
  , listing
  , delete
  , messageIfFileNotFound
  , dirNotAccessible
  , fileNotAccessible
  , module Quasar.Error
  ) where

import SlamData.Prelude

import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Fork (class MonadFork)

import Data.Array as Arr
import Data.Foldable as F
import Data.Lens ((.~), (^.), (^?), _Left)
import Data.List as List
import Data.Map as Map
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String as S

import Quasar.Advanced.QuasarAF as QF
import Quasar.Error (QError(..))
import Quasar.FS as QFS
import Quasar.FS.Mount as QFSM
import Quasar.FS.Resource as QR
import Quasar.Types (AnyPath, DirPath, FilePath)

import SlamData.Config as Config
import SlamData.Effects (SlamDataEffects)
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL, liftQuasar)
import SlamData.Quasar.Data as QD

import SlamData.Workspace.Legacy (isLegacy, loadCompatWorkspace, pruneLegacyData)
import SlamData.Workspace.Model as WM
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Open.Model as Open

import Utils.Array (enumerate)
import Utils.Ace (RangeRec)

children
  ∷ ∀ m
  . Monad m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
children dir = runExceptT do
  cs ← ExceptT $ listing dir
  let result = (R._root .~ dir) <$> cs
  -- TODO: do this somewhere more appropriate
  -- lift $ fromAff $ memoizeCompletionStrs dir result
  pure result

transitiveChildren
  ∷ ∀ f m
  . Parallel f m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
transitiveChildren start = runExceptT do
  rs ← ExceptT $ children start
  cs ← parTraverse go rs
  pure $ rs <> join cs
  where
  go ∷ R.Resource → ExceptT QError m (Array R.Resource)
  go r = case R.getPath r of
    Left dir → do
      crs ← ExceptT $ transitiveChildren dir
      pure $ [r] <> crs
    Right _ → pure [r]

listing
  ∷ ∀ m
  . Functor m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
listing p =
  map (map toResource) <$> liftQuasar (QF.dirMetadata p)
  where
  toResource ∷ QFS.Resource → R.Resource
  toResource res = case res of
    QFS.File path → R.File path
    QFS.Directory path →
      let workspaceName
            = S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension)
            ∘ P.runDirName =<< P.dirName path
      in case workspaceName of
        Just name → R.Workspace (p </> P.dir name)
        Nothing → R.Directory path
    QFS.Mount m → R.Mount $ either R.Database R.View $ QFSM.getPath m

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  ∷ ∀ m
  . Monad m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → String
  → m (Either QError String)
getNewName parent name = do
  result ← liftQuasar (QF.dirMetadata parent)
  pure case result of
    Right items
      | exists name items → Right (getNewName' items 1)
      | otherwise → Right name
    Left QF.NotFound → Right name
    Left err → Left err
  where

  getNewName' ∷ Array QFS.Resource → Int → String
  getNewName' items i =
    let arr = S.split (S.Pattern ".") name
    in fromMaybe "" do
      body ← Arr.head arr
      suffixes ← Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists newName items
           then getNewName' items (i + one)
           else newName

  exists ∷ String → Array QFS.Resource → Boolean
  exists n = F.any ((_ == n) ∘ printName ∘ QR.getName)

  printName ∷ Either (Maybe P.DirName) P.FileName → String
  printName = either (fromMaybe "" ∘ map P.runDirName) P.runFileName

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  ∷ ∀ f m
  . MonadAff SlamDataEffects m
  ⇒ MonadFork Error m
  ⇒ QuasarDSL m
  ⇒ Parallel f m
  ⇒ R.Resource
  → AnyPath
  → m (Either QError (Maybe AnyPath))
move src tgt = do
  let
    srcPath = R.getPath src

  _ ← runExceptT ∘ traverse_ cleanViewMounts $ srcPath ^? _Left

  _ ← runExceptT case src of
    R.Workspace wsDir → replacePathsInWorkspace wsDir
    _ → pure unit

  result ←
    case src of
      R.Mount _ → liftQuasar $ QF.moveMount srcPath tgt
      _ → liftQuasar $ QF.moveData srcPath tgt

  pure
    case result of
      Right _ → Right (Just tgt)
      Left QF.NotFound → Right Nothing
      Left err → Left err

  where
  replacePathsInWorkspace ∷ DirPath → ExceptT QError m Unit
  replacePathsInWorkspace wsDir = do
    stat × ws ← ExceptT $ loadCompatWorkspace wsDir
    let
      updated =
        ws.cards
          # Map.toUnfoldable
          # List.mapMaybe (sequence ∘ map (replacePaths wsDir))
          # Map.fromFoldable
      ws' = ws { cards = Map.union updated ws.cards }
    unless (Map.isEmpty updated) $ putWorkspace wsDir ws
    when (isLegacy stat) $ void $ lift $ pruneLegacyData wsDir

  putWorkspace ∷ DirPath → WM.Workspace → ExceptT QError m Unit
  putWorkspace wsDir ws =
    ExceptT $ QD.save (wsDir </> P.file "index") $ WM.encode ws

  replacePaths ∷ DirPath → CM.AnyCardModel → Maybe CM.AnyCardModel
  replacePaths wsDir = case _ of
    CM.Cache m →
      let
        newM =
          S.replace
            (S.Pattern $ P.printPath wsDir)
            (S.Replacement $ either P.printPath P.printPath tgt)
            <$> m
      in
        if newM ≡ m
          then Nothing
          else pure $ CM.Cache newM
    CM.Open (Just (Open.Resource r)) →
      let
        newR = fromMaybe r do
          rel ←
            bisequence
              $ bimap (flip P.relativeTo wsDir) (flip P.relativeTo wsDir)
              $ R.getPath r
          tgtDir ← either Just (const Nothing) tgt
          let
            newP =
              bimap P.canonicalize P.canonicalize
              $ bimap (tgtDir </> _) (tgtDir </> _) rel
          pure $ R.setPath r newP
      in
        if newR ≡ r
          then Nothing
          else pure $ CM.Open (Just (Open.Resource newR))
    CM.Ace mode m →
      let
        wsStr ∷ String
        wsStr = P.printPath wsDir

        pat ∷ S.Pattern
        pat = S.Pattern wsStr

        tgtStr ∷ String
        tgtStr = either P.printPath P.printPath tgt

        replacement ∷ S.Replacement
        replacement = S.Replacement tgtStr

        srcLen ∷ Int
        srcLen = S.length wsStr

        tgtLen ∷ Int
        tgtLen = S.length tgtStr

        lenDiff ∷ Int
        lenDiff = tgtLen - srcLen

        sortRangeRecs ∷ Array RangeRec → Array RangeRec
        sortRangeRecs =
          Arr.sortBy \a b →
            compare a.startRow b.startRow
            ⊕ compare a.startColumn b.startColumn

        -- We don't care about endings
        eqRangeRec ∷ RangeRec → RangeRec → Boolean
        eqRangeRec a b =
          -- That's a bug workaround, modification of ace field for whatever reason
          -- removes one space left padding :(
          (a.startColumn ≡ b.startColumn
           ∨ a.startColumn + one ≡ b.startColumn
           ∨ a.startColumn - one ≡ b.startColumn)
          ∧ a.startRow ≡ b.startRow

        substrIndices
          ∷ S.Pattern
          → Array (Int × String)
          → Array RangeRec
        substrIndices needle =
          sortRangeRecs ∘ foldl foldRanges [ ]
          where
          findStartColumns ∷ Array Int → String → Array Int
          findStartColumns accum hay =
            case S.indexOf needle hay of
              Nothing → accum
              Just i → findStartColumns (Arr.cons i accum) $ S.drop (i + srcLen) hay

          foldRanges
            ∷ Array RangeRec
            → Int × String
            → Array RangeRec
          foldRanges accum (startRow × hay) =
            let
              starts = findStartColumns [] hay
              fromKWlen = 6
              mkRange start =
                [ { startColumn: start - fromKWlen
                  , endColumn: 0
                  , startRow
                  , endRow: startRow
                  } ]
            in
             foldMap mkRange starts ⊕ accum

        initialRanges ∷ Array RangeRec
        initialRanges = substrIndices pat $ enumerate $ S.split (S.Pattern "\n") m.text

        -- inputs must be sorted
        filterRanges
          ∷ Array RangeRec
          → Array RangeRec
          → Array RangeRec
          → Array RangeRec
        filterRanges accum needles hays = fromMaybe accum do
          needles' ← Arr.uncons needles
          hays' ← Arr.uncons hays
          pure
            $ if eqRangeRec hays'.head needles'.head
            -- Note that we use stuff from hays, because it has endColumn and endRow
              then
                filterRanges
                  (Arr.snoc
                     accum
                     hays'.head{ endColumn = hays'.head.endColumn
                                             + lenDiff
                                             + hays'.head.startRow
                                             - one
                               , startColumn = hays'.head.startColumn
                                               - hays'.head.startRow
                                               - one
                               })
                  needles'.tail
                  hays
              else
                filterRanges
                  (Arr.snoc accum hays'.head)
                  needles
                  hays'.tail

        newText ∷ String
        newText = S.replace pat replacement m.text

        newRanges ∷ Array RangeRec
        newRanges
          | newText ≠ m.text  =
            filterRanges [ ] initialRanges $ sortRangeRecs m.ranges
          | otherwise = m.ranges
      in
        if newText ≡ m.text
          then Nothing
          else pure $ CM.Ace mode { text: newText, ranges: newRanges }

    _ → Nothing

delete
  ∷ ∀ f m
  . MonadAff SlamDataEffects m
  ⇒ MonadFork Error m
  ⇒ QuasarDSL m
  ⇒ Parallel f m
  ⇒ R.Resource
  → m (Either QError (Maybe R.Resource))
delete resource =
  runExceptT $
    if R.isMount resource || alreadyInTrash resource
    then
      forceDelete resource $> Nothing
    else
      moveToTrash resource `catchError` \(err ∷ QError) →
        forceDelete resource $> Nothing

  where
  msg ∷ String
  msg = "cannot delete"

  moveToTrash
    ∷ R.Resource
    → ExceptT QError m (Maybe R.Resource)
  moveToTrash res = do
    let
      d = (res ^. R._root) </> P.dir Config.trashFolder
      path = (res # R._root .~ d) ^. R._path
    name ← ExceptT $ getNewName d (res ^. R._name)
    _ ← ExceptT $ move res (path # R._nameAnyPath .~ name)
    pure ∘ Just $ R.Directory d

  alreadyInTrash ∷ R.Resource → Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left path → alreadyInTrash' path
      Right _ → alreadyInTrash' (res ^. R._root)

  alreadyInTrash' ∷ DirPath → Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

    where
    go ∷ Tuple DirPath (Either P.DirName P.FileName) → Boolean
    go (Tuple d' name) =
      case name of
        Right _ → false
        Left n →
          if n == P.DirName Config.trashFolder
          then true
          else alreadyInTrash' d'

forceDelete
  ∷ ∀ f m
  . QuasarDSL m
  ⇒ Parallel f m
  ⇒ R.Resource
  → ExceptT QError m Unit
forceDelete res =
  case res of
    R.Mount _ →
      ExceptT ∘ liftQuasar $ QF.deleteMount (R.getPath res)
    _ → do
      let path = R.getPath res
      traverse_ cleanViewMounts $ path ^? _Left
      ExceptT ∘ liftQuasar $ QF.deleteData path

cleanViewMounts
  ∷ ∀ f m
  . Parallel f m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → ExceptT QError m Unit
cleanViewMounts =
  parTraverse_ deleteViewMount <=< ExceptT ∘ transitiveChildren
  where
  deleteViewMount ∷ R.Resource → ExceptT QError m Unit
  deleteViewMount =
    case _ of
      R.Mount (R.View vp) →
        ExceptT ∘ liftQuasar $ QF.deleteMount (Right vp)
      _ → pure unit

messageIfFileNotFound
  ∷ ∀ a m
  . Functor m
  ⇒ QuasarDSL m
  ⇒ FilePath
  → a
  → m (Either QError (Maybe a))
messageIfFileNotFound path defaultMsg =
  handleResult <$> liftQuasar (QF.fileMetadata path)
  where
  handleResult ∷ ∀ b. Either QF.QError b → Either QError (Maybe a)
  handleResult (Left QF.NotFound) = Right (Just defaultMsg)
  handleResult (Left err) = Left err
  handleResult (Right _) = Right Nothing

dirNotAccessible
  ∷ ∀ m
  . Functor m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → m (Maybe QF.QError)
dirNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.dirMetadata path)

fileNotAccessible
  ∷ ∀ m
  . Functor m
  ⇒ QuasarDSL m
  ⇒ FilePath
  → m (Maybe QF.QError)
fileNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.fileMetadata path)

{-
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.Quasar.FS
  ( children
  , getNewName
  , move
  , listing
  , delete
  , messageIfFileNotFound
  , dirNotAccessible
  , fileNotAccessible
  , module Quasar.Error
  ) where

import SlamData.Prelude

import Control.Monad.Aff.Class (class MonadAff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Fork (class MonadFork)

import Data.Array as Arr
import Data.Foldable as F
import Data.Lens ((.~), (^.), (^?), _Left)
import Data.List as List
import Data.Map as Map
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String as S

import Quasar.Advanced.QuasarAF as QF
import Quasar.Error (QError(..))
import Quasar.FS as QFS
import Quasar.FS.Mount as QFSM
import Quasar.FS.Resource as QR
import Quasar.Types (AnyPath, DirPath, FilePath)

import SlamData.Config as Config
import SlamData.Effects (SlamDataEffects)
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL, liftQuasar)
import SlamData.Quasar.Data as QD

import SlamData.Workspace.Legacy (isLegacy, loadCompatWorkspace, pruneLegacyData)
import SlamData.Workspace.Model as WM
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Open.Model as Open

import Utils.Array (enumerate)
import Utils.Ace (RangeRec)

children
  ∷ ∀ m
  . Monad m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
children dir = runExceptT do
  cs ← ExceptT $ listing dir
  let result = (R._root .~ dir) <$> cs
  -- TODO: do this somewhere more appropriate
  -- lift $ fromAff $ memoizeCompletionStrs dir result
  pure result

transitiveChildren
  ∷ ∀ f m
  . Parallel f m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
transitiveChildren start = runExceptT do
  rs ← ExceptT $ children start
  cs ← parTraverse go rs
  pure $ rs <> join cs
  where
  go ∷ R.Resource → ExceptT QError m (Array R.Resource)
  go r = case R.getPath r of
    Left dir → do
      crs ← ExceptT $ transitiveChildren dir
      pure $ [r] <> crs
    Right _ → pure [r]

listing
  ∷ ∀ m
  . Functor m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
listing p =
  map (map toResource) <$> liftQuasar (QF.dirMetadata p)
  where
  toResource ∷ QFS.Resource → R.Resource
  toResource res = case res of
    QFS.File path → R.File path
    QFS.Directory path →
      let workspaceName
            = S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension)
            ∘ P.runDirName =<< P.dirName path
      in case workspaceName of
        Just name → R.Workspace (p </> P.dir name)
        Nothing → R.Directory path
    QFS.Mount m → R.Mount $ either R.Database R.View $ QFSM.getPath m

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  ∷ ∀ m
  . Monad m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → String
  → m (Either QError String)
getNewName parent name = do
  result ← liftQuasar (QF.dirMetadata parent)
  pure case result of
    Right items
      | exists name items → Right (getNewName' items 1)
      | otherwise → Right name
    Left QF.NotFound → Right name
    Left err → Left err
  where

  getNewName' ∷ Array QFS.Resource → Int → String
  getNewName' items i =
    let arr = S.split (S.Pattern ".") name
    in fromMaybe "" do
      body ← Arr.head arr
      suffixes ← Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists newName items
           then getNewName' items (i + one)
           else newName

  exists ∷ String → Array QFS.Resource → Boolean
  exists n = F.any ((_ == n) ∘ printName ∘ QR.getName)

  printName ∷ Either (Maybe P.DirName) P.FileName → String
  printName = either (fromMaybe "" ∘ map P.runDirName) P.runFileName

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  ∷ ∀ f m
  . MonadAff SlamDataEffects m
  ⇒ MonadFork Error m
  ⇒ QuasarDSL m
  ⇒ Parallel f m
  ⇒ R.Resource
  → AnyPath
  → m (Either QError (Maybe AnyPath))
move src tgt = do
  let
    srcPath = R.getPath src

  _ ← runExceptT ∘ traverse_ cleanViewMounts $ srcPath ^? _Left

  _ ← runExceptT case src of
    R.Workspace wsDir → replacePathsInWorkspace wsDir
    _ → pure unit

  result ←
    case src of
      R.Mount _ → liftQuasar $ QF.moveMount srcPath tgt
      _ → liftQuasar $ QF.moveData srcPath tgt

  pure
    case result of
      Right _ → Right (Just tgt)
      Left QF.NotFound → Right Nothing
      Left err → Left err

  where
  replacePathsInWorkspace ∷ DirPath → ExceptT QError m Unit
  replacePathsInWorkspace wsDir = do
    stat × ws ← ExceptT $ loadCompatWorkspace wsDir
    let
      updated =
        ws.cards
          # Map.toUnfoldable
          # List.mapMaybe (sequence ∘ map (replacePaths wsDir))
          # Map.fromFoldable
      ws' = ws { cards = Map.union updated ws.cards }
    unless (Map.isEmpty updated) $ putWorkspace wsDir ws
    when (isLegacy stat) $ void $ lift $ pruneLegacyData wsDir

  putWorkspace ∷ DirPath → WM.Workspace → ExceptT QError m Unit
  putWorkspace wsDir ws =
    ExceptT $ QD.save (wsDir </> P.file "index") $ WM.encode ws

  replacePaths ∷ DirPath → CM.AnyCardModel → Maybe CM.AnyCardModel
  replacePaths wsDir = case _ of
    CM.Cache m →
      let
        newM =
          S.replace
            (S.Pattern $ P.printPath wsDir)
            (S.Replacement $ either P.printPath P.printPath tgt)
            <$> m
      in
        if newM ≡ m
          then Nothing
          else pure $ CM.Cache newM
    CM.Open (Just (Open.Resource r)) →
      let
        newR = fromMaybe r do
          rel ←
            bisequence
              $ bimap (flip P.relativeTo wsDir) (flip P.relativeTo wsDir)
              $ R.getPath r
          tgtDir ← either Just (const Nothing) tgt
          let
            newP =
              bimap P.canonicalize P.canonicalize
              $ bimap (tgtDir </> _) (tgtDir </> _) rel
          pure $ R.setPath r newP
      in
        if newR ≡ r
          then Nothing
          else pure $ CM.Open (Just (Open.Resource newR))
    CM.Ace mode m →
      let
        wsStr ∷ String
        wsStr = P.printPath wsDir

        pat ∷ S.Pattern
        pat = S.Pattern wsStr

        tgtStr ∷ String
        tgtStr = either P.printPath P.printPath tgt

        replacement ∷ S.Replacement
        replacement = S.Replacement tgtStr

        srcLen ∷ Int
        srcLen = S.length wsStr

        tgtLen ∷ Int
        tgtLen = S.length tgtStr

        lenDiff ∷ Int
        lenDiff = tgtLen - srcLen

        sortRangeRecs ∷ Array RangeRec → Array RangeRec
        sortRangeRecs =
          Arr.sortBy \a b →
            compare a.startRow b.startRow
            ⊕ compare a.startColumn b.startColumn

        -- We don't care about endings
        eqRangeRec ∷ RangeRec → RangeRec → Boolean
        eqRangeRec a b =
          -- That's a bug workaround, modification of ace field for whatever reason
          -- removes one space left padding :(
          (a.startColumn ≡ b.startColumn
           ∨ a.startColumn + one ≡ b.startColumn
           ∨ a.startColumn - one ≡ b.startColumn)
          ∧ a.startRow ≡ b.startRow

        substrIndices
          ∷ S.Pattern
          → Array (Int × String)
          → Array RangeRec
        substrIndices needle =
          sortRangeRecs ∘ foldl foldRanges [ ]
          where
          findStartColumns ∷ Array Int → String → Array Int
          findStartColumns accum hay =
            case S.indexOf needle hay of
              Nothing → accum
              Just i → findStartColumns (Arr.cons i accum) $ S.drop (i + srcLen) hay

          foldRanges
            ∷ Array RangeRec
            → Int × String
            → Array RangeRec
          foldRanges accum (startRow × hay) =
            let
              starts = findStartColumns [] hay
              fromKWlen = 6
              mkRange start =
                [ { startColumn: start - fromKWlen
                  , endColumn: 0
                  , startRow
                  , endRow: startRow
                  } ]
            in
             foldMap mkRange starts ⊕ accum

        initialRanges ∷ Array RangeRec
        initialRanges = substrIndices pat $ enumerate $ S.split (S.Pattern "\n") m.text

        -- inputs must be sorted
        filterRanges
          ∷ Array RangeRec
          → Array RangeRec
          → Array RangeRec
          → Array RangeRec
        filterRanges accum needles hays = fromMaybe accum do
          needles' ← Arr.uncons needles
          hays' ← Arr.uncons hays
          pure
            $ if eqRangeRec hays'.head needles'.head
            -- Note that we use stuff from hays, because it has endColumn and endRow
              then
                filterRanges
                  (Arr.snoc
                     accum
                     hays'.head{ endColumn = hays'.head.endColumn
                                             + lenDiff
                                             + hays'.head.startRow
                                             - one
                               , startColumn = hays'.head.startColumn
                                               - hays'.head.startRow
                                               - one
                               })
                  needles'.tail
                  hays
              else
                filterRanges
                  (Arr.snoc accum hays'.head)
                  needles
                  hays'.tail

        newText ∷ String
        newText = S.replace pat replacement m.text

        newRanges ∷ Array RangeRec
        newRanges
          | newText ≠ m.text  =
            filterRanges [ ] initialRanges $ sortRangeRecs m.ranges
          | otherwise = m.ranges
      in
        if newText ≡ m.text
          then Nothing
          else pure $ CM.Ace mode { text: newText, ranges: newRanges }

    _ → Nothing

delete
  ∷ ∀ f m
  . MonadAff SlamDataEffects m
  ⇒ MonadFork Error m
  ⇒ QuasarDSL m
  ⇒ Parallel f m
  ⇒ R.Resource
  → m (Either QError (Maybe R.Resource))
delete resource =
  runExceptT $
    if R.isMount resource || alreadyInTrash resource
    then
      forceDelete resource $> Nothing
    else
      moveToTrash resource `catchError` \(err ∷ QError) →
        forceDelete resource $> Nothing

  where
  msg ∷ String
  msg = "cannot delete"

  moveToTrash
    ∷ R.Resource
    → ExceptT QError m (Maybe R.Resource)
  moveToTrash res = do
    let
      d = (res ^. R._root) </> P.dir Config.trashFolder
      path = (res # R._root .~ d) ^. R._path
    name ← ExceptT $ getNewName d (res ^. R._name)
    _ ← ExceptT $ move res (path # R._nameAnyPath .~ name)
    pure ∘ Just $ R.Directory d

  alreadyInTrash ∷ R.Resource → Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left path → alreadyInTrash' path
      Right _ → alreadyInTrash' (res ^. R._root)

  alreadyInTrash' ∷ DirPath → Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

    where
    go ∷ Tuple DirPath (Either P.DirName P.FileName) → Boolean
    go (Tuple d' name) =
      case name of
        Right _ → false
        Left n →
          if n == P.DirName Config.trashFolder
          then true
          else alreadyInTrash' d'

forceDelete
  ∷ ∀ f m
  . QuasarDSL m
  ⇒ Parallel f m
  ⇒ R.Resource
  → ExceptT QError m Unit
forceDelete res =
  case res of
    R.Mount _ →
      ExceptT ∘ liftQuasar $ QF.deleteMount (R.getPath res)
    _ → do
      let path = R.getPath res
      traverse_ cleanViewMounts $ path ^? _Left
      ExceptT ∘ liftQuasar $ QF.deleteData path

cleanViewMounts
  ∷ ∀ f m
  . Parallel f m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → ExceptT QError m Unit
cleanViewMounts =
  parTraverse_ deleteViewMount <=< ExceptT ∘ transitiveChildren
  where
  deleteViewMount ∷ R.Resource → ExceptT QError m Unit
  deleteViewMount =
    case _ of
      R.Mount (R.View vp) →
        ExceptT ∘ liftQuasar $ QF.deleteMount (Right vp)
      _ → pure unit

messageIfFileNotFound
  ∷ ∀ m
  . Functor m
  ⇒ QuasarDSL m
  ⇒ FilePath
  → String
  → m (Either QError (Maybe String))
messageIfFileNotFound path defaultMsg =
  handleResult <$> liftQuasar (QF.fileMetadata path)
  where
  handleResult ∷ ∀ a. Either QF.QError a → Either QError (Maybe String)
  handleResult (Left QF.NotFound) = Right (Just defaultMsg)
  handleResult (Left err) = Left err
  handleResult (Right _) = Right Nothing

dirNotAccessible
  ∷ ∀ m
  . Functor m
  ⇒ QuasarDSL m
  ⇒ DirPath
  → m (Maybe QF.QError)
dirNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.dirMetadata path)

fileNotAccessible
  ∷ ∀ m
  . Functor m
  ⇒ QuasarDSL m
  ⇒ FilePath
  → m (Maybe QF.QError)
fileNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.fileMetadata path)


actually fix it

actually fix it

module Test.Chai
  ( Chai(..), Error(..)
  , expect, Expect(..), Expectation(..)
  , toEqual, toNotEqual
  , toDeepEqual, toNotDeepEqual, toEql, toNotEql
  , toBeAbove, toNotBeAbove, toBeAtLeast, toNotBeAtLeast
  , toBeBelow, toNotBeBelow, toBeAtMost, toNotBeAtMost
  , toInclude, toNotInclude
  , toThrow, toNotThrow, ErrorExpectation(..)) where

import Control.Monad.Eff
import Data.Foreign.EasyFFI

foreign import data Chai :: !
data Expect              = Expect
data Error               = Error

foreign import chai
  """var chai = (function() {
    if (typeof window === 'undefined') {
      // this is Node.js
      return require('chai');
    } else {
      // in the browser; `chai` should already be defined on `window`
      return window.chai;
    }
  })()"""
  :: forall a. a

expect                   :: forall a. a -> Expect
expect                   = unsafeForeignFunction ["chai", "source"] "chai.expect(source)" $ chai

type Expectation         = forall a e. Expect -> a -> Eff (chai :: Chai | e) Unit
bindExpectation        x = unsafeForeignProcedure ["expect", "target", ""] $ "expect." ++ x ++ "(target)"

toEqual                  :: Expectation
toEqual                  = bindExpectation "to.equal"
toNotEqual               :: Expectation
toNotEqual               = bindExpectation "to.not.equal"

toDeepEqual              :: Expectation
toDeepEqual              = bindExpectation "to.deep.equal"
toNotDeepEqual           :: Expectation
toNotDeepEqual           = bindExpectation "to.not.deep.equal"

toEql                    :: Expectation
toEql                    = bindExpectation "to.eql"
toNotEql                 :: Expectation
toNotEql                 = bindExpectation "to.not.eql"

toBeAbove                :: Expectation
toBeAbove                = bindExpectation "to.be.above"
toNotBeAbove             :: Expectation
toNotBeAbove             = bindExpectation "to.not.be.above"

toBeAtLeast              :: Expectation
toBeAtLeast              = bindExpectation "to.be.at.least"
toNotBeAtLeast           :: Expectation
toNotBeAtLeast           = bindExpectation "to.not.be.at.least"

toBeBelow                :: Expectation
toBeBelow                = bindExpectation "to.be.below"
toNotBeBelow             :: Expectation
toNotBeBelow             = bindExpectation "to.not.be.below"

toBeAtMost               :: Expectation
toBeAtMost               = bindExpectation "to.be.at.most"
toNotBeAtMost            :: Expectation
toNotBeAtMost            = bindExpectation "to.not.be.at.most"

toInclude                :: Expectation
toInclude                = bindExpectation "to.include"
toNotInclude             :: Expectation
toNotInclude             = bindExpectation "to.not.include"

type ErrorExpectation    = forall eff. Expect -> Error -> Eff (chai :: Chai | eff) Unit

toThrow                  :: ErrorExpectation
toThrow                  = unsafeForeignProcedure ["expect", "", ""] "expect.to.throw(Error)"
toNotThrow               :: ErrorExpectation
toNotThrow               = unsafeForeignProcedure ["expect", "", ""] "expect.to.not.throw(Error)"

module Test.Chai
  ( Chai(..), Error(..)
  , expect, Expect(..), Expectation(..)
  , toEqual, toNotEqual
  , toDeepEqual, toNotDeepEqual, toEql, toNotEql
  , toBeAbove, toNotBeAbove, toBeAtLeast, toNotBeAtLeast
  , toBeBelow, toNotBeBelow, toBeAtMost, toNotBeAtMost
  , toInclude, toNotInclude
  , toThrow, toNotThrow, ErrorExpectation(..)) where

import Control.Monad.Eff
import Data.Foreign.EasyFFI

foreign import data Chai :: !
data Expect              = Expect
data Error               = Error

foreign import chai
  "var chai = typeof chai === 'undefined' ? require('chai') : chai"
  :: forall a. a

expect                   :: forall a. a -> Expect
expect                   = unsafeForeignFunction ["chai", "source", ""] "chai.expect(source)" $ chai

type Expectation         = forall a e. Expect -> a -> Eff (chai :: Chai | e) Unit
bindExpectation        x = unsafeForeignProcedure ["expect", "target", ""] $ "expect." ++ x ++ "(target)"

toEqual                  :: Expectation
toEqual                  = bindExpectation "to.equal"
toNotEqual               :: Expectation
toNotEqual               = bindExpectation "to.not.equal"

toDeepEqual              :: Expectation
toDeepEqual              = bindExpectation "to.deep.equal"
toNotDeepEqual           :: Expectation
toNotDeepEqual           = bindExpectation "to.not.deep.equal"

toEql                    :: Expectation
toEql                    = bindExpectation "to.eql"
toNotEql                 :: Expectation
toNotEql                 = bindExpectation "to.not.eql"

toBeAbove                :: Expectation
toBeAbove                = bindExpectation "to.be.above"
toNotBeAbove             :: Expectation
toNotBeAbove             = bindExpectation "to.not.be.above"

toBeAtLeast              :: Expectation
toBeAtLeast              = bindExpectation "to.be.at.least"
toNotBeAtLeast           :: Expectation
toNotBeAtLeast           = bindExpectation "to.not.be.at.least"

toBeBelow                :: Expectation
toBeBelow                = bindExpectation "to.be.below"
toNotBeBelow             :: Expectation
toNotBeBelow             = bindExpectation "to.not.be.below"

toBeAtMost               :: Expectation
toBeAtMost               = bindExpectation "to.be.at.most"
toNotBeAtMost            :: Expectation
toNotBeAtMost            = bindExpectation "to.not.be.at.most"

toInclude                :: Expectation
toInclude                = bindExpectation "to.include"
toNotInclude             :: Expectation
toNotInclude             = bindExpectation "to.not.include"

type ErrorExpectation    = forall eff. Expect -> Error -> Eff (chai :: Chai | eff) Unit

toThrow                  :: ErrorExpectation
toThrow                  = unsafeForeignProcedure ["expect", "", ""] "expect.to.throw(Error)"
toNotThrow               :: ErrorExpectation
toNotThrow               = unsafeForeignProcedure ["expect", "", ""] "expect.to.not.throw(Error)"


Missing empty function wrapper for Eff

Missing empty function wrapper for Eff

module Data.Date
  ( JSDate()
  , Now()
  , Date()
  , Year()
  , Month(..)
  , Day()
  , DayOfWeek()
  , Hours()
  , Minutes()
  , Seconds()
  , Milliseconds()
  , fromJSDate
  , toJSDate
  , now
  , dateTime
  , date
  , year
  , yearUTC
  , month
  , monthUTC
  , day
  , dayUTC
  , dayOfWeek
  , dayOfWeekUTC
  , hour
  , hourUTC
  , minute
  , minuteUTC
  , second
  , secondUTC
  , millisecond
  , millisecondUTC
  , timezoneOffset
  , toEpochMilliseconds
  , fromEpochMilliseconds
  , fromString
  , fromStringStrict
  ) where

import Control.Monad.Eff
import Data.Enum
import Data.Maybe
import Data.Function
import qualified Data.Maybe.Unsafe as U

foreign import jsDateMethod
  "function jsDateMethod(method) { \
  \  return function(date) { \
  \    return date[method](); \
  \  }; \
  \}" :: forall a. String -> JSDate -> a

foreign import jsDateConstructor
  "function jsDateConstructor(x) { \
  \  return new Date(x); \
  \}" :: forall a. a -> JSDate

foreign import strictJsDate
  """function strictJsDate(Just, Nothing, s) {
    var epoch = Date.parse(s);
    if (isNaN(epoch)) return Nothing;
    var date = new Date(epoch);
    var s2 = date.toISOString();
    var idx = s2.indexOf(s);
    if (idx < 0) return Nothing;
    else return Just(date);
  }""" :: Fn3 (forall a. a -> Maybe a) (forall a. Maybe a) String (Maybe JSDate)

foreign import jsDateFromRecord
  "function jsDateFromRecord(r) {\
  \  return new Date(r.year, r.month, r.day, r.hours, r.minutes, r.seconds, r.milliseconds); \
  \}" :: { year :: Number
         , month :: Number
         , day :: Number
         , hours :: Number
         , minutes :: Number
         , seconds :: Number
         , milliseconds :: Number } -> JSDate

foreign import data JSDate :: *
foreign import data Now :: !

data Date = DateTime JSDate

instance eqDate :: Eq Date where
  (==) = liftOp (==)
  (/=) = liftOp (/=)

instance ordDate :: Ord Date where
  compare = liftOp compare

liftOp :: forall b. (Number -> Number -> b) -> Date -> Date -> b
liftOp op x y = toEpochMilliseconds x `op` toEpochMilliseconds y

type Year = Number

data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

type Day = Number

data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

type Hours = Number
type Minutes = Number
type Seconds = Number
type Milliseconds = Number

instance eqMonth :: Eq Month where
  (==) January January = true
  (==) February February = true
  (==) March March = true
  (==) April April = true
  (==) May May = true
  (==) June June = true
  (==) July July = true
  (==) August August = true
  (==) September September = true
  (==) October October = true
  (==) November November = true
  (==) December December = true
  (==) _ _ = false

  (/=) a b = not (a == b)

instance ordMonth :: Ord Month where
  compare a b = compare (fromEnum a) (fromEnum b)

instance enumMonth :: Enum Month where
  cardinality = Cardinality 12

  firstEnum = January

  lastEnum = December

  succ January    = Just February
  succ February   = Just March
  succ March      = Just April
  succ April      = Just May
  succ May        = Just June
  succ June       = Just July
  succ July       = Just August
  succ August     = Just September
  succ September  = Just October
  succ October    = Just November
  succ November   = Just December
  succ December   = Nothing

  pred January    = Nothing
  pred February   = Just January
  pred March      = Just February
  pred April      = Just March
  pred May        = Just April
  pred June       = Just May
  pred July       = Just June
  pred August     = Just July
  pred September  = Just August
  pred October    = Just September
  pred November   = Just October
  pred December   = Just November

instance showMonth :: Show Month where
  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance eqDayOfWeek :: Eq DayOfWeek where
  (==) Sunday Sunday = true
  (==) Monday Monday = true
  (==) Tuesday Tuesday = true
  (==) Wednesday Wednesday = true
  (==) Thursday Thursday = true
  (==) Friday Friday = true
  (==) Saturday Saturday = true
  (==) _ _ = false

  (/=) a b = not (a == b)

instance ordDayOfWeek :: Ord DayOfWeek where
  compare a b = compare (fromEnum a) (fromEnum b)

instance enumDayOfWeek :: Enum DayOfWeek where
  cardinality = Cardinality 7

  firstEnum = Sunday

  lastEnum = Saturday

  succ Sunday     = Just Monday
  succ Monday     = Just Tuesday
  succ Tuesday    = Just Wednesday
  succ Wednesday  = Just Thursday
  succ Thursday   = Just Friday
  succ Friday     = Just Saturday
  succ Saturday   = Nothing

  pred Sunday     = Nothing
  pred Monday     = Just Sunday
  pred Tuesday    = Just Monday
  pred Wednesday  = Just Tuesday
  pred Thursday   = Just Wednesday
  pred Friday     = Just Thursday
  pred Saturday   = Just Friday

instance showDayOfWeek :: Show DayOfWeek where
  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

fromJSDate :: JSDate -> Maybe Date
fromJSDate d = if Global.isNaN (jsDateMethod "getTime" d)
               then Nothing
               else Just $ DateTime d

toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

liftDate :: forall a. (JSDate -> a) -> Date -> a
liftDate f (DateTime d) = f d

foreign import nowImpl """
  function nowImpl(f) {
    return function(){
      return f(new Date());
    };
  }
  """ :: forall e. (JSDate -> Date) -> Eff (now :: Now | e) Date

now :: forall e. Eff (now :: Now | e) Date
now = nowImpl DateTime

dateTime :: Year -> Month -> Day
         -> Hours -> Minutes -> Seconds -> Milliseconds
         -> Maybe Date
dateTime y m d h n s ms =
  fromJSDate $ jsDateFromRecord { year: y
                                , month: (fromEnum m)
                                , day: d
                                , hours: h
                                , minutes: n
                                , seconds: s
                                , milliseconds: ms }

date :: Year -> Month -> Day -> Maybe Date
date y m d = dateTime y m d 0 0 0 0

year :: Date -> Year
year = liftDate $ jsDateMethod "getFullYear"

yearUTC :: Date -> Year
yearUTC = liftDate $ jsDateMethod "getUTCFullYear"

month :: Date -> Month
month = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getMonth")

monthUTC :: Date -> Month
monthUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCMonth")

day :: Date -> Day
day = liftDate $ jsDateMethod "getDate"

dayUTC :: Date -> Day
dayUTC = liftDate $ jsDateMethod "getUTCDate"

dayOfWeek :: Date -> DayOfWeek
dayOfWeek = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getDay")

dayOfWeekUTC :: Date -> DayOfWeek
dayOfWeekUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCDay")

hour :: Date -> Hours
hour = liftDate $ jsDateMethod "getHours"

hourUTC :: Date -> Hours
hourUTC = liftDate $ jsDateMethod "getUTCHours"

minute :: Date -> Minutes
minute = liftDate $ jsDateMethod "getMinutes"

minuteUTC :: Date -> Minutes
minuteUTC = liftDate $ jsDateMethod "getUTCMinutes"

second :: Date -> Seconds
second = liftDate $ jsDateMethod "getSeconds"

secondUTC :: Date -> Seconds
secondUTC = liftDate $ jsDateMethod "getUTCSeconds"

millisecond :: Date -> Seconds
millisecond = liftDate $ jsDateMethod "getMilliseconds"

millisecondUTC :: Date -> Seconds
millisecondUTC = liftDate $ jsDateMethod "getUTCMilliseconds"

timezoneOffset :: Date -> Minutes
timezoneOffset = liftDate $ jsDateMethod "getTimezoneOffset"

toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds = liftDate $ jsDateMethod "getTime"

fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

fromStringStrict :: String -> Maybe Date
fromStringStrict s = runFn3 strictJsDate Just Nothing s >>= fromJSDate

instance showDate :: Show Date where
  show = liftDate $ jsDateMethod "toString"

module Data.Date
  ( JSDate()
  , Now()
  , Date()
  , Year()
  , Month(..)
  , Day()
  , DayOfWeek()
  , Hours()
  , Minutes()
  , Seconds()
  , Milliseconds()
  , fromJSDate
  , toJSDate
  , now
  , dateTime
  , date
  , year
  , yearUTC
  , month
  , monthUTC
  , day
  , dayUTC
  , dayOfWeek
  , dayOfWeekUTC
  , hour
  , hourUTC
  , minute
  , minuteUTC
  , second
  , secondUTC
  , millisecond
  , millisecondUTC
  , timezoneOffset
  , toEpochMilliseconds
  , fromEpochMilliseconds
  , fromString
  , fromStringStrict
  ) where

import Control.Monad.Eff
import Data.Enum
import Data.Maybe
import Data.Function
import qualified Data.Maybe.Unsafe as U

foreign import jsDateMethod
  "function jsDateMethod(method) { \
  \  return function(date) { \
  \    return date[method](); \
  \  }; \
  \}" :: forall a. String -> JSDate -> a

foreign import jsDateConstructor
  "function jsDateConstructor(x) { \
  \  return new Date(x); \
  \}" :: forall a. a -> JSDate

foreign import strictJsDate
  """function strictJsDate(Just, Nothing, s) {
    var epoch = Date.parse(s);
    if (isNaN(epoch)) return Nothing;
    var date = new Date(epoch);
    var s2 = date.toISOString();
    var idx = s2.indexOf(s);
    if (idx < 0) return Nothing;
    else return Just(date);
  }""" :: Fn3 (forall a. a -> Maybe a) (forall a. Maybe a) String (Maybe JSDate)

foreign import jsDateFromRecord
  "function jsDateFromRecord(r) {\
  \  return new Date(r.year, r.month, r.day, r.hours, r.minutes, r.seconds, r.milliseconds); \
  \}" :: { year :: Number
         , month :: Number
         , day :: Number
         , hours :: Number
         , minutes :: Number
         , seconds :: Number
         , milliseconds :: Number } -> JSDate

foreign import data JSDate :: *
foreign import data Now :: !

data Date = DateTime JSDate

instance eqDate :: Eq Date where
  (==) = liftOp (==)
  (/=) = liftOp (/=)

instance ordDate :: Ord Date where
  compare = liftOp compare

liftOp :: forall b. (Number -> Number -> b) -> Date -> Date -> b
liftOp op x y = toEpochMilliseconds x `op` toEpochMilliseconds y

type Year = Number

data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

type Day = Number

data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

type Hours = Number
type Minutes = Number
type Seconds = Number
type Milliseconds = Number

instance eqMonth :: Eq Month where
  (==) January January = true
  (==) February February = true
  (==) March March = true
  (==) April April = true
  (==) May May = true
  (==) June June = true
  (==) July July = true
  (==) August August = true
  (==) September September = true
  (==) October October = true
  (==) November November = true
  (==) December December = true
  (==) _ _ = false

  (/=) a b = not (a == b)

instance ordMonth :: Ord Month where
  compare a b = compare (fromEnum a) (fromEnum b)

instance enumMonth :: Enum Month where
  cardinality = Cardinality 12

  firstEnum = January

  lastEnum = December

  succ January    = Just February
  succ February   = Just March
  succ March      = Just April
  succ April      = Just May
  succ May        = Just June
  succ June       = Just July
  succ July       = Just August
  succ August     = Just September
  succ September  = Just October
  succ October    = Just November
  succ November   = Just December
  succ December   = Nothing

  pred January    = Nothing
  pred February   = Just January
  pred March      = Just February
  pred April      = Just March
  pred May        = Just April
  pred June       = Just May
  pred July       = Just June
  pred August     = Just July
  pred September  = Just August
  pred October    = Just September
  pred November   = Just October
  pred December   = Just November

instance showMonth :: Show Month where
  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance eqDayOfWeek :: Eq DayOfWeek where
  (==) Sunday Sunday = true
  (==) Monday Monday = true
  (==) Tuesday Tuesday = true
  (==) Wednesday Wednesday = true
  (==) Thursday Thursday = true
  (==) Friday Friday = true
  (==) Saturday Saturday = true
  (==) _ _ = false

  (/=) a b = not (a == b)

instance ordDayOfWeek :: Ord DayOfWeek where
  compare a b = compare (fromEnum a) (fromEnum b)

instance enumDayOfWeek :: Enum DayOfWeek where
  cardinality = Cardinality 7

  firstEnum = Sunday

  lastEnum = Saturday

  succ Sunday     = Just Monday
  succ Monday     = Just Tuesday
  succ Tuesday    = Just Wednesday
  succ Wednesday  = Just Thursday
  succ Thursday   = Just Friday
  succ Friday     = Just Saturday
  succ Saturday   = Nothing

  pred Sunday     = Nothing
  pred Monday     = Just Sunday
  pred Tuesday    = Just Monday
  pred Wednesday  = Just Tuesday
  pred Thursday   = Just Wednesday
  pred Friday     = Just Thursday
  pred Saturday   = Just Friday

instance showDayOfWeek :: Show DayOfWeek where
  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

fromJSDate :: JSDate -> Maybe Date
fromJSDate d = if Global.isNaN (jsDateMethod "getTime" d)
               then Nothing
               else Just $ DateTime d

toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

liftDate :: forall a. (JSDate -> a) -> Date -> a
liftDate f (DateTime d) = f d

foreign import nowImpl
  "function nowImpl(f) { \
  \  return f(new Date()); \
  \}" :: forall e. (JSDate -> Date) -> Eff (now :: Now | e) Date

now :: forall e. Eff (now :: Now | e) Date
now = nowImpl DateTime

dateTime :: Year -> Month -> Day
         -> Hours -> Minutes -> Seconds -> Milliseconds
         -> Maybe Date
dateTime y m d h n s ms =
  fromJSDate $ jsDateFromRecord { year: y
                                , month: (fromEnum m)
                                , day: d
                                , hours: h
                                , minutes: n
                                , seconds: s
                                , milliseconds: ms }

date :: Year -> Month -> Day -> Maybe Date
date y m d = dateTime y m d 0 0 0 0

year :: Date -> Year
year = liftDate $ jsDateMethod "getFullYear"

yearUTC :: Date -> Year
yearUTC = liftDate $ jsDateMethod "getUTCFullYear"

month :: Date -> Month
month = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getMonth")

monthUTC :: Date -> Month
monthUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCMonth")

day :: Date -> Day
day = liftDate $ jsDateMethod "getDate"

dayUTC :: Date -> Day
dayUTC = liftDate $ jsDateMethod "getUTCDate"

dayOfWeek :: Date -> DayOfWeek
dayOfWeek = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getDay")

dayOfWeekUTC :: Date -> DayOfWeek
dayOfWeekUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCDay")

hour :: Date -> Hours
hour = liftDate $ jsDateMethod "getHours"

hourUTC :: Date -> Hours
hourUTC = liftDate $ jsDateMethod "getUTCHours"

minute :: Date -> Minutes
minute = liftDate $ jsDateMethod "getMinutes"

minuteUTC :: Date -> Minutes
minuteUTC = liftDate $ jsDateMethod "getUTCMinutes"

second :: Date -> Seconds
second = liftDate $ jsDateMethod "getSeconds"

secondUTC :: Date -> Seconds
secondUTC = liftDate $ jsDateMethod "getUTCSeconds"

millisecond :: Date -> Seconds
millisecond = liftDate $ jsDateMethod "getMilliseconds"

millisecondUTC :: Date -> Seconds
millisecondUTC = liftDate $ jsDateMethod "getUTCMilliseconds"

timezoneOffset :: Date -> Minutes
timezoneOffset = liftDate $ jsDateMethod "getTimezoneOffset"

toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds = liftDate $ jsDateMethod "getTime"

fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

fromStringStrict :: String -> Maybe Date
fromStringStrict s = runFn3 strictJsDate Just Nothing s >>= fromJSDate

instance showDate :: Show Date where
  show = liftDate $ jsDateMethod "toString"