├── .envrc ├── .github └── workflows │ └── nix-test.yml ├── .gitignore ├── .replica └── test │ ├── check_file │ ├── expected │ └── file │ ├── crossSuiteDependency │ └── expected │ ├── custom_golden_dir │ └── expected │ ├── custom_golden_dir_for_file │ └── expected │ ├── end_fail │ └── expected │ ├── error_expectation │ └── expected.err │ ├── excludeSuite │ └── expected │ ├── fileREPL │ ├── expected │ └── input │ ├── file_expectation1 │ └── file │ │ └── tmp123456 │ ├── file_expectation2 │ └── file │ │ └── tests │ │ └── tmp123456 │ ├── includeSuite │ └── expected │ ├── loadAFile │ └── expected │ ├── loadAPackage │ ├── expected │ └── input │ ├── local_config │ └── expected │ ├── multi_json │ └── expected │ ├── multi_json_error │ ├── expected │ └── expected.err │ ├── new_dhall_empty_template │ └── expected │ ├── new_dhall_template │ └── expected │ ├── new_json_empty_template │ └── expected │ ├── new_json_template │ └── expected │ ├── no_golden_with_inlined_expectation │ └── expected │ ├── opposite_include_exclude │ ├── expected │ └── expected.err │ ├── opposite_include_exclude_tags │ ├── expected │ └── expected.err │ ├── ordered_partial_expectation_mismatch │ └── expected │ ├── packageREPL │ ├── expected │ └── input │ ├── rawREPL │ ├── expected │ └── input │ ├── simpleDisplay │ └── expected │ ├── simplest_success │ └── expected │ ├── start_fail │ └── expected │ ├── test │ ├── test space │ └── expected │ ├── testBefore │ └── expected │ ├── testBeforeTestFailImpact │ └── expected │ ├── testExclude │ └── expected │ ├── testExcludeTags │ └── expected │ ├── testInput │ ├── expected │ └── input │ ├── testOnly │ └── expected │ ├── testOutput │ └── expected │ ├── testOutputMismatch │ └── expected │ ├── testPending │ └── expected │ ├── testPunitive │ └── expected │ ├── testReplica │ └── expected │ ├── testRequire │ └── expected │ ├── testSkipExcludedDependencies │ └── expected │ ├── testTags │ └── expected │ ├── testWorkingDir │ └── expected │ ├── test_failure │ └── expected │ ├── test_success │ └── expected │ ├── unknown_command │ ├── expected │ └── expected.err │ └── unknown_parameter │ ├── expected │ └── expected.err ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENSE ├── Makefile ├── README.md ├── RELEASE.md ├── default.nix ├── documentation ├── ErrorCodes.md ├── README_JSON.md ├── TestExecution.md └── TestSpecification.md ├── examples ├── hello.dhall └── hello.json ├── flake.lock ├── flake.nix ├── nix ├── buildReplica.nix ├── online-tests.nix ├── papersLib.nix ├── replica.nix └── replicaTest.nix ├── replica.ipkg ├── scripts └── release.sh ├── src ├── Replica.idr └── Replica │ ├── App.idr │ ├── App │ ├── Clock.idr │ ├── Display.idr │ ├── FileSystem.idr │ ├── Filter.idr │ ├── Format.idr │ ├── Info.idr │ ├── Info │ │ ├── Suite.idr │ │ ├── Test.idr │ │ └── Types.idr │ ├── Log.idr │ ├── New.idr │ ├── Replica.idr │ ├── Run.idr │ ├── Run │ │ ├── Dependencies.idr │ │ ├── Display.idr │ │ ├── RunOne.idr │ │ └── Types.idr │ ├── Set.idr │ └── System.idr │ ├── Command.idr │ ├── Command │ ├── Help.idr │ ├── Info.idr │ ├── Info │ │ ├── Suite.idr │ │ └── Test.idr │ ├── New.idr │ ├── Run.idr │ ├── Set.idr │ └── Version.idr │ ├── Core.idr │ ├── Core │ ├── Parse.idr │ ├── Test.idr │ └── Types.idr │ ├── Help.idr │ ├── Option │ ├── Filter.idr │ ├── Global.idr │ ├── Parse.idr │ └── Types.idr │ └── Other │ ├── Decorated.idr │ ├── Free.idr │ ├── String.idr │ └── Validation.idr ├── tests.dhall ├── tests ├── Meta │ ├── Help.dhall │ ├── Info.dhall │ ├── Run.dhall │ ├── Type.dhall │ ├── default.dhall │ ├── package.dhall │ ├── toCommand.dhall │ └── toTest.dhall ├── basic │ └── run.sh ├── help.dhall ├── idris.dhall ├── idris │ ├── file │ │ └── Test.idr │ └── package │ │ ├── Test.idr │ │ └── test.ipkg ├── parsing_errors.dhall ├── replica │ ├── allButOne │ │ ├── .replica │ │ │ └── test │ │ │ │ ├── theChosen │ │ │ │ ├── expected │ │ │ │ └── output │ │ │ │ ├── unfortunate1 │ │ │ │ └── output │ │ │ │ ├── unfortunate2 │ │ │ │ └── output │ │ │ │ └── unfortunate3 │ │ │ │ └── output │ │ └── tests.dhall │ ├── beforeFailed │ │ ├── .replica │ │ │ └── test │ │ │ │ └── later │ │ │ │ ├── expected │ │ │ │ └── output │ │ ├── getOut │ │ │ └── includeMe.txt │ │ └── tests.dhall │ ├── empty │ │ └── tests.dhall │ ├── end_fail │ │ └── tests.dhall │ ├── goldenDir │ │ ├── .replica │ │ │ └── test │ │ │ │ ├── mismatch │ │ │ │ ├── expected │ │ │ │ └── output │ │ │ │ └── valid │ │ │ │ └── output │ │ ├── golden │ │ │ └── valid │ │ │ │ └── expected │ │ └── tests.dhall │ ├── goldenDirFile │ │ ├── .replica │ │ │ └── test │ │ │ │ ├── mismatch │ │ │ │ ├── expected │ │ │ │ └── output │ │ │ │ └── valid │ │ │ │ └── output │ │ ├── golden │ │ │ └── valid │ │ │ │ ├── expected │ │ │ │ └── file │ │ └── tests.dhall │ ├── inlineMismatch │ │ ├── .replica │ │ │ └── test │ │ │ │ └── mismatch │ │ │ │ └── output │ │ └── tests.dhall │ ├── localConfig │ │ ├── .replica.json │ │ ├── .replica │ │ │ └── test │ │ │ │ └── mismatch │ │ │ │ └── expected │ │ ├── golden │ │ │ └── valid │ │ │ │ └── expected │ │ └── tests.dhall │ ├── mismatch │ │ ├── .replica │ │ │ └── test │ │ │ │ └── mismatch │ │ │ │ ├── expected │ │ │ │ └── output │ │ └── tests.dhall │ ├── multi │ │ ├── .replica │ │ │ └── test │ │ │ │ ├── one │ │ │ │ └── expected │ │ │ │ └── two │ │ │ │ └── expected │ │ ├── tests1.dhall │ │ ├── tests2.dhall │ │ └── testsDup.dhall │ ├── new │ │ └── .keepit │ ├── onePending │ │ ├── .replica │ │ │ └── test │ │ │ │ └── two │ │ │ │ ├── expected │ │ │ │ └── output │ │ └── tests.dhall │ ├── orderedPartialFail │ │ ├── .replica │ │ │ └── test │ │ │ │ └── ordered_partial_expectation_mismatch │ │ │ │ └── output │ │ └── tests.dhall │ ├── require1 │ │ ├── .replica │ │ │ └── test │ │ │ │ ├── depends_failed │ │ │ │ ├── expected │ │ │ │ └── output │ │ │ │ └── root_failed │ │ │ │ └── output │ │ └── tests.dhall │ ├── start_fail │ │ └── tests.dhall │ ├── suite │ │ ├── crossSuiteDependency.dhall │ │ └── simpleDisplay.dhall │ ├── tooManyError │ │ └── tests.dhall │ └── two │ │ ├── .replica │ │ └── test │ │ │ ├── one │ │ │ ├── expected │ │ │ └── output │ │ │ └── two │ │ │ ├── expected │ │ │ └── output │ │ └── tests.dhall └── suite.dhall ├── utils ├── .gitignore ├── Makefile ├── README.md └── _replica └── version.nix /.envrc: -------------------------------------------------------------------------------- 1 | use flake 2 | -------------------------------------------------------------------------------- /.github/workflows/nix-test.yml: -------------------------------------------------------------------------------- 1 | name: "nix test" 2 | on: 3 | pull_request: 4 | push: 5 | branches: 6 | - 'main' 7 | jobs: 8 | test-matrix: 9 | strategy: 10 | matrix: 11 | os: [ubuntu-latest, macos-latest] 12 | runs-on: ${{ matrix.os }} 13 | steps: 14 | - name: Checkout 15 | uses: actions/checkout@v3 16 | - name: Set up nix 17 | uses: cachix/install-nix-action@v18 18 | - name: Start cachix 19 | uses: cachix/cachix-action@v12 20 | with: 21 | name: replica 22 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 23 | - name: Test build 24 | run: nix build 25 | - name: Run tests 26 | run: nix flake check --show-trace 27 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .replica/log 2 | .replica/test/*/output 3 | .replica/test/*/status 4 | .replica/test/*/error 5 | /tests/replica/*/.replica/log 6 | /tests/replica/*/*.json 7 | /tests/replica/*/.replica/test/*/output 8 | /tests/replica/*/.replica/test/*/status 9 | /tests/replica/*/.replica/test/*/error 10 | examples/.replica 11 | 12 | /.pre-commit-config.yaml 13 | 14 | /.direnv 15 | /tests.json 16 | /.history 17 | /.replica.json 18 | src/Replica/Version.idr 19 | 20 | /build 21 | /submodules 22 | 23 | -------------------------------------------------------------------------------- /.replica/test/check_file/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/.replica/test/check_file/expected -------------------------------------------------------------------------------- /.replica/test/check_file/file: -------------------------------------------------------------------------------- 1 | hello, world 2 | -------------------------------------------------------------------------------- /.replica/test/crossSuiteDependency/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | Suite: A 5 | ✅ secondA 6 | Suite: B 7 | ✅ oneB 8 | Suite: A 9 | ✅ oneA 10 | -------------------------------------------------------------------------------- 11 | Summary: 12 | ✅ (Success): 3 / 3 13 | -------------------------------------------------------------------------------- /.replica/test/custom_golden_dir/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ valid 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/custom_golden_dir_for_file/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ valid 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/end_fail/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ❌ end_failure: 6 | Error on standard output: 7 | End mismatch: 8 | Warld! 9 | Given: 10 | Hello, World! 11 | -------------------------------------------------------------------------------- 12 | Summary: 13 | ❌ (Failure): 1 / 1 14 | -------------------------------------------------------------------------------- /.replica/test/error_expectation/expected.err: -------------------------------------------------------------------------------- 1 | test 2 | -------------------------------------------------------------------------------- /.replica/test/excludeSuite/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | Suite: B 5 | ✅ oneB 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/fileREPL/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Test (Test.idr) 2 | Test> "Hello, World!" 3 | Test> Bye for now! 4 | -------------------------------------------------------------------------------- /.replica/test/fileREPL/input: -------------------------------------------------------------------------------- 1 | aString 2 | :q 3 | -------------------------------------------------------------------------------- /.replica/test/file_expectation1/file/tmp123456: -------------------------------------------------------------------------------- 1 | test 2 | -------------------------------------------------------------------------------- /.replica/test/file_expectation2/file/tests/tmp123456: -------------------------------------------------------------------------------- 1 | test 2 | -------------------------------------------------------------------------------- /.replica/test/includeSuite/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | Suite: A 5 | ✅ oneA 6 | ✅ secondA 7 | -------------------------------------------------------------------------------- 8 | Summary: 9 | ✅ (Success): 2 / 2 10 | -------------------------------------------------------------------------------- /.replica/test/loadAFile/expected: -------------------------------------------------------------------------------- 1 | "Hello, World!" 2 | -------------------------------------------------------------------------------- /.replica/test/loadAPackage/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Test (Test.idr) 2 | Test> Imported module Test 3 | Test> "Hello, World!" 4 | Test> Bye for now! 5 | -------------------------------------------------------------------------------- /.replica/test/loadAPackage/input: -------------------------------------------------------------------------------- 1 | :module Test 2 | aString 3 | :q 4 | -------------------------------------------------------------------------------- /.replica/test/local_config/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ valid 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/multi_json/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ one 6 | ✅ two 7 | -------------------------------------------------------------------------------- 8 | Summary: 9 | ✅ (Success): 2 / 2 10 | -------------------------------------------------------------------------------- /.replica/test/multi_json_error/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/.replica/test/multi_json_error/expected -------------------------------------------------------------------------------- /.replica/test/multi_json_error/expected.err: -------------------------------------------------------------------------------- 1 | Can't parse JSON: 2 | Duplicated key(s): ["one"] 3 | -------------------------------------------------------------------------------- /.replica/test/new_dhall_empty_template/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | -------------------------------------------------------------------------------- 5 | Summary: 6 | No test 7 | -------------------------------------------------------------------------------- /.replica/test/new_dhall_template/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ hello 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/new_json_empty_template/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | -------------------------------------------------------------------------------- 5 | Summary: 6 | No test 7 | -------------------------------------------------------------------------------- /.replica/test/new_json_template/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ hello 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/no_golden_with_inlined_expectation/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | -------------------------------------------------------------------------------- 6 | Test results: 7 | No suite given: 8 | ❌ mismatch: 9 | Error on standard output: 10 | Exact expectation mismatch: 11 | two 12 | Given: 13 | one 14 | -------------------------------------------------------------------------------- 15 | Summary: 16 | ❌ (Failure): 1 / 1 17 | -------------------------------------------------------------------------------- /.replica/test/opposite_include_exclude/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/.replica/test/opposite_include_exclude/expected -------------------------------------------------------------------------------- /.replica/test/opposite_include_exclude/expected.err: -------------------------------------------------------------------------------- 1 | Some tests were both included and excluded: one 2 | -------------------------------------------------------------------------------- /.replica/test/opposite_include_exclude_tags/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/.replica/test/opposite_include_exclude_tags/expected -------------------------------------------------------------------------------- /.replica/test/opposite_include_exclude_tags/expected.err: -------------------------------------------------------------------------------- 1 | Some tags were both included and excluded: shiny 2 | -------------------------------------------------------------------------------- /.replica/test/ordered_partial_expectation_mismatch/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ❌ ordered_partial_expectation_mismatch: 6 | Error on standard output: 7 | Consecutive expectations mismatch, first not found: 8 | Hello 9 | Given: 10 | Hello, World! 11 | -------------------------------------------------------------------------------- 12 | Summary: 13 | ❌ (Failure): 1 / 1 14 | -------------------------------------------------------------------------------- /.replica/test/packageREPL/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Test (Test.idr) 2 | Test> Imported module Test 3 | Test> "Hello, World!" 4 | Test> Bye for now! 5 | -------------------------------------------------------------------------------- /.replica/test/packageREPL/input: -------------------------------------------------------------------------------- 1 | :module Test 2 | aString 3 | :q 4 | -------------------------------------------------------------------------------- /.replica/test/rawREPL/expected: -------------------------------------------------------------------------------- 1 | Main> Just "work!" 2 | Main> Bye for now! 3 | -------------------------------------------------------------------------------- /.replica/test/rawREPL/input: -------------------------------------------------------------------------------- 1 | Just "work!" 2 | :q 3 | -------------------------------------------------------------------------------- /.replica/test/simpleDisplay/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | Suite: A 5 | ✅ oneA 6 | ✅ secondA 7 | Suite: B 8 | ✅ oneB 9 | -------------------------------------------------------------------------------- 10 | Summary: 11 | ✅ (Success): 3 / 3 12 | -------------------------------------------------------------------------------- /.replica/test/simplest_success/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/.replica/test/simplest_success/expected -------------------------------------------------------------------------------- /.replica/test/start_fail/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ❌ start_fail: 6 | Error on standard output: 7 | Start mismatch: 8 | Hella 9 | Given: 10 | Hello, World! 11 | -------------------------------------------------------------------------------- 12 | Summary: 13 | ❌ (Failure): 1 / 1 14 | -------------------------------------------------------------------------------- /.replica/test/test: -------------------------------------------------------------------------------- 1 | 0 space/status 2 | -------------------------------------------------------------------------------- /.replica/test/test space/expected: -------------------------------------------------------------------------------- 1 | Hello, World! 2 | -------------------------------------------------------------------------------- /.replica/test/testBefore/expected: -------------------------------------------------------------------------------- 1 | Fresh content 2 | -------------------------------------------------------------------------------- /.replica/test/testBeforeTestFailImpact/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ⚠️ before: Before test action failed: oops 6 | ✅ later 7 | -------------------------------------------------------------------------------- 8 | Summary: 9 | ✅ (Success): 1 / 2 10 | ⚠️ (Errors): 1 / 2 11 | -------------------------------------------------------------------------------- /.replica/test/testExclude/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ two 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/testExcludeTags/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ one 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/testInput/expected: -------------------------------------------------------------------------------- 1 | hello, world -------------------------------------------------------------------------------- /.replica/test/testInput/input: -------------------------------------------------------------------------------- 1 | hello, world -------------------------------------------------------------------------------- /.replica/test/testOnly/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ one 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/testOutput/expected: -------------------------------------------------------------------------------- 1 | Hello, World! 2 | -------------------------------------------------------------------------------- /.replica/test/testOutputMismatch/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ❌ mismatch: 6 | Error on standard output: 7 | Golden value expectation mismatch: 8 | two 9 | Given: 10 | one 11 | -------------------------------------------------------------------------------- 12 | Summary: 13 | ❌ (Failure): 1 / 1 14 | -------------------------------------------------------------------------------- /.replica/test/testPending/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | 💤 one 6 | ✅ two 7 | -------------------------------------------------------------------------------- 8 | Summary: 9 | ✅ (Success): 1 / 2 10 | 💤 (Pending): 1 / 2 11 | -------------------------------------------------------------------------------- /.replica/test/testPunitive/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ theChosen 6 | ❌ unfortunate1: 7 | [Fails while it should pass : 1] 8 | [Missing Golden for standard output] 9 | [Unexpected content for standard output] 10 | Error on standard output: 11 | Given: 12 | -------------------------------------------------------------------------------- 13 | Summary: 14 | ❌ (Failure): 1 / 1 15 | -------------------------------------------------------------------------------- /.replica/test/testReplica/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | -------------------------------------------------------------------------------- 5 | Summary: 6 | No test 7 | -------------------------------------------------------------------------------- /.replica/test/testRequire/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ❌ root_failed: 6 | [Fails while it should pass : 1] 7 | [Missing Golden for standard output] 8 | [Unexpected content for standard output] 9 | Error on standard output: 10 | Given: 11 | No suite given: 12 | ⚠️ depends_failed: Test rely on test root_failed, which failed 13 | -------------------------------------------------------------------------------- 14 | Summary: 15 | ❌ (Failure): 1 / 2 16 | ⚠️ (Errors): 1 / 2 17 | -------------------------------------------------------------------------------- /.replica/test/testSkipExcludedDependencies/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ depends_failed 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/testTags/expected: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | Running tests... 3 |  4 | No suite given: 5 | ✅ two 6 | -------------------------------------------------------------------------------- 7 | Summary: 8 | ✅ (Success): 1 / 1 9 | -------------------------------------------------------------------------------- /.replica/test/testWorkingDir/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/.replica/test/testWorkingDir/expected -------------------------------------------------------------------------------- /.replica/test/test_failure/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/.replica/test/test_failure/expected -------------------------------------------------------------------------------- /.replica/test/test_success/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/.replica/test/test_success/expected -------------------------------------------------------------------------------- /.replica/test/unknown_command/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/.replica/test/unknown_command/expected -------------------------------------------------------------------------------- /.replica/test/unknown_command/expected.err: -------------------------------------------------------------------------------- 1 | Invalid command or option: tagada, tests.json 2 | 3 | Usage: replica COMMAND [COMMAND_OPTIONS] 4 | 5 | Integration testing for command line interfaces 6 | 7 | Commands: 8 | run Run tests from a Replica JSON file 9 | test Alias for 'replica run' 10 | info Get information about a given test file 11 | set Set a global configuration for replica commands 12 | new Create test files 13 | version Show replica version 14 | 15 | Run 'replica help COMMAND' for more information on a command. 16 | -------------------------------------------------------------------------------- /.replica/test/unknown_parameter/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/.replica/test/unknown_parameter/expected -------------------------------------------------------------------------------- /.replica/test/unknown_parameter/expected.err: -------------------------------------------------------------------------------- 1 | Invalid command or option: --oops 2 | 3 | Usage: replica run [OPTIONS] JSON_TEST_FILE(S) 4 | 5 | Run tests from a Replica JSON file 6 | 7 | Options: 8 | --working-dir, --wdir, -w DIR set where is the test working directory 9 | --interactive, -i (re)generate golden number if different/missing 10 | --no-timing, --no-duration, -D hide execution time of each tests 11 | --timing, --duration, -d display execution time of each tests 12 | --threads, -x N max number of threads (default 1; 0 for no thread limit) 13 | --hide-success, --fail-only hide successful tests in the report 14 | --punitive, --fail-fast, -p fail fast mode: stops on the first test that fails 15 | --only, -n testX,testY a comma separated list of the tests to run 16 | --exclude, -N testX,testY a comma separated list of the tests to exclude 17 | --tags, --only-tags, -t TAGS a comma separated list of the tags to run 18 | --exclude-tags, -T TAGS a comma separated list of the tags to exclude 19 | --suites, --only-suites, -s SUITES a comma separated list of the suites to run 20 | --exclude-suites, -S SUITES a comma separated list of the suites to exclude 21 | --last-fails, -l if a previous run fails, rerun only the tests that failed 22 | --replica-dir DIR set the location of replica store (default: ".replica") 23 | --golden-dir DIR set the location of golden values (default: "REPLICA_DIR/test") 24 | --no-color, --no-colour desactivate colour in output 25 | --color, --colour, -c activate colour in output (default) 26 | --ascii use only ascii in reports (unless there are some in your test file) 27 | --utf8 allow emojis in reports (default) 28 | --verbose, -v similar to --log info 29 | --log logLevel define the log level of the application 30 | available values: (default: none) 31 | --no-diff remove all diff from the output, equivalent of `--diff none` 32 | --diff, -d CMD diff command use to display difference between the given and the golden one 33 | available values: (default : native) 34 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # REPLica changelog 2 | 3 | ## version 0.6.0 4 | 5 | - CHANGE: 6 | - exit error code has changed: 7 | - we don't count error after 128 8 | - error code semantic is more precise and documented 9 | - error text when calling replica is sent to `stderr` 10 | 11 | - INTERNAL: 12 | - pre-commit hooks 13 | 14 | ## version 0.5.2 15 | 16 | - INTERNAL: 17 | - Explicit version management 18 | 19 | ## version 0.5.1 20 | 21 | - INTERNAL: 22 | - Port the code base to Idris2 0.6.0 23 | - Upgrade nix flake (`nix check` and `nix develop` works) 24 | 25 | ## version 0.5.0 26 | 27 | - CHANGE: 28 | - The dhall language for replica has changed and is now hosted in its own project. 29 | If you have existing `dhall` tests that you don't want to change, you can use 30 | this url as an entry point for replica: 31 | . 32 | - Migration to Idris2 0.5.1 33 | - NEW: 34 | - `replica new` to create tests file templates 35 | - `suite` to organise your test by suites 36 | - test name with spaces are officially supported 37 | - execution time of each test is tracked 38 | - FIX: 39 | - `replica help` mentions `version` 40 | - skipped tests are displayed 41 | 42 | ## version 0.4.0 43 | 44 | - CHANGE: 45 | - Expectation format: Note if you use "partial expectations" in your tests, 46 | you need to upgrade your tests suites. 47 | - NEW: 48 | - New expectations functions: `contains`, `consecutive`, `start`, `end` 49 | - Differentiate `stdOut` and `stdErr` 50 | - command exit code can be checked 51 | - we can submit several json files 52 | - add a `version` subcommand 53 | 54 | ## version 0.3.1 55 | 56 | - FIX documentation error in replica set 57 | - CHANGE docker entry point is now a shell 58 | 59 | ## version 0.3.0 60 | 61 | - Can mark tests as _pending_ 62 | - Can set `expected` in json and dhall to specify expected output directly 63 | - Can check the content of a generated file using `outputFile` 64 | - Partial expectations 65 | - Space sensitivity is configurable 66 | - Directory for golden values is configurable 67 | - external configuration (via `replica set`) 68 | - nix flake (thanks to Matthieu Coudron) 69 | - dockerfile 70 | 71 | ## version 0.2.0 72 | 73 | - Tests suites are in json format, with dhall support 74 | - Tests have: 75 | - tags 76 | - dependencies 77 | - description 78 | - pre/post acitions 79 | - definition of a working directories 80 | - input that will replace stdin 81 | - Multi-threading is supported (tests are sent by bathches of n threads) 82 | - Expcetations, last outputs, and tests results are stored in `.replica` 83 | - Filters to run a subset of tests 84 | 85 | ## version 0.1 86 | 87 | - direct port of idris2 testing libraries, 88 | with a configuration file _à la_ idris package. 89 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to REPLica 2 | 3 | ## Setting up an environment 4 | 5 | The best way to setup a working environment is to use [`nix flakes`][nix-flakes] 6 | 7 | `nix develop` should bring everything you need: 8 | the current `idris2` version we use and its libraries, 9 | `dhall` and `dhall-to-json`. 10 | 11 | [nix-flakes]: https://nixos.wiki/wiki/Flakes 12 | 13 | ## Running the tests 14 | 15 | `make test` is running all the tests referenced in `tests.dhall`. 16 | Note that the tests are run by the current version of `REPLica`, so if you're 17 | changing the behaviour of `REPLica` during your development, it may impact the 18 | tests. 19 | If you prefer to use a stable version of replica to launch your tests, you can 20 | set the `REPLICA_EXE` variable to the path of the replica version you want to 21 | use. 22 | 23 | In the end though, the tests must pass with the current version. 24 | 25 | If you want to update the golden values of the tests, you can use `make generate`. 26 | 27 | All contributions are welcome. 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2020 Nicolas Biri 2 | 3 | This code is derived from software written by Edwin Brady 4 | (ecb10@st-andrews.ac.uk). 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 3. None of the names of the copyright holders may be used to endorse 15 | or promote products derived from this software without specific 16 | prior written permission. 17 | 18 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | SOFTWARE. 25 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build all clean clean-test generate test freeze docker-run docker-build 2 | 3 | .SUFFIXES: .dhall .json 4 | 5 | TEST_DHALL := tests.dhall 6 | TEST := $(TEST_DHALL:.dhall=.json) 7 | 8 | REPLICA_TESTS_DHALL := $(wildcard ./tests/replica/*/*.dhall) 9 | REPLICA_TESTS := $(REPLICA_TESTS_DHALL:.dhall=.json) 10 | REPLICA_EXE := build/exec/replica 11 | 12 | META_DHALL := $(wildcard ./tests/META/*.dhall) 13 | TEST_INCLUDE_DHALL := $(wildcard ./tests/*.dhall) 14 | 15 | DEST = ${HOME}/.local/bin 16 | 17 | build: src/Replica/Version.idr 18 | idris2 --build replica.ipkg 19 | 20 | src/Replica/Version.idr: version.nix 21 | echo "module Replica.Version" > src/Replica/Version.idr 22 | echo "" >> src/Replica/Version.idr 23 | echo "export" >> src/Replica/Version.idr 24 | echo "version : String" >> src/Replica/Version.idr 25 | echo "version = `cat version.nix`" >> src/Replica/Version.idr 26 | 27 | install: build 28 | mkdir -p ${DEST} 29 | cp -r build/exec/* ${DEST} 30 | 31 | clean-test: 32 | ${RM} ${TEST} 33 | ${RM} ${REPLICA_TESTS} 34 | 35 | clean: clean-test 36 | ${RM} -r build 37 | 38 | .dhall.json: 39 | dhall-to-json --file $? --output $@ 40 | 41 | ${TEST}: ${TEST_DHALL} ${TEST_INCLUDE_DHALL} 42 | dhall-to-json --file ${TEST_DHALL} --output $@ 43 | 44 | freeze: ${TEST_DHALL} ${META_DHALL} ${TEST_INCLUDE_DHALL} 45 | dhall freeze $? 46 | 47 | generate: ${REPLICA_TESTS} ${TEST} build 48 | ${REPLICA_EXE} ${GLOBAL} run ${RUN} --interactive ${TEST} 49 | 50 | test: ${REPLICA_TESTS} ${TEST} build 51 | ${REPLICA_EXE} ${GLOBAL} run ${RUN} ${TEST} 52 | 53 | all: test install 54 | 55 | tests/replica/%/: 56 | mkdir $@ 57 | ${REPLICA_EXE} new -f dhall -s $@/tests.dhall 58 | 59 | -------------------------------------------------------------------------------- /RELEASE.md: -------------------------------------------------------------------------------- 1 | # Release checklist 2 | 3 | To set up an new release, you can use 4 | [`scripts/release.sh`](./scripts/release.sh). 5 | The script: 6 | 7 | 1. set up the version field of `replica.ipkg` to the given version number 8 | 2. set the version in `version.nix` to the given version number 9 | 3. commit these two files with a "Set up release message" 10 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | (import 2 | (fetchTarball 3 | "https://github.com/edolstra/flake-compat/archive/master.tar.gz") 4 | { 5 | src = builtins.fetchGit ./.; 6 | }).defaultNix 7 | -------------------------------------------------------------------------------- /documentation/ErrorCodes.md: -------------------------------------------------------------------------------- 1 | # Error codes 2 | 3 | A list of `replica` error codes: 4 | 5 | | Error Code | Meaning | 6 | | 0 | Success 7 | | 1 to 127 | Number of failing tests (wrong expectation or test error) | 8 | | 128 | More than 127 failing tests | 9 | | 252 | Incompatible options (eg. including and excluding the same tag) | 10 | | 253 | Invalid option | 11 | | 254 | Invalid JSON test file | 12 | | 255 | Cant read/write a file | 13 | -------------------------------------------------------------------------------- /documentation/TestExecution.md: -------------------------------------------------------------------------------- 1 | # Test execution workflow 2 | 3 | When you launch a `replica run` command, the following steps happen: 4 | 5 | 1. The tool list tests that can be direcly executed 6 | (those that don't have any test in their `require` fields). 7 | 2. For each of these tests, here are the steps: 8 | 0. The test is declared as `pending`, we skip it and pass to the next one. 9 | 1. Move to the directory defined in `workingDir`, if any. 10 | 2. Run the `beforeTest`, if any and collect the output. 11 | 3. Run the `afterTest`. 12 | 4. Check the exit status of the tested command. If `mustSucceed` is set 13 | and the exit status is not valid, me stop here and the test failed. 14 | Otherwise, we continue. 15 | 5. Retrieve the expected content for the standard output 16 | and if `outputFile` is defined, for the generated file. 17 | 6. Compare the result of the command with the expectations, either: 18 | * We got the expected result and the test succeeded. 19 | * There's a mismatch and we continue. 20 | 7. If `replica` is run in interactive mode, 21 | the difference between the expected values 22 | and the given values are displayed, 23 | and the user can set/replace the values for the test. 24 | 3. The tests that didn't explicitly failed are removed of the `require` field 25 | of the remaining tests. 26 | 4. If at least one tests succeeded and there is at least one test left, 27 | we loop. 28 | Otherwise, we show the results. 29 | -------------------------------------------------------------------------------- /documentation/TestSpecification.md: -------------------------------------------------------------------------------- 1 | # Test Specification 2 | 3 | REPLica tests suites are specified in a JSON file. 4 | Although, it is probably more convenient to use 5 | [Dhall][] and [`dhall-to-json`][] to benefit 6 | of a typespace and more concise way to write them. 7 | 8 | ## Test suite 9 | 10 | A test suite is a JSON object (or a Dhall record) in which each field must be a test. 11 | 12 | ## Test definition 13 | 14 | ### Available fields 15 | 16 | A test is a JSON object or a Dhall record. 17 | Here is the list of available fields: 18 | 19 | 20 | | Field name | JSON Type | Dhall Type | Mandatory | Default | Description | 21 | | :--------- | --------- | ---------- | :-------: | ------- | ----------- | 22 | | `description` | String | Optional Text | | Use when you display text info | 23 | | `command` | String | Text | Yes | | The tested command. | 24 | | `workingDir` | String | Optional Text | No | `.` | The directory where the test is executed | 25 | | `beforeTest` | Array String | List Text | No | `[]` | A list of command to execute before the test.
It is ran in a separated shell and thus you can't declare environment variables needed for the test here. | 26 | | `afterTest` | Array String | List Text | No | `[]` | A list of command to execute after the test.
It is ran in a separated shell and thus you can't access the environment variables declared in the test here. | 27 | | `input` | String | Optional Text | No | | Text that is sent to the test command as standard input | 28 | | `require` | Array String | List Text | No | `[]` | A list of tests that must succeed before this one can be triggered 29 | | `tags` | Array String | List Text | No | `[]` | Used to classify tests | 30 | | `pending` | Boolean | Bool | No | `False` | Pending tests won't be executed | 31 | | `succeed` | Boolean | Optional Bool | No | | If set, REPLica will check the value returned by the command | 32 | | `spaceSensitive` | Boolean | Bool | No | `True` | If set, the spaces are normalized before comparing the given and expected output: each chunk of space-like character are replaced by a single space and empty-lines are not considered | 33 | | `stdOut` | Anything but an integer | Optional Expectation | No | True | set the expectation for `stdOut`, see [Expectation](#expectation) | 34 | | `stdErr` | Anything but an integer | Optional Expectation | No | False | set the expectation for `stdErr`, see [Expectation](#expectation) | 35 | | `files` | Object | Map Text Expectation | No | | List the files to check, and set the 36 | corresponding expectation, see [Expectation](#expectation) | 37 | 38 | 39 | The default value are infered in JSON. 40 | In Dhall, you need to use `Replica.Test` a schema that populate 41 | a test record with the default values. 42 | 43 | Aside `Test`, Dhall provides two other schema `Replica.Test.Success` 44 | and `Replicat.Test.Failure`, 45 | which respectively set the `succeed` value to `Some True` and `Some False`. 46 | 47 | ## Expectation 48 | 49 | By default the behaviour of REPLica is to wait for a golden value 50 | for `stdOut` to be saved 51 | (generaly thanks to `replica run --interactive`) 52 | and then to compare the output of the next runs with this _golden value_. 53 | 54 | However, users may wants to inline their own expectations directly in the test. 55 | This can be done by setting the `stdOut`, `stdErr` and `file` fields. 56 | 57 | The semantic of an `expectation` depends on the type of its value. 58 | 59 | ### JSON 60 | 61 | There is three types of values that are supported for expactations: 62 | 63 | - **Booleans.** If true, use a golden value. 64 | If false, explicitly skip this source. 65 | - **null.** don't check this source (equivalent to `false`) 66 | - **Strings.** The given string define the exact value that 67 | must be match by the output of the command 68 | (after a potential normalisation of the space 69 | if `spaceSensitive` is set to `False`). 70 | - **An array of strings.** It defines a partial expectation: 71 | the result of the command must contain each member of the array. 72 | If `spaceSensitive` is set to false, both the output and the 73 | expectations are normalized before comparison. 74 | - **An object**: allow the defitinion of several requirements that must all be satisfied. 75 | The recognised fields are: 76 | 77 | - `generated`: A boolean that indicates whether or not we use a golden value 78 | - `exact`: Check for that exact string 79 | - `start`: Check if the source starts with this string 80 | - `end`: Check if the source ends with this string 81 | - `contains`: Check if the source contains all the strings of the provided 82 | list of strings 83 | - `consecutive`: Check if the source contains all the strings 84 | of the provided list of strings, in the given order. 85 | 86 | ### Dhall 87 | 88 | The corresponding specification in dhall is the following: 89 | 90 | ```dhall 91 | let Replica.Expectation 92 | : Type 93 | = { generated : Bool 94 | , exact : Optional Text 95 | , start : Optional Text 96 | , end: Optional Text 97 | , consecutive : List Text 98 | , contains : List Text 99 | } 100 | ``` 101 | 102 | Reader may refer to the [JSON section](#json) for the semantic of the fields. 103 | 104 | A few helper are available, to ease the definition of usual expectations: 105 | to ease their use: 106 | 107 | - `Golden : Expectation` allows you to use a golden value for the given entry. 108 | - `Ignored : Expectation` ignore this output. 109 | - `Exact : Text -> Expectation` allows you to check that the entry is exactly 110 | the given string. 111 | - `Contains : List Text -> Expectation` check that each value is in the output. 112 | - `Consecutive : List Text -> Expectation` check that each value is present 113 | in the output, in this 114 | order (possibly separated by other parts of text) 115 | of consecutive values to check. 116 | 117 | ## How test are executed 118 | 119 | See the [Test execution][] section to learn more about how REPLica handles a specification. 120 | 121 | [Dhall]: https://dhall-lang.org/ 122 | [`dhall-to-json`]: https://github.com/dhall-lang/dhall-haskell/blob/master/dhall-json/README.md 123 | [Test execution]: ./TestExecution.md 124 | -------------------------------------------------------------------------------- /examples/hello.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | 5 | in { hello = Replica.Test::{ command = "echo \"Hello, world!\"" } } 6 | -------------------------------------------------------------------------------- /examples/hello.json: -------------------------------------------------------------------------------- 1 | { "hello": {"command": "echo \"hello,word!\""} } 2 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-compat": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1668681692, 7 | "narHash": "sha256-Ht91NGdewz8IQLtWZ9LCeNXMSXHUss+9COoqu6JLmXU=", 8 | "owner": "edolstra", 9 | "repo": "flake-compat", 10 | "rev": "009399224d5e398d03b22badca40a37ac85412a1", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "edolstra", 15 | "repo": "flake-compat", 16 | "type": "github" 17 | } 18 | }, 19 | "flake-utils": { 20 | "locked": { 21 | "lastModified": 1667395993, 22 | "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=", 23 | "owner": "numtide", 24 | "repo": "flake-utils", 25 | "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f", 26 | "type": "github" 27 | }, 28 | "original": { 29 | "owner": "numtide", 30 | "repo": "flake-utils", 31 | "type": "github" 32 | } 33 | }, 34 | "flake-utils_2": { 35 | "locked": { 36 | "lastModified": 1667395993, 37 | "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=", 38 | "owner": "numtide", 39 | "repo": "flake-utils", 40 | "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f", 41 | "type": "github" 42 | }, 43 | "original": { 44 | "owner": "numtide", 45 | "repo": "flake-utils", 46 | "type": "github" 47 | } 48 | }, 49 | "flake-utils_3": { 50 | "locked": { 51 | "lastModified": 1667395993, 52 | "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=", 53 | "owner": "numtide", 54 | "repo": "flake-utils", 55 | "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f", 56 | "type": "github" 57 | }, 58 | "original": { 59 | "owner": "numtide", 60 | "repo": "flake-utils", 61 | "type": "github" 62 | } 63 | }, 64 | "gitignore": { 65 | "inputs": { 66 | "nixpkgs": [ 67 | "pre-commit-hooks", 68 | "nixpkgs" 69 | ] 70 | }, 71 | "locked": { 72 | "lastModified": 1660459072, 73 | "narHash": "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=", 74 | "owner": "hercules-ci", 75 | "repo": "gitignore.nix", 76 | "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73", 77 | "type": "github" 78 | }, 79 | "original": { 80 | "owner": "hercules-ci", 81 | "repo": "gitignore.nix", 82 | "type": "github" 83 | } 84 | }, 85 | "idris": { 86 | "inputs": { 87 | "flake-utils": [ 88 | "flake-utils" 89 | ], 90 | "idris-emacs-src": "idris-emacs-src", 91 | "nixpkgs": [ 92 | "nixpkgs" 93 | ] 94 | }, 95 | "locked": { 96 | "lastModified": 1673134368, 97 | "narHash": "sha256-77fOU/rNUOMcIKAgLC8G5CruZKwomr8wYJT4ed5ET54=", 98 | "owner": "idris-lang", 99 | "repo": "Idris2", 100 | "rev": "f630675cfb8b553ad3304163af544c2c4719fade", 101 | "type": "github" 102 | }, 103 | "original": { 104 | "owner": "idris-lang", 105 | "repo": "Idris2", 106 | "type": "github" 107 | } 108 | }, 109 | "idris-emacs-src": { 110 | "flake": false, 111 | "locked": { 112 | "lastModified": 1666078909, 113 | "narHash": "sha256-oYNHFIpcrFfPb4sXJwEBFKeH+PB4AGCrAFrfBrSTCeo=", 114 | "owner": "redfish64", 115 | "repo": "idris2-mode", 116 | "rev": "3bcb52a65c488f31c99d20f235f6050418a84c9d", 117 | "type": "github" 118 | }, 119 | "original": { 120 | "owner": "redfish64", 121 | "repo": "idris2-mode", 122 | "type": "github" 123 | } 124 | }, 125 | "nixpkgs": { 126 | "locked": { 127 | "lastModified": 1673027386, 128 | "narHash": "sha256-Wjt+oDhRLcf3opIjUKHGN+Xrp3w2ZDms6bO4pCLvsco=", 129 | "owner": "NixOS", 130 | "repo": "nixpkgs", 131 | "rev": "b3818a46e686f24561a28eaa9fcf35e18b8d8e89", 132 | "type": "github" 133 | }, 134 | "original": { 135 | "id": "nixpkgs", 136 | "type": "indirect" 137 | } 138 | }, 139 | "nixpkgs-stable": { 140 | "locked": { 141 | "lastModified": 1671271954, 142 | "narHash": "sha256-cSvu+bnvN08sOlTBWbBrKaBHQZq8mvk8bgpt0ZJ2Snc=", 143 | "owner": "NixOS", 144 | "repo": "nixpkgs", 145 | "rev": "d513b448cc2a6da2c8803e3c197c9fc7e67b19e3", 146 | "type": "github" 147 | }, 148 | "original": { 149 | "owner": "NixOS", 150 | "ref": "nixos-22.05", 151 | "repo": "nixpkgs", 152 | "type": "github" 153 | } 154 | }, 155 | "nixpkgs_2": { 156 | "locked": { 157 | "lastModified": 1671271357, 158 | "narHash": "sha256-xRJdLbWK4v2SewmSStYrcLa0YGJpleufl44A19XSW8k=", 159 | "owner": "NixOS", 160 | "repo": "nixpkgs", 161 | "rev": "40f79f003b6377bd2f4ed4027dde1f8f922995dd", 162 | "type": "github" 163 | }, 164 | "original": { 165 | "owner": "NixOS", 166 | "ref": "nixos-unstable", 167 | "repo": "nixpkgs", 168 | "type": "github" 169 | } 170 | }, 171 | "nixpkgs_3": { 172 | "locked": { 173 | "lastModified": 1672428209, 174 | "narHash": "sha256-eejhqkDz2cb2vc5VeaWphJz8UXNuoNoM8/Op8eWv2tQ=", 175 | "owner": "NixOS", 176 | "repo": "nixpkgs", 177 | "rev": "293a28df6d7ff3dec1e61e37cc4ee6e6c0fb0847", 178 | "type": "github" 179 | }, 180 | "original": { 181 | "id": "nixpkgs", 182 | "type": "indirect" 183 | } 184 | }, 185 | "papers": { 186 | "flake": false, 187 | "locked": { 188 | "dir": "libs/papers", 189 | "lastModified": 1673134368, 190 | "narHash": "sha256-77fOU/rNUOMcIKAgLC8G5CruZKwomr8wYJT4ed5ET54=", 191 | "owner": "idris-lang", 192 | "repo": "Idris2", 193 | "rev": "f630675cfb8b553ad3304163af544c2c4719fade", 194 | "type": "github" 195 | }, 196 | "original": { 197 | "dir": "libs/papers", 198 | "owner": "idris-lang", 199 | "repo": "Idris2", 200 | "type": "github" 201 | } 202 | }, 203 | "pre-commit-hooks": { 204 | "inputs": { 205 | "flake-compat": "flake-compat", 206 | "flake-utils": "flake-utils_2", 207 | "gitignore": "gitignore", 208 | "nixpkgs": "nixpkgs_2", 209 | "nixpkgs-stable": "nixpkgs-stable" 210 | }, 211 | "locked": { 212 | "lastModified": 1672912243, 213 | "narHash": "sha256-QnQeKUjco2kO9J4rBqIBPp5XcOMblIMnmyhpjeaJBYc=", 214 | "owner": "cachix", 215 | "repo": "pre-commit-hooks.nix", 216 | "rev": "a4548c09eac4afb592ab2614f4a150120b29584c", 217 | "type": "github" 218 | }, 219 | "original": { 220 | "owner": "cachix", 221 | "repo": "pre-commit-hooks.nix", 222 | "type": "github" 223 | } 224 | }, 225 | "replicadhall": { 226 | "inputs": { 227 | "flake-utils": "flake-utils_3", 228 | "nixpkgs": "nixpkgs_3" 229 | }, 230 | "locked": { 231 | "lastModified": 1672865541, 232 | "narHash": "sha256-yIcvyBCjiGc5qFdLPn7MuQ/7iN6ibHzQ98ciA0ffHBs=", 233 | "owner": "ReplicaTest", 234 | "repo": "replica-dhall", 235 | "rev": "c2bf442fbbb092973c76d78e642fff3fe0abf0c3", 236 | "type": "github" 237 | }, 238 | "original": { 239 | "owner": "ReplicaTest", 240 | "repo": "replica-dhall", 241 | "type": "github" 242 | } 243 | }, 244 | "root": { 245 | "inputs": { 246 | "flake-utils": "flake-utils", 247 | "idris": "idris", 248 | "nixpkgs": "nixpkgs", 249 | "papers": "papers", 250 | "pre-commit-hooks": "pre-commit-hooks", 251 | "replicadhall": "replicadhall" 252 | } 253 | } 254 | }, 255 | "root": "root", 256 | "version": 7 257 | } 258 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Golden tests for command-line interfaces."; 3 | 4 | inputs = { 5 | flake-utils.url = github:numtide/flake-utils; 6 | idris = { 7 | url = "github:idris-lang/Idris2"; 8 | inputs.nixpkgs.follows = "nixpkgs"; 9 | inputs.flake-utils.follows = "flake-utils"; 10 | }; 11 | papers = { 12 | url = "github:idris-lang/Idris2?dir=libs/papers"; 13 | flake = false; 14 | }; 15 | pre-commit-hooks.url = "github:cachix/pre-commit-hooks.nix"; 16 | replicadhall.url = "github:ReplicaTest/replica-dhall"; 17 | }; 18 | outputs = { self, nixpkgs, idris, papers, flake-utils, pre-commit-hooks, replicadhall }: 19 | flake-utils.lib.eachDefaultSystem (system: 20 | let 21 | pkgs = import nixpkgs { inherit system; }; 22 | inherit (pkgs) 23 | dhall 24 | lib; 25 | inherit (pkgs.haskellPackages) 26 | dhall-json; 27 | 28 | version = import ./version.nix; 29 | idrisPkgs = idris.packages.${system}; 30 | 31 | callPackage = lib.callPackageWith (pkgs // packages); 32 | 33 | packages = { 34 | inherit version; 35 | buildIdris = idris.buildIdris.${system}; 36 | papersLib = callPackage ./nix/papersLib.nix { inherit papers; }; 37 | replica_dhall = replicadhall.packages.${system}.default; 38 | buildReplica = callPackage ./nix/buildReplica.nix { }; 39 | replica = callPackage ./nix/replica.nix { }; 40 | replicaTest = callPackage ./nix/replica.nix { }; 41 | }; 42 | 43 | inherit (packages) 44 | replica 45 | replicaTest 46 | replica_dhall 47 | papersLib; 48 | 49 | dockerImage = pkgs.dockerTools.buildImage { 50 | name = "replica"; 51 | config = { 52 | Cmd = [ "${replica}/bin/replica" ]; 53 | }; 54 | tag = "v${version}"; 55 | }; 56 | 57 | in 58 | { 59 | packages = { 60 | default = replica; 61 | replica = replica; 62 | docker = dockerImage; 63 | }; 64 | 65 | checks = { 66 | tests = replicaTest; 67 | pre-commit-check = pre-commit-hooks.lib.${system}.run { 68 | src = ./.; 69 | hooks = { 70 | nixpkgs-fmt.enable = true; 71 | dhall-format.enable = true; 72 | markdownlint.enable = true; 73 | online-tests = import ./nix/online-tests.nix; 74 | }; 75 | }; 76 | }; 77 | 78 | devShells.default = pkgs.mkShell { 79 | packages = [ idrisPkgs.idris2 papersLib pkgs.rlwrap dhall dhall-json ]; 80 | shellHook = '' 81 | alias idris2="rlwrap -s 1000 idris2 --no-banner" 82 | ${self.checks.${system}.pre-commit-check.shellHook} 83 | ''; 84 | }; 85 | 86 | } 87 | ); 88 | } 89 | -------------------------------------------------------------------------------- /nix/buildReplica.nix: -------------------------------------------------------------------------------- 1 | { buildIdris, papersLib }: 2 | buildIdris { 3 | projectName = "replica"; 4 | src = ../.; 5 | idrisLibraries = [ papersLib ]; 6 | } 7 | -------------------------------------------------------------------------------- /nix/online-tests.nix: -------------------------------------------------------------------------------- 1 | { 2 | name = "REPLica online tests"; 3 | description = 4 | '' 5 | We don't run online tests in the CI, so we check 6 | it in pre-commit 7 | ''; 8 | enable = true; 9 | entry = 10 | '' 11 | make test RUN="-t online" 12 | ''; 13 | pass_filenames = false; 14 | stages = [ "push" ]; 15 | } 16 | -------------------------------------------------------------------------------- /nix/papersLib.nix: -------------------------------------------------------------------------------- 1 | { system, buildIdris, papers }: 2 | let 3 | version = import ../version.nix; 4 | papersPkg = buildIdris { 5 | projectName = "papers"; 6 | src = papers; 7 | idrisLibraries = [ ]; 8 | preBuild = "cd libs/papers"; 9 | }; 10 | in 11 | papersPkg.installLibrary 12 | -------------------------------------------------------------------------------- /nix/replica.nix: -------------------------------------------------------------------------------- 1 | { buildReplica, version }: 2 | buildReplica.build.overrideAttrs (attrs: { 3 | pname = "replica"; 4 | version = version; 5 | buildPhase = '' 6 | make 7 | ''; 8 | }) 9 | -------------------------------------------------------------------------------- /nix/replicaTest.nix: -------------------------------------------------------------------------------- 1 | { zsh, dhall, haskellPackages, buildReplica, replica_dhall }: 2 | let 3 | inherit (haskellPackages) 4 | dhall-json; 5 | in 6 | buildReplica.build.overrideAttrs (attrs: { 7 | buildInputs = [ replica_dhall dhall dhall-json zsh ]; 8 | buildPhase = '' 9 | cp -r ${replica_dhall}/.cache .cache 10 | chmod -R u+w .cache 11 | export XDG_CACHE_HOME=.cache 12 | make test RUN="-T online" 13 | ''; 14 | }); 15 | -------------------------------------------------------------------------------- /replica.ipkg: -------------------------------------------------------------------------------- 1 | package replica 2 | 3 | version = 0.6.0 4 | 5 | sourcedir = "src" 6 | 7 | depends = papers, contrib 8 | langversion >= 0.6.0 9 | 10 | modules = Replica 11 | 12 | , Replica.App 13 | , Replica.App.Display 14 | , Replica.App.Info 15 | , Replica.App.Info.Suite 16 | , Replica.App.Info.Test 17 | , Replica.App.FileSystem 18 | , Replica.App.Format 19 | , Replica.App.Log 20 | , Replica.App.Replica 21 | , Replica.App.Run 22 | , Replica.App.Run.Display 23 | , Replica.App.Run.Dependencies 24 | , Replica.App.Run.RunOne 25 | , Replica.App.Run.Types 26 | , Replica.App.System 27 | 28 | , Replica.Command 29 | , Replica.Command.Help 30 | , Replica.Command.Info 31 | , Replica.Command.Info.Suite 32 | , Replica.Command.Info.Test 33 | , Replica.Command.Run 34 | , Replica.Command.Version 35 | 36 | , Replica.Core 37 | , Replica.Core.Parse 38 | , Replica.Core.Test 39 | , Replica.Core.Types 40 | 41 | , Replica.Help 42 | 43 | , Replica.Option.Global 44 | , Replica.Option.Filter 45 | , Replica.Option.Types 46 | 47 | , Replica.Other.Decorated 48 | , Replica.Other.Free 49 | , Replica.Other.String 50 | , Replica.Other.Validation 51 | 52 | , Replica.Version 53 | 54 | main = Replica 55 | 56 | executable = replica 57 | -------------------------------------------------------------------------------- /scripts/release.sh: -------------------------------------------------------------------------------- 1 | sed "s/version = .*/version = $1/" -i replica.ipkg 2 | echo "\"$1\"" > ./version.nix 3 | git commit replica.ipkg ./version.nix -m "Set up release v$1" 4 | -------------------------------------------------------------------------------- /src/Replica.idr: -------------------------------------------------------------------------------- 1 | ||| Entry point of the Replica application. 2 | ||| It's where we call the parser, 3 | ||| call the corresponding command 4 | ||| and handle the result. 5 | module Replica 6 | 7 | import Data.So 8 | import Data.String 9 | import Data.List.AtIndex 10 | import Data.List 11 | import Data.List1 12 | import Data.OpenUnion 13 | 14 | 15 | import System 16 | import System.File 17 | 18 | import Replica.App 19 | import Replica.Core 20 | import Replica.Command 21 | import Replica.Option.Parse 22 | import Replica.Option.Types 23 | import Replica.Other.Decorated 24 | import Replica.Other.Validation 25 | 26 | %default total 27 | 28 | data ReplicaExit : Type where 29 | HasReplicaError : ReplicaError -> ReplicaExit 30 | HasTestErrors : (n : Int) -> (notZ : So (not $ n == 0)) -> ReplicaExit 31 | HasArgParsingError : (res : ParseResult a) -> (0 isErr : ParsingFailure res) => ReplicaExit 32 | HasEnvInitialisationError : ReplicaExit 33 | Success : ReplicaExit 34 | 35 | exitCode : ReplicaExit -> ExitCode 36 | exitCode (HasReplicaError (CantAccessTestFile str)) = ExitFailure 255 37 | exitCode (HasReplicaError (InvalidJSON strs)) = ExitFailure 254 38 | exitCode (HasTestErrors n notZ) = if n > 127 39 | then ExitFailure 128 40 | else ExitFailure n 41 | exitCode (HasArgParsingError (InvalidOption _ _)) = ExitFailure 253 42 | exitCode (HasArgParsingError (InvalidMix _)) = ExitFailure 252 43 | exitCode HasEnvInitialisationError = ExitFailure 255 44 | exitCode Success = ExitSuccess 45 | 46 | runHelp : File -> Help -> IO () 47 | 48 | toStdErr : String -> IO () 49 | toStdErr = ignore . fPutStrLn stderr 50 | 51 | displayExit : ReplicaExit -> IO () 52 | displayExit (HasReplicaError x) = ignore $ fPutStrLn stderr $ show x 53 | displayExit (HasTestErrors n notZ) = pure () 54 | displayExit (HasArgParsingError (InvalidOption h xs)) = do 55 | ignore $ fPutStrLn stderr "Invalid command or option: \{joinBy ", " $ forget xs}" 56 | maybe (pure ()) (runHelp stderr) h 57 | displayExit (HasArgParsingError (InvalidMix str)) = do 58 | ignore $ fPutStrLn stderr str 59 | displayExit HasEnvInitialisationError = 60 | ignore $ fPutStrLn stderr "Can't init env" 61 | displayExit Success = pure () 62 | 63 | exitReplica : ReplicaExit -> IO () 64 | exitReplica x = displayExit x >> exitWith (exitCode x) 65 | 66 | covering 67 | runRun : RunCommand -> IO ReplicaExit 68 | runRun ctx = run $ new ctx.global $ new ctx $ handle runReplica 69 | (\stats => do 70 | let nbErrs = cast $ stats.failures + stats.errors 71 | pure $ case choose (nbErrs == 0) of 72 | Left _ => Success 73 | Right notZ => HasTestErrors nbErrs notZ 74 | ) 75 | (pure . HasReplicaError) 76 | 77 | covering 78 | runInfo : InfoCommand -> IO ReplicaExit 79 | runInfo info = run $ new info $ handle infoReplica 80 | (const $ pure Success) 81 | (pure . HasReplicaError) 82 | 83 | runHelp h = ignore . fPutStrLn h . display 84 | 85 | covering 86 | runSet : SetCommand -> IO ReplicaExit 87 | runSet x = do 88 | home <- getEnv "HOME" 89 | let Just gb = noGlobal 90 | | Nothing => putStrLn "Can't init env" >> pure HasEnvInitialisationError 91 | run $ new x $ new gb $ new home $ handle setReplica 92 | (const $ pure Success) 93 | (pure . HasReplicaError) 94 | where 95 | noGlobal : Maybe Global 96 | noGlobal = build $ initBuilder ({files := Just []} defaultGlobal) 97 | 98 | covering 99 | runNew : NewCommand -> IO ReplicaExit 100 | runNew ctx = run $ new ctx $ handle newReplica 101 | (const $ pure Success) 102 | (pure . HasReplicaError) 103 | 104 | covering 105 | runCommand : Commands -> IO ReplicaExit 106 | runCommand a0 = let 107 | Left a1 = decomp a0 108 | | Right cmd => runRun cmd 109 | Left a2 = decomp a1 110 | | Right cmd => runInfo cmd 111 | Left a3 = decomp a2 112 | | Right cmd => runSet cmd 113 | Left a4 = decomp a3 114 | | Right cmd => runNew cmd 115 | Left a5 = decomp a4 116 | | Right h => runHelp stdout h $> Success 117 | MkVersion v = (decomp0 a5) 118 | in putStrLn v $> Success 119 | 120 | covering 121 | main : IO () 122 | main = do 123 | (cmd::args) <- getArgs 124 | | _ => putStrLn "Error" 125 | let Just args' = toList1' args 126 | | Nothing => runHelp stdout help 127 | gc <- givenConfig 128 | let x = parseArgs gc args' 129 | case x of 130 | InvalidMix _ => do 131 | exitReplica $ HasArgParsingError x 132 | InvalidOption _ _ => do 133 | exitReplica $ HasArgParsingError x 134 | Done cmd => do 135 | result <- runCommand cmd 136 | exitReplica result 137 | -------------------------------------------------------------------------------- /src/Replica/App.idr: -------------------------------------------------------------------------------- 1 | ||| Re-export the `App` submodules that provide the logic for the different 2 | ||| command 3 | module Replica.App 4 | 5 | import public Control.App 6 | import public Control.App.Console 7 | 8 | import public Replica.App.Clock 9 | import public Replica.App.FileSystem 10 | import public Replica.App.Info 11 | import public Replica.App.Log 12 | import public Replica.App.New 13 | import public Replica.App.Replica 14 | import public Replica.App.Run 15 | import public Replica.App.Set 16 | import public Replica.App.System 17 | -------------------------------------------------------------------------------- /src/Replica/App/Clock.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Clock 2 | 3 | import Control.App 4 | import public System.Clock 5 | 6 | %default total 7 | 8 | public export 9 | interface SystemClock e where 10 | threadClock : App e (Clock Thread) 11 | 12 | export 13 | PrimIO e => SystemClock e where 14 | threadClock = primIO $ clockTime Thread 15 | 16 | export 17 | showDuration : Clock Duration -> String 18 | showDuration (MkClock seconds nanoseconds) = let 19 | ns = div nanoseconds 10000 20 | in "\{show seconds}.\{show ns}s" 21 | 22 | export 23 | durationOf : SystemClock e => App e a -> App e (Clock Duration, a) 24 | durationOf x = do 25 | start <- threadClock 26 | res <- x 27 | end <- threadClock 28 | pure (timeDifference end start, res) 29 | -------------------------------------------------------------------------------- /src/Replica/App/Display.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Display 2 | 3 | import Control.App 4 | import Control.App.Console 5 | 6 | import Replica.App.Format 7 | import Replica.App.Replica 8 | import Replica.Option.Global 9 | 10 | export 11 | formattedSuiteName : 12 | Has [ State GlobalConfig Global 13 | ] e => Maybe String -> App e String 14 | formattedSuiteName suite = 15 | bold <*> pure (maybe "No suite given:" ("Suite: " <+>) suite) 16 | 17 | 18 | -- display the name of a suite 19 | export 20 | displaySuite : 21 | Has [ State GlobalConfig Global 22 | , Console 23 | ] e => Maybe String -> App e () 24 | displaySuite suite = putStrLn !(formattedSuiteName suite) 25 | -------------------------------------------------------------------------------- /src/Replica/App/FileSystem.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.FileSystem 2 | 3 | 4 | import Control.App 5 | import System.Directory 6 | import System.Path 7 | 8 | %default covering 9 | 10 | public export 11 | data FSError 12 | = MissingFile String 13 | | CantAccess String 14 | | CantWriteFile String 15 | | CantReadFile String 16 | | CantCreate String 17 | | UnmanagedError String 18 | | FileExists String 19 | 20 | export total 21 | toFSError : FileError -> String -> FSError 22 | toFSError (GenericFileError i) = UnmanagedError 23 | toFSError FileReadError = CantReadFile 24 | toFSError FileWriteError = CantWriteFile 25 | toFSError FileNotFound = MissingFile 26 | toFSError PermissionDenied = CantAccess 27 | toFSError FileExists = FileExists 28 | 29 | public export 30 | interface Exception FSError e => FileSystem e where 31 | createDir : (dirname : String) -> App e () 32 | getCurrentDir : App e String 33 | changeDir : (dirname : String) -> App e () 34 | removeDir : (dirname : String) -> App e () 35 | writeFile : (filename : String) -> (content : String) -> App e () 36 | readFile : (filename : String) -> App e String 37 | 38 | export 39 | Has [PrimIO, Exception FSError] e => FileSystem e where 40 | createDir d = do 41 | Right x <- primIO $ createDir d 42 | | Left err => throw (toFSError err d) 43 | pure x 44 | getCurrentDir = do 45 | Just dir <- primIO currentDir 46 | | Nothing => throw (UnmanagedError "current dir") 47 | pure dir 48 | changeDir d = do 49 | res <- primIO $ changeDir d 50 | if res 51 | then pure () 52 | else throw (CantAccess d) 53 | removeDir d = primIO $ removeDir d 54 | writeFile f content = do 55 | case splitParent f of 56 | Just ("", filename) => pure () 57 | Just (dir, filename) => buildDirectory dir 58 | Nothing => pure () 59 | Right x <- primIO $ writeFile f content 60 | | Left err => throw (toFSError err f) 61 | pure x 62 | where 63 | buildDirectory : String -> App e () 64 | buildDirectory dir = do 65 | Left _ <- primIO $ openDir dir 66 | | _ => pure () 67 | let Just (parent, _) = splitParent dir 68 | | Nothing => throw (CantAccess dir) 69 | buildDirectory parent 70 | createDir dir 71 | readFile f = do 72 | Right x <- primIO $ readFile f 73 | | Left err => throw (toFSError err f) 74 | pure x 75 | -------------------------------------------------------------------------------- /src/Replica/App/Filter.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Filter 2 | 3 | import Control.App 4 | import Control.App.Console 5 | 6 | import Data.List 7 | 8 | import Language.JSON 9 | 10 | import Replica.App.FileSystem 11 | import Replica.App.Log 12 | import Replica.App.Replica 13 | 14 | import Replica.Core.Parse 15 | import Replica.Core.Types 16 | import Replica.Option.Filter 17 | import Replica.Option.Global 18 | import Replica.Other.Decorated 19 | import Replica.Other.Validation 20 | 21 | %default total 22 | 23 | filterTests : FileSystem (FSError :: e) => 24 | Has [ State ActiveFilter Filter 25 | , State GlobalConfig Global 26 | , Exception ReplicaError 27 | , Console 28 | ] e => (s, r : List Test) -> App e (List Test, List Test) 29 | filterTests s r = do 30 | activeFilters <- get ActiveFilter 31 | debug $ "Filters: \{show activeFilters}" 32 | let (selected, rejected) = partition (keepTest activeFilters) s 33 | pure (selected, rejected ++ r) 34 | 35 | getLastFailures : FileSystem (FSError :: e) => 36 | Has [ State GlobalConfig Global 37 | , Exception ReplicaError 38 | , Console 39 | ] e => App e (List Test, List Test) 40 | getLastFailures = do 41 | repl <- getReplica 42 | logFile <- lastRunLog <$> getReplicaDir 43 | lastLog <- catchNew (readFile logFile) 44 | (\err : FSError => throw $ CantAccessTestFile logFile) 45 | let Just json = parse lastLog 46 | | Nothing => throw $ InvalidJSON ["Can't parse JSON (invalid syntax)"] 47 | let Valid report = parseReport json 48 | | Error err => throw $ InvalidJSON err 49 | let notWorking = fst <$> filter (not . isFullSuccess . snd) report 50 | let (selected, rejected) = partition (flip elem notWorking . name) repl.tests 51 | debug $ "Previous invalid tests: \{show selected}" 52 | pure (selected, rejected) 53 | 54 | export 55 | defineActiveTests : FileSystem (FSError :: e) => 56 | Has [ State ActiveFilter Filter 57 | , State GlobalConfig Global 58 | , Exception ReplicaError 59 | , Console 60 | ] e => App e (List Test, List Test) 61 | defineActiveTests = do 62 | tests <- if (!(get ActiveFilter)).lastFailures 63 | then getLastFailures 64 | else do 65 | repl <- getReplica 66 | pure (repl.tests, []) 67 | uncurry filterTests tests 68 | -------------------------------------------------------------------------------- /src/Replica/App/Format.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Format 2 | 3 | import public Control.ANSI 4 | import Control.App 5 | 6 | import Replica.Option.Global 7 | import Replica.App.Log 8 | import Replica.App.Replica 9 | import Replica.Other.Decorated 10 | 11 | export 12 | ok : State GlobalConfig Global e => App e String 13 | ok = do 14 | ascii <- map ascii $ get GlobalConfig 15 | pure $ if ascii then "OK " else "✅ " 16 | 17 | export 18 | ko : State GlobalConfig Global e => App e String 19 | ko = do 20 | ascii <- map ascii $ get GlobalConfig 21 | pure $ if ascii then "KO " else "❌ " 22 | 23 | export 24 | err : State GlobalConfig Global e => App e String 25 | err = do 26 | ascii <- map ascii $ get GlobalConfig 27 | pure $ if ascii then "ERR" else "⚠️ " 28 | 29 | export 30 | pending : State GlobalConfig Global e => App e String 31 | pending = do 32 | ascii <- map ascii $ get GlobalConfig 33 | pure $ if ascii then "ZzZ" else "💤" 34 | 35 | export 36 | qmark : State GlobalConfig Global e => App e String 37 | qmark = do 38 | ascii <- map ascii $ get GlobalConfig 39 | pure $ if ascii then "?" else "❓" 40 | 41 | export 42 | bold : State GlobalConfig Global e => App e (String -> String) 43 | bold = do 44 | c <- map colour $ get GlobalConfig 45 | pure $ if c then (show . bolden) else id 46 | 47 | export 48 | yellow : State GlobalConfig Global e => App e (String -> String) 49 | yellow = do 50 | c <- map colour $ get GlobalConfig 51 | pure $ if c then (show . colored Yellow) else id 52 | 53 | export 54 | green : State GlobalConfig Global e => App e (String -> String) 55 | green = do 56 | c <- map colour $ get GlobalConfig 57 | pure $ if c then (show . colored Green) else id 58 | 59 | export 60 | red : State GlobalConfig Global e => App e (String -> String) 61 | red = do 62 | c <- map colour $ get GlobalConfig 63 | pure $ if c then (show . colored Red) else id 64 | 65 | export 66 | blue : State GlobalConfig Global e => App e (String -> String) 67 | blue = do 68 | c <- map colour $ get GlobalConfig 69 | pure $ if c then (show . colored BrightBlue) else id 70 | 71 | -------------------------------------------------------------------------------- /src/Replica/App/Info.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Info 2 | 3 | import Control.App 4 | import Control.App.Console 5 | 6 | import Data.List 7 | import Data.String 8 | import Data.String.Extra 9 | 10 | import Language.JSON 11 | 12 | import Replica.App.FileSystem 13 | import Replica.App.Format 14 | import Replica.App.Log 15 | import Replica.App.Replica 16 | import Replica.Command.Info 17 | import Replica.Command.Info.Suite 18 | import Replica.Command.Info.Test 19 | import Replica.Core 20 | import Replica.Option.Filter 21 | import Replica.Option.Global 22 | import Replica.Other.Decorated 23 | import Replica.Other.String 24 | import Replica.Other.Validation 25 | 26 | import Replica.App.Info.Suite 27 | import Replica.App.Info.Test 28 | import public Replica.App.Info.Types 29 | 30 | export 31 | infoReplica : 32 | FileSystem (FSError :: e) => 33 | Has 34 | [ State InfoContext InfoCommand 35 | , Exception ReplicaError 36 | , Console 37 | ] e => App e () 38 | infoReplica = do 39 | cmd <- get InfoContext 40 | case cmd of 41 | SuiteInfo x => new x.global $ new x $ suiteInfoReplica 42 | TestInfo x => new x.global $ new x $ testInfoReplica 43 | -------------------------------------------------------------------------------- /src/Replica/App/Info/Suite.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Info.Suite 2 | 3 | import Control.App 4 | import Control.App.Console 5 | 6 | import Data.List 7 | import Data.List1 8 | 9 | import Replica.App.Display 10 | import Replica.App.FileSystem 11 | import Replica.App.Filter 12 | import Replica.App.Format 13 | import Replica.App.Log 14 | import Replica.App.Replica 15 | import Replica.Core.Test 16 | import Replica.Core.Types 17 | import Replica.Command.Info.Suite 18 | import Replica.Option.Filter 19 | import Replica.Option.Global 20 | import Replica.Other.Decorated 21 | import Replica.Other.String 22 | 23 | import Replica.Core.Types 24 | import Replica.App.Info.Types 25 | 26 | displaySuite : 27 | Has 28 | [ State GlobalConfig Global 29 | , Console 30 | ] e => 31 | (Maybe String, List1 Test) -> App e () 32 | displaySuite (name, tests) = 33 | putStrLn 34 | "\{!bold (maybe "- No suite" ("- " <+>) name)} (\{show $ length tests} tests)" 35 | 36 | export 37 | suiteInfoReplica : 38 | FileSystem (FSError :: e) => 39 | Has 40 | [ State SuiteInfoContext SuiteInfoCommand 41 | , State GlobalConfig Global 42 | , Exception ReplicaError 43 | , Console 44 | ] e => App e () 45 | suiteInfoReplica = do 46 | ctx <- get SuiteInfoContext 47 | debug "Info: \{show ctx}" 48 | debug $ show !(get GlobalConfig) 49 | putStrLn "" 50 | tests <- fst <$> new ctx.filter defineActiveTests 51 | traverse_ displaySuite $ bySuite tests 52 | -------------------------------------------------------------------------------- /src/Replica/App/Info/Test.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Info.Test 2 | 3 | import Control.App 4 | import Control.App.Console 5 | 6 | import Data.List 7 | import Data.List1 8 | import Data.String 9 | import Data.String.Extra 10 | 11 | import Language.JSON 12 | 13 | import Replica.App.Display 14 | import Replica.App.FileSystem 15 | import Replica.App.Filter 16 | import Replica.App.Format 17 | import Replica.App.Log 18 | import Replica.App.Replica 19 | import Replica.Command.Info.Test 20 | import Replica.Core 21 | import Replica.Core.Test 22 | import Replica.Option.Filter 23 | import Replica.Option.Global 24 | import Replica.Other.Decorated 25 | import Replica.Other.String 26 | import Replica.Other.Validation 27 | 28 | import Replica.App.Info.Types 29 | 30 | displayTestName : Console e => 31 | State GlobalConfig Global e => 32 | String -> App e () 33 | displayTestName x = putStrLn $ "\{!qmark} " ++ (!bold "\{x}:") 34 | 35 | displayExpectation : FileSystem (FSError :: e) => 36 | Has [ State TestInfoContext TestInfoCommand 37 | , State GlobalConfig Global 38 | , State CurrentTest Test 39 | , Console] e => Expectation -> App e () 40 | displayExpectation exp = do 41 | let Generated = exp 42 | | Exact expected => printExpectation expected 43 | | Partial x xs => do 44 | putStrLn $ withOffset 6 $ case x of 45 | Ordered => "Expect these parts (ordered):" 46 | Whatever => "Expect these parts (in any order):" 47 | traverse_ putStrLn (map partialExpectation xs) 48 | | EndsWith x => do 49 | putStrLn $ withOffset 6 $ "Ends with: \{show x}" 50 | | StartsWith x => do 51 | putStrLn $ withOffset 6 $ "Starts with: \{show x}" 52 | handle (readFile !getExpectedOutput) 53 | printExpectation 54 | (\err : FSError => putStrLn "No expectation yet.") 55 | where 56 | printExpectation : String -> App e () 57 | printExpectation o = do 58 | putStrLn $ withOffset 6 $ "Expect exactly as output:" 59 | putStrLn $ removeTrailingNL $ unlines $ map (withOffset 8) $ lines o 60 | partialExpectation : String -> String 61 | partialExpectation x = case lines x of 62 | (head :: tail) => removeTrailingNL $ unlines $ withOffset 6 ("- " ++ head) :: (withOffset 8 <$> tail) 63 | [] => withOffset 6 "- " 64 | 65 | displayExpectations : FileSystem (FSError :: e) => 66 | Has [ State TestInfoContext TestInfoCommand 67 | , State GlobalConfig Global 68 | , State CurrentTest Test 69 | , Console] e => App e () 70 | displayExpectations = do 71 | t <- get CurrentTest 72 | traverse_ (uncurry go) t.expectations 73 | where 74 | showPart : Part -> App e () 75 | showPart StdOut = putStrLn $ withOffset 4 "Expected on standard output" 76 | showPart StdErr = putStrLn $ withOffset 4 "Expected on error output" 77 | showPart (FileName x) = putStrLn $ withOffset 4 "Expected in file \{show x}" 78 | go : Part -> List Expectation -> App e () 79 | go x xs = do 80 | showPart x 81 | traverse_ displayExpectation xs 82 | 83 | 84 | displayTest : 85 | FileSystem (FSError :: e) => 86 | Has [ State TestInfoContext TestInfoCommand 87 | , State GlobalConfig Global 88 | , State CurrentTest Test 89 | , Console] e => 90 | App e () 91 | displayTest = do 92 | t <- get CurrentTest 93 | displayTestName t.name 94 | traverse_ (putStrLn . withOffset 4) t.description 95 | when (not $ null t.tags) 96 | $ putStrLn . withOffset 4 $ "Tags: \{show t.tags}" 97 | when (not $ null t.require) 98 | $ putStrLn . withOffset 4 $ "Require: \{show t.require}" 99 | putStrLn $ withOffset 4 "Command : \{show t.command}" 100 | when !(showExpectation <$> get TestInfoContext) 101 | displayExpectations 102 | putStrLn "" 103 | 104 | displayTestBySuite : 105 | FileSystem (FSError :: e) => 106 | Has [ State TestInfoContext TestInfoCommand 107 | , State GlobalConfig Global 108 | , Console 109 | ] e => 110 | (Maybe String, List1 Test) -> App e () 111 | displayTestBySuite (suite, tests) = do 112 | displaySuite suite 113 | traverse_ (\t => new t displayTest) tests 114 | 115 | 116 | export 117 | testInfoReplica : 118 | FileSystem (FSError :: e) => 119 | Has 120 | [ State TestInfoContext TestInfoCommand 121 | , State GlobalConfig Global 122 | , Exception ReplicaError 123 | , Console 124 | ] e => App e () 125 | testInfoReplica = do 126 | ctx <- get TestInfoContext 127 | debug "Info: \{show ctx}" 128 | debug $ show !(get GlobalConfig) 129 | putStrLn "" 130 | tests <- fst <$> new ctx.filter defineActiveTests 131 | traverse_ displayTestBySuite $ bySuite tests 132 | -------------------------------------------------------------------------------- /src/Replica/App/Info/Types.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Info.Types 2 | 3 | export 4 | data SuiteInfoContext : Type where 5 | 6 | export 7 | data TestInfoContext : Type where 8 | 9 | export 10 | data InfoContext : Type where 11 | 12 | -------------------------------------------------------------------------------- /src/Replica/App/Log.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Log 2 | 3 | import Control.App 4 | import Control.App.Console 5 | 6 | import Replica.App.Replica 7 | import Replica.Option.Global 8 | import Replica.Other.Decorated 9 | 10 | %default total 11 | 12 | export 13 | interface Log e where 14 | logWithLevel : (lvl : LogLevel) -> (content : String) -> App e () 15 | 16 | export 17 | log : Log e => String -> App e () 18 | log = logWithLevel Info 19 | 20 | export 21 | debug : Log e => String -> App e () 22 | debug = logWithLevel Debug 23 | 24 | export 25 | warning : Log e => String -> App e () 26 | warning = logWithLevel Warning 27 | 28 | export 29 | critical : Log e => String -> App e () 30 | critical = logWithLevel Critical 31 | 32 | export 33 | Console e => State GlobalConfig Global e => Log e where 34 | logWithLevel lvl content = do 35 | Just threshold <- map logLevel $ get GlobalConfig 36 | | Nothing => pure () 37 | if lvl >= threshold 38 | then putStrLn content 39 | else pure () 40 | -------------------------------------------------------------------------------- /src/Replica/App/New.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.New 2 | 3 | import Control.App 4 | import Control.App.Console 5 | 6 | import Data.String 7 | 8 | import Language.JSON 9 | 10 | import Replica.App.FileSystem 11 | import Replica.App.Format 12 | import Replica.App.Log 13 | import Replica.App.Replica 14 | import Replica.Command.New 15 | import Replica.Other.Decorated 16 | import Replica.Other.String 17 | 18 | data NewContext : Type where 19 | 20 | replicaURL : String 21 | replicaURL = "https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall" 22 | 23 | jsonTestSample : JSON 24 | jsonTestSample = JObject 25 | [ ("command", JString "echo \"Hello, World!\"") 26 | , ("description", JString "This test is a placeholder, you can edit it.") 27 | , ("spaceSensitive", JBoolean False) 28 | , ("status", JBoolean True) 29 | , ("stdOut", JObject 30 | [ ("generated", JBoolean False) 31 | , ("consecutive", JArray $ JString <$> ["Hello", "World"]) 32 | , ("end", JString "!") 33 | ]) 34 | ] 35 | 36 | dhallTestSample : String 37 | dhallTestSample = 38 | #""" 39 | let hello = 40 | Test.Success::{ 41 | , command = "echo \"Hello, World!\"" 42 | , description = Some "This test is a placeholder, you can edit it." 43 | , spaceSensitive = False 44 | , stdOut = Expectation ::{ 45 | , consecutive = ["Hello", "World"] 46 | , end = Some "!" 47 | } 48 | } 49 | """# 50 | 51 | jsonContent : (withSample : Bool) -> JSON 52 | jsonContent withSample = 53 | JObject $ if withSample then [("hello", jsonTestSample)] else [] 54 | 55 | dhallContent : (withSample : Bool) -> String 56 | dhallContent withSample = removeTrailingNL $ unlines 57 | [ "let Replica =" 58 | , " env:REPLICA_DHALL" 59 | , " ? \{replicaURL}" 60 | , "" 61 | , "let Prelude = Replica.Prelude" 62 | , "" 63 | , "let Test = Replica.Test" 64 | , "" 65 | , "let Status = Replica.Status" 66 | , "" 67 | , "let Expectation = Replica.Expectation" 68 | , if withSample 69 | then "\n" <+> dhallTestSample <+> "\n" 70 | else "" 71 | , "let tests" 72 | , " : Replica.Type" 73 | , " = \{sample}" 74 | , "" 75 | , "in tests" 76 | ] 77 | where 78 | sample : String 79 | sample = if withSample then "toMap { hello }" else "[] : Replica.Type" 80 | 81 | export 82 | newReplica : FileSystem (FSError :: e) => 83 | Has 84 | [ State NewContext NewCommand 85 | , Exception ReplicaError 86 | , Console 87 | ] e => 88 | App e () 89 | newReplica = do 90 | ctx <- get NewContext 91 | let content = case ctx.format of 92 | JSON => format 2 $ jsonContent ctx.includeSample 93 | Dhall => dhallContent ctx.includeSample 94 | catchNew (writeFile ctx.file content) 95 | (\err : FSError => throw (CantAccessTestFile ctx.file)) 96 | putStrLn "Test file created (\{show ctx.format}): \{ctx.file}" 97 | -------------------------------------------------------------------------------- /src/Replica/App/Replica.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Replica 2 | 3 | import Control.App 4 | import Control.App.Console 5 | 6 | import Data.List 7 | import Data.Maybe 8 | import Data.String 9 | 10 | import Language.JSON 11 | 12 | import System.Path 13 | 14 | import Replica.App.FileSystem 15 | import Replica.App.System 16 | import Replica.Command.Run 17 | import Replica.Core.Parse 18 | import Replica.Core.Types 19 | import Replica.Option.Global 20 | import Replica.Other.Decorated 21 | import Replica.Other.String 22 | import Replica.Other.Validation 23 | 24 | 25 | %default total 26 | 27 | export 28 | data CurrentTest : Type where 29 | 30 | export 31 | data ActiveFilter : Type where 32 | 33 | export 34 | data GlobalConfig : Type where 35 | 36 | public export 37 | data ReplicaError 38 | = CantAccessTestFile String 39 | | InvalidJSON (List String) 40 | 41 | export 42 | Show ReplicaError where 43 | show (CantAccessTestFile x) = "Can't access file \{x}" 44 | show (InvalidJSON xs) = removeTrailingNL $ unlines $ "Can't parse JSON:" :: xs 45 | 46 | export 47 | testDir : String -> String 48 | testDir = ( "test") 49 | 50 | export 51 | logDir : String -> String 52 | logDir = ( "log") 53 | 54 | export 55 | lastRunLog : String -> String 56 | lastRunLog rdir = logDir rdir "last.json" 57 | 58 | export 59 | getReplicaDir : State GlobalConfig Global e => App e String 60 | getReplicaDir = replicaDir <$> get GlobalConfig 61 | 62 | export 63 | getGoldenDir : State GlobalConfig Global e => App e String 64 | getGoldenDir = do 65 | gd <- goldenDir <$> get GlobalConfig 66 | maybe (testDir <$> getReplicaDir) pure gd 67 | 68 | export 69 | setAbsoluteReplicaDir : Has [State GlobalConfig Global, FileSystem] e => App e () 70 | setAbsoluteReplicaDir = do 71 | rdir <- getReplicaDir 72 | if isAbsolute rdir 73 | then pure () 74 | else do 75 | pwd <- getCurrentDir 76 | modify GlobalConfig ({replicaDir := pwd rdir}) 77 | 78 | export 79 | getSingleTestDir : Has 80 | [ State CurrentTest Test 81 | , State GlobalConfig Global ] e => App e String 82 | getSingleTestDir = do 83 | d <- getReplicaDir 84 | t <- get CurrentTest 85 | pure $ testDir d t.name 86 | 87 | export 88 | getSingleTestFileDir : Has 89 | [ State CurrentTest Test 90 | , State GlobalConfig Global ] e => App e String 91 | getSingleTestFileDir = ( defaultFile) <$> getSingleTestDir 92 | 93 | export 94 | getSingleTestGoldenDir : Has 95 | [ State CurrentTest Test 96 | , State GlobalConfig Global ] e => App e String 97 | getSingleTestGoldenDir = do 98 | d <- getGoldenDir 99 | t <- get CurrentTest 100 | pure $ d t.name 101 | 102 | export 103 | getSingleTestGoldenFileDir : Has 104 | [ State CurrentTest Test 105 | , State GlobalConfig Global ] e => App e String 106 | getSingleTestGoldenFileDir = ( defaultFile) <$> getSingleTestGoldenDir 107 | 108 | export 109 | getErrorFile : Has 110 | [ State CurrentTest Test 111 | , State GlobalConfig Global ] e => App e String 112 | getErrorFile = do 113 | t <- getSingleTestDir 114 | pure $ t defaultError 115 | 116 | export 117 | getInputFile : Has 118 | [ State CurrentTest Test 119 | , State GlobalConfig Global ] e => App e String 120 | getInputFile = do 121 | t <- getSingleTestDir 122 | pure $ t defaultInput 123 | 124 | export 125 | getOutputFile : Has 126 | [ State CurrentTest Test 127 | , State GlobalConfig Global ] e => App e String 128 | getOutputFile = do 129 | t <- getSingleTestDir 130 | pure $ t defaultOutput 131 | 132 | export 133 | getStatusFile : Has 134 | [ State CurrentTest Test 135 | , State GlobalConfig Global ] e => App e String 136 | getStatusFile = do 137 | t <- getSingleTestDir 138 | pure $ t defaultStatus 139 | 140 | export 141 | getWatchedFile : Has 142 | [ State CurrentTest Test 143 | , State GlobalConfig Global ] e => String -> App e String 144 | getWatchedFile f = do 145 | t <- get CurrentTest 146 | pure $ maybe f ( f) t.workingDir 147 | 148 | export 149 | getExpectedOutput : Has 150 | [ State CurrentTest Test 151 | , State GlobalConfig Global ] e => App e String 152 | getExpectedOutput = do 153 | t <- getSingleTestGoldenDir 154 | pure $ t defaultExpectedOutput 155 | 156 | export 157 | getExpectedError : Has 158 | [ State CurrentTest Test 159 | , State GlobalConfig Global ] e => App e String 160 | getExpectedError = do 161 | t <- getSingleTestGoldenDir 162 | pure $ t defaultExpectedError 163 | 164 | export 165 | getExpectedFile : Has 166 | [ State CurrentTest Test 167 | , State GlobalConfig Global ] e => String -> App e String 168 | getExpectedFile s = do 169 | t <- getSingleTestGoldenFileDir 170 | pure $ t s 171 | 172 | export 173 | getReplica : 174 | FileSystem (FSError :: e) => 175 | Has [ State GlobalConfig Global 176 | , Exception ReplicaError ] e => App e Replica 177 | getReplica = do 178 | ctx <- get GlobalConfig 179 | let fs = ctx.files 180 | content <- traverse readReplica fs 181 | let Just jsons = traverse parse content 182 | | Nothing => throw $ InvalidJSON [] 183 | let res = traverse jsonToReplica jsons 184 | let Valid repl = map (>>= (\(MkReplica xs) => xs)) res 185 | | Error xs => throw $ InvalidJSON xs 186 | let ([], _) = duplicatedKeys repl 187 | | (dup, _) => throw $ InvalidJSON ["Duplicated key(s): \{show dup}"] 188 | pure $ MkReplica repl 189 | where 190 | readReplica : String -> App e String 191 | readReplica f = handle (readFile f) 192 | pure (\err : FSError => throw $ CantAccessTestFile f) 193 | go : (List String, List String) -> Test -> (List String, List String) 194 | go (dup, names) t = if t.name `elem` names 195 | then if t.name `elem` dup 196 | then (dup, names) 197 | else (t.name :: dup, names) 198 | else (dup, t.name :: names) 199 | duplicatedKeys : List Test -> (List String, List String) 200 | duplicatedKeys xs = foldl go ([], []) xs 201 | 202 | export 203 | when : Bool -> App e () -> App e () 204 | when cond x = if cond then x else pure () 205 | 206 | export 207 | catchNew : App (err :: e) a -> (err -> App e a) -> App e a 208 | catchNew x f = handle x pure (\er : err => f er) 209 | -------------------------------------------------------------------------------- /src/Replica/App/Run.idr: -------------------------------------------------------------------------------- 1 | ||| Applitation of a `replica run` command 2 | module Replica.App.Run 3 | 4 | import Control.App 5 | import Control.App.Console 6 | 7 | import Data.Either 8 | import Data.List 9 | import Data.String 10 | 11 | import Language.JSON 12 | 13 | import System.Future 14 | import System.Path 15 | 16 | import Replica.App.Clock 17 | import Replica.App.FileSystem 18 | import Replica.App.Filter 19 | import Replica.App.Format 20 | import Replica.App.Log 21 | import Replica.App.Replica 22 | import Replica.App.Run.Dependencies 23 | import Replica.App.Run.Display 24 | import Replica.App.Run.RunOne 25 | import public Replica.App.Run.Types 26 | import Replica.App.System 27 | 28 | import Replica.Command.Run 29 | import Replica.Core.Parse 30 | import Replica.Core.Types 31 | import Replica.Option.Global 32 | import Replica.Other.Decorated 33 | import Replica.Other.String 34 | import Replica.Other.Validation 35 | 36 | %default total 37 | 38 | -- Create the folders needed by Replica (usually ./.replica/test and ./.replica/log) 39 | prepareReplicaDir : SystemIO (SystemError :: e) => 40 | FileSystem (FSError :: e) => 41 | Has [ State RunContext RunCommand 42 | , State GlobalConfig Global 43 | , Exception ReplicaError 44 | , Console 45 | ] e => App e String 46 | prepareReplicaDir = do 47 | debug $ "GlobalConfig: \{!(show <$> get GlobalConfig)}" 48 | catchNew setAbsoluteReplicaDir 49 | (\err : FSError => throw $ CantAccessTestFile "current directory") 50 | rDir <- getReplicaDir 51 | log "Replica directory: \{rDir}" 52 | debug "Creating test directory: \{testDir rDir}" 53 | catchNew (system "mkdir -p \{show (testDir rDir)}") 54 | (\err : SystemError => throw $ CantAccessTestFile "\{show (testDir rDir)}") 55 | debug "Creating log directory: \{testDir rDir}" 56 | catchNew (system "mkdir -p \{show (logDir rDir)}") 57 | (\err : SystemError => throw $ CantAccessTestFile "\{show (logDir rDir)}") 58 | Just gd <- goldenDir <$> get GlobalConfig 59 | | Nothing => pure rDir 60 | debug "Creating golden-value directory: \{gd}" 61 | catchNew (system "mkdir -p \{show gd}") 62 | (\err : SystemError => throw $ CantAccessTestFile "\{show gd}") 63 | pure rDir 64 | 65 | data RunType = Partial | Total 66 | 67 | data RunningPlan = 68 | None 69 | | Running RunType SuitePlan TestPlan 70 | 71 | -- add result to an existing suite or create a new one 72 | mergeResults : List (Maybe String, List (Test, Either TestError TestResult)) -> 73 | (Maybe String, List (Test, Either TestError TestResult)) -> 74 | List (Maybe String, List (Test, Either TestError TestResult)) 75 | mergeResults [] x = [x] 76 | mergeResults (y :: xs) x@(suiteName, results) 77 | = if fst y == suiteName 78 | then (map (++ results) y) :: xs 79 | else y :: mergeResults xs x 80 | 81 | selectNextSuite : TestPlan -> RunningPlan 82 | selectNextSuite (Plan (x :: xs) waitingOthers) = 83 | Running Total x (Plan xs waitingOthers) 84 | selectNextSuite (Plan [] waitingOthers) = 85 | case sortBy (flip compare `on` (length . now)) waitingOthers of 86 | {- if all tests have at least one test waiting for another one to 87 | succeed, 88 | take the suite that has the more tests ready for execution 89 | -} 90 | [] => None 91 | (w::ws) => Running Partial w (Plan [] ws) 92 | 93 | prepareBatch : Nat -> SuitePlan -> (List Test, SuitePlan) 94 | prepareBatch 0 plan = (plan.now, {now := []} plan) 95 | prepareBatch n plan = 96 | map (\remains => {now := remains} plan) $ 97 | splitAt n plan.now 98 | 99 | runAllTests : SystemIO (SystemError :: TestError :: e) => 100 | SystemIO (SystemError :: e) => 101 | FileSystem (FSError :: TestError :: e) => 102 | SystemClock (TestError :: e) => 103 | Console (TestError :: e) => 104 | Has [ State RunContext RunCommand 105 | , State GlobalConfig Global 106 | , Console 107 | ] e => TestPlan -> App e (List (Maybe String, List (Test, Either TestError TestResult))) 108 | runAllTests plan = do 109 | putStrLn $ separator 80 110 | putStrLn $ !bold "Running tests...\n" 111 | batchTests [] plan 112 | where 113 | 114 | 115 | handleInaccessibleTests : 116 | List (Test, Either TestError TestResult) -> SuitePlan -> 117 | App e (Maybe SuitePlan, List (Test, Either TestError TestResult)) 118 | handleInaccessibleTests acc plan = do 119 | let errs = join 120 | [ map (\t => (t, Left Inaccessible)) plan.later 121 | , map (\(reason, t) => (t, Left $ RequirementsFailed reason)) plan.skipped 122 | ] 123 | when (not !(interactive <$> get RunContext)) 124 | (traverse_ (\(t, r) => new t (testOutput r)) errs) 125 | pure (Nothing, acc ++ errs) 126 | 127 | runSuite : 128 | RunType -> (List (Test, Either TestError TestResult)) -> SuitePlan -> 129 | App e (Maybe SuitePlan, List (Test, Either TestError TestResult)) 130 | runSuite mode acc plan = do 131 | n <- threads <$> get RunContext 132 | case prepareBatch n plan of 133 | -- No new tests are ready 134 | ([], later) => case (mode, acc) of 135 | -- On a total run, remainintests must be in error 136 | (Total, _) => handleInaccessibleTests acc later 137 | {- On a partial run, tests may be stuck because they're waiting for 138 | tests of another suite. 139 | It can be the case if we ran at least one test in this run, 140 | Otherwise, we're just stuck 141 | -} 142 | (Partial, []) => handleInaccessibleTests acc later 143 | (Partial, _) => pure (guard (not $ emptySuite later) $> later, acc) 144 | (now, nextBatches) => do 145 | debug $ withOffset 4 "Now: \{show $ length now}" 146 | debug $ withOffset 4 "Later: \{show $ nextBatches.now ++ nextBatches.later}" 147 | res <- map await <$> traverse (map (fork . delay) . processTest) now 148 | when (not !(interactive <$> get RunContext)) 149 | (traverse_ (\(t, r) => new t $ testOutput r) res) 150 | p <- punitive <$> get RunContext 151 | -- stop on error in in punitive mode 152 | if p && any (not . isFullSuccess . snd) res 153 | then pure (Nothing, res) 154 | else do 155 | let (suc, fai) = sortResults res 156 | let newPlan = updateSuite suc fai nextBatches 157 | debug $ displaySuitePlan newPlan 158 | runSuite mode (acc ++ res) $ assert_smaller plan newPlan 159 | 160 | batchTests : List (Maybe String, List (Test, Either TestError TestResult)) -> 161 | TestPlan -> App e (List (Maybe String, List (Test, Either TestError TestResult))) 162 | batchTests acc plan = do 163 | debug $ withOffset 4 $ "Run a batch" 164 | p <- punitive <$> get RunContext 165 | case selectNextSuite plan of 166 | None => pure acc 167 | Running mode suite plan' => do 168 | displaySuite suite.name 169 | (stuckPlan, suiteResults) <- runSuite mode [] suite 170 | let acc' = mergeResults acc (suite.name, suiteResults) 171 | if p && any (not . isFullSuccess . snd) suiteResults 172 | then pure acc' 173 | else do 174 | let plan'' = {waitingOthers $= maybe id (::) stuckPlan} plan' 175 | batchTests acc' $ assert_smaller plan $ updateOnBatchResults suiteResults plan'' 176 | 177 | extractReport : (Maybe String, List (Test, Either TestError TestResult)) -> 178 | List (String, Either TestError TestResult) 179 | extractReport = map (mapFst name) . snd 180 | 181 | export 182 | suiteOutput : SystemIO (SystemError :: e) => 183 | Has [ State RunContext RunCommand 184 | , State GlobalConfig Global 185 | , Console 186 | ] e => 187 | Maybe String -> List (Test, Either TestError TestResult) -> App e () 188 | suiteOutput suite tests = do 189 | displaySuite suite 190 | traverse_ (uncurry (\t, r => new t (testOutput r))) tests 191 | 192 | export 193 | runReplica : SystemIO (SystemError :: TestError :: e) => 194 | SystemIO (SystemError :: e) => 195 | FileSystem (FSError :: TestError :: e) => 196 | FileSystem (FSError :: e) => 197 | SystemClock (TestError :: e) => 198 | Console (TestError :: e) => 199 | Has [ State RunContext RunCommand 200 | , State GlobalConfig Global 201 | , Exception ReplicaError 202 | , Console 203 | ] e => App e Stats 204 | runReplica = do 205 | ctx <- get RunContext 206 | debug $ "Run: \{show ctx}" 207 | rDir <- prepareReplicaDir 208 | (kept, excluded) <- new ctx.filter defineActiveTests 209 | let plan = buildPlan kept excluded 210 | log $ displayPlan plan 211 | result <- runAllTests plan 212 | let logFile = lastRunLog rDir 213 | catchNew (writeFile logFile (show $ reportToJSON $ extractReport =<< result)) 214 | (\err : FSError => throw $ CantAccessTestFile logFile) 215 | when !(interactive <$> get RunContext) 216 | (do putStrLn $ separator 80 217 | putStrLn $ !bold "Test results:" 218 | traverse_ (uncurry (\t, r => suiteOutput t r)) result) 219 | let stats = asStats $ map snd $ snd =<< result 220 | report stats 221 | pure stats 222 | -------------------------------------------------------------------------------- /src/Replica/App/Run/Dependencies.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Run.Dependencies 2 | 3 | import Data.Maybe 4 | import Data.List 5 | import Data.List1 6 | import Data.String 7 | 8 | import Replica.Core.Test 9 | import Replica.Core.Types 10 | import Replica.Other.String 11 | 12 | %default total 13 | 14 | public export 15 | record SuitePlan where 16 | constructor SPlan 17 | name : Maybe String 18 | now : List Test 19 | later : List Test 20 | skipped : List (String, Test) 21 | 22 | export 23 | emptySuite : SuitePlan -> Bool 24 | emptySuite (SPlan _ [] [] []) = True 25 | emptySuite _ = False 26 | 27 | public export 28 | record TestPlan where 29 | constructor Plan 30 | ready : List SuitePlan 31 | waitingOthers : List SuitePlan 32 | 33 | export 34 | displaySuitePlan : SuitePlan -> String 35 | displaySuitePlan x = removeTrailingNL $ unlines 36 | [ " Plan:" 37 | , " Now: \{show $ map name x.now}" 38 | , " Later: \{show $ map name x.later}" 39 | , " Skipped: \{show $ map (name . snd) x.skipped}" 40 | ] 41 | 42 | export 43 | displayPlan : TestPlan -> String 44 | displayPlan plan = unlines $ ("Ready:" 45 | :: (plan.ready >>= go)) 46 | ++ ("Postponed:" 47 | :: (plan.waitingOthers >>= go)) 48 | where 49 | go : SuitePlan -> List String 50 | go p = ["\{fromMaybe "No suite" p.name}:", displaySuitePlan p] 51 | 52 | 53 | -- Does any of the tests depends on a test that is not in the list? 54 | dependsOnOther : List Test -> Bool 55 | dependsOnOther xs = any (not . flip elem (name <$> xs)) $ xs >>= require 56 | 57 | buildSuitePlan : Maybe String -> List1 Test -> SuitePlan 58 | buildSuitePlan name xs = let 59 | (now, later) = partition (null . require) $ forget xs 60 | in SPlan name now later [] 61 | 62 | removeRequirements : List String -> Test -> Test 63 | removeRequirements xs y 64 | = {require $= filter (not . (`elem` xs))} y 65 | 66 | export 67 | buildPlan : (available : List Test) -> (rejected : List Test) -> TestPlan 68 | buildPlan available rejected = uncurry Plan $ 69 | partition (not . dependsOnOther . later) $ namedSuitePlan 70 | where 71 | cleantAvailable : List Test 72 | cleantAvailable 73 | = removeRequirements (name <$> rejected) <$> available 74 | suites : List (Maybe String, List1 Test) 75 | suites = bySuite cleantAvailable 76 | namedSuitePlan : List SuitePlan 77 | namedSuitePlan = map (uncurry buildSuitePlan) suites 78 | 79 | export 80 | sortResults : List (Test, Either TestError TestResult) -> (List String, List String) 81 | sortResults 82 | = bimap (map (Test.name . fst)) (map (Test.name . fst)) 83 | . partition (either (const False) isSuccess . snd) 84 | 85 | export 86 | updateSuite : (successes, other : List String) -> SuitePlan -> SuitePlan 87 | updateSuite successes other (SPlan n now later skipped) = let 88 | (now', later') = partition isReady $ removeRequirements successes <$> later 89 | (later'', skipped') = partition (not . any (`elem` other) . require) later' 90 | in SPlan n (now ++ now') later'' (skipped ++ (map (\t => (fromMaybe "unknown_test" $ head' t.require , t)) skipped')) 91 | 92 | export 93 | updateOnBatchResults : List (Test, Either TestError TestResult) -> TestPlan -> TestPlan 94 | updateOnBatchResults xs plan = let 95 | (successes, other) = sortResults xs 96 | ready' = updateSuite successes other <$> plan.ready 97 | waiting' = updateSuite successes other <$> plan.waitingOthers 98 | (ready'', waitingOthers') = 99 | partition (not . dependsOnOther . later) waiting' 100 | in Plan (ready' ++ ready'') waitingOthers' 101 | -------------------------------------------------------------------------------- /src/Replica/App/Run/Display.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Run.Display 2 | 3 | import Control.App 4 | import Control.App.Console 5 | 6 | import Data.List1 7 | import Data.String 8 | 9 | import Replica.App.Clock 10 | import public Replica.App.Display 11 | import Replica.App.Format 12 | import Replica.App.Replica 13 | import Replica.App.Run.Types 14 | import Replica.App.System 15 | 16 | import Replica.Core.Types 17 | import Replica.Option.Global 18 | 19 | import Replica.Command.Run 20 | import Replica.Option.Global 21 | import Replica.Other.Decorated 22 | import Replica.Other.String 23 | 24 | %default total 25 | 26 | -- native way to display expectations 27 | expectedVsGiven : State GlobalConfig Global e => 28 | Nat -> String -> String -> App e (List String) 29 | expectedVsGiven k expected given = pure $ map (withOffset k) $ 30 | ( "Expected:" :: map !red (lines expected)) ++ 31 | ( "Given:" :: map !green (lines given)) 32 | 33 | nativeShow : State GlobalConfig Global e => 34 | Console e => Nat -> String -> String -> App e () 35 | nativeShow n expected given = 36 | traverse_ putStrLn !(expectedVsGiven n expected given) 37 | 38 | -- Provide different ways to show the difference between expectations and givens 39 | export 40 | showDiff : SystemIO (SystemError :: e) => 41 | State GlobalConfig Global e => 42 | State CurrentTest Test e => 43 | Console e => DiffCommand -> Nat -> String -> String -> App e () 44 | showDiff None n expected given = pure () 45 | showDiff Native n expected given = nativeShow n expected given 46 | showDiff Diff n x y = catchNew 47 | (system $ "diff --minimal \{!getExpectedOutput} \{!getOutputFile}") 48 | (\err : SystemError => pure ()) 49 | showDiff GitDiff n x y = catchNew 50 | (system $ "git diff --minimal --word-diff=color --no-index -- \{!getExpectedOutput} \{!getOutputFile}") 51 | (\err : SystemError => pure ()) 52 | showDiff (Custom z) n x y = catchNew 53 | (system $ "\{z} \{!getExpectedOutput} \{!getOutputFile}") 54 | (\err : SystemError => pure ()) 55 | 56 | -- display the final report of a run 57 | export 58 | report : Console e => State GlobalConfig Global e => Stats -> App e () 59 | report x = do 60 | putStrLn $ separator 80 61 | putStrLn $ !bold "Summary:" 62 | let nb = countTests x 63 | if nb == 0 64 | then putStrLn $ withOffset 2 "No test" 65 | else putStrLn $ removeTrailingNL $ unlines $ catMaybes 66 | [ guard (x.successes > 0) $> 67 | withOffset 2 "\{!ok} (Success): \{show x.successes} / \{show nb}" 68 | , guard (x.failures > 0) $> 69 | withOffset 2 "\{!ko} (Failure): \{show x.failures} / \{show nb}" 70 | , guard (x.errors > 0) $> 71 | withOffset 2 "\{!err} (Errors): \{show x.errors} / \{show nb}" 72 | , guard (x.skipped > 0) $> 73 | withOffset 2 "\{!pending} (Pending): \{show x.skipped} / \{show nb}" 74 | ] 75 | 76 | export 77 | testOutput : SystemIO (SystemError :: e) => 78 | Has [ State RunContext RunCommand 79 | , State GlobalConfig Global 80 | , State CurrentTest Test 81 | , Console 82 | ] e => Either TestError TestResult -> App e () 83 | testOutput (Left y) = do 84 | t <- get CurrentTest 85 | putStr (withOffset 2 $ (!yellow "\{!err} \{t.name}: ")) 86 | putStrLn (displayTestError y) 87 | testOutput (Right Skipped) = do 88 | t <- get CurrentTest 89 | putStrLn $ withOffset 2 "\{!pending} \{t.name}" 90 | testOutput (Right (Success duration)) = do 91 | displayTime <- timing <$> get RunContext 92 | let time : String := if displayTime then " (\{showDuration duration})" else "" 93 | t <- get CurrentTest 94 | if !(hideSuccess <$> get RunContext) 95 | then pure () 96 | else putStrLn $ withOffset 2 "\{!ok} \{t.name}\{time}" 97 | testOutput (Right (Fail xs)) = do 98 | t <- get CurrentTest 99 | putStrLn $ withOffset 2 $ !red "\{!ko} \{t.name}:" 100 | traverse_ (putStrLn . withOffset 6 . !red) (xs >>= displayFailReason) 101 | traverse_ writeFailure xs 102 | where 103 | multilineDisplay : (offset : Nat) -> (content : String) -> App e () 104 | multilineDisplay offset = traverse_ (putStrLn . withOffset offset) . lines 105 | 106 | displayError : (given : String) -> (exp : (e: Expectation ** ExpectationError e)) -> App e () 107 | displayError given (MkDPair (Exact x) snd) = 108 | let content = case !(diff <$> get GlobalConfig) of 109 | None => multilineDisplay 8 x 110 | Native => multilineDisplay 8 x 111 | d' => showDiff d' 8 given x 112 | in putStrLn (withOffset 6 "Exact expectation mismatch:") >> content 113 | displayError given (MkDPair (StartsWith x) snd) = 114 | putStrLn (withOffset 6 "Start mismatch:") >> multilineDisplay 4 x 115 | displayError given (MkDPair (EndsWith x) snd) = 116 | putStrLn (withOffset 6 "End mismatch:") >> multilineDisplay 4 x 117 | displayError given (MkDPair (Partial Ordered ys) snd) = do 118 | putStrLn (withOffset 6 "Consecutive expectations mismatch, first not found:") 119 | multilineDisplay 8 snd 120 | displayError given (MkDPair (Partial Whatever ys) snd) = do 121 | putStrLn (withOffset 6 "Contains expectations mismatch, not found:") 122 | traverse_ (multilineDisplay 8) snd 123 | displayError given (MkDPair Generated Nothing) = pure () 124 | displayError given (MkDPair Generated (Just x)) = 125 | let content = case !(diff <$> get GlobalConfig) of 126 | None => multilineDisplay 8 x 127 | Native => multilineDisplay 8 x 128 | d' => showDiff d' 8 given x 129 | in putStrLn (withOffset 6 "Golden value expectation mismatch:") >> content 130 | 131 | writeFailure : FailReason -> App e () 132 | writeFailure (WrongStatus _ expected) = pure () 133 | writeFailure (ExpectedFileNotFound x) = pure () 134 | writeFailure (WrongOutput x given ys) = do 135 | putStrLn $ withOffset 6 $ !bold "Error on \{displaySource x}:" 136 | traverse_ (displayError given) ys 137 | putStrLn $ withOffset 6 $ "Given:" 138 | traverse_ (putStrLn . withOffset 8) $ lines given 139 | 140 | -------------------------------------------------------------------------------- /src/Replica/App/Run/Types.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Run.Types 2 | 3 | public export 4 | data RunContext : Type where 5 | -------------------------------------------------------------------------------- /src/Replica/App/Set.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.Set 2 | 3 | import Control.App 4 | import Control.App.Console 5 | 6 | import Data.List 7 | 8 | import Language.JSON 9 | 10 | import Replica.App.FileSystem 11 | import Replica.App.Format 12 | import Replica.App.Log 13 | import Replica.App.Replica 14 | import Replica.Command.Set 15 | import Replica.Core 16 | 17 | import Replica.Option.Global 18 | import Replica.Other.Decorated 19 | import Replica.Other.String 20 | import Replica.Other.Validation 21 | 22 | import System.Path 23 | 24 | %default total 25 | 26 | export 27 | data HomeDir : Type where 28 | 29 | export 30 | data SetContext : Type where 31 | 32 | export 33 | updateConfig : List (String, JSON) -> Setter -> JSON 34 | updateConfig = updateConfig' [] 35 | where 36 | updateConfig' : List (String, JSON) -> List (String, JSON) -> Setter -> JSON 37 | updateConfig' xs [] (MkSetter key value) = JObject $ reverse $ (key, value) :: xs 38 | updateConfig' xs (x :: ys) s@(MkSetter key value) = if fst x == key 39 | then JObject $ reverse xs ++ ((key, value) :: ys) 40 | else updateConfig' (x :: xs) ys s 41 | 42 | 43 | 44 | export 45 | setReplica : 46 | FileSystem (FSError :: e) => 47 | Has 48 | [ Console 49 | , State HomeDir (Maybe String) 50 | , State SetContext SetCommand 51 | , State GlobalConfig Global 52 | , Exception ReplicaError 53 | ] e => App e () 54 | setReplica = do 55 | setCtx <- get SetContext 56 | debug "Set: \{show setCtx}" 57 | tgt <- case setCtx.target of 58 | Local => pure $ "." ".replica.json" 59 | Global => do 60 | Just hd <- get HomeDir 61 | | Nothing => throw $ InvalidJSON ["Can't access global config: No HOME"] 62 | pure $ hd ".replica.json" 63 | f <- catchNew (readFile tgt) 64 | (\err : FSError => case err of 65 | (MissingFile x) => pure $ show $ JObject [] 66 | pat => throw $ InvalidJSON ["Error when accessing config"]) 67 | let Just (JObject xs) = JSON.parse f 68 | | Nothing => throw $ InvalidJSON 69 | ["Can't parse current config \{show tgt} (either delete the file or fix its content)"] 70 | | Just _ => throw $ InvalidJSON 71 | ["Current config \{show tgt} is invalid (object expected) (either delete the file or fix its content)"] 72 | let newConfig = updateConfig xs !(setter <$> get SetContext) 73 | catchNew (writeFile tgt $ show newConfig) 74 | (\err : FSError => throw $ InvalidJSON ["Can't write config"]) 75 | -------------------------------------------------------------------------------- /src/Replica/App/System.idr: -------------------------------------------------------------------------------- 1 | module Replica.App.System 2 | 3 | 4 | import Control.App 5 | import System 6 | 7 | %default covering 8 | 9 | public export 10 | data SystemError = Err Int 11 | 12 | public export 13 | interface Has [Exception SystemError] e => SystemIO e where 14 | system : String -> App e () 15 | 16 | export 17 | Has [PrimIO, Exception SystemError] e => SystemIO e where 18 | system exec = do 19 | 0 <- primIO $ system exec 20 | | n => throw (Err n) 21 | pure () 22 | -------------------------------------------------------------------------------- /src/Replica/Command.idr: -------------------------------------------------------------------------------- 1 | module Replica.Command 2 | 3 | import Data.List 4 | import Data.List1 5 | import Data.List.AtIndex 6 | import Data.OpenUnion 7 | 8 | import Replica.Option.Types 9 | import Replica.Other.Decorated 10 | import Replica.Other.Validation 11 | 12 | import public Replica.Command.Info 13 | import public Replica.Command.Run 14 | import public Replica.Command.Set 15 | import public Replica.Command.New 16 | import public Replica.Command.Help 17 | import public Replica.Command.Version 18 | 19 | public export 20 | Commands : Type 21 | Commands = Union Prelude.id [RunCommand, InfoCommand, SetCommand, NewCommand, Help, Version] 22 | 23 | export 24 | parseArgs : Default Global' -> List1 String -> ParseResult Commands 25 | parseArgs g xs = foldl1 go $ InvalidOption (pure help) xs ::: map (flip apply xs) 26 | [ map inj . parseRun g 27 | , map inj . parseInfo g 28 | , map inj . parseSet 29 | , map inj . parseNew 30 | , map inj . parseHelp 31 | , map inj . parseVersion 32 | ] 33 | where 34 | go : ParseResult Commands -> ParseResult Commands -> ParseResult Commands 35 | go (Done x) _ = Done x 36 | go _ (Done x) = Done x 37 | go x@(InvalidMix _) y = x 38 | go x y@(InvalidMix _) = y 39 | go x@(InvalidOption _ xs) y@(InvalidOption _ ys) = 40 | if length xs <= length ys then x else y 41 | -------------------------------------------------------------------------------- /src/Replica/Command/Help.idr: -------------------------------------------------------------------------------- 1 | module Replica.Command.Help 2 | 3 | import Data.List 4 | import Data.List1 5 | import Data.String 6 | 7 | import Replica.Command.Info 8 | import Replica.Command.Run 9 | import Replica.Command.Set 10 | import Replica.Command.New 11 | import Replica.Command.Version 12 | import public Replica.Help 13 | import Replica.Option.Types 14 | import Replica.Other.Validation 15 | 16 | export 17 | help : Help 18 | help = MkHelp 19 | { name = "help" 20 | , usage = Just "replica COMMAND [COMMAND_OPTIONS]" 21 | , description = "Integration testing for command line interfaces" 22 | , chapter = [ ("Commands", helpRun ::: [helpTest, helpInfo, helpSet, helpNew, helpVersion]) 23 | ] 24 | , lastWords = Just "Run 'replica help COMMAND' for more information on a command." 25 | } 26 | 27 | parseHelp' : Help -> List1 String -> ParseResult Help 28 | parseHelp' help xs@(name:::ys) = maybe 29 | (InvalidOption (pure help) xs) 30 | ( const $ case ys of 31 | [] => Done help 32 | (next::ys') => let 33 | subs = foldMap (forget . snd) help.chapter 34 | in foldl 35 | (\res, h => res <+> parseHelp' h (assert_smaller xs (next:::ys'))) 36 | (InvalidOption (pure help) $ pure "Cannot find help for '\{unwords ys}'") 37 | subs 38 | ) 39 | $ guard $ name == help.name 40 | 41 | export 42 | parseHelp : List1 String -> ParseResult Help 43 | parseHelp = parseHelp' help 44 | -------------------------------------------------------------------------------- /src/Replica/Command/Info.idr: -------------------------------------------------------------------------------- 1 | module Replica.Command.Info 2 | 3 | import Data.String 4 | 5 | import Replica.Help 6 | import Replica.Option.Filter 7 | import Replica.Option.Global 8 | import Replica.Option.Types 9 | import Replica.Other.Decorated 10 | 11 | import Replica.Command.Info.Suite 12 | import Replica.Command.Info.Test 13 | 14 | %default total 15 | 16 | public export 17 | data InfoCommand' : (f : Type -> Type) -> Type where 18 | SuiteInfo : SuiteInfoCommand' f -> InfoCommand' f 19 | TestInfo : TestInfoCommand' f -> InfoCommand' f 20 | 21 | public export 22 | InfoCommand : Type 23 | InfoCommand = Done InfoCommand' 24 | 25 | export 26 | TyMap InfoCommand' where 27 | tyMap func (SuiteInfo x) = SuiteInfo (tyMap func x) 28 | tyMap func (TestInfo x) = TestInfo (tyMap func x) 29 | 30 | export 31 | TyTraversable InfoCommand' where 32 | tyTraverse func (SuiteInfo x) = [| SuiteInfo (tyTraverse func x) |] 33 | tyTraverse func (TestInfo x) = [| TestInfo (tyTraverse func x) |] 34 | 35 | export 36 | Show InfoCommand where 37 | show (SuiteInfo i) = unwords [ "SuiteInfo", "(", show i, ")" ] 38 | show (TestInfo i) = unwords [ "TestInfo", "(", show i, ")" ] 39 | 40 | export 41 | helpInfo : Help 42 | helpInfo = 43 | MkHelp 44 | "info" 45 | (Just "replica info [TOPIC] [TOPIC_OPTIONS] JSON_TEST_FILE") 46 | "Get information about a given test file" 47 | [ ("Topics", helpTestInfo ::: [helpSuiteInfo]) 48 | ] 49 | (Just "Run 'replica help info TOPIC' for more information on a topic.") 50 | 51 | export 52 | parseInfo : Default Global' -> List1 String -> ParseResult InfoCommand 53 | parseInfo g ("info":::xs) = case xs of 54 | "suite"::xs' => SuiteInfo <$> parseSuiteInfo g xs' 55 | "test"::xs' => TestInfo <$> parseTestInfo g xs' 56 | _ => TestInfo <$> parseTestInfo g xs 57 | parseInfo _ xs = InvalidOption Nothing xs 58 | -------------------------------------------------------------------------------- /src/Replica/Command/Info/Suite.idr: -------------------------------------------------------------------------------- 1 | module Replica.Command.Info.Suite 2 | 3 | import Data.String 4 | 5 | import Replica.Help 6 | import Replica.Option.Filter 7 | import Replica.Option.Global 8 | import Replica.Option.Types 9 | import Replica.Other.Decorated 10 | 11 | public export 12 | record SuiteInfoCommand' (f : Type -> Type) where 13 | constructor MkSuiteInfo 14 | filter : Filter' f 15 | global : Global' f 16 | 17 | public export 18 | SuiteInfoCommand : Type 19 | SuiteInfoCommand = Done SuiteInfoCommand' 20 | 21 | export 22 | TyMap SuiteInfoCommand' where 23 | tyMap func x = MkSuiteInfo 24 | (tyMap func x.filter) (tyMap func x.global) 25 | 26 | export 27 | TyTraversable SuiteInfoCommand' where 28 | tyTraverse func x = [| MkSuiteInfo 29 | (tyTraverse func x.filter) (tyTraverse func x.global) 30 | |] 31 | 32 | export 33 | Show SuiteInfoCommand where 34 | show i = unwords 35 | [ "MkSuiteInfo" 36 | , show i.filter 37 | , show i.global 38 | ] 39 | 40 | optParseInfo : OptParse (Builder SuiteInfoCommand') SuiteInfoCommand 41 | optParseInfo = [| MkSuiteInfo 42 | (embed SuiteInfoCommand'.filter (\x => {filter := x}) optParseFilter) 43 | (embed global (\x => {global := x}) optParseGlobal) 44 | |] 45 | 46 | defaultInfo : Default SuiteInfoCommand' 47 | defaultInfo = MkSuiteInfo 48 | defaultFilter 49 | defaultGlobal 50 | 51 | export 52 | withGivenGlobal : Default SuiteInfoCommand' -> Default Global' -> Default SuiteInfoCommand' 53 | withGivenGlobal x g = {global := g <+> defaultGlobal} x 54 | 55 | 56 | export 57 | helpSuiteInfo : Help 58 | helpSuiteInfo = 59 | commandHelp {b = Builder SuiteInfoCommand'} 60 | ("replica":::["info"]) "suite" "Display information about test suites" 61 | optParseInfo 62 | (Just "JSON_TEST_FILE") 63 | 64 | export 65 | parseSuiteInfo : Default Global' -> List String -> ParseResult SuiteInfoCommand 66 | parseSuiteInfo g xs = do 67 | builder <- parse 68 | helpSuiteInfo 69 | (initBuilder $ defaultInfo `withGivenGlobal` g) 70 | optParseInfo 71 | xs 72 | maybe (InvalidMix "No test file given") Done $ build builder 73 | -------------------------------------------------------------------------------- /src/Replica/Command/Info/Test.idr: -------------------------------------------------------------------------------- 1 | module Replica.Command.Info.Test 2 | 3 | import Data.String 4 | 5 | import Replica.Help 6 | import Replica.Option.Filter 7 | import Replica.Option.Global 8 | import Replica.Option.Types 9 | import Replica.Other.Decorated 10 | 11 | %default total 12 | 13 | public export 14 | record TestInfoCommand' (f : Type -> Type) where 15 | constructor MkTestInfo 16 | showExpectation : f Bool 17 | filter : Filter' f 18 | global : Global' f 19 | 20 | public export 21 | TestInfoCommand : Type 22 | TestInfoCommand = Done TestInfoCommand' 23 | 24 | export 25 | TyMap TestInfoCommand' where 26 | tyMap func x = MkTestInfo 27 | (func x.showExpectation) 28 | (tyMap func x.filter) (tyMap func x.global) 29 | 30 | export 31 | TyTraversable TestInfoCommand' where 32 | tyTraverse func x = [| MkTestInfo 33 | (func x.showExpectation) 34 | (tyTraverse func x.filter) (tyTraverse func x.global) 35 | |] 36 | 37 | export 38 | Show TestInfoCommand where 39 | show i = unwords [ "MkTestInfo" 40 | , show i.showExpectation 41 | , show i.filter 42 | , show i.global] 43 | 44 | showExpectationPart : Part (Builder TestInfoCommand') Bool 45 | showExpectationPart = inj $ MkOption 46 | ( singleton 47 | $ MkMod (singleton "expectations") ['e'] (Left True) 48 | "show expectation for each test") 49 | False 50 | go 51 | where 52 | go : Bool -> Builder TestInfoCommand' -> Either String (Builder TestInfoCommand') 53 | go = ifSame showExpectation 54 | (\x => {showExpectation := Right x}) 55 | (const $ const "Contradictory values for expectations") 56 | 57 | 58 | optParseInfo : OptParse (Builder TestInfoCommand') TestInfoCommand 59 | optParseInfo = [|MkTestInfo 60 | (liftAp showExpectationPart) 61 | (embed filter (\x => {filter := x}) optParseFilter) 62 | (embed global (\x => {global := x}) optParseGlobal) 63 | |] 64 | 65 | defaultInfo : Default TestInfoCommand' 66 | defaultInfo = MkTestInfo 67 | (defaultPart showExpectationPart) 68 | defaultFilter 69 | defaultGlobal 70 | 71 | export 72 | withGivenGlobal : Default TestInfoCommand' -> Default Global' -> Default TestInfoCommand' 73 | withGivenGlobal x g = {global := g <+> defaultGlobal} x 74 | 75 | export 76 | helpTestInfo : Help 77 | helpTestInfo = 78 | commandHelp {b = Builder TestInfoCommand'} 79 | ("replica":::["info"]) "test" "Display information about tests" 80 | optParseInfo 81 | (Just "JSON_TEST_FILE") 82 | 83 | export 84 | parseTestInfo : Default Global' -> List String -> ParseResult TestInfoCommand 85 | parseTestInfo g xs = do 86 | builder <- parse 87 | helpTestInfo 88 | (initBuilder $ defaultInfo `withGivenGlobal` g) 89 | optParseInfo 90 | xs 91 | maybe (InvalidMix "No test file given") Done $ build builder 92 | -------------------------------------------------------------------------------- /src/Replica/Command/New.idr: -------------------------------------------------------------------------------- 1 | module Replica.Command.New 2 | 3 | import Data.List 4 | import Data.List1 5 | import Data.String 6 | import System.Path 7 | 8 | import Replica.Help 9 | import public Replica.Option.Types 10 | import Replica.Other.Decorated 11 | 12 | public export 13 | data FileFormat = JSON | Dhall 14 | 15 | export 16 | Show FileFormat where 17 | show JSON = "JSON" 18 | show Dhall = "Dhall" 19 | 20 | public export 21 | record NewCommand' (f : Type -> Type) where 22 | constructor MkNewCommand 23 | format : f FileFormat 24 | includeSample : f Bool 25 | file : f String 26 | 27 | public export 28 | NewCommand : Type 29 | NewCommand = Done NewCommand' 30 | 31 | TyMap NewCommand' where 32 | tyMap func x = 33 | MkNewCommand 34 | (func x.format) 35 | (func x.includeSample) 36 | (func x.file) 37 | 38 | TyTraversable NewCommand' where 39 | tyTraverse func x = [| 40 | MkNewCommand 41 | (func x.format) 42 | (func x.includeSample) 43 | (func x.file) 44 | |] 45 | 46 | Show NewCommand where 47 | show x = unwords 48 | [ "MkNewCommand" 49 | , show x.format 50 | , show x.includeSample 51 | , show x.file 52 | ] 53 | 54 | formatPart : Part (Builder NewCommand') FileFormat 55 | formatPart = inj $ MkOption 56 | (singleton $ MkMod (singleton "format") ['f'] 57 | (Right $ MkValue "FORMAT" (parseFormat . toLower)) 58 | "format of the file to create (json|dhall)") 59 | Dhall 60 | go 61 | where 62 | parseFormat : String -> Maybe FileFormat 63 | parseFormat "json" = Just JSON 64 | parseFormat "dhall"= Just Dhall 65 | parseFormat x = Nothing 66 | go : FileFormat -> Builder NewCommand' -> Either String (Builder NewCommand') 67 | go = one format 68 | (\x => {format := Right x}) 69 | (\x, y => "More than one format given: \{show y}, \{show x}") 70 | 71 | includeSamplePart : Part (Builder NewCommand') Bool 72 | includeSamplePart = inj $ MkOption (toList1 73 | [ MkMod (singleton "includeSample") ['s'] (Left True) 74 | "include a sample test" 75 | , MkMod (singleton "noSample") ['S'] (Left False) 76 | "no sample test" 77 | ]) 78 | True 79 | go 80 | where 81 | go : Bool -> Builder NewCommand' -> Either String (Builder NewCommand') 82 | go = ifSame includeSample 83 | (\x => {includeSample := Right x}) 84 | (const $ const "Contradictory values for includeSample") 85 | 86 | fileParamPart : Part (Builder NewCommand') String 87 | fileParamPart = inj $ MkParam1 "NEW_TEST_FILE" Just go 88 | where 89 | checkFileType : String -> Maybe FileFormat 90 | checkFileType "json" = Just JSON 91 | checkFileType "dhall" = Just Dhall 92 | checkFileType x = Nothing 93 | setFile : String -> Builder NewCommand' -> Builder NewCommand' 94 | setFile f = {file := Right f} 95 | setFileAndFormat : String -> FileFormat -> Builder NewCommand' -> Builder NewCommand' 96 | setFileAndFormat f fmt = {file := Right f, format := Right fmt} 97 | go : String -> Builder NewCommand' -> Either String (Builder NewCommand') 98 | go = one file 99 | (\x, cmd => case cmd.format of 100 | Left _ => maybe 101 | (setFile x cmd) 102 | (\fmt => setFileAndFormat x fmt cmd) 103 | (checkFileType =<< (toLower <$> extension x)) 104 | Right _ => setFile x cmd 105 | ) 106 | (const $ const $"Can't write more than one test file") 107 | 108 | export 109 | optParseNew : OptParse (Builder NewCommand') NewCommand 110 | optParseNew = 111 | [| MkNewCommand 112 | (liftAp formatPart) 113 | (liftAp includeSamplePart) 114 | (liftAp fileParamPart) 115 | |] 116 | 117 | export 118 | defaultNew : Default NewCommand' 119 | defaultNew = 120 | MkNewCommand 121 | (defaultPart formatPart) 122 | (defaultPart includeSamplePart) 123 | (defaultPart fileParamPart) 124 | 125 | export 126 | helpNew : Help 127 | helpNew = commandHelp {b = Builder NewCommand'} 128 | (pure "replica") "new" "Create test files" 129 | optParseNew 130 | (Just "NEW_TEST_FILE") 131 | 132 | export 133 | parseNew : List1 String -> ParseResult NewCommand 134 | parseNew ("new":::xs) = do 135 | builder <- parse helpNew (initBuilder defaultNew) optParseNew xs 136 | maybe (InvalidMix "No test file given") Done $ build builder 137 | parseNew xs = InvalidOption Nothing xs 138 | -------------------------------------------------------------------------------- /src/Replica/Command/Run.idr: -------------------------------------------------------------------------------- 1 | ||| Parser for command line argument of a `replica run command` 2 | module Replica.Command.Run 3 | 4 | import Data.List 5 | import Data.String 6 | 7 | import Replica.Help 8 | import Replica.Option.Types 9 | import public Replica.Option.Filter 10 | import public Replica.Option.Global 11 | import Replica.Other.Decorated 12 | 13 | %default total 14 | 15 | public export 16 | record RunCommand' (f : Type -> Type) where 17 | constructor MkRunCommand 18 | workingDir : f String 19 | interactive : f Bool 20 | timing : f Bool 21 | threads : f Nat 22 | hideSuccess : f Bool 23 | punitive : f Bool 24 | filter : Filter' f 25 | global : Global' f 26 | 27 | public export 28 | RunCommand : Type 29 | RunCommand = Done RunCommand' 30 | 31 | TyMap RunCommand' where 32 | tyMap func x = 33 | MkRunCommand 34 | (func x.workingDir) 35 | (func x.interactive) 36 | (func x.timing) 37 | (func x.threads) 38 | (func x.hideSuccess) 39 | (func x.punitive) 40 | (tyMap func x.filter) 41 | (tyMap func x.global) 42 | 43 | TyTraversable RunCommand' where 44 | tyTraverse func x = [| 45 | MkRunCommand 46 | (func x.workingDir) 47 | (func x.interactive) 48 | (func x.timing) 49 | (func x.threads) 50 | (func x.hideSuccess) 51 | (func x.punitive) 52 | (tyTraverse func x.filter) 53 | (tyTraverse func x.global) 54 | |] 55 | 56 | export 57 | Show RunCommand where 58 | show x = unwords 59 | [ "MkRunCommand" 60 | , show x.workingDir 61 | , show x.interactive 62 | , show x.timing 63 | , show x.threads 64 | , show x.hideSuccess 65 | , show x.punitive 66 | , show x.filter 67 | , show x.global 68 | ] 69 | 70 | interactivePart : Part (Builder RunCommand') Bool 71 | interactivePart = inj $ MkOption 72 | (singleton $ MkMod (singleton "interactive") ['i'] (Left True) 73 | "(re)generate golden number if different/missing") 74 | False 75 | go 76 | where 77 | go : Bool -> Builder RunCommand' -> Either String (Builder RunCommand') 78 | go = ifSame interactive 79 | (\x => {interactive := Right x}) 80 | (const $ const "Contradictory values for interactive") 81 | 82 | timingPart : Part (Builder RunCommand') Bool 83 | timingPart = inj $ MkOption 84 | (toList1 85 | [ MkMod ("timing" ::: ["duration"]) ['d'] (Left True) 86 | "display execution time of each tests" 87 | , MkMod ("no-timing" ::: ["no-duration"]) ['D'] (Left False) 88 | "hide execution time of each tests" 89 | ] 90 | ) 91 | True 92 | go 93 | where 94 | go : Bool -> Builder RunCommand' -> Either String (Builder RunCommand') 95 | go = ifSame interactive 96 | (\x => {timing := Right x}) 97 | (const $ const "Contradictory values for timing") 98 | 99 | workingDirPart : Part (Builder RunCommand') String 100 | workingDirPart = inj $ MkOption 101 | (singleton $ MkMod ("working-dir" ::: ["wdir"]) ['w'] 102 | (Right $ MkValue "DIR" Just) 103 | "set where is the test working directory") 104 | "." 105 | go 106 | where 107 | go : String -> Builder RunCommand' -> Either String (Builder RunCommand') 108 | go = one workingDir 109 | (\x => {workingDir := Right x}) 110 | (\x, y => "More than one working directony were given: \{y}, \{x}") 111 | 112 | 113 | threadsPart : Part (Builder RunCommand') Nat 114 | threadsPart = inj $ MkOption 115 | (singleton $ MkMod (singleton "threads") ['x'] 116 | (Right $ MkValue "N" parsePositive) 117 | "max number of threads (default 1; 0 for no thread limit)") 118 | 1 119 | go 120 | where 121 | go : Nat -> Builder RunCommand' -> Either String (Builder RunCommand') 122 | go = one threads 123 | (\x => {threads := Right x}) 124 | (\x, y => "More than one threads values were given: \{show y}, \{show x}") 125 | 126 | punitivePart : Part (Builder RunCommand') Bool 127 | punitivePart = inj $ MkOption 128 | (singleton $ MkMod ("punitive" ::: ["fail-fast"]) ['p'] 129 | (Left True) 130 | "fail fast mode: stops on the first test that fails") 131 | False 132 | go 133 | where 134 | go : Bool -> Builder RunCommand' -> Either String (Builder RunCommand') 135 | go = ifSame punitive 136 | (\x => {punitive := Right x}) 137 | (const $ const "Contradictory values for punitive mode") 138 | 139 | hideSuccessPart : Part (Builder RunCommand') Bool 140 | hideSuccessPart = inj $ MkOption 141 | (singleton $ MkMod (toList1 ["hide-success", "fail-only"]) [] 142 | (Left True) 143 | "hide successful tests in the report") 144 | False 145 | go 146 | where 147 | go : Bool -> Builder RunCommand' -> Either String (Builder RunCommand') 148 | go = ifSame hideSuccess 149 | (\x => {hideSuccess := Right x}) 150 | (const $ const "Contradictory values for hide success mode") 151 | 152 | optParseRun : OptParse (Builder RunCommand') RunCommand 153 | optParseRun = 154 | [| MkRunCommand 155 | (liftAp workingDirPart) 156 | (liftAp interactivePart) 157 | (liftAp timingPart) 158 | (liftAp threadsPart) 159 | (liftAp hideSuccessPart) 160 | (liftAp punitivePart) 161 | (embed filter (\x => {filter := x}) optParseFilter) 162 | (embed global (\x => {global := x}) optParseGlobal) 163 | |] 164 | 165 | defaultRun : Default RunCommand' 166 | defaultRun = MkRunCommand 167 | (defaultPart workingDirPart) 168 | (defaultPart interactivePart) 169 | (defaultPart timingPart) 170 | (defaultPart threadsPart) 171 | (defaultPart hideSuccessPart) 172 | (defaultPart punitivePart) 173 | defaultFilter 174 | defaultGlobal 175 | 176 | withGivenGlobal : Default RunCommand' -> Default Global' -> Default RunCommand' 177 | withGivenGlobal x g = {global := g <+> defaultGlobal} x 178 | 179 | 180 | parseRun' : Help -> Default Global' -> List String -> ParseResult RunCommand 181 | parseRun' help g xs = do 182 | builder <- parse 183 | help 184 | (initBuilder $ defaultRun `withGivenGlobal` g) 185 | optParseRun 186 | xs 187 | maybe (InvalidMix "No test file given") Done $ build builder 188 | 189 | export 190 | helpRun : Help 191 | helpRun = commandHelp {b = Builder RunCommand'} 192 | (pure "replica") "run" "Run tests from a Replica JSON file" 193 | optParseRun 194 | (Just "JSON_TEST_FILE(S)") 195 | 196 | export 197 | helpTest : Help 198 | helpTest = commandHelp {b = Builder RunCommand'} 199 | (pure "replica") "test" "Alias for 'replica run'" 200 | optParseRun 201 | (Just "JSON_TEST_FILE(S)") 202 | 203 | export 204 | parseRun : Default Global' -> List1 String -> ParseResult RunCommand 205 | parseRun g ("run":::xs) = parseRun' helpRun g xs 206 | parseRun g ("test":::xs) = parseRun' helpTest g xs 207 | parseRun _ xs = InvalidOption Nothing xs 208 | -------------------------------------------------------------------------------- /src/Replica/Command/Set.idr: -------------------------------------------------------------------------------- 1 | module Replica.Command.Set 2 | 3 | import Data.List 4 | import Data.String 5 | 6 | import Replica.Help 7 | import Replica.Option.Parse 8 | import Replica.Option.Types 9 | import public Replica.Option.Filter 10 | import public Replica.Option.Global 11 | import Replica.Other.Decorated 12 | 13 | import Language.JSON 14 | 15 | %default total 16 | 17 | public export 18 | data TargetConfig = Local | Global 19 | 20 | export 21 | Show TargetConfig where 22 | show Local = "Local" 23 | show Global = "Global" 24 | 25 | export 26 | Eq TargetConfig where 27 | Local == Local = True 28 | Global == Global = True 29 | _ == _ = False 30 | 31 | public export 32 | record Setter where 33 | constructor MkSetter 34 | key: String 35 | value: JSON 36 | 37 | export 38 | Show Setter where 39 | show (MkSetter key value) = 40 | "MkSetter \{show key} \{show value}" 41 | 42 | public export 43 | record SetCommand' (f : Type -> Type) where 44 | constructor MkSetCommand 45 | target : f TargetConfig 46 | setter : f Setter 47 | 48 | public export 49 | SetCommand : Type 50 | SetCommand = Done SetCommand' 51 | 52 | TyMap SetCommand' where 53 | tyMap func x = 54 | MkSetCommand (func x.target) (func x.setter) 55 | 56 | TyTraversable SetCommand' where 57 | tyTraverse func x = 58 | [| MkSetCommand (func x.target) (func x.setter) |] 59 | 60 | export 61 | Show SetCommand where 62 | show x = "MkSetCommand \{show x.target} (\{show x.setter})" 63 | 64 | targetPart : Part (Builder SetCommand') TargetConfig 65 | targetPart = inj $ MkOption 66 | (toList1 67 | [ MkMod (singleton "local") ['l'] (Left Local) 68 | "Set a local config value (in `./.replica.json`) (default)" 69 | , MkMod (singleton "global") ['g'] (Left Global) 70 | "Set a global config value (in `$HOME/.replica.json`)" 71 | ]) 72 | Local 73 | go 74 | where 75 | go : TargetConfig -> Builder SetCommand' -> Either String (Builder SetCommand') 76 | go = ifSame target (\x => {target := Right $ x}) 77 | (const $ const "Contradictory target") 78 | 79 | setterPart : Part (Builder SetCommand') Setter 80 | setterPart = inj $ MkParam1 81 | "KEY=VALUE" 82 | parseKV 83 | go 84 | where 85 | go : Setter -> Builder SetCommand' -> Either String (Builder SetCommand') 86 | go s = Right . {setter := Right $ s} 87 | 88 | buildSetter : ConfigValue -> (String, String) -> Maybe Setter 89 | buildSetter x = map (uncurry MkSetter) . jsonFor x 90 | 91 | validateKV : String -> String -> Maybe Setter 92 | validateKV x y with (strM x, strM y) 93 | validateKV "" y | (StrNil, w) = Nothing 94 | validateKV x (prim__strCons '=' t) | (w, StrCons '=' t) = 95 | concatMap (flip buildSetter (x, t)) configValues 96 | validateKV x y | (w, z) = Nothing 97 | 98 | parseKV : String -> Maybe Setter 99 | parseKV x = uncurry validateKV $ break (== '=') x 100 | 101 | optParseSet : OptParse (Builder SetCommand') SetCommand 102 | optParseSet = 103 | [| MkSetCommand 104 | (liftAp targetPart) 105 | (liftAp setterPart) 106 | |] 107 | 108 | defaultSet : Default SetCommand' 109 | defaultSet = MkSetCommand 110 | (defaultPart targetPart) 111 | (defaultPart setterPart) 112 | 113 | export 114 | helpSet : Help 115 | helpSet = {lastWords := Just footer} baseCommand 116 | where 117 | baseCommand : Help 118 | baseCommand = commandHelp {b = Builder SetCommand'} 119 | (pure "replica") "set" "Set a global configuration for replica commands" 120 | (optParseSet) 121 | (Just "KEY=VALUE") 122 | footer : String 123 | footer = 124 | #""" 125 | Available keys, and description: 126 | replicaDir (or replica-dir, rDir) where replica stores internal information (default `./.replica`) 127 | goldenDir (or golden-dir, gDir) where replica stores golden values (default `./.replica/tests`) 128 | colour (or color) do we used colored output or not? (true or false, default `true`) 129 | ascii do we keep away emojis or not? (true or false, default `false`) 130 | diff command used to display diff 131 | (known value: diff, git, native, other strings are considered as custom command) 132 | (default: `native`) 133 | log log level (default: `none`) 134 | (known value: debug, info, warning, critical) 135 | testFile (or jsonFile, test) the path of the test file to use (prefer a relative path) 136 | (no default) 137 | """# 138 | 139 | 140 | export 141 | parseSet : List1 String -> ParseResult SetCommand 142 | parseSet ("set":::xs) = do 143 | builder <- parse helpSet (initBuilder $ defaultSet) optParseSet xs 144 | maybe (InvalidMix "No test file given") Done $ build builder 145 | parseSet xs = InvalidOption Nothing xs 146 | 147 | -------------------------------------------------------------------------------- /src/Replica/Command/Version.idr: -------------------------------------------------------------------------------- 1 | module Replica.Command.Version 2 | 3 | import Data.List1 4 | 5 | import Replica.Help 6 | import Replica.Option.Types 7 | import Replica.Version 8 | 9 | public export 10 | data Version = MkVersion String 11 | 12 | export 13 | parseVersion : List1 String -> ParseResult Version 14 | parseVersion ("version" ::: xs) = Done $ MkVersion "replica version \{version}" 15 | parseVersion xs = InvalidOption Nothing xs 16 | 17 | export 18 | helpVersion : Help 19 | helpVersion = MkHelp 20 | "version" (Just "replica version") 21 | "Show replica version" 22 | [] 23 | Nothing 24 | -------------------------------------------------------------------------------- /src/Replica/Core.idr: -------------------------------------------------------------------------------- 1 | ||| Re-exports modules that are used through most of the replica app 2 | module Replica.Core 3 | 4 | import public Replica.Core.Types 5 | import public Replica.Core.Parse 6 | -------------------------------------------------------------------------------- /src/Replica/Core/Test.idr: -------------------------------------------------------------------------------- 1 | ||| Some useful methods for test manipulation 2 | module Replica.Core.Test 3 | 4 | import Data.List 5 | import Data.List1 6 | 7 | import Replica.Core.Types 8 | 9 | export 10 | bySuite : List Test -> List (Maybe String, List1 Test) 11 | bySuite = let 12 | withName : List1 Test -> (Maybe String, List1 Test) 13 | withName xs@(x:::_) = (x.suite, xs) 14 | in map withName . groupBy ((==) `on` suite) . sortBy (compare `on` suite) 15 | 16 | export 17 | isReady : Test -> Bool 18 | isReady = null . require 19 | -------------------------------------------------------------------------------- /src/Replica/Core/Types.idr: -------------------------------------------------------------------------------- 1 | module Replica.Core.Types 2 | 3 | import Data.String 4 | import Data.List 5 | import Data.List1 6 | import Language.JSON 7 | import System.Clock 8 | 9 | %default total 10 | 11 | public export 12 | data OrderSensitive = Ordered | Whatever 13 | 14 | export 15 | Show OrderSensitive where 16 | show Ordered = "Ordered" 17 | show Whatever = "Whatever" 18 | 19 | public export 20 | data Part = StdOut | StdErr | FileName String 21 | 22 | export 23 | Show Part where 24 | show StdOut = "StdOut" 25 | show StdErr = "StdErr" 26 | show (FileName x) = "(File \{x})" 27 | 28 | public export 29 | data Expectation 30 | = Exact String 31 | | StartsWith String 32 | | EndsWith String 33 | | Partial OrderSensitive (List String) 34 | | Generated 35 | 36 | public export 37 | ExpectationError : Expectation -> Type 38 | ExpectationError Generated = Maybe String 39 | ExpectationError (Partial Ordered xs) = String 40 | ExpectationError (Partial Whatever xs) = List1 String 41 | ExpectationError x = Unit 42 | 43 | 44 | export 45 | Show Expectation where 46 | show (Exact x) = "Exact \{show x}" 47 | show (StartsWith x) = "StartsWith x" 48 | show (EndsWith x) = "EndsWith \{show x}" 49 | show (Partial x xs) = "Partial \{show x} \{show xs}" 50 | show Generated = "Generated" 51 | 52 | public export 53 | record Test where 54 | constructor MkTest 55 | name: String 56 | pending : Bool 57 | description: Maybe String 58 | require : List String 59 | workingDir : Maybe String 60 | tags: List String 61 | suite : Maybe String 62 | beforeTest : List String 63 | afterTest : List String 64 | command: String 65 | input : Maybe String 66 | status : Maybe (Either Bool Nat) 67 | spaceSensitive : Bool 68 | stdOut : List Expectation 69 | stdErr : List Expectation 70 | files : List (String, List Expectation) 71 | 72 | export 73 | (.expectations) : Test -> List (Part, List Expectation) 74 | (.expectations) t = (StdOut, t.stdOut) :: (StdErr, t.stdErr) :: (mapFst FileName <$> t.files) 75 | 76 | export 77 | Show Test where 78 | show x = unwords 79 | [ "MkTest" 80 | , show x.name 81 | , show x.pending 82 | , show x.description 83 | , show x.require 84 | , show x.workingDir 85 | , show x.tags 86 | , show x.beforeTest 87 | , show x.afterTest 88 | , show x.command 89 | , show x.input 90 | , show x.status 91 | , show x.spaceSensitive 92 | , show x.stdOut 93 | , show x.stdErr 94 | , show x.files 95 | ] 96 | 97 | export 98 | defaultExpectedOutput : String 99 | defaultExpectedOutput = "expected" 100 | 101 | export 102 | defaultExpectedError : String 103 | defaultExpectedError = "expected.err" 104 | 105 | export 106 | defaultFile : String 107 | defaultFile = "file" 108 | 109 | export 110 | defaultError : String 111 | defaultError = "error" 112 | 113 | export 114 | defaultOutput : String 115 | defaultOutput = "output" 116 | 117 | export 118 | defaultInput : String 119 | defaultInput = "input" 120 | 121 | export 122 | defaultStatus : String 123 | defaultStatus = "status" 124 | 125 | 126 | 127 | public export 128 | record Replica where 129 | constructor MkReplica 130 | tests: List Test 131 | 132 | public export 133 | data FailReason : Type where 134 | WrongStatus : (status : Nat) -> (expected : Either Bool Nat) -> FailReason 135 | WrongOutput : Part -> String -> List1 (e : Expectation ** ExpectationError e) -> FailReason 136 | ExpectedFileNotFound : String -> FailReason 137 | 138 | export 139 | isNoGolden : FailReason -> Bool 140 | isNoGolden (WrongOutput source given xs) = hasGolden $ forget xs 141 | where 142 | hasGolden : List (e : Expectation ** ExpectationError e) -> Bool 143 | hasGolden [] = False 144 | hasGolden ((Generated ** Nothing) :: _) = True 145 | hasGolden (_ :: xs) = hasGolden xs 146 | isNoGolden _ = False 147 | 148 | export 149 | isMismatch : FailReason -> Bool 150 | isMismatch (WrongOutput source given xs) = hasMismatch $ forget xs 151 | where 152 | hasMismatch : List (e : Expectation ** ExpectationError e) -> Bool 153 | hasMismatch [] = False 154 | hasMismatch ((Generated ** Nothing) :: xs) = hasMismatch xs 155 | hasMismatch (_ :: xs) = True 156 | isMismatch _ = False 157 | 158 | export 159 | displaySource : Part -> String 160 | displaySource StdOut = "standard output" 161 | displaySource StdErr = "standard error" 162 | displaySource (FileName x) = "file \{show x}" 163 | 164 | export 165 | Eq Part where 166 | (==) StdOut StdOut = True 167 | (==) StdErr StdErr = True 168 | (==) (FileName x) (FileName y) = x == y 169 | (==) _ _ = False 170 | 171 | export 172 | displayFailReason : FailReason -> List String 173 | displayFailReason (WrongStatus x (Left True)) = pure "[Fails while it should pass : \{show x}]" 174 | displayFailReason (WrongStatus _ (Left False)) = pure "[Pass but it should fail]" 175 | displayFailReason (WrongStatus x (Right y)) = pure "[Status error: got \{show x}, expected \{show y}]" 176 | displayFailReason (ExpectedFileNotFound src) = pure "[Missing expected file \"\{src}\"]" 177 | displayFailReason w@(WrongOutput src given reasons) = join 178 | [ guard (isNoGolden w) $> "[Missing Golden for \{displaySource src}]" 179 | , guard (isNoGolden w) $> "[Unexpected content for \{displaySource src}]" 180 | ] 181 | 182 | namespace FailReason 183 | 184 | encodePart : Part -> (String, JSON) 185 | encodePart StdOut = ("source", JString "stdout") 186 | encodePart StdErr = ("source", JString "stderr") 187 | encodePart (FileName x) = ("source", JObject [("file", JString x)]) 188 | 189 | encodeFailure : (e : Expectation ** ExpectationError e) -> List (String, JSON) 190 | encodeFailure (MkDPair (Exact x) ()) = [("exact", JString x)] 191 | encodeFailure (MkDPair (StartsWith x) ()) = [("start", JString x)] 192 | encodeFailure (MkDPair (EndsWith x) ()) = [("end", JString x)] 193 | encodeFailure (MkDPair (Partial Ordered xs) snd) = 194 | [("consecutive", JArray $ JString <$> xs), ("notFound", JString snd)] 195 | encodeFailure (MkDPair (Partial Whatever xs) snd) = 196 | [("contains", JArray $ JString <$> xs), ("notFound", JArray $ forget $ JString <$> snd)] 197 | encodeFailure (MkDPair Generated Nothing) = [("generated", JNull)] 198 | encodeFailure (MkDPair Generated (Just x)) = [("generated", JString x)] 199 | 200 | export 201 | toJSON : FailReason -> JSON 202 | toJSON (WrongStatus x y) = JObject 203 | [("type", JString "status"), ("expected", either JBoolean (JNumber . cast) y), ("given", JNumber $ cast x)] 204 | toJSON (ExpectedFileNotFound src) = JObject 205 | [("type", JString "missing"), ("expected", JString src)] 206 | toJSON (WrongOutput src given err) = JObject $ 207 | encodePart src :: ("type", JString "output") :: ("given", JString given) :: 208 | [("errors", JArray $ map (JObject . encodeFailure) $ forget err)] 209 | 210 | public export 211 | data TestResult 212 | = Success (Clock Duration) 213 | | Fail (List FailReason) 214 | | Skipped 215 | 216 | namespace TestResult 217 | 218 | export 219 | toJSON : TestResult -> JSON 220 | toJSON (Success d) = JObject [("Success", JString $ show d)] 221 | toJSON (Fail xs) = JObject [("Fail", JArray $ map toJSON xs)] 222 | toJSON Skipped = JString "Skipped" 223 | 224 | export 225 | isSuccess : TestResult -> Bool 226 | isSuccess (Success _) = True 227 | isSuccess _ = False 228 | 229 | public export 230 | data TestError 231 | = FileSystemError String 232 | | InitializationFailed String 233 | | WrapUpFailed TestResult String 234 | | RequirementsFailed String 235 | | Inaccessible 236 | 237 | namespace TestError 238 | 239 | export 240 | toJSON : TestError -> JSON 241 | toJSON (FileSystemError x) = 242 | JObject [("type", JString "FileSystemError") , ("content", JString x)] 243 | toJSON (InitializationFailed x) = 244 | JObject [("type", JString "InitializationFailed") , ("content", JString x)] 245 | toJSON (WrapUpFailed x y) = 246 | JObject [("type", JString "WrapUpFailed"), ("result", toJSON x), ("content", JString y)] 247 | toJSON (RequirementsFailed x) = 248 | JObject [("type", JString "RequirementsFailed"), ("content", JString x)] 249 | toJSON Inaccessible = 250 | JObject [("type", JString "Inaccessible")] 251 | 252 | export 253 | displayTestError : TestError -> String 254 | displayTestError (FileSystemError x) = "File error: \{x}" 255 | displayTestError (InitializationFailed x) = "Before test action failed: \{x}" 256 | displayTestError (WrapUpFailed x y) = "After test action failed: \{y}" 257 | displayTestError (RequirementsFailed x) = "Test rely on test \{x}, which failed" 258 | displayTestError Inaccessible = "Test rely on other tests that weren't run" 259 | 260 | export 261 | isFullSuccess : Either TestError TestResult -> Bool 262 | isFullSuccess (Right (Success _)) = True 263 | isFullSuccess _ = False 264 | 265 | public export 266 | record Stats where 267 | constructor MkStats 268 | successes : Nat 269 | failures : Nat 270 | errors : Nat 271 | skipped : Nat 272 | 273 | export 274 | Semigroup Stats where 275 | (<+>) x y = MkStats 276 | (x.successes + y.successes) 277 | (x.failures + y.failures) 278 | (x.errors + y.errors) 279 | (x.skipped + y.skipped) 280 | 281 | export 282 | Monoid Stats where 283 | neutral = MkStats 0 0 0 0 284 | 285 | export 286 | asStats : List (Either TestError TestResult) -> Stats 287 | asStats = foldMap go 288 | where 289 | go : Either TestError TestResult -> Stats 290 | go (Left x) = {errors := 1} neutral 291 | go (Right (Success _)) = {successes := 1} neutral 292 | go (Right (Fail xs)) = {failures := 1} neutral 293 | go (Right Skipped) = {skipped := 1} neutral 294 | 295 | export 296 | countTests : Stats -> Nat 297 | countTests x = x.successes + x.failures + x.errors + x.skipped 298 | 299 | export 300 | resultToJSON : Either TestError TestResult -> JSON 301 | resultToJSON (Left x) = JObject [("Error", toJSON x)] 302 | resultToJSON (Right x) = toJSON x 303 | 304 | export 305 | reportToJSON : List (String, Either TestError TestResult) -> JSON 306 | reportToJSON = JObject . map (map resultToJSON) 307 | -------------------------------------------------------------------------------- /src/Replica/Help.idr: -------------------------------------------------------------------------------- 1 | ||| Help building consistent help for a command line interface 2 | module Replica.Help 3 | 4 | import Data.List 5 | import Data.List1 6 | import Data.String 7 | import Data.String.Extra 8 | import Replica.Other.String 9 | 10 | %default total 11 | 12 | public export 13 | record Help where 14 | constructor MkHelp 15 | name : String 16 | usage : Maybe String 17 | description : String 18 | chapter : List (String, List1 Help) 19 | lastWords : Maybe String 20 | 21 | padRightTo : Nat -> String -> String 22 | padRightTo k x = x ++ pack (replicate (minus k (length x)) ' ') 23 | 24 | entrySynopsis : Nat -> Help -> List String 25 | entrySynopsis k x = 26 | let (y::ys) = lines x.description 27 | | [] => [] 28 | in "\{padRightTo k x.name} \{y}" :: map (pack (replicate (2 + k) ' ') ++) ys 29 | 30 | chapterSynopsis : Nat -> String -> List1 Help -> String 31 | chapterSynopsis k x xs = removeTrailingNL $ unlines $ 32 | "\{x}:" :: map (withOffset 2) (forget xs >>= entrySynopsis k) 33 | 34 | export 35 | display : Help -> String 36 | display h = removeTrailingNL $ unlines $ "" :: intersperse "" ( 37 | maybe id (\u => ("Usage: \{u}" ::)) h.usage $ 38 | h.description :: 39 | map (uncurry $ chapterSynopsis maxLengthName) h.chapter 40 | ++ (maybe [] (\l => [l]) h.lastWords)) 41 | where 42 | maxLengthName : Nat 43 | maxLengthName = foldl (\x, h => max x (length h.name)) 0 (h.chapter >>= forget . snd) 44 | -------------------------------------------------------------------------------- /src/Replica/Option/Filter.idr: -------------------------------------------------------------------------------- 1 | ||| Filter options that are common to a set of replica commands 2 | module Replica.Option.Filter 3 | 4 | import Data.List 5 | import Data.String 6 | 7 | import Replica.Core 8 | import Replica.Option.Types 9 | import Replica.Other.Decorated 10 | 11 | %default total 12 | 13 | public export 14 | record Filter' (f : Type -> Type) where 15 | constructor MkFilter 16 | only : f (List String) 17 | exclude : f (List String) 18 | onlyTags : f (List String) 19 | excludeTags : f (List String) 20 | onlySuites : f (List String) 21 | excludeSuites : f (List String) 22 | lastFailures : f Bool 23 | 24 | public export 25 | Filter : Type 26 | Filter = Done Filter' 27 | 28 | export 29 | TyMap Filter' where 30 | tyMap func x = MkFilter 31 | (func x.only) 32 | (func x.exclude) 33 | (func x.onlyTags) 34 | (func x.excludeTags) 35 | (func x.onlySuites) 36 | (func x.excludeSuites) 37 | (func x.lastFailures) 38 | 39 | export 40 | TyTraversable Filter' where 41 | tyTraverse func x = [| MkFilter 42 | (func x.only) 43 | (func x.exclude) 44 | (func x.onlyTags) 45 | (func x.excludeTags) 46 | (func x.onlySuites) 47 | (func x.excludeSuites) 48 | (func x.lastFailures) 49 | |] 50 | 51 | export 52 | Show Filter where 53 | show x = unwords 54 | [ "MkFilter" 55 | , show x.only 56 | , show x.exclude 57 | , show x.onlyTags 58 | , show x.excludeTags 59 | , show x.lastFailures 60 | ] 61 | 62 | onlyPart : Part (Builder Filter') (List String) 63 | onlyPart = inj $ MkOption 64 | (singleton $ MkMod (singleton "only") ['n'] 65 | (Right $ MkValue "testX,testY" $ Just . go) 66 | "a comma separated list of the tests to run") 67 | [] compose 68 | where 69 | go : String -> List String 70 | go = forget . split (== ',') 71 | compose : List String -> Builder Filter' -> Either String (Builder Filter') 72 | compose xs x = case either (const []) (intersect xs) x.exclude of 73 | [] => Right $ {only $= Right . (++ xs) . either (const []) id} x 74 | xs => Left "Some tests were both included and excluded: \{joinBy ", " xs}" 75 | 76 | 77 | excludePart : Part (Builder Filter') (List String) 78 | excludePart = inj $ MkOption 79 | (singleton $ MkMod (singleton "exclude") ['N'] 80 | (Right $ MkValue "testX,testY" $ Just . go) 81 | "a comma separated list of the tests to exclude") 82 | [] compose 83 | where 84 | go : String -> List String 85 | go = forget . split (== ',') 86 | compose : List String -> Builder Filter' -> Either String (Builder Filter') 87 | compose xs x = case either (const []) (intersect xs) x.only of 88 | [] => Right $ {exclude $= Right . (++ xs) . either (const []) id} x 89 | xs => Left "Some tests were both included and excluded: \{joinBy ", " xs}" 90 | 91 | onlyTagsPart : Part (Builder Filter') (List String) 92 | onlyTagsPart = inj $ MkOption 93 | (singleton $ MkMod ("tags" ::: ["only-tags"]) ['t'] 94 | (Right $ MkValue "TAGS" $ Just . go) 95 | "a comma separated list of the tags to run") 96 | [] compose 97 | where 98 | go : String -> List String 99 | go = forget . split (== ',') 100 | compose : List String -> Builder Filter' -> Either String (Builder Filter') 101 | compose xs x = case either (const []) (intersect xs) x.excludeTags of 102 | [] => Right $ {onlyTags $= Right . (++ xs) . either (const []) id} x 103 | xs => Left "Some tags were both included and excluded: \{joinBy ", " xs}" 104 | 105 | excludeTagsPart : Part (Builder Filter') (List String) 106 | excludeTagsPart = inj $ MkOption 107 | (singleton $ MkMod (singleton "exclude-tags") ['T'] 108 | (Right $ MkValue "TAGS" $ Just . go) 109 | "a comma separated list of the tags to exclude") 110 | [] 111 | compose 112 | where 113 | go : String -> List String 114 | go = forget . split (== ',') 115 | compose : List String -> Builder Filter' -> Either String (Builder Filter') 116 | compose xs x = case either (const []) (intersect xs) x.onlyTags of 117 | [] => Right $ {excludeTags $= Right . (++ xs) . either (const []) id} x 118 | xs => Left "Some tags were both included and excluded: \{joinBy ", " xs}" 119 | 120 | onlySuitesPart : Part (Builder Filter') (List String) 121 | onlySuitesPart = inj $ MkOption 122 | (singleton $ MkMod ("suites" ::: ["only-suites"]) ['s'] 123 | (Right $ MkValue "SUITES" $ Just . go) 124 | "a comma separated list of the suites to run") 125 | [] compose 126 | where 127 | go : String -> List String 128 | go = forget . split (== ',') 129 | compose : List String -> Builder Filter' -> Either String (Builder Filter') 130 | compose xs x = case either (const []) (intersect xs) x.excludeTags of 131 | [] => Right $ {onlySuites $= Right . (++ xs) . either (const []) id} x 132 | xs => Left "Some tags were both included and excluded: \{joinBy ", " xs}" 133 | 134 | excludeSuitesPart : Part (Builder Filter') (List String) 135 | excludeSuitesPart = inj $ MkOption 136 | (singleton $ MkMod (singleton "exclude-suites") ['S'] 137 | (Right $ MkValue "SUITES" $ Just . go) 138 | "a comma separated list of the suites to exclude") 139 | [] 140 | compose 141 | where 142 | go : String -> List String 143 | go = forget . split (== ',') 144 | compose : List String -> Builder Filter' -> Either String (Builder Filter') 145 | compose xs x = case either (const []) (intersect xs) x.onlyTags of 146 | [] => Right $ {excludeSuites $= Right . (++ xs) . either (const []) id} x 147 | xs => Left "Some tags were both included and excluded: \{joinBy ", " xs}" 148 | 149 | lastFailuresPart : Part (Builder Filter') Bool 150 | lastFailuresPart = inj $ MkOption 151 | (singleton $ MkMod (singleton "last-fails") ['l'] 152 | (Left True) 153 | "if a previous run fails, rerun only the tests that failed") 154 | False 155 | go 156 | where 157 | go : Bool -> Builder Filter' -> Either String (Builder Filter') 158 | go = ifSame lastFailures 159 | (\x => {lastFailures := Right x}) 160 | (const $ const "Contradictory values for last failures mode") 161 | 162 | 163 | export 164 | optParseFilter : OptParse (Builder Filter') (Done Filter') 165 | optParseFilter = [|MkFilter 166 | (liftAp onlyPart) (liftAp excludePart) 167 | (liftAp onlyTagsPart) (liftAp excludeTagsPart) 168 | (liftAp onlySuitesPart) (liftAp excludeSuitesPart) 169 | (liftAp lastFailuresPart) |] 170 | 171 | export 172 | defaultFilter : Default Filter' 173 | defaultFilter = MkFilter (defaultPart onlyPart) (defaultPart excludePart) 174 | (defaultPart onlyTagsPart) (defaultPart excludeTagsPart) 175 | (defaultPart onlySuitesPart) (defaultPart excludeSuitesPart) 176 | (defaultPart lastFailuresPart) 177 | 178 | export 179 | keepTest : Filter -> Test -> Bool 180 | keepTest x y = (null x.only || (y.name `elem` x.only)) 181 | && (null x.exclude || not (y.name `elem` x.exclude)) 182 | && (null x.onlyTags || not (null $ y.tags `intersect` x.onlyTags)) 183 | && (null x.excludeTags || null (y.tags `intersect` x.excludeTags)) 184 | && (null x.onlySuites || maybe False (`elem` x.onlySuites) y.suite) 185 | && (null x.excludeSuites || maybe True (not . (`elem` x.excludeSuites)) y.suite) 186 | -------------------------------------------------------------------------------- /src/Replica/Option/Global.idr: -------------------------------------------------------------------------------- 1 | ||| Replica options that can be applied to any command 2 | module Replica.Option.Global 3 | 4 | import Data.List 5 | import Data.Maybe 6 | import Data.String 7 | 8 | import Replica.Help 9 | import Replica.Option.Types 10 | import Replica.Other.Decorated 11 | 12 | public export 13 | data LogLevel = Debug | Info | Warning | Critical 14 | 15 | export 16 | Show LogLevel where 17 | show Debug = "Debug" 18 | show Info = "Info" 19 | show Warning = "Warning" 20 | show Critical = "Critical" 21 | 22 | levelToNat : LogLevel -> Nat 23 | levelToNat Debug = 0 24 | levelToNat Info = 1 25 | levelToNat Warning = 2 26 | levelToNat Critical = 3 27 | 28 | public export 29 | data DiffCommand 30 | = None 31 | | Native 32 | | Diff 33 | | GitDiff 34 | | Custom String 35 | 36 | export 37 | Show DiffCommand where 38 | show None = "None" 39 | show Native = "Native" 40 | show Diff = "Diff" 41 | show GitDiff = "GitDiff" 42 | show (Custom x) = "Custom \{show x}" 43 | 44 | export 45 | Eq LogLevel where 46 | (==) = (==) `on` levelToNat 47 | 48 | export 49 | Ord LogLevel where 50 | compare = compare `on` levelToNat 51 | 52 | public export 53 | record Global' (f : Type -> Type) where 54 | constructor MkGlobal 55 | replicaDir : f String 56 | goldenDir : f (Maybe String) 57 | colour : f Bool 58 | ascii : f Bool 59 | logLevel : f (Maybe LogLevel) 60 | diff : f DiffCommand 61 | files : f (List String) 62 | 63 | public export 64 | Global : Type 65 | Global = Done Global' 66 | 67 | export 68 | Show Global where 69 | show x = unwords 70 | [ "MkGlobal" 71 | , show x.replicaDir 72 | , show x.goldenDir 73 | , show x.colour 74 | , show x.ascii 75 | , show x.logLevel 76 | , show x.diff 77 | , show x.files 78 | ] 79 | 80 | export 81 | TyMap Global' where 82 | tyMap func x = MkGlobal 83 | (func x.replicaDir) (func x.goldenDir) 84 | (func x.colour) (func x.ascii) 85 | (func x.logLevel) 86 | (func x.diff) (func x.files) 87 | 88 | export 89 | TyTraversable Global' where 90 | tyTraverse func x = 91 | [| MkGlobal 92 | (func x.replicaDir) (func x.goldenDir) 93 | (func x.colour) (func x.ascii) 94 | (func x.logLevel) 95 | (func x.diff) (func x.files) 96 | |] 97 | 98 | export 99 | replicaDefaultDir : String 100 | replicaDefaultDir = ".replica" 101 | 102 | replicaDirPart : Part (Builder Global') String 103 | replicaDirPart = inj $ MkOption 104 | (singleton $ MkMod (singleton "replica-dir") [] 105 | (Right $ MkValue "DIR" Just) 106 | "set the location of replica store (default: \".replica\")") 107 | replicaDefaultDir 108 | go 109 | where 110 | go : String -> Builder Global' -> Either String (Builder Global') 111 | go = one replicaDir (\x => {replicaDir := Right x}) 112 | (\x, y => "More than one replica dir were given: \{y}, \{x}") 113 | 114 | goldenDirPart : Part (Builder Global') (Maybe String) 115 | goldenDirPart = inj $ MkOption 116 | (singleton $ MkMod (singleton "golden-dir") [] 117 | (Right $ MkValue "DIR" (Just . Just)) 118 | "set the location of golden values (default: \"REPLICA_DIR/test\")") 119 | Nothing 120 | go 121 | where 122 | go : Maybe String -> Builder Global' -> Either String (Builder Global') 123 | go = one goldenDir (\x => {goldenDir := Right x}) 124 | (\x, y => "More than one replica dir were given: \{show y}, \{show x}") 125 | 126 | export 127 | readLogLevel : String -> Maybe (Maybe LogLevel) 128 | readLogLevel = readLogLevel' . toLower 129 | where 130 | readLogLevel' : String -> Maybe (Maybe LogLevel) 131 | readLogLevel' "none" = Just Nothing 132 | readLogLevel' "debug" = Just $ Just Debug 133 | readLogLevel' "info" = Just $ Just Info 134 | readLogLevel' "warning" = Just $ Just Warning 135 | readLogLevel' "critical" = Just $ Just Critical 136 | readLogLevel' _ = Nothing 137 | 138 | logLevelPart : Part (Builder Global') (Maybe LogLevel) 139 | logLevelPart = inj $ MkOption 140 | (toList1 141 | [ MkMod (singleton "log") [] (Right logLevelValue) 142 | #""" 143 | define the log level of the application 144 | available values: (default: none) 145 | """# 146 | , MkMod (singleton "verbose") ['v'] (Left $ Just Info) 147 | "similar to --log info" 148 | ]) 149 | Nothing 150 | go 151 | where 152 | logLevelValue : Value (Maybe LogLevel) 153 | logLevelValue = MkValue "logLevel" (readLogLevel . toLower) 154 | go : Maybe LogLevel -> Builder Global' -> Either String (Builder Global') 155 | go = ifSame logLevel (\x => {logLevel := Right $ x}) 156 | (const $ const "Contradictory log level") 157 | 158 | colourPart : Part (Builder Global') Bool 159 | colourPart = inj $ MkOption 160 | (toList1 161 | [ MkMod (toList1 ["color", "colour"]) ['c'] (Left True) 162 | "activate colour in output (default)" 163 | , MkMod (toList1 ["no-color", "no-colour"]) [] (Left False) 164 | "desactivate colour in output" 165 | ]) 166 | True 167 | go 168 | where 169 | go : Bool -> Builder Global' -> Either String (Builder Global') 170 | go = ifSame colour (\x => {colour := Right $ x}) 171 | (const $ const "Contradictory colour settings") 172 | 173 | asciiPart : Part (Builder Global') Bool 174 | asciiPart = inj $ MkOption 175 | (toList1 176 | [ MkMod (singleton "utf8") [] (Left False) 177 | "allow emojis in reports (default)" 178 | , MkMod (singleton "ascii") [] (Left True) 179 | "use only ascii in reports (unless there are some in your test file)" 180 | ]) 181 | False 182 | go 183 | where 184 | go : Bool -> Builder Global' -> Either String (Builder Global') 185 | go = ifSame ascii (\x => {ascii := Right $ x}) 186 | (const $ const "Contradictory ascii settings") 187 | 188 | export 189 | readDiffCommand : String -> DiffCommand 190 | readDiffCommand x = fromMaybe (Custom x) $ go $ toLower x 191 | where 192 | go : String -> Maybe DiffCommand 193 | go "none" = Just None 194 | go "native" = Just Native 195 | go "git" = Just GitDiff 196 | go "diff" = Just Diff 197 | go x = Nothing 198 | 199 | diffPart : Part (Builder Global') DiffCommand 200 | diffPart = inj $ MkOption 201 | (toList1 202 | [ MkMod (singleton "diff") ['d'] (Right parseDiff) 203 | #""" 204 | diff command use to display difference between the given and the golden one 205 | available values: (default : native) 206 | """# 207 | , MkMod (singleton "no-diff") [] (Left None) 208 | "remove all diff from the output, equivalent of `--diff none`" 209 | ]) 210 | Native 211 | compose 212 | where 213 | parseDiff : Value DiffCommand 214 | parseDiff = MkValue "CMD" (Just . readDiffCommand) 215 | compose : DiffCommand -> Builder Global' -> Either String (Builder Global') 216 | compose = one diff (\x => {diff := Right x}) 217 | (\x, y => "More than one diff command were given: \{show y}, \{show x}") 218 | 219 | export 220 | filesParamPart : Part (Builder Global') (List String) 221 | filesParamPart = inj $ MkParam "JSON_FILE(S)" (traverse checkNotOption) go 222 | where 223 | checkNotOption : String -> Maybe String 224 | checkNotOption x = guard (not $ "-" `isPrefixOf` x) $> x 225 | go : List String -> Builder Global' -> Either String (Builder Global') 226 | go = one files 227 | (\x => {files := Right x}) 228 | (\x, y => "More than one set of test files were given: \{show y}, \{show x}") 229 | 230 | 231 | export 232 | optParseGlobal : OptParse (Builder Global') Global 233 | optParseGlobal = 234 | [| MkGlobal 235 | (liftAp replicaDirPart) 236 | (liftAp goldenDirPart) 237 | (liftAp colourPart) 238 | (liftAp asciiPart) 239 | (liftAp logLevelPart) 240 | (liftAp diffPart) 241 | (liftAp filesParamPart) 242 | |] 243 | 244 | export 245 | defaultGlobal : Default Global' 246 | defaultGlobal = 247 | MkGlobal 248 | (defaultPart replicaDirPart) 249 | (defaultPart goldenDirPart) 250 | (defaultPart colourPart) 251 | (defaultPart asciiPart) 252 | (defaultPart logLevelPart) 253 | (defaultPart diffPart) 254 | (defaultPart filesParamPart) 255 | 256 | export 257 | globalOptionsHelp : List1 Help 258 | globalOptionsHelp = toList1 {ok = ?trustMe} 259 | $ runApM (\p => partHelp p) optParseGlobal 260 | 261 | export 262 | Alternative m => Semigroup (Global' m) where 263 | x <+> y = MkGlobal 264 | (x.replicaDir <|> y.replicaDir) 265 | (x.goldenDir <|> y.goldenDir) 266 | (x.colour <|> y.colour) 267 | (x.ascii <|> y.ascii) 268 | (x.logLevel <|> y.logLevel) 269 | (x.diff <|> y.diff) 270 | (x.files <|> y.files) 271 | 272 | export 273 | Alternative m => Monoid (Global' m) where 274 | neutral = MkGlobal empty empty empty empty empty empty empty 275 | -------------------------------------------------------------------------------- /src/Replica/Option/Parse.idr: -------------------------------------------------------------------------------- 1 | ||| JSON parser for tests 2 | module Replica.Option.Parse 3 | 4 | import Replica.Other.Validation 5 | import Replica.Other.Decorated 6 | import Replica.Option.Global 7 | 8 | import Control.Monad.Identity 9 | import Control.Monad.RWS 10 | import Data.Either 11 | import Data.List 12 | import Data.List1 13 | import Data.String 14 | import System 15 | import System.File 16 | import System.Path 17 | 18 | 19 | import Language.JSON 20 | 21 | validateReplicaDir : JSON -> Validation (List String) String 22 | validateReplicaDir (JString x) = Valid x 23 | validateReplicaDir x = Error ["Replica dir must be a string, found: \{show x}"] 24 | 25 | validateGoldenDir : JSON -> Validation (List String) String 26 | validateGoldenDir (JString x) = Valid x 27 | validateGoldenDir x = Error ["Goldendir must be a string, found: \{show x}"] 28 | 29 | validateColour : JSON -> Validation (List String) Bool 30 | validateColour (JBoolean x) = Valid x 31 | validateColour x = Error ["Colour must be a boolean, found: \{show x}"] 32 | 33 | validateAscii : JSON -> Validation (List String) Bool 34 | validateAscii (JBoolean x) = Valid x 35 | validateAscii x = Error ["Ascii must be a boolean, found: \{show x}"] 36 | 37 | invalidLogLevel : Validation (List String) a 38 | invalidLogLevel = Error ["LogLevel must be either none, debug, info, warning, or critical"] 39 | 40 | validateLogLevel : JSON -> Validation (List String) (Maybe LogLevel) 41 | validateLogLevel (JString x) = maybe invalidLogLevel Valid $ readLogLevel x 42 | validateLogLevel x = invalidLogLevel 43 | 44 | validateDiff : JSON -> Validation (List String) DiffCommand 45 | validateDiff (JString x) = Valid $ readDiffCommand x 46 | validateDiff x = Error ["Diff should be a string"] 47 | 48 | validateFile : JSON -> Validation (List String) String 49 | validateFile (JString x) = Valid x 50 | validateFile x = Error ["File should be a string"] 51 | 52 | export 53 | record ConfigValue where 54 | constructor CfgValue 55 | primary : String 56 | secondaries : List String 57 | parser : String -> Maybe JSON 58 | 59 | (.keys) : ConfigValue -> List1 String 60 | (.keys) x = x.primary ::: x.secondaries 61 | 62 | export 63 | checkKey : ConfigValue -> String -> Maybe String 64 | checkKey x y = guard (y `elem` forget x.keys) $> x.primary 65 | 66 | export 67 | getKey : ConfigValue -> (String, a) -> Maybe a 68 | getKey x (k, v) = guard (k `elem` forget x.keys) $> v 69 | 70 | export 71 | jsonFor: ConfigValue -> (String, String) -> Maybe (String, JSON) 72 | jsonFor x kv = getKey x kv >>= map (MkPair x.primary) . x.parser 73 | 74 | replicaDirValues : ConfigValue 75 | replicaDirValues = CfgValue "replicaDir" ["replica-dir", "rDir"] 76 | (Just . JString) 77 | 78 | goldenDirValues : ConfigValue 79 | goldenDirValues = CfgValue "goldenDir" ["golden-dir", "gDir"] 80 | (Just . JString) 81 | 82 | colourValues : ConfigValue 83 | colourValues = CfgValue "colour" ["color"] 84 | (\x => case toLower x of 85 | "true" => Just $ JBoolean True 86 | "false" => Just $ JBoolean False 87 | _ => Nothing) 88 | 89 | asciiValues : ConfigValue 90 | asciiValues = CfgValue "ascii" [] 91 | (\x => case toLower x of 92 | "true" => Just $ JBoolean True 93 | "false" => Just $ JBoolean False 94 | _ => Nothing) 95 | 96 | logValues : ConfigValue 97 | logValues = CfgValue "logLevel" ["log-level", "log"] 98 | (\x => readLogLevel x $> JString x) 99 | 100 | diffValues : ConfigValue 101 | diffValues = CfgValue "diff" [] 102 | (Just . JString) 103 | 104 | testFileValues : ConfigValue 105 | testFileValues= CfgValue "testFile" ["jsonFile", "test"] 106 | (Just . JString) 107 | 108 | export 109 | configValues : List ConfigValue 110 | configValues = 111 | [ replicaDirValues 112 | , goldenDirValues 113 | , colourValues 114 | , asciiValues 115 | , logValues 116 | , diffValues 117 | , testFileValues] 118 | 119 | jsonConfig : JSON -> Default Global' 120 | jsonConfig (JObject xs) = MkGlobal 121 | (foldMap (getKey replicaDirValues) xs >>= toMaybe . validateReplicaDir) 122 | (foldMap (getKey goldenDirValues) xs >>= map Just . toMaybe . validateGoldenDir) 123 | (foldMap (getKey colourValues) xs >>= toMaybe . validateColour) 124 | (foldMap (getKey asciiValues) xs >>= toMaybe . validateAscii) 125 | (foldMap (getKey logValues) xs >>= toMaybe . validateLogLevel) 126 | (foldMap (getKey diffValues) xs >>= toMaybe . validateDiff) 127 | (foldMap (getKey testFileValues) xs >>= toMaybe . map pure . validateFile) 128 | jsonConfig json = neutral 129 | 130 | export 131 | configPath : IO (List String) 132 | configPath = do 133 | Just global <- map ( ".replica.json") <$> getEnv "HOME" 134 | | Nothing => pure [".replica.json"] 135 | pure [global ".replica.json", ".replica.json"] 136 | 137 | export 138 | givenConfig : IO (Default Global') 139 | givenConfig = do 140 | path <- configPath 141 | xs <- catMaybes . map JSON.parse . rights <$> traverse readFile path 142 | pure $ concatMap jsonConfig xs 143 | -------------------------------------------------------------------------------- /src/Replica/Option/Types.idr: -------------------------------------------------------------------------------- 1 | ||| Define types for CLI options 2 | module Replica.Option.Types 3 | 4 | import Data.List 5 | import public Data.List1 6 | import public Data.List.AtIndex 7 | import Data.Maybe 8 | import Data.String 9 | import public Data.OpenUnion 10 | 11 | import Replica.Help 12 | import public Replica.Other.Free 13 | 14 | %default total 15 | 16 | 17 | export 18 | prefixLongOption : String -> String 19 | prefixLongOption = ("--" <+>) 20 | 21 | export 22 | prefixShortOption : Char -> String 23 | prefixShortOption x = pack ['-',x] 24 | 25 | public export 26 | record Value a where 27 | constructor MkValue 28 | name : String 29 | parser : String -> Maybe a 30 | 31 | export 32 | Functor Value where 33 | map func x = MkValue x.name (map func . x.parser) 34 | 35 | public export 36 | record Mod a where 37 | constructor MkMod 38 | longNames : List1 String 39 | shortNames : List Char 40 | param : Either a (Value a) 41 | description : String 42 | 43 | export 44 | Functor Mod where 45 | map func x = MkMod x.longNames x.shortNames 46 | (bimap func (map func) x.param) 47 | x.description 48 | 49 | public export 50 | record Option b a where 51 | constructor MkOption 52 | mods : List1 (Mod a) 53 | defaultValue : a 54 | setter : a -> b -> Either String b 55 | 56 | export 57 | embedOption : (c -> b) -> (b -> c -> c) -> Option b a -> Option c a 58 | embedOption f g x = MkOption x.mods x.defaultValue (embed f g x.setter) 59 | where 60 | embed : (c -> b) -> (b -> c -> c) -> (a -> b -> Either String b) -> a -> c -> Either String c 61 | embed unwrap wrap set p w = flip wrap w <$> set p (unwrap w) 62 | 63 | namespace Param 64 | 65 | public export 66 | record Param b a where 67 | constructor MkParam 68 | name : String 69 | parser : List String -> Maybe a 70 | setter : a -> b -> Either String b 71 | 72 | export 73 | MkParam1 : (name : String) -> (parser : String -> Maybe a) -> 74 | (setter : a -> b -> Either String b) -> 75 | Param b a 76 | MkParam1 name parser setter = MkParam name (go parser) setter 77 | where 78 | go : (String -> Maybe a) -> List String -> Maybe a 79 | go f [x] = f x 80 | go f _ = Nothing 81 | 82 | export 83 | embedParam : (c -> b) -> (b -> c -> c) -> Param b a -> Param c a 84 | embedParam f g x = MkParam x.name x.parser (embed f g x.setter) 85 | where 86 | embed : (c -> b) -> (b -> c -> c) -> (a -> b -> Either String b) -> a -> c -> Either String c 87 | embed unwrap wrap set p w = flip wrap w <$> set p (unwrap w) 88 | 89 | namespace Parts 90 | 91 | public export 92 | Part : Type -> Type -> Type 93 | Part b a = Union (\p => p b a) [Param, Option] 94 | 95 | export 96 | embedPart : (c -> b) -> (b -> c -> c) -> Part b a -> Part c a 97 | embedPart get set x = let 98 | Left x1 = decomp x 99 | | Right v => inj $ embedParam get set v 100 | v = decomp0 x1 101 | in inj $ embedOption get set v 102 | 103 | public export 104 | OptParse : Type -> Type -> Type 105 | OptParse = Ap . Part 106 | 107 | export 108 | embed : (c -> b) -> (b -> c -> c) -> OptParse b a -> OptParse c a 109 | embed get set (Pure x) = Pure x 110 | embed get set (MkAp x y) = MkAp (embedPart get set x) $ embed get set y 111 | 112 | namespace Parser 113 | 114 | Parser : (a : Type) -> Type 115 | Parser a = List String -> Maybe (List String, a) 116 | 117 | modParser : Mod a -> Parser a 118 | modParser m [] = Nothing 119 | modParser m (x::xs) = let 120 | validOption = map prefixLongOption (forget m.longNames) 121 | ++ map prefixShortOption m.shortNames 122 | in do 123 | guard $ x `elem` validOption 124 | let Right v = m.param 125 | | Left r => pure (xs, r) 126 | case xs of 127 | [] => Nothing 128 | (y::ys) => MkPair ys <$> v.parser y 129 | 130 | optionParser : Option b a -> Parser (b -> Either String b) 131 | optionParser x xs = map x.setter <$> choiceMap (flip modParser xs) x.mods 132 | 133 | partParser : Part b a -> Parser (b -> Either String b) 134 | partParser x xs = let 135 | Left x1 = decomp x 136 | | Right v => MkPair [] . v.setter <$> v.parser xs 137 | in optionParser (decomp0 x1) xs 138 | 139 | public export 140 | data ParseResult a 141 | -- = InvalidCommand (List1 String) 142 | = InvalidOption (Maybe Help) (List1 String) 143 | | InvalidMix String -- reason 144 | | Done a 145 | 146 | public export 147 | data ParsingFailure : ParseResult a -> Type where 148 | OptionFailure : ParsingFailure (InvalidOption help xs) 149 | MixFailure : ParsingFailure (InvalidMix reason) 150 | 151 | export 152 | Semigroup (ParseResult a) where 153 | Done x <+> _ = Done x 154 | _ <+> y = y 155 | 156 | export 157 | Functor ParseResult where 158 | map func (InvalidOption help xs) = InvalidOption help xs 159 | map func (InvalidMix reason) = InvalidMix reason 160 | map func (Done x) = Done (func x) 161 | 162 | export 163 | Applicative ParseResult where 164 | pure = Done 165 | InvalidOption h xs <*> _ = InvalidOption h xs 166 | InvalidMix reason <*> _ = InvalidMix reason 167 | Done f <*> InvalidOption h xs = InvalidOption h xs 168 | Done f <*> InvalidMix reason = InvalidMix reason 169 | Done f <*> Done x = Done $ f x 170 | 171 | export 172 | Monad ParseResult where 173 | InvalidOption h xs >>= f = InvalidOption h xs 174 | InvalidMix reason >>= f = InvalidMix reason 175 | Done x >>= f = f x 176 | 177 | export 178 | parse : 179 | Help -> 180 | a -> 181 | OptParse a b -> 182 | List String -> 183 | ParseResult a 184 | parse help acc o [] = Done acc 185 | parse help acc o (x::xs) = let 186 | Just (xs', f) = runApM (\p => partParser p (x::xs)) o 187 | | Nothing => case parse help acc o xs of 188 | InvalidOption h xs' => InvalidOption h $ x:::forget xs' 189 | _ => InvalidOption (pure help) $ singleton x 190 | in either 191 | InvalidMix 192 | (\acc' => parse help acc' o $ assert_smaller (x::xs) xs') 193 | (f acc) 194 | 195 | namespace Default 196 | 197 | defaultOption : Option b a -> Maybe a 198 | defaultOption = Just . defaultValue 199 | 200 | defaultParam : Param b a -> Maybe a 201 | defaultParam = const Nothing 202 | 203 | export 204 | defaultPart : Part b a -> Maybe a 205 | defaultPart x = let 206 | Left x1 = decomp x 207 | | Right v => defaultParam v 208 | v = decomp0 x1 209 | in defaultOption v 210 | 211 | namespace Help 212 | 213 | optionName : (long : List String) -> (short : List Char) -> 214 | (param : Either a (Value b)) -> String 215 | optionName long short param = 216 | either (flip const) (\v => (++ " \{v.name}")) param $ 217 | (concat $ intersperse ", " $ 218 | map ("--" ++) long ++ map (\c => pack ['-',c]) short) 219 | 220 | modHelp : Mod a -> Help 221 | modHelp x = MkHelp 222 | (optionName (forget x.longNames) x.shortNames x.param) 223 | Nothing 224 | x.description 225 | [] 226 | Nothing 227 | 228 | export 229 | partHelp : Part b a -> List Help 230 | partHelp x = let 231 | Left x1 = decomp x 232 | | Right v => [] 233 | v = decomp0 x1 234 | in map modHelp $ forget v.mods 235 | 236 | export 237 | commandHelp : 238 | (parents : List1 String) -> 239 | (name : String) -> (description : String) -> 240 | (options : OptParse b c) -> 241 | (param : Maybe String) -> Help 242 | commandHelp parents name description options param = MkHelp 243 | name 244 | (Just "\{unwords $ forget parents} \{name} [OPTIONS]\{paramExt param}") 245 | description 246 | ( catMaybes 247 | [ map (MkPair "Options") $ 248 | toList1' $ reverse $ runApM (\p => partHelp p) options 249 | ]) 250 | Nothing 251 | where 252 | paramExt : Maybe String -> String 253 | paramExt = maybe "" (" "<+>) 254 | -------------------------------------------------------------------------------- /src/Replica/Other/Decorated.idr: -------------------------------------------------------------------------------- 1 | module Replica.Other.Decorated 2 | 3 | import Replica.Option.Types 4 | import Replica.Other.Free 5 | 6 | 7 | %default total 8 | 9 | public export 10 | Builder : (ty : (Type -> Type) -> Type) -> Type 11 | Builder ty = ty (\a => Either (Maybe a) a) 12 | 13 | 14 | public export 15 | Default : (ty : (Type -> Type) -> Type) -> Type 16 | Default ty = ty Maybe 17 | 18 | public export 19 | Done : (ty : (Type -> Type) -> Type) -> Type 20 | Done ty = ty id 21 | 22 | public export 23 | interface TyMap (0 ty : (Type -> Type) -> Type) where 24 | tyMap : (forall x. f x -> g x) -> ty f -> ty g 25 | 26 | public export 27 | interface TyTraversable (0 ty : (Type -> Type) -> Type) where 28 | tyTraverse : Applicative g => (forall a. f a -> g a) -> ty f -> g (Done ty) 29 | 30 | export 31 | initBuilder : TyMap ty => Default ty -> Builder ty 32 | initBuilder = tyMap Left 33 | 34 | export 35 | build : TyTraversable ty => Builder ty -> Maybe (Done ty) 36 | build = tyTraverse (either id Just) 37 | 38 | export 39 | one : (get : b -> Either c a) -> (set : a -> b -> b) -> (errMsg : a -> a -> err) -> 40 | a -> b -> Either err b 41 | one get set errMsg x y = case get y of 42 | Left _ => Right $ set x y 43 | Right z => Left $ errMsg x z 44 | 45 | export 46 | ifSame : Eq a => 47 | (get : b -> Either c a) -> (set : a -> b -> b) -> (errMsg : a -> a -> err) -> 48 | a -> b -> Either err b 49 | ifSame get set errMsg x y = case get y of 50 | Left _ => Right $ set x y 51 | Right z => if x /= z 52 | then Left $ errMsg x z 53 | else Right y 54 | 55 | export 56 | first : (get : b -> Either c a) -> (set : a -> b -> b) -> a -> b -> b 57 | first get set x y = case get y of 58 | Left _ => set x y 59 | Right _ => y 60 | -------------------------------------------------------------------------------- /src/Replica/Other/Free.idr: -------------------------------------------------------------------------------- 1 | ||| Free applicative 2 | module Replica.Other.Free 3 | 4 | %default total 5 | 6 | public export 7 | data Ap : (Type -> Type) -> Type -> Type where 8 | Pure : a -> Ap f a 9 | MkAp : f a -> Ap f (a -> b) -> Ap f b 10 | 11 | export 12 | Functor (Ap f) where 13 | map func (Pure x) = Pure (func x) 14 | map func (MkAp x y) = MkAp x (map (func .) y) 15 | 16 | export 17 | Applicative (Ap f) where 18 | pure = Pure 19 | (<*>) (Pure y) x = map y x 20 | (<*>) e@(MkAp y z) x = MkAp y $ assert_smaller e (map flip z) <*> x 21 | 22 | export 23 | runAp : Applicative g => (forall x. f x -> g x) -> Ap f c -> g c 24 | runAp func (Pure x) = pure x 25 | runAp func (MkAp x y) = runAp func y <*> func x 26 | 27 | export 28 | runApM : Monoid m => (forall x. f x -> m) -> Ap f c -> m 29 | runApM func (Pure x) = neutral 30 | runApM func (MkAp x y) = runApM func y <+> func x 31 | 32 | export 33 | runApM' : Monoid m => (forall x. f x -> m) -> Ap f c -> m 34 | runApM' func (Pure x) = neutral 35 | runApM' func (MkAp x y) = func x <+> runApM func y 36 | 37 | export 38 | liftAp : f a -> Ap f a 39 | liftAp x = MkAp x (Pure id) 40 | -------------------------------------------------------------------------------- /src/Replica/Other/String.idr: -------------------------------------------------------------------------------- 1 | ||| Some utils for string manipulation 2 | module Replica.Other.String 3 | 4 | import Data.List 5 | import Data.String 6 | import Data.String.Extra 7 | 8 | %default total 9 | 10 | export 11 | separator : Nat -> String 12 | separator = pack . flip replicate '-' 13 | 14 | export 15 | withOffset : Nat -> String -> String 16 | withOffset k = (++) (pack $ replicate k ' ') 17 | 18 | export 19 | removeTrailingNL : String -> String 20 | removeTrailingNL str = if "\n" `isSuffixOf` str then dropLast 1 str else str 21 | -------------------------------------------------------------------------------- /src/Replica/Other/Validation.idr: -------------------------------------------------------------------------------- 1 | ||| `Validation` an either applicative that accumulates error 2 | module Replica.Other.Validation 3 | 4 | %default total 5 | 6 | public export 7 | data Validation : (err, a : Type) -> Type where 8 | Valid : (x : a) -> Validation err a 9 | Error : (e : err) -> Validation err a 10 | 11 | export 12 | Functor (Validation err) where 13 | map f (Valid x) = Valid $ f x 14 | map f (Error x) = Error x 15 | 16 | export 17 | (Semigroup err) => Applicative (Validation err) where 18 | pure = Valid 19 | (Valid f) <*> (Valid x) = Valid $ f x 20 | (Valid _) <*> (Error e) = Error e 21 | (Error e) <*> (Valid x) = Error e 22 | (Error e1) <*> (Error e2) = Error $ e1 <+> e2 23 | 24 | export 25 | (Monoid err) => Alternative (Validation err) where 26 | empty = Error neutral 27 | (<|>) (Valid x) y = Valid x 28 | (<|>) (Error e) (Valid y) = Valid y 29 | (<|>) (Error e) (Error r) = Error $ e <+> r 30 | 31 | export 32 | fromEither : Applicative f => Either err a -> Validation (f err) a 33 | fromEither = either (Error . pure) Valid 34 | 35 | export 36 | toMaybe : Validation _ a -> Maybe a 37 | toMaybe (Valid x) = Just x 38 | toMaybe (Error e) = Nothing 39 | -------------------------------------------------------------------------------- /tests/Meta/Help.dhall: -------------------------------------------------------------------------------- 1 | \(parameters : List Text) -> 2 | ./toTest.dhall 3 | ( ./default.dhall 4 | // { command = "help", parameters, testFiles = [] : List Text } 5 | ) 6 | -------------------------------------------------------------------------------- /tests/Meta/Info.dhall: -------------------------------------------------------------------------------- 1 | \(parameters : List Text) -> 2 | \(testFiles : List Text) -> 3 | ./toTest.dhall 4 | (./default.dhall // { command = "info", parameters, testFiles }) 5 | -------------------------------------------------------------------------------- /tests/Meta/Run.dhall: -------------------------------------------------------------------------------- 1 | \(parameters : List Text) -> 2 | \(testFiles : List Text) -> 3 | ./toTest.dhall (./default.dhall // { parameters, testFiles }) 4 | -------------------------------------------------------------------------------- /tests/Meta/Type.dhall: -------------------------------------------------------------------------------- 1 | { executable : Text 2 | , command : Text 3 | , parameters : List Text 4 | , testFiles : List Text 5 | } 6 | -------------------------------------------------------------------------------- /tests/Meta/default.dhall: -------------------------------------------------------------------------------- 1 | { executable = "${env:PWD as Text}/build/exec/replica" ? "replica" 2 | , command = "run -D" 3 | , parameters = [] : List Text 4 | , testFiles = [] : List Text 5 | } 6 | : ./Type.dhall 7 | -------------------------------------------------------------------------------- /tests/Meta/package.dhall: -------------------------------------------------------------------------------- 1 | { Type = ./Type.dhall 2 | , default = ./default.dhall 3 | , toTest = ./toTest.dhall 4 | , Run = ./Run.dhall 5 | , Info = ./Info.dhall 6 | , Help = ./Help.dhall 7 | } 8 | -------------------------------------------------------------------------------- /tests/Meta/toCommand.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:e89a5d8a50bf5551f1012d7c627ab6d1fd278148a7341682247b2e024fcf90d4 5 | 6 | let Command = Replica.Command 7 | 8 | let toCommand 9 | : ./Type.dhall -> Command.Type 10 | = \(repl : ./Type.dhall) -> 11 | { executable = repl.executable 12 | , parameters = [ repl.command ] # repl.parameters # repl.testFiles 13 | } 14 | 15 | in toCommand 16 | -------------------------------------------------------------------------------- /tests/Meta/toTest.dhall: -------------------------------------------------------------------------------- 1 | let toCommand = ./toCommand.dhall 2 | 3 | let Replica = ./Type.dhall 4 | 5 | let ReplicaDhall = 6 | env:REPLICA_DHALL 7 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 8 | sha256:e89a5d8a50bf5551f1012d7c627ab6d1fd278148a7341682247b2e024fcf90d4 9 | 10 | let Test = ReplicaDhall.Test 11 | 12 | let Command/show = ReplicaDhall.Command.show 13 | 14 | in \(repl : Replica) -> Test::{ command = Command/show (toCommand repl) } 15 | -------------------------------------------------------------------------------- /tests/basic/run.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | true 3 | -------------------------------------------------------------------------------- /tests/help.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:e89a5d8a50bf5551f1012d7c627ab6d1fd278148a7341682247b2e024fcf90d4 5 | 6 | let Prelude = Replica.Prelude 7 | 8 | let Test = Replica.Test 9 | 10 | let Status = Replica.Status 11 | 12 | let Expectation = Replica.Expectation 13 | 14 | let Meta = ./Meta/package.dhall 15 | 16 | let help = 17 | (Meta.Help ([] : List Text)) 18 | with description = Some "Display a help of all available commands" 19 | with stdOut = Expectation::{ 20 | , contains = 21 | [ "replica help" 22 | , " run" 23 | , " test" 24 | , " info" 25 | , " set" 26 | , " new" 27 | , " version" 28 | ] 29 | } 30 | 31 | let helpRun = 32 | (Meta.Help ([ "run" ] : List Text)) 33 | with description = Some "Help on run command display the right command" 34 | with stdOut = Expectation::{ contains = [ "replica run" ] } 35 | 36 | let helpTest = 37 | (Meta.Help ([ "test" ] : List Text)) 38 | with description = Some "Help on test command display the right command" 39 | with stdOut = Expectation::{ contains = [ "replica test", "Alias" ] } 40 | 41 | let helpNew = 42 | (Meta.Help ([ "new" ] : List Text)) 43 | with description = Some "Help on new command display the right command" 44 | with stdOut = Expectation::{ 45 | , contains = [ "replica new", "dhall", "json" ] 46 | } 47 | 48 | let helpInfo = 49 | (Meta.Help ([ "info" ] : List Text)) 50 | with description = Some "Display a help of all available info topics" 51 | with stdOut = Expectation::{ 52 | , contains = [ "replica info", " test", " suite" ] 53 | } 54 | 55 | let helpInfoSuite = 56 | (Meta.Help ([ "info", "suite" ] : List Text)) 57 | with description = Some "Display a help dedicated to the 'suite' topic" 58 | with stdOut = Expectation::{ contains = [ "replica info suite" ] } 59 | 60 | let helpInfoTest = 61 | (Meta.Help ([ "info", "test" ] : List Text)) 62 | with description = Some "Display a help dedicated to the 'test' topic" 63 | with stdOut = Expectation::{ contains = [ "replica info test" ] } 64 | 65 | let tests 66 | : Replica.Type 67 | = Replica.Suite 68 | "help" 69 | ( toMap 70 | { help 71 | , helpRun 72 | , helpTest 73 | , helpNew 74 | , helpInfo 75 | , helpInfoSuite 76 | , helpInfoTest 77 | } 78 | ) 79 | 80 | in tests 81 | -------------------------------------------------------------------------------- /tests/idris.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:e89a5d8a50bf5551f1012d7c627ab6d1fd278148a7341682247b2e024fcf90d4 5 | 6 | let Idris = 7 | Replica.Command.Idris 8 | with default.executable = "${env:PWD as Text}/build/exec/replica" 9 | 10 | let Context = Idris.Context 11 | 12 | let tests 13 | : Replica.Type 14 | = Replica.Suite 15 | "idris" 16 | ( toMap 17 | { typecheckPackage = 18 | (Idris.Typecheck "test.ipkg") 19 | with workingDir = Some "tests/idris/package" 20 | with description = Some "Typecheck a package" 21 | with tags = [ "idris", "typecheck" ] 22 | , packageREPL = 23 | (Idris.REPL (Context.Package "test.ipkg")) 24 | with workingDir = Some "tests/idris/package" 25 | with description = Some "REPL session with a package" 26 | with input = Some 27 | '' 28 | :module Test 29 | aString 30 | :q 31 | '' 32 | with tags = [ "idris", "repl" ] 33 | , fileREPL = 34 | ( Idris.REPL 35 | ( Context.File 36 | { dependencies = [] : List Text, name = "Test.idr" } 37 | ) 38 | ) 39 | with workingDir = Some "tests/idris/file" 40 | with description = Some "REPL session with a file" 41 | with input = Some 42 | '' 43 | aString 44 | :q 45 | '' 46 | with tags = [ "idris", "repl" ] 47 | , rawREPL = 48 | (Idris.REPL (Context.Raw ([] : List Text))) 49 | with description = Some "REPL session without context" 50 | with input = Some 51 | '' 52 | Just "work!" 53 | :q 54 | '' 55 | with tags = [ "idris", "repl" ] 56 | } 57 | ) 58 | 59 | in tests 60 | -------------------------------------------------------------------------------- /tests/idris/file/Test.idr: -------------------------------------------------------------------------------- 1 | module Test 2 | 3 | aString : String 4 | aString = "Hello, World!" 5 | -------------------------------------------------------------------------------- /tests/idris/package/Test.idr: -------------------------------------------------------------------------------- 1 | module Test 2 | 3 | export 4 | aString : String 5 | aString = "Hello, World!" 6 | -------------------------------------------------------------------------------- /tests/idris/package/test.ipkg: -------------------------------------------------------------------------------- 1 | package test 2 | 3 | modules = Test 4 | -------------------------------------------------------------------------------- /tests/parsing_errors.dhall: -------------------------------------------------------------------------------- 1 | let Meta = ./Meta/package.dhall 2 | 3 | let Replica = 4 | env:REPLICA_DHALL 5 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 6 | sha256:e89a5d8a50bf5551f1012d7c627ab6d1fd278148a7341682247b2e024fcf90d4 7 | 8 | let Status = Replica.Status 9 | 10 | let tests 11 | : Replica.Type 12 | = Replica.Suite 13 | "parsing" 14 | ( toMap 15 | { unknown_command = 16 | ( Meta.toTest 17 | Meta::{ command = "tagada", testFiles = [ "tests.json" ] } 18 | ) 19 | with description = Some 20 | "Unknown commands are rejected, showing help" 21 | with stdErr = Replica.Expectation.Golden 22 | with status = Status.Exactly 253 23 | with tags = [ "meta", "parser" ] 24 | , unknown_parameter = 25 | (Meta.Run [ "--oops" ] [ "tests.json" ]) 26 | with description = Some 27 | "If a parameter doesn't exist, display an error message and the help" 28 | with workingDir = Some "tests/replica/two" 29 | with stdErr = Replica.Expectation.Golden 30 | with status = Status.Exactly 253 31 | with tags = [ "meta", "parser" ] 32 | , opposite_include_exclude = 33 | (Meta.Run [ "--only one", "--exclude one" ] [ "tests.json" ]) 34 | with description = Some 35 | "If a test is both included and rejected, the command fails" 36 | with workingDir = Some "tests/replica/two" 37 | with stdErr = Replica.Expectation.Golden 38 | with status = Status.Exactly 252 39 | with tags = [ "meta", "parser" ] 40 | , opposite_include_exclude_tags = 41 | ( Meta.Run 42 | [ "--tags shiny", "--exclude-tags shiny" ] 43 | [ "tests.json" ] 44 | ) 45 | with workingDir = Some "tests/replica/two" 46 | with description = Some 47 | "If a tag is both included and rejected, the command fails" 48 | with stdErr = Replica.Expectation.Golden 49 | with status = Status.Exactly 252 50 | with tags = [ "meta", "parser" ] 51 | } 52 | ) 53 | 54 | in tests 55 | -------------------------------------------------------------------------------- /tests/replica/allButOne/.replica/test/theChosen/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/allButOne/.replica/test/theChosen/expected -------------------------------------------------------------------------------- /tests/replica/allButOne/.replica/test/theChosen/output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/allButOne/.replica/test/theChosen/output -------------------------------------------------------------------------------- /tests/replica/allButOne/.replica/test/unfortunate1/output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/allButOne/.replica/test/unfortunate1/output -------------------------------------------------------------------------------- /tests/replica/allButOne/.replica/test/unfortunate2/output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/allButOne/.replica/test/unfortunate2/output -------------------------------------------------------------------------------- /tests/replica/allButOne/.replica/test/unfortunate3/output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/allButOne/.replica/test/unfortunate3/output -------------------------------------------------------------------------------- /tests/replica/allButOne/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Success = Replica.Status.Success 9 | 10 | in { unfortunate1 = Test::{ command = "false" } with status = Success 11 | , unfortunate2 = Test::{ command = "false" } with status = Success 12 | , unfortunate3 = Test::{ command = "false" } with status = Success 13 | , theChosen = Test::{ command = "true" } with status = Success 14 | } 15 | -------------------------------------------------------------------------------- /tests/replica/beforeFailed/.replica/test/later/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/beforeFailed/.replica/test/later/expected -------------------------------------------------------------------------------- /tests/replica/beforeFailed/.replica/test/later/output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/beforeFailed/.replica/test/later/output -------------------------------------------------------------------------------- /tests/replica/beforeFailed/getOut/includeMe.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/beforeFailed/getOut/includeMe.txt -------------------------------------------------------------------------------- /tests/replica/beforeFailed/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Success = Replica.Status.Success 9 | 10 | in { before = Test::{ 11 | , beforeTest = [ "oops" ] 12 | , command = "true" 13 | , workingDir = Some "getOut" 14 | } 15 | , later = Test::{ command = "true", workingDir = Some "getOut" } 16 | } 17 | -------------------------------------------------------------------------------- /tests/replica/empty/tests.dhall: -------------------------------------------------------------------------------- 1 | {=} 2 | -------------------------------------------------------------------------------- /tests/replica/end_fail/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | 5 | let Prelude = Replica.Prelude 6 | 7 | let Test = Replica.Test 8 | 9 | let Status = Replica.Status 10 | 11 | let Expectation = Replica.Expectation 12 | 13 | let end_failure = 14 | Test.Success::{ 15 | , command = "echo \"Hello, World!\"" 16 | , description = Some "Wrong end expectation" 17 | , spaceSensitive = False 18 | , stdOut = Expectation::{ end = Some "Warld!" } 19 | } 20 | 21 | let tests 22 | : Replica.Type 23 | = toMap { end_failure } 24 | 25 | in tests 26 | -------------------------------------------------------------------------------- /tests/replica/goldenDir/.replica/test/mismatch/expected: -------------------------------------------------------------------------------- 1 | two 2 | -------------------------------------------------------------------------------- /tests/replica/goldenDir/.replica/test/mismatch/output: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/goldenDir/.replica/test/valid/output: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/goldenDir/golden/valid/expected: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/goldenDir/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | in { valid = 9 | Test::{ command = "echo \"one\"" } 10 | with description = Some "Simple expectations" 11 | } 12 | -------------------------------------------------------------------------------- /tests/replica/goldenDirFile/.replica/test/mismatch/expected: -------------------------------------------------------------------------------- 1 | two 2 | -------------------------------------------------------------------------------- /tests/replica/goldenDirFile/.replica/test/mismatch/output: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/goldenDirFile/.replica/test/valid/output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/goldenDirFile/.replica/test/valid/output -------------------------------------------------------------------------------- /tests/replica/goldenDirFile/golden/valid/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/goldenDirFile/golden/valid/expected -------------------------------------------------------------------------------- /tests/replica/goldenDirFile/golden/valid/file: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/goldenDirFile/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | in { valid = 9 | Test.Success::{ command = "echo \"one\" > one.txt" } 10 | with outputFile = Some "one.txt" 11 | with afterTest = [ "rm one.txt" ] 12 | with description = Some "Expectation of a file on a custom directory" 13 | } 14 | -------------------------------------------------------------------------------- /tests/replica/inlineMismatch/.replica/test/mismatch/output: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/inlineMismatch/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Expectation = Replica.Expectation 9 | 10 | in { mismatch = 11 | Test::{ command = "echo \"one\"" } 12 | with description = Some "Expectation is different than one" 13 | with stdOut = 14 | Expectation.Exact 15 | '' 16 | two 17 | '' 18 | } 19 | -------------------------------------------------------------------------------- /tests/replica/localConfig/.replica.json: -------------------------------------------------------------------------------- 1 | { "goldenDir": "golden" 2 | } 3 | -------------------------------------------------------------------------------- /tests/replica/localConfig/.replica/test/mismatch/expected: -------------------------------------------------------------------------------- 1 | two 2 | -------------------------------------------------------------------------------- /tests/replica/localConfig/golden/valid/expected: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/localConfig/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Success = Replica.Status.Success 9 | 10 | in { valid = 11 | Test::{ command = "echo \"one\"" } 12 | with description = Some "Simple expectations" 13 | } 14 | -------------------------------------------------------------------------------- /tests/replica/mismatch/.replica/test/mismatch/expected: -------------------------------------------------------------------------------- 1 | two 2 | -------------------------------------------------------------------------------- /tests/replica/mismatch/.replica/test/mismatch/output: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/mismatch/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Success = Replica.Status.Success 9 | 10 | in { mismatch = 11 | Test::{ command = "echo \"one\"" } 12 | with description = Some "Expectation is different than one" 13 | } 14 | -------------------------------------------------------------------------------- /tests/replica/multi/.replica/test/one/expected: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/multi/.replica/test/two/expected: -------------------------------------------------------------------------------- 1 | two 2 | -------------------------------------------------------------------------------- /tests/replica/multi/tests1.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | in { one = Test::{ command = "echo \"one\"" } } 9 | -------------------------------------------------------------------------------- /tests/replica/multi/tests2.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | in { two = Test::{ command = "echo \"two\"" } } 9 | -------------------------------------------------------------------------------- /tests/replica/multi/testsDup.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Success = Replica.Status.Success 9 | 10 | in { one = Test::{ command = "echo \"one\"" } } 11 | -------------------------------------------------------------------------------- /tests/replica/new/.keepit: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/new/.keepit -------------------------------------------------------------------------------- /tests/replica/onePending/.replica/test/two/expected: -------------------------------------------------------------------------------- 1 | two 2 | -------------------------------------------------------------------------------- /tests/replica/onePending/.replica/test/two/output: -------------------------------------------------------------------------------- 1 | two 2 | -------------------------------------------------------------------------------- /tests/replica/onePending/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Success = Replica.Status.Success 9 | 10 | in { one = Test::{ command = "echo \"one\"" } with pending = True 11 | , two = Test::{ command = "echo \"two\"" } 12 | } 13 | -------------------------------------------------------------------------------- /tests/replica/orderedPartialFail/.replica/test/ordered_partial_expectation_mismatch/output: -------------------------------------------------------------------------------- 1 | Hello, World! 2 | -------------------------------------------------------------------------------- /tests/replica/orderedPartialFail/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Expectation = Replica.Expectation 9 | 10 | in { ordered_partial_expectation_mismatch = 11 | Test.Success::{ command = "echo \"Hello, World!\"" } 12 | with description = Some "check an ordered partial expectation that fails" 13 | with stdOut = Expectation.Consecutive [ "World", "Hello" ] 14 | } 15 | -------------------------------------------------------------------------------- /tests/replica/require1/.replica/test/depends_failed/expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/require1/.replica/test/depends_failed/expected -------------------------------------------------------------------------------- /tests/replica/require1/.replica/test/depends_failed/output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/require1/.replica/test/depends_failed/output -------------------------------------------------------------------------------- /tests/replica/require1/.replica/test/root_failed/output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ReplicaTest/REPLica/182ad0f86550bd8b9d725d0495a9c9fd20cca310/tests/replica/require1/.replica/test/root_failed/output -------------------------------------------------------------------------------- /tests/replica/require1/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Success = Replica.Status.Success 9 | 10 | let tests = 11 | { root_failed = Test::{ command = "false" } with succeed = Success 12 | , depends_failed = 13 | Test::{ command = "true" } 14 | with require = [ "root_failed" ] 15 | with succeed = Success 16 | } 17 | 18 | in tests 19 | -------------------------------------------------------------------------------- /tests/replica/start_fail/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | 5 | let Prelude = Replica.Prelude 6 | 7 | let Test = Replica.Test 8 | 9 | let Status = Replica.Status 10 | 11 | let Expectation = Replica.Expectation 12 | 13 | let start_fail = 14 | Test.Success::{ 15 | , command = "echo \"Hello, World!\"" 16 | , description = Some "Start fails" 17 | , stdOut = Expectation::{ start = Some "Hella" } 18 | } 19 | 20 | let tests 21 | : Replica.Type 22 | = toMap { start_fail } 23 | 24 | in tests 25 | -------------------------------------------------------------------------------- /tests/replica/suite/crossSuiteDependency.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Status = Replica.Status 9 | 10 | let Expectation = Replica.Expectation 11 | 12 | let tests 13 | : Replica.Type 14 | = toMap 15 | { oneA = Test.Success::{ 16 | , command = "true" 17 | , suite = Some "A" 18 | , require = [ "oneB" ] 19 | , stdOut = Expectation.Skipped 20 | } 21 | , oneB = Test.Success::{ 22 | , command = "true" 23 | , suite = Some "B" 24 | , require = [ "secondA" ] 25 | , stdOut = Expectation.Skipped 26 | } 27 | , secondA = Test.Success::{ 28 | , command = "true" 29 | , suite = Some "A" 30 | , stdOut = Expectation.Skipped 31 | } 32 | } 33 | 34 | in tests 35 | -------------------------------------------------------------------------------- /tests/replica/suite/simpleDisplay.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let Status = Replica.Status 9 | 10 | let Expectation = Replica.Expectation 11 | 12 | let tests 13 | : Replica.Type 14 | = toMap 15 | { oneA = Test.Success::{ 16 | , command = "true" 17 | , suite = Some "A" 18 | , stdOut = Expectation.Skipped 19 | } 20 | , oneB = Test.Success::{ 21 | , command = "true" 22 | , suite = Some "B" 23 | , stdOut = Expectation.Skipped 24 | } 25 | , secondA = Test.Success::{ 26 | , command = "true" 27 | , suite = Some "A" 28 | , stdOut = Expectation.Skipped 29 | } 30 | } 31 | 32 | in tests 33 | -------------------------------------------------------------------------------- /tests/replica/tooManyError/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | let to_129 = Replica.Prelude.Natural.enumerate 129 9 | 10 | let tests 11 | : Replica.Type 12 | = Replica.Prelude.List.map 13 | Natural 14 | (Replica.Prelude.Map.Entry Text Replica.Test.Type) 15 | ( \(n : Natural) -> 16 | { mapKey = "test" ++ Replica.Prelude.Natural.show n 17 | , mapValue = Test::{ command = "false" } 18 | } 19 | ) 20 | to_129 21 | 22 | in tests 23 | -------------------------------------------------------------------------------- /tests/replica/two/.replica/test/one/expected: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/two/.replica/test/one/output: -------------------------------------------------------------------------------- 1 | one 2 | -------------------------------------------------------------------------------- /tests/replica/two/.replica/test/two/expected: -------------------------------------------------------------------------------- 1 | two 2 | -------------------------------------------------------------------------------- /tests/replica/two/.replica/test/two/output: -------------------------------------------------------------------------------- 1 | two 2 | -------------------------------------------------------------------------------- /tests/replica/two/tests.dhall: -------------------------------------------------------------------------------- 1 | let Replica = 2 | env:REPLICA_DHALL 3 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 4 | sha256:b11ac5d5195183145bbff03ba7b99e98b4e1bce32c725af5bedf01b4b328a741 5 | 6 | let Test = Replica.Test 7 | 8 | in { one = Test::{ command = "echo \"one\"" } 9 | , two = Test::{ command = "echo \"two\"", tags = [ "shiny" ] } 10 | } 11 | -------------------------------------------------------------------------------- /tests/suite.dhall: -------------------------------------------------------------------------------- 1 | let Meta = ./Meta/package.dhall 2 | 3 | let Replica = 4 | env:REPLICA_DHALL 5 | ? https://raw.githubusercontent.com/ReplicaTest/replica-dhall/main/package.dhall 6 | sha256:e89a5d8a50bf5551f1012d7c627ab6d1fd278148a7341682247b2e024fcf90d4 7 | 8 | let tests 9 | : Replica.Type 10 | = toMap 11 | { simpleDisplay = 12 | (Meta.Run ([] : List Text) [ "simpleDisplay.json" ]) 13 | with workingDir = Some "tests/replica/suite" 14 | with description = Some "tests are ran by suite" 15 | with tags = [ "suite" ] 16 | , crossSuiteDependency = 17 | (Meta.Run ([] : List Text) [ "crossSuiteDependency.json" ]) 18 | with workingDir = Some "tests/replica/suite" 19 | with description = Some "require can work on different suites" 20 | with tags = [ "suite" ] 21 | with suite = Some "ordering" 22 | , includeSuite = 23 | (Meta.Run ([ "-s A" ] : List Text) [ "crossSuiteDependency.json" ]) 24 | with workingDir = Some "tests/replica/suite" 25 | with description = Some "can select only a given suite" 26 | with tags = [ "suite" ] 27 | with suite = Some "filter" 28 | , excludeSuite = 29 | (Meta.Run ([ "-S A" ] : List Text) [ "crossSuiteDependency.json" ]) 30 | with workingDir = Some "tests/replica/suite" 31 | with description = Some "can exclude a give suite" 32 | with tags = [ "suite" ] 33 | with suite = Some "filter" 34 | } 35 | 36 | in tests 37 | -------------------------------------------------------------------------------- /utils/.gitignore: -------------------------------------------------------------------------------- 1 | # replica .gitignore template 2 | 3 | # ignore the whole replica internal mess (except golden values) 4 | .replica/log 5 | .replica/test/*/output 6 | .replica/test/*/status 7 | .replica/test/*/error 8 | -------------------------------------------------------------------------------- /utils/Makefile: -------------------------------------------------------------------------------- 1 | # with this rule if x.dhall exists but not x.json, and x.json is a target 2 | .dhall.json: 3 | dhall-to-json --file $? --output $@ 4 | 5 | ## Example usage 6 | test: mytests.json 7 | replica run mytests.json 8 | 9 | # Do not forget to clean the json file on clean 10 | clean: 11 | ${RM} mytests.json 12 | -------------------------------------------------------------------------------- /utils/README.md: -------------------------------------------------------------------------------- 1 | # replica utils 2 | 3 | This directory contains various files that can ease the integration of replica 4 | in your project. 5 | 6 | - [`_replica`](./_replica) zsh completion for replica. 7 | In your `.zshrc`` 8 | 1. Add the location of `_replica` to `$fpath` 9 | 2. If not added yet, add: 10 | 11 | ```shell 12 | autoload -U compinit 13 | compinit 14 | ``` 15 | 16 | - [`.gitignore`](./.gitignore) provides the baseline to ignore replica internals 17 | in your gi project. 18 | - [`Makefile`](./Makefile) provides a target for dhall to json transformation. 19 | -------------------------------------------------------------------------------- /utils/_replica: -------------------------------------------------------------------------------- 1 | #compdef replica 2 | typeset -A opt_args 3 | 4 | # local -a sub 5 | # sub=('info:get information about test suites' 'run:run test suite' 'new:create a test suite' 'help:get some help' 'version:show replica version' 'config:set replica default config') 6 | # _describe 'command' sub 7 | 8 | _arguments -C \ 9 | '1:command:->cmds' \ 10 | '*:: :->args' \ 11 | && ret=0 12 | 13 | local commands common 14 | 15 | commands=( 16 | 'run:run test suite' 17 | 'info:get information about test suites' 18 | 'new:create a test suite' 19 | 'set:set replica default config' 20 | 'help:get some help' 21 | 'version:show replica version' 22 | ) 23 | 24 | common=( 25 | '(-N --exclude)'{-n,--only}'[tests to run]:comma separated list' \ 26 | '(-n --only)'{-N,--exclude}'[tests to exclude]:comma separated list' \ 27 | {-t,-tags,--only-tags}'[tags to run]:comma separated list' \ 28 | {-T,--exclude-tags}'[tags to include]:comma separated list' \ 29 | {--last-fails,-l}'[select only failing tests]' \ 30 | '(-v --verbose)--log[log level]:log:(none critical warning info debug)' \ 31 | {-v,--verbose}'[verbose output (log info)]' 32 | '--replica-dir[replica store directory]:replica dir:_files -/' \ 33 | '--golden-dir[golden values directory]:golden dir:_files -/' \ 34 | '(--no-color --no-colour)'{--color,--colour,-c}'[use coloured ouput]' \ 35 | '(--color --colour -c)'{--no-color,--no-colour}'[desactivate coloured ouput]' \ 36 | '(--ascii)--utf8[use emojis in reports]' \ 37 | "(--utf8)--ascii[reports don't use emojis]" \ 38 | '(--diff)--no-diff[dont show diff on errors]' \ 39 | '(--no-diff)--diff[define a diff command]:either a known or a custom command:(git diff native)' 40 | ) 41 | 42 | case "$state" in 43 | (cmds) 44 | _describe -V -t commands 'command' commands && ret=0 45 | ;; 46 | (args) 47 | case $line[1] in 48 | (info) 49 | _arguments \ 50 | {-e,--expectations}'[show expectations for each test]' \ 51 | $common \ 52 | '(-)*:tests files:_files' \ 53 | && ret=0 54 | ;; 55 | (run) 56 | _arguments \ 57 | {--threads,-x}'[Number of threads to run the tests]' \ 58 | {--punitive,-p}'[Stop on first error]' \ 59 | $common \ 60 | '(-)*:tests files:_files -g *.json' \ 61 | && ret=0 62 | ;; 63 | (new) 64 | _arguments \ 65 | '--format[type of the file to be created]:file format:(json dhall)' \ 66 | + sample \ 67 | '(noSample)'{-s,--includeSample}'[sample test included]:sample' \ 68 | + noSample \ 69 | '(sample)'{-S,--noSample}'[no sample test included]:no sample' \ 70 | '(-):created file:_files' \ 71 | && ret=0 72 | ;; 73 | (set) 74 | _arguments \ 75 | '*'{-l,--local}'[Set local config value]:key=value pair:->kv' \ 76 | '*'{-g,--global}'[Set global config value]:key=value pair:->kv' \ 77 | && ret=0 78 | case "$state" in 79 | (kv) 80 | _values 'replica configuration' \ 81 | 'replicaDir:replica file location:_files' \ 82 | 'goldenDir:golden values location:_files' \ 83 | 'colour:coloured output:(true false)' \ 84 | 'ascii:use only ascii in reports:(false true)' \ 85 | 'diff:tool used to print diff' \ 86 | 'log:specify a log level:(none critical warning info debug)' \ 87 | 'testFile:name of the file to test:_files' \ 88 | && ret=0 89 | esac 90 | ;; 91 | (help) 92 | _arguments -C ':topic:->topic' 93 | case "$state" in 94 | (topic) 95 | _describe -V -t topic 'topic' commands && ret=0 96 | esac 97 | ;; 98 | (version) 99 | ret=0 100 | ;; 101 | esac 102 | ;; 103 | esac 104 | 105 | return 1 106 | -------------------------------------------------------------------------------- /version.nix: -------------------------------------------------------------------------------- 1 | "0.6.0" 2 | --------------------------------------------------------------------------------