├── .github └── workflows │ ├── ci.yml │ ├── docs.yml │ └── nix-ci.yml ├── .gitignore ├── .readthedocs.yaml ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── agda2hs.cabal ├── cabal.project ├── docs ├── Makefile ├── make.bat ├── requirements.txt └── source │ ├── conf.py │ ├── features.md │ ├── index.md │ ├── introduction.md │ └── tutorials.md ├── flake.lock ├── flake.nix ├── lib ├── base │ ├── Haskell │ │ ├── Control │ │ │ ├── Exception.agda │ │ │ └── Monad.agda │ │ ├── Data │ │ │ ├── List.agda │ │ │ ├── Maybe.agda │ │ │ └── Ord.agda │ │ ├── Extra │ │ │ ├── Dec.agda │ │ │ ├── Delay.agda │ │ │ ├── Erase.agda │ │ │ ├── Refinement.agda │ │ │ └── Sigma.agda │ │ ├── Law.agda │ │ ├── Law │ │ │ ├── Applicative.agda │ │ │ ├── Applicative │ │ │ │ ├── Def.agda │ │ │ │ ├── Either.agda │ │ │ │ ├── IO.agda │ │ │ │ ├── List.agda │ │ │ │ └── Maybe.agda │ │ │ ├── Bool.agda │ │ │ ├── Def.agda │ │ │ ├── Either.agda │ │ │ ├── Eq.agda │ │ │ ├── Eq │ │ │ │ ├── Def.agda │ │ │ │ └── Instances.agda │ │ │ ├── Equality.agda │ │ │ ├── Function.agda │ │ │ ├── Functor.agda │ │ │ ├── Functor │ │ │ │ ├── Def.agda │ │ │ │ ├── Either.agda │ │ │ │ ├── IO.agda │ │ │ │ ├── List.agda │ │ │ │ └── Maybe.agda │ │ │ ├── Int.agda │ │ │ ├── Integer.agda │ │ │ ├── List.agda │ │ │ ├── Maybe.agda │ │ │ ├── Monad.agda │ │ │ ├── Monad │ │ │ │ ├── Def.agda │ │ │ │ ├── Either.agda │ │ │ │ ├── IO.agda │ │ │ │ ├── List.agda │ │ │ │ └── Maybe.agda │ │ │ ├── Monoid.agda │ │ │ ├── Monoid │ │ │ │ ├── Def.agda │ │ │ │ ├── List.agda │ │ │ │ └── Maybe.agda │ │ │ ├── Nat.agda │ │ │ ├── Num.agda │ │ │ ├── Num │ │ │ │ ├── Def.agda │ │ │ │ ├── Int.agda │ │ │ │ ├── Integer.agda │ │ │ │ ├── Nat.agda │ │ │ │ └── Word.agda │ │ │ ├── Ord.agda │ │ │ ├── Ord │ │ │ │ ├── Bool.agda │ │ │ │ ├── Def.agda │ │ │ │ ├── Maybe.agda │ │ │ │ └── Ordering.agda │ │ │ └── Semigroup │ │ │ │ ├── Def.agda │ │ │ │ ├── Either.agda │ │ │ │ ├── List.agda │ │ │ │ └── Maybe.agda │ │ ├── Prelude.agda │ │ ├── Prim.agda │ │ └── Prim │ │ │ ├── Absurd.agda │ │ │ ├── Applicative.agda │ │ │ ├── Bool.agda │ │ │ ├── Bounded.agda │ │ │ ├── Char.agda │ │ │ ├── Double.agda │ │ │ ├── Either.agda │ │ │ ├── Enum.agda │ │ │ ├── Eq.agda │ │ │ ├── Foldable.agda │ │ │ ├── Functor.agda │ │ │ ├── IO.agda │ │ │ ├── Int.agda │ │ │ ├── Integer.agda │ │ │ ├── List.agda │ │ │ ├── Maybe.agda │ │ │ ├── Monad.agda │ │ │ ├── Monoid.agda │ │ │ ├── Num.agda │ │ │ ├── Ord.agda │ │ │ ├── Show.agda │ │ │ ├── Strict.agda │ │ │ ├── String.agda │ │ │ ├── Thunk.agda │ │ │ ├── Traversable.agda │ │ │ ├── Tuple.agda │ │ │ └── Word.agda │ └── base.agda-lib └── containers │ ├── CHANGELOG.md │ ├── README.md │ ├── agda │ ├── Data │ │ ├── Map.agda │ │ ├── Map │ │ │ ├── Maybe.agda │ │ │ └── Prop.agda │ │ ├── Set.agda │ │ └── Set │ │ │ └── Prop.agda │ ├── Haskell │ │ └── Data │ │ │ ├── Map.agda │ │ │ └── Set.agda │ ├── Test │ │ └── Agda2Hs │ │ │ └── Data │ │ │ ├── Map.agda │ │ │ └── Set.agda │ └── containers.agda │ ├── agda2hs-libraries │ ├── containers-prop.cabal │ ├── containers.agda-lib │ └── generate-haskell.sh ├── nix ├── agda2hs.nix ├── default.nix ├── lib.nix └── shell.nix ├── release-notes ├── 1.0.md ├── 1.1.md └── 1.2.md ├── rewrite-rules-example.yaml ├── src ├── Agda2Hs │ ├── AgdaUtils.hs │ ├── Compile.hs │ ├── Compile │ │ ├── ClassInstance.hs │ │ ├── Data.hs │ │ ├── Function.hs │ │ ├── Function.hs-boot │ │ ├── Imports.hs │ │ ├── Name.hs │ │ ├── Postulate.hs │ │ ├── Record.hs │ │ ├── Term.hs │ │ ├── Type.hs │ │ ├── TypeDefinition.hs │ │ ├── Types.hs │ │ ├── Utils.hs │ │ └── Var.hs │ ├── Config.hs │ ├── Language │ │ ├── Haskell.hs │ │ └── Haskell │ │ │ └── Utils.hs │ ├── Pragma.hs │ └── Render.hs ├── AgdaInternals.hs └── Main.hs ├── test ├── .gitignore ├── Agda.css ├── AllCubicalTests.agda ├── AllFailTests.agda ├── AllTests.agda ├── Assert.agda ├── AutoLambdaCaseInBind.agda ├── AutoLambdaCaseInCase.agda ├── BangPatterns.agda ├── CanonicalInstance.agda ├── Coerce.agda ├── Coinduction.agda ├── CommonQualifiedImports.agda ├── ConstrainedInstance.agda ├── Cubical │ └── StreamFusion.agda ├── CustomTuples.agda ├── Datatypes.agda ├── Default.agda ├── DefaultMethods.agda ├── Delay.agda ├── Deriving.agda ├── DoNotation.agda ├── EraseType.agda ├── ErasedLocalDefinitions.agda ├── ErasedPatternLambda.agda ├── ErasedTypeArguments.agda ├── Fail │ ├── ClashingImport.agda │ ├── Copatterns.agda │ ├── DerivingParseFailure.agda │ ├── ErasedRecordParameter.agda │ ├── ExplicitInstance.agda │ ├── ExplicitInstance2.agda │ ├── Fixities.agda │ ├── Inline.agda │ ├── Inline2.agda │ ├── InvalidName.agda │ ├── Issue113a.agda │ ├── Issue113b.agda │ ├── Issue119.agda │ ├── Issue125.agda │ ├── Issue142.agda │ ├── Issue146.agda │ ├── Issue150.agda │ ├── Issue154.agda │ ├── Issue169-record.agda │ ├── Issue185.agda │ ├── Issue223.agda │ ├── Issue357a.agda │ ├── Issue357b.agda │ ├── Issue71.agda │ ├── MatchOnDelay.agda │ ├── MultiArgumentPatternLambda.agda │ ├── NewTypeRecordTwoFields.agda │ ├── NewTypeTwoConstructors.agda │ ├── NewTypeTwoFields.agda │ ├── NonCanonicalSpecialFunction.agda │ ├── NonCanonicalSuperclass.agda │ ├── NonCopatternInstance.agda │ ├── NonStarDatatypeIndex.agda │ ├── NonStarRecordIndex.agda │ ├── PartialCase.agda │ ├── PartialCaseNoLambda.agda │ ├── PartialIf.agda │ ├── QualifiedRecordProjections.agda │ └── TypeLambda.agda ├── Fixities.agda ├── FunCon.agda ├── Haskell │ └── Data │ │ └── ByteString.agda ├── HeightMirror.agda ├── IOFile.agda ├── IOInput.agda ├── Importee.agda ├── Importer.agda ├── Inlining.agda ├── Issue107.agda ├── Issue115.agda ├── Issue14.agda ├── Issue145.agda ├── Issue169.agda ├── Issue200.agda ├── Issue210.agda ├── Issue218.agda ├── Issue251.agda ├── Issue257.agda ├── Issue264.agda ├── Issue273.agda ├── Issue286.agda ├── Issue301.agda ├── Issue302.agda ├── Issue305.agda ├── Issue308.agda ├── Issue309.agda ├── Issue317.agda ├── Issue324.agda ├── Issue324instance.agda ├── Issue353.agda ├── Issue377.agda ├── Issue394.agda ├── Issue65.agda ├── Issue69.agda ├── Issue73.agda ├── Issue90.agda ├── Issue92.agda ├── Issue93.agda ├── Issue94.agda ├── Kinds.agda ├── LanguageConstructs.agda ├── LawfulOrd.agda ├── LiteralPatterns.agda ├── Makefile ├── ModuleParameters.agda ├── ModuleParametersImports.agda ├── NewTypePragma.agda ├── NonClassInstance.agda ├── Numbers.agda ├── OtherImportee.agda ├── Pragmas.agda ├── ProjLike.agda ├── ProjectionLike.agda ├── QualifiedImportee.agda ├── QualifiedImports.agda ├── QualifiedModule.agda ├── QualifiedPrelude.agda ├── RankNTypes.agda ├── Records.agda ├── RequalifiedImports.agda ├── ScopedTypeVariables.agda ├── SecondImportee.agda ├── Sections.agda ├── Superclass.agda ├── Test.agda ├── TransparentFun.agda ├── Tree.agda ├── Tuples.agda ├── TypeBasedUnboxing.agda ├── TypeDirected.agda ├── TypeOperatorExport.agda ├── TypeOperatorImport.agda ├── TypeOperators.agda ├── TypeSignature.agda ├── TypeSynonyms.agda ├── UnboxPragma.agda ├── Vector.agda ├── Where.agda ├── WitnessedFlows.agda ├── agda2hs-test.agda-lib ├── golden │ ├── AllCubicalTests.hs │ ├── AllTests.hs │ ├── Assert.hs │ ├── AutoLambdaCaseInBind.hs │ ├── AutoLambdaCaseInCase.hs │ ├── BangPatterns.hs │ ├── CanonicalInstance.hs │ ├── ClashingImport.err │ ├── Coerce.hs │ ├── Coinduction.hs │ ├── CommonQualifiedImports.hs │ ├── ConstrainedInstance.hs │ ├── Copatterns.err │ ├── Cubical │ │ └── StreamFusion.hs │ ├── CustomTuples.hs │ ├── Datatypes.hs │ ├── Default.hs │ ├── DefaultMethods.hs │ ├── Delay.hs │ ├── Deriving.hs │ ├── DerivingParseFailure.err │ ├── DoNotation.hs │ ├── EraseType.hs │ ├── ErasedLocalDefinitions.hs │ ├── ErasedPatternLambda.hs │ ├── ErasedRecordParameter.err │ ├── ErasedTypeArguments.hs │ ├── ExplicitInstance.err │ ├── ExplicitInstance2.err │ ├── Fixities.err │ ├── Fixities.hs │ ├── FunCon.hs │ ├── HeightMirror.hs │ ├── IOFile.hs │ ├── IOInput.hs │ ├── Importee.hs │ ├── Importer.hs │ ├── Inline.err │ ├── Inline2.err │ ├── Inlining.hs │ ├── InvalidName.err │ ├── Issue113a.err │ ├── Issue113b.err │ ├── Issue115.hs │ ├── Issue119.err │ ├── Issue125.err │ ├── Issue14.hs │ ├── Issue142.err │ ├── Issue145.hs │ ├── Issue146.err │ ├── Issue150.err │ ├── Issue154.err │ ├── Issue169-record.err │ ├── Issue169.hs │ ├── Issue185.err │ ├── Issue200.hs │ ├── Issue210.hs │ ├── Issue218.hs │ ├── Issue223.err │ ├── Issue251.hs │ ├── Issue264.hs │ ├── Issue273.hs │ ├── Issue286.hs │ ├── Issue301.hs │ ├── Issue302.hs │ ├── Issue305.hs │ ├── Issue308.hs │ ├── Issue309.hs │ ├── Issue317.hs │ ├── Issue324.hs │ ├── Issue324instance.hs │ ├── Issue353.hs │ ├── Issue357a.err │ ├── Issue357b.err │ ├── Issue377.hs │ ├── Issue394.hs │ ├── Issue65.hs │ ├── Issue69.hs │ ├── Issue71.err │ ├── Issue73.hs │ ├── Issue90.hs │ ├── Issue92.hs │ ├── Issue93.hs │ ├── Issue94.hs │ ├── Kinds.hs │ ├── LanguageConstructs.hs │ ├── LawfulOrd.hs │ ├── LiteralPatterns.hs │ ├── MatchOnDelay.err │ ├── ModuleParameters.hs │ ├── ModuleParametersImports.hs │ ├── MultiArgumentPatternLambda.err │ ├── NewTypePragma.hs │ ├── NewTypeRecordTwoFields.err │ ├── NewTypeTwoConstructors.err │ ├── NewTypeTwoFields.err │ ├── NonCanonicalSpecialFunction.err │ ├── NonCanonicalSuperclass.err │ ├── NonClassInstance.hs │ ├── NonCopatternInstance.err │ ├── NonStarDatatypeIndex.err │ ├── NonStarRecordIndex.err │ ├── Numbers.hs │ ├── OtherImportee.hs │ ├── PartialCase.err │ ├── PartialCaseNoLambda.err │ ├── PartialIf.err │ ├── Pragmas.hs │ ├── ProjLike.hs │ ├── ProjectionLike.hs │ ├── QualifiedImportee.hs │ ├── QualifiedImports.hs │ ├── QualifiedModule.hs │ ├── QualifiedPrelude.hs │ ├── QualifiedRecordProjections.err │ ├── RankNTypes.hs │ ├── Records.hs │ ├── RequalifiedImports.hs │ ├── ScopedTypeVariables.hs │ ├── SecondImportee.hs │ ├── Sections.hs │ ├── Superclass.hs │ ├── Test.hs │ ├── TransparentFun.hs │ ├── Tree.hs │ ├── Tuples.hs │ ├── TypeBasedUnboxing.hs │ ├── TypeDirected.hs │ ├── TypeLambda.err │ ├── TypeOperatorExport.hs │ ├── TypeOperatorImport.hs │ ├── TypeOperators.hs │ ├── TypeSignature.hs │ ├── TypeSynonyms.hs │ ├── UnboxPragma.hs │ ├── Vector.hs │ ├── Where.hs │ └── WitnessedFlows.hs └── renderTranslations.sh └── tutorials ├── example-basics ├── HelloWorld.agda ├── HelloWorld.hs └── example-basics.agda-lib ├── example-proofs ├── Ascending.agda ├── Triangle.agda └── example-proofs.agda-lib └── example-structure ├── example-structure.agda-lib ├── script.sh └── src ├── agda ├── Definition.agda └── Usage.agda └── haskell ├── Definition.hs └── Usage.hs /.github/workflows/docs.yml: -------------------------------------------------------------------------------- 1 | # Simple workflow for deploying static content to GitHub Pages 2 | name: Docs 3 | 4 | on: 5 | # Runs on pushes targeting the default branch 6 | push: 7 | branches: [master] 8 | 9 | # Allows you to run this workflow manually from the Actions tab 10 | workflow_dispatch: 11 | 12 | # Allow one concurrent deployment 13 | concurrency: 14 | group: "pages" 15 | cancel-in-progress: true 16 | 17 | jobs: 18 | # Single deploy job since we're just deploying 19 | deploy: 20 | strategy: 21 | matrix: 22 | python-version: ["3.10.8"] 23 | 24 | env: 25 | DOCS_DIR: docs 26 | DOCS_BUILD_DIR: docs/build 27 | DOCS_BUILD_HTML_DIR: docs/build/html 28 | 29 | runs-on: ubuntu-latest 30 | steps: 31 | - name: Checkout 32 | uses: actions/checkout@v3 33 | - name: Set up Python ${{ matrix.python-version }} 34 | uses: actions/setup-python@v4 35 | with: 36 | python-version: ${{ matrix.python-version }} 37 | - name: Install dependencies 38 | run: | 39 | pip install -r ${{ env.DOCS_DIR }}/requirements.txt 40 | - name: Build User Manual in HTML 41 | run: | 42 | cd ${{ env.DOCS_DIR }} 43 | make html 44 | - name: Deploy to GitHub Pages 45 | uses: peaceiris/actions-gh-pages@v3 46 | with: 47 | github_token: ${{ secrets.GITHUB_TOKEN }} 48 | publish_dir: ${{ env.DOCS_BUILD_HTML_DIR }} 49 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Haskell 2 | _build 3 | dist 4 | dist-newstyle 5 | *~ 6 | html/ 7 | docs/build/ 8 | *.hi 9 | *.o 10 | 11 | # Agda 12 | *.agdai 13 | 14 | # For nix users 15 | .direnv/** 16 | .envrc 17 | result 18 | -------------------------------------------------------------------------------- /.readthedocs.yaml: -------------------------------------------------------------------------------- 1 | version: 1 2 | 3 | build: 4 | tools: 5 | python: "3.8.10" 6 | 7 | # Build from the docs/ directory with Sphinx 8 | sphinx: 9 | configuration: docs/source/conf.py 10 | 11 | # Explicitly set the version of Python and its requirements 12 | python: 13 | install: 14 | - requirements: docs/requirements.txt -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2024 Ulf Norell, Jesper Cockx, Orestis Melkonian, Sára Juhošová, James Chapman, Lucas Escot, Henry Blanchette, Viktor Csimma, Aleksander Wolska, Paul Bittner, Andreas Källberg, Bohdan Liesnikov, and Jakob Naucke. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY : install agda repl libHtml test testContainers testHtml golden docs 2 | FILES = $(shell find src -type f) 3 | 4 | install : 5 | cabal install --overwrite-policy=always 6 | 7 | agda : 8 | cabal install Agda --program-suffix=-erased --overwrite-policy=always 9 | 10 | repl : 11 | cabal repl # e.g. `:set args -itest -otest/build test/AllTests.agda ... main ... :r ... main` 12 | 13 | libHtml : 14 | cabal run agda2hs -- --html --include-path lib/base lib/base/Haskell/Prelude.agda 15 | cp html/Haskell.Prelude.html html/index.html 16 | 17 | test/agda2hs : $(FILES) 18 | cabal install agda2hs --overwrite-policy=always --installdir=test --install-method=copy 19 | 20 | testContainers: 21 | cd ./lib/containers && ./generate-haskell.sh && cabal build containers-prop 22 | 23 | test : test/agda2hs testContainers 24 | make -C test 25 | 26 | testHtml : test/agda2hs 27 | make -C test html 28 | 29 | golden : 30 | make -C test golden 31 | 32 | docs : 33 | make -C docs html 34 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./agda2hs.cabal 3 | ./lib/containers/containers-prop.cabal 4 | 5 | constraints: Agda +debug 6 | -------------------------------------------------------------------------------- /docs/Makefile: -------------------------------------------------------------------------------- 1 | # Minimal makefile for Sphinx documentation 2 | # 3 | 4 | # You can set these variables from the command line, and also 5 | # from the environment for the first two. 6 | SPHINXOPTS ?= 7 | SPHINXBUILD ?= sphinx-build 8 | SOURCEDIR = source 9 | BUILDDIR = build 10 | 11 | # Put it first so that "make" without argument is like "make help". 12 | help: 13 | @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 14 | 15 | .PHONY: help Makefile 16 | 17 | # Catch-all target: route all unknown targets to Sphinx using the new 18 | # "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). 19 | %: Makefile 20 | @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 21 | -------------------------------------------------------------------------------- /docs/make.bat: -------------------------------------------------------------------------------- 1 | @ECHO OFF 2 | 3 | pushd %~dp0 4 | 5 | REM Command file for Sphinx documentation 6 | 7 | if "%SPHINXBUILD%" == "" ( 8 | set SPHINXBUILD=sphinx-build 9 | ) 10 | set SOURCEDIR=source 11 | set BUILDDIR=build 12 | 13 | %SPHINXBUILD% >NUL 2>NUL 14 | if errorlevel 9009 ( 15 | echo. 16 | echo.The 'sphinx-build' command was not found. Make sure you have Sphinx 17 | echo.installed, then set the SPHINXBUILD environment variable to point 18 | echo.to the full path of the 'sphinx-build' executable. Alternatively you 19 | echo.may add the Sphinx directory to PATH. 20 | echo. 21 | echo.If you don't have Sphinx installed, grab it from 22 | echo.https://www.sphinx-doc.org/ 23 | exit /b 1 24 | ) 25 | 26 | if "%1" == "" goto help 27 | 28 | %SPHINXBUILD% -M %1 %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% %O% 29 | goto end 30 | 31 | :help 32 | %SPHINXBUILD% -M help %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% %O% 33 | 34 | :end 35 | popd 36 | -------------------------------------------------------------------------------- /docs/requirements.txt: -------------------------------------------------------------------------------- 1 | sphinx==5.3.0 2 | sphinx_rtd_theme==1.1.1 3 | readthedocs-sphinx-search==0.1.2 4 | myst_parser==0.18.1 -------------------------------------------------------------------------------- /docs/source/conf.py: -------------------------------------------------------------------------------- 1 | # Configuration file for the Sphinx documentation builder. 2 | # 3 | # For the full list of built-in configuration values, see the documentation: 4 | # https://www.sphinx-doc.org/en/master/usage/configuration.html 5 | 6 | # -- Project information ------------------------------------------------------- 7 | # https://www.sphinx-doc.org/en/master/usage/configuration.html#project-information 8 | 9 | project = "agda2hs" 10 | copyright = "2022, Jexper Cockx, Orestis Melkonian, Lucas Escot, James Chapman, Ulf Norell" 11 | author = "Jexper Cockx, Orestis Melkonian, Lucas Escot, James Chapman, Ulf Norell, Henry Blanchette" 12 | 13 | # -- General configuration ----------------------------------------------------- 14 | # https://www.sphinx-doc.org/en/master/usage/configuration.html#general-configuration 15 | 16 | # extensions = ["myst_parser", "sphinx_rtd_theme", "rtds_action"] 17 | extensions = ["myst_parser", "sphinx_rtd_theme"] 18 | 19 | templates_path = ["_templates"] 20 | exclude_patterns = [] 21 | 22 | # -- Options for HTML output --------------------------------------------------- 23 | # https://www.sphinx-doc.org/en/master/usage/configuration.html#options-for-html-output 24 | 25 | html_theme = "sphinx_rtd_theme" 26 | html_static_path = ["_static"] 27 | 28 | # ==[ OLD ]== 29 | # # -- Build docs ---------------------------------------------------------------- 30 | # # https://github.com/dfm/rtds-action 31 | 32 | # rtds_action_github_repo = "USERNAME/REPONAME" 33 | # rtds_action_path = "rtds_action_path" 34 | # rtds_action_artifact_prefix = "notebooks-for-" 35 | # rtds_action_github_token = os.environ["GITHUB_TOKEN"] 36 | # rtds_action_error_if_missing = True 37 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1726560853, 9 | "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1726757509, 24 | "narHash": "sha256-3/2rV78QyC/OPu+WzimbElmSdD3HsQq/P/TLcFQHjZQ=", 25 | "owner": "NixOS", 26 | "repo": "nixpkgs", 27 | "rev": "78fdf431cdf6bc4ba4af9c100aaeda65da7e4ed3", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "NixOS", 32 | "repo": "nixpkgs", 33 | "type": "github" 34 | } 35 | }, 36 | "root": { 37 | "inputs": { 38 | "flake-utils": "flake-utils", 39 | "nixpkgs": "nixpkgs" 40 | } 41 | }, 42 | "systems": { 43 | "locked": { 44 | "lastModified": 1681028828, 45 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 46 | "owner": "nix-systems", 47 | "repo": "default", 48 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 49 | "type": "github" 50 | }, 51 | "original": { 52 | "owner": "nix-systems", 53 | "repo": "default", 54 | "type": "github" 55 | } 56 | } 57 | }, 58 | "root": "root", 59 | "version": 7 60 | } 61 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Agda2hs"; 3 | 4 | inputs.nixpkgs.url = "github:NixOS/nixpkgs"; 5 | inputs.flake-utils.url = "github:numtide/flake-utils"; 6 | 7 | outputs = 8 | { 9 | self, 10 | nixpkgs, 11 | flake-utils, 12 | }: 13 | flake-utils.lib.eachDefaultSystem ( 14 | system: 15 | let 16 | pkgs = import nixpkgs { inherit system; }; 17 | packages = import ./nix/default.nix { inherit pkgs; }; 18 | lib = import ./nix/lib.nix { inherit pkgs; }; 19 | in 20 | { 21 | packages = packages // { 22 | default = packages.agda2hs; 23 | }; 24 | inherit lib; 25 | devShells.default = import ./nix/shell.nix { 26 | inherit pkgs; 27 | inherit (lib) agda2hs-hs; 28 | }; 29 | } 30 | ); 31 | } 32 | -------------------------------------------------------------------------------- /lib/base/Haskell/Control/Exception.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Control.Exception where 2 | 3 | open import Haskell.Prim 4 | 5 | open import Haskell.Extra.Dec 6 | open import Haskell.Extra.Refinement 7 | 8 | assert : (@0 b : Type ℓ) → {{Dec b}} → (@0 {{b}} → a) → a 9 | assert _ {{True ⟨ p ⟩}} x = x {{p}} 10 | assert _ {{False ⟨ _ ⟩}} x = oops 11 | where postulate oops : _ 12 | -------------------------------------------------------------------------------- /lib/base/Haskell/Control/Monad.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Control.Monad where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Bool 5 | open import Haskell.Prim.Monad 6 | open import Haskell.Prim.String 7 | open import Haskell.Extra.Erase 8 | 9 | guard : {{ MonadFail m }} → (b : Bool) → m (Erase (b ≡ True)) 10 | guard True = return (Erased refl) 11 | guard False = fail "Guard was not True" 12 | -------------------------------------------------------------------------------- /lib/base/Haskell/Data/Maybe.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Data.Maybe where 2 | 3 | open import Haskell.Prelude 4 | 5 | isJust : Maybe a → Bool 6 | isJust Nothing = False 7 | isJust (Just _) = True 8 | 9 | isNothing : Maybe a → Bool 10 | isNothing Nothing = True 11 | isNothing (Just _) = False 12 | 13 | fromJust : (x : Maybe a) → @0 {IsJust x} → a 14 | fromJust Nothing = error "fromJust Nothing" 15 | fromJust (Just x) = x 16 | 17 | fromMaybe : {a : Type} → a → Maybe a → a 18 | fromMaybe d Nothing = d 19 | fromMaybe _ (Just x) = x 20 | 21 | listToMaybe : List a → Maybe a 22 | listToMaybe [] = Nothing 23 | listToMaybe (x ∷ _) = Just x 24 | 25 | maybeToList : Maybe a → List a 26 | maybeToList Nothing = [] 27 | maybeToList (Just x) = x ∷ [] 28 | 29 | mapMaybe : (a → Maybe b) → List a → List b 30 | mapMaybe f [] = [] 31 | mapMaybe f (x ∷ xs) = maybe id _∷_ (f x) (mapMaybe f xs) 32 | 33 | catMaybes : List (Maybe a) → List a 34 | catMaybes = mapMaybe id 35 | -------------------------------------------------------------------------------- /lib/base/Haskell/Data/Ord.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Data.Ord where 2 | 3 | open import Haskell.Prelude 4 | 5 | comparing : ⦃ Ord a ⦄ → (b → a) → b → b → Ordering 6 | comparing p x y = compare (p x) (p y) 7 | 8 | clamp : ⦃ Ord a ⦄ → (a × a) → a → a 9 | clamp (low , high) a = min high (max a low) 10 | -------------------------------------------------------------------------------- /lib/base/Haskell/Extra/Delay.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --sized-types #-} 2 | 3 | module Haskell.Extra.Delay where 4 | 5 | open import Agda.Builtin.Size public 6 | 7 | open import Haskell.Prelude 8 | 9 | open import Haskell.Data.Maybe 10 | open import Haskell.Extra.Refinement 11 | open import Haskell.Prim.Thunk 12 | 13 | private variable 14 | x y z : a 15 | @0 i : Size 16 | 17 | data Delay (a : Type) (@0 i : Size) : Type where 18 | now : a → Delay a i 19 | later : Thunk (Delay a) i → Delay a i 20 | 21 | data HasResult (x : a) : Delay a i → Type where 22 | now : HasResult x (now x) 23 | later : HasResult x (y .force) → HasResult x (later y) 24 | 25 | runDelay : {@0 x : a} (y : Delay a ∞) → @0 HasResult x y → a 26 | runDelay (now x) now = x 27 | runDelay (later y) (later p) = runDelay (y .force) p 28 | 29 | runDelaySound : {@0 x : a} (y : Delay a ∞) → (@0 hr : HasResult x y) → runDelay y hr ≡ x 30 | runDelaySound (now x) now = refl 31 | runDelaySound (later y) (later hr) = runDelaySound (y .force) hr 32 | 33 | -- tryDelay and unDelay cannot and should not be compiled to Haskell, 34 | -- so they are marked as erased. 35 | @0 tryDelay : (y : Delay a ∞) → Nat → Maybe (∃ a (λ x → HasResult x y)) 36 | tryDelay (now x) _ = Just (x ⟨ now ⟩) 37 | tryDelay (later y) zero = Nothing 38 | tryDelay (later y) (suc n) = fmap (mapRefine later) (tryDelay (y .force) n) 39 | 40 | @0 unDelay : (y : Delay a ∞) (n : Nat) → @0 {IsJust (tryDelay y n)} → a 41 | unDelay y n {p} = fromJust (tryDelay y n) {p} .value 42 | -------------------------------------------------------------------------------- /lib/base/Haskell/Extra/Refinement.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Extra.Refinement where 2 | 3 | open import Haskell.Prelude 4 | open import Agda.Primitive 5 | 6 | private variable 7 | ℓ ℓ′ : Level 8 | 9 | record ∃ (a : Type ℓ) (@0 P : a → Type ℓ′) : Type (ℓ ⊔ ℓ′) where 10 | constructor _⟨_⟩ 11 | field 12 | value : a 13 | @0 proof : P value 14 | open ∃ public 15 | {-# COMPILE AGDA2HS ∃ unboxed #-} 16 | 17 | mapRefine : {@0 P Q : a → Type ℓ} (@0 f : ∀ {x} → P x → Q x) → ∃ a P → ∃ a Q 18 | mapRefine f (x ⟨ p ⟩) = x ⟨ f p ⟩ 19 | 20 | {-# COMPILE AGDA2HS mapRefine transparent #-} 21 | 22 | refineMaybe : {@0 P : a → Type ℓ} 23 | → (mx : Maybe a) → @0 (∀ {x} → mx ≡ Just x → P x) 24 | → Maybe (∃ a P) 25 | refineMaybe Nothing f = Nothing 26 | refineMaybe (Just x) f = Just (x ⟨ f refl ⟩) 27 | 28 | {-# COMPILE AGDA2HS refineMaybe transparent #-} 29 | -------------------------------------------------------------------------------- /lib/base/Haskell/Extra/Sigma.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Extra.Sigma where 2 | 3 | open import Haskell.Prelude 4 | 5 | record Σ (a : Type) (b : @0 a → Type) : Type where 6 | constructor _,_ 7 | field 8 | fst : a 9 | snd : b fst 10 | open Σ public 11 | {-# COMPILE AGDA2HS Σ tuple #-} 12 | 13 | infix 2 Σ-syntax 14 | 15 | Σ-syntax : (a : Type) → (@0 a → Type) → Type 16 | Σ-syntax = Σ 17 | {-# COMPILE AGDA2HS Σ-syntax inline #-} 18 | 19 | syntax Σ-syntax a (λ x → b) = Σ[ x ∈ a ] b 20 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Bool 5 | 6 | open import Haskell.Law.Def public 7 | open import Haskell.Law.Applicative public 8 | open import Haskell.Law.Bool public 9 | open import Haskell.Law.Either public 10 | open import Haskell.Law.Eq public 11 | open import Haskell.Law.Equality public 12 | open import Haskell.Law.Functor public 13 | open import Haskell.Law.Int public 14 | open import Haskell.Law.Integer public 15 | open import Haskell.Law.List public 16 | open import Haskell.Law.Maybe public 17 | open import Haskell.Law.Monad public 18 | open import Haskell.Law.Monoid public 19 | open import Haskell.Law.Nat public 20 | open import Haskell.Law.Ord public 21 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Applicative.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Applicative where 2 | 3 | open import Haskell.Law.Applicative.Def public 4 | open import Haskell.Law.Applicative.Either public 5 | open import Haskell.Law.Applicative.IO public 6 | open import Haskell.Law.Applicative.List public 7 | open import Haskell.Law.Applicative.Maybe public 8 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Applicative/Def.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Applicative.Def where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Functor 5 | 6 | open import Haskell.Prim.Applicative 7 | open import Haskell.Prim.Monoid 8 | open import Haskell.Prim.Tuple 9 | 10 | open import Haskell.Law.Functor 11 | 12 | record IsLawfulApplicative (F : Type → Type) ⦃ iAppF : Applicative F ⦄ : Type₁ where 13 | field 14 | overlap ⦃ super ⦄ : IsLawfulFunctor F 15 | 16 | -- Identity: pure id <*> v = v 17 | identity : (v : F a) → (pure id <*> v) ≡ v 18 | 19 | -- Composition: pure (.) <*> u <*> v <*> w = u <*> (v <*> w) 20 | composition : {a b c : Type} → (u : F (b → c)) (v : F (a → b)) (w : F a) 21 | → (pure _∘_ <*> u <*> v <*> w) ≡ (u <*> (v <*> w)) 22 | 23 | -- Homomorphism: pure f <*> pure x = pure (f x) 24 | homomorphism : {a b : Type} → (f : a → b) (x : a) 25 | → (Applicative._<*>_ iAppF (pure f) (pure x)) ≡ (pure (f x)) 26 | 27 | -- Interchange: u <*> pure y = pure ($ y) <*> u 28 | interchange : {a b : Type} → (u : F (a → b)) (y : a) 29 | → (u <*> (pure y)) ≡ (pure (_$ y) <*> u) 30 | 31 | -- fmap f x = pure f <*> x 32 | functor : (f : a → b) (x : F a) → (fmap f x) ≡ ((pure f) <*> x) 33 | 34 | open IsLawfulApplicative ⦃ ... ⦄ public 35 | 36 | instance postulate 37 | iLawfulApplicativeFun : IsLawfulApplicative (λ b → a → b) 38 | 39 | iLawfulApplicativeTuple₂ : ⦃ Monoid a ⦄ → Applicative (a ×_) 40 | 41 | iLawfulApplicativeTuple₃ : ⦃ Monoid a ⦄ → ⦃ Monoid b ⦄ → Applicative (a × b ×_) 42 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Applicative/Either.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Applicative.Either where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Either 5 | 6 | open import Haskell.Prim.Applicative 7 | 8 | open import Haskell.Law.Applicative.Def 9 | 10 | open import Haskell.Law.Functor.Either 11 | 12 | instance 13 | iLawfulApplicativeEither : IsLawfulApplicative (Either a) 14 | -- (λ { true → true ; false → false }) 15 | 16 | iLawfulApplicativeEither .identity = λ { (Left _) → refl; (Right _) → refl } 17 | 18 | iLawfulApplicativeEither .composition = 19 | λ { (Left _) _ _ → refl 20 | ; (Right _) (Left _) _ → refl 21 | ; (Right _) (Right _) (Left _) → refl 22 | ; (Right _) (Right _) (Right _) → refl 23 | } 24 | 25 | iLawfulApplicativeEither .homomorphism _ _ = refl 26 | 27 | iLawfulApplicativeEither .interchange = λ { (Left _) _ → refl; (Right _) _ → refl } 28 | 29 | iLawfulApplicativeEither .functor = λ { _ (Left _) → refl; _ (Right _) → refl } 30 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Applicative/IO.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Applicative.IO where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.IO 5 | 6 | open import Haskell.Prim.Applicative 7 | 8 | open import Haskell.Law.Applicative.Def 9 | 10 | open import Haskell.Law.Functor.IO 11 | 12 | instance postulate iLawfulApplicativeIO : IsLawfulApplicative IO 13 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Applicative/Maybe.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Applicative.Maybe where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Maybe 5 | 6 | open import Haskell.Prim.Applicative 7 | 8 | open import Haskell.Law.Applicative.Def 9 | 10 | open import Haskell.Law.Functor.Maybe 11 | 12 | instance 13 | iLawfulApplicativeMaybe : IsLawfulApplicative Maybe 14 | iLawfulApplicativeMaybe .identity = λ { Nothing → refl; (Just _) → refl } 15 | 16 | iLawfulApplicativeMaybe .composition = 17 | λ { Nothing _ _ → refl 18 | ; (Just _) Nothing _ → refl 19 | ; (Just _) (Just _) Nothing → refl 20 | ; (Just _) (Just _) (Just _) → refl 21 | } 22 | 23 | iLawfulApplicativeMaybe .homomorphism _ _ = refl 24 | 25 | iLawfulApplicativeMaybe .interchange = λ { Nothing _ → refl; (Just _) _ → refl } 26 | 27 | iLawfulApplicativeMaybe .functor = λ { _ Nothing → refl; _ (Just _) → refl } 28 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Def.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Def where 2 | 3 | open import Haskell.Prim 4 | 5 | Injective : (a → b) → Type _ 6 | Injective f = ∀ {x y} → f x ≡ f y → x ≡ y 7 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Either.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Either where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Either 5 | 6 | open import Haskell.Law.Def 7 | 8 | Left-injective : Injective (Left {a}{b}) 9 | Left-injective refl = refl 10 | 11 | Right-injective : Injective (Right {a}{b}) 12 | Right-injective refl = refl 13 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Eq.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Eq where 2 | 3 | open import Haskell.Law.Eq.Def public 4 | open import Haskell.Law.Eq.Instances public 5 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Functor.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Functor where 2 | 3 | open import Haskell.Law.Functor.Def public 4 | open import Haskell.Law.Functor.Either public 5 | open import Haskell.Law.Functor.IO public 6 | open import Haskell.Law.Functor.List public 7 | open import Haskell.Law.Functor.Maybe public 8 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Functor/Def.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Functor.Def where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Tuple 5 | 6 | open import Haskell.Prim.Functor 7 | 8 | record IsLawfulFunctor (F : Type → Type) ⦃ iFuncF : Functor F ⦄ : Type₁ where 9 | field 10 | -- Identity: fmap id == id 11 | identity : (fa : F a) → (fmap id) fa ≡ id fa 12 | 13 | -- Composition: fmap (f . g) == fmap f . fmap g 14 | composition : (fa : F a) (f : a → b) (g : b → c) 15 | → fmap (g ∘ f) fa ≡ (fmap g ∘ fmap f) fa 16 | 17 | open IsLawfulFunctor ⦃ ... ⦄ public 18 | 19 | instance postulate 20 | iLawfulFunctorFun : IsLawfulFunctor (λ b → a → b) 21 | 22 | iLawfulFunctorTuple₂ : IsLawfulFunctor (a ×_) 23 | 24 | iLawfulFunctorTuple₃ : IsLawfulFunctor (a × b ×_) 25 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Functor/Either.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Functor.Either where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Either 5 | 6 | open import Haskell.Prim.Functor 7 | 8 | open import Haskell.Law.Functor.Def 9 | 10 | instance 11 | iLawfulFunctorEither : IsLawfulFunctor (Either a) 12 | iLawfulFunctorEither .identity = λ { (Left _) → refl; (Right _) → refl } 13 | 14 | iLawfulFunctorEither .composition = λ { (Left _) _ _ → refl; (Right _) _ _ → refl } 15 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Functor/IO.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Functor.IO where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.IO 5 | 6 | open import Haskell.Prim.Functor 7 | 8 | open import Haskell.Law.Functor.Def 9 | 10 | instance postulate isLawFulFunctorIO : IsLawfulFunctor IO 11 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Functor/List.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Functor.List where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.List 5 | 6 | open import Haskell.Prim.Functor 7 | 8 | open import Haskell.Law.Equality 9 | open import Haskell.Law.Functor.Def 10 | 11 | private 12 | identityList : (fa : List a) → (fmap id) fa ≡ id fa 13 | identityList [] = refl 14 | identityList (x ∷ xs) rewrite identityList xs = refl 15 | 16 | compositionList : (fa : List a) → (f : a → b) → (g : b → c) 17 | → fmap (g ∘ f) fa ≡ (fmap g ∘ fmap f) fa 18 | compositionList [] _ _ = refl 19 | compositionList (x ∷ xs) f g rewrite compositionList xs f g = refl 20 | 21 | instance 22 | iLawfulFunctorList : IsLawfulFunctor List 23 | iLawfulFunctorList = λ where 24 | .identity → identityList 25 | .composition → compositionList 26 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Functor/Maybe.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Functor.Maybe where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Maybe 5 | 6 | open import Haskell.Prim.Functor 7 | 8 | open import Haskell.Law.Functor.Def 9 | 10 | instance 11 | iLawfulFunctorMaybe : IsLawfulFunctor Maybe 12 | iLawfulFunctorMaybe .identity = λ { Nothing → refl; (Just _) → refl } 13 | 14 | iLawfulFunctorMaybe .composition = λ { Nothing _ _ → refl; (Just _) _ _ → refl } 15 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Int.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Int where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Int using ( int64 ) 5 | 6 | open import Haskell.Law.Def 7 | 8 | int64-injective : Injective int64 9 | int64-injective refl = refl 10 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Integer.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Integer where 2 | 3 | open import Haskell.Prim 4 | 5 | open import Haskell.Law.Def 6 | 7 | pos-injective : Injective pos 8 | pos-injective refl = refl 9 | 10 | neg-injective : Injective negsuc 11 | neg-injective refl = refl 12 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Maybe.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Maybe where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Maybe 5 | 6 | open import Haskell.Law.Def 7 | 8 | Just-injective : Injective (Just {a = a}) 9 | Just-injective refl = refl 10 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Monad.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Monad where 2 | 3 | open import Haskell.Law.Monad.Def public 4 | open import Haskell.Law.Monad.Either public 5 | open import Haskell.Law.Monad.IO public 6 | open import Haskell.Law.Monad.List public 7 | open import Haskell.Law.Monad.Maybe public 8 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Monad/Either.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Monad.Either where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Either 5 | 6 | open import Haskell.Prim.Monad 7 | 8 | open import Haskell.Law.Monad.Def 9 | 10 | open import Haskell.Law.Applicative.Either 11 | 12 | instance 13 | iLawfulMonadEither : IsLawfulMonad (Either a) 14 | iLawfulMonadEither .leftIdentity _ _ = refl 15 | 16 | iLawfulMonadEither .rightIdentity = λ { (Left _) → refl; (Right _) → refl } 17 | 18 | iLawfulMonadEither .associativity = λ { (Left _) _ _ → refl; (Right _) _ _ → refl } 19 | 20 | iLawfulMonadEither .pureIsReturn _ = refl 21 | 22 | iLawfulMonadEither .sequence2bind = 23 | λ { (Left _) _ → refl 24 | ; (Right _) (Left _) → refl 25 | ; (Right _) (Right _) → refl 26 | } 27 | 28 | iLawfulMonadEither .fmap2bind = λ { _ (Left _) → refl; _ (Right _) → refl } 29 | 30 | iLawfulMonadEither .rSequence2rBind = 31 | λ { (Left _) _ → refl 32 | ; (Right _) (Left _) → refl 33 | ; (Right _) (Right _) → refl 34 | } 35 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Monad/IO.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Monad.IO where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.IO 5 | 6 | open import Haskell.Prim.Monad 7 | 8 | open import Haskell.Law.Monad.Def 9 | 10 | open import Haskell.Law.Applicative.IO 11 | 12 | instance postulate iLawfulMonadIO : IsLawfulMonad IO 13 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Monad/List.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Monad.List where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.List 5 | 6 | open import Haskell.Prim.Monad 7 | 8 | open import Haskell.Law.Monad.Def 9 | open import Haskell.Law.List 10 | 11 | open import Haskell.Law.Applicative.List 12 | 13 | instance 14 | iLawfulMonadList : IsLawfulMonad List 15 | iLawfulMonadList .leftIdentity a k 16 | rewrite ++-[] (k a) 17 | = refl 18 | 19 | iLawfulMonadList .rightIdentity [] = refl 20 | iLawfulMonadList .rightIdentity (_ ∷ xs) 21 | rewrite rightIdentity xs 22 | = refl 23 | 24 | iLawfulMonadList .associativity [] f g = refl 25 | iLawfulMonadList .associativity (x ∷ xs) f g 26 | rewrite associativity xs f g 27 | | concatMap-++-distr (f x) (xs >>= f) g 28 | = refl 29 | 30 | iLawfulMonadList .pureIsReturn _ = refl 31 | 32 | iLawfulMonadList .sequence2bind [] _ = refl 33 | iLawfulMonadList .sequence2bind (f ∷ fs) xs 34 | rewrite sequence2bind fs xs 35 | | map-concatMap f xs 36 | = refl 37 | 38 | iLawfulMonadList .fmap2bind f [] = refl 39 | iLawfulMonadList .fmap2bind f (_ ∷ xs) 40 | rewrite fmap2bind f xs 41 | = refl 42 | 43 | iLawfulMonadList .rSequence2rBind [] mb = refl 44 | iLawfulMonadList .rSequence2rBind (x ∷ ma) mb 45 | rewrite rSequence2rBind ma mb 46 | | map-id mb 47 | = refl 48 | 49 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Monad/Maybe.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Monad.Maybe where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Maybe 5 | 6 | open import Haskell.Prim.Monad 7 | 8 | open import Haskell.Law.Monad.Def 9 | 10 | open import Haskell.Law.Applicative.Maybe 11 | 12 | instance 13 | iLawfulMonadMaybe : IsLawfulMonad Maybe 14 | iLawfulMonadMaybe .leftIdentity _ _ = refl 15 | 16 | iLawfulMonadMaybe .rightIdentity = λ { Nothing → refl; (Just _) → refl } 17 | 18 | iLawfulMonadMaybe .associativity = λ { Nothing _ _ → refl; (Just _) _ _ → refl } 19 | 20 | iLawfulMonadMaybe .pureIsReturn _ = refl 21 | 22 | iLawfulMonadMaybe .sequence2bind = 23 | λ { Nothing _ → refl 24 | ; (Just _) Nothing → refl 25 | ; (Just _) (Just _) → refl 26 | } 27 | 28 | iLawfulMonadMaybe .fmap2bind = λ { _ Nothing → refl; _ (Just _) → refl } 29 | 30 | iLawfulMonadMaybe .rSequence2rBind = 31 | λ { Nothing _ → refl 32 | ; (Just _) Nothing → refl 33 | ; (Just _) (Just _) → refl 34 | } 35 | 36 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Monoid.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Monoid where 2 | 3 | open import Haskell.Law.Semigroup.Def public 4 | open import Haskell.Law.Semigroup.Either public 5 | open import Haskell.Law.Semigroup.List public 6 | open import Haskell.Law.Semigroup.Maybe public 7 | 8 | open import Haskell.Law.Monoid.Def public 9 | open import Haskell.Law.Monoid.List public 10 | open import Haskell.Law.Monoid.Maybe public 11 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Monoid/Def.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Monoid.Def where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Tuple 5 | 6 | open import Haskell.Prim.Foldable 7 | open import Haskell.Prim.Monoid 8 | 9 | open import Haskell.Law.Semigroup.Def 10 | 11 | record IsLawfulMonoid (a : Type) ⦃ iMonoidA : Monoid a ⦄ : Type₁ where 12 | field 13 | overlap ⦃ super ⦄ : IsLawfulSemigroup a 14 | 15 | -- Right identity: x <> mempty = x 16 | rightIdentity : (x : a) → x <> mempty ≡ x 17 | 18 | -- Left identity: mempty <> x = x 19 | leftIdentity : (x : a) → mempty <> x ≡ x 20 | 21 | -- Concatenation: mconcat = foldr (<>) mempty 22 | concatenation : (xs : List a) → mconcat xs ≡ foldr _<>_ mempty xs 23 | 24 | open IsLawfulMonoid ⦃ ... ⦄ public 25 | 26 | postulate instance 27 | iLawfulMonoidFun : ⦃ iSemB : Monoid b ⦄ → ⦃ IsLawfulMonoid b ⦄ → IsLawfulMonoid (a → b) 28 | 29 | iLawfulMonoidUnit : IsLawfulMonoid ⊤ 30 | 31 | iLawfulMonoidTuple₂ : ⦃ iSemA : Monoid a ⦄ ⦃ iSemB : Monoid b ⦄ 32 | → ⦃ IsLawfulMonoid a ⦄ → ⦃ IsLawfulMonoid b ⦄ 33 | → IsLawfulMonoid (a × b) 34 | 35 | iLawfulMonoidTuple₃ : ⦃ iSemA : Monoid a ⦄ ⦃ iSemB : Monoid b ⦄ ⦃ iSemC : Monoid c ⦄ 36 | → ⦃ IsLawfulMonoid a ⦄ → ⦃ IsLawfulMonoid b ⦄ → ⦃ IsLawfulMonoid c ⦄ 37 | → IsLawfulMonoid (a × b × c) 38 | 39 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Monoid/List.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Monoid.List where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.List 5 | 6 | open import Haskell.Prim.Monoid 7 | 8 | open import Haskell.Law.List 9 | open import Haskell.Law.Monoid.Def 10 | open import Haskell.Law.Semigroup.Def 11 | open import Haskell.Law.Semigroup.List 12 | 13 | instance 14 | iLawfulMonoidList : IsLawfulMonoid (List a) 15 | iLawfulMonoidList .rightIdentity [] = refl 16 | iLawfulMonoidList .rightIdentity (x ∷ xs) 17 | rewrite ++-[] (x ∷ xs) 18 | = refl 19 | 20 | iLawfulMonoidList .leftIdentity [] = refl 21 | iLawfulMonoidList .leftIdentity (x ∷ xs) 22 | rewrite ++-[] (x ∷ xs) 23 | = refl 24 | 25 | iLawfulMonoidList .concatenation [] = refl 26 | iLawfulMonoidList .concatenation (x ∷ xs) 27 | rewrite ++-[] (x ∷ xs) 28 | | concatenation xs 29 | = refl 30 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Monoid/Maybe.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Monoid.Maybe where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Maybe 5 | 6 | open import Haskell.Prim.Monoid 7 | 8 | open import Haskell.Law.Monoid.Def 9 | open import Haskell.Law.Semigroup.Def 10 | open import Haskell.Law.Semigroup.Maybe 11 | 12 | instance 13 | iLawfulMonoidMaybe : ⦃ iMonoidA : Monoid a ⦄ → ⦃ iLawfulMonoidA : IsLawfulMonoid a ⦄ → IsLawfulMonoid (Maybe a) 14 | iLawfulMonoidMaybe .rightIdentity = λ { Nothing → refl; (Just _) → refl } 15 | 16 | iLawfulMonoidMaybe .leftIdentity = λ { Nothing → refl; (Just _) → refl } 17 | 18 | iLawfulMonoidMaybe .concatenation [] = refl 19 | iLawfulMonoidMaybe .concatenation (x ∷ xs) 20 | rewrite (concatenation xs) 21 | = refl 22 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Nat.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Nat where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Num 5 | 6 | open import Haskell.Law.Def 7 | open import Haskell.Law.Equality 8 | 9 | suc-injective : Injective suc 10 | suc-injective refl = refl 11 | 12 | {-| 13 | The canonical formalization of the 14 | less-than-or-equal-to relation for natural numbers. 15 | -} 16 | data _≤_ : Nat → Nat → Type where 17 | z≤n : ∀ {n} → zero ≤ n 18 | s≤s : ∀ {m n} (m≤n : m ≤ n) → suc m ≤ suc n 19 | 20 | ≤-refl : ∀ (x : Nat) → x ≤ x 21 | ≤-refl zero = z≤n 22 | ≤-refl (suc x) = s≤s (≤-refl x) 23 | 24 | ≤-antisym : ∀ {x y : Nat} 25 | → x ≤ y 26 | → y ≤ x 27 | ----- 28 | → x ≡ y 29 | ≤-antisym z≤n z≤n = refl 30 | ≤-antisym (s≤s x≤y) (s≤s y≤x) = cong suc (≤-antisym x≤y y≤x) 31 | 32 | ≤-trans : ∀ {x y z : Nat} 33 | → x ≤ y 34 | → y ≤ z 35 | ----- 36 | → x ≤ z 37 | ≤-trans z≤n y≤z = z≤n 38 | ≤-trans (s≤s x≤y) (s≤s y≤z) = s≤s (≤-trans x≤y y≤z) 39 | 40 | x≤x+1 : ∀ (x : Nat) → x ≤ suc x 41 | x≤x+1 zero = z≤n 42 | x≤x+1 (suc x) = s≤s (x≤x+1 x) 43 | 44 | x+[y-x]≡y : ∀ (x y : Nat) → x ≤ y → x + monusNat y x ≡ y 45 | x+[y-x]≡y zero y x≤y = refl 46 | x+[y-x]≡y (suc x) (suc y) (s≤s x≤y) = cong suc (x+[y-x]≡y x y x≤y) 47 | 48 | y-x≤y : ∀ (x y : Nat) → monusNat y x ≤ y 49 | y-x≤y zero y = ≤-refl y 50 | y-x≤y (suc x) zero = z≤n 51 | y-x≤y (suc x) (suc y) = ≤-trans (y-x≤y x y) (x≤x+1 y) 52 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Num.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Num where 2 | 3 | open import Haskell.Law.Num.Def public 4 | open import Haskell.Law.Num.Int public 5 | open import Haskell.Law.Num.Integer public 6 | open import Haskell.Law.Num.Nat public 7 | open import Haskell.Law.Num.Word public 8 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Num/Int.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Num.Int where 2 | 3 | open import Haskell.Prim using (refl; tt) 4 | open import Haskell.Prim.Num 5 | open import Haskell.Prim.Int 6 | open import Haskell.Prim.Word 7 | 8 | open import Haskell.Law.Num.Def 9 | open import Haskell.Law.Num.Word 10 | 11 | instance 12 | open NumHomomorphism 13 | open NumEmbedding 14 | 15 | iNumEmbeddingIntWord : NumEmbedding Int Word intToWord int64 16 | +-hom (hom iNumEmbeddingIntWord) (int64 _) (int64 _) = refl 17 | *-hom (hom iNumEmbeddingIntWord) (int64 _) (int64 _) = refl 18 | minus-ok (hom iNumEmbeddingIntWord) = tt 19 | negate-ok (hom iNumEmbeddingIntWord) = tt 20 | fromInteger-ok (hom iNumEmbeddingIntWord) = tt 21 | 0-hom (hom iNumEmbeddingIntWord) = refl 22 | 1-hom (hom iNumEmbeddingIntWord) = refl 23 | negate-hom (hom iNumEmbeddingIntWord) (int64 _) = refl 24 | embed iNumEmbeddingIntWord (int64 _) = refl 25 | 26 | iLawfulNumInt : IsLawfulNum Int 27 | iLawfulNumInt = map-IsLawfulNum intToWord int64 iNumEmbeddingIntWord iLawfulNumWord 28 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Ord.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Ord where 2 | 3 | open import Haskell.Law.Ord.Def public 4 | open import Haskell.Law.Ord.Bool public 5 | open import Haskell.Law.Ord.Maybe public 6 | open import Haskell.Law.Ord.Ordering public 7 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Semigroup/Def.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Semigroup.Def where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Tuple 5 | 6 | open import Haskell.Prim.Monoid 7 | 8 | record IsLawfulSemigroup (a : Type) ⦃ iSemigroupA : Semigroup a ⦄ : Type₁ where 9 | field 10 | -- Associativity: x <> (y <> z) = (x <> y) <> z 11 | associativity : (x y z : a) → x <> (y <> z) ≡ (x <> y) <> z 12 | 13 | open IsLawfulSemigroup ⦃ ... ⦄ public 14 | 15 | postulate instance 16 | iLawfulSemigroupFun : ⦃ iSemB : Semigroup b ⦄ → ⦃ IsLawfulSemigroup b ⦄ → IsLawfulSemigroup (a → b) 17 | 18 | iLawfulSemigroupUnit : IsLawfulSemigroup ⊤ 19 | 20 | iLawfulSemigroupTuple₂ : ⦃ iSemA : Semigroup a ⦄ ⦃ iSemB : Semigroup b ⦄ 21 | → ⦃ IsLawfulSemigroup a ⦄ → ⦃ IsLawfulSemigroup b ⦄ 22 | → IsLawfulSemigroup (a × b) 23 | 24 | iLawfulSemigroupTuple₃ : ⦃ iSemA : Semigroup a ⦄ ⦃ iSemB : Semigroup b ⦄ ⦃ iSemC : Semigroup c ⦄ 25 | → ⦃ IsLawfulSemigroup a ⦄ → ⦃ IsLawfulSemigroup b ⦄ → ⦃ IsLawfulSemigroup c ⦄ 26 | → IsLawfulSemigroup (a × b × c) 27 | 28 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Semigroup/Either.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Semigroup.Either where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Either 5 | 6 | open import Haskell.Prim.Monoid 7 | 8 | open import Haskell.Law.Equality 9 | open import Haskell.Law.Semigroup.Def 10 | 11 | instance 12 | iLawfulSemigroupEither : IsLawfulSemigroup (Either a b) 13 | iLawfulSemigroupEither .associativity = λ { (Left _) _ _ → refl; (Right _) _ _ → refl } 14 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Semigroup/List.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Semigroup.List where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.List 5 | 6 | open import Haskell.Prim.Monoid 7 | 8 | open import Haskell.Law.Equality 9 | open import Haskell.Law.List 10 | open import Haskell.Law.Semigroup.Def 11 | 12 | instance 13 | iLawfulSemigroupList : IsLawfulSemigroup (List a) 14 | iLawfulSemigroupList .associativity [] _ _ = refl 15 | iLawfulSemigroupList .associativity (x ∷ xs) ys zs 16 | rewrite sym (++-assoc xs ys zs) 17 | = refl 18 | -------------------------------------------------------------------------------- /lib/base/Haskell/Law/Semigroup/Maybe.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Law.Semigroup.Maybe where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Maybe 5 | 6 | open import Haskell.Prim.Monoid 7 | 8 | open import Haskell.Law.Equality 9 | open import Haskell.Law.Semigroup.Def 10 | 11 | instance 12 | iLawfulSemigroupMaybe : ⦃ iSemA : Semigroup a ⦄ → ⦃ IsLawfulSemigroup a ⦄ → IsLawfulSemigroup (Maybe a) 13 | iLawfulSemigroupMaybe .associativity Nothing _ _ = refl 14 | iLawfulSemigroupMaybe .associativity (Just _) Nothing _ = refl 15 | iLawfulSemigroupMaybe .associativity (Just _) (Just _) Nothing = refl 16 | iLawfulSemigroupMaybe .associativity (Just x) (Just y) (Just z) 17 | rewrite associativity x y z 18 | = refl 19 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/Absurd.agda: -------------------------------------------------------------------------------- 1 | 2 | module Haskell.Prim.Absurd where 3 | 4 | open import Haskell.Prim 5 | 6 | open import Agda.Builtin.Reflection renaming (bindTC to _>>=_; absurd to absurdP) 7 | 8 | private 9 | 10 | pattern vArg x = arg (arg-info visible (modality relevant quantity-ω)) x 11 | 12 | refute : Nat → Term 13 | refute i = def (quote _$_) ( vArg (pat-lam (absurd-clause [] (vArg (absurdP 0) ∷ []) ∷ []) []) 14 | ∷ vArg (var i []) ∷ []) 15 | 16 | tryRefute : Nat → Term → TC ⊤ 17 | tryRefute 0 _ = typeError (strErr "No variable of empty type found in the context" ∷ []) 18 | tryRefute (suc n) hole = catchTC (unify hole (refute n)) (tryRefute n hole) 19 | 20 | absurd : Term → TC ⊤ 21 | absurd hole = do 22 | Γ ← getContext 23 | tryRefute (lengthNat Γ) hole 24 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/Bool.agda: -------------------------------------------------------------------------------- 1 | 2 | module Haskell.Prim.Bool where 3 | 4 | open import Haskell.Prim 5 | 6 | -------------------------------------------------- 7 | -- Booleans 8 | 9 | infixr 3 _&&_ 10 | _&&_ : Bool → Bool → Bool 11 | False && _ = False 12 | True && x = x 13 | 14 | infixr 2 _||_ 15 | _||_ : Bool → Bool → Bool 16 | False || x = x 17 | True || _ = True 18 | 19 | not : Bool → Bool 20 | not False = True 21 | not True = False 22 | 23 | otherwise : Bool 24 | otherwise = True 25 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/Char.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Prim.Char where 2 | 3 | open import Haskell.Prim 4 | 5 | import Agda.Builtin.Char 6 | open Agda.Builtin.Char using (Char) 7 | 8 | eqChar : Char → Char → Bool 9 | eqChar a b = eqNat (c2n a) (c2n b) 10 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/Double.agda: -------------------------------------------------------------------------------- 1 | 2 | module Haskell.Prim.Double where 3 | 4 | open import Agda.Builtin.Float public renaming (Float to Double) 5 | 6 | open import Haskell.Prim 7 | 8 | instance 9 | iNumberDouble : Number Double 10 | iNumberDouble .Number.Constraint _ = ⊤ 11 | iNumberDouble .fromNat n = primNatToFloat n 12 | 13 | iNegativeDouble : Negative Double 14 | iNegativeDouble .Negative.Constraint _ = ⊤ 15 | iNegativeDouble .fromNeg n = primFloatMinus 0.0 (fromNat n) 16 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/Either.agda: -------------------------------------------------------------------------------- 1 | 2 | module Haskell.Prim.Either where 3 | 4 | open import Haskell.Prim 5 | open import Haskell.Prim.Bool 6 | 7 | -------------------------------------------------- 8 | -- Either 9 | 10 | data Either (a b : Type) : Type where 11 | Left : a → Either a b 12 | Right : b → Either a b 13 | 14 | either : (a → c) → (b → c) → Either a b → c 15 | either f g (Left x) = f x 16 | either f g (Right y) = g y 17 | 18 | testBool : (b : Bool) → Either (IsFalse b) (IsTrue b) 19 | testBool False = Left itsFalse 20 | testBool True = Right itsTrue 21 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/IO.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Prim.IO where 2 | 3 | open import Haskell.Prim 4 | open import Haskell.Prim.Show 5 | open import Haskell.Prim.String 6 | 7 | postulate IO : ∀{a} → Type a → Type a 8 | 9 | FilePath = String 10 | 11 | postulate 12 | -- Input functions 13 | interact : (String → String) → IO ⊤ 14 | getContents : IO String 15 | getLine : IO String 16 | getChar : IO Char 17 | 18 | -- Output functions 19 | print : ⦃ Show a ⦄ → a → IO ⊤ 20 | putChar : Char → IO ⊤ 21 | putStr : String → IO ⊤ 22 | putStrLn : String → IO ⊤ 23 | 24 | -- Files 25 | readFile : FilePath → IO String 26 | writeFile : FilePath → String → IO ⊤ 27 | appendFile : FilePath → String → IO ⊤ 28 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/Maybe.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Prim.Maybe where 2 | 3 | open import Haskell.Prim 4 | 5 | -------------------------------------------------- 6 | -- Maybe 7 | 8 | data Maybe {@0 ℓ} (a : Type ℓ) : Type ℓ where 9 | Nothing : Maybe a 10 | Just : a -> Maybe a 11 | 12 | maybe : ∀ {@0 ℓ₁ ℓ₂} {@0 a : Type ℓ₁} {@0 b : Type ℓ₂} → b → (a → b) → Maybe a → b 13 | maybe n j Nothing = n 14 | maybe n j (Just x) = j x 15 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/Strict.agda: -------------------------------------------------------------------------------- 1 | 2 | module Haskell.Prim.Strict where 3 | 4 | open import Haskell.Prim 5 | 6 | record Strict (a : Type ℓ) : Type ℓ where 7 | constructor !_ 8 | field 9 | force : a 10 | open Strict public 11 | 12 | {-# COMPILE AGDA2HS Strict unboxed-strict #-} 13 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/String.agda: -------------------------------------------------------------------------------- 1 | 2 | module Haskell.Prim.String where 3 | 4 | open import Haskell.Prim 5 | open import Haskell.Prim.List 6 | open import Haskell.Prim.Foldable 7 | 8 | -------------------------------------------------- 9 | -- String 10 | -- This is _not_ the builtin String type of Agda 11 | -- which is defined by postulates. 12 | -- `fromString` can be used to convert back 13 | -- to builtin Agda strings. 14 | 15 | String = List Char 16 | 17 | instance 18 | iIsStringString : IsString String 19 | iIsStringString .IsString.Constraint _ = ⊤ 20 | iIsStringString .fromString s = primStringToList s 21 | 22 | private 23 | cons : Char → List String → List String 24 | cons c [] = (c ∷ []) ∷ [] 25 | cons c (s ∷ ss) = (c ∷ s) ∷ ss 26 | 27 | lines : String → List String 28 | lines [] = [] 29 | lines ('\n' ∷ s) = [] ∷ lines s 30 | lines (c ∷ s) = cons c (lines s) 31 | 32 | private 33 | mutual 34 | space : String → List String 35 | space [] = [] 36 | space (c ∷ s) = if primIsSpace c then space s else cons c (word s) 37 | 38 | word : String → List String 39 | word [] = [] 40 | word (c ∷ s) = if primIsSpace c then [] ∷ space s else cons c (word s) 41 | 42 | words : String → List String 43 | words [] = [] 44 | words s@(c ∷ s₁) = if primIsSpace c then space s₁ else word s 45 | 46 | unlines : List String → String 47 | unlines = concatMap (_++ "\n") 48 | 49 | unwords : List String → String 50 | unwords [] = "" 51 | unwords (w ∷ []) = w 52 | unwords (w ∷ ws) = w ++ ' ' ∷ unwords ws 53 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/Thunk.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --sized-types #-} 2 | 3 | module Haskell.Prim.Thunk where 4 | 5 | open import Agda.Builtin.Size public 6 | 7 | open import Haskell.Prim 8 | 9 | record Thunk {ℓ} (a : @0 Size → Type ℓ) (@0 i : Size) : Type ℓ where 10 | constructor delay 11 | coinductive 12 | field force : {@0 j : Size< i} → a j 13 | open Thunk public 14 | 15 | {-# COMPILE AGDA2HS Thunk unboxed #-} 16 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/Tuple.agda: -------------------------------------------------------------------------------- 1 | 2 | module Haskell.Prim.Tuple where 3 | 4 | open import Haskell.Prim 5 | 6 | -------------------------------------------------- 7 | -- Tuples 8 | 9 | infix 3 _×_ _×_×_ 10 | 11 | infix -1 _,_ _,_,_ 12 | 13 | record _×_ (a b : Type) : Type where 14 | constructor _,_ 15 | field 16 | fst : a 17 | snd : b 18 | open _×_ public 19 | 20 | {-# COMPILE AGDA2HS _×_ tuple #-} 21 | 22 | record _×_×_ (a b c : Type) : Type where 23 | no-eta-equality; pattern 24 | constructor _,_,_ 25 | field 26 | fst3 : a 27 | snd3 : b 28 | thd3 : c 29 | 30 | {-# COMPILE AGDA2HS _×_×_ tuple #-} 31 | 32 | uncurry : (a → b → c) → a × b → c 33 | uncurry f (x , y) = f x y 34 | 35 | curry : (a × b → c) → a → b → c 36 | curry f x y = f (x , y) 37 | 38 | first : (a → b) → a × c → b × c 39 | first f (x , y) = f x , y 40 | 41 | second : (a → b) → c × a → c × b 42 | second f (x , y) = x , f y 43 | 44 | _***_ : (a → b) → (c → d) → a × c → b × d 45 | (f *** g) (x , y) = f x , g y 46 | -------------------------------------------------------------------------------- /lib/base/Haskell/Prim/Word.agda: -------------------------------------------------------------------------------- 1 | 2 | module Haskell.Prim.Word where 3 | 4 | open import Haskell.Prim 5 | open import Haskell.Prim.Integer 6 | 7 | import Agda.Builtin.Word renaming (Word64 to Word) 8 | open Agda.Builtin.Word public using (Word) 9 | 10 | 11 | -------------------------------------------------- 12 | -- Literals 13 | 14 | module WordInternal where 15 | 2⁶⁴ : Nat 16 | 2⁶⁴ = 18446744073709551616 17 | open WordInternal 18 | 19 | instance 20 | iNumberWord : Number Word 21 | iNumberWord .Number.Constraint n = IsTrue (ltNat n 2⁶⁴) 22 | iNumberWord .fromNat n = n2w n 23 | 24 | 25 | -------------------------------------------------- 26 | -- Arithmetic 27 | 28 | negateWord : Word → Word 29 | negateWord a = n2w (monusNat 2⁶⁴ (w2n a)) 30 | 31 | addWord : Word → Word → Word 32 | addWord a b = n2w (addNat (w2n a) (w2n b)) 33 | 34 | subWord : Word → Word → Word 35 | subWord a b = addWord a (negateWord b) 36 | 37 | mulWord : Word → Word → Word 38 | mulWord a b = n2w (mulNat (w2n a) (w2n b)) 39 | 40 | eqWord : Word → Word → Bool 41 | eqWord a b = eqNat (w2n a) (w2n b) 42 | 43 | ltWord : Word → Word → Bool 44 | ltWord a b = ltNat (w2n a) (w2n b) 45 | 46 | showWord : Word → List Char 47 | showWord a = primStringToList (primShowNat (w2n a)) 48 | 49 | integerToWord : Integer → Word 50 | integerToWord (pos n) = n2w n 51 | integerToWord (negsuc n) = negateWord (n2w (suc n)) 52 | 53 | wordToInteger : Word → Integer 54 | wordToInteger n = pos (w2n n) 55 | -------------------------------------------------------------------------------- /lib/base/base.agda-lib: -------------------------------------------------------------------------------- 1 | -- This library 2 | -- * mirrors the Haskell `base` package 3 | -- * is intertwined with `agda2hs` 4 | 5 | name: base 6 | depend: 7 | include: . 8 | flags: -W noUnsupportedIndexedMatch --erasure 9 | -------------------------------------------------------------------------------- /lib/containers/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for containers-prop 2 | 3 | ## 0.8.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /lib/containers/README.md: -------------------------------------------------------------------------------- 1 | `containers.agda-lib` proves properties about the Haskell [containers][] library. 2 | 3 | 4 | ## Roadmap 5 | 6 | For the time being, this library is developed as part of the [agda2hs][] repository. There are two reasons: 7 | 8 | * Significant backflow of code from `containers.agda-lib` to `base.agda-lib`. For example, proving properties about `Data.Map.spanAntitone` will require additions to `Data.Ord`. 9 | * Informs the development of [agda2hs][]: changes to `agda2hs` are immediately confronted with the fact that there is at least one separate library of considerable size. 10 | 11 | However, once [agda2hs][] has become sufficiently complete and stable, we want to move `containers.agda-lib` into a separate repository. 12 | 13 | [agda2hs]: https://github.com/agda/agda2hs 14 | [containers]: https://hackage.haskell.org/package/containers 15 | -------------------------------------------------------------------------------- /lib/containers/agda/Data/Map.agda: -------------------------------------------------------------------------------- 1 | module Data.Map where 2 | 3 | open import Haskell.Data.Map public 4 | open import Data.Map.Prop public 5 | -------------------------------------------------------------------------------- /lib/containers/agda/Data/Set.agda: -------------------------------------------------------------------------------- 1 | module Data.Set where 2 | 3 | open import Haskell.Data.Set public 4 | open import Data.Set.Prop public 5 | -------------------------------------------------------------------------------- /lib/containers/agda/Test/Agda2Hs/Data/Map.agda: -------------------------------------------------------------------------------- 1 | module Test.Agda2Hs.Data.Map where 2 | 3 | open import Haskell.Prelude 4 | 5 | open import Data.Map using (Map) 6 | import Data.Map as Map 7 | 8 | {----------------------------------------------------------------------------- 9 | Test definitions 10 | for exercising Data.Map 11 | ------------------------------------------------------------------------------} 12 | test0 : Map Nat String 13 | test0 = Map.fromList ((1 , "Hello") ∷ (2 , "Map") ∷ []) 14 | 15 | test1 : Map Nat String 16 | test1 = Map.filter (λ x → length x > 3) test0 17 | 18 | test2 : Map Nat String 19 | test2 = Map.singleton 1 "Data" 20 | 21 | test3 : Map Nat String 22 | test3 = Map.unionWith _<>_ test0 (Map.unionWith _<>_ test1 test2) 23 | 24 | test4 : Map Nat String 25 | test4 = Map.intersectionWith _<>_ test2 test3 26 | 27 | testLookup0 : Maybe String 28 | testLookup0 = Map.lookup 1 test4 29 | 30 | {-# COMPILE AGDA2HS test0 #-} 31 | {-# COMPILE AGDA2HS test1 #-} 32 | {-# COMPILE AGDA2HS test2 #-} 33 | {-# COMPILE AGDA2HS test3 #-} 34 | {-# COMPILE AGDA2HS test4 #-} 35 | {-# COMPILE AGDA2HS testLookup0 #-} 36 | -------------------------------------------------------------------------------- /lib/containers/agda/Test/Agda2Hs/Data/Set.agda: -------------------------------------------------------------------------------- 1 | module Test.Agda2Hs.Data.Set where 2 | 3 | open import Haskell.Prelude 4 | 5 | open import Data.Set using (Set) 6 | import Data.Set as Set 7 | 8 | {----------------------------------------------------------------------------- 9 | Test definitions 10 | for exercising Data.Set 11 | ------------------------------------------------------------------------------} 12 | test0 : Set String 13 | test0 = Set.fromList ("Hello" ∷ "Set" ∷ []) 14 | 15 | test1 : Set String 16 | test1 = Set.filter (λ x → length x > 3) test0 17 | 18 | test2 : Set String 19 | test2 = Set.singleton "Data" 20 | 21 | test3 : Set String 22 | test3 = Set.union test0 (Set.union test1 test2) 23 | 24 | test4 : Set String 25 | test4 = Set.intersection test2 test3 26 | 27 | testBool0 : Bool 28 | testBool0 = Set.isSubsetOf test2 test4 29 | 30 | {-# COMPILE AGDA2HS test0 #-} 31 | {-# COMPILE AGDA2HS test1 #-} 32 | {-# COMPILE AGDA2HS test2 #-} 33 | {-# COMPILE AGDA2HS test3 #-} 34 | {-# COMPILE AGDA2HS test4 #-} 35 | {-# COMPILE AGDA2HS testBool0 #-} 36 | -------------------------------------------------------------------------------- /lib/containers/agda/containers.agda: -------------------------------------------------------------------------------- 1 | -- This file imports all modules from the library. 2 | 3 | import Data.Map 4 | import Data.Set 5 | 6 | import Test.Agda2Hs.Data.Map 7 | import Test.Agda2Hs.Data.Set 8 | -------------------------------------------------------------------------------- /lib/containers/agda2hs-libraries: -------------------------------------------------------------------------------- 1 | ./../base/base.agda-lib 2 | -------------------------------------------------------------------------------- /lib/containers/containers.agda-lib: -------------------------------------------------------------------------------- 1 | name: containers 2 | include: agda 3 | depend: 4 | base 5 | flags: --erasure --no-import-sorts 6 | -------------------------------------------------------------------------------- /lib/containers/generate-haskell.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ROOT=containers.agda 3 | AGDA2HS="cabal run agda2hs --" 4 | ${AGDA2HS} \ 5 | --local-interfaces \ 6 | --no-default-libraries \ 7 | --library-file ./agda2hs-libraries \ 8 | -o ./haskell/ \ 9 | ./agda/${ROOT} 10 | -------------------------------------------------------------------------------- /nix/agda2hs.nix: -------------------------------------------------------------------------------- 1 | # this file should be very close to a copy of nixpkgs/pkgs/build-support/agda/default.nix 2 | # I think I took the version from https://github.com/NixOS/nixpkgs/blob/bbe6402ecacfc3a0e2c65e3527c2cbe148b98ff8/pkgs/build-support/agda/default.nix 3 | # but it would be nice to expose this in upstream so that we don't have to duplicate the file 4 | {stdenv, lib, self, agda2hs, runCommandNoCC, makeWrapper, writeText, mkShell, ghcWithPackages}: 5 | with lib.strings; 6 | let 7 | withPackages' = { 8 | pkgs, 9 | ghc ? ghcWithPackages (p: with p; [ ieee754 ]) 10 | }: let 11 | pkgs' = if builtins.isList pkgs then pkgs else pkgs self; 12 | library-file = writeText "libraries" '' 13 | ${(concatMapStringsSep "\n" (p: "${p}/${p.libraryFile}") pkgs')} 14 | ''; 15 | pname = "agda2hsWithPackages"; 16 | version = agda2hs.version; 17 | in runCommandNoCC "${pname}-${version}" { 18 | inherit pname version; 19 | nativeBuildInputs = [ makeWrapper ]; 20 | passthru.unwrapped = agda2hs; 21 | } '' 22 | mkdir -p $out/bin 23 | makeWrapper ${agda2hs}/bin/agda2hs $out/bin/agda2hs \ 24 | --add-flags "--with-compiler=${ghc}/bin/ghc" \ 25 | --add-flags "--library-file=${library-file}" \ 26 | --add-flags "--local-interfaces" 27 | ''; # Local interfaces has been added for now: See https://github.com/agda/agda/issues/4526 28 | withPackages = arg: if builtins.isAttrs arg then withPackages' arg else withPackages' { pkgs = arg; }; 29 | in { 30 | inherit withPackages; 31 | agda2hs = withPackages []; 32 | } 33 | -------------------------------------------------------------------------------- /nix/default.nix: -------------------------------------------------------------------------------- 1 | { 2 | pkgs ? import { }, 3 | ... 4 | }: 5 | let 6 | lib = import ./lib.nix { inherit pkgs; }; 7 | version = "1.3"; 8 | base-lib = pkgs.agdaPackages.mkDerivation { 9 | pname = "base"; 10 | meta = { }; 11 | version = version; 12 | preBuild = '' 13 | echo "{-# OPTIONS --sized-types #-}" > Everything.agda 14 | echo "module Everything where" >> Everything.agda 15 | find . -name '*.agda' ! -name 'Everything.agda' | sed -e 's/.\///;s/\//./g;s/\.agda$//;s/^/import /' >> Everything.agda 16 | ''; 17 | src = ../lib/base; 18 | }; 19 | in 20 | { 21 | inherit (lib) agda2hs; 22 | base-lib = base-lib; 23 | } 24 | -------------------------------------------------------------------------------- /nix/lib.nix: -------------------------------------------------------------------------------- 1 | { 2 | pkgs ? import { }, 3 | ... 4 | }: 5 | let 6 | hsrc = 7 | options: 8 | pkgs.haskellPackages.haskellSrc2nix { 9 | name = "agda2hs"; 10 | src = ../.; 11 | extraCabal2nixOptions = options; # "--jailbreak" 12 | }; 13 | hpkg = pkgs.haskellPackages.callPackage (hsrc "") { }; 14 | expr = import ./agda2hs.nix; 15 | agda2hs = pkgs.lib.makeScope pkgs.newScope ( 16 | self: 17 | pkgs.callPackage expr { 18 | agda2hs = hpkg; 19 | inherit self; 20 | inherit (pkgs.haskellPackages) ghcWithPackages; 21 | } 22 | ); 23 | in 24 | { 25 | agda2hs-pkg = hsrc; 26 | agda2hs-hs = hpkg; 27 | agda2hs-expr = expr; 28 | inherit (agda2hs) agda2hs withPackages; 29 | } 30 | -------------------------------------------------------------------------------- /nix/shell.nix: -------------------------------------------------------------------------------- 1 | { 2 | pkgs ? import { }, 3 | agda2hs-hs ? (import ./lib.nix { inherit pkgs; }).agda2hs-hs, 4 | }: 5 | pkgs.haskellPackages.shellFor { 6 | # This doesn't result in a shell where you can use cabal (v2-)build, 7 | # due to build-tool-depends in Agda's .cabal file, so for now only v1-build works 8 | # Making cabal re-install alex and happy from Hackage can work, 9 | # which will be done if the user runs `cabal update` and `cabal build`. 10 | # relevant issues listed in: 11 | # https://gist.github.com/ScottFreeCode/ef9f254e2dd91544bba4a068852fc81f 12 | # main ones are: 13 | # https://github.com/haskell/cabal/issues/8434 14 | # https://github.com/NixOS/nixpkgs/issues/130556 15 | # https://github.com/NixOS/nixpkgs/issues/176887 16 | packages = p: [ agda2hs-hs ]; 17 | nativeBuildInputs = with pkgs.haskellPackages; [ 18 | # related to haskell 19 | cabal-install 20 | haskell-language-server 21 | # general goodies 22 | pkgs.agda 23 | pkgs.nixfmt-rfc-style 24 | cabal2nix 25 | ]; 26 | } 27 | -------------------------------------------------------------------------------- /release-notes/1.0.md: -------------------------------------------------------------------------------- 1 | Release notes for agda2hs 1.0 2 | ============================= 3 | 4 | Initial release. 5 | -------------------------------------------------------------------------------- /release-notes/1.1.md: -------------------------------------------------------------------------------- 1 | Release notes for agda2hs v1.1 2 | ============================== 3 | 4 | Changes 5 | ------- 6 | 7 | - Updated Agda base version to 2.6.4. 8 | - The `agda2hs` executable can now also be used in interactive mode (e.g. in Emacs or VS Code). 9 | - Added option to specify user-defined rewrites (see https://agda.github.io/agda2hs/features.html#rewrite-rules). 10 | - Type operators with names not starting with a colon are now allowed. 11 | - Added bindings for the `IO` monad. 12 | - Various other additions to the `Haskell.Prelude` library. 13 | 14 | Fixed issues 15 | ------------ 16 | 17 | See https://github.com/agda/agda2hs/issues?q=milestone%3A1.1+is%3Aissue for the full list of fixed issues. 18 | -------------------------------------------------------------------------------- /release-notes/1.2.md: -------------------------------------------------------------------------------- 1 | Release notes for agda2hs v1.2 2 | ============================== 3 | 4 | Changes 5 | ------- 6 | 7 | - Increased bounds to support GHC 9.6.3 8 | - Changed flag `--rewrite-rules` to `--config`. 9 | - Deprecated `Tuple` (#228). Now there are distinct 2-uples (`_×_`) and 3-uples (`_×_×_`). 10 | Only 2-uples can be pattern-matched inside of let bindings. 11 | - Experimental support for *erased module parameters* (#229). 12 | - Support for erased hidden type parameters. 13 | - Functions with no clause throw a hard error when getting compiled. 14 | - Unboxed records can preserve any field -- not only the first one. 15 | - Improved documentation. 16 | 17 | See https://github.com/agda/agda2hs/issues?q=milestone%3A1.2+is%3Apr for the full list of changes. 18 | 19 | Fixed issues 20 | ------------ 21 | 22 | See https://github.com/agda/agda2hs/issues?q=milestone%3A1.2+is%3Aissue for the full list of fixed issues. 23 | -------------------------------------------------------------------------------- /src/Agda2Hs/Compile/Function.hs-boot: -------------------------------------------------------------------------------- 1 | module Agda2Hs.Compile.Function where 2 | 3 | import qualified Agda2Hs.Language.Haskell as Hs ( Match, Name ) 4 | import Agda.Syntax.Internal ( Clause, ModuleName, QName, Type ) 5 | import Agda2Hs.Compile.Types ( C ) 6 | 7 | compileClause' :: ModuleName -> Maybe QName -> Hs.Name () -> Type -> Clause -> C (Maybe (Hs.Match ())) 8 | -------------------------------------------------------------------------------- /src/Agda2Hs/Compile/Postulate.hs: -------------------------------------------------------------------------------- 1 | module Agda2Hs.Compile.Postulate where 2 | 3 | import Agda.Compiler.Backend 4 | 5 | import Agda.Syntax.Internal 6 | import Agda.Syntax.Common.Pretty ( prettyShow ) 7 | 8 | import Agda2Hs.Compile.Type ( compileType ) 9 | import Agda2Hs.Compile.Types 10 | import Agda2Hs.Compile.Utils 11 | 12 | import qualified Agda2Hs.Language.Haskell as Hs 13 | import Agda2Hs.Language.Haskell.Utils ( hsName, pp, hsError ) 14 | 15 | compilePostulate :: Definition -> C [Hs.Decl ()] 16 | compilePostulate def = do 17 | let n = qnameName (defName def) 18 | x = hsName $ prettyShow n 19 | checkValidFunName x 20 | setCurrentRange (nameBindingSite n) $ do 21 | ty <- compileType (unEl $ defType def) 22 | let body = hsError $ "postulate: " ++ pp ty 23 | return [ Hs.TypeSig () [x] ty 24 | , Hs.FunBind () [Hs.Match () x [] (Hs.UnGuardedRhs () body) Nothing] ] 25 | -------------------------------------------------------------------------------- /src/Agda2Hs/Compile/Var.hs: -------------------------------------------------------------------------------- 1 | module Agda2Hs.Compile.Var where 2 | 3 | import Control.Arrow ( (&&&) ) 4 | import Control.Monad ( unless ) 5 | import Control.Monad.Reader.Class ( asks ) 6 | 7 | import Agda2Hs.Compile.Types 8 | import Agda.Syntax.Common 9 | import Agda.Syntax.Internal ( unDom ) 10 | import Agda.Syntax.Common.Pretty ( prettyShow ) 11 | import Agda.Syntax.Abstract.Name ( nameConcrete ) 12 | import Agda.TypeChecking.Pretty ( text ) 13 | import Agda.TypeChecking.Monad.Base ( genericDocError ) 14 | import Agda.TypeChecking.Monad.Context ( lookupBV ) 15 | import Agda.Utils.Monad ( whenM ) 16 | 17 | 18 | -- | Compile a variable. 19 | compileDBVar :: Nat -> C String 20 | compileDBVar x = do 21 | (d, n) <- (fmap snd &&& fst . unDom) <$> lookupBV x 22 | return $ prettyShow $ nameConcrete n 23 | -------------------------------------------------------------------------------- /src/Agda2Hs/Language/Haskell.hs: -------------------------------------------------------------------------------- 1 | -- | Haskell syntax, parsing, pretty printing. 2 | -- 3 | -- This module contains those elements of the Haskell language 4 | -- that are needed by Agda2hs. 5 | -- 6 | -- We are mainly re-exporting @haskell-src-exts@. 7 | module Agda2Hs.Language.Haskell 8 | ( module Language.Haskell.Exts.Build 9 | , module Language.Haskell.Exts.Comments 10 | , module Language.Haskell.Exts.ExactPrint 11 | , module Language.Haskell.Exts.Extension 12 | , module Language.Haskell.Exts.Parser 13 | , module Language.Haskell.Exts.Pretty 14 | , module Language.Haskell.Exts.SrcLoc 15 | , module Language.Haskell.Exts.Syntax 16 | , module Agda2Hs.Language.Haskell.Utils 17 | ) where 18 | 19 | import Agda2Hs.Language.Haskell.Utils 20 | 21 | import Language.Haskell.Exts.Comments (Comment) 22 | import Language.Haskell.Exts.Build hiding (pApp) 23 | import Language.Haskell.Exts.ExactPrint (exactPrint) 24 | import Language.Haskell.Exts.Extension hiding (Strict, Lazy) 25 | import Language.Haskell.Exts.Parser 26 | import Language.Haskell.Exts.Pretty 27 | import Language.Haskell.Exts.SrcLoc (SrcSpanInfo) 28 | import Language.Haskell.Exts.Syntax 29 | -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | build/ 2 | agda2hs 3 | html/ 4 | -------------------------------------------------------------------------------- /test/AllCubicalTests.agda: -------------------------------------------------------------------------------- 1 | module AllCubicalTests where 2 | 3 | import Cubical.StreamFusion 4 | 5 | {-# FOREIGN AGDA2HS 6 | import Cubical.StreamFusion 7 | #-} 8 | -------------------------------------------------------------------------------- /test/AllFailTests.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --guardedness #-} 2 | module AllFailTests where 3 | 4 | import Fail.ClashingImport 5 | import Fail.Issue142 6 | import Fail.MatchOnDelay 7 | import Fail.NewTypeRecordTwoFields 8 | import Fail.Issue150 9 | import Fail.NonCopatternInstance 10 | import Fail.Issue113a 11 | import Fail.Issue119 12 | import Fail.NonStarRecordIndex 13 | import Fail.ErasedRecordParameter 14 | import Fail.Issue146 15 | import Fail.PartialCase 16 | import Fail.Issue169-record 17 | import Fail.Issue113b 18 | import Fail.Fixities 19 | import Fail.PartialIf 20 | import Fail.Inline2 21 | import Fail.Issue71 22 | import Fail.Issue223 23 | import Fail.NewTypeTwoConstructors 24 | import Fail.MultiArgumentPatternLambda 25 | import Fail.Inline 26 | import Fail.ExplicitInstance2 27 | import Fail.QualifiedRecordProjections 28 | import Fail.NewTypeTwoFields 29 | import Fail.InvalidName 30 | import Fail.Issue185 31 | import Fail.ExplicitInstance 32 | import Fail.ClashingImport 33 | import Fail.Copatterns 34 | import Fail.Issue154 35 | import Fail.PartialCaseNoLambda 36 | import Fail.NonStarDatatypeIndex 37 | import Fail.NonCanonicalSpecialFunction 38 | import Fail.TypeLambda 39 | import Fail.NonCanonicalSuperclass 40 | import Fail.Issue125 41 | import Fail.Issue357a 42 | import Fail.Issue357b 43 | import Fail.DerivingParseFailure 44 | -------------------------------------------------------------------------------- /test/Assert.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | open import Haskell.Control.Exception 4 | open import Haskell.Law.Ord 5 | open import Haskell.Extra.Dec 6 | 7 | subtractChecked : Nat → Nat → Nat 8 | subtractChecked x y = assert (IsFalse (x < y)) (x - y) 9 | 10 | {-# COMPILE AGDA2HS subtractChecked #-} 11 | -------------------------------------------------------------------------------- /test/AutoLambdaCaseInBind.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | lcaseInsideBind : Maybe (Maybe a) → Maybe a 4 | lcaseInsideBind mx = do 5 | x ← mx 6 | let go : Maybe a → Maybe a 7 | go = λ where Nothing → Nothing 8 | (Just _) → Nothing 9 | go x 10 | {-# COMPILE AGDA2HS lcaseInsideBind #-} 11 | -------------------------------------------------------------------------------- /test/AutoLambdaCaseInCase.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | lcaseInsideCaseOf : List a → (Maybe a → Maybe a) 4 | lcaseInsideCaseOf xs = case xs of λ where 5 | [] → λ where Nothing → Nothing 6 | (Just _) → Nothing 7 | (x ∷ _) → λ where Nothing → Nothing 8 | (Just _) → Just x 9 | {-# COMPILE AGDA2HS lcaseInsideCaseOf #-} 10 | -------------------------------------------------------------------------------- /test/BangPatterns.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | open import Haskell.Prim using (ℓ) 3 | open import Haskell.Prim.Strict 4 | 5 | strictId : Strict a → a 6 | strictId (! x) = x 7 | 8 | {-# COMPILE AGDA2HS strictId #-} 9 | 10 | myFoldl : (b -> a -> b) -> b -> List a -> b 11 | myFoldl f x0 [] = x0 12 | myFoldl f x0 (x ∷ xs) = myFoldl f (f x0 x) xs 13 | 14 | {-# COMPILE AGDA2HS myFoldl #-} 15 | 16 | foldl'' : (b -> a -> b) -> Strict b -> List a -> b 17 | foldl'' f (! x0) [] = x0 18 | foldl'' f (! x0) (x ∷ xs) = foldl'' f (! f x0 x) xs 19 | 20 | {-# COMPILE AGDA2HS foldl'' #-} 21 | 22 | data LazyMaybe (a : Type ℓ) : Type ℓ where 23 | LazyNothing : LazyMaybe a 24 | LazyJust : a → LazyMaybe a 25 | 26 | {-# COMPILE AGDA2HS LazyMaybe #-} 27 | 28 | data StrictMaybe (a : Type ℓ) : Type ℓ where 29 | StrictNothing : StrictMaybe a 30 | StrictJust : Strict a → StrictMaybe a 31 | 32 | {-# COMPILE AGDA2HS StrictMaybe #-} 33 | -------------------------------------------------------------------------------- /test/CanonicalInstance.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --erase-record-parameters #-} 2 | 3 | module _ where 4 | 5 | open import Haskell.Prelude 6 | 7 | record ClassA (a : Type) : Type where 8 | field 9 | myA : a 10 | 11 | open ClassA ⦃ ... ⦄ public 12 | {-# COMPILE AGDA2HS ClassA class #-} 13 | 14 | record ClassB (b : Type) : Type where 15 | field 16 | overlap ⦃ super ⦄ : ClassA b 17 | {-# COMPILE AGDA2HS ClassB class #-} 18 | 19 | myB : {{ClassB b}} → b 20 | myB = myA 21 | {-# COMPILE AGDA2HS myB #-} 22 | -------------------------------------------------------------------------------- /test/Coerce.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | data A : Type where 4 | MkA : Nat → A 5 | 6 | data B : Type where 7 | MkB : Nat → B 8 | 9 | postulate A≡B : A ≡ B 10 | 11 | coerceExample : B 12 | coerceExample = coerce A≡B (MkA 5) 13 | 14 | {-# COMPILE AGDA2HS A newtype #-} 15 | {-# COMPILE AGDA2HS B newtype deriving (Show) #-} 16 | {-# COMPILE AGDA2HS coerceExample #-} 17 | -------------------------------------------------------------------------------- /test/Coinduction.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --sized-types #-} 2 | 3 | module Coinduction where 4 | 5 | open import Haskell.Prelude 6 | open import Haskell.Prim.Thunk 7 | 8 | data Colist (a : Type) (@0 i : Size) : Type where 9 | Nil : Colist a i 10 | Cons : a -> Thunk (Colist a) i -> Colist a i 11 | 12 | {-# COMPILE AGDA2HS Colist #-} 13 | 14 | repeater : ∀ {a i} → a → Colist a i 15 | repeater x = Cons x λ where .force → repeater x 16 | 17 | {-# COMPILE AGDA2HS repeater #-} 18 | -------------------------------------------------------------------------------- /test/CommonQualifiedImports.agda: -------------------------------------------------------------------------------- 1 | {-# FOREIGN AGDA2HS 2 | -- ** common qualification 3 | #-} 4 | 5 | import Haskell.Prelude as Common 6 | import Importee as Common 7 | using (foo) 8 | import Importee as Common 9 | using (anotherFoo) 10 | 11 | foos : Common.Int 12 | foos = Common.foo Common.+ Common.anotherFoo 13 | {-# COMPILE AGDA2HS foos #-} 14 | -------------------------------------------------------------------------------- /test/ConstrainedInstance.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | data D (a : Type) : Type where 5 | C : a → D a 6 | {-# COMPILE AGDA2HS D #-} 7 | 8 | instance 9 | iEqD : {{Eq a}} → Eq (D a) 10 | iEqD ._==_ (C x) (C y) = x == y 11 | {-# COMPILE AGDA2HS iEqD #-} 12 | -------------------------------------------------------------------------------- /test/Cubical/StreamFusion.agda: -------------------------------------------------------------------------------- 1 | module Cubical.StreamFusion where 2 | 3 | open import Haskell.Prelude 4 | 5 | open import Agda.Primitive.Cubical 6 | open import Agda.Builtin.Equality 7 | open import Agda.Builtin.Size 8 | 9 | variable 10 | @0 i : Size 11 | 12 | record Stream (a : Type) (@0 i : Size) : Type where 13 | pattern; inductive; constructor _:>_ 14 | field 15 | shead : a 16 | stail : ∀ {@0 j} → Stream a j 17 | open Stream public 18 | 19 | {-# COMPILE AGDA2HS Stream #-} 20 | 21 | smap : (a → b) → Stream a i → Stream b i 22 | smap f (x :> xs) = (f x) :> smap f xs 23 | 24 | {-# COMPILE AGDA2HS smap #-} 25 | 26 | smap-fusion : (f : a → b) (g : b → c) (s : Stream a i) 27 | → PathP (λ _ → Stream c i) (smap {i = i} g (smap {i = i} f s)) (smap {i = i} (λ x → g (f x)) s) 28 | smap-fusion f g (hd :> tl) i = (g (f hd)) :> smap-fusion f g tl i 29 | -------------------------------------------------------------------------------- /test/CustomTuples.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | record Σ (a : Type) (b : @0 a → Type) : Type where 4 | constructor _,_ 5 | field 6 | fst : a 7 | snd : b fst 8 | open Σ public 9 | {-# COMPILE AGDA2HS Σ tuple #-} 10 | 11 | test : Σ Int (λ _ → Int) → Int 12 | test xy = fst xy + snd xy 13 | 14 | {-# COMPILE AGDA2HS test #-} 15 | 16 | record Stuff (a : Type) : Type where 17 | no-eta-equality; pattern 18 | constructor stuff 19 | field 20 | something : Int 21 | more : a 22 | another : Bool 23 | 24 | {-# COMPILE AGDA2HS Stuff unboxed-tuple #-} 25 | 26 | foo : Stuff Int → Stuff Bool → Stuff Char 27 | foo (stuff a b c) (stuff x y z) = stuff (a + b + x) 'x' (or (c ∷ y ∷ z ∷ [])) 28 | 29 | {-# COMPILE AGDA2HS foo #-} 30 | 31 | bare : Int → Char → Bool → Stuff Char 32 | bare = stuff 33 | 34 | {-# COMPILE AGDA2HS bare #-} 35 | 36 | section : a → Bool → Stuff a 37 | section = stuff 42 38 | 39 | {-# COMPILE AGDA2HS section #-} 40 | 41 | record NoStuff : Type where 42 | no-eta-equality; pattern 43 | constructor dontlook 44 | 45 | {-# COMPILE AGDA2HS NoStuff tuple #-} 46 | 47 | bar : NoStuff → NoStuff 48 | bar dontlook = dontlook 49 | 50 | {-# COMPILE AGDA2HS bar #-} 51 | 52 | -- This is legal, basically the same as an unboxed record. 53 | record Legal (a : Type) : Type where 54 | constructor mkLegal 55 | field 56 | theA : a 57 | 58 | {-# COMPILE AGDA2HS Legal tuple #-} 59 | 60 | baz : Legal Int → Legal Int 61 | baz (mkLegal x) = mkLegal 42 62 | 63 | {-# COMPILE AGDA2HS baz #-} 64 | -------------------------------------------------------------------------------- /test/Datatypes.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prim using (Bool; Type) 3 | 4 | data Test : Type where 5 | CTest : Bool -> @0 {Bool} -> Test 6 | {-# COMPILE AGDA2HS Test #-} 7 | 8 | getTest : Test → Bool 9 | getTest (CTest b) = b 10 | {-# COMPILE AGDA2HS getTest #-} 11 | 12 | putTest : Bool → Test → Test 13 | putTest b (CTest _ {b'}) = CTest b {b'} 14 | {-# COMPILE AGDA2HS putTest #-} 15 | -------------------------------------------------------------------------------- /test/Default.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | record HasDefault (a : Type) : Type where 4 | field 5 | theDefault : a 6 | open HasDefault {{...}} 7 | {-# COMPILE AGDA2HS HasDefault class #-} 8 | 9 | instance 10 | defaultBool : HasDefault Bool 11 | defaultBool .theDefault = False 12 | {-# COMPILE AGDA2HS defaultBool instance #-} 13 | 14 | test : Bool 15 | test = theDefault 16 | {-# COMPILE AGDA2HS test #-} 17 | -------------------------------------------------------------------------------- /test/Delay.agda: -------------------------------------------------------------------------------- 1 | 2 | module Delay where 3 | 4 | open import Haskell.Prelude 5 | open import Haskell.Prim.Thunk 6 | open import Haskell.Extra.Delay 7 | 8 | open import Agda.Builtin.Size 9 | 10 | postulate 11 | div' : Int → Int → Int 12 | mod' : Int → Int → Int 13 | 14 | {-# COMPILE AGDA2HS div' #-} 15 | {-# COMPILE AGDA2HS mod' #-} 16 | 17 | even' : Int → Bool 18 | even' x = mod' x 2 == 0 19 | 20 | {-# COMPILE AGDA2HS even' #-} 21 | 22 | collatz : ∀ {@0 j} → Int → Delay Int j 23 | collatz x = 24 | if x == 0 then now 0 25 | else if even' x then later (λ where .force → collatz (div' x 2)) 26 | else later λ where .force → collatz (3 * x + 1) 27 | 28 | {-# COMPILE AGDA2HS collatz #-} 29 | -------------------------------------------------------------------------------- /test/DoNotation.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | -- Example from http://learnyouahaskell.com/a-fistful-of-monads#getting-our-feet-wet-with-maybe 5 | 6 | Birds = Int 7 | Pole = Birds × Birds 8 | 9 | {-# COMPILE AGDA2HS Birds #-} 10 | {-# COMPILE AGDA2HS Pole #-} 11 | 12 | 13 | landLeft : Birds → Pole → Maybe Pole 14 | landLeft n (left , right) = 15 | if abs ((left + n) - right) < 4 16 | then Just (left + n , right) 17 | else Nothing 18 | 19 | {-# COMPILE AGDA2HS landLeft #-} 20 | 21 | landRight : Birds → Pole → Maybe Pole 22 | landRight n (left , right) = 23 | if abs (left - (right + n)) < 4 24 | then Just (left , right + n) 25 | else Nothing 26 | 27 | {-# COMPILE AGDA2HS landRight #-} 28 | 29 | routine : Maybe Pole 30 | routine = do 31 | start ← return (0 , 0) 32 | first ← landLeft 2 start 33 | second ← landRight 2 first 34 | landLeft 1 second 35 | 36 | {-# COMPILE AGDA2HS routine #-} 37 | 38 | routineWithoutDo : Maybe Pole 39 | routineWithoutDo = 40 | return (0 , 0) Dont.>>= λ start → 41 | landLeft 2 start Dont.>>= λ first → 42 | landRight 2 first Dont.>>= λ second → 43 | landLeft 1 second 44 | 45 | {-# COMPILE AGDA2HS routineWithoutDo #-} 46 | 47 | swapPolesMaybe : Maybe Pole → Maybe Pole 48 | swapPolesMaybe x = do 49 | (one , two) ← x 50 | pure (two , one) 51 | 52 | {-# COMPILE AGDA2HS swapPolesMaybe #-} 53 | -------------------------------------------------------------------------------- /test/EraseType.agda: -------------------------------------------------------------------------------- 1 | module EraseType where 2 | 3 | open import Haskell.Prelude 4 | open import Haskell.Extra.Erase 5 | 6 | testErase : Erase Int 7 | testErase = Erased 42 8 | 9 | {-# COMPILE AGDA2HS testErase #-} 10 | 11 | testMatch : Erase Int → Erase Int 12 | testMatch (Erased x) = Erased (x + 1) 13 | 14 | {-# COMPILE AGDA2HS testMatch #-} 15 | 16 | testRezz : Rezz (get testErase) 17 | testRezz = rezz 42 18 | 19 | {-# COMPILE AGDA2HS testRezz #-} 20 | 21 | testRezzErase : Rezz testErase 22 | testRezzErase = rezzErase 23 | 24 | {-# COMPILE AGDA2HS testRezzErase #-} 25 | 26 | testCong : Rezz (1 + get testErase) 27 | testCong = rezzCong (1 +_) testRezz 28 | 29 | {-# COMPILE AGDA2HS testCong #-} 30 | 31 | rTail : ∀ {@0 x xs} → Rezz {a = List Int} (x ∷ xs) → Rezz xs 32 | rTail = rezzTail 33 | 34 | {-# COMPILE AGDA2HS rTail #-} 35 | -------------------------------------------------------------------------------- /test/ErasedLocalDefinitions.agda: -------------------------------------------------------------------------------- 1 | -- See issue #182. 2 | 3 | open import Agda.Builtin.Bool 4 | open import Agda.Builtin.Equality 5 | 6 | f : (m : Bool) → Bool 7 | f m = g m greattruth 8 | where 9 | @0 greattruth : true ≡ true 10 | greattruth = refl 11 | g : (m : Bool) (@0 proof : true ≡ true) → Bool 12 | g m _ = m 13 | {-# COMPILE AGDA2HS f #-} 14 | -------------------------------------------------------------------------------- /test/ErasedPatternLambda.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | Scope = List Bool 4 | 5 | data Telescope (@0 α : Scope) : @0 Scope → Type where 6 | ExtendTel : ∀ {@0 x β} → Bool → Telescope (x ∷ α) β → Telescope α (x ∷ β) 7 | {-# COMPILE AGDA2HS Telescope #-} 8 | 9 | caseTelBind : ∀ {@0 x α β} (tel : Telescope α (x ∷ β)) 10 | → ((a : Bool) (rest : Telescope (x ∷ α) β) → @0 tel ≡ ExtendTel a rest → d) 11 | → d 12 | caseTelBind (ExtendTel a tel) f = f a tel refl 13 | 14 | {-# COMPILE AGDA2HS caseTelBind #-} 15 | 16 | checkSubst : ∀ {@0 x α β} (t : Telescope α (x ∷ β)) → Bool 17 | checkSubst t = caseTelBind t λ ty rest → λ where refl → True 18 | {-# COMPILE AGDA2HS checkSubst #-} 19 | -------------------------------------------------------------------------------- /test/ErasedTypeArguments.agda: -------------------------------------------------------------------------------- 1 | -- Testing whether erased value arguments in record type signatures 2 | -- and in lambdas do get erased. 3 | module ErasedTypeArguments where 4 | 5 | open import Agda.Primitive renaming (Set to Type) 6 | open import Agda.Builtin.Unit 7 | open import Agda.Builtin.Nat 8 | 9 | -- A record type which has both members compiled, 10 | -- but the argument of the lambda is erased; 11 | -- so that it won't be dependent-typed after compilation. 12 | record Σ' {i j} (a : Type i) (b : @0 a -> Type j) : Type (i ⊔ j) where 13 | constructor _:^:_ 14 | field 15 | proj₁ : a 16 | proj₂ : b proj₁ 17 | open Σ' public 18 | infixr 4 _:^:_ 19 | {-# COMPILE AGDA2HS Σ' #-} 20 | 21 | -- Now test lambdas. 22 | -- Actually, Agda can deduce here that n is erased; probably from the type signature of Σ'. 23 | test : Nat -> Σ' Nat (λ (n : Nat) -> ⊤) 24 | test n = n :^: tt 25 | {-# COMPILE AGDA2HS test #-} 26 | 27 | -- Tests a type function that would be accepted anyway, 28 | -- but the argument is erased. 29 | data Id {i j} (@0 a : Type i) (f : @0 Type i -> Type j) : Type j where 30 | MkId : f a -> Id a f 31 | {-# COMPILE AGDA2HS Id newtype #-} 32 | -------------------------------------------------------------------------------- /test/Fail/ClashingImport.agda: -------------------------------------------------------------------------------- 1 | module Fail.ClashingImport where 2 | 3 | open import Importee 4 | open import OtherImportee 5 | 6 | testFoo : Foo 7 | testFoo = MkFoo 8 | {-# COMPILE AGDA2HS testFoo #-} 9 | 10 | otherFoo : OtherFoo 11 | otherFoo = MkFoo 12 | {-# COMPILE AGDA2HS otherFoo #-} 13 | -------------------------------------------------------------------------------- /test/Fail/Copatterns.agda: -------------------------------------------------------------------------------- 1 | -- Copatterns are not supported, except in specific cases 2 | 3 | module Fail.Copatterns where 4 | 5 | open import Haskell.Prelude 6 | 7 | record R : Type where 8 | field 9 | foo : Bool 10 | open R public 11 | 12 | {-# COMPILE AGDA2HS R #-} 13 | 14 | test : R 15 | test .foo = True 16 | 17 | {-# COMPILE AGDA2HS test #-} 18 | -------------------------------------------------------------------------------- /test/Fail/DerivingParseFailure.agda: -------------------------------------------------------------------------------- 1 | module Fail.DerivingParseFailure where 2 | 3 | open import Haskell.Prim using (Type) 4 | 5 | record Example : Type where 6 | {-# COMPILE AGDA2HS Example deriving !& #-} 7 | -- {-# COMPILE AGDA2HS Example deriving Show via Foo #-} 8 | -- {-# COMPILE AGDA2HS Example deriving (Show, Eq, Ord) class #-} 9 | -------------------------------------------------------------------------------- /test/Fail/ErasedRecordParameter.agda: -------------------------------------------------------------------------------- 1 | -- c.f. Issue #145, this is the record variant 2 | module Fail.ErasedRecordParameter where 3 | 4 | open import Haskell.Prim using (Type) 5 | 6 | record Ok (@0 a : Type) : Type where 7 | constructor Thing 8 | field unThing : a 9 | open Ok public 10 | {-# COMPILE AGDA2HS Ok #-} 11 | -------------------------------------------------------------------------------- /test/Fail/ExplicitInstance.agda: -------------------------------------------------------------------------------- 1 | 2 | module Fail.ExplicitInstance where 3 | 4 | open import Haskell.Prelude 5 | 6 | record HasDefault (a : Type) : Type where 7 | field 8 | theDefault : a 9 | open HasDefault {{...}} 10 | {-# COMPILE AGDA2HS HasDefault class #-} 11 | 12 | instance 13 | defaultBool : HasDefault Bool 14 | defaultBool .theDefault = False 15 | {-# COMPILE AGDA2HS defaultBool instance #-} 16 | 17 | test : Bool 18 | test = theDefault {{λ where .theDefault → True}} 19 | {-# COMPILE AGDA2HS test #-} 20 | 21 | important-theorem : test ≡ True 22 | important-theorem = refl 23 | -------------------------------------------------------------------------------- /test/Fail/ExplicitInstance2.agda: -------------------------------------------------------------------------------- 1 | 2 | module Fail.ExplicitInstance2 where 3 | 4 | open import Haskell.Prelude 5 | 6 | record HasDefault (a : Type) : Type where 7 | field 8 | theDefault : a 9 | open HasDefault {{...}} 10 | {-# COMPILE AGDA2HS HasDefault class #-} 11 | 12 | -- This should be an error even if there is no instance in scope 13 | test : Bool 14 | test = theDefault {{λ where .theDefault → True}} 15 | {-# COMPILE AGDA2HS test #-} 16 | -------------------------------------------------------------------------------- /test/Fail/Fixities.agda: -------------------------------------------------------------------------------- 1 | module Fail.Fixities where 2 | 3 | open import Haskell.Prelude 4 | 5 | infixl 8.5 _<+>_ 6 | _<+>_ : Int → Int → Int 7 | x <+> y = x 8 | 9 | {-# COMPILE AGDA2HS _<+>_ #-} 10 | -------------------------------------------------------------------------------- /test/Fail/Inline.agda: -------------------------------------------------------------------------------- 1 | module Fail.Inline where 2 | 3 | open import Haskell.Prelude 4 | 5 | tail' : List a → List a 6 | tail' (x ∷ xs) = xs 7 | tail' [] = [] 8 | {-# COMPILE AGDA2HS tail' inline #-} 9 | -------------------------------------------------------------------------------- /test/Fail/Inline2.agda: -------------------------------------------------------------------------------- 1 | module Fail.Inline2 where 2 | 3 | open import Haskell.Prelude 4 | 5 | tail' : (xs : List a) → @0 {{ NonEmpty xs }} → List a 6 | tail' (x ∷ xs) = xs 7 | {-# COMPILE AGDA2HS tail' inline #-} 8 | -------------------------------------------------------------------------------- /test/Fail/InvalidName.agda: -------------------------------------------------------------------------------- 1 | 2 | module Fail.InvalidName where 3 | 4 | open import Haskell.Prelude 5 | 6 | F : Int → Int 7 | F x = x 8 | 9 | {-# COMPILE AGDA2HS F #-} 10 | -------------------------------------------------------------------------------- /test/Fail/Issue113a.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --guardedness #-} 2 | 3 | module Fail.Issue113a where 4 | 5 | open import Haskell.Prim using (Type) 6 | 7 | record Loop : Type where 8 | coinductive 9 | field force : Loop 10 | open Loop public 11 | 12 | {-# COMPILE AGDA2HS Loop unboxed #-} 13 | 14 | loop : Loop 15 | loop = λ where .force → loop 16 | {-# COMPILE AGDA2HS loop #-} 17 | -------------------------------------------------------------------------------- /test/Fail/Issue113b.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --guardedness #-} 2 | 3 | module Fail.Issue113b where 4 | 5 | open import Haskell.Prim using (Type) 6 | 7 | postulate A : Type 8 | 9 | record Loop : Type where 10 | coinductive 11 | field force : Loop 12 | open Loop public 13 | 14 | {-# COMPILE AGDA2HS Loop unboxed #-} 15 | 16 | loop : {@0 x : A} → Loop 17 | loop {x} = λ where .force → loop {x} 18 | {-# COMPILE AGDA2HS loop #-} 19 | -------------------------------------------------------------------------------- /test/Fail/Issue119.agda: -------------------------------------------------------------------------------- 1 | module Fail.Issue119 where 2 | 3 | open import Haskell.Prelude 4 | 5 | aaa : Int 6 | aaa = 21 7 | 8 | -- Oops, forgot compile pragma for aaa 9 | 10 | bbb : Int 11 | bbb = aaa + aaa 12 | 13 | {-# COMPILE AGDA2HS bbb #-} 14 | -------------------------------------------------------------------------------- /test/Fail/Issue125.agda: -------------------------------------------------------------------------------- 1 | module Fail.Issue125 where 2 | 3 | open import Haskell.Prim using (Type) 4 | 5 | data A (a : Type) : Type where 6 | ACtr : a -> A a 7 | 8 | {-# COMPILE AGDA2HS A #-} 9 | 10 | data B : Type where 11 | ACtr : B 12 | 13 | {-# COMPILE AGDA2HS B #-} 14 | 15 | data C : Type where 16 | Ca : C 17 | 18 | {-# COMPILE AGDA2HS C #-} 19 | -------------------------------------------------------------------------------- /test/Fail/Issue142.agda: -------------------------------------------------------------------------------- 1 | module Fail.Issue142 where 2 | 3 | open import Haskell.Prelude 4 | 5 | -- `coerce` is a primitive but this general structure remains disallowed 6 | falseCoerce : @0 a ≡ b → a → b 7 | falseCoerce refl x = x 8 | {-# COMPILE AGDA2HS falseCoerce #-} 9 | -------------------------------------------------------------------------------- /test/Fail/Issue146.agda: -------------------------------------------------------------------------------- 1 | module Fail.Issue146 where 2 | 3 | open import Haskell.Prelude 4 | 5 | record Wrap (a : Type) : Type where 6 | constructor MkWrap 7 | field wrapped : a 8 | open Wrap public 9 | 10 | {-# COMPILE AGDA2HS Wrap #-} 11 | 12 | record Class (a : Type) : Type where 13 | field 14 | method : Wrap a → Wrap a 15 | open Class ⦃...⦄ public 16 | 17 | {-# COMPILE AGDA2HS Class class #-} 18 | 19 | instance 20 | BoolClass : Class Bool 21 | BoolClass .method (MkWrap x) .wrapped = x 22 | 23 | {-# COMPILE AGDA2HS BoolClass #-} 24 | 25 | -------------------------------------------------------------------------------- /test/Fail/Issue150.agda: -------------------------------------------------------------------------------- 1 | module Fail.Issue150 where 2 | 3 | open import Haskell.Prelude 4 | 5 | record Tup (a b : Type) : Type where 6 | constructor MkTup 7 | field exl : a ; exr : b 8 | open Tup public 9 | 10 | {-# COMPILE AGDA2HS Tup #-} 11 | 12 | swap : Tup a b → Tup b a 13 | swap = λ (MkTup x y) → MkTup y x 14 | 15 | {-# COMPILE AGDA2HS swap #-} 16 | -------------------------------------------------------------------------------- /test/Fail/Issue154.agda: -------------------------------------------------------------------------------- 1 | module Fail.Issue154 where 2 | 3 | open import Haskell.Prelude 4 | 5 | foo : Nat → Nat 6 | foo zero = zero 7 | foo (suc x) = x 8 | {-# COMPILE AGDA2HS foo #-} 9 | -------------------------------------------------------------------------------- /test/Fail/Issue169-record.agda: -------------------------------------------------------------------------------- 1 | -- Using a default method implementation for an instance declaration currently 2 | -- requires a named definition or an anonymous `λ where` on the Agda side, so a 3 | -- record is not allowed. 4 | 5 | module Fail.Issue169-record where 6 | 7 | open import Haskell.Prelude 8 | 9 | record Identity (a : Type) : Type where 10 | field 11 | runIdentity : a 12 | open Identity public 13 | 14 | {-# COMPILE AGDA2HS Identity newtype #-} 15 | 16 | showIdentity : ⦃ Show a ⦄ → Identity a → String 17 | showIdentity record { runIdentity = id } = "Id < " ++ show id ++ " >" 18 | 19 | {-# COMPILE AGDA2HS showIdentity #-} 20 | 21 | instance 22 | iIdentityShow : ⦃ Show a ⦄ → Show (Identity a) 23 | iIdentityShow = record {Show₂ record {show = showIdentity}} 24 | 25 | {-# COMPILE AGDA2HS iIdentityShow #-} 26 | -------------------------------------------------------------------------------- /test/Fail/Issue185.agda: -------------------------------------------------------------------------------- 1 | module Fail.Issue185 where 2 | 3 | open import Haskell.Prim using (Bool; True; Type) 4 | 5 | record RecordTest : Type where 6 | constructor MkRecord 7 | field 8 | aBool : Bool 9 | 10 | aBoolAsAFunction : Bool 11 | aBoolAsAFunction = aBool 12 | open RecordTest public 13 | {-# COMPILE AGDA2HS RecordTest newtype #-} 14 | {-# COMPILE AGDA2HS aBoolAsAFunction #-} 15 | 16 | test : Bool 17 | test = aBoolAsAFunction (MkRecord True) 18 | {-# COMPILE AGDA2HS test #-} 19 | -------------------------------------------------------------------------------- /test/Fail/Issue223.agda: -------------------------------------------------------------------------------- 1 | module Fail.Issue223 where 2 | 3 | open import Haskell.Prim using (Type) 4 | 5 | data Void : Type where 6 | {-# COMPILE AGDA2HS Void #-} 7 | 8 | test : {a : Type} → Void → a 9 | test () 10 | {-# COMPILE AGDA2HS test #-} 11 | -------------------------------------------------------------------------------- /test/Fail/Issue357a.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | open import Agda.Primitive 3 | 4 | module Fail.Issue357a where 5 | 6 | k : a → b → a 7 | k x _ = x 8 | {-# COMPILE AGDA2HS k #-} 9 | 10 | testK : Nat 11 | testK = k 42 lzero 12 | {-# COMPILE AGDA2HS testK #-} 13 | -------------------------------------------------------------------------------- /test/Fail/Issue357b.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | open import Agda.Primitive 3 | 4 | module Fail.Issue357b where 5 | 6 | k : a → b → a 7 | k x _ = x 8 | {-# COMPILE AGDA2HS k #-} 9 | 10 | l : Level → Nat 11 | l = k 42 12 | {-# COMPILE AGDA2HS l #-} 13 | 14 | testK : Nat 15 | testK = l lzero 16 | {-# COMPILE AGDA2HS testK #-} 17 | -------------------------------------------------------------------------------- /test/Fail/Issue71.agda: -------------------------------------------------------------------------------- 1 | module Fail.Issue71 where 2 | 3 | open import Haskell.Prelude 4 | 5 | scanrList : (a → b → b) → b → List a → List b 6 | scanrList f z [] = z ∷ [] 7 | scanrList f z (x ∷ xs) = 8 | case scanrList f z xs of λ { 9 | [] -> [] 10 | ; qs@(q ∷ _) -> f x q ∷ qs 11 | } 12 | {-# COMPILE AGDA2HS scanrList #-} 13 | -------------------------------------------------------------------------------- /test/Fail/MatchOnDelay.agda: -------------------------------------------------------------------------------- 1 | 2 | module Fail.MatchOnDelay where 3 | 4 | open import Haskell.Prelude 5 | open import Haskell.Extra.Delay 6 | 7 | bad : Delay a ∞ → Bool 8 | bad (now x) = True 9 | bad (later x) = False 10 | 11 | {-# COMPILE AGDA2HS bad #-} 12 | -------------------------------------------------------------------------------- /test/Fail/MultiArgumentPatternLambda.agda: -------------------------------------------------------------------------------- 1 | 2 | module Fail.MultiArgumentPatternLambda where 3 | 4 | open import Agda.Builtin.Bool 5 | 6 | tooManyPats : Bool → Bool → Bool 7 | tooManyPats = λ where false false → false 8 | true true → false 9 | _ _ → true 10 | {-# COMPILE AGDA2HS tooManyPats #-} 11 | -------------------------------------------------------------------------------- /test/Fail/NewTypeRecordTwoFields.agda: -------------------------------------------------------------------------------- 1 | module Fail.NewTypeRecordTwoFields where 2 | 3 | open import Haskell.Prelude 4 | 5 | record Duo (a b : Type) : Type where 6 | constructor MkDuo 7 | field 8 | left : a 9 | right : b 10 | open Duo public 11 | 12 | {-# COMPILE AGDA2HS Duo newtype #-} 13 | 14 | -------------------------------------------------------------------------------- /test/Fail/NewTypeTwoConstructors.agda: -------------------------------------------------------------------------------- 1 | module Fail.NewTypeTwoConstructors where 2 | 3 | open import Haskell.Prelude 4 | 5 | data Choice (a b : Type) : Type where 6 | A : a → Choice a b 7 | B : b → Choice a b 8 | 9 | {-# COMPILE AGDA2HS Choice newtype #-} 10 | 11 | -------------------------------------------------------------------------------- /test/Fail/NewTypeTwoFields.agda: -------------------------------------------------------------------------------- 1 | module Fail.NewTypeTwoFields where 2 | 3 | open import Haskell.Prelude 4 | 5 | data Duo (a b : Type) : Type where 6 | MkDuo : a → b → Duo a b 7 | 8 | {-# COMPILE AGDA2HS Duo newtype #-} 9 | 10 | -------------------------------------------------------------------------------- /test/Fail/NonCanonicalSpecialFunction.agda: -------------------------------------------------------------------------------- 1 | module Fail.NonCanonicalSpecialFunction where 2 | 3 | open import Haskell.Prelude 4 | 5 | sneaky : Enum Int 6 | Enum.BoundedBelowEnum sneaky = Just (record { minBound = 42 }) 7 | Enum.BoundedAboveEnum sneaky = Just (record { maxBound = 42 }) 8 | Enum.fromEnum sneaky = λ _ → 42 9 | Enum.toEnum sneaky = λ _ → 42 10 | Enum.succ sneaky = λ _ → 42 11 | Enum.pred sneaky = λ _ → 42 12 | Enum.enumFrom sneaky = λ _ → [] 13 | Enum.enumFromTo sneaky = λ _ _ → [] 14 | Enum.enumFromThenTo sneaky = λ _ _ _ → [] 15 | Enum.enumFromThen sneaky = λ _ _ → [] 16 | 17 | test : List Int 18 | test = enumFrom {{sneaky}} 5 19 | 20 | proof : test ≡ [] 21 | proof = refl 22 | 23 | {-# COMPILE AGDA2HS test #-} 24 | -------------------------------------------------------------------------------- /test/Fail/NonCanonicalSuperclass.agda: -------------------------------------------------------------------------------- 1 | 2 | module Fail.NonCanonicalSuperclass where 3 | 4 | open import Haskell.Prelude 5 | 6 | record Class (a : Type) : Type where 7 | field 8 | foo : a → a 9 | open Class {{...}} public 10 | 11 | {-# COMPILE AGDA2HS Class class #-} 12 | 13 | instance 14 | ClassBool : Class Bool 15 | ClassBool .foo = not 16 | 17 | {-# COMPILE AGDA2HS ClassBool #-} 18 | 19 | record Subclass (a : Type) : Type where 20 | field 21 | overlap {{super}} : Class a 22 | bar : a 23 | open Subclass {{...}} public 24 | 25 | {-# COMPILE AGDA2HS Subclass class #-} 26 | 27 | instance 28 | SubclassBool : Subclass Bool 29 | SubclassBool .super = record { foo = id } 30 | SubclassBool .bar = False 31 | 32 | {-# COMPILE AGDA2HS SubclassBool #-} 33 | -------------------------------------------------------------------------------- /test/Fail/NonCopatternInstance.agda: -------------------------------------------------------------------------------- 1 | 2 | module Fail.NonCopatternInstance where 3 | 4 | open import Haskell.Prim using (Type) 5 | 6 | record HasId (a : Type) : Type where 7 | field id : a → a 8 | 9 | open HasId ⦃ ... ⦄ 10 | 11 | {-# COMPILE AGDA2HS HasId class #-} 12 | 13 | data Unit : Type where 14 | MkUnit : Unit 15 | 16 | {-# COMPILE AGDA2HS Unit #-} 17 | 18 | instance 19 | UnitHasId : HasId Unit 20 | UnitHasId = r -- NOT CORRECT 21 | where r = record {id = λ x → x} 22 | -- UnitHasId .id x = x -- CORRECT 23 | -- UnitHasId = record {id = λ x → x} -- CORRECT 24 | 25 | {-# COMPILE AGDA2HS UnitHasId #-} 26 | -------------------------------------------------------------------------------- /test/Fail/NonStarDatatypeIndex.agda: -------------------------------------------------------------------------------- 1 | module Fail.NonStarDatatypeIndex where 2 | 3 | open import Haskell.Prelude 4 | 5 | data T (n : Nat) : Type where 6 | MkT : T n 7 | {-# COMPILE AGDA2HS T #-} 8 | -------------------------------------------------------------------------------- /test/Fail/NonStarRecordIndex.agda: -------------------------------------------------------------------------------- 1 | module Fail.NonStarRecordIndex where 2 | 3 | open import Haskell.Prelude 4 | 5 | record T (n : Nat) : Type where 6 | field 7 | Tb : Bool 8 | {-# COMPILE AGDA2HS T #-} 9 | -------------------------------------------------------------------------------- /test/Fail/PartialCase.agda: -------------------------------------------------------------------------------- 1 | module Fail.PartialCase where 2 | 3 | open import Haskell.Prelude 4 | 5 | caseOf : (i : Int) → ((i' : Int) → @0 {{ i ≡ i' }} → Nat) → Nat 6 | caseOf = case_of_ 7 | {-# COMPILE AGDA2HS caseOf #-} 8 | -------------------------------------------------------------------------------- /test/Fail/PartialCaseNoLambda.agda: -------------------------------------------------------------------------------- 1 | module Fail.PartialCaseNoLambda where 2 | 3 | open import Haskell.Prelude 4 | 5 | applyToFalse : ((b : Bool) → @0 {{ False ≡ b }} → Int) → Int 6 | applyToFalse = case False of_ 7 | {-# COMPILE AGDA2HS applyToFalse #-} 8 | -------------------------------------------------------------------------------- /test/Fail/PartialIf.agda: -------------------------------------------------------------------------------- 1 | module Fail.PartialIf where 2 | 3 | open import Haskell.Prelude 4 | 5 | if_partial : (flg : Bool) → (@0 {{ flg ≡ True }} → Nat) → (@0 {{ flg ≡ False }} → Nat) → Nat 6 | if_partial = if_then_else_ 7 | {-# COMPILE AGDA2HS if_partial #-} 8 | -------------------------------------------------------------------------------- /test/Fail/QualifiedRecordProjections.agda: -------------------------------------------------------------------------------- 1 | module Fail.QualifiedRecordProjections where 2 | 3 | open import Haskell.Prim using (Type) 4 | 5 | record Test (a : Type) : Type where 6 | field 7 | one : a 8 | 9 | {-# COMPILE AGDA2HS Test #-} 10 | -------------------------------------------------------------------------------- /test/Fail/TypeLambda.agda: -------------------------------------------------------------------------------- 1 | 2 | module Fail.TypeLambda where 3 | 4 | open import Haskell.Prelude 5 | 6 | foo : (f : (Type → Type) → Type) (x : f (λ y → Nat)) (y : f List) → Nat 7 | foo f x y = 42 8 | 9 | {-# COMPILE AGDA2HS foo #-} 10 | -------------------------------------------------------------------------------- /test/Fixities.agda: -------------------------------------------------------------------------------- 1 | 2 | module Fixities where 3 | 4 | open import Haskell.Prelude 5 | 6 | leftAssoc : Int → List Int 7 | leftAssoc n = 2 * n + 1 8 | ∷ 2 * (n + 1) 9 | ∷ 1 + n * 2 10 | ∷ (1 + n) * 2 11 | ∷ (n + n) + n 12 | ∷ n + (n + n) 13 | ∷ [] 14 | 15 | rightAssoc : List Int → List Int 16 | rightAssoc xs = xs ++ xs ++ ((xs ++ xs) ++ xs) ++ xs 17 | 18 | nonAssoc : Bool → Bool 19 | nonAssoc b = (b == b) == (b == b) 20 | 21 | mixedAssoc : Maybe Int → (Int → Maybe Int) → Maybe Int 22 | mixedAssoc m f = f =<< (((f =<< m) >>= f) >>= f) 23 | 24 | {-# COMPILE AGDA2HS leftAssoc #-} 25 | {-# COMPILE AGDA2HS rightAssoc #-} 26 | {-# COMPILE AGDA2HS nonAssoc #-} 27 | {-# COMPILE AGDA2HS mixedAssoc #-} 28 | 29 | infixl 7 _<+>_ 30 | _<+>_ : Int → Int → Int 31 | x <+> y = x + y 32 | 33 | {-# COMPILE AGDA2HS _<+>_ #-} 34 | 35 | infixr 8 _<->_ 36 | _<->_ : Int → Int → Int 37 | x <-> y = x - y 38 | 39 | {-# COMPILE AGDA2HS _<->_ #-} 40 | -------------------------------------------------------------------------------- /test/FunCon.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | data D1 (t : Type → Type) : Type where 5 | C1 : t Bool → D1 t 6 | 7 | {-# COMPILE AGDA2HS D1 #-} 8 | 9 | f1 : D1 (λ a → Int → a) 10 | f1 = C1 (_== 0) 11 | 12 | {-# COMPILE AGDA2HS f1 #-} 13 | 14 | data D2 (t : Type → Type → Type) : Type where 15 | C2 : t Int Int → D2 t 16 | 17 | {-# COMPILE AGDA2HS D2 #-} 18 | 19 | f2 : D2 (λ a b → a → b) 20 | f2 = C2 (_+ 1) 21 | 22 | {-# COMPILE AGDA2HS f2 #-} 23 | -------------------------------------------------------------------------------- /test/Haskell/Data/ByteString.agda: -------------------------------------------------------------------------------- 1 | module Haskell.Data.ByteString where 2 | 3 | open import Haskell.Prelude 4 | 5 | postulate 6 | ByteString : Type 7 | 8 | instance 9 | iEqByteString : Eq ByteString 10 | -------------------------------------------------------------------------------- /test/HeightMirror.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude hiding (max) 3 | open import Haskell.Law.Equality hiding (subst) 4 | 5 | subst : {p : @0 a → Type} {@0 m n : a} → @0 m ≡ n → p m → p n 6 | subst refl t = t 7 | 8 | {-# COMPILE AGDA2HS subst transparent #-} 9 | 10 | max : Nat → Nat → Nat 11 | max zero n = n 12 | max (suc m) zero = suc m 13 | max (suc m) (suc n) = suc (max m n) 14 | 15 | data Tree (a : Type) : (@0 height : Nat) → Type where 16 | Tip : Tree a 0 17 | Bin : ∀ {@0 l r} (x : a) → Tree a l → Tree a r → Tree a (suc (max l r)) 18 | 19 | {-# COMPILE AGDA2HS Tree #-} 20 | 21 | @0 max-comm : (@0 l r : Nat) → max l r ≡ max r l 22 | max-comm zero zero = refl 23 | max-comm zero (suc r) = refl 24 | max-comm (suc l) zero = refl 25 | max-comm (suc l) (suc r) = cong suc (max-comm l r) 26 | 27 | mirror : ∀ {@0 h} → Tree a h → Tree a h 28 | mirror Tip = Tip 29 | mirror {a = a} (Bin {l} {r} x lt rt) = 30 | subst {p = Tree a} (cong suc (max-comm r l)) (Bin x (mirror rt) (mirror lt)) 31 | 32 | {-# COMPILE AGDA2HS mirror #-} 33 | -------------------------------------------------------------------------------- /test/IOFile.agda: -------------------------------------------------------------------------------- 1 | module IOFile where 2 | 3 | open import Haskell.Prelude 4 | 5 | main : IO ⊤ 6 | main = do file ← readFile "IOFile.agda" 7 | writeFile "IOFile2.agda" file 8 | appendFile "IOFile2.agda" "-- Written by appendFile" 9 | file2 ← readFile "IOFile2.agda" 10 | print file2 11 | return tt 12 | 13 | {-# COMPILE AGDA2HS main #-} 14 | -------------------------------------------------------------------------------- /test/IOInput.agda: -------------------------------------------------------------------------------- 1 | module IOInput where 2 | 3 | open import Haskell.Prelude 4 | 5 | main : IO ⊤ 6 | main = do putStrLn "Write something " 7 | x ← getLine 8 | putStr $ "You wrote: " ++ x 9 | return tt 10 | 11 | {-# COMPILE AGDA2HS main #-} 12 | -------------------------------------------------------------------------------- /test/Importee.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | foo : Int 4 | foo = 42 5 | {-# COMPILE AGDA2HS foo #-} 6 | 7 | _!#_ : Int → Int → Int 8 | x !# y = x + y 9 | {-# COMPILE AGDA2HS _!#_ #-} 10 | 11 | data Foo : Type where 12 | MkFoo : Foo 13 | {-# COMPILE AGDA2HS Foo #-} 14 | 15 | -- ** base 16 | record Fooable (a : Type) : Type where 17 | field doTheFoo defaultFoo : a 18 | -- ** defaults 19 | record DefaultFooable (a : Type) : Type where 20 | field doTheFoo : a 21 | 22 | defaultFoo : a 23 | defaultFoo = doTheFoo 24 | -- ** export 25 | open Fooable ⦃...⦄ public 26 | {-# COMPILE AGDA2HS Fooable class DefaultFooable #-} 27 | -- ** instances 28 | instance 29 | FF : Fooable Foo 30 | FF = record {DefaultFooable (λ where .doTheFoo → MkFoo)} 31 | where open DefaultFooable 32 | {-# COMPILE AGDA2HS FF #-} 33 | 34 | open import SecondImportee public 35 | -------------------------------------------------------------------------------- /test/Importer.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | {-# FOREIGN AGDA2HS 4 | -- ** simple imports (possibly with transitive dependencies) 5 | #-} 6 | 7 | open import Importee 8 | open import OtherImportee using (MkFoo) 9 | 10 | bar : Int 11 | bar = foo 12 | {-# COMPILE AGDA2HS bar #-} 13 | 14 | anotherBar : Int 15 | anotherBar = anotherFoo 16 | {-# COMPILE AGDA2HS anotherBar #-} 17 | 18 | baz : Int 19 | baz = 21 !# 21 20 | {-# COMPILE AGDA2HS baz #-} 21 | 22 | mkFoo : Foo 23 | mkFoo = MkFoo -- This is MkFoo from Importee, NOT from OtherImportee!! 24 | {-# COMPILE AGDA2HS mkFoo #-} 25 | 26 | fooable : Foo 27 | fooable = doTheFoo 28 | {-# COMPILE AGDA2HS fooable #-} 29 | 30 | {-# FOREIGN AGDA2HS 31 | -- ** interplay with class default methods 32 | #-} 33 | 34 | defaultBar : Foo 35 | defaultBar = defaultFoo 36 | {-# COMPILE AGDA2HS defaultBar #-} 37 | 38 | {-# FOREIGN AGDA2HS 39 | -- ** interplay with methods of existing class 40 | #-} 41 | 42 | testFoldMap : List Nat → List Nat 43 | testFoldMap = foldMap _∷_ [] 44 | {-# COMPILE AGDA2HS testFoldMap #-} 45 | 46 | {-# FOREIGN AGDA2HS 47 | -- ** interplay with default methods of existing class 48 | #-} 49 | 50 | testFoldr : List Nat → Nat 51 | testFoldr = foldr (λ _ x → x) 0 52 | {-# COMPILE AGDA2HS testFoldr #-} 53 | -------------------------------------------------------------------------------- /test/Inlining.agda: -------------------------------------------------------------------------------- 1 | module Inlining where 2 | 3 | open import Haskell.Prelude 4 | 5 | Alias : Type 6 | Alias = Bool 7 | {-# COMPILE AGDA2HS Alias inline #-} 8 | 9 | aliased : Alias 10 | aliased = True 11 | {-# COMPILE AGDA2HS aliased #-} 12 | 13 | record Wrap (a : Type) : Type where 14 | constructor Wrapped 15 | field 16 | unwrap : a 17 | open Wrap public 18 | {-# COMPILE AGDA2HS Wrap unboxed #-} 19 | 20 | mapWrap : (f : a → b) → Wrap a → Wrap b 21 | mapWrap f (Wrapped x) = Wrapped (f x) 22 | {-# COMPILE AGDA2HS mapWrap inline #-} 23 | 24 | mapWrap2 : (f : a → b → c) → Wrap a → Wrap b → Wrap c 25 | mapWrap2 f (Wrapped x) (Wrapped y) = Wrapped (f x y) 26 | {-# COMPILE AGDA2HS mapWrap2 inline #-} 27 | 28 | test1 : Wrap Int → Wrap Int 29 | test1 x = mapWrap (1 +_) x 30 | {-# COMPILE AGDA2HS test1 #-} 31 | 32 | test2 : Wrap Int → Wrap Int → Wrap Int 33 | test2 x y = mapWrap2 _+_ x y 34 | {-# COMPILE AGDA2HS test2 #-} 35 | 36 | -- partial application of inline function 37 | test3 : Wrap Int → Wrap Int → Wrap Int 38 | test3 x = mapWrap2 _+_ x 39 | {-# COMPILE AGDA2HS test3 #-} 40 | 41 | test4 : Wrap Int → Wrap Int → Wrap Int 42 | test4 = mapWrap2 _+_ 43 | {-# COMPILE AGDA2HS test4 #-} 44 | -------------------------------------------------------------------------------- /test/Issue107.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | testMax : (x y : Nat) → max (suc x) (suc y) ≡ suc (max x y) 5 | testMax x y = refl 6 | 7 | testMin : (x y : Nat) → min (suc x) (suc y) ≡ suc (min x y) 8 | testMin x y = refl 9 | -------------------------------------------------------------------------------- /test/Issue115.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prim using (Type) 2 | 3 | record Pointed (a : Type) : Type where 4 | field 5 | it : a 6 | open Pointed {{...}} public 7 | {-# COMPILE AGDA2HS Pointed class #-} 8 | 9 | data A : Type where A1 : A 10 | {-# COMPILE AGDA2HS A #-} 11 | 12 | instance 13 | iPointedA : Pointed A 14 | iPointedA .it = A1 15 | {-# COMPILE AGDA2HS iPointedA #-} 16 | 17 | data Delay (a : Type) : Type where 18 | Later : Delay a → Delay a 19 | Now : a → Delay a 20 | {-# COMPILE AGDA2HS Delay #-} 21 | 22 | test : Delay A 23 | test = Later λ where → Now it 24 | {-# COMPILE AGDA2HS test #-} 25 | -------------------------------------------------------------------------------- /test/Issue14.agda: -------------------------------------------------------------------------------- 1 | 2 | module Issue14 where 3 | 4 | open import Haskell.Prelude 5 | 6 | -- Wrong name for shadowed lambda 7 | constid : a → b → b 8 | constid x = λ x → x 9 | 10 | {-# COMPILE AGDA2HS constid #-} 11 | 12 | sectionTest₁ : Nat → Nat → Nat 13 | sectionTest₁ n = _+ n 14 | 15 | sectionTest₂ : Nat → Nat → Nat 16 | sectionTest₂ section = _+ section 17 | 18 | {-# COMPILE AGDA2HS sectionTest₁ #-} 19 | {-# COMPILE AGDA2HS sectionTest₂ #-} 20 | -------------------------------------------------------------------------------- /test/Issue145.agda: -------------------------------------------------------------------------------- 1 | module Issue145 where 2 | 3 | open import Haskell.Prelude 4 | open import Haskell.Prim.Strict 5 | 6 | -- ** PASS 7 | 8 | module _ {a : Type} where 9 | it : a → a 10 | it x = x 11 | {-# COMPILE AGDA2HS it #-} 12 | 13 | it' : ⦃ Monoid a ⦄ → a → a 14 | it' x = x 15 | {-# COMPILE AGDA2HS it' #-} 16 | 17 | data Ok' {ℓ} (a : Type ℓ) : Type ℓ where 18 | Thing' : Strict a → Ok' a 19 | {-# COMPILE AGDA2HS Ok' #-} 20 | 21 | -- ** FAIL 22 | 23 | data Ok {a : Type} : Type where 24 | Thing : a → Ok 25 | {-# COMPILE AGDA2HS Ok #-} 26 | 27 | test : Ok 28 | test = Thing "ok" 29 | {-# COMPILE AGDA2HS test #-} 30 | -------------------------------------------------------------------------------- /test/Issue169.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | record Identity (a : Type) : Type where 4 | field 5 | runIdentity : a 6 | open Identity public 7 | 8 | {-# COMPILE AGDA2HS Identity newtype #-} 9 | 10 | showIdentity : ⦃ Show a ⦄ → Identity a → String 11 | showIdentity record { runIdentity = id } = "Id < " ++ show id ++ " >" 12 | 13 | {-# COMPILE AGDA2HS showIdentity #-} 14 | 15 | instance 16 | iIdentityShow : ⦃ Show a ⦄ → Show (Identity a) 17 | iIdentityShow = record {Show₂ (λ where .Show₂.show → showIdentity)} 18 | 19 | {-# COMPILE AGDA2HS iIdentityShow #-} 20 | -------------------------------------------------------------------------------- /test/Issue200.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | data Void : Type where 4 | 5 | test : Maybe Void → Maybe Void 6 | test = λ 7 | { Nothing → Nothing 8 | } 9 | 10 | {-# COMPILE AGDA2HS Void #-} 11 | {-# COMPILE AGDA2HS test #-} 12 | -------------------------------------------------------------------------------- /test/Issue210.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude hiding (f) 2 | 3 | record Test (a : Type) : Type₁ where 4 | field 5 | f : a -> a 6 | open Test {{...}} public 7 | {-# COMPILE AGDA2HS Test class #-} 8 | 9 | instance 10 | testNat : Test Nat 11 | Test.f testNat n = h 12 | where 13 | g : Nat 14 | g = 3 + n 15 | h : Nat 16 | h = n + g 17 | {-# COMPILE AGDA2HS testNat #-} 18 | 19 | f1 : Nat -> Nat 20 | f1 n = h1 21 | where 22 | g1 : Nat 23 | g1 = 3 + n 24 | h1 : Nat 25 | h1 = n + g1 26 | {-# COMPILE AGDA2HS f1 #-} 27 | 28 | f2 : Nat -> Nat 29 | f2 n = h2 n 30 | where 31 | g2 : Nat 32 | g2 = 3 + n 33 | h2 : Nat -> Nat 34 | h2 m = n + g2 + m 35 | {-# COMPILE AGDA2HS f2 #-} 36 | -------------------------------------------------------------------------------- /test/Issue218.agda: -------------------------------------------------------------------------------- 1 | 2 | module Issue218 where 3 | 4 | open import Haskell.Prelude 5 | open import Haskell.Extra.Erase 6 | open import Haskell.Extra.Refinement 7 | 8 | module _ (@0 n : Int) where 9 | 10 | foo : {{Rezz n}} → ∃ Int (_≡ n) 11 | foo {{rezz n}} = n ⟨ refl ⟩ 12 | 13 | {-# COMPILE AGDA2HS foo #-} 14 | 15 | bar : ∃ Int (_≡ 42) 16 | bar = foo _ 17 | 18 | {-# COMPILE AGDA2HS bar #-} 19 | -------------------------------------------------------------------------------- /test/Issue251.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | instance 4 | favoriteNumber : Int 5 | favoriteNumber = 42 6 | {-# COMPILE AGDA2HS favoriteNumber inline #-} 7 | 8 | get : {{Int}} → Int 9 | get {{x}} = x 10 | {-# COMPILE AGDA2HS get #-} 11 | 12 | test : Int 13 | test = get 14 | {-# COMPILE AGDA2HS test #-} 15 | -------------------------------------------------------------------------------- /test/Issue257.agda: -------------------------------------------------------------------------------- 1 | module Issue257 where 2 | 3 | open import Haskell.Prelude 4 | 5 | record Wrap : Type where 6 | field int : Integer 7 | {-# COMPILE AGDA2HS Wrap unboxed #-} 8 | -------------------------------------------------------------------------------- /test/Issue264.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prim using (Type) 2 | 3 | module Issue264 (@0 name : Type) where 4 | 5 | data Term : @0 Type → Type where 6 | Dummy : Term name 7 | 8 | {-# COMPILE AGDA2HS Term #-} 9 | 10 | reduce : Term name → Term name 11 | reduce v = go v 12 | where 13 | go : Term name → Term name 14 | go v = v 15 | 16 | {-# COMPILE AGDA2HS reduce #-} 17 | -------------------------------------------------------------------------------- /test/Issue273.agda: -------------------------------------------------------------------------------- 1 | module Issue273 where 2 | 3 | open import Haskell.Prelude 4 | 5 | test : Int × Int → Int 6 | test = λ x → snd $ x 7 | {-# COMPILE AGDA2HS test #-} 8 | 9 | mySnd : Int × Int → Int 10 | mySnd x = snd x 11 | {-# COMPILE AGDA2HS mySnd #-} 12 | 13 | test2 : Int × Int → Int 14 | test2 = λ x → mySnd $ x 15 | {-# COMPILE AGDA2HS test2 #-} 16 | 17 | test3 : Int × Int → Int 18 | test3 = λ x → snd x 19 | {-# COMPILE AGDA2HS test3 #-} 20 | 21 | test4 : Int × Int → Int 22 | test4 = λ x → mySnd x 23 | {-# COMPILE AGDA2HS test4 #-} 24 | 25 | test5 : Int × Int → Int → Int 26 | test5 = λ x _ → snd $ x 27 | {-# COMPILE AGDA2HS test5 #-} 28 | 29 | test6 : Int → Int 30 | test6 = _- (1 + 1) 31 | {-# COMPILE AGDA2HS test6 #-} 32 | 33 | test7 : Int → Int 34 | test7 = _+ (1 - 1) 35 | {-# COMPILE AGDA2HS test7 #-} 36 | -------------------------------------------------------------------------------- /test/Issue286.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | instance 4 | favoriteNumber : Int 5 | favoriteNumber = 42 6 | {-# COMPILE AGDA2HS favoriteNumber inline #-} 7 | 8 | get : {{Int}} → Int 9 | get {{x}} = x 10 | {-# COMPILE AGDA2HS get inline #-} 11 | 12 | test : Int 13 | test = get 14 | {-# COMPILE AGDA2HS test #-} 15 | -------------------------------------------------------------------------------- /test/Issue301.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | open import Haskell.Prim.Monoid 4 | open import Haskell.Prim.Foldable 5 | 6 | data MyData (a : Type) : Type where 7 | Nuttin' : MyData a 8 | {-# COMPILE AGDA2HS MyData #-} 9 | 10 | -- notice this does not occur with other classes such as Foldable 11 | myDataDefaultFoldable : DefaultFoldable MyData 12 | DefaultFoldable.foldMap myDataDefaultFoldable _ _ = mempty 13 | 14 | instance 15 | MyDataFoldable : Foldable MyData 16 | MyDataFoldable = record {DefaultFoldable myDataDefaultFoldable} 17 | {-# COMPILE AGDA2HS MyDataFoldable #-} 18 | 19 | -- need to create instance for semigroup first 20 | -- (requires explicitly typed function AFAICT) 21 | _><_ : {a : Type} -> MyData a -> MyData a -> MyData a 22 | _ >< _ = Nuttin' 23 | {-# COMPILE AGDA2HS _><_ #-} 24 | 25 | instance 26 | MyDataSemigroup : Semigroup (MyData a) 27 | MyDataSemigroup ._<>_ = _><_ 28 | {-# COMPILE AGDA2HS MyDataSemigroup #-} 29 | 30 | instance 31 | myDataDefaultMonoid : DefaultMonoid (MyData a) 32 | DefaultMonoid.mempty myDataDefaultMonoid = Nuttin' 33 | 34 | instance 35 | MyDataMonoid : Monoid (MyData a) 36 | MyDataMonoid = record {DefaultMonoid myDataDefaultMonoid} 37 | {-# COMPILE AGDA2HS MyDataMonoid #-} 38 | -------------------------------------------------------------------------------- /test/Issue302.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | not0 : Int → Bool 4 | not0 n = n /= 0 5 | {-# COMPILE AGDA2HS not0 #-} 6 | -------------------------------------------------------------------------------- /test/Issue305.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | module Issue305 (@0 X : Type) where 4 | 5 | record Class (a : Type) : Type where 6 | field 7 | foo : a → a 8 | open Class {{...}} public 9 | 10 | {-# COMPILE AGDA2HS Class class #-} 11 | 12 | instance 13 | ClassInt : Class Int 14 | ClassInt .foo = _+ 1 15 | 16 | {-# COMPILE AGDA2HS ClassInt #-} 17 | 18 | instance 19 | ClassBool : Class Bool 20 | ClassBool .foo = not 21 | 22 | {-# COMPILE AGDA2HS ClassBool #-} 23 | 24 | test : Int 25 | test = foo 41 26 | 27 | {-# COMPILE AGDA2HS test #-} 28 | 29 | anotherTest : Int 30 | anotherTest = test 31 | 32 | {-# COMPILE AGDA2HS anotherTest #-} 33 | 34 | yetAnotherTest : Int 35 | yetAnotherTest = case Just True of λ where 36 | Nothing → error "unreachable" 37 | (Just y) → foo 5 38 | {-# COMPILE AGDA2HS yetAnotherTest #-} 39 | 40 | andOneMoreTest : Int → Int 41 | andOneMoreTest x = foo 5 42 | {-# COMPILE AGDA2HS andOneMoreTest #-} 43 | 44 | record Subclass (a : Type) : Type where 45 | field 46 | overlap {{super}} : Class a 47 | bar : a 48 | open Subclass {{...}} public 49 | 50 | {-# COMPILE AGDA2HS Subclass class #-} 51 | 52 | instance 53 | SubclassBool : Subclass Bool 54 | SubclassBool .super = ClassBool 55 | SubclassBool .bar = False 56 | 57 | {-# COMPILE AGDA2HS SubclassBool #-} 58 | -------------------------------------------------------------------------------- /test/Issue308.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | record Class (a : Type) : Type where 4 | field 5 | foo : a → a 6 | open Class {{...}} public 7 | {-# COMPILE AGDA2HS Class class #-} 8 | 9 | module M1 (@0 X : Type) where 10 | 11 | instance 12 | ClassInt : Class Int 13 | ClassInt .foo = _+ 1 14 | {-# COMPILE AGDA2HS ClassInt #-} 15 | 16 | module M2 (@0 X : Type) where 17 | 18 | open M1 X 19 | 20 | tester : Int 21 | tester = foo 41 22 | {-# COMPILE AGDA2HS tester #-} 23 | -------------------------------------------------------------------------------- /test/Issue309.agda: -------------------------------------------------------------------------------- 1 | module Issue309 where 2 | 3 | open import Haskell.Prim using (Type) 4 | 5 | private variable @0 a : Type 6 | 7 | Ap : (p : @0 a → Type) → @0 a → Type 8 | Ap p x = p x 9 | {-# COMPILE AGDA2HS Ap #-} 10 | -------------------------------------------------------------------------------- /test/Issue317.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | record D : Type where 4 | constructor C 5 | field unC : Int 6 | open D public 7 | {-# COMPILE AGDA2HS D #-} 8 | 9 | test : D → D 10 | test d = C ∘ unC $ d 11 | {-# COMPILE AGDA2HS test #-} 12 | -------------------------------------------------------------------------------- /test/Issue324.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | open import Issue324instance 4 | 5 | test : Bool 6 | test = not == id 7 | 8 | {-# COMPILE AGDA2HS test #-} 9 | -------------------------------------------------------------------------------- /test/Issue324instance.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | instance 5 | eqBoolFun : Eq (Bool → Bool) 6 | eqBoolFun ._==_ x y = x True == y True && x False == y False 7 | 8 | {-# COMPILE AGDA2HS eqBoolFun #-} 9 | 10 | -------------------------------------------------------------------------------- /test/Issue353.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | module Issue353 where 4 | -- Calling functions between local anonymous modules removed arguments 5 | 6 | module FooBar (a : Bool) where 7 | hello : Bool 8 | hello = a 9 | {-# COMPILE AGDA2HS hello #-} 10 | 11 | module Foo (a : Bool) where 12 | -- If the name of the current module is a prefix of the called module 13 | -- they would be interpreted as the same module 14 | world : Bool 15 | world = FooBar.hello a 16 | {-# COMPILE AGDA2HS world #-} 17 | 18 | open FooBar a 19 | world2 : Bool 20 | world2 = hello 21 | {-# COMPILE AGDA2HS world2 #-} 22 | 23 | module _ (a : Bool) (b : Int) where 24 | foo : Bool 25 | foo = not a 26 | {-# COMPILE AGDA2HS foo #-} 27 | 28 | module _ (b : Bool) where 29 | 30 | bar : Bool 31 | bar = foo True 0 32 | {-# COMPILE AGDA2HS bar #-} 33 | 34 | baz : Bool 35 | baz = bar 36 | {-# COMPILE AGDA2HS baz #-} 37 | 38 | callFromNested : Bool 39 | callFromNested = nested 40 | where nested = bar 41 | {-# COMPILE AGDA2HS callFromNested #-} 42 | 43 | -- The check is needed both for instance declarations and where-clauses 44 | -------------------------------------------------------------------------------- /test/Issue377.agda: -------------------------------------------------------------------------------- 1 | module Issue377 where 2 | 3 | open import Haskell.Prelude 4 | open import Haskell.Data.Maybe 5 | 6 | test : Integer 7 | test = fromMaybe 0 (Just 12) 8 | 9 | {-# COMPILE AGDA2HS test #-} 10 | -------------------------------------------------------------------------------- /test/Issue394.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | open import Haskell.Data.ByteString using (ByteString) 4 | 5 | test : ByteString → ByteString → Bool 6 | test x y = x == y 7 | 8 | {-# COMPILE AGDA2HS test #-} 9 | -------------------------------------------------------------------------------- /test/Issue65.agda: -------------------------------------------------------------------------------- 1 | 2 | module Issue65 where 3 | 4 | open import Haskell.Prelude 5 | 6 | yeet : (c : Bool) → (@0 {{c ≡ True}} → a) → (@0 {{c ≡ False}} → a) → a 7 | yeet False x y = y {{refl}} 8 | yeet True x y = x {{refl}} 9 | {-# COMPILE AGDA2HS yeet #-} 10 | 11 | -- The branches start with instance lambdas that should be dropped. 12 | xx : Int 13 | xx = yeet True 1 2 14 | {-# COMPILE AGDA2HS xx #-} 15 | -------------------------------------------------------------------------------- /test/Issue69.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | mutual 4 | 5 | data Map (k : Type) (a : Type) : Type where 6 | Bin : (sz : Nat) → (kx : k) → (x : a) 7 | → (l : Map k a) → (r : Map k a) 8 | → {{@0 szVal : sz ≡ (size l) + (size r) + 1}} 9 | → Map k a 10 | Tip : Map k a 11 | {-# COMPILE AGDA2HS Map #-} 12 | 13 | size : {k a : Type} → Map k a → Nat 14 | size Tip = 0 15 | size (Bin sz _ _ _ _) = sz 16 | {-# COMPILE AGDA2HS size #-} 17 | -------------------------------------------------------------------------------- /test/Issue73.agda: -------------------------------------------------------------------------------- 1 | module Issue73 where 2 | 3 | open import Haskell.Prim using (Type) 4 | 5 | record ImplicitField (a : Type) : Type where 6 | field 7 | aField : a 8 | @0 {anImplicitField} : a 9 | open ImplicitField public 10 | {-# COMPILE AGDA2HS ImplicitField class #-} 11 | -------------------------------------------------------------------------------- /test/Issue90.agda: -------------------------------------------------------------------------------- 1 | module Issue90 where 2 | 3 | open import Haskell.Prelude 4 | 5 | good : Nat 6 | good = bar 7 | where 8 | foo : Nat 9 | foo = 42 10 | 11 | bar : Nat 12 | bar = foo 13 | {-# COMPILE AGDA2HS good #-} 14 | 15 | bad : Nat 16 | bad = bar 17 | where 18 | bar : Nat 19 | foo : Nat 20 | bar = foo 21 | foo = 42 22 | {-# COMPILE AGDA2HS bad #-} 23 | 24 | good2 : Nat 25 | good2 = bar 26 | where 27 | foo : Nat 28 | foo = 42 + x 29 | where 30 | x : Nat 31 | x = 1 32 | bar : Nat 33 | bar = foo + x 34 | where 35 | x : Nat 36 | x = 2 37 | {-# COMPILE AGDA2HS good2 #-} 38 | 39 | bad2 : Nat 40 | bad2 = bar 41 | where 42 | bar : Nat 43 | foo : Nat 44 | foo = 42 + x 45 | where 46 | x : Nat 47 | x = 1 48 | bar = foo + x 49 | where 50 | x : Nat 51 | x = 2 52 | {-# COMPILE AGDA2HS bad2 #-} 53 | 54 | test : Bool → Nat 55 | test True = bar 56 | where 57 | foo : Nat 58 | foo = 42 + ted 59 | where 60 | nes : Nat 61 | nes = 1 62 | ted : Nat 63 | ted = nes + 1 64 | 65 | bar : Nat 66 | bar = foo 67 | test False = bar 68 | where 69 | bar : Nat 70 | foo : Nat 71 | foo = 42 + ted 72 | where 73 | ted : Nat 74 | nes : Nat 75 | nes = 1 76 | ted = nes + 1 77 | bar = foo 78 | {-# COMPILE AGDA2HS test #-} 79 | -------------------------------------------------------------------------------- /test/Issue92.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | postulate Something : Type 4 | postulate something : Something 5 | 6 | module _ {a : Type} where 7 | foo : a → a 8 | foo x = bar {something} 9 | where 10 | bar : @0 {Something} → a 11 | bar {eq} = baz 12 | where 13 | baz : a 14 | baz = x 15 | {-# COMPILE AGDA2HS foo #-} 16 | -------------------------------------------------------------------------------- /test/Issue93.agda: -------------------------------------------------------------------------------- 1 | module Issue93 where 2 | 3 | open import Haskell.Prelude 4 | 5 | fun : Bool → Bool 6 | fun x = case x of λ where 7 | True → False 8 | False → y 9 | where 10 | y : Bool 11 | y = True 12 | {-# COMPILE AGDA2HS fun #-} 13 | 14 | nested : Maybe Bool → Bool 15 | nested x = case x of λ where 16 | (Just b) → (case y of λ where 17 | True → b 18 | False → z) 19 | Nothing → y 20 | where 21 | y : Bool 22 | y = True 23 | 24 | z : Bool 25 | z = case y of λ where 26 | True → y 27 | False → True 28 | {-# COMPILE AGDA2HS nested #-} 29 | -------------------------------------------------------------------------------- /test/Issue94.agda: -------------------------------------------------------------------------------- 1 | module Issue94 where 2 | 3 | open import Haskell.Prelude 4 | 5 | thing : List a → List a 6 | thing xs = aux xs 7 | where 8 | aux : List a → List a 9 | aux xs = xs 10 | {-# COMPILE AGDA2HS thing #-} 11 | -------------------------------------------------------------------------------- /test/Kinds.agda: -------------------------------------------------------------------------------- 1 | module Kinds where 2 | 3 | open import Haskell.Prelude 4 | 5 | record ReaderT (r : Type) (m : Type → Type) (a : Type) : Type where 6 | constructor RdrT 7 | field runReaderT : r → m a 8 | open ReaderT public 9 | 10 | {-# COMPILE AGDA2HS ReaderT #-} 11 | 12 | data Kleisli (m : Type → Type) (a b : Type) : Type where 13 | K : (a → m b) → Kleisli m a b 14 | 15 | {-# COMPILE AGDA2HS Kleisli #-} 16 | 17 | -------------------------------------------------------------------------------- /test/LawfulOrd.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | open import Haskell.Law 3 | 4 | data Ordered (a : Type) : Type where 5 | Gt : ⦃ @0 iOrd : Ord a ⦄ → (a' : a) → (a'' : a) → ⦃ @0 pf : (a' > a'') ≡ True ⦄ → Ordered a 6 | Lt : ⦃ @0 iOrd : Ord a ⦄ → (a' : a) → (a'' : a) → ⦃ @0 pf : (a' < a'') ≡ True ⦄ → Ordered a 7 | E : ⦃ @0 iOrd : Ord a ⦄ → (a' : a) → (a'' : a) → ⦃ @0 pf : a' ≡ a'' ⦄ → Ordered a 8 | 9 | {-# COMPILE AGDA2HS Ordered #-} 10 | 11 | nLtEq2Gt : ⦃ iOrdA : Ord a ⦄ → ⦃ IsLawfulOrd a ⦄ 12 | → ∀ (x y : a) → ⦃ (x < y) ≡ False ⦄ → ⦃ (x == y) ≡ False ⦄ → (x > y) ≡ True 13 | nLtEq2Gt x y ⦃ h1 ⦄ ⦃ h2 ⦄ = 14 | begin 15 | (x > y) 16 | ≡⟨ sym (not-involution (x <= y) (x > y) (lte2ngt x y)) ⟩ 17 | not (x <= y) 18 | ≡⟨ cong not (lte2LtEq x y) ⟩ 19 | not ((x < y) || (x == y)) 20 | ≡⟨ cong (λ b → not (b || (x == y))) h1 ⟩ 21 | not (False || (x == y)) 22 | ≡⟨ cong (λ b → not (False || b)) h2 ⟩ 23 | not (False || False) 24 | ≡⟨⟩ 25 | True 26 | ∎ 27 | 28 | order : ⦃ iOrd : Ord a ⦄ → @0 ⦃ IsLawfulOrd a ⦄ 29 | → (a' : a) → (a'' : a) → Ordered a 30 | order left right = 31 | if left < right then 32 | Lt left right 33 | else ( 34 | if left == right then 35 | (λ ⦃ h ⦄ → E left right ⦃ equality left right h ⦄) 36 | else 37 | Gt left right ⦃ nLtEq2Gt left right ⦄ 38 | ) 39 | 40 | {-# COMPILE AGDA2HS order #-} 41 | -------------------------------------------------------------------------------- /test/LiteralPatterns.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | open import Agda.Builtin.Int using (pos; negsuc) 4 | 5 | testInt : Integer → Bool 6 | testInt (pos 10) = True 7 | testInt (negsuc 7) = True 8 | testInt _ = False 9 | 10 | {-# COMPILE AGDA2HS testInt #-} 11 | 12 | testChar : Char → Bool 13 | testChar 'c' = True 14 | testChar _ = False 15 | 16 | {-# COMPILE AGDA2HS testChar #-} 17 | -------------------------------------------------------------------------------- /test/ModuleParameters.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --no-projection-like #-} 2 | open import Haskell.Prelude hiding (a) 3 | 4 | module ModuleParameters 5 | (@0 name : Type) 6 | (p : @0 name → Type) where 7 | 8 | data Scope : Type where 9 | Empty : Scope 10 | Bind : (@0 x : name) → p x → Scope → Scope 11 | {-# COMPILE AGDA2HS Scope #-} 12 | 13 | unbind : Scope → Scope 14 | unbind Empty = Empty 15 | unbind (Bind _ _ s) = s 16 | {-# COMPILE AGDA2HS unbind #-} 17 | 18 | module _ {a : Type} where 19 | thing : a → a 20 | thing x = y 21 | where y : a 22 | y = x 23 | {-# COMPILE AGDA2HS thing #-} 24 | 25 | stuff : a → Scope → a 26 | stuff x Empty = x 27 | stuff x (Bind _ _ _) = x 28 | {-# COMPILE AGDA2HS stuff #-} 29 | 30 | module _ {b : Type} where 31 | more : b → a → Scope → Scope 32 | more _ _ Empty = Empty 33 | more _ _ (Bind _ _ s) = s 34 | {-# COMPILE AGDA2HS more #-} 35 | -------------------------------------------------------------------------------- /test/ModuleParametersImports.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --no-projection-like #-} 2 | module ModuleParametersImports where 3 | 4 | open import Haskell.Prelude 5 | open import ModuleParameters Bool (λ _ → Nat) 6 | 7 | scope : Scope 8 | scope = unbind (Bind True 3 (Bind False 2 Empty)) 9 | {-# COMPILE AGDA2HS scope #-} 10 | 11 | 12 | -------------------------------------------------------------------------------- /test/NonClassInstance.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | open import Haskell.Extra.Dec 4 | open import Haskell.Extra.Refinement 5 | 6 | foo : (b : Bool) → {{Dec (IsTrue b)}} → Bool 7 | foo _ {{b ⟨ _ ⟩}} = not b 8 | 9 | {-# COMPILE AGDA2HS foo #-} 10 | 11 | bar : Bool → Bool 12 | bar b = foo b 13 | 14 | {-# COMPILE AGDA2HS bar #-} 15 | -------------------------------------------------------------------------------- /test/Numbers.agda: -------------------------------------------------------------------------------- 1 | 2 | module Numbers where 3 | 4 | open import Haskell.Prelude 5 | 6 | posNatural : Nat 7 | posNatural = 14 8 | 9 | posInteger : Integer 10 | posInteger = 52 11 | 12 | negInteger : Integer 13 | negInteger = -1001 14 | 15 | natToPos : Nat → Integer 16 | natToPos n = fromNat n 17 | 18 | natToNeg : Nat → Integer 19 | natToNeg n = fromNeg n 20 | 21 | {-# COMPILE AGDA2HS posNatural #-} 22 | {-# COMPILE AGDA2HS posInteger #-} 23 | {-# COMPILE AGDA2HS negInteger #-} 24 | {-# COMPILE AGDA2HS natToPos #-} 25 | {-# COMPILE AGDA2HS natToNeg #-} 26 | -------------------------------------------------------------------------------- /test/OtherImportee.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | data OtherFoo : Type where 4 | MkFoo : OtherFoo 5 | 6 | {-# COMPILE AGDA2HS OtherFoo #-} 7 | -------------------------------------------------------------------------------- /test/Pragmas.agda: -------------------------------------------------------------------------------- 1 | 2 | module Pragmas where 3 | 4 | -- Check that Haskell code is parsed with the correct language pragmas 5 | {-# FOREIGN AGDA2HS 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | #-} 9 | 10 | {-# FOREIGN AGDA2HS 11 | foo :: Bool -> a -> (a, Int) 12 | foo = \ case 13 | False -> (, 0) 14 | True -> (, 1) 15 | #-} 16 | -------------------------------------------------------------------------------- /test/ProjLike.agda: -------------------------------------------------------------------------------- 1 | module ProjLike where 2 | 3 | open import Haskell.Prelude 4 | 5 | module M (a : Type) where 6 | 7 | data Scope : Type where 8 | Empty : Scope 9 | Bind : a → Scope → Scope 10 | 11 | {-# COMPILE AGDA2HS Scope #-} 12 | 13 | unbind : Scope → Scope 14 | unbind Empty = Empty 15 | unbind (Bind _ s) = s 16 | 17 | open M Nat public 18 | 19 | test : Scope 20 | test = unbind (Bind 1 (Bind 2 Empty)) 21 | 22 | {-# COMPILE AGDA2HS test #-} 23 | -------------------------------------------------------------------------------- /test/ProjectionLike.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | module _ (@0 n : Bool) where 5 | 6 | record R : Type where 7 | field 8 | fld : Int 9 | open R public 10 | 11 | {-# COMPILE AGDA2HS R #-} 12 | 13 | foo : R → Int 14 | foo x = fld x 15 | 16 | {-# COMPILE AGDA2HS foo #-} 17 | -------------------------------------------------------------------------------- /test/QualifiedImportee.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | foo : Int 4 | foo = 43 5 | 6 | {-# COMPILE AGDA2HS foo #-} 7 | 8 | _!#_ : Int → Int → Int 9 | x !# y = x - y 10 | 11 | {-# COMPILE AGDA2HS _!#_ #-} 12 | 13 | data Foo : Type where 14 | MkFoo : Foo 15 | 16 | {-# COMPILE AGDA2HS Foo #-} 17 | 18 | -- ** base 19 | record Fooable (a : Type) : Type where 20 | field doTheFoo defaultFoo : a 21 | -- ** defaults 22 | record DefaultFooable (a : Type) : Type where 23 | field doTheFoo : a 24 | 25 | defaultFoo : a 26 | defaultFoo = doTheFoo 27 | -- ** export 28 | open Fooable ⦃...⦄ public 29 | {-# COMPILE AGDA2HS Fooable class DefaultFooable #-} 30 | -- ** instances 31 | instance 32 | FF : Fooable Foo 33 | FF = record {DefaultFooable (λ where .doTheFoo → MkFoo)} 34 | where open DefaultFooable 35 | {-# COMPILE AGDA2HS FF #-} 36 | -------------------------------------------------------------------------------- /test/QualifiedImports.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | {-# FOREIGN AGDA2HS 4 | -- ** simple qualification 5 | #-} 6 | 7 | import Importee 8 | 9 | simpqualBar : Int 10 | simpqualBar = Importee.foo 11 | {-# COMPILE AGDA2HS simpqualBar #-} 12 | 13 | simpfoo : Importee.Foo 14 | simpfoo = Importee.Foo.MkFoo 15 | {-# COMPILE AGDA2HS simpfoo #-} 16 | 17 | {-# FOREIGN AGDA2HS 18 | -- ** qualified imports 19 | #-} 20 | 21 | import QualifiedImportee as Qually 22 | 23 | qualBar : Int 24 | qualBar = Qually.foo 25 | {-# COMPILE AGDA2HS qualBar #-} 26 | 27 | qualBaz : Int 28 | qualBaz = 2 Qually.!# 2 29 | {-# COMPILE AGDA2HS qualBaz #-} 30 | 31 | qualFooable : Qually.Foo 32 | qualFooable = Qually.doTheFoo 33 | {-# COMPILE AGDA2HS qualFooable #-} 34 | 35 | qualDefaultBar : Qually.Foo 36 | qualDefaultBar = Qually.defaultFoo 37 | {-# COMPILE AGDA2HS qualDefaultBar #-} 38 | 39 | Foo : Type 40 | Foo = Importee.Foo 41 | {-# COMPILE AGDA2HS Foo #-} 42 | -------------------------------------------------------------------------------- /test/QualifiedModule.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prim hiding (f) 3 | 4 | -- Names of definitions inside a module should not be qualified in the 5 | -- generated Haskell code! 6 | 7 | module _ where 8 | 9 | module A where 10 | 11 | data D : Type where 12 | C : D 13 | {-# COMPILE AGDA2HS D #-} 14 | 15 | f : D → D 16 | f C = C 17 | {-# COMPILE AGDA2HS f #-} 18 | 19 | g : D 20 | g = h 21 | where 22 | h : D 23 | h = C 24 | {-# COMPILE AGDA2HS g #-} 25 | 26 | open A public 27 | -------------------------------------------------------------------------------- /test/QualifiedPrelude.agda: -------------------------------------------------------------------------------- 1 | {-# FOREIGN AGDA2HS 2 | -- ** qualifying the Prelude 3 | #-} 4 | import Haskell.Prelude as Pre 5 | 6 | _+_ : Pre.Nat → Pre.Nat → Pre.Nat 7 | x + y = x 8 | {-# COMPILE AGDA2HS _+_ #-} 9 | 10 | comp : (Pre.Nat → Pre.Nat) → (Pre.Nat → Pre.Nat) → (Pre.Nat → Pre.Nat) 11 | comp f g = f Pre.∘ g 12 | {-# COMPILE AGDA2HS comp #-} 13 | 14 | test : Pre.Nat 15 | test = 0 Pre.+ 1 + 0 16 | {-# COMPILE AGDA2HS test #-} 17 | 18 | testComp : Pre.Nat 19 | testComp = comp (_+ 0) (Pre._+ 1) 0 20 | {-# COMPILE AGDA2HS testComp #-} 21 | 22 | {-# FOREIGN AGDA2HS 23 | -- ** interplay with (qualified) default methods of existing class 24 | #-} 25 | 26 | testFoldr : Pre.List Pre.Nat → Pre.Nat 27 | testFoldr = Pre.foldr (λ _ x → x) 0 28 | {-# COMPILE AGDA2HS testFoldr #-} 29 | 30 | {-# FOREIGN AGDA2HS 31 | -- ** re-qualifying the Prelude 32 | #-} 33 | import Haskell.Prelude as pre 34 | 35 | retest : pre.Nat 36 | retest = 0 pre.+ 1 + 0 37 | {-# COMPILE AGDA2HS retest #-} 38 | -------------------------------------------------------------------------------- /test/RankNTypes.agda: -------------------------------------------------------------------------------- 1 | {-# FOREIGN AGDA2HS 2 | {-# LANGUAGE Haskell98 #-} 3 | #-} 4 | 5 | open import Haskell.Prim using (Type) 6 | 7 | data MyBool : Type where 8 | MyTrue : MyBool 9 | MyFalse : MyBool 10 | {-# COMPILE AGDA2HS MyBool #-} 11 | 12 | rank2ForallUse : (∀ (a : Type) → a → a) → MyBool 13 | rank2ForallUse f = f MyBool MyTrue 14 | {-# COMPILE AGDA2HS rank2ForallUse #-} 15 | 16 | module _ (f : ∀ (a : Type) → a → a) where 17 | rank2Module : MyBool 18 | rank2Module = f MyBool MyTrue 19 | {-# COMPILE AGDA2HS rank2Module #-} 20 | 21 | -- ExistentialQuantification: Not supported yet, but also no error message yet 22 | -- data Exist : Type₁ where 23 | -- MkExist : ∀ (a : Type) → a → Exist 24 | -- {-# COMPILE AGDA2HS Exist #-} 25 | -------------------------------------------------------------------------------- /test/Records.agda: -------------------------------------------------------------------------------- 1 | module Records where 2 | 3 | open import Haskell.Prim using (Type) 4 | open import Haskell.Prelude using (String; Nat) 5 | 6 | variable a b : Type 7 | 8 | -- parametrized record type exported as an Haskell record 9 | record Pair (a b : Type) : Type where 10 | constructor MkPair 11 | field 12 | proj₁ : a 13 | proj₂ : b 14 | 15 | open Pair public 16 | 17 | {-# COMPILE AGDA2HS Pair #-} 18 | 19 | -- no named constructor means we reuse the record name 20 | 21 | record Wrap (a : Type) : Type where 22 | field unwrap : a 23 | open Wrap public 24 | {-# COMPILE AGDA2HS Wrap #-} 25 | 26 | -- record type exported as an Haskell class definition 27 | record MyMonoid (a : Type) : Type where 28 | field 29 | mempty : a 30 | mappend : a → a → a 31 | 32 | {-# COMPILE AGDA2HS MyMonoid class #-} 33 | 34 | swap : Pair a b → Pair b a 35 | swap (MkPair x y) = MkPair y x 36 | 37 | swap₂ : Wrap (Pair a b) → Wrap (Pair b a) 38 | swap₂ (record {unwrap = p}) = record {unwrap = record { proj₁ = proj₂ p; proj₂ = p .proj₁ } } 39 | 40 | {-# COMPILE AGDA2HS swap #-} 41 | {-# COMPILE AGDA2HS swap₂ #-} 42 | 43 | -- record with deriving clause 44 | record User : Type where 45 | field 46 | name : String 47 | code : Nat 48 | open User public 49 | {-# COMPILE AGDA2HS User deriving (Eq, Show) #-} 50 | -------------------------------------------------------------------------------- /test/RequalifiedImports.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | {-# FOREIGN AGDA2HS 4 | -- ** conflicting imports are all replaced with the "smallest" qualifier 5 | -- * the characters are ordered based on their ASCII value (i.e. capitals first) 6 | -- * the order of the imports in the file does not matter 7 | -- * the scope-checker has already replaced previous definitions in the file 8 | #-} 9 | 10 | import QualifiedImportee as C 11 | 12 | requalBar : Int 13 | requalBar = C.foo 14 | {-# COMPILE AGDA2HS requalBar #-} 15 | 16 | import QualifiedImportee as A 17 | 18 | requalBaz : Int 19 | requalBaz = 2 A.!# 2 20 | {-# COMPILE AGDA2HS requalBaz #-} 21 | 22 | requalFooable : A.Foo 23 | requalFooable = C.doTheFoo 24 | {-# COMPILE AGDA2HS requalFooable #-} 25 | 26 | import QualifiedImportee as B 27 | 28 | requalDefaultBar : B.Foo 29 | requalDefaultBar = B.defaultFoo 30 | {-# COMPILE AGDA2HS requalDefaultBar #-} 31 | 32 | {-# FOREIGN AGDA2HS 33 | -- ** qualifying an open'ed module has no effect 34 | #-} 35 | import Haskell.Prelude as Pre 36 | import OtherImportee as Other 37 | open import OtherImportee using (OtherFoo) 38 | 39 | T = Pre.Int 40 | {-# COMPILE AGDA2HS T #-} 41 | 42 | otherFoo : OtherFoo 43 | otherFoo = Other.MkFoo -- this qualification is not retained 44 | {-# COMPILE AGDA2HS otherFoo #-} 45 | -------------------------------------------------------------------------------- /test/ScopedTypeVariables.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | module ScopedTypeVariables (@0 x : Bool) where 4 | 5 | -- We can encode explicit `forall` quantification by module parameters in Agda. 6 | module _ {a : Type} {{_ : Eq a}} where 7 | foo : a → Bool 8 | foo x = it x == x 9 | where 10 | it : a -> a 11 | it = const x 12 | {-# COMPILE AGDA2HS foo #-} 13 | 14 | -- Type arguments should be compiled in the right order. 15 | module _ {a b : Type} where 16 | bar : a → b → (b → b) → b 17 | bar x y f = baz y 18 | where 19 | baz : b → b 20 | baz z = f (f z) 21 | {-# COMPILE AGDA2HS bar #-} 22 | 23 | data D : Type where 24 | MakeD : (y : Bool) → @0 x ≡ y → D 25 | {-# COMPILE AGDA2HS D #-} 26 | 27 | mybool : Bool 28 | mybool = False 29 | {-# COMPILE AGDA2HS mybool #-} 30 | -------------------------------------------------------------------------------- /test/SecondImportee.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | anotherFoo : Int 5 | anotherFoo = 666 6 | 7 | {-# COMPILE AGDA2HS anotherFoo #-} 8 | -------------------------------------------------------------------------------- /test/Sections.agda: -------------------------------------------------------------------------------- 1 | 2 | module Sections where 3 | 4 | open import Haskell.Prelude 5 | 6 | test₁ : Nat → Nat 7 | test₁ = 5 +_ 8 | 9 | test₂ : Nat → Nat 10 | test₂ = _+ 5 11 | 12 | test₃ : Nat → Nat 13 | test₃ = _+_ 5 14 | 15 | test₄ : Nat → Nat 16 | test₄ = λ x → x + 5 17 | 18 | test₅ : Nat → Nat 19 | test₅ = λ x → 5 + x -- Agda eta-contracts this before we get to see it 20 | 21 | {-# COMPILE AGDA2HS test₁ #-} 22 | {-# COMPILE AGDA2HS test₂ #-} 23 | {-# COMPILE AGDA2HS test₃ #-} 24 | {-# COMPILE AGDA2HS test₄ #-} 25 | {-# COMPILE AGDA2HS test₅ #-} 26 | -------------------------------------------------------------------------------- /test/TransparentFun.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | data Unit : Type where 5 | unit : Unit 6 | 7 | myId : @0 Unit → a → a 8 | myId unit x = x 9 | 10 | {-# COMPILE AGDA2HS myId transparent #-} 11 | 12 | testMyId : @0 Unit → Nat 13 | testMyId u = myId u 42 14 | 15 | {-# COMPILE AGDA2HS testMyId #-} 16 | 17 | tyId : @0 Unit → Type → Type 18 | tyId unit a = a 19 | 20 | {-# COMPILE AGDA2HS tyId transparent #-} 21 | 22 | testTyId : ∀ {@0 u : Unit} → tyId u (tyId u Int → tyId u Int) 23 | testTyId {unit} n = n 24 | 25 | {-# COMPILE AGDA2HS testTyId #-} 26 | 27 | data Tree : Type where 28 | Tip : Tree 29 | Bin : Tree → Tree → Tree 30 | 31 | {-# COMPILE AGDA2HS Tree #-} 32 | 33 | treeId : Tree → Tree 34 | treeId Tip = Tip 35 | treeId (Bin x y) = Bin (treeId x) (treeId y) 36 | 37 | {-# COMPILE AGDA2HS treeId transparent #-} 38 | 39 | testTreeId : Tree → Tree 40 | testTreeId = treeId 41 | 42 | {-# COMPILE AGDA2HS testTreeId #-} 43 | -------------------------------------------------------------------------------- /test/Tree.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | 3 | data _≤_ : Nat → Nat → Type where 4 | instance 5 | zero-≤ : ∀ {@0 n} → zero ≤ n 6 | suc-≤ : ∀ {@0 m n} → @0 {{m ≤ n}} → suc m ≤ suc n 7 | 8 | data Tree (@0 l u : Nat) : Type where 9 | Leaf : @0 {{l ≤ u}} → Tree l u 10 | Node : (x : Nat) → Tree l x → Tree x u → Tree l u 11 | {-# COMPILE AGDA2HS Tree #-} 12 | -------------------------------------------------------------------------------- /test/Tuples.agda: -------------------------------------------------------------------------------- 1 | 2 | module Tuples where 3 | 4 | open import Haskell.Prelude 5 | 6 | swap : a × b → b × a 7 | swap (a , b) = b , a 8 | 9 | {-# COMPILE AGDA2HS swap #-} 10 | 11 | data TuplePos : Type where 12 | Test : TuplePos × Bool → TuplePos 13 | 14 | {-# COMPILE AGDA2HS TuplePos #-} 15 | 16 | 17 | t1 : Bool × Bool × Bool 18 | t1 = True , False , True 19 | 20 | {-# COMPILE AGDA2HS t1 #-} 21 | 22 | t2 : (Bool × Bool) × Bool 23 | t2 = (True , False) , True 24 | 25 | {-# COMPILE AGDA2HS t2 #-} 26 | 27 | t3 : Bool × (Bool × Bool) 28 | t3 = True , (False , True) 29 | 30 | {-# COMPILE AGDA2HS t3 #-} 31 | 32 | pair : Int × Int 33 | pair = 1 , 2 34 | 35 | {-# COMPILE AGDA2HS pair #-} 36 | 37 | test : Int 38 | test = let (x , y) = pair in x + y 39 | 40 | {-# COMPILE AGDA2HS test #-} 41 | 42 | test2 : Bool 43 | test2 = case t1 of \where 44 | (a , b , c) → c 45 | 46 | {-# COMPILE AGDA2HS test2 #-} 47 | 48 | open import Haskell.Extra.Sigma as S using (Σ-syntax) 49 | open import Haskell.Extra.Dec 50 | open import Haskell.Prim using (itsTrue) 51 | open import Haskell.Extra.Refinement 52 | 53 | t4 : Σ[ n ∈ Nat ] (Dec (IsTrue (n <= 5))) 54 | t4 = 3 S., (True ⟨ itsTrue ⟩) 55 | 56 | {-# COMPILE AGDA2HS t4 #-} 57 | 58 | t5 : Σ[ x ∈ a ] b → a 59 | t5 p = case p of λ where (x S., y) → x 60 | 61 | {-# COMPILE AGDA2HS t5 #-} 62 | -------------------------------------------------------------------------------- /test/TypeBasedUnboxing.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --prop --sized-types #-} 2 | 3 | open import Agda.Primitive 4 | open import Agda.Builtin.Size 5 | open import Haskell.Prelude 6 | 7 | data P : Prop where 8 | 9 | record R : Type where 10 | field 11 | @0 anErasedThing : Bool 12 | aRealThing : Int 13 | aLevel : Level 14 | aProp : P 15 | aSize : Size 16 | open R public 17 | 18 | {-# COMPILE AGDA2HS R unboxed #-} 19 | 20 | foo : R → Int 21 | foo = aRealThing 22 | 23 | {-# COMPILE AGDA2HS foo #-} 24 | -------------------------------------------------------------------------------- /test/TypeDirected.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --prop #-} 2 | module TypeDirected where 3 | 4 | open import Agda.Builtin.Reflection hiding (Type) 5 | open import Agda.Builtin.Unit 6 | open import Haskell.Prelude 7 | 8 | data MyProp : Prop where 9 | true : MyProp 10 | 11 | myconst : {a : Type} → MyProp → a → {y : a} → a 12 | myconst p x = x 13 | 14 | {-# COMPILE AGDA2HS myconst #-} 15 | 16 | defTrue : Term → TC ⊤ 17 | defTrue hole = unify hole (quoteTerm True) 18 | 19 | fn : {@(tactic defTrue) b : Bool} → Int 20 | fn {False} = 0 21 | fn {True } = 5 22 | 23 | {-# COMPILE AGDA2HS fn #-} 24 | 25 | test1 : Int 26 | test1 = fn 27 | 28 | {-# COMPILE AGDA2HS test1 #-} 29 | 30 | test2 : Int 31 | test2 = fn {False} 32 | 33 | {-# COMPILE AGDA2HS test2 #-} 34 | 35 | -------------------------------------------------------------------------------- /test/TypeOperatorExport.agda: -------------------------------------------------------------------------------- 1 | module TypeOperatorExport where 2 | 3 | {-# FOREIGN AGDA2HS {-# LANGUAGE TypeOperators #-} #-} 4 | 5 | open import Haskell.Prim 6 | 7 | _<_ : Type -> Type -> Type 8 | a < b = a 9 | {-# COMPILE AGDA2HS _<_ #-} 10 | 11 | data _***_ {i j : Level} (a : Type i) (b : Type j) : Type (i ⊔ j) where 12 | _:*:_ : a -> b -> a *** b 13 | open _***_ public 14 | {-# COMPILE AGDA2HS _***_ #-} 15 | 16 | _&&&_ : Bool -> Bool -> Bool 17 | False &&& _ = False 18 | _ &&& b2 = b2 19 | {-# COMPILE AGDA2HS _&&&_ #-} 20 | -------------------------------------------------------------------------------- /test/TypeOperatorImport.agda: -------------------------------------------------------------------------------- 1 | module TypeOperatorImport where 2 | 3 | {-# FOREIGN AGDA2HS {-# LANGUAGE TypeOperators #-} #-} 4 | 5 | open import Haskell.Prelude hiding (_<_) 6 | open import TypeOperatorExport 7 | 8 | test1 : ⊤ < Bool 9 | test1 = tt 10 | {-# COMPILE AGDA2HS test1 #-} 11 | 12 | test2 : Bool -> Bool -> ⊤ *** Bool 13 | test2 b1 b2 = ((tt :*:_) ∘ not) (b1 &&& b2) 14 | {-# COMPILE AGDA2HS test2 #-} 15 | -------------------------------------------------------------------------------- /test/TypeOperators.agda: -------------------------------------------------------------------------------- 1 | module TypeOperators where 2 | 3 | {-# FOREIGN AGDA2HS {-# LANGUAGE TypeOperators #-} #-} 4 | 5 | open import Haskell.Prim using (Type) 6 | open import Haskell.Prim.Either 7 | 8 | open import Agda.Builtin.Nat 9 | open import Agda.Builtin.Bool 10 | 11 | _:++:_ : Type → Type → Type 12 | _:++:_ = Either 13 | {-# COMPILE AGDA2HS _:++:_ #-} 14 | 15 | mx : Bool :++: Nat 16 | mx = Left true 17 | {-# COMPILE AGDA2HS mx #-} 18 | 19 | _++++_ : Type → Type → Type 20 | _++++_ = Either 21 | {-# COMPILE AGDA2HS _++++_ #-} 22 | 23 | mx' : Bool ++++ Nat 24 | mx' = Left true 25 | {-# COMPILE AGDA2HS mx' #-} 26 | 27 | data _****_ (a b : Type): Type where 28 | _:****_ : a → b → a **** b 29 | {-# COMPILE AGDA2HS _****_ #-} 30 | 31 | cross : Bool **** Nat 32 | cross = true :**** 1 33 | {-# COMPILE AGDA2HS cross #-} 34 | -------------------------------------------------------------------------------- /test/TypeSignature.agda: -------------------------------------------------------------------------------- 1 | module TypeSignature where 2 | 3 | open import Agda.Builtin.Nat 4 | open import Haskell.Prim 5 | 6 | five : Nat 7 | five = the (Nat -> Nat) id 5 8 | {-# COMPILE AGDA2HS five #-} 9 | -------------------------------------------------------------------------------- /test/TypeSynonyms.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prim using (Type) 2 | 3 | data Nat : Type where 4 | Zero : Nat 5 | Suc : Nat → Nat 6 | {-# COMPILE AGDA2HS Nat #-} 7 | 8 | Nat' = Nat 9 | {-# COMPILE AGDA2HS Nat' #-} 10 | 11 | myNat : Nat' 12 | myNat = Suc (Suc Zero) 13 | {-# COMPILE AGDA2HS myNat #-} 14 | 15 | data List (a : Type) : Type where 16 | Nil : List a 17 | Cons : a → List a → List a 18 | {-# COMPILE AGDA2HS List #-} 19 | 20 | List' : Type → Type 21 | List' a = List a 22 | {-# COMPILE AGDA2HS List' #-} 23 | 24 | NatList = List Nat 25 | {-# COMPILE AGDA2HS NatList #-} 26 | 27 | myListFun : List' Nat' → NatList 28 | myListFun Nil = Nil 29 | myListFun (Cons x xs) = Cons x (myListFun xs) 30 | {-# COMPILE AGDA2HS myListFun #-} 31 | 32 | ListList : Type → Type 33 | ListList a = List (List a) 34 | {-# COMPILE AGDA2HS ListList #-} 35 | 36 | flatten : ∀ {a} → ListList a → List a 37 | flatten Nil = Nil 38 | flatten (Cons Nil xss) = flatten xss 39 | flatten (Cons (Cons x xs) xss) = Cons x (flatten (Cons xs xss)) 40 | {-# COMPILE AGDA2HS flatten #-} 41 | -------------------------------------------------------------------------------- /test/UnboxPragma.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | record ∃ (A : Type) (@0 P : A → Type) : Type where 5 | constructor _[_] 6 | field 7 | el : A 8 | @0 pf : P el 9 | open ∃ public 10 | 11 | {-# COMPILE AGDA2HS ∃ unboxed #-} 12 | 13 | postulate 14 | IsSorted : List Int → Type 15 | looksfine : {xs : List Int} → IsSorted xs 16 | 17 | sort1 : List Int → ∃ (List Int) IsSorted 18 | sort1 xs = xs [ looksfine ] 19 | 20 | {-# COMPILE AGDA2HS sort1 #-} 21 | 22 | sort2 : List Int → ∃ (List Int) IsSorted 23 | sort2 xs .el = xs 24 | sort2 xs .pf = looksfine 25 | 26 | {-# COMPILE AGDA2HS sort2 #-} 27 | 28 | sort3 : List Int → ∃ (List Int) IsSorted 29 | sort3 xs = xs [ sort2 xs .pf ] 30 | 31 | {-# COMPILE AGDA2HS sort3 #-} 32 | 33 | sortAll : List (List Int) 34 | sortAll = map el (map (λ xs → xs [ looksfine {xs} ]) ((1 ∷ 2 ∷ []) ∷ (3 ∷ []) ∷ [])) 35 | 36 | {-# COMPILE AGDA2HS sortAll #-} 37 | 38 | record Σ0 (A : Type) (P : @0 A → Type) : Type where 39 | constructor _[_] 40 | field 41 | @0 el : A 42 | pf : P el 43 | open Σ0 public 44 | 45 | {-# COMPILE AGDA2HS Σ0 unboxed #-} 46 | 47 | Scope : (name : Type) → Type 48 | Scope name = Σ0 (List name) λ xs → ∃ Int λ n → length xs ≡ n 49 | 50 | {-# COMPILE AGDA2HS Scope #-} 51 | 52 | emptyScope : {name : Type} → Scope name 53 | emptyScope = [] [ 0 [ refl ] ] 54 | 55 | {-# COMPILE AGDA2HS emptyScope #-} 56 | -------------------------------------------------------------------------------- /test/Vector.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Haskell.Prelude 3 | 4 | {- Old style using implicit arguments (no longer supported) 5 | data Vec (a : Type) : {n : Nat} → Type where 6 | Nil : Vec a {0} 7 | Cons : {n : Nat} → a → Vec a {n} → Vec a {suc n} 8 | {-# COMPILE AGDA2HS Vec #-} 9 | 10 | mapV : {a b : Type} {n : Nat} (f : a → b) → Vec a {n} → Vec b {n} 11 | mapV f Nil = Nil 12 | mapV f (Cons x xs) = Cons (f x) (mapV f xs) 13 | {-# COMPILE AGDA2HS mapV #-} 14 | 15 | tailV : {a : Type} {n : Nat} → Vec a {suc n} → Vec a {n} 16 | tailV (Cons x xs) = xs 17 | {-# COMPILE AGDA2HS tailV #-} 18 | -} 19 | 20 | -- New style using erasure instead of implicit arguments 21 | data Vec (a : Type) : (@0 n : Nat) → Type where 22 | Nil : Vec a 0 23 | Cons : {@0 n : Nat} → a → Vec a n → Vec a (suc n) 24 | {-# COMPILE AGDA2HS Vec #-} 25 | 26 | mapV : {a b : Type} {@0 n : Nat} (f : a → b) → Vec a n → Vec b n 27 | mapV f Nil = Nil 28 | mapV f (Cons x xs) = Cons (f x) (mapV f xs) 29 | {-# COMPILE AGDA2HS mapV #-} 30 | 31 | tailV : {a : Type} {@0 n : Nat} → Vec a (suc n) → Vec a n 32 | tailV (Cons x xs) = xs 33 | {-# COMPILE AGDA2HS tailV #-} 34 | -------------------------------------------------------------------------------- /test/WitnessedFlows.agda: -------------------------------------------------------------------------------- 1 | open import Haskell.Prelude 2 | open import Haskell.Control.Monad 3 | 4 | data Range : Type where 5 | MkRange : (low high : Int) 6 | → {{ @0 h : ((low <= high) ≡ True) }} 7 | → Range 8 | 9 | {-# COMPILE AGDA2HS Range #-} 10 | 11 | createRange : Int → Int → Maybe Range 12 | createRange low high = if low <= high then Just (MkRange low high) else Nothing 13 | 14 | {-# COMPILE AGDA2HS createRange #-} 15 | 16 | createRange' : Int → Int → Maybe Range 17 | createRange' low high = 18 | if low <= high then 19 | (λ {{ h }} → if low <= high then Just (MkRange low high {{ h }}) else Nothing) 20 | else Nothing 21 | 22 | {-# COMPILE AGDA2HS createRange' #-} 23 | 24 | createRangeCase : Int → Int → Maybe Range 25 | createRangeCase low high = 26 | case low <= high of λ where 27 | True → Just (MkRange low high) 28 | False → Nothing 29 | 30 | {-# COMPILE AGDA2HS createRangeCase #-} 31 | 32 | createRangeGuardSeq : Int → Int → Maybe Range 33 | createRangeGuardSeq low high = 34 | do guard (low <= high) 35 | pure (MkRange low high) 36 | 37 | {-# COMPILE AGDA2HS createRangeGuardSeq #-} 38 | 39 | createRangeGuardFmap : Int → Int → Maybe Range 40 | createRangeGuardFmap low high 41 | = MkRange low high <$ guard (low <= high) 42 | 43 | {-# COMPILE AGDA2HS createRangeGuardFmap #-} 44 | -------------------------------------------------------------------------------- /test/agda2hs-test.agda-lib: -------------------------------------------------------------------------------- 1 | name: agda2hs-test 2 | depend: 3 | include: . ../lib/base/ 4 | flags: --sized-types --erasure 5 | -------------------------------------------------------------------------------- /test/golden/AllCubicalTests.hs: -------------------------------------------------------------------------------- 1 | module AllCubicalTests where 2 | 3 | import Cubical.StreamFusion 4 | 5 | -------------------------------------------------------------------------------- /test/golden/Assert.hs: -------------------------------------------------------------------------------- 1 | module Assert where 2 | 3 | import Control.Exception (assert) 4 | import Numeric.Natural (Natural) 5 | 6 | subtractChecked :: Natural -> Natural -> Natural 7 | subtractChecked x y = assert (not (x < y)) (x - y) 8 | 9 | -------------------------------------------------------------------------------- /test/golden/AutoLambdaCaseInBind.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module AutoLambdaCaseInBind where 3 | 4 | lcaseInsideBind :: Maybe (Maybe a) -> Maybe a 5 | lcaseInsideBind mx 6 | = do x <- mx 7 | (\case 8 | Nothing -> Nothing 9 | Just _ -> Nothing) 10 | x 11 | 12 | -------------------------------------------------------------------------------- /test/golden/AutoLambdaCaseInCase.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module AutoLambdaCaseInCase where 3 | 4 | lcaseInsideCaseOf :: [a] -> Maybe a -> Maybe a 5 | lcaseInsideCaseOf xs 6 | = case xs of 7 | [] -> \case 8 | Nothing -> Nothing 9 | Just _ -> Nothing 10 | x : _ -> \case 11 | Nothing -> Nothing 12 | Just _ -> Just x 13 | 14 | -------------------------------------------------------------------------------- /test/golden/BangPatterns.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module BangPatterns where 3 | 4 | strictId :: a -> a 5 | strictId !x = x 6 | 7 | myFoldl :: (b -> a -> b) -> b -> [a] -> b 8 | myFoldl f x0 [] = x0 9 | myFoldl f x0 (x : xs) = myFoldl f (f x0 x) xs 10 | 11 | foldl'' :: (b -> a -> b) -> b -> [a] -> b 12 | foldl'' f !x0 [] = x0 13 | foldl'' f !x0 (x : xs) = foldl'' f (f x0 x) xs 14 | 15 | data LazyMaybe a = LazyNothing 16 | | LazyJust a 17 | 18 | data StrictMaybe a = StrictNothing 19 | | StrictJust !a 20 | 21 | -------------------------------------------------------------------------------- /test/golden/CanonicalInstance.hs: -------------------------------------------------------------------------------- 1 | module CanonicalInstance where 2 | 3 | class ClassA a where 4 | myA :: a 5 | 6 | class ClassA b => ClassB b where 7 | 8 | myB :: ClassB b => b 9 | myB = myA 10 | 11 | -------------------------------------------------------------------------------- /test/golden/ClashingImport.err: -------------------------------------------------------------------------------- 1 | Clashing import: MkFoo (both from Foo and OtherFoo) 2 | -------------------------------------------------------------------------------- /test/golden/Coerce.hs: -------------------------------------------------------------------------------- 1 | module Coerce where 2 | 3 | import Numeric.Natural (Natural) 4 | import Unsafe.Coerce (unsafeCoerce) 5 | 6 | newtype A = MkA Natural 7 | 8 | newtype B = MkB Natural 9 | deriving (Show) 10 | 11 | coerceExample :: B 12 | coerceExample = unsafeCoerce (MkA 5) 13 | 14 | -------------------------------------------------------------------------------- /test/golden/Coinduction.hs: -------------------------------------------------------------------------------- 1 | module Coinduction where 2 | 3 | data Colist a = Nil 4 | | Cons a (Colist a) 5 | 6 | repeater :: a -> Colist a 7 | repeater x = Cons x (repeater x) 8 | 9 | -------------------------------------------------------------------------------- /test/golden/CommonQualifiedImports.hs: -------------------------------------------------------------------------------- 1 | module CommonQualifiedImports where 2 | 3 | import qualified Importee as Common (foo) 4 | import qualified Prelude as Common (Int, Num((+))) 5 | import qualified SecondImportee as Common (anotherFoo) 6 | 7 | -- ** common qualification 8 | 9 | foos :: Common.Int 10 | foos = (Common.+) Common.foo Common.anotherFoo 11 | 12 | -------------------------------------------------------------------------------- /test/golden/ConstrainedInstance.hs: -------------------------------------------------------------------------------- 1 | module ConstrainedInstance where 2 | 3 | data D a = C a 4 | 5 | instance (Eq a) => Eq (D a) where 6 | C x == C y = x == y 7 | 8 | -------------------------------------------------------------------------------- /test/golden/Copatterns.err: -------------------------------------------------------------------------------- 1 | test/Fail/Copatterns.agda:14,1-5 2 | not supported in Haskell: copatterns 3 | -------------------------------------------------------------------------------- /test/golden/Cubical/StreamFusion.hs: -------------------------------------------------------------------------------- 1 | module Cubical.StreamFusion where 2 | 3 | data Stream a = (:>){shead :: a, stail :: Stream a} 4 | 5 | smap :: (a -> b) -> Stream a -> Stream b 6 | smap f (x :> xs) = f x :> smap f xs 7 | 8 | -------------------------------------------------------------------------------- /test/golden/CustomTuples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UnboxedTuples, TupleSections #-} 2 | module CustomTuples where 3 | 4 | test :: (Int, Int) -> Int 5 | test xy = fst xy + snd xy 6 | 7 | foo :: 8 | (# Int, Int, Bool #) -> 9 | (# Int, Bool, Bool #) -> (# Int, Char, Bool #) 10 | foo (# a, b, c #) (# x, y, z #) 11 | = (# a + b + x, 'x', or [c, y, z] #) 12 | 13 | bare :: Int -> Char -> Bool -> (# Int, Char, Bool #) 14 | bare = (# ,, #) 15 | 16 | section :: a -> Bool -> (# Int, a, Bool #) 17 | section = (# 42, , #) 18 | 19 | bar :: () -> () 20 | bar () = () 21 | 22 | baz :: (Int) -> (Int) 23 | baz (x) = (42) 24 | 25 | -------------------------------------------------------------------------------- /test/golden/Datatypes.hs: -------------------------------------------------------------------------------- 1 | module Datatypes where 2 | 3 | data Test = CTest Bool 4 | 5 | getTest :: Test -> Bool 6 | getTest (CTest b) = b 7 | 8 | putTest :: Bool -> Test -> Test 9 | putTest b (CTest _) = CTest b 10 | 11 | -------------------------------------------------------------------------------- /test/golden/Default.hs: -------------------------------------------------------------------------------- 1 | module Default where 2 | 3 | class HasDefault a where 4 | theDefault :: a 5 | 6 | instance HasDefault Bool where 7 | theDefault = False 8 | 9 | test :: Bool 10 | test = theDefault 11 | 12 | -------------------------------------------------------------------------------- /test/golden/Delay.hs: -------------------------------------------------------------------------------- 1 | module Delay where 2 | 3 | div' :: Int -> Int -> Int 4 | div' = error "postulate: Int -> Int -> Int" 5 | 6 | mod' :: Int -> Int -> Int 7 | mod' = error "postulate: Int -> Int -> Int" 8 | 9 | even' :: Int -> Bool 10 | even' x = mod' x 2 == 0 11 | 12 | collatz :: Int -> Int 13 | collatz x 14 | = if x == 0 then 0 else 15 | if even' x then collatz (div' x 2) else collatz (3 * x + 1) 16 | 17 | -------------------------------------------------------------------------------- /test/golden/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving, DerivingStrategies, 2 | DeriveAnyClass, GeneralizedNewtypeDeriving #-} 3 | module Deriving where 4 | 5 | data Planet = Mercury 6 | | Venus 7 | | Earth 8 | | Mars 9 | | Jupiter 10 | | Saturn 11 | | Uranus 12 | | Neptune 13 | | Pluto 14 | deriving (Read) 15 | 16 | deriving instance Eq Planet 17 | 18 | deriving instance Ord Planet 19 | 20 | deriving stock instance Show Planet 21 | 22 | class Clazz a where 23 | foo :: a -> Int 24 | bar :: a -> Bool 25 | 26 | deriving anyclass instance Clazz Planet 27 | 28 | data Optional a = Of a 29 | | Empty 30 | 31 | deriving instance (Eq a) => Eq (Optional a) 32 | 33 | newtype Duo a b = MkDuo (a, b) 34 | 35 | deriving newtype instance (Eq a, Eq b) => Eq (Duo a b) 36 | 37 | -------------------------------------------------------------------------------- /test/golden/DerivingParseFailure.err: -------------------------------------------------------------------------------- 1 | test/Fail/DerivingParseFailure.agda:6,1-44 2 | Parse error: !& 3 | -------------------------------------------------------------------------------- /test/golden/DoNotation.hs: -------------------------------------------------------------------------------- 1 | module DoNotation where 2 | 3 | type Birds = Int 4 | 5 | type Pole = (Birds, Birds) 6 | 7 | landLeft :: Birds -> Pole -> Maybe Pole 8 | landLeft n (left, right) 9 | = if abs (left + n - right) < 4 then Just (left + n, right) else 10 | Nothing 11 | 12 | landRight :: Birds -> Pole -> Maybe Pole 13 | landRight n (left, right) 14 | = if abs (left - (right + n)) < 4 then Just (left, right + n) else 15 | Nothing 16 | 17 | routine :: Maybe Pole 18 | routine 19 | = do start <- return (0, 0) 20 | first <- landLeft 2 start 21 | landRight 2 first >>= landLeft 1 22 | 23 | routineWithoutDo :: Maybe Pole 24 | routineWithoutDo 25 | = return (0, 0) >>= 26 | \ start -> 27 | landLeft 2 start >>= \ first -> landRight 2 first >>= landLeft 1 28 | 29 | swapPolesMaybe :: Maybe Pole -> Maybe Pole 30 | swapPolesMaybe x 31 | = do (one, two) <- x 32 | pure (two, one) 33 | 34 | -------------------------------------------------------------------------------- /test/golden/EraseType.hs: -------------------------------------------------------------------------------- 1 | module EraseType where 2 | 3 | testErase :: () 4 | testErase = () 5 | 6 | testMatch :: () -> () 7 | testMatch () = () 8 | 9 | testRezz :: Int 10 | testRezz = 42 11 | 12 | testRezzErase :: () 13 | testRezzErase = () 14 | 15 | testCong :: Int 16 | testCong = 1 + testRezz 17 | 18 | rTail :: [Int] -> [Int] 19 | rTail = \ ys -> tail ys 20 | 21 | -------------------------------------------------------------------------------- /test/golden/ErasedLocalDefinitions.hs: -------------------------------------------------------------------------------- 1 | module ErasedLocalDefinitions where 2 | 3 | f :: Bool -> Bool 4 | f m = g m 5 | where 6 | g :: Bool -> Bool 7 | g m = m 8 | 9 | -------------------------------------------------------------------------------- /test/golden/ErasedPatternLambda.hs: -------------------------------------------------------------------------------- 1 | module ErasedPatternLambda where 2 | 3 | data Telescope = ExtendTel Bool Telescope 4 | 5 | caseTelBind :: Telescope -> (Bool -> Telescope -> d) -> d 6 | caseTelBind (ExtendTel a tel) f = f a tel 7 | 8 | checkSubst :: Telescope -> Bool 9 | checkSubst t = caseTelBind t (\ ty rest -> True) 10 | 11 | -------------------------------------------------------------------------------- /test/golden/ErasedRecordParameter.err: -------------------------------------------------------------------------------- 1 | test/Fail/ErasedRecordParameter.agda:6,8-10 2 | Cannot use erased variable a in Haskell type 3 | -------------------------------------------------------------------------------- /test/golden/ErasedTypeArguments.hs: -------------------------------------------------------------------------------- 1 | module ErasedTypeArguments where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | data Σ' a b = (:^:){proj₁ :: a, proj₂ :: b} 6 | 7 | test :: Natural -> Σ' Natural () 8 | test n = n :^: () 9 | 10 | newtype Id f = MkId f 11 | 12 | -------------------------------------------------------------------------------- /test/golden/ExplicitInstance.err: -------------------------------------------------------------------------------- 1 | test/Fail/ExplicitInstance.agda:17,1-5 2 | illegal instance: λ { .Fail.ExplicitInstance.theDefault → True } 3 | -------------------------------------------------------------------------------- /test/golden/ExplicitInstance2.err: -------------------------------------------------------------------------------- 1 | test/Fail/ExplicitInstance2.agda:13,1-5 2 | illegal instance: λ { .Fail.ExplicitInstance2.theDefault → True } 3 | -------------------------------------------------------------------------------- /test/golden/Fixities.err: -------------------------------------------------------------------------------- 1 | test/Fail/Fixities.agda:6,1-6 2 | Invalid fixity 8.5 for operator _<+>_ 3 | -------------------------------------------------------------------------------- /test/golden/Fixities.hs: -------------------------------------------------------------------------------- 1 | module Fixities where 2 | 3 | leftAssoc :: Int -> [Int] 4 | leftAssoc n 5 | = [2 * n + 1, 2 * (n + 1), 1 + n * 2, (1 + n) * 2, n + n + n, 6 | n + (n + n)] 7 | 8 | rightAssoc :: [Int] -> [Int] 9 | rightAssoc xs = xs ++ xs ++ ((xs ++ xs) ++ xs) ++ xs 10 | 11 | nonAssoc :: Bool -> Bool 12 | nonAssoc b = (b == b) == (b == b) 13 | 14 | mixedAssoc :: Maybe Int -> (Int -> Maybe Int) -> Maybe Int 15 | mixedAssoc m f = f =<< ((f =<< m) >>= f >>= f) 16 | 17 | infixl 7 <+> 18 | (<+>) :: Int -> Int -> Int 19 | x <+> y = x + y 20 | 21 | infixr 8 <-> 22 | (<->) :: Int -> Int -> Int 23 | x <-> y = x - y 24 | 25 | -------------------------------------------------------------------------------- /test/golden/FunCon.hs: -------------------------------------------------------------------------------- 1 | module FunCon where 2 | 3 | data D1 t = C1 (t Bool) 4 | 5 | f1 :: D1 ((->) Int) 6 | f1 = C1 (== 0) 7 | 8 | data D2 t = C2 (t Int Int) 9 | 10 | f2 :: D2 (->) 11 | f2 = C2 (+ 1) 12 | 13 | -------------------------------------------------------------------------------- /test/golden/HeightMirror.hs: -------------------------------------------------------------------------------- 1 | module HeightMirror where 2 | 3 | data Tree a = Tip 4 | | Bin a (Tree a) (Tree a) 5 | 6 | mirror :: Tree a -> Tree a 7 | mirror Tip = Tip 8 | mirror (Bin x lt rt) = Bin x (mirror rt) (mirror lt) 9 | 10 | -------------------------------------------------------------------------------- /test/golden/IOFile.hs: -------------------------------------------------------------------------------- 1 | module IOFile where 2 | 3 | main :: IO () 4 | main 5 | = do file <- readFile "IOFile.agda" 6 | writeFile "IOFile2.agda" file 7 | appendFile "IOFile2.agda" "-- Written by appendFile" 8 | file2 <- readFile "IOFile2.agda" 9 | print file2 10 | return () 11 | 12 | -------------------------------------------------------------------------------- /test/golden/IOInput.hs: -------------------------------------------------------------------------------- 1 | module IOInput where 2 | 3 | main :: IO () 4 | main 5 | = do putStrLn "Write something " 6 | x <- getLine 7 | putStr $ "You wrote: " ++ x 8 | return () 9 | 10 | -------------------------------------------------------------------------------- /test/golden/Importee.hs: -------------------------------------------------------------------------------- 1 | module Importee where 2 | 3 | foo :: Int 4 | foo = 42 5 | 6 | (!#) :: Int -> Int -> Int 7 | x !# y = x + y 8 | 9 | data Foo = MkFoo 10 | 11 | class Fooable a where 12 | doTheFoo :: a 13 | defaultFoo :: a 14 | {-# MINIMAL doTheFoo #-} 15 | defaultFoo = doTheFoo 16 | 17 | instance Fooable Foo where 18 | doTheFoo = MkFoo 19 | 20 | -------------------------------------------------------------------------------- /test/golden/Importer.hs: -------------------------------------------------------------------------------- 1 | module Importer where 2 | 3 | import Importee (Foo(MkFoo), Fooable(defaultFoo, doTheFoo), foo, (!#)) 4 | import Numeric.Natural (Natural) 5 | import SecondImportee (anotherFoo) 6 | 7 | -- ** simple imports (possibly with transitive dependencies) 8 | 9 | bar :: Int 10 | bar = foo 11 | 12 | anotherBar :: Int 13 | anotherBar = anotherFoo 14 | 15 | baz :: Int 16 | baz = 21 !# 21 17 | 18 | mkFoo :: Foo 19 | mkFoo = MkFoo 20 | 21 | fooable :: Foo 22 | fooable = doTheFoo 23 | 24 | -- ** interplay with class default methods 25 | 26 | defaultBar :: Foo 27 | defaultBar = defaultFoo 28 | 29 | -- ** interplay with methods of existing class 30 | 31 | testFoldMap :: [Natural] -> [Natural] 32 | testFoldMap = foldMap (:) [] 33 | 34 | -- ** interplay with default methods of existing class 35 | 36 | testFoldr :: [Natural] -> Natural 37 | testFoldr = foldr (\ _ x -> x) 0 38 | 39 | -------------------------------------------------------------------------------- /test/golden/Inline.err: -------------------------------------------------------------------------------- 1 | test/Fail/Inline.agda:5,1-6 2 | Cannot make function tail' inlinable. An inline function must have exactly one clause. 3 | -------------------------------------------------------------------------------- /test/golden/Inline2.err: -------------------------------------------------------------------------------- 1 | test/Fail/Inline2.agda:5,1-6 2 | Cannot make function tail' inlinable. Inline functions can only use variable patterns or transparent record constructor patterns. 3 | -------------------------------------------------------------------------------- /test/golden/Inlining.hs: -------------------------------------------------------------------------------- 1 | module Inlining where 2 | 3 | aliased :: Bool 4 | aliased = True 5 | 6 | test1 :: Int -> Int 7 | test1 x = 1 + x 8 | 9 | test2 :: Int -> Int -> Int 10 | test2 x y = x + y 11 | 12 | test3 :: Int -> Int -> Int 13 | test3 x = \ y -> x + y 14 | 15 | test4 :: Int -> Int -> Int 16 | test4 = \ x y -> x + y 17 | 18 | -------------------------------------------------------------------------------- /test/golden/InvalidName.err: -------------------------------------------------------------------------------- 1 | test/Fail/InvalidName.agda:6,1-2 2 | Invalid name for Haskell function: F 3 | -------------------------------------------------------------------------------- /test/golden/Issue113a.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue113a.agda:7,8-12 2 | Unboxed record Loop cannot be recursive 3 | -------------------------------------------------------------------------------- /test/golden/Issue113b.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue113b.agda:9,8-12 2 | Unboxed record Loop cannot be recursive 3 | -------------------------------------------------------------------------------- /test/golden/Issue115.hs: -------------------------------------------------------------------------------- 1 | module Issue115 where 2 | 3 | class Pointed a where 4 | it :: a 5 | 6 | data A = A1 7 | 8 | instance Pointed A where 9 | it = A1 10 | 11 | data Delay a = Later (Delay a) 12 | | Now a 13 | 14 | test :: Delay A 15 | test = Later (Now it) 16 | 17 | -------------------------------------------------------------------------------- /test/golden/Issue119.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue119.agda:10,1-4 2 | agda2hs: Symbol aaa is missing a COMPILE pragma or rewrite rule 3 | -------------------------------------------------------------------------------- /test/golden/Issue125.err: -------------------------------------------------------------------------------- 1 | Cannot generate multiple constructors with the same identifier: ACtr 2 | -------------------------------------------------------------------------------- /test/golden/Issue14.hs: -------------------------------------------------------------------------------- 1 | module Issue14 where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | constid :: a -> b -> b 6 | constid x = \ x -> x 7 | 8 | sectionTest₁ :: Natural -> Natural -> Natural 9 | sectionTest₁ n = (+ n) 10 | 11 | sectionTest₂ :: Natural -> Natural -> Natural 12 | sectionTest₂ section = (+ section) 13 | 14 | -------------------------------------------------------------------------------- /test/golden/Issue142.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue142.agda:6,1-12 2 | not supported by agda2hs: forced (dot) patterns in non-erased positions 3 | -------------------------------------------------------------------------------- /test/golden/Issue145.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, BangPatterns #-} 2 | module Issue145 where 3 | 4 | it :: forall a . a -> a 5 | it x = x 6 | 7 | it' :: Monoid a => a -> a 8 | it' x = x 9 | 10 | data Ok' a = Thing' !a 11 | 12 | data Ok a = Thing a 13 | 14 | test :: Ok String 15 | test = Thing "ok" 16 | 17 | -------------------------------------------------------------------------------- /test/golden/Issue146.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue146.agda:20,3-12 2 | not supported in Haskell: copatterns 3 | -------------------------------------------------------------------------------- /test/golden/Issue150.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue150.agda:12,1-5 2 | Record pattern translation not supported. Use a pattern matching lambda instead. 3 | -------------------------------------------------------------------------------- /test/golden/Issue154.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue154.agda:5,1-4 2 | constructor `zero` not supported in patterns 3 | -------------------------------------------------------------------------------- /test/golden/Issue169-record.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue169-record.agda:22,3-16 2 | illegal instance declaration: instances using default methods should use a named definition or an anonymous `λ where`. 3 | -------------------------------------------------------------------------------- /test/golden/Issue169.hs: -------------------------------------------------------------------------------- 1 | module Issue169 where 2 | 3 | newtype Identity a = Identity{runIdentity :: a} 4 | 5 | showIdentity :: Show a => Identity a -> String 6 | showIdentity (Identity id) = "Id < " ++ show id ++ " >" 7 | 8 | instance (Show a) => Show (Identity a) where 9 | show = showIdentity 10 | 11 | -------------------------------------------------------------------------------- /test/golden/Issue185.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue185.agda:10,3-19 2 | not supported by agda2hs: functions inside a record module 3 | -------------------------------------------------------------------------------- /test/golden/Issue200.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Issue200 where 3 | 4 | data Void 5 | 6 | test :: Maybe Void -> Maybe Void 7 | test 8 | = \case 9 | Nothing -> Nothing 10 | 11 | -------------------------------------------------------------------------------- /test/golden/Issue210.hs: -------------------------------------------------------------------------------- 1 | module Issue210 where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | class Test a where 6 | f :: a -> a 7 | 8 | instance Test Natural where 9 | f n = h 10 | where 11 | g :: Natural 12 | g = 3 + n 13 | h :: Natural 14 | h = n + g 15 | 16 | f1 :: Natural -> Natural 17 | f1 n = h1 18 | where 19 | g1 :: Natural 20 | g1 = 3 + n 21 | h1 :: Natural 22 | h1 = n + g1 23 | 24 | f2 :: Natural -> Natural 25 | f2 n = h2 n 26 | where 27 | g2 :: Natural 28 | g2 = 3 + n 29 | h2 :: Natural -> Natural 30 | h2 m = n + g2 + m 31 | 32 | -------------------------------------------------------------------------------- /test/golden/Issue218.hs: -------------------------------------------------------------------------------- 1 | module Issue218 where 2 | 3 | foo :: Int -> Int 4 | foo n = n 5 | 6 | bar :: Int 7 | bar = foo 42 8 | 9 | -------------------------------------------------------------------------------- /test/golden/Issue223.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue223.agda:8,1-5 2 | Functions defined with absurd patterns exclusively are not supported. Use function `error` from the Haskell.Prelude instead. 3 | -------------------------------------------------------------------------------- /test/golden/Issue251.hs: -------------------------------------------------------------------------------- 1 | module Issue251 where 2 | 3 | get :: Int -> Int 4 | get x = x 5 | 6 | test :: Int 7 | test = get 42 8 | 9 | -------------------------------------------------------------------------------- /test/golden/Issue264.hs: -------------------------------------------------------------------------------- 1 | module Issue264 where 2 | 3 | data Term = Dummy 4 | 5 | reduce :: Term -> Term 6 | reduce v = go v 7 | where 8 | go :: Term -> Term 9 | go v = v 10 | 11 | -------------------------------------------------------------------------------- /test/golden/Issue273.hs: -------------------------------------------------------------------------------- 1 | module Issue273 where 2 | 3 | test :: (Int, Int) -> Int 4 | test = ((\ r -> snd r) $) 5 | 6 | mySnd :: (Int, Int) -> Int 7 | mySnd x = snd x 8 | 9 | test2 :: (Int, Int) -> Int 10 | test2 = (mySnd $) 11 | 12 | test3 :: (Int, Int) -> Int 13 | test3 = \ x -> snd x 14 | 15 | test4 :: (Int, Int) -> Int 16 | test4 = mySnd 17 | 18 | test5 :: (Int, Int) -> Int -> Int 19 | test5 = \ x _ -> (\ r -> snd r) $ x 20 | 21 | test6 :: Int -> Int 22 | test6 = ((1 + 1) `subtract`) 23 | 24 | test7 :: Int -> Int 25 | test7 = (+ (1 - 1)) 26 | 27 | -------------------------------------------------------------------------------- /test/golden/Issue286.hs: -------------------------------------------------------------------------------- 1 | module Issue286 where 2 | 3 | test :: Int 4 | test = 42 5 | 6 | -------------------------------------------------------------------------------- /test/golden/Issue301.hs: -------------------------------------------------------------------------------- 1 | module Issue301 where 2 | 3 | data MyData a = Nuttin' 4 | 5 | instance Foldable MyData where 6 | foldMap _ _ = mempty 7 | 8 | (><) :: MyData a -> MyData a -> MyData a 9 | _ >< _ = Nuttin' 10 | 11 | instance Semigroup (MyData a) where 12 | (<>) = (><) 13 | 14 | instance Monoid (MyData a) where 15 | mempty = Nuttin' 16 | 17 | -------------------------------------------------------------------------------- /test/golden/Issue302.hs: -------------------------------------------------------------------------------- 1 | module Issue302 where 2 | 3 | not0 :: Int -> Bool 4 | not0 n = n /= 0 5 | 6 | -------------------------------------------------------------------------------- /test/golden/Issue305.hs: -------------------------------------------------------------------------------- 1 | module Issue305 where 2 | 3 | class Class a where 4 | foo :: a -> a 5 | 6 | instance Class Int where 7 | foo = (+ 1) 8 | 9 | instance Class Bool where 10 | foo = not 11 | 12 | test :: Int 13 | test = foo 41 14 | 15 | anotherTest :: Int 16 | anotherTest = test 17 | 18 | yetAnotherTest :: Int 19 | yetAnotherTest 20 | = case Just True of 21 | Nothing -> error "unreachable" 22 | Just y -> foo 5 23 | 24 | andOneMoreTest :: Int -> Int 25 | andOneMoreTest x = foo 5 26 | 27 | class Class a => Subclass a where 28 | bar :: a 29 | 30 | instance Subclass Bool where 31 | bar = False 32 | 33 | -------------------------------------------------------------------------------- /test/golden/Issue308.hs: -------------------------------------------------------------------------------- 1 | module Issue308 where 2 | 3 | class Class a where 4 | foo :: a -> a 5 | 6 | instance Class Int where 7 | foo = (+ 1) 8 | 9 | tester :: Int 10 | tester = foo 41 11 | 12 | -------------------------------------------------------------------------------- /test/golden/Issue309.hs: -------------------------------------------------------------------------------- 1 | module Issue309 where 2 | 3 | type Ap p = p 4 | 5 | -------------------------------------------------------------------------------- /test/golden/Issue317.hs: -------------------------------------------------------------------------------- 1 | module Issue317 where 2 | 3 | data D = C{unC :: Int} 4 | 5 | test :: D -> D 6 | test d = (C . \ r -> unC r) $ d 7 | 8 | -------------------------------------------------------------------------------- /test/golden/Issue324.hs: -------------------------------------------------------------------------------- 1 | module Issue324 where 2 | 3 | import Issue324instance () 4 | 5 | test :: Bool 6 | test = not == id 7 | 8 | -------------------------------------------------------------------------------- /test/golden/Issue324instance.hs: -------------------------------------------------------------------------------- 1 | module Issue324instance where 2 | 3 | instance Eq (Bool -> Bool) where 4 | x == y = x True == y True && x False == y False 5 | 6 | -------------------------------------------------------------------------------- /test/golden/Issue353.hs: -------------------------------------------------------------------------------- 1 | module Issue353 where 2 | 3 | hello :: Bool -> Bool 4 | hello a = a 5 | 6 | world :: Bool -> Bool 7 | world a = hello a 8 | 9 | world2 :: Bool -> Bool 10 | world2 a = hello a 11 | 12 | foo :: Bool -> Int -> Bool 13 | foo a b = not a 14 | 15 | bar :: Bool -> Bool 16 | bar b = foo True 0 17 | 18 | baz :: Bool -> Bool 19 | baz b = bar b 20 | 21 | callFromNested :: Bool -> Bool 22 | callFromNested b = nested 23 | where 24 | nested :: Bool 25 | nested = bar b 26 | 27 | -------------------------------------------------------------------------------- /test/golden/Issue357a.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue357a.agda:10,1-6 2 | Bad Haskell type: Level 3 | -------------------------------------------------------------------------------- /test/golden/Issue357b.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue357b.agda:10,1-2 2 | Bad Haskell type: Level 3 | -------------------------------------------------------------------------------- /test/golden/Issue377.hs: -------------------------------------------------------------------------------- 1 | module Issue377 where 2 | 3 | import Data.Maybe (fromMaybe) 4 | 5 | test :: Integer 6 | test = fromMaybe 0 (Just 12) 7 | 8 | -------------------------------------------------------------------------------- /test/golden/Issue394.hs: -------------------------------------------------------------------------------- 1 | module Issue394 where 2 | 3 | import Data.ByteString (ByteString) 4 | 5 | test :: ByteString -> ByteString -> Bool 6 | test x y = x == y 7 | 8 | -------------------------------------------------------------------------------- /test/golden/Issue65.hs: -------------------------------------------------------------------------------- 1 | module Issue65 where 2 | 3 | yeet :: Bool -> a -> a -> a 4 | yeet False x y = y 5 | yeet True x y = x 6 | 7 | xx :: Int 8 | xx = yeet True 1 2 9 | 10 | -------------------------------------------------------------------------------- /test/golden/Issue69.hs: -------------------------------------------------------------------------------- 1 | module Issue69 where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | data Map k a = Bin Natural k a (Map k a) (Map k a) 6 | | Tip 7 | 8 | size :: Map k a -> Natural 9 | size Tip = 0 10 | size (Bin sz _ _ _ _) = sz 11 | 12 | -------------------------------------------------------------------------------- /test/golden/Issue71.err: -------------------------------------------------------------------------------- 1 | test/Fail/Issue71.agda:8,28-11,4 2 | not supported by agda2hs: as patterns 3 | -------------------------------------------------------------------------------- /test/golden/Issue73.hs: -------------------------------------------------------------------------------- 1 | module Issue73 where 2 | 3 | class ImplicitField a where 4 | aField :: a 5 | 6 | -------------------------------------------------------------------------------- /test/golden/Issue90.hs: -------------------------------------------------------------------------------- 1 | module Issue90 where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | good :: Natural 6 | good = bar 7 | where 8 | foo :: Natural 9 | foo = 42 10 | bar :: Natural 11 | bar = foo 12 | 13 | bad :: Natural 14 | bad = bar 15 | where 16 | bar :: Natural 17 | bar = foo 18 | foo :: Natural 19 | foo = 42 20 | 21 | good2 :: Natural 22 | good2 = bar 23 | where 24 | foo :: Natural 25 | foo = 42 + x 26 | where 27 | x :: Natural 28 | x = 1 29 | bar :: Natural 30 | bar = foo + x 31 | where 32 | x :: Natural 33 | x = 2 34 | 35 | bad2 :: Natural 36 | bad2 = bar 37 | where 38 | bar :: Natural 39 | bar = foo + x 40 | where 41 | x :: Natural 42 | x = 2 43 | foo :: Natural 44 | foo = 42 + x 45 | where 46 | x :: Natural 47 | x = 1 48 | 49 | test :: Bool -> Natural 50 | test True = bar 51 | where 52 | foo :: Natural 53 | foo = 42 + ted 54 | where 55 | nes :: Natural 56 | nes = 1 57 | ted :: Natural 58 | ted = nes + 1 59 | bar :: Natural 60 | bar = foo 61 | test False = bar 62 | where 63 | bar :: Natural 64 | bar = foo 65 | foo :: Natural 66 | foo = 42 + ted 67 | where 68 | ted :: Natural 69 | ted = nes + 1 70 | nes :: Natural 71 | nes = 1 72 | 73 | -------------------------------------------------------------------------------- /test/golden/Issue92.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Issue92 where 3 | 4 | foo :: forall a . a -> a 5 | foo x = bar 6 | where 7 | bar :: a 8 | bar = baz 9 | where 10 | baz :: a 11 | baz = x 12 | 13 | -------------------------------------------------------------------------------- /test/golden/Issue93.hs: -------------------------------------------------------------------------------- 1 | module Issue93 where 2 | 3 | fun :: Bool -> Bool 4 | fun x 5 | = case x of 6 | True -> False 7 | False -> y 8 | where 9 | y :: Bool 10 | y = True 11 | 12 | nested :: Maybe Bool -> Bool 13 | nested x 14 | = case x of 15 | Just b -> case y of 16 | True -> b 17 | False -> z 18 | Nothing -> y 19 | where 20 | y :: Bool 21 | y = True 22 | z :: Bool 23 | z = case y of 24 | True -> y 25 | False -> True 26 | 27 | -------------------------------------------------------------------------------- /test/golden/Issue94.hs: -------------------------------------------------------------------------------- 1 | module Issue94 where 2 | 3 | thing :: [a] -> [a] 4 | thing xs = aux xs 5 | where 6 | aux :: [a] -> [a] 7 | aux xs = xs 8 | 9 | -------------------------------------------------------------------------------- /test/golden/Kinds.hs: -------------------------------------------------------------------------------- 1 | module Kinds where 2 | 3 | data ReaderT r m a = RdrT{runReaderT :: r -> m a} 4 | 5 | data Kleisli m a b = K (a -> m b) 6 | 7 | -------------------------------------------------------------------------------- /test/golden/LanguageConstructs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module LanguageConstructs where 3 | 4 | oneTwoThree :: [Int] 5 | oneTwoThree = [1, 2, 3] 6 | 7 | exactlyTwo :: [a] -> Maybe (a, a) 8 | exactlyTwo [x, y] = Just (x, y) 9 | exactlyTwo _ = Nothing 10 | 11 | ifThenElse :: Int -> String 12 | ifThenElse n = if n >= 10 then "big" else "small" 13 | 14 | maybeToList :: Maybe a -> [a] 15 | maybeToList 16 | = \case 17 | Nothing -> [] 18 | Just x -> [x] 19 | 20 | mhead :: [a] -> Maybe a 21 | mhead xs 22 | = case xs of 23 | [] -> Nothing 24 | x : _ -> Just x 25 | 26 | plus5minus5 :: Int -> Int 27 | plus5minus5 n 28 | = case n + 5 of 29 | m -> m - 5 30 | 31 | enum₁ :: [Int] 32 | enum₁ = [5 .. 10] 33 | 34 | enum₂ :: [Integer] 35 | enum₂ = [10, 20 .. 100] 36 | 37 | enum₃ :: [Bool] 38 | enum₃ = [False ..] 39 | 40 | enum₄ :: [Ordering] 41 | enum₄ = [LT, EQ ..] 42 | 43 | underappliedEnum :: [Int] -> [[Int]] 44 | underappliedEnum = map (enumFromTo 1) 45 | 46 | -------------------------------------------------------------------------------- /test/golden/LawfulOrd.hs: -------------------------------------------------------------------------------- 1 | module LawfulOrd where 2 | 3 | data Ordered a = Gt a a 4 | | Lt a a 5 | | E a a 6 | 7 | order :: Ord a => a -> a -> Ordered a 8 | order left right 9 | = if left < right then Lt left right else 10 | if left == right then E left right else Gt left right 11 | 12 | -------------------------------------------------------------------------------- /test/golden/LiteralPatterns.hs: -------------------------------------------------------------------------------- 1 | module LiteralPatterns where 2 | 3 | testInt :: Integer -> Bool 4 | testInt 10 = True 5 | testInt (-8) = True 6 | testInt _ = False 7 | 8 | testChar :: Char -> Bool 9 | testChar 'c' = True 10 | testChar _ = False 11 | 12 | -------------------------------------------------------------------------------- /test/golden/MatchOnDelay.err: -------------------------------------------------------------------------------- 1 | test/Fail/MatchOnDelay.agda:7,1-4 2 | constructor `now` not supported in patterns 3 | -------------------------------------------------------------------------------- /test/golden/ModuleParameters.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module ModuleParameters where 3 | 4 | data Scope p = Empty 5 | | Bind p (Scope p) 6 | 7 | unbind :: forall p . Scope p -> Scope p 8 | unbind Empty = Empty 9 | unbind (Bind _ s) = s 10 | 11 | thing :: forall p a . a -> a 12 | thing x = y 13 | where 14 | y :: a 15 | y = x 16 | 17 | stuff :: forall p a . a -> Scope p -> a 18 | stuff x Empty = x 19 | stuff x (Bind _ _) = x 20 | 21 | more :: forall p a b . b -> a -> Scope p -> Scope p 22 | more _ _ Empty = Empty 23 | more _ _ (Bind _ s) = s 24 | 25 | -------------------------------------------------------------------------------- /test/golden/ModuleParametersImports.hs: -------------------------------------------------------------------------------- 1 | module ModuleParametersImports where 2 | 3 | import qualified ModuleParameters (Scope(Bind, Empty), unbind) 4 | import Numeric.Natural (Natural) 5 | 6 | scope :: ModuleParameters.Scope Natural 7 | scope 8 | = ModuleParameters.unbind 9 | (ModuleParameters.Bind 3 10 | (ModuleParameters.Bind 2 ModuleParameters.Empty)) 11 | 12 | -------------------------------------------------------------------------------- /test/golden/MultiArgumentPatternLambda.err: -------------------------------------------------------------------------------- 1 | test/Fail/MultiArgumentPatternLambda.agda:7,15-9,41 2 | Pattern matching lambdas must take a single argument 3 | -------------------------------------------------------------------------------- /test/golden/NewTypePragma.hs: -------------------------------------------------------------------------------- 1 | module NewTypePragma where 2 | 3 | -- data newtype 4 | 5 | newtype Indexed a = MkIndexed (Int, a) 6 | 7 | index :: (Int, a) -> Indexed a 8 | index = MkIndexed 9 | 10 | -- data newtype with deriving 11 | 12 | newtype Pair a b = MkPair (a, b) 13 | deriving (Show, Eq) 14 | 15 | -- record newtype 16 | 17 | newtype Identity a = MkIdentity{runIdentity :: a} 18 | 19 | -- record newtype with erased proof 20 | 21 | newtype Equal a = MkEqual{pair :: (a, a)} 22 | 23 | -- record newtype with same name 24 | 25 | newtype Duo a = Duo{duo :: (a, a)} 26 | 27 | createDuo :: a -> a -> Duo a 28 | createDuo a b = Duo (a, b) 29 | 30 | -------------------------------------------------------------------------------- /test/golden/NewTypeRecordTwoFields.err: -------------------------------------------------------------------------------- 1 | test/Fail/NewTypeRecordTwoFields.agda:5,8-11 2 | Newtype must have exactly one field in constructor: MkDuo 3 | -------------------------------------------------------------------------------- /test/golden/NewTypeTwoConstructors.err: -------------------------------------------------------------------------------- 1 | test/Fail/NewTypeTwoConstructors.agda:5,6-12 2 | Newtype must have exactly one constructor in definition: Choice 3 | -------------------------------------------------------------------------------- /test/golden/NewTypeTwoFields.err: -------------------------------------------------------------------------------- 1 | test/Fail/NewTypeTwoFields.agda:5,6-9 2 | Newtype must have exactly one field in constructor: MkDuo 3 | -------------------------------------------------------------------------------- /test/golden/NonCanonicalSpecialFunction.err: -------------------------------------------------------------------------------- 1 | test/Fail/NonCanonicalSpecialFunction.agda:17,1-5 2 | illegal instance: sneaky 3 | -------------------------------------------------------------------------------- /test/golden/NonCanonicalSuperclass.err: -------------------------------------------------------------------------------- 1 | test/Fail/NonCanonicalSuperclass.agda:28,3-15 2 | illegal instance: record { foo = id } 3 | -------------------------------------------------------------------------------- /test/golden/NonClassInstance.hs: -------------------------------------------------------------------------------- 1 | module NonClassInstance where 2 | 3 | foo :: Bool -> Bool -> Bool 4 | foo _ b = not b 5 | 6 | bar :: Bool -> Bool 7 | bar b = foo b b 8 | 9 | -------------------------------------------------------------------------------- /test/golden/NonCopatternInstance.err: -------------------------------------------------------------------------------- 1 | test/Fail/NonCopatternInstance.agda:19,3-12 2 | Type class instances must be defined using copatterns (or top-level 3 | records) and cannot be defined using helper functions. 4 | -------------------------------------------------------------------------------- /test/golden/NonStarDatatypeIndex.err: -------------------------------------------------------------------------------- 1 | test/Fail/NonStarDatatypeIndex.agda:5,6-7 2 | Term variable in type parameter not supported: (n : Nat) 3 | -------------------------------------------------------------------------------- /test/golden/NonStarRecordIndex.err: -------------------------------------------------------------------------------- 1 | test/Fail/NonStarRecordIndex.agda:5,8-9 2 | Term variable in type parameter not supported: (n : Nat) 3 | -------------------------------------------------------------------------------- /test/golden/Numbers.hs: -------------------------------------------------------------------------------- 1 | module Numbers where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | posNatural :: Natural 6 | posNatural = 14 7 | 8 | posInteger :: Integer 9 | posInteger = 52 10 | 11 | negInteger :: Integer 12 | negInteger = -1001 13 | 14 | natToPos :: Natural -> Integer 15 | natToPos n = fromIntegral n 16 | 17 | natToNeg :: Natural -> Integer 18 | natToNeg n = (negate . fromIntegral) n 19 | 20 | -------------------------------------------------------------------------------- /test/golden/OtherImportee.hs: -------------------------------------------------------------------------------- 1 | module OtherImportee where 2 | 3 | data OtherFoo = MkFoo 4 | 5 | -------------------------------------------------------------------------------- /test/golden/PartialCase.err: -------------------------------------------------------------------------------- 1 | test/Fail/PartialCase.agda:5,1-7 2 | case_of_ must be fully applied to a lambda term 3 | -------------------------------------------------------------------------------- /test/golden/PartialCaseNoLambda.err: -------------------------------------------------------------------------------- 1 | test/Fail/PartialCaseNoLambda.agda:5,1-13 2 | case_of_ must be fully applied to a lambda term 3 | -------------------------------------------------------------------------------- /test/golden/PartialIf.err: -------------------------------------------------------------------------------- 1 | test/Fail/PartialIf.agda:5,1-11 2 | if_then_else_ must be fully applied 3 | -------------------------------------------------------------------------------- /test/golden/Pragmas.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module Pragmas where 5 | 6 | foo :: Bool -> a -> (a, Int) 7 | foo = \ case 8 | False -> (, 0) 9 | True -> (, 1) 10 | 11 | -------------------------------------------------------------------------------- /test/golden/ProjLike.hs: -------------------------------------------------------------------------------- 1 | module ProjLike where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | data Scope a = Empty 6 | | Bind a (Scope a) 7 | 8 | test :: Scope Natural 9 | test = Bind 2 Empty 10 | 11 | -------------------------------------------------------------------------------- /test/golden/ProjectionLike.hs: -------------------------------------------------------------------------------- 1 | module ProjectionLike where 2 | 3 | data R = R{fld :: Int} 4 | 5 | foo :: R -> Int 6 | foo x = fld x 7 | 8 | -------------------------------------------------------------------------------- /test/golden/QualifiedImportee.hs: -------------------------------------------------------------------------------- 1 | module QualifiedImportee where 2 | 3 | foo :: Int 4 | foo = 43 5 | 6 | (!#) :: Int -> Int -> Int 7 | x !# y = x - y 8 | 9 | data Foo = MkFoo 10 | 11 | class Fooable a where 12 | doTheFoo :: a 13 | defaultFoo :: a 14 | {-# MINIMAL doTheFoo #-} 15 | defaultFoo = doTheFoo 16 | 17 | instance Fooable Foo where 18 | doTheFoo = MkFoo 19 | 20 | -------------------------------------------------------------------------------- /test/golden/QualifiedImports.hs: -------------------------------------------------------------------------------- 1 | module QualifiedImports where 2 | 3 | import qualified Importee (Foo(MkFoo), foo) 4 | import QualifiedImportee () 5 | import qualified QualifiedImportee as Qually (Foo, Fooable(defaultFoo, doTheFoo), foo, (!#)) 6 | 7 | -- ** simple qualification 8 | 9 | simpqualBar :: Int 10 | simpqualBar = Importee.foo 11 | 12 | simpfoo :: Importee.Foo 13 | simpfoo = Importee.MkFoo 14 | 15 | -- ** qualified imports 16 | 17 | qualBar :: Int 18 | qualBar = Qually.foo 19 | 20 | qualBaz :: Int 21 | qualBaz = (Qually.!#) 2 2 22 | 23 | qualFooable :: Qually.Foo 24 | qualFooable = Qually.doTheFoo 25 | 26 | qualDefaultBar :: Qually.Foo 27 | qualDefaultBar = Qually.defaultFoo 28 | 29 | type Foo = Importee.Foo 30 | 31 | -------------------------------------------------------------------------------- /test/golden/QualifiedModule.hs: -------------------------------------------------------------------------------- 1 | module QualifiedModule where 2 | 3 | data D = C 4 | 5 | f :: D -> D 6 | f C = C 7 | 8 | g :: D 9 | g = h 10 | where 11 | h :: D 12 | h = C 13 | 14 | -------------------------------------------------------------------------------- /test/golden/QualifiedPrelude.hs: -------------------------------------------------------------------------------- 1 | module QualifiedPrelude where 2 | 3 | import Numeric.Natural (Natural) 4 | import qualified Prelude as Pre (Foldable(foldr), Num((+)), (.)) 5 | 6 | -- ** qualifying the Prelude 7 | 8 | (+) :: Natural -> Natural -> Natural 9 | x + y = x 10 | 11 | comp :: 12 | (Natural -> Natural) -> (Natural -> Natural) -> Natural -> Natural 13 | comp f g = (Pre..) f g 14 | 15 | test :: Natural 16 | test = (Pre.+) 0 (1 + 0) 17 | 18 | testComp :: Natural 19 | testComp = comp (+ 0) (\ section -> (Pre.+) section 1) 0 20 | 21 | -- ** interplay with (qualified) default methods of existing class 22 | 23 | testFoldr :: [Natural] -> Natural 24 | testFoldr = Pre.foldr (\ _ x -> x) 0 25 | 26 | -- ** re-qualifying the Prelude 27 | 28 | retest :: Natural 29 | retest = (Pre.+) 0 (1 + 0) 30 | 31 | -------------------------------------------------------------------------------- /test/golden/QualifiedRecordProjections.err: -------------------------------------------------------------------------------- 1 | test/Fail/QualifiedRecordProjections.agda:7,5-8 2 | Record projections (`one` in this case) must be brought into scope 3 | when compiling to Haskell record types. Add `open Test public` 4 | after the record declaration to fix this. 5 | -------------------------------------------------------------------------------- /test/golden/RankNTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE Haskell98 #-} 3 | 4 | module RankNTypes where 5 | 6 | data MyBool = MyTrue 7 | | MyFalse 8 | 9 | rank2ForallUse :: (forall a . a -> a) -> MyBool 10 | rank2ForallUse f = f MyTrue 11 | 12 | rank2Module :: (forall a . a -> a) -> MyBool 13 | rank2Module f = f MyTrue 14 | 15 | -------------------------------------------------------------------------------- /test/golden/Records.hs: -------------------------------------------------------------------------------- 1 | module Records where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | data Pair a b = MkPair{proj₁ :: a, proj₂ :: b} 6 | 7 | data Wrap a = Wrap{unwrap :: a} 8 | 9 | class MyMonoid a where 10 | mempty :: a 11 | mappend :: a -> a -> a 12 | 13 | swap :: Pair a b -> Pair b a 14 | swap (MkPair x y) = MkPair y x 15 | 16 | swap₂ :: Wrap (Pair a b) -> Wrap (Pair b a) 17 | swap₂ (Wrap p) = Wrap (MkPair (proj₂ p) (proj₁ p)) 18 | 19 | data User = User{name :: String, code :: Natural} 20 | deriving (Eq, Show) 21 | 22 | -------------------------------------------------------------------------------- /test/golden/RequalifiedImports.hs: -------------------------------------------------------------------------------- 1 | module RequalifiedImports where 2 | 3 | import OtherImportee (OtherFoo(MkFoo)) 4 | import QualifiedImportee () 5 | import qualified QualifiedImportee as A (Foo, Fooable(defaultFoo, doTheFoo), foo, (!#)) 6 | 7 | -- ** conflicting imports are all replaced with the "smallest" qualifier 8 | -- * the characters are ordered based on their ASCII value (i.e. capitals first) 9 | -- * the order of the imports in the file does not matter 10 | -- * the scope-checker has already replaced previous definitions in the file 11 | 12 | requalBar :: Int 13 | requalBar = A.foo 14 | 15 | requalBaz :: Int 16 | requalBaz = (A.!#) 2 2 17 | 18 | requalFooable :: A.Foo 19 | requalFooable = A.doTheFoo 20 | 21 | requalDefaultBar :: A.Foo 22 | requalDefaultBar = A.defaultFoo 23 | 24 | -- ** qualifying an open'ed module has no effect 25 | 26 | type T = Int 27 | 28 | otherFoo :: OtherFoo 29 | otherFoo = MkFoo 30 | 31 | -------------------------------------------------------------------------------- /test/golden/ScopedTypeVariables.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module ScopedTypeVariables where 3 | 4 | foo :: forall a . Eq a => a -> Bool 5 | foo x = it x == x 6 | where 7 | it :: a -> a 8 | it = const x 9 | 10 | bar :: forall a b . a -> b -> (b -> b) -> b 11 | bar x y f = baz y 12 | where 13 | baz :: b -> b 14 | baz z = f (f z) 15 | 16 | data D = MakeD Bool 17 | 18 | mybool :: Bool 19 | mybool = False 20 | 21 | -------------------------------------------------------------------------------- /test/golden/SecondImportee.hs: -------------------------------------------------------------------------------- 1 | module SecondImportee where 2 | 3 | anotherFoo :: Int 4 | anotherFoo = 666 5 | 6 | -------------------------------------------------------------------------------- /test/golden/Sections.hs: -------------------------------------------------------------------------------- 1 | module Sections where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | test₁ :: Natural -> Natural 6 | test₁ = (5 +) 7 | 8 | test₂ :: Natural -> Natural 9 | test₂ = (+ 5) 10 | 11 | test₃ :: Natural -> Natural 12 | test₃ = (5 +) 13 | 14 | test₄ :: Natural -> Natural 15 | test₄ = \ x -> x + 5 16 | 17 | test₅ :: Natural -> Natural 18 | test₅ = (5 +) 19 | 20 | -------------------------------------------------------------------------------- /test/golden/Superclass.hs: -------------------------------------------------------------------------------- 1 | module Superclass where 2 | 3 | class Super a where 4 | myFun :: a -> a 5 | 6 | class Super a => Sub a where 7 | 8 | foo :: Sub a => a -> a 9 | foo = myFun . myFun 10 | 11 | class Super a => Sub2 a where 12 | 13 | class (Sub a, Sub2 a) => Subber a where 14 | 15 | bar :: Subber a => a -> a 16 | bar = myFun . id 17 | 18 | instance Super Int where 19 | myFun = (1 +) 20 | 21 | instance Sub Int where 22 | 23 | class Ord a => DiscreteOrd a where 24 | 25 | instance DiscreteOrd Bool where 26 | 27 | baz :: DiscreteOrd a => a -> Bool 28 | baz x = x < x 29 | 30 | usebaz :: Bool 31 | usebaz = baz True 32 | 33 | -------------------------------------------------------------------------------- /test/golden/TransparentFun.hs: -------------------------------------------------------------------------------- 1 | module TransparentFun where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | testMyId :: Natural 6 | testMyId = 42 7 | 8 | testTyId :: Int -> Int 9 | testTyId n = n 10 | 11 | data Tree = Tip 12 | | Bin Tree Tree 13 | 14 | testTreeId :: Tree -> Tree 15 | testTreeId = id 16 | 17 | -------------------------------------------------------------------------------- /test/golden/Tree.hs: -------------------------------------------------------------------------------- 1 | module Tree where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | data Tree = Leaf 6 | | Node Natural Tree Tree 7 | 8 | -------------------------------------------------------------------------------- /test/golden/Tuples.hs: -------------------------------------------------------------------------------- 1 | module Tuples where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | swap :: (a, b) -> (b, a) 6 | swap (a, b) = (b, a) 7 | 8 | data TuplePos = Test (TuplePos, Bool) 9 | 10 | t1 :: (Bool, Bool, Bool) 11 | t1 = (True, False, True) 12 | 13 | t2 :: ((Bool, Bool), Bool) 14 | t2 = ((True, False), True) 15 | 16 | t3 :: (Bool, (Bool, Bool)) 17 | t3 = (True, (False, True)) 18 | 19 | pair :: (Int, Int) 20 | pair = (1, 2) 21 | 22 | test :: Int 23 | test = fst pair + snd pair 24 | 25 | test2 :: Bool 26 | test2 27 | = case t1 of 28 | (a, b, c) -> c 29 | 30 | t4 :: (Natural, Bool) 31 | t4 = (3, True) 32 | 33 | t5 :: (a, b) -> a 34 | t5 p 35 | = case p of 36 | (x, y) -> x 37 | 38 | -------------------------------------------------------------------------------- /test/golden/TypeBasedUnboxing.hs: -------------------------------------------------------------------------------- 1 | module TypeBasedUnboxing where 2 | 3 | foo :: Int -> Int 4 | foo = \ r -> r 5 | 6 | -------------------------------------------------------------------------------- /test/golden/TypeDirected.hs: -------------------------------------------------------------------------------- 1 | module TypeDirected where 2 | 3 | myconst :: a -> a -> a 4 | myconst x y = x 5 | 6 | fn :: Bool -> Int 7 | fn False = 0 8 | fn True = 5 9 | 10 | test1 :: Int 11 | test1 = fn True 12 | 13 | test2 :: Int 14 | test2 = fn False 15 | 16 | -------------------------------------------------------------------------------- /test/golden/TypeLambda.err: -------------------------------------------------------------------------------- 1 | test/Fail/TypeLambda.agda:6,1-4 2 | Not supported: type-level lambda λ y → Nat 3 | -------------------------------------------------------------------------------- /test/golden/TypeOperatorExport.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | module TypeOperatorExport where 4 | 5 | type (<) a b = a 6 | 7 | data (***) a b = (:*:) a b 8 | 9 | (&&&) :: Bool -> Bool -> Bool 10 | False &&& _ = False 11 | _ &&& b2 = b2 12 | 13 | -------------------------------------------------------------------------------- /test/golden/TypeOperatorImport.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | module TypeOperatorImport where 4 | 5 | import TypeOperatorExport ((&&&), type (***)((:*:)), type (<)) 6 | 7 | test1 :: (<) () Bool 8 | test1 = () 9 | 10 | test2 :: Bool -> Bool -> (***) () Bool 11 | test2 b1 b2 = ((() :*:) . not) (b1 &&& b2) 12 | 13 | -------------------------------------------------------------------------------- /test/golden/TypeOperators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | module TypeOperators where 4 | 5 | import Numeric.Natural (Natural) 6 | 7 | type (:++:) = Either 8 | 9 | mx :: (:++:) Bool Natural 10 | mx = Left True 11 | 12 | type (++++) = Either 13 | 14 | mx' :: (++++) Bool Natural 15 | mx' = Left True 16 | 17 | data (****) a b = (:****) a b 18 | 19 | cross :: (****) Bool Natural 20 | cross = True :**** 1 21 | 22 | -------------------------------------------------------------------------------- /test/golden/TypeSignature.hs: -------------------------------------------------------------------------------- 1 | module TypeSignature where 2 | 3 | import Numeric.Natural (Natural) 4 | 5 | five :: Natural 6 | five = (id :: Natural -> Natural) 5 7 | 8 | -------------------------------------------------------------------------------- /test/golden/TypeSynonyms.hs: -------------------------------------------------------------------------------- 1 | module TypeSynonyms where 2 | 3 | data Nat = Zero 4 | | Suc Nat 5 | 6 | type Nat' = Nat 7 | 8 | myNat :: Nat' 9 | myNat = Suc (Suc Zero) 10 | 11 | data List a = Nil 12 | | Cons a (List a) 13 | 14 | type List' a = List a 15 | 16 | type NatList = List Nat 17 | 18 | myListFun :: List' Nat' -> NatList 19 | myListFun Nil = Nil 20 | myListFun (Cons x xs) = Cons x (myListFun xs) 21 | 22 | type ListList a = List (List a) 23 | 24 | flatten :: ListList a -> List a 25 | flatten Nil = Nil 26 | flatten (Cons Nil xss) = flatten xss 27 | flatten (Cons (Cons x xs) xss) = Cons x (flatten (Cons xs xss)) 28 | 29 | -------------------------------------------------------------------------------- /test/golden/UnboxPragma.hs: -------------------------------------------------------------------------------- 1 | module UnboxPragma where 2 | 3 | sort1 :: [Int] -> [Int] 4 | sort1 xs = xs 5 | 6 | sort2 :: [Int] -> [Int] 7 | sort2 xs = xs 8 | 9 | sort3 :: [Int] -> [Int] 10 | sort3 xs = xs 11 | 12 | sortAll :: [[Int]] 13 | sortAll = map (\ r -> r) (map (\ xs -> xs) [[1, 2], [3]]) 14 | 15 | type Scope name = Int 16 | 17 | emptyScope :: Scope name 18 | emptyScope = 0 19 | 20 | -------------------------------------------------------------------------------- /test/golden/Vector.hs: -------------------------------------------------------------------------------- 1 | module Vector where 2 | 3 | data Vec a = Nil 4 | | Cons a (Vec a) 5 | 6 | mapV :: (a -> b) -> Vec a -> Vec b 7 | mapV f Nil = Nil 8 | mapV f (Cons x xs) = Cons (f x) (mapV f xs) 9 | 10 | tailV :: Vec a -> Vec a 11 | tailV (Cons x xs) = xs 12 | 13 | -------------------------------------------------------------------------------- /test/golden/WitnessedFlows.hs: -------------------------------------------------------------------------------- 1 | module WitnessedFlows where 2 | 3 | import Control.Monad (guard) 4 | 5 | data Range = MkRange Int Int 6 | 7 | createRange :: Int -> Int -> Maybe Range 8 | createRange low high 9 | = if low <= high then Just (MkRange low high) else Nothing 10 | 11 | createRange' :: Int -> Int -> Maybe Range 12 | createRange' low high 13 | = if low <= high then 14 | if low <= high then Just (MkRange low high) else Nothing else 15 | Nothing 16 | 17 | createRangeCase :: Int -> Int -> Maybe Range 18 | createRangeCase low high 19 | = case low <= high of 20 | True -> Just (MkRange low high) 21 | False -> Nothing 22 | 23 | createRangeGuardSeq :: Int -> Int -> Maybe Range 24 | createRangeGuardSeq low high 25 | = do guard (low <= high) 26 | pure (MkRange low high) 27 | 28 | createRangeGuardFmap :: Int -> Int -> Maybe Range 29 | createRangeGuardFmap low high 30 | = MkRange low high <$ guard (low <= high) 31 | 32 | -------------------------------------------------------------------------------- /test/renderTranslations.sh: -------------------------------------------------------------------------------- 1 | #!/bin/zsh 2 | 3 | # PREREQUISITES: 4 | # - generated target files are placed under build/ 5 | BUILD_DIR=build 6 | # - Agda generated HTML is placed under html/ 7 | AGDA_HTML_DIR=html 8 | 9 | echo "Rendering translations..." 10 | for f in $BUILD_DIR/**/**.*; do 11 | echo " *** file: $f ***" 12 | ext=${f##*.} 13 | fn=${${f#"$BUILD_DIR"/}%."$ext"} 14 | 15 | failMod=$(case $ext in 16 | "err") echo 'Fail.';; 17 | *) echo '';; 18 | esac) 19 | 20 | sourceHtml=$AGDA_HTML_DIR/"$failMod"$(echo $fn | tr '/' '.').html 21 | [ ! -f $sourceHtml ] && \ 22 | echo " No corresponding HTML for $f (should be at $sourceHtml)" && \ 23 | exit 1 24 | echo " $f ~ $sourceHtml" 25 | 26 | mdFn=$BUILD_DIR/"$fn".md 27 | echo " Generating $mdFn" 28 | mdBlock=$(case $ext in 29 | "hs") echo "haskell";; 30 | "rs") echo "rust";; 31 | "agda") echo "agda";; 32 | "sh") echo "bash";; 33 | "js") echo "javascript";; 34 | *) echo "";; 35 | esac) 36 | echo "\`\`\`$mdBlock" > $mdFn 37 | cat $f >> $mdFn 38 | echo "\`\`\`" >> $mdFn 39 | 40 | targetHtml=$BUILD_DIR/"$fn".html 41 | echo " Generating $targetHtml" 42 | pandoc --quiet -i "$mdFn" -o "$targetHtml" -s --highlight-style=tango 43 | mkdir -p "$AGDA_HTML_DIR/$BUILD_DIR" 44 | echo " Copy build/ into html/" 45 | cp -r $BUILD_DIR/ $AGDA_HTML_DIR/ 46 | 47 | echo " Modifying $sourceHtml" 48 | sed -i "s%class=\"Agda\"%class=\"split left Agda\"%g" $sourceHtml 49 | sed -i "s%%
%g" $sourceHtml 50 | done 51 | echo "...done!" 52 | -------------------------------------------------------------------------------- /tutorials/example-basics/HelloWorld.agda: -------------------------------------------------------------------------------- 1 | module HelloWorld where 2 | 3 | open import Haskell.Prelude 4 | 5 | --defining a type synonym 6 | Entry = Int × List String 7 | 8 | 9 | --defining a datatype 10 | data Tree (a : Type) : Type where 11 | Leaf : a → Tree a 12 | Branch : a → Tree a → Tree a → Tree a 13 | 14 | --agda2hs pragmas 15 | {-# COMPILE AGDA2HS Entry #-} 16 | 17 | {-# COMPILE AGDA2HS Tree #-} 18 | -------------------------------------------------------------------------------- /tutorials/example-basics/HelloWorld.hs: -------------------------------------------------------------------------------- 1 | module HelloWorld where 2 | 3 | type Entry = (Int, [String]) 4 | 5 | data Tree a = Leaf a 6 | | Branch a (Tree a) (Tree a) 7 | 8 | -------------------------------------------------------------------------------- /tutorials/example-basics/example-basics.agda-lib: -------------------------------------------------------------------------------- 1 | name: example-basics 2 | include: . 3 | depend: agda2hs 4 | flags: --erasure 5 | -------------------------------------------------------------------------------- /tutorials/example-proofs/example-proofs.agda-lib: -------------------------------------------------------------------------------- 1 | name: example-proofs 2 | include: . 3 | depend: agda2hs, standard-library 4 | flags: --erasure 5 | -------------------------------------------------------------------------------- /tutorials/example-structure/example-structure.agda-lib: -------------------------------------------------------------------------------- 1 | name: example-structure 2 | include: ./src/agda 3 | depend: agda2hs 4 | flags: --erasure 5 | -------------------------------------------------------------------------------- /tutorials/example-structure/script.sh: -------------------------------------------------------------------------------- 1 | agda2hs ./src/agda/Usage.agda -o ./src/haskell/ 2 | -------------------------------------------------------------------------------- /tutorials/example-structure/src/agda/Definition.agda: -------------------------------------------------------------------------------- 1 | module Definition where 2 | 3 | open import Haskell.Prelude 4 | 5 | data CountDown : Type where 6 | MkCountdown : (start : Int) 7 | → {{ @0 h : ((start > 0) ≡ True) }} 8 | → CountDown 9 | 10 | {-# COMPILE AGDA2HS CountDown #-} 11 | -------------------------------------------------------------------------------- /tutorials/example-structure/src/agda/Usage.agda: -------------------------------------------------------------------------------- 1 | module Usage where 2 | 3 | open import Definition 4 | open import Haskell.Prelude 5 | 6 | createCountDown : Int → Maybe CountDown 7 | createCountDown start = if start > 0 then Just (MkCountdown start) else Nothing 8 | 9 | {-# COMPILE AGDA2HS createCountDown #-} 10 | -------------------------------------------------------------------------------- /tutorials/example-structure/src/haskell/Definition.hs: -------------------------------------------------------------------------------- 1 | module Definition where 2 | 3 | data CountDown = MkCountdown Int 4 | 5 | -------------------------------------------------------------------------------- /tutorials/example-structure/src/haskell/Usage.hs: -------------------------------------------------------------------------------- 1 | module Usage where 2 | 3 | import Definition (CountDown(MkCountdown)) 4 | 5 | createCountDown :: Int -> Maybe CountDown 6 | createCountDown start 7 | = if start > 0 then Just (MkCountdown start) else Nothing 8 | 9 | --------------------------------------------------------------------------------