Add more tests

Add more tests

module Test.Spec.SolverSpec (solverSpec) where

import Prelude
import Debug.Trace
import Data.Either (Either(..), either, fromRight)
import Control.Bind ((=<<))
import Control.Apply ((*>))
import Data.List (List(..), fromFoldable)
import Data.Bifunctor (lmap, rmap)
import Control.Plus (empty)
import Data.Foldable (intercalate, for_)
import Data.Traversable (for)
import Control.Monad.Eff.Exception (error, throwException)
import Data.Array as A
import Data.Maybe (Maybe(..), maybe)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)

import Test.Support (vliftEff, runEitherEff)
import Test.Support.Usage as U
import Test.Support.Desc as DE
import Test.Support.Docopt as D
import Test.Support.Arguments

import Language.Docopt (preparseDocopt)
import Language.Docopt.Errors
import Language.Docopt.Specification
import Language.Docopt.Argument
import Language.Docopt.Value
import Language.Docopt.Usage
import Language.Docopt.Solver (solve)
import Language.Docopt.SpecParser.Desc (Desc())
import Language.Docopt.Argument as D
import Test.Support.Docopt      as D
import Language.Docopt.SpecParser.Usage.Argument as U
import Language.Docopt.SpecParser.Usage          as U
import Language.Docopt.SpecParser.Desc           as DE
import Language.Docopt.Scanner (scan)
import Language.Docopt.SpecParser.Lexer (lex)
import Text.Wrap (dedent)
import Partial.Unsafe

data Expected = Source String | Parsed (Array (Array Argument))

newtype TestSuite = TestSuite { help  :: String
                              , cases :: Array TestCase
                              }
newtype TestCase = TestCase { expected :: Either String Expected
                            , desctext :: String
                            }

test :: String -> Array TestCase -> TestSuite
test help cs = TestSuite { help: help, cases: cs }

pass :: String -> Array (Array Argument) -> TestCase
pass text as = TestCase { expected: Right (Parsed as), desctext: text  }

pass' :: String -> String -> TestCase
pass' text s = TestCase { expected: Right (Source s), desctext: text  }

fail :: String -> String -> TestCase
fail text msg = TestCase { expected: Left msg, desctext: text }

solverSpec = \_ ->
  describe "The solver" do
    for_ (fromFoldable [

      test "Usage: prog foo"
        [ pass "" [ [ co "foo" ] ] ]

    , test "Usage: prog <prog>..."
        [ pass "" [ [ poR "<prog>" ] ] ]

    , test
        "Usage: prog --foo..."
        [ fail
            "options: -f --foo=bar [default: qux]"
            "Option-Argument specified in options-section missing --foo"
        ]

    , test
        "Usage: prog --foo... BAR"
        [ fail
            "options: -f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing --foo"
        ]

    , test
        "Usage: prog -f... BAR"
        [ fail
            "options: -f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing -f"
        ]

    , test
        "Usage: prog --foo BAR..."
        [ pass
            "options: -f --foo=BAR [default: qux]"
            [ [ optR 'f' "foo" (oa "BAR" (D.str "qux")) ] ]
        ]

    , test
        "Usage: prog --foo BAR"
        [ pass
            "options: -f --foo=BAR [default: qux]"
            [ [ opt 'f' "foo" (oa "BAR" (D.str "qux")) ] ]
        ]

    , test
        "Usage: prog --foo... BAR..."
        [ fail
            "options: -f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing --foo"
        ]

    , test
        "Usage: prog -f... BAR..."
        [ fail
            "options: -f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing -f"
        ]

    , test
        "Usage: prog -xvzfFILE..."
        [ pass
            "options: -f --file=FILE  [default: foo]"
            [ [ soptR_ 'x'
              , soptR_ 'v'
              , soptR_ 'z'
              , optR 'f' "file" (oa "FILE" (D.str "foo"))
            ] ]
        ]

    , test
        "Usage: prog -xvzf FILE..."
        [ pass
            "options: -f --file=FILE  [default: foo]"
            [ [ soptR_ 'x'
              , soptR_ 'v'
              , soptR_ 'z'
              , optR 'f' "file" (oa "FILE" (D.str "foo"))
            ] ]
        ]

    , test
        "Usage: prog --file FILE..."
        [ fail
            """
            options:
              -f --file=FILE  [default: foo]
              -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option --file"
        ]

    , test
        "Usage: prog -f FILE..."
        [ fail
            """
            options:
              -f --file=FILE  [default: foo]
              -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option -f"
        ]

    , test
        "Usage: prog --file FILE..."
        [ fail
            """
            options:
              -f --file=FILE  [default: foo]
              -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option --file"
        ]

    , test
        "Usage: prog -fx..."
        [ fail
            "options: -f --file=FILE  [default: foo]"
            "Stacked option -f may not specify arguments"
        ]

      -- Note: `f` should not adopt `file` as it's full name since it's in an
      -- option stack and not in trailing position (therefore cannot inherit the
      -- description's argument, rendering it an unfit candidate)
    , test
        "Usage: prog -fvzx..."
        [ fail
            "options: -f --file=FILE  [default: foo]"
            "Stacked option -f may not specify arguments"
        ]

    , test
        "Usage: prog -xvzf FILE..."
        [ pass
            "options: -f --file=FILE  [default: foo]"
            [ [ soptR_ 'x'
              , soptR_ 'v'
              , soptR_ 'z'
              , optR 'f' "file" (oa "FILE" (StringValue "foo"))
            ] ]
        ]

    , test
        "Usage: prog -xvzf..."
        [ fail
            "options: -f --file=FILE  [default: foo]"
            "Option-Argument specified in options-section missing -f"
        ]

    , test
        "Usage: prog [options]"
        [ pass
            "options: -f --file=FILE [default: foo]"
            [ [ gro false [ [
                  opt 'f' "file" (oa "FILE" $ StringValue "foo")
            ] ] ] ]

        -- newline treatment for option alias in the description:
        -- the aliases may be separated by commas, in which case the alias may
        -- appear on a new line. If the comma is ommitted, the association won't
        -- take place
        , pass
            """
            options:
              -f,
              --foo
            """
            [ [ gro false [ [
                  opt_ 'f' "foo"
            ] ] ] ]

        , pass
            """
            options:
              -f
              --foo
            """
            [ [ gro false [ [ sopt_ 'f'   ] ]
              , gro false [ [ lopt_ "foo" ] ]
            ] ]

        , pass
            """
            options:
              --foo
                  ARG
                  ...
              -q
                  ARG
                  ...
            """
            [ [ gro false [ [ lopt_ "foo" ] ]
              , gro false [ [ sopt_ 'q'   ] ]
            ] ]
        ]

    , test
        "Usage: prog [options] [-a]"
        [ pass
            "options: -a, --all"
            [ [ gro false [ [
                  opt_ 'a' "all"
            ] ] ] ]
        ]

      -- Canonicalisation / simplification

    , test
        "Usage: prog (-a)"
        [ pass' "" "Usage: prog (-a)" ]

    , test
        "Usage: prog (a)"
        [ pass' "" "Usage: prog a" ]

    , test
        "Usage: prog [a]"
        [ pass' "" "Usage: prog [a]" ]

    , test
        "Usage: prog [-a]"
        [ pass' "" "Usage: prog [-a]" ]

    , test
        "Usage: prog [[-a]]"
        [ pass' "" "Usage: prog [-a]" ]

    , test
        "Usage: prog [[[-a]]]"
        [ pass' "" "Usage: prog [-a]" ]

    , test
        "Usage: prog [[-a]...]"
        [ pass' "" "Usage: prog [-a]..." ]

    , test
        "Usage: prog [(-a)...]"
        [ pass' "" "Usage: prog [-a]..." ]

    , test
        "Usage: prog [(-a...)]"
        [ pass' "" "Usage: prog [-a...]" ]

    , test
        "Usage: prog [(-a...)...]..."
        -- XXX: this could be reduced even further: `[-a]...`, but little to
        -- gain here, so low priority
        [ pass' "" "Usage: prog [-a...]..." ]

    , test
        "Usage: prog ([-a]...)"
        [ pass' "" "Usage: prog [-a]..." ]

    , test
        "Usage: prog [[[-a|-b]]]"
        [ pass' "" "Usage: prog [-a|-b]" ]

    , test
        "Usage: prog [[[-a|[-b]]]]"
        [ pass' "" "Usage: prog [-a|-b]" ]

    , test
        "Usage: prog [[[-a|[-b]]]]"
        [ pass' "" "Usage: prog [-a|-b]" ]

    , test
        "Usage: prog [<name> [<name>]]"
        [ pass' "" "Usage: prog [<name> [<name>]]" ]

    , test
        "Usage: prog [[-a=FOO] | [[-a=FOO] [-b=FOO]]]"
        [ pass' "" "Usage: prog [-a=FOO | [[-a=FOO] [-b=FOO]]]" ]

    , test
        "Usage: prog ((-i=FILE) -o=FILE)"
        [ pass' "" "Usage: prog (-i=FILE -o=FILE)" ]

    , test
        "Usage: prog (-i=FILE) | (-o=FILE)"
        [ pass' "" "Usage: prog -i=FILE | -o=FILE" ]

    ]) runtest

  where

    prettyPrintOutput :: Specification -> String
    prettyPrintOutput as =
      intercalate "\n" (("  " <> _) <$>
        (prettyPrintUsage <$> as))

    runtest (TestSuite { help, cases }) = do
      for_ cases \(TestCase { expected, desctext }) -> do
        describe ("\n" <> help <> "\n" <> dedent desctext) do
          it (
            either
              (\msg      -> "Should fail with:\n" <> msg)
              (\expected ->
                let msg = case expected of
                      Source s  -> s
                      Parsed xs -> intercalate "\n" $
                        ("Usage: prog " <> _)
                          <$> (intercalate " " <<< (prettyPrintArg <$> _))
                                <$> xs
                 in "Should resolve to:\n" <> msg)
              expected
          ) do
            vliftEff do
              { usages, descriptions } <- runEitherEff do
                preparseDocopt
                  (help <> "\n" <> dedent desctext)
                  { smartOptions: false }
              evaltest
                (solve usages descriptions)
                (rmap (case _ of
                  Parsed xs -> Parsed xs
                  Source  s -> Source $ s <> "\n" <> dedent desctext)
                expected)

    evaltest (Right output) (Right expected) = do
      expected' <- case expected of
        Parsed xs   -> pure $ pure $ fromFoldable $ fromFoldable <$> xs
        Source help -> do
          runEitherEff do
            { usages, descriptions } <- preparseDocopt help {
              smartOptions: false
            }
            lmap show (solve usages descriptions)
      if output == expected'
          then pure unit
          else throwException $ error $
            "Unexpected output:\n\n" <> prettyPrintOutput output

    evaltest (Right output) (Left _)
      = throwException $ error $
          "Missing exception! Got:\n\n" <> prettyPrintOutput output

    evaltest (Left (SolveError err)) (Left expected)
      = if err == expected
            then pure unit
            else throwException $ error $
              "Unexpected error:\n\n" <> err

    evaltest (Left err) _ = throwException $ error $ show err

module Test.Spec.SolverSpec (solverSpec) where

import Prelude
import Debug.Trace
import Data.Either (Either(..), either, fromRight)
import Control.Bind ((=<<))
import Control.Apply ((*>))
import Data.List (List(..), fromFoldable)
import Data.Bifunctor (lmap, rmap)
import Control.Plus (empty)
import Data.Foldable (intercalate, for_)
import Data.Traversable (for)
import Control.Monad.Eff.Exception (error, throwException)
import Data.Array as A
import Data.Maybe (Maybe(..), maybe)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)

import Test.Support (vliftEff, runEitherEff)
import Test.Support.Usage as U
import Test.Support.Desc as DE
import Test.Support.Docopt as D
import Test.Support.Arguments

import Language.Docopt (preparseDocopt)
import Language.Docopt.Errors
import Language.Docopt.Specification
import Language.Docopt.Argument
import Language.Docopt.Value
import Language.Docopt.Usage
import Language.Docopt.Solver (solve)
import Language.Docopt.SpecParser.Desc (Desc())
import Language.Docopt.Argument as D
import Test.Support.Docopt      as D
import Language.Docopt.SpecParser.Usage.Argument as U
import Language.Docopt.SpecParser.Usage          as U
import Language.Docopt.SpecParser.Desc           as DE
import Language.Docopt.Scanner (scan)
import Language.Docopt.SpecParser.Lexer (lex)
import Text.Wrap (dedent)
import Partial.Unsafe

data Expected = Source String | Parsed (Array (Array Argument))

newtype TestSuite = TestSuite { help  :: String
                              , cases :: Array TestCase
                              }
newtype TestCase = TestCase { expected :: Either String Expected
                            , desctext :: String
                            }

test :: String -> Array TestCase -> TestSuite
test help cs = TestSuite { help: help, cases: cs }

pass :: String -> Array (Array Argument) -> TestCase
pass text as = TestCase { expected: Right (Parsed as), desctext: text  }

pass' :: String -> String -> TestCase
pass' text s = TestCase { expected: Right (Source s), desctext: text  }

fail :: String -> String -> TestCase
fail text msg = TestCase { expected: Left msg, desctext: text }

solverSpec = \_ ->
  describe "The solver" do
    for_ (fromFoldable [

      test "Usage: prog foo"
        [ pass "" [ [ co "foo" ] ] ]

    , test "Usage: prog <prog>..."
        [ pass "" [ [ poR "<prog>" ] ] ]

    , test
        "Usage: prog --foo..."
        [ fail
            "options: -f --foo=bar [default: qux]"
            "Option-Argument specified in options-section missing --foo"
        ]

    , test
        "Usage: prog --foo... BAR"
        [ fail
            "options: -f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing --foo"
        ]

    , test
        "Usage: prog -f... BAR"
        [ fail
            "options: -f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing -f"
        ]

    , test
        "Usage: prog --foo BAR..."
        [ pass
            "options: -f --foo=BAR [default: qux]"
            [ [ optR 'f' "foo" (oa "BAR" (D.str "qux")) ] ]
        ]

    , test
        "Usage: prog --foo BAR"
        [ pass
            "options: -f --foo=BAR [default: qux]"
            [ [ opt 'f' "foo" (oa "BAR" (D.str "qux")) ] ]
        ]

    , test
        "Usage: prog --foo... BAR..."
        [ fail
            "options: -f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing --foo"
        ]

    , test
        "Usage: prog -f... BAR..."
        [ fail
            "options: -f --foo=BAR [default: qux]"
            "Option-Argument specified in options-section missing -f"
        ]

    , test
        "Usage: prog -xvzfFILE..."
        [ pass
            "options: -f --file=FILE  [default: foo]"
            [ [ soptR_ 'x'
              , soptR_ 'v'
              , soptR_ 'z'
              , optR 'f' "file" (oa "FILE" (D.str "foo"))
            ] ]
        ]

    , test
        "Usage: prog -xvzf FILE..."
        [ pass
            "options: -f --file=FILE  [default: foo]"
            [ [ soptR_ 'x'
              , soptR_ 'v'
              , soptR_ 'z'
              , optR 'f' "file" (oa "FILE" (D.str "foo"))
            ] ]
        ]

    , test
        "Usage: prog --file FILE..."
        [ fail
            """
            options:
              -f --file=FILE  [default: foo]
              -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option --file"
        ]

    , test
        "Usage: prog -f FILE..."
        [ fail
            """
            options:
              -f --file=FILE  [default: foo]
              -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option -f"
        ]

    , test
        "Usage: prog --file FILE..."
        [ fail
            """
            options:
              -f --file=FILE  [default: foo]
              -f --file=FILE  [default: foo]
            """
            "Multiple option descriptions for option --file"
        ]

    , test
        "Usage: prog -fx..."
        [ fail
            "options: -f --file=FILE  [default: foo]"
            "Stacked option -f may not specify arguments"
        ]

      -- Note: `f` should not adopt `file` as it's full name since it's in an
      -- option stack and not in trailing position (therefore cannot inherit the
      -- description's argument, rendering it an unfit candidate)
    , test
        "Usage: prog -fvzx..."
        [ fail
            "options: -f --file=FILE  [default: foo]"
            "Stacked option -f may not specify arguments"
        ]

    , test
        "Usage: prog -xvzf FILE..."
        [ pass
            "options: -f --file=FILE  [default: foo]"
            [ [ soptR_ 'x'
              , soptR_ 'v'
              , soptR_ 'z'
              , optR 'f' "file" (oa "FILE" (StringValue "foo"))
            ] ]
        ]

    , test
        "Usage: prog -xvzf..."
        [ fail
            "options: -f --file=FILE  [default: foo]"
            "Option-Argument specified in options-section missing -f"
        ]

    , test
        "Usage: prog [options]"
        [ pass
            "options: -f --file=FILE [default: foo]"
            [ [ gro false [ [
                  opt 'f' "file" (oa "FILE" $ StringValue "foo")
            ] ] ] ]

        -- newline treatment for option alias in the description:
        -- the aliases may be separated by commas, in which case the alias may
        -- appear on a new line. If the comma is ommitted, the association won't
        -- take place
        , pass
            """
            options:
              -f,
              --foo
            """
            [ [ gro false [ [
                  opt_ 'f' "foo"
            ] ] ] ]

        , pass
            """
            options:
              -f
              --foo
            """
            [ [ gro false [ [ sopt_ 'f'   ] ]
              , gro false [ [ lopt_ "foo" ] ]
            ] ]

        , pass
            """
            options:
              --foo
                  ARG
                  ...
              -q
                  ARG
                  ...
            """
            [ [ gro false [ [ lopt_ "foo" ] ]
              , gro false [ [ sopt_ 'q'   ] ]
            ] ]
        ]

    , test
        "Usage: prog [options] [-a]"
        [ pass
            "options: -a, --all"
            [ [ gro false [ [
                  opt_ 'a' "all"
            ] ] ] ]
        ]

      -- Canonicalisation / simplification

    , test
        "Usage: prog [-a]"
        [ pass' "" "Usage: prog [-a]" ]

    , test
        "Usage: prog [[-a]]"
        [ pass' "" "Usage: prog [-a]" ]

    , test
        "Usage: prog [[[-a]]]"
        [ pass' "" "Usage: prog [-a]" ]

    , test
        "Usage: prog [[[-a|-b]]]"
        [ pass' "" "Usage: prog [-a|-b]" ]

    , test
        "Usage: prog [[[-a|[-b]]]]"
        [ pass' "" "Usage: prog [-a|-b]" ]

    , test
        "Usage: prog [[[-a|[-b]]]]"
        [ pass' "" "Usage: prog [-a|-b]" ]

    , test
        "Usage: prog [<name> [<name>]]"
        [ pass' "" "Usage: prog [<name> [<name>]]" ]

    , test
        "Usage: prog [[-a=FOO] | [[-a=FOO] [-b=FOO]]]"
        [ pass' "" "Usage: prog [-a=FOO | [[-a=FOO] [-b=FOO]]]" ]

    , test
        "Usage: prog ((-i=FILE) -o=FILE)"
        [ pass' "" "Usage: prog (-i=FILE -o=FILE)" ]

    , test
        "Usage: prog (-i=FILE) | (-o=FILE)"
        [ pass' "" "Usage: prog -i=FILE | -o=FILE" ]

    ]) runtest

  where

    prettyPrintOutput :: Specification -> String
    prettyPrintOutput as =
      intercalate "\n" (("  " <> _) <$>
        (prettyPrintUsage <$> as))

    runtest (TestSuite { help, cases }) = do
      for_ cases \(TestCase { expected, desctext }) -> do
        describe ("\n" <> help <> "\n" <> dedent desctext) do
          it (
            either
              (\msg      -> "Should fail with:\n" <> msg)
              (\expected ->
                let msg = case expected of
                      Source s  -> s
                      Parsed xs -> intercalate "\n" $
                        ("Usage: prog " <> _)
                          <$> (intercalate " " <<< (prettyPrintArg <$> _))
                                <$> xs
                 in "Should resolve to:\n" <> msg)
              expected
          ) do
            vliftEff do
              { usages, descriptions } <- runEitherEff do
                preparseDocopt
                  (help <> "\n" <> dedent desctext)
                  { smartOptions: false }
              evaltest
                (solve usages descriptions)
                (rmap (case _ of
                  Parsed xs -> Parsed xs
                  Source  s -> Source $ s <> "\n" <> dedent desctext)
                expected)

    evaltest (Right output) (Right expected) = do
      expected' <- case expected of
        Parsed xs   -> pure $ pure $ fromFoldable $ fromFoldable <$> xs
        Source help -> do
          runEitherEff do
            { usages, descriptions } <- preparseDocopt help {
              smartOptions: false
            }
            lmap show (solve usages descriptions)
      if output == expected'
          then pure unit
          else throwException $ error $
            "Unexpected output:\n\n" <> prettyPrintOutput output

    evaltest (Right output) (Left _)
      = throwException $ error $
          "Missing exception! Got:\n\n" <> prettyPrintOutput output

    evaltest (Left (SolveError err)) (Left expected)
      = if err == expected
            then pure unit
            else throwException $ error $
              "Unexpected error:\n\n" <> err

    evaltest (Left err) _ = throwException $ error $ show err


Use helper function

Use helper function

module Test.Main where

import Prelude
import Debug.Trace
import Control.MonadPlus (guard)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION(), error, throwException)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Trans (lift)
import qualified Text.Parsing.Parser as P
import Data.Either (Either(..), isRight, isLeft, either)
import Data.Either.Unsafe (fromLeft, fromRight)
import Data.List (List(..), length, (!!), take)
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(..))
import Test.Assert.Simple
import Data.Foldable (foldMap, traverse_, for_)
import Data.Array ((..))

import Docopt
import qualified Docopt.Parser.Usage as Usage
import qualified Docopt.Parser.Options as Options
import qualified Docopt.Textwrap as Textwrap
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Scanner as Scanner
import Docopt.Parser.Base (debug)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)

data Expected a = F | P a

main = run [consoleReporter] do
  describe "scanner" do
    it "should scan sections" do
      let docopt = fromRight $ Scanner.scan $
          Textwrap.dedent
            """
            Usage: foo
            Options: bar
            Advanced Options: qux
            """
      liftEff do
        assert $ docopt.usage == "foo\n"
        assert $ length docopt.options == 2
        assert $ fromJust (docopt.options !! 0) == " bar\n"
        assert $ fromJust (docopt.options !! 1) == " qux\n"
      pure unit

    it "should scan sections with new line after colon" do
      let docopt = fromRight $ Scanner.scan $
          Textwrap.dedent
            """
            Usage:
              foo
            Options:
              bar
            Advanced Options:
              qux
            """
      liftEff do
        assert $ docopt.usage == "foo\n"
        assert $ length docopt.options == 2
        assert $ fromJust (docopt.options !! 0) == "\n  bar\n"
        assert $ fromJust (docopt.options !! 1) == "\n  qux\n"
      pure unit

    it "should fail w/o a usage section" do
      let result = Scanner.scan $
          Textwrap.dedent
            """
            Options: bar
            """
      liftEff $ do
        assert $ isLeft result
      pure unit

    it "should fail multiple usage sections" do
      let result = Scanner.scan $
          Textwrap.dedent
            """
            Usage: bar
            Options: foo
            Usage: qux
            """
      liftEff $ do
        assert $ isLeft result
      pure unit

    it "should fail if usage section is not the first section" do
      let result = Scanner.scan $
          Textwrap.dedent
            """
            Options: foo
            Usage: qux
            """
      liftEff $ do
        assert $ isLeft result
      pure unit

    it "should fail w/o any sections" do
      let result = Scanner.scan $
          Textwrap.dedent
            """
            """
      liftEff $ do
        assert $ isLeft result
      pure unit

  describe "parser" do

    it "should parse commands" do
      liftEff do
        usage <- runEitherEff do
          toks <- Lexer.lex "foo bar"
          Usage.parse toks
        assertEqual 1 (length usage)
        (Usage.Usage _ u) <- runMaybeEff $ usage !! 0
        g <- runMaybeEff $ u !! 0
        flip assertEqual g (Cons (Usage.Command "bar") Nil)

    -- Test positionals in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "positionals" do
      runSingleUsageNodeTests
        [ pass "BAR"       $ po "BAR"
        , pass "<foo-qux>" $ po "foo-qux"
        , pass "<QUX>"     $ po "QUX"
        , pass "<QuX>"     $ po "QuX"
        , pass "<quux>"    $ po "quux"
        ]

    -- Test long options in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "long options" do
      runSingleUsageNodeTests
        [ pass "--bar"         $ lo "bar" Nothing
        , pass "--bar = foo"   $ lo "bar" (Just "foo")
        , pass "--bar=<foo>"   $ lo "bar" (Just "foo")
        , pass "--bar=FOO"     $ lo "bar" (Just "FOO")
        , pass "--bar = FOO"   $ lo "bar" (Just "FOO")
        , pass "--bar=fOo"     $ lo "bar" (Just "fOo")
        , pass "--bar = fOo"   $ lo "bar" (Just "fOo")
        , pass "--bar = <foo>" $ lo "bar" (Just "foo")
        , fail "-- bar"
        , fail "- - bar"
        , fail "--bar="
        , fail "--bar=<>"
        , fail "--bar=--foo"
        , fail "--bar=-foo"
        ]

    -- Test stacked options in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "stacked options" do
      runSingleUsageNodeTests
        [ pass "-b"          $ so 'b' [] Nothing
        , pass "-bFOO"       $ so 'b' [] (Just "FOO")
        , pass "-bFoo"       $ so 'b' [] (Just "Foo")
        , pass "-b<foo>"     $ so 'b' [] (Just "foo")
        , pass "-b<foo>"     $ so 'b' [] (Just "foo")
        , pass "-b=foo"      $ so 'b' [] (Just "foo")
        , pass "-b=FOO"      $ so 'b' [] (Just "FOO")
        , pass "-b=<foo>"    $ so 'b' [] (Just "foo")
        , pass "-bar"        $ so 'b' ['a', 'r'] Nothing
        , pass "-barFOO"     $ so 'b' ['a', 'r'] (Just "FOO")
        , pass "-bar<foo>"   $ so 'b' ['a', 'r'] (Just "foo")
        , pass "-barFoo"     $ so 'b' ['a', 'r'] (Just "Foo")
        , pass "-bar=foo"    $ so 'b' ['a', 'r'] (Just "foo")
        , pass "-bar=FOO"    $ so 'b' ['a', 'r'] (Just "FOO")
        , pass "-bar=<foo>"  $ so 'b' ['a', 'r'] (Just "foo")
        , pass "-bAR"        $ so 'b' [] (Just "AR")
        , pass "-bARfoo"     $ so 'b' [] (Just "ARfoo")
        , fail "-bAR=foo"
        , fail "-bAR=<foo>"
        , fail "-bAR<foo>"
        -- , pass "-b foo"      $ (so 'b' [] Nothing)
        -- , pass "-b FOO"      $ (so 'b' [] Nothing)
        -- , pass "-bar foo"    $ (so 'b' ['a', 'r'] Nothing
        -- , pass "-bar FOO"    $ (so 'b' ['a', 'r'] Nothing
        ]

    it "should parse scanned and lexed usage sections" do
      liftEff do

        -- Scan, lex and parse the usage section
        usage <- runEitherEff do
          docopt <- Scanner.scan $
            Textwrap.dedent
              """
              Usage: foo foo | bar aux
                    foo (bar qux)
              NOT PART OF SECTION
              """
          toks <- Lexer.lex docopt.usage
          Usage.parse toks
        assertEqual 2 (length usage)

        -- Validate the first usage
        (Usage.Usage _ u0) <- runMaybeEff $ usage !! 0
        assertEqual 2 (length u0)

        -- Validate the left half of the mutex group
        u0g0 <- runMaybeEff $ u0 !! 0
        assertEqual 1 (length u0g0)

        -- Validate the right half of the mutex group
        u0g1 <- runMaybeEff $ u0 !! 1
        assertEqual 2 (length u0g1)

        -- Validate the second usage
        (Usage.Usage _ u1) <- runMaybeEff $ usage !! 1
        assertEqual 1 (length u1)

        u1g0 <- runMaybeEff $ u1 !! 0
        assertEqual 1 (length u1g0)

      pure unit

  where

    runMaybeEff :: forall a eff.
      Maybe a ->
      Eff (err :: EXCEPTION | eff) a
    runMaybeEff m =
      case m of
        Just v  -> pure v
        Nothing -> throwException (error "Nothing")

    runEitherEff :: forall err a eff. (Show err, Show a) =>
      Either err a ->
      Eff (err :: EXCEPTION | eff) a
    runEitherEff m =
      case m of
        Right v  -> pure v
        Left err -> throwException (error $ show err)

    -- short hand to create a short option node
    so :: Char -> Array Char -> Maybe String -> Boolean -> Usage.UsageNode
    so = Usage.OptionStack

    -- short hand to create a long option node
    lo :: String -> Maybe String -> Boolean -> Usage.UsageNode
    lo = Usage.Option

    -- short hand to create a positional node
    po :: String -> Boolean -> Usage.UsageNode
    po = Usage.Positional

    kase i o = { i: i, o: o }
    pass i o = kase i (P o)
    fail i = kase i F

    runSingleUsageNodeTests xs =
      for_ xs \{ i: i, o: o } -> do
        for_ [ false, true ] \isRepeated -> do -- Append "..." ?
          for_ (1 .. 2) \q -> do -- "..." vs " ..." (note the space)
            let input = "foo " ++ i ++ (if isRepeated
                                       then (if q == 1 then "..." else " ...")
                                       else "")
            case o of
              P v -> do
                let expected = v isRepeated
                it (input ++ " -> " ++ show expected)  do
                  liftEff do
                    usage <- runEitherEff do
                      Lexer.lex input >>= Usage.parse

                    -- There should only be one top-level mutex group
                    assertEqual 1 (length usage)
                    (Usage.Usage _ u) <- runMaybeEff $ usage !! 0
                    g <- runMaybeEff $ u !! 0

                    -- Assert output matches expected
                    flip assertEqual (take 1 g) (Cons expected Nil)
              _ -> do
                it (input ++ " should fail") do
                liftEff do
                  assertThrows (const true) do
                    runEitherEff do
                      toks <- Lexer.lex input
                      traceShowA input
                      Usage.parse toks >>= debug
                      pure unit

module Test.Main where

import Prelude
import Debug.Trace
import Control.MonadPlus (guard)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION(), error, throwException)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Trans (lift)
import qualified Text.Parsing.Parser as P
import Data.Either (Either(..), isRight, isLeft, either)
import Data.Either.Unsafe (fromLeft, fromRight)
import Data.List (List(..), length, (!!))
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(..))
import Test.Assert.Simple
import Data.Foldable (foldMap, traverse_, for_)
import Data.Array ((..))

import Docopt
import qualified Docopt.Parser.Usage as Usage
import qualified Docopt.Parser.Options as Options
import qualified Docopt.Textwrap as Textwrap
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Scanner as Scanner
import Docopt.Parser.Base (debug)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)

data Expected a = F | P a

main = run [consoleReporter] do
  describe "scanner" do
    it "should scan sections" do
      let docopt = fromRight $ Scanner.scan $
          Textwrap.dedent
            """
            Usage: foo
            Options: bar
            Advanced Options: qux
            """
      liftEff do
        assert $ docopt.usage == "foo\n"
        assert $ length docopt.options == 2
        assert $ fromJust (docopt.options !! 0) == " bar\n"
        assert $ fromJust (docopt.options !! 1) == " qux\n"
      pure unit

    it "should scan sections with new line after colon" do
      let docopt = fromRight $ Scanner.scan $
          Textwrap.dedent
            """
            Usage:
              foo
            Options:
              bar
            Advanced Options:
              qux
            """
      liftEff do
        assert $ docopt.usage == "foo\n"
        assert $ length docopt.options == 2
        assert $ fromJust (docopt.options !! 0) == "\n  bar\n"
        assert $ fromJust (docopt.options !! 1) == "\n  qux\n"
      pure unit

    it "should fail w/o a usage section" do
      let result = Scanner.scan $
          Textwrap.dedent
            """
            Options: bar
            """
      liftEff $ do
        assert $ isLeft result
      pure unit

    it "should fail multiple usage sections" do
      let result = Scanner.scan $
          Textwrap.dedent
            """
            Usage: bar
            Options: foo
            Usage: qux
            """
      liftEff $ do
        assert $ isLeft result
      pure unit

    it "should fail if usage section is not the first section" do
      let result = Scanner.scan $
          Textwrap.dedent
            """
            Options: foo
            Usage: qux
            """
      liftEff $ do
        assert $ isLeft result
      pure unit

    it "should fail w/o any sections" do
      let result = Scanner.scan $
          Textwrap.dedent
            """
            """
      liftEff $ do
        assert $ isLeft result
      pure unit

  describe "parser" do

    it "should parse commands" do
      liftEff do
        usage <- runEitherEff do
          toks <- Lexer.lex "foo bar"
          Usage.parse toks
        assertEqual 1 (length usage)
        (Usage.Usage _ u) <- runMaybeEff $ usage !! 0
        g <- runMaybeEff $ u !! 0
        flip assertEqual g (Cons (Usage.Command "bar") Nil)

    -- Test positionals in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "positionals" do
      runSingleUsageNodeTests
        [ { i: "BAR"       , o: P $ po "BAR"     }
        , { i: "<foo-qux>" , o: P $ po "foo-qux" }
        , { i: "<QUX>"     , o: P $ po "QUX"     }
        , { i: "<QuX>"     , o: P $ po "QuX"     }
        , { i: "<quux>"    , o: P $ po "quux"    }
        ]

    -- Test long options in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "long options" do
      runSingleUsageNodeTests
        [ { i: "--bar"         , o: P $ lo "bar" Nothing      }
        , { i: "--bar = foo"   , o: P $ lo "bar" (Just "foo") }
        , { i: "--bar=<foo>"   , o: P $ lo "bar" (Just "foo") }
        , { i: "--bar=FOO"     , o: P $ lo "bar" (Just "FOO") }
        , { i: "--bar = FOO"   , o: P $ lo "bar" (Just "FOO") }
        , { i: "--bar=fOo"     , o: P $ lo "bar" (Just "fOo") }
        , { i: "--bar = fOo"   , o: P $ lo "bar" (Just "fOo") }
        , { i: "--bar = <foo>" , o: P $ lo "bar" (Just "foo") }
        , { i: "-- bar"        , o: F                         }
        , { i: "- - bar"       , o: F                         }
        , { i: "--bar="        , o: F                         }
        , { i: "--bar=<>"      , o: F                         }
        , { i: "--bar=--foo"   , o: F                         }
        , { i: "--bar=-foo"    , o: F                         }
        ]

    -- Test stacked options in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "stacked options" do
      runSingleUsageNodeTests
        [ { i: "-b"          , o: P $ so 'b' [] Nothing      }
        , { i: "-bFOO"       , o: P $ so 'b' [] (Just "FOO") }
        , { i: "-bFoo"       , o: P $ so 'b' [] (Just "Foo") }
        , { i: "-b<foo>"     , o: P $ so 'b' [] (Just "foo") }
        , { i: "-b<foo>"     , o: P $ so 'b' [] (Just "foo") }
        , { i: "-b=foo"      , o: P $ so 'b' [] (Just "foo") }
        , { i: "-b=FOO"      , o: P $ so 'b' [] (Just "FOO") }
        , { i: "-b=<foo>"    , o: P $ so 'b' [] (Just "foo") }
        , { i: "-bar"        , o: P $ so 'b' ['a', 'r'] Nothing }
        , { i: "-barFOO"     , o: P $ so 'b' ['a', 'r'] (Just "FOO") }
        , { i: "-bar<foo>"   , o: P $ so 'b' ['a', 'r'] (Just "foo") }
        , { i: "-barFoo"     , o: P $ so 'b' ['a', 'r'] (Just "Foo") }
        , { i: "-bar=foo"    , o: P $ so 'b' ['a', 'r'] (Just "foo") }
        , { i: "-bar=FOO"    , o: P $ so 'b' ['a', 'r'] (Just "FOO") }
        , { i: "-bar=<foo>"  , o: P $ so 'b' ['a', 'r'] (Just "foo") }
        , { i: "-bAR"        , o: P $ so 'b' [] (Just "AR") }
        , { i: "-bARfoo"     , o: P $ so 'b' [] (Just "ARfoo") }
        , { i: "-bAR=foo"    , o: F }
        , { i: "-bAR=<foo>"  , o: F }
        , { i: "-bAR<foo>"   , o: F }
        ]

                -- -b foo     -b FOO...
                -- -b FOO     -b FOO...
        --         -bar foo   -bar foo...
        --         -bar FOO   -bar FOO...

    it "should parse scanned and lexed usage sections" do
      liftEff do

        -- Scan, lex and parse the usage section
        usage <- runEitherEff do
          docopt <- Scanner.scan $
            Textwrap.dedent
              """
              Usage: foo foo | bar aux
                    foo (bar qux)
              NOT PART OF SECTION
              """
          toks <- Lexer.lex docopt.usage
          Usage.parse toks
        assertEqual 2 (length usage)

        -- Validate the first usage
        (Usage.Usage _ u0) <- runMaybeEff $ usage !! 0
        assertEqual 2 (length u0)

        -- Validate the left half of the mutex group
        u0g0 <- runMaybeEff $ u0 !! 0
        assertEqual 1 (length u0g0)

        -- Validate the right half of the mutex group
        u0g1 <- runMaybeEff $ u0 !! 1
        assertEqual 2 (length u0g1)

        -- Validate the second usage
        (Usage.Usage _ u1) <- runMaybeEff $ usage !! 1
        assertEqual 1 (length u1)

        u1g0 <- runMaybeEff $ u1 !! 0
        assertEqual 1 (length u1g0)

      pure unit

  where

    runMaybeEff :: forall a eff.
      Maybe a ->
      Eff (err :: EXCEPTION | eff) a
    runMaybeEff m =
      case m of
        Just v  -> pure v
        Nothing -> throwException (error "Nothing")

    runEitherEff :: forall err a eff. (Show err, Show a) =>
      Either err a ->
      Eff (err :: EXCEPTION | eff) a
    runEitherEff m =
      case m of
        Right v  -> pure v
        Left err -> throwException (error $ show err)

    -- short hand to create a short option node
    so :: Char -> Array Char -> Maybe String -> Boolean -> Usage.UsageNode
    so = Usage.OptionStack

    -- short hand to create a long option node
    lo :: String -> Maybe String -> Boolean -> Usage.UsageNode
    lo = Usage.Option

    -- short hand to create a positional node
    po :: String -> Boolean -> Usage.UsageNode
    po = Usage.Positional

    runSingleUsageNodeTests xs =
      for_ xs \{ i: i, o: o } -> do
        for_ [ false, true ] \isRepeated -> do -- Append "..." ?
          for_ (1 .. 2) \q -> do -- "..." vs " ..." (note the space)
            let input = "foo " ++ i ++ (if isRepeated
                                       then (if q == 1 then "..." else " ...")
                                       else "")
            case o of
              P v -> do
                let expected = v isRepeated
                it (input ++ " -> " ++ show expected)  do
                  liftEff do
                    usage <- runEitherEff do
                      Lexer.lex input >>= Usage.parse

                    -- There should only be one top-level mutex group
                    assertEqual 1 (length usage)
                    (Usage.Usage _ u) <- runMaybeEff $ usage !! 0
                    g <- runMaybeEff $ u !! 0

                    -- Assert output matches expected
                    flip assertEqual g (Cons expected Nil)
              _ -> do
                it (input ++ " should fail") do
                liftEff do
                  assertThrows (const true) do
                    runEitherEff do
                      toks <- Lexer.lex input
                      traceShowA input
                      Usage.parse toks >>= debug
                      pure unit


Simplified.

Simplified.

module Test.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION(), throwException, error)
import Control.Monad.MonadFix
import Data.Fix
import Data.Lazy
import Data.List.Lazy
import Data.Maybe
import Data.Tuple
import Prelude

--

newtype Maybel a = Maybel (Lazy (Maybe a))
runMaybel (Maybel x) = x

instance maybelApplicative :: Applicative Maybel where
  pure = pure >>> pure >>> Maybel

instance maybelBind :: Bind Maybel where
  bind (Maybel aOL) a2bOL =
    Maybel (aOL >>= \aO -> pure (aO >>= a2bOL >>> runMaybel >>> force))

instance maybelFunctor :: Functor Maybel where
  map = liftM1

instance maybelApply :: Apply Maybel where
  apply = ap

instance maybelMonad :: Monad Maybel

instance maybelLiftFix :: MonadFix Maybel where
  liftFix xF = Maybel (liftFix xF >>= pure >>> pure)

--

oneTwoThrees :: Maybel (List Int)
oneTwoThrees = do
  Tuple xs _ <-
    mfix \(Tuple xs (Tuple ys zs)) -> do
      xs <- pure (cons 1 ys)
      ys <- pure (cons 2 zs)
      zs <- pure (cons 3 xs)
      pure (Tuple xs (Tuple ys zs))
  pure xs

testEq :: forall a e. (Eq a) => a -> a -> Eff (err :: EXCEPTION | e) Unit
testEq actual expected =
  if actual == expected
    then pure unit
    else throwException $ error $ "Invalid result"

takeAsArray :: forall a. Int -> List a -> Array a
takeAsArray n xs = fromList (take n xs)

main = do
  xs <- fix \xs -> cons 1 xs
  testEq (takeAsArray 5 xs) [1, 1, 1, 1, 1]

  case force (runMaybel oneTwoThrees) of
    Just xs -> testEq (takeAsArray 5 xs) [1, 2, 3, 1, 2]
    Nothing -> throwException $ error $ "Got nothing"

module Test.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION(), throwException, error)
import Control.Monad.MonadFix
import Data.Fix
import Data.Lazy
import Data.List.Lazy
import Data.Maybe
import Data.Tuple
import Prelude

--

newtype Maybel a = Maybel (Lazy (Maybe a))

instance maybelApplicative :: Applicative Maybel where
  pure a = Maybel (defer \_ -> Just a)

instance maybelBind :: Bind Maybel where
  bind (Maybel aM) a2bM =
    Maybel (defer \_ ->
            force aM >>= \a -> case a2bM a of Maybel bM -> force bM)

instance maybelFunctor :: Functor Maybel where
  map = liftM1

instance maybelApply :: Apply Maybel where
  apply = ap

instance maybelMonad :: Monad Maybel

instance maybelLiftFix :: MonadFix Maybel where
  liftFix xF =
    Maybel (do x <- liftFix xF
               pure (pure x))

--

oneTwoThrees :: Maybel (List Int)
oneTwoThrees = do
  Tuple xs _ <-
    mfix \(Tuple xs (Tuple ys zs)) -> do
      xs <- pure (cons 1 ys)
      ys <- pure (cons 2 zs)
      zs <- pure (cons 3 xs)
      pure (Tuple xs (Tuple ys zs))
  pure xs

testEq :: forall a e. (Eq a) => a -> a -> Eff (err :: EXCEPTION | e) Unit
testEq actual expected =
  if actual == expected
    then pure unit
    else throwException $ error $ "Invalid result"

takeAsArray :: forall a. Int -> List a -> Array a
takeAsArray n xs = fromList (take n xs)

main = do
  xs <- fix \xs -> cons 1 xs
  testEq (takeAsArray 5 xs) [1, 1, 1, 1, 1]

  case force (case oneTwoThrees of Maybel x -> x) of
    Just xs -> testEq (takeAsArray 5 xs) [1, 2, 3, 1, 2]
    Nothing -> throwException $ error $ "Got nothing"


Remove unused imports

Remove unused imports

module Test.Spec.Reporter (
  Entry(..),
  EntryPath,
  Entries,
  Reporter(),
  collapse,
  collapseAll
  ) where

import Prelude
import Test.Spec as S
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (message)
import Data.Array (foldl)
import Data.Map (unionWith, empty, singleton, Map)
import Test.Spec (Name, Group, Result(Failure, Success))

data Entry = It Name Result
           | Pending Name

instance eqEntry :: Eq Entry where
  eq (It n1 Success) (It n2 Success) = n1 == n2
  eq (It n1 (Failure e1)) (It n2 (Failure e2)) =
    n1 == n2 && (message e1) == (message e2)
  eq (Pending n1) (Pending n2) = n1 == n2
  eq _ _ = false

instance showEntry :: Show Entry where
  show (It name Success) = "It \"" <> name <> "\" Success"
  show (It name (Failure err)) = "It \"" <> name <> "\" (Failure \"" <> message err <> "\")"
  show (Pending name) = "Pending \"" <> name <> "\""

type Reporter e = (Array (Group Result)) -> Eff e Unit

type EntryPath = Array Name
type Entries = Map EntryPath (Array Entry)

collapseAt :: EntryPath -> Group Result -> Entries
collapseAt path group =
  case group of
    S.It name result -> singleton path [It name result]
    S.Pending name -> singleton path [Pending name]
    S.Describe name groups -> collapseAllAt (path <> [name]) groups

collapseAllAt :: EntryPath -> Array (Group Result) -> Entries
collapseAllAt path = foldl (unionWith (<>)) empty <<< map (collapseAt path)

collapse :: Group Result -> Entries
collapse = collapseAt []

collapseAll :: Array (Group Result) -> Entries
collapseAll = collapseAllAt []

module Test.Spec.Reporter (
  Entry(..),
  EntryPath,
  Entries,
  Reporter(),
  collapse,
  collapseAll
  ) where

import Prelude
import Test.Spec as S
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (message)
import Data.Array (foldl, head, concat)
import Data.Foldable (fold, foldMap)
import Data.Map (unionWith, empty, singleton, Map)
import Data.NonEmpty (foldl1)
import Test.Spec (Name, Group(Describe), Result(Failure, Success))

data Entry = It Name Result
           | Pending Name

instance eqEntry :: Eq Entry where
  eq (It n1 Success) (It n2 Success) = n1 == n2
  eq (It n1 (Failure e1)) (It n2 (Failure e2)) =
    n1 == n2 && (message e1) == (message e2)
  eq (Pending n1) (Pending n2) = n1 == n2
  eq _ _ = false

instance showEntry :: Show Entry where
  show (It name Success) = "It \"" <> name <> "\" Success"
  show (It name (Failure err)) = "It \"" <> name <> "\" (Failure \"" <> message err <> "\")"
  show (Pending name) = "Pending \"" <> name <> "\""

type Reporter e = (Array (Group Result)) -> Eff e Unit

type EntryPath = Array Name
type Entries = Map EntryPath (Array Entry)

collapseAt :: EntryPath -> Group Result -> Entries
collapseAt path group =
  case group of
    S.It name result -> singleton path [It name result]
    S.Pending name -> singleton path [Pending name]
    S.Describe name groups -> collapseAllAt (path <> [name]) groups

collapseAllAt :: EntryPath -> Array (Group Result) -> Entries
collapseAllAt path = foldl (unionWith (<>)) empty <<< map (collapseAt path)

collapse :: Group Result -> Entries
collapse = collapseAt []

collapseAll :: Array (Group Result) -> Entries
collapseAll = collapseAllAt []


Use qualified support import

Use qualified support import

module Test.Spec.GenSpec (genSpec) where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import qualified Data.Map as Map
import qualified Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import qualified Text.Parsing.Parser as P

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)

import Language.Docopt
import Language.Docopt.ParserGen (genParser, runParser)
import qualified Test.Support.Docopt as D

data Test = Test (Array Argument) (Array Case)
data Case = Case (Array String) (Either String (Map Argument Value))

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Array String -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Array String -> String -> Case
fail i e = Case i (Left e)

(:>) = Tuple
infixr 0 :>

genSpec = \_ -> describe "The generator" do

  -- Some options that will be used for these tests
  let cmd_foo          = D.co    "foo"
      opt_f_foo_FOZ__r = D.optR  'f' "foo" (D.oa_ "FOZ")
      opt_q_qux___r    = D.optR_ 'q' "qux"
      opt_b_baz        = D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax")
      opt_o_out        = D.opt_  'o' "out"
      opt_i_input      = D.opt_  'i' "input"
      pos_arg_r        = D.poR    "qux"
      cmd_baz          = D.co     "baz"

  let testCases = [

      test [ pos_arg_r ]
        [ pass
            [ "a", "b", "c" ]
            [ pos_arg_r :> D.array [ D.str "a" , D.str "b" , D.str "c" ] ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument: \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test [ pos_arg_r, D.eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ pos_arg_r :> D.array [ D.str "a" , D.str "b" , D.str "c" ]
            , D.eoa     :> D.array []
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ pos_arg_r :> D.array [ D.str "a" , D.str "b" , D.str "c" ]
            , D.eoa     :> D.array [ D.str "--" , D.str "--" ]
            ]
        ]

    , test
        [ D.grr false [] ]
        [ pass [] [] ]

    , test
        [ D.gro false [] ]
        [ pass [] [] ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ D.opt 'i' "input" (D.oa_ "FILE") :> (D.str "bar") ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail [] "Missing required options: -o, --output=FILE, (-i, --input=FILE)"
        , fail [ "-i", "bar" ] "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
        ]

    , test
        [ D.grr false [[
            D.grr false [[
              D.opt 'i' "input" (D.oa_ "FILE")
            ]]
          , D.opt 'r' "redirect" (D.oa_ "FILE")
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail []
            "Missing required options: -o, --output=FILE, ((-i, --input=FILE) -r, --redirect=FILE)"
        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE")   :> D.str "bar"
            , D.opt 'r' "redirect" (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE")   :> D.str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE")   :> D.str "bar"
            , D.opt 'r' "redirect" (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE")   :> D.str "bar" ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          , D.po  "env"
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.po  "env"                       :> D.str "x"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ cmd_foo
        , opt_o_out
        , opt_q_qux___r
        , opt_b_baz
        , opt_i_input
        , opt_f_foo_FOZ__r
        , cmd_baz
        ]

        [ pass
            [ "foo" , "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ cmd_foo          :> D.bool true
            , opt_o_out        :> D.bool true
            , opt_i_input      :> D.bool true
            , opt_q_qux___r    :> D.array [ D.bool true ]
            , opt_f_foo_FOZ__r :> D.array [ D.str "ox" ]
            , cmd_baz          :> D.bool true
            -- should have added default value that was not provided above:
            , opt_b_baz        :> D.str "ax"
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ cmd_foo          :> D.bool true
            , opt_o_out        :> D.bool true
            , opt_q_qux___r    :> D.array [ D.bool true , D.bool true , D.bool true ]
            , opt_f_foo_FOZ__r :> D.array [D.str "ox"]
            , opt_b_baz        :> D.str "ax"
            , opt_i_input      :> D.bool true
            , cmd_baz          :> D.bool true
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ cmd_foo          :> D.bool true
            , opt_q_qux___r    :> D.array [ D.bool true , D.bool true ]
            , opt_o_out        :> D.bool true
            , opt_i_input      :> D.bool true
            , opt_b_baz        :> D.str "ax"
            , opt_f_foo_FOZ__r :> D.array [ D.str "ox" ]
            , cmd_baz          :> D.bool true
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ cmd_foo          :> D.bool true
            , opt_b_baz        :> D.str "ax"
            , opt_o_out        :> D.bool true
            , opt_f_foo_FOZ__r :> D.array [ D.str "ox" ]
            , opt_i_input      :> D.bool true
            , cmd_baz          :> D.bool true
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ cmd_foo     :> D.bool true
            , opt_o_out   :> D.bool true
            , opt_i_input :> D.bool true
            , opt_b_baz   :> D.str "ax"
            , cmd_baz     :> D.bool true
            -- should have added default value that was not provided above:
            , opt_b_baz   :> D.str "ax"
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ D.gro false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ D.grr false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ D.br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  prettyPrintOut
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

      prettyPrintOut :: Map Argument Value -> String
      prettyPrintOut m = "\n\t" ++ (prettyPrintMap m prettyPrintArg)

      prettyPrintMap :: forall a. Map a Value -> (a -> String) -> String
      prettyPrintMap m p = intercalate "\n\t" $
        Map.toList m <#> \(Tuple arg val) ->
          p arg ++ " => " ++ prettyPrintValue val

      validate :: forall eff. Array Argument
                            -> Array String
                            -> Either String (Map Argument Value)
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = do
              runParser
                (toList argv)
                (genParser $ singleton $ Usage $ singleton $ D.br args)
        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOut r
                  else return unit)
              expected

module Test.Spec.GenSpec (genSpec) where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import qualified Data.Map as Map
import qualified Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import qualified Text.Parsing.Parser as P

import Language.Docopt
import Language.Docopt.ParserGen (genParser, runParser)
import qualified Language.Docopt.ParserGen.Trans as Trans

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)
import Test.Support.Docopt

data Test = Test (Array Argument) (Array Case)
data Case = Case (Array String) (Either String (Map Argument Value))

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Array String -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Array String -> String -> Case
fail i e = Case i (Left e)

(:>) = Tuple
infixr 0 :>

genSpec = \_ -> describe "The generator" do

  -- Some options that will be used for these tests
  let cmd_foo          = co    "foo"
      opt_f_foo_FOZ__r = optR  'f' "foo" (oa_ "FOZ")
      opt_q_qux___r    = optR_ 'q' "qux"
      opt_b_baz        = opt   'b' "baz"   (oa "BAZ" $ str "ax")
      opt_o_out        = opt_  'o' "out"
      opt_i_input      = opt_  'i' "input"
      pos_arg_r        = poR    "qux"
      cmd_baz          = co     "baz"

  let testCases = [

      test [ pos_arg_r ]
        [ pass
            [ "a", "b", "c" ]
            [ pos_arg_r :> array [ str "a" , str "b" , str "c" ] ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument: \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test [ pos_arg_r, eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ pos_arg_r :> array [ str "a" , str "b" , str "c" ]
            , eoa       :> array []
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ pos_arg_r :> array [ str "a" , str "b" , str "c" ]
            , eoa       :> array [ str "--" , str "--" ]
            ]
        ]

    , test
        [ grr false [] ]
        [ pass [] [] ]

    , test
        [ gro false [] ]
        [ pass [] [] ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ opt 'i' "input" (oa_ "FILE") :> (str "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -o, --output=FILE, (-i, --input=FILE)"
        , fail [ "-i", "bar" ] "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") :> str "bar"
            , opt 'o' "output" (oa_ "FILE") :> str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") :> str "bar"
            , opt 'o' "output" (oa_ "FILE") :> str "bar" ]
        ]

    , test
        [ grr false [[
            grr false [[
              opt 'i' "input" (oa_ "FILE")
            ]]
          , opt 'r' "redirect" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail []
            "Missing required options: -o, --output=FILE, ((-i, --input=FILE) -r, --redirect=FILE)"
        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   :> str "bar"
            , opt 'r' "redirect" (oa_ "FILE") :> str "bar"
            , opt 'o' "output" (oa_ "FILE")   :> str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   :> str "bar"
            , opt 'r' "redirect" (oa_ "FILE") :> str "bar"
            , opt 'o' "output" (oa_ "FILE")   :> str "bar" ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          , po  "env"
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") :> str "bar"
            , po  "env"                     :> str "x"
            , opt 'o' "output" (oa_ "FILE") :> str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ cmd_foo
        , opt_o_out
        , opt_q_qux___r
        , opt_b_baz
        , opt_i_input
        , opt_f_foo_FOZ__r
        , cmd_baz
        ]

        [ pass
            [ "foo" , "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ cmd_foo          :> bool true
            , opt_o_out        :> bool true
            , opt_i_input      :> bool true
            , opt_q_qux___r    :> array [ bool true ]
            , opt_f_foo_FOZ__r :> array [ str "ox" ]
            , cmd_baz          :> bool true
            -- should have added default value that was not provided above:
            , opt_b_baz        :> str "ax"
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ cmd_foo          :> bool true
            , opt_o_out        :> bool true
            , opt_q_qux___r    :> array [ bool true , bool true , bool true ]
            , opt_f_foo_FOZ__r :> array [str "ox"]
            , opt_b_baz        :> str "ax"
            , opt_i_input      :> bool true
            , cmd_baz          :> bool true
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ cmd_foo          :> bool true
            , opt_q_qux___r    :> array [ bool true , bool true ]
            , opt_o_out        :> bool true
            , opt_i_input      :> bool true
            , opt_b_baz        :> str "ax"
            , opt_f_foo_FOZ__r :> array [ str "ox" ]
            , cmd_baz          :> bool true
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ cmd_foo          :> bool true
            , opt_b_baz        :> str "ax"
            , opt_o_out        :> bool true
            , opt_f_foo_FOZ__r :> array [ str "ox" ]
            , opt_i_input      :> bool true
            , cmd_baz          :> bool true
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ cmd_foo     :> bool true
            , opt_o_out   :> bool true
            , opt_i_input :> bool true
            , opt_b_baz   :> str "ax"
            , cmd_baz     :> bool true
            -- should have added default value that was not provided above:
            , opt_b_baz   :> str "ax"
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ gro false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ grr false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  prettyPrintOut
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

      prettyPrintOut :: Map Argument Value -> String
      prettyPrintOut m = "\n\t" ++ (prettyPrintMap m prettyPrintArg)

      prettyPrintMap :: forall a. Map a Value -> (a -> String) -> String
      prettyPrintMap m p = intercalate "\n\t" $
        Map.toList m <#> \(Tuple arg val) ->
          p arg ++ " => " ++ prettyPrintValue val

      validate :: forall eff. Array Argument
                            -> Array String
                            -> Either String (Map Argument Value)
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = do
              runParser
                (toList argv)
                (genParser $ singleton $ Usage $ singleton $ br args)
        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOut r
                  else return unit)
              expected


before producer

before producer

{-
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 (main) where

import SlamData.Prelude

import Ace.Config as AceConfig

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Free (fromAff, fromEff)
import Control.Monad.Aff.AVar (AVar, makeVar', modifyVar, putVar, takeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Fork (Canceler(..), fork, cancel)
import Control.Monad.Eff.Exception (Error, error)
import Control.UI.Browser (setTitle, replaceLocation)

import Data.Array (null, filter, mapMaybe)
import Data.Lens (Lens', lens, (%~), (<>~))
import Data.Map as M
import Data.Path.Pathy ((</>), rootDir, parseAbsDir, sandbox, currentDir)

import DOM (DOM)

import Halogen.Component (parentState, interpret)
import Halogen.Driver (Driver, runUI)
import Halogen.Query (action)
import Halogen.Util (runHalogenAff, awaitBody)

import Quasar.Error as QE

import Routing (matchesAff)

import SlamData.Analytics as Analytics
import SlamData.Common.Sort (Sort(..))
import SlamData.Config as Config
import SlamData.Config.Version (slamDataVersion)
import SlamData.Effects (SlamDataEffects, SlamDataRawEffects)
import SlamData.FileSystem.Component (QueryP, Query(..), toListing, toDialog, toSearch, toFs, initialState, comp)
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..))
import SlamData.FileSystem.Resource (Resource, getPath)
import SlamData.FileSystem.Routing (Routes(..), routing, browseURL)
import SlamData.FileSystem.Routing.Salt (Salt, newSalt)
import SlamData.FileSystem.Routing.Search (isSearchQuery, searchPath, filterByQuery)
import SlamData.FileSystem.Search.Component as Search
import SlamData.GlobalError as GE
import SlamData.Monad (Slam, runSlam)
import SlamData.Quasar.FS (children) as Quasar
import SlamData.Quasar.Mount (mountInfo) as Quasar
import SlamData.Wiring (makeWiring)

import Text.SlamSearch.Printer (strQuery)
import Text.SlamSearch.Types (SearchQuery)

import Utils.Path (DirPath, hidePath, renderPath)

main ∷ Eff SlamDataEffects Unit
main = do
  AceConfig.set AceConfig.basePath $ Config.baseUrl ⊕ "js/ace"
  AceConfig.set AceConfig.modePath $ Config.baseUrl ⊕ "js/ace"
  AceConfig.set AceConfig.themePath $ Config.baseUrl ⊕ "js/ace"

  runHalogenAff do
    fork Analytics.enableAnalytics

    wiring ←
      makeWiring rootDir mempty

    let
      ui = interpret (runSlam wiring) comp

    driver ←
      runUI ui (parentState initialState) =<< awaitBody

    fork do
      setSlamDataTitle slamDataVersion
      driver $ left $ action $ SetVersion slamDataVersion

    runSlam wiring $ fork $ routeSignal driver

setSlamDataTitle ∷ ∀ e. String → Aff (dom ∷ DOM|e) Unit
setSlamDataTitle version =
  liftEff $ setTitle $ "SlamData " ⊕ version

type ListingState =
  { canceler ∷ Canceler Error Slam
    -- depth ↔ active requests
  , requestMap ∷ M.Map Int Int
  }

initialListingState ∷ ListingState
initialListingState =
  { canceler: mempty
  , requestMap: M.singleton 0 0
  }

_canceler ∷ ∀ a r. Lens' { canceler ∷ a | r } a
_canceler = lens _.canceler _{ canceler = _ }

_requestMap ∷ ∀ a r. Lens' { requestMap ∷ a | r } a
_requestMap = lens _.requestMap _{ requestMap = _ }

routeSignal ∷ Driver QueryP SlamDataRawEffects → Slam Unit
routeSignal driver = do
  avar ←
    fromAff $ makeVar' initialListingState

  routeTpl ←
    fromAff $ matchesAff routing

  flip uncurry routeTpl
    $ redirects driver avar

redirects
  ∷ Driver QueryP SlamDataRawEffects
  → AVar ListingState
  → Maybe Routes → Routes
  → Slam Unit
redirects driver var mbOld = case _ of
  Index →
    updateURL Nothing Asc Nothing rootDir

  Sort sort →
    updateURL Nothing sort Nothing rootDir

  SortAndQ sort query →
    let
      queryParts = splitQuery query
    in
      updateURL queryParts.query sort Nothing queryParts.path

  Salted sort query salt → do
    {canceler} ← fromAff $ takeVar var

    cancel canceler $ error "cancel search"

    fromAff
      $ putVar var initialListingState

    fromAff
      $ driver
      $ toListing
      $ Listing.SetIsSearching
      $ isSearchQuery query

    let
      queryParts = splitQuery query

      isNewPage = fromMaybe true do
        old ← mbOld
        oldQuery × oldSalt ← case old of
          Salted _ oldQuery' oldSalt' → pure $ oldQuery' × oldSalt'
          _ → Nothing
        pure $ oldQuery ≠ query ∨ oldSalt ≡ salt

    if isNewPage
      then do
      fromAff do
        driver $ toListing Listing.Reset
        driver $ toFs $ SetPath queryParts.path
        driver $ toFs $ SetSort sort
        driver $ toFs $ SetSalt salt
        driver $ toFs $ SetIsMount false
        driver $ toSearch $ Search.SetLoading true
        driver $ toSearch $ Search.SetValue $ fromMaybe "" queryParts.query
        driver $ toSearch $ Search.SetValid true
        driver $ toSearch $ Search.SetPath queryParts.path

      listPath query zero var queryParts.path driver

      when (isNothing queryParts.query)
        $ checkMount queryParts.path driver
      else
        fromAff $ driver $ toSearch $ Search.SetLoading false

checkMount
  ∷ DirPath
  → Driver QueryP SlamDataRawEffects
  → Slam Unit
checkMount path driver = do
  let
    setIsMount =
      fromAff
        $ driver
        $ left
        $ action
        $ SetIsMount true

  Quasar.mountInfo (Left path) >>= case _ of
    Left _ →
      -- When Quasar has no mounts configured we want to enable the root to be
      -- configured as a mount - if `/` is not a mount and also has no children
      -- then we know it's in this unconfigured state.
      when (path ≡ rootDir)
        $ void
        $ Quasar.children path >>= traverse \children →
            when (null children) $ setIsMount

    Right _ →
      setIsMount

listPath
  ∷ SearchQuery
  → Int
  → AVar ListingState
  → DirPath
  → Driver QueryP SlamDataRawEffects
  → Slam Unit
listPath query depth var dir driver = do
  fromAff
    $ flip modifyVar var
    $ _requestMap %~ M.alter memThisRequest depth

  canceler ←
    map Canceler $ fork goDeeper

  fromAff
    $ flip modifyVar var
    $ _canceler <>~ canceler

  where
  memThisRequest = case _ of
    Nothing → Just 1
    Just n → Just $ n + 1

  markThisRequestAsFinished = case _ of
    Just v | v > 1 → Just $ v - 1
    _ → Nothing

  -- Note that initialState is (zero ↔ zero) and final Ø
  allRequestsAreFinished = M.isEmpty

  goDeeper = do
    Quasar.children dir >>= either sendError getChildren
    fromAff do
      flip modifyVar var
        $ _requestMap %~ M.alter markThisRequestAsFinished depth

      st@{canceler: c, requestMap: r} ←
        takeVar var

      if allRequestsAreFinished r
        then do
        driver $ toSearch $ Search.SetLoading false
        putVar var initialListingState
        else
        putVar var st

  sendError ∷ QE.QError → Slam Unit
  sendError err =
    case GE.fromQError err of
      Left msg →
        presentError $
          "There was a problem accessing this directory listing. " <> msg
      Right ge →
        GE.raiseGlobalError ge

  presentError message =
    when ((not $ isSearchQuery query) ∨ depth ≡ zero)
      $ fromAff
      $ driver
      $ toDialog $ Dialog.Show
      $ Dialog.Error message

  getChildren ∷ Array Resource → Slam Unit
  getChildren ress = do
    let
      next = do
        guard $ isSearchQuery query
        flip mapMaybe ress $ either Just (const Nothing) ∘ getPath
      toAdd =
        map Item $ flip filter ress $ filterByQuery query

    fromAff
      $ driver
      $ toListing
      $ Listing.Adds toAdd

    flip parTraverse_ next \n →
      listPath query (depth + one) var n driver

updateURL
  ∷ Maybe String
  → Sort
  → Maybe Salt
  → DirPath
  → Slam Unit
updateURL query sort salt path = fromEff do
  salt' ← maybe newSalt pure salt
  replaceLocation $ browseURL query sort salt' path

splitQuery
  ∷ SearchQuery
  → { path ∷ DirPath, query ∷ Maybe String }
splitQuery q =
  { path: path
  , query: query
  }
  where
  path =
    rootDir </> fromMaybe currentDir
      (searchPath q >>= parseAbsDir >>= sandbox rootDir)
  query = do
    guard $ isSearchQuery q
    pure $ hidePath (renderPath $ Left path) (strQuery q)

{-
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 (main) where

import SlamData.Prelude

import Ace.Config as AceConfig

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Free (fromAff, fromEff)
import Control.Monad.Aff.AVar (AVar, makeVar', modifyVar, putVar, takeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Fork (Canceler(..), fork, cancel)
import Control.Monad.Eff.Exception (Error, error)
import Control.UI.Browser (setTitle, replaceLocation)

import Data.Array (null, filter, mapMaybe)
import Data.Lens (Lens', lens, (%~), (<>~))
import Data.Map as M
import Data.Path.Pathy ((</>), rootDir, parseAbsDir, sandbox, currentDir)

import DOM (DOM)

import Halogen.Component (parentState, interpret)
import Halogen.Driver (Driver, runUI)
import Halogen.Query (action)
import Halogen.Util (runHalogenAff, awaitBody)

import Quasar.Error as QE

import Routing (matchesAff)

import SlamData.Analytics as Analytics
import SlamData.Common.Sort (Sort(..))
import SlamData.Config as Config
import SlamData.Config.Version (slamDataVersion)
import SlamData.Effects (SlamDataEffects, SlamDataRawEffects)
import SlamData.FileSystem.Component (QueryP, Query(..), toListing, toDialog, toSearch, toFs, initialState, comp)
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..))
import SlamData.FileSystem.Resource (Resource, getPath)
import SlamData.FileSystem.Routing (Routes(..), routing, browseURL)
import SlamData.FileSystem.Routing.Salt (Salt, newSalt)
import SlamData.FileSystem.Routing.Search (isSearchQuery, searchPath, filterByQuery)
import SlamData.FileSystem.Search.Component as Search
import SlamData.GlobalError as GE
import SlamData.Monad (Slam, runSlam)
import SlamData.Quasar.FS (children) as Quasar
import SlamData.Quasar.Mount (mountInfo) as Quasar
import SlamData.Wiring (makeWiring)

import Text.SlamSearch.Printer (strQuery)
import Text.SlamSearch.Types (SearchQuery)

import Utils.Path (DirPath, hidePath, renderPath)

main ∷ Eff SlamDataEffects Unit
main = do
  AceConfig.set AceConfig.basePath (Config.baseUrl ⊕ "js/ace")
  AceConfig.set AceConfig.modePath (Config.baseUrl ⊕ "js/ace")
  AceConfig.set AceConfig.themePath (Config.baseUrl ⊕ "js/ace")
  runHalogenAff do
    fork Analytics.enableAnalytics
    wiring ← makeWiring rootDir mempty
    let ui = interpret (runSlam wiring) comp
    driver ← runUI ui (parentState initialState) =<< awaitBody
    fork do
      setSlamDataTitle slamDataVersion
      driver (left $ action $ SetVersion slamDataVersion)
    runSlam wiring $ fork $ routeSignal driver

setSlamDataTitle ∷ ∀ e. String → Aff (dom ∷ DOM|e) Unit
setSlamDataTitle version =
  liftEff $ setTitle $ "SlamData " ⊕ version

type ListingState =
  { canceler ∷ Canceler Error Slam
    -- depth ↔ active requests
  , requestMap ∷ M.Map Int Int
  }

initialListingState ∷ ListingState
initialListingState =
  { canceler: mempty
  , requestMap: M.empty
  }

_canceler ∷ ∀ a r. Lens' { canceler ∷ a | r } a
_canceler = lens _.canceler _{ canceler = _ }

_requestMap ∷ ∀ a r. Lens' { requestMap ∷ a | r } a
_requestMap = lens _.requestMap _{ requestMap = _ }

routeSignal ∷ Driver QueryP SlamDataRawEffects → Slam Unit
routeSignal driver = do
  avar ← fromAff $ makeVar' initialListingState
  routeTpl ← fromAff $ matchesAff routing
  uncurry (redirects driver avar) routeTpl

redirects
  ∷ Driver QueryP SlamDataRawEffects
  → AVar ListingState
  → Maybe Routes → Routes
  → Slam Unit
redirects driver var mbOld = case _ of
  Index →
    updateURL Nothing Asc Nothing rootDir
  Sort sort →
    updateURL Nothing sort Nothing rootDir
  SortAndQ sort query →
    let queryParts = splitQuery query
    in updateURL queryParts.query sort Nothing queryParts.path
  Salted sort query salt → do
    {canceler} ← fromAff $ takeVar var
    cancel canceler (error "cancel search")
    fromAff $ putVar var initialListingState
    fromAff $ driver $ toListing $ Listing.SetIsSearching $ isSearchQuery query
    let
      queryParts = splitQuery query
      isNewPage = fromMaybe true do
        old ← mbOld
        oldQuery × oldSalt ← case old of
          Salted _ oldQuery' oldSalt' → pure $ oldQuery' × oldSalt'
          _ → Nothing
        pure $ oldQuery ≠ query ∨ oldSalt ≡ salt
    if isNewPage
      then do
        fromAff do
          driver $ toListing Listing.Reset
          driver $ toFs $ SetPath queryParts.path
          driver $ toFs $ SetSort sort
          driver $ toFs $ SetSalt salt
          driver $ toFs $ SetIsMount false
          driver $ toSearch $ Search.SetLoading true
          driver $ toSearch $ Search.SetValue $ fromMaybe "" queryParts.query
          driver $ toSearch $ Search.SetValid true
          driver $ toSearch $ Search.SetPath queryParts.path
        listPath query zero var queryParts.path driver
        maybe (checkMount queryParts.path driver) (const $ pure unit) queryParts.query
      else
        fromAff $ driver $ toSearch $ Search.SetLoading false

checkMount
  ∷ DirPath
  → Driver QueryP SlamDataRawEffects
  → Slam Unit
checkMount path driver = do
  Quasar.mountInfo (Left path) >>= case _ of
    Left _ →
      -- When Quasar has no mounts configured we want to enable the root to be
      -- configured as a mount - if `/` is not a mount and also has no children
      -- then we know it's in this unconfigured state.
      when (path == rootDir) do
        void $ Quasar.children path >>= traverse \children →
          when (null children) $
            fromAff $ driver $ left $ action $ SetIsMount true
    Right _ →
      fromAff $ driver $ left $ action $ SetIsMount true

listPath
  ∷ SearchQuery
  → Int
  → AVar ListingState
  → DirPath
  → Driver QueryP SlamDataRawEffects
  → Slam Unit
listPath query deep var dir driver = do
  fromAff $ modifyVar (_requestMap %~ M.alter (pure ∘ maybe 1 (_ + 1)) deep) var
  canceler ← Canceler <$> fork goDeeper
  fromAff $ modifyVar (_canceler <>~ canceler) var
  where
  goDeeper = do
    Quasar.children dir >>= either sendError getChildren
    fromAff do
      modifyVar (_requestMap %~ M.update (\v → guard (v > one) $> (v - one)) deep) var
      st@{canceler: c, requestMap: r} ← takeVar var
      if (foldl (+) zero $ M.values r) ≡ zero
        then do
        driver $ toSearch $ Search.SetLoading false
        putVar var initialListingState
        else
        putVar var st

  sendError ∷ QE.QError → Slam Unit
  sendError err =
    case GE.fromQError err of
      Left msg →
        presentError $
          "There was a problem accessing this directory listing. " <> msg
      Right ge →
        GE.raiseGlobalError ge

  presentError message =
    when ((not $ isSearchQuery query) ∨ deep ≡ zero)
      $ fromAff
      $ driver
      $ toDialog $ Dialog.Show
      $ Dialog.Error message

  getChildren ∷ Array Resource → Slam Unit
  getChildren ress = do
    let next = mapMaybe (either Just (const Nothing) <<< getPath) ress
        toAdd = map Item $ filter (filterByQuery query) ress
    fromAff $ driver $ toListing $ Listing.Adds toAdd
    parTraverse_ (\n → listPath query (deep + one) var n driver)
      (guard (isSearchQuery query) *> next)

updateURL
  ∷ Maybe String
  → Sort
  → Maybe Salt
  → DirPath
  → Slam Unit
updateURL query sort salt path = fromEff do
  salt' ← maybe newSalt pure salt
  replaceLocation $ browseURL query sort salt' path

splitQuery
  ∷ SearchQuery
  → { path ∷ DirPath, query ∷ Maybe String }
splitQuery q =
  { path: path
  , query: query
  }
  where
  path =
    rootDir </> fromMaybe currentDir
      (searchPath q >>= parseAbsDir >>= sandbox rootDir)
  query = do
    guard $ isSearchQuery q
    pure $ hidePath (renderPath $ Left path) (strQuery q)