Repository: finkel-lang/finkel Branch: master Commit: 17f1cfc35a55 Files: 541 Total size: 1.2 MB Directory structure: gitextract_w18apfhd/ ├── .appveyor.yml ├── .circleci/ │ └── config.yml ├── .codecov.yml ├── .dir-locals.el ├── .gitattributes ├── .github/ │ ├── ISSUE_TEMPLATE/ │ │ └── bug_report.md │ ├── dependabot.yml │ └── workflows/ │ ├── cabal-install.yml │ ├── ci.yml │ ├── nix-build.yml │ ├── pre-job.yml │ ├── sdist.yml │ └── stack.yml ├── .gitignore ├── .hlint.yaml ├── .readthedocs.yaml ├── .stylish-haskell.yaml ├── .travis.yml ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── cabal.project ├── default.nix ├── doc/ │ ├── LICENSE │ ├── Makefile │ ├── Setup.hs │ ├── conf.py │ ├── contents/ │ │ ├── building-package.rst │ │ ├── finkel-executable.rst │ │ ├── install.rst │ │ ├── language-syntax.rst │ │ └── macros.rst │ ├── doc.cabal │ ├── include/ │ │ ├── building-package/ │ │ │ ├── my-first-package/ │ │ │ │ ├── Setup.hs │ │ │ │ ├── my-first-package.cabal │ │ │ │ ├── package.yaml │ │ │ │ ├── src/ │ │ │ │ │ └── MyFirstPackage.hs │ │ │ │ ├── stack.git.yaml │ │ │ │ └── stack.template.yaml │ │ │ ├── my-new-package/ │ │ │ │ ├── LICENSE │ │ │ │ ├── README.md │ │ │ │ ├── Setup.hs │ │ │ │ ├── app/ │ │ │ │ │ └── Main.hs │ │ │ │ ├── my-new-package.cabal │ │ │ │ ├── src/ │ │ │ │ │ └── Lib.hs │ │ │ │ ├── stack.yaml │ │ │ │ └── test/ │ │ │ │ └── Spec.hs │ │ │ └── my-second-package/ │ │ │ ├── LICENSE │ │ │ ├── README.md │ │ │ ├── Setup.hs │ │ │ ├── app/ │ │ │ │ └── Main.hs │ │ │ ├── my-second-package.cabal │ │ │ ├── src/ │ │ │ │ ├── FnkCodes.hs │ │ │ │ ├── HsCodes.hs │ │ │ │ └── Lib.hs │ │ │ └── test/ │ │ │ ├── FactorialTest.hs │ │ │ └── Spec.hs │ │ ├── finkel-executable/ │ │ │ ├── finkel-help-make.console │ │ │ ├── hello-prof.console │ │ │ ├── hello.console │ │ │ ├── hello.hs │ │ │ └── hello904.console │ │ ├── language-syntax/ │ │ │ ├── decl/ │ │ │ │ ├── bind-pat.fnk │ │ │ │ ├── bind-pat.hs │ │ │ │ ├── bind-simpl.fnk │ │ │ │ ├── bind-simpl.hs │ │ │ │ ├── bind-where.fnk │ │ │ │ ├── bind-where.hs │ │ │ │ ├── class.fnk │ │ │ │ ├── class.hs │ │ │ │ ├── data-d1.fnk │ │ │ │ ├── data-d1.hs │ │ │ │ ├── data-d2.fnk │ │ │ │ ├── data-d2.hs │ │ │ │ ├── default.fnk │ │ │ │ ├── default.hs │ │ │ │ ├── fixity.fnk │ │ │ │ ├── fixity.hs │ │ │ │ ├── instance.fnk │ │ │ │ ├── instance.hs │ │ │ │ ├── newtype.fnk │ │ │ │ ├── newtype.hs │ │ │ │ ├── tysig-constraints.fnk │ │ │ │ ├── tysig-constraints.hs │ │ │ │ ├── tysig-many.fnk │ │ │ │ ├── tysig-many.hs │ │ │ │ ├── tysig-one.fnk │ │ │ │ ├── tysig-one.hs │ │ │ │ ├── tysym.fnk │ │ │ │ └── tysym.hs │ │ │ ├── expr/ │ │ │ │ ├── block-comment.fnk │ │ │ │ ├── block-comment.hs │ │ │ │ ├── case.fnk │ │ │ │ ├── case.hs │ │ │ │ ├── char-a.fnk │ │ │ │ ├── char-a.hs │ │ │ │ ├── char-escape.fnk │ │ │ │ ├── char-escape.hs │ │ │ │ ├── char-ncode.fnk │ │ │ │ ├── char-ncode.hs │ │ │ │ ├── char-special.fnk │ │ │ │ ├── char-special.hs │ │ │ │ ├── discard-prefix.fnk │ │ │ │ ├── discard-prefix.hs │ │ │ │ ├── do.fnk │ │ │ │ ├── do.hs │ │ │ │ ├── fieldlabels.fnk │ │ │ │ ├── fieldlabels.hs │ │ │ │ ├── funapp-pars.fnk │ │ │ │ ├── funapp-pars.hs │ │ │ │ ├── funapp.fnk │ │ │ │ ├── funapp.hs │ │ │ │ ├── guard.fnk │ │ │ │ ├── guard.hs │ │ │ │ ├── if.fnk │ │ │ │ ├── if.hs │ │ │ │ ├── lambda.fnk │ │ │ │ ├── lambda.hs │ │ │ │ ├── let.fnk │ │ │ │ ├── let.hs │ │ │ │ ├── line-comment.fnk │ │ │ │ ├── line-comment.hs │ │ │ │ ├── list-comp.fnk │ │ │ │ ├── list-comp.hs │ │ │ │ ├── list-const.fnk │ │ │ │ ├── list-const.hs │ │ │ │ ├── list-range.fnk │ │ │ │ ├── list-range.hs │ │ │ │ ├── map-mul2.fnk │ │ │ │ ├── map-mul2.hs │ │ │ │ ├── map-unary.fnk │ │ │ │ ├── map-unary.hs │ │ │ │ ├── muladd.fnk │ │ │ │ ├── muladd.hs │ │ │ │ ├── numeric.fnk │ │ │ │ ├── numeric.hs │ │ │ │ ├── opexp-add.fnk │ │ │ │ ├── opexp-add.hs │ │ │ │ ├── opexp-app.fnk │ │ │ │ ├── opexp-app.hs │ │ │ │ ├── pat-as.fnk │ │ │ │ ├── pat-as.hs │ │ │ │ ├── pat-irf.fnk │ │ │ │ ├── pat-irf.hs │ │ │ │ ├── pat-maybe.fnk │ │ │ │ ├── pat-maybe.hs │ │ │ │ ├── pat-opexp.fnk │ │ │ │ ├── pat-opexp.hs │ │ │ │ ├── sige.fnk │ │ │ │ ├── sige.hs │ │ │ │ ├── string.fnk │ │ │ │ ├── string.hs │ │ │ │ ├── tup2.fnk │ │ │ │ ├── tup2.hs │ │ │ │ ├── tup5.fnk │ │ │ │ ├── tup5.hs │ │ │ │ ├── tupfn.fnk │ │ │ │ ├── tupfn.hs │ │ │ │ ├── unit.fnk │ │ │ │ ├── unit.hs │ │ │ │ ├── varid.fnk │ │ │ │ └── varid.hs │ │ │ ├── ffi/ │ │ │ │ ├── export.fnk │ │ │ │ ├── export.hs │ │ │ │ ├── import.fnk │ │ │ │ └── import.hs │ │ │ ├── import/ │ │ │ │ ├── altogether.fnk │ │ │ │ ├── altogether.hs │ │ │ │ ├── entity-list.fnk │ │ │ │ ├── entity-list.hs │ │ │ │ ├── hiding.fnk │ │ │ │ ├── hiding.hs │ │ │ │ ├── qualified-as.fnk │ │ │ │ ├── qualified-as.hs │ │ │ │ ├── simpl.fnk │ │ │ │ └── simpl.hs │ │ │ └── module/ │ │ │ ├── export-list.fnk │ │ │ ├── export-list.hs │ │ │ ├── simpl.fnk │ │ │ └── simpl.hs │ │ └── macros/ │ │ ├── RequireMe.fnk │ │ ├── arglist.console │ │ ├── arglist.fnk │ │ ├── begin.console │ │ ├── begin.fnk │ │ ├── eval-when-compile.console │ │ ├── eval-when-compile.fnk │ │ ├── eval-when.console │ │ ├── eval-when.fnk │ │ ├── fib-macro.console │ │ ├── fib-macro.fnk │ │ ├── macrolet.console │ │ ├── macrolet.fnk │ │ ├── quasiquote.console │ │ ├── quasiquote.fnk │ │ ├── quasiquote904.console │ │ ├── quote.console │ │ ├── quote.fnk │ │ ├── raw-require.console │ │ ├── raw-require.fnk │ │ ├── require.console │ │ ├── require.fnk │ │ ├── unquote-splice.console │ │ ├── unquote-splice.fnk │ │ ├── unquote.console │ │ └── unquote.fnk │ ├── index.rst │ ├── make.bat │ ├── requirements.txt │ └── test/ │ ├── Doc/ │ │ ├── BuildingPackage.hs │ │ ├── FinkelExecutable.hs │ │ ├── LanguageSyntax.hs │ │ ├── Macros.hs │ │ └── TestAux.hs │ ├── Doc.hs │ └── Spec.hs ├── finkel/ │ ├── CHANGELOG.md │ ├── LICENSE │ ├── Main.hs │ ├── README.md │ ├── Setup.hs │ └── finkel.cabal ├── finkel-core/ │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── finkel-core.cabal │ ├── src/ │ │ └── Finkel/ │ │ ├── Core/ │ │ │ ├── Functions.hs │ │ │ ├── Internal/ │ │ │ │ ├── Ghc/ │ │ │ │ │ ├── Compat.hs │ │ │ │ │ └── Version.hs │ │ │ │ ├── Ghc.hs │ │ │ │ ├── Stage0.hs │ │ │ │ ├── Stage1.hs │ │ │ │ └── Stage2.hs │ │ │ ├── Internal.hs │ │ │ └── Plugin.hs │ │ ├── Core.hs │ │ └── Prelude.hs │ └── test/ │ ├── CoreTest.hs │ ├── FunctionTest.hs │ ├── Orphan.hs │ ├── PluginTest.hs │ ├── Spec.hs │ ├── TestAux.hs │ └── data/ │ └── plugin/ │ ├── ImportMe.hs │ └── c01.hs ├── finkel-kernel/ │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── exec/ │ │ ├── fnkc.hs │ │ └── profile.hs │ ├── finkel-kernel.cabal │ ├── include/ │ │ ├── ghc_modules.h │ │ └── hooks.c │ ├── src/ │ │ └── Language/ │ │ ├── Finkel/ │ │ │ ├── Builder.hs │ │ │ ├── Data/ │ │ │ │ ├── FastString.hs │ │ │ │ ├── Fractional.hs │ │ │ │ └── SourceText.hs │ │ │ ├── Emit.hs │ │ │ ├── Error.hs │ │ │ ├── Eval.hs │ │ │ ├── Exception.hs │ │ │ ├── Expand.hs │ │ │ ├── Fnk.hs │ │ │ ├── Form.hs │ │ │ ├── Homoiconic.hs │ │ │ ├── Hooks.hs │ │ │ ├── Lexer.x │ │ │ ├── Main.hs │ │ │ ├── Make/ │ │ │ │ ├── Cache.hs │ │ │ │ ├── Recompile.hs │ │ │ │ ├── Session.hs │ │ │ │ ├── Summary.hs │ │ │ │ ├── TargetSource.hs │ │ │ │ └── Trace.hs │ │ │ ├── Make.hs │ │ │ ├── Options.hs │ │ │ ├── ParsedResult.hs │ │ │ ├── Plugin.hs │ │ │ ├── Preprocess.hs │ │ │ ├── Reader.y │ │ │ ├── SpecialForms.hs │ │ │ ├── Syntax/ │ │ │ │ ├── Extension.hs │ │ │ │ ├── HBind.hs │ │ │ │ ├── HDecl.hs │ │ │ │ ├── HExpr.hs │ │ │ │ ├── HImpExp.hs │ │ │ │ ├── HPat.hs │ │ │ │ ├── HType.hs │ │ │ │ ├── Location.hs │ │ │ │ └── Utils.hs │ │ │ └── Syntax.y │ │ └── Finkel.hs │ └── test/ │ ├── EmitTest.hs │ ├── EvalTest.hs │ ├── ExceptionTest.hs │ ├── FnkTest.hs │ ├── FormTest.hs │ ├── Main.hs │ ├── MainTest.hs │ ├── MakeTest.hs │ ├── Orphan.hs │ ├── PluginTest.hs │ ├── PreprocessTest.hs │ ├── SyntaxTest.hs │ ├── TestAux.hs │ └── data/ │ ├── eval/ │ │ ├── 0001-simple.fnk │ │ ├── 0002-shadowing-macro.fnk │ │ ├── 0003-expand1.fnk │ │ └── 0004-unquote-unquote-splice.fnk │ ├── exception/ │ │ ├── 0001-invalid-unquote-splice.hs │ │ ├── 0002-invalid-string-literal.hs │ │ └── 0003-malformed-qq.hs │ ├── main/ │ │ ├── MyMain.hs │ │ ├── m001.hs │ │ ├── m002.hs │ │ └── m003.c │ ├── make/ │ │ ├── E01.hs │ │ ├── E02.hs │ │ ├── M1.hs │ │ ├── M2.hs │ │ ├── M3.hs │ │ ├── M4/ │ │ │ ├── A.hs │ │ │ └── B.hs │ │ ├── M4.hs │ │ ├── M5.hs │ │ ├── M6/ │ │ │ ├── A.hs │ │ │ └── B.hs │ │ ├── P1.hs │ │ ├── P2.hs │ │ ├── P3.hs │ │ ├── R01.hs.1 │ │ ├── R01.hs.2 │ │ ├── R02.hs │ │ ├── R03.hs │ │ ├── R04.hs │ │ ├── R05.hs │ │ ├── R05a.hs │ │ ├── R06.hs │ │ ├── R06a.hs │ │ ├── R07.hs │ │ ├── R07a.hs │ │ ├── R07b.hs │ │ ├── R08.hs │ │ ├── R08a.hs │ │ ├── R08b.hs │ │ ├── R09.hs │ │ ├── R09a.hs │ │ ├── R09b.hs │ │ ├── R10.hs │ │ ├── R10a.hs │ │ ├── R10b.hs │ │ ├── R11.hs │ │ ├── R11a.hs │ │ ├── R11b.hs │ │ ├── cbits1.c │ │ ├── cbits2.c │ │ ├── cbits3.c │ │ ├── main1.hs │ │ ├── main2.hs │ │ ├── main3.hs │ │ ├── main4.hs │ │ ├── main5.hs │ │ ├── main6.hs │ │ ├── main7.hs │ │ ├── main8.hs │ │ └── main9.hs │ ├── plugin/ │ │ ├── M01.hs │ │ ├── M02.hs │ │ ├── M03.hs │ │ ├── M04.hs │ │ ├── M04b.hs │ │ ├── p01.hs │ │ ├── p02.hs │ │ ├── p03.hs │ │ ├── p04.hs │ │ ├── p05.hs │ │ ├── p06.hs │ │ ├── p07.hs │ │ ├── p08.hs │ │ ├── p09.hs │ │ ├── p10.hs │ │ └── p11.hs │ ├── preprocess/ │ │ ├── fnk01.hs │ │ ├── fnk02.hs │ │ ├── fnk03.hs │ │ ├── fnk04.hs │ │ ├── fnk05.hs │ │ ├── fnk06.hs │ │ ├── fnk11.hs │ │ ├── fnk12.hs │ │ ├── fnk13.hs │ │ ├── fnk14.hs │ │ ├── fnk15.hs │ │ ├── hs01.hs │ │ └── hs02.hs │ └── syntax/ │ ├── 0001-hello.hs │ ├── 0002-lexical.hs │ ├── 0003-expressions-1.hs │ ├── 0003-expressions-2.hs │ ├── 0003-expressions-3.hs │ ├── 0004-decls.hs │ ├── 0005-modules-01.hs │ ├── 0005-modules-02.hs │ ├── 0005-modules-03.hs │ ├── 0005-modules-04.hs │ ├── 0005-modules-05.hs │ ├── 0008-ffi.hs │ ├── 0012-pragmas.hs │ ├── 1000-comment.hs │ ├── 1001-quote.hs │ ├── 1002-macro.hs │ ├── 1003-eval-when-compile.hs │ ├── 1004-doccomment-01.hs │ ├── 1004-doccomment-02.hs │ ├── 1004-doccomment-03.hs │ ├── 1005-begin.hs │ ├── 2001-unpack.hs │ ├── 2002-bang.hs │ ├── 2003-derive.hs │ ├── 2004-overloaded.hs │ ├── 2005-gadts-01.hs │ ├── 2005-gadts-02.hs │ ├── 2006-existential.hs │ ├── 2007-rankn.hs │ ├── 2008-options.hs │ ├── 2009-flexible.hs │ ├── 2010-kindsig.hs │ ├── 2011-scoped.hs │ ├── 2012-typeop.hs │ ├── 2013-undecidable.hs │ ├── 2014-noprelude.hs │ ├── 2015-typefam.hs │ ├── 2016-datakinds.hs │ ├── 2017-polykinds.hs │ ├── 2018-typeapp.hs │ ├── 2019-overlabel.hs │ ├── 2020-emptyderiv.hs │ ├── 2021-dfltsig.hs │ ├── 2022-drvstrat.hs │ ├── 2023-standalone.hs │ ├── 2024-derivingvia.hs │ ├── 2025-namedfieldpuns.hs │ ├── 2026-recordwildcards.hs │ ├── 2027-emptycase-1.hs │ ├── 2027-emptycase-2.hs │ ├── 2028-standalonekind.hs │ └── 2029-impredicative.hs ├── finkel-setup/ │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── finkel-setup.cabal │ ├── src/ │ │ └── Distribution/ │ │ └── Simple/ │ │ └── Finkel.hs │ └── test/ │ ├── Main.hs │ └── data/ │ ├── p01/ │ │ ├── LICENSE │ │ ├── Setup.hs │ │ ├── exec/ │ │ │ └── p01.hs │ │ ├── p01.cabal │ │ ├── src/ │ │ │ └── P01/ │ │ │ ├── A.fnk │ │ │ ├── B.fnk │ │ │ ├── C.fnk │ │ │ ├── D.hs │ │ │ ├── E.hs │ │ │ ├── F.fnk │ │ │ ├── G1.fnk │ │ │ ├── G2.fnk │ │ │ ├── H.fnk │ │ │ ├── I.fnk │ │ │ └── J.fnk │ │ └── test/ │ │ ├── Spec.hs │ │ └── TestAll.fnk │ └── p02/ │ ├── CHANGELOG.md │ ├── LICENSE │ ├── Setup.hs │ ├── app/ │ │ └── Main.hs │ ├── p02.cabal │ ├── src/ │ │ └── MyLib.hs │ └── test/ │ └── Main.hs ├── finkel-tool/ │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── finkel-tool.cabal │ ├── finkel.hsfiles │ ├── src/ │ │ └── Finkel/ │ │ └── Tool/ │ │ ├── Command/ │ │ │ ├── Eval.hs │ │ │ ├── Help.hs │ │ │ ├── Make.hs │ │ │ ├── Repl.hs │ │ │ ├── Run.hs │ │ │ ├── Sdist.hs │ │ │ └── Version.hs │ │ ├── Command.hs │ │ ├── Internal/ │ │ │ ├── CLI.hs │ │ │ ├── Commit.hs │ │ │ ├── Compat.hs │ │ │ ├── Eval.hs │ │ │ ├── Exception.hs │ │ │ ├── IO.hs │ │ │ ├── Listen.hs │ │ │ ├── Loop.hs │ │ │ ├── Macro/ │ │ │ │ ├── Ghc.hs │ │ │ │ └── Repl.hs │ │ │ └── Types.hs │ │ └── Main.hs │ └── test/ │ ├── CLITest.hs │ ├── GhcTest.hs │ ├── MainTest.hs │ ├── ReplMacroTest.hs │ ├── ReplTest.hs │ ├── Spec.hs │ ├── TestAux.hs │ └── data/ │ ├── Err001.fnk │ ├── LoadMe.hs │ ├── RunMeToo.hs │ ├── input01.txt │ ├── m01.hs │ ├── p02/ │ │ ├── LICENSE │ │ ├── README.md │ │ ├── Setup.hs │ │ ├── app/ │ │ │ └── Main.hs │ │ ├── p02.cabal │ │ ├── src/ │ │ │ └── Lib.fnk │ │ ├── stack.yaml │ │ └── test/ │ │ └── Spec.hs │ ├── print-int.hs │ ├── print-load-me.hs │ ├── run-me.hs │ └── sleep-for-while.fnk ├── fkc/ │ ├── LICENSE │ ├── Main.hs │ ├── README.md │ ├── Setup.hs │ └── fkc.cabal ├── fnkpp/ │ ├── LICENSE │ ├── Main.hs │ ├── README.md │ └── fnkpp.cabal ├── nix/ │ ├── docker.nix │ └── finkel-packages.nix ├── scripts/ │ └── travis.sh ├── shell.nix └── stack.yaml ================================================ FILE CONTENTS ================================================ ================================================ FILE: .appveyor.yml ================================================ branches: only: - /appveyor-*/ environment: global: CABOPTS: "--store-dir=C:\\SR --http-transport=plain-http" GHCVER: 8.10.2 CABALVER: 3.2.0.0 clone_folder: "C:\\WORK" clone_depth: 5 cache: - C:\SR install: - choco install -y cabal --version %CABALVER% - choco install -y ghc --version %GHCVER% - refreshenv before_build: - cabal --version - ghc --version - cabal %CABOPTS% v2-update build_script: - cabal %CABOPTS% v2-configure --disable-optimization --disable-library-profiling - cabal %CABOPTS% v2-build all -j --only-dependencies - cabal %CABOPTS% v2-build all - cabal %CABOPTS% v2-test all ================================================ FILE: .circleci/config.yml ================================================ # Use the latest 2.1 version of CircleCI pipeline process engine. See: # https://circleci.com/docs/2.0/configuration-reference version: 2.1 jobs: build-linux: docker: - image: fpco/stack-build:lts-15.4 steps: - checkout - restore_cache: name: Restore Cached Dependencies keys: - stack-{{ checksum "stack.yaml" }} - kernel-{{ checksum "finkel-kernel/finkel-kernel.cabal" }} - kernel-{{ checksum "fkc/fkc.cabal" }} - setup-{{ checksum "finkel-setup/finkel-setup.cabal" }} - lang-{{ checksum "finkel-core/finkel-core.cabal" }} - tool-{{ checksum "finkel-tool/finkel-tool.cabal" }} - finkel-{{ checksum "finkel/finkel.cabal" }} - run: name: Resolve/Update Dependencies command: stack --no-terminal setup - run: name: Build Packages command: stack --no-terminal build --test --no-run-tests - run: name: Run tests command: RESOLVER=lts-15.4 stack --no-terminal build --test - save_cache: name: Cache dependencies key: stack-{{ checksum "stack.yaml" }} paths: - ~/.stack - ~/.stack-work workflows: build: jobs: - build-linux: filters: branches: only: - /circleci-.*/ ================================================ FILE: .codecov.yml ================================================ coverage: status: project: default: threshold: 5% ================================================ FILE: .dir-locals.el ================================================ ;;; Directory Local Variables ;;; For more information see (info "(emacs) Directory Variables") ((nil (fill-column . 80) (indent-tabs-mode . nil)) (finkel-mode (eval finkel-put-indent-method 'define-macro 'finkel-indent-multiargs) (eval finkel-put-doc-string-elt 'define-macro 2) (eval finkel-put-indent-method 'define-macro\' 'finkel-indent-multiargs) (eval finkel-put-doc-string-elt 'define-macro\' 2) (eval finkel-put-indent-method 'describe 1) (eval finkel-put-indent-method 'it 1))) ================================================ FILE: .gitattributes ================================================ * text=auto ================================================ FILE: .github/ISSUE_TEMPLATE/bug_report.md ================================================ --- name: Bug Report about: Report a bug in Finkel --- Please follow the steps below for reporting a bug: Make sure that you are using the latest source (currently git HEAD in the master branch). Please use the following schema for your bug report: ### General summary/comments (optional) ### Steps to reproduce For example: 1. Remove directory *foo*. 2. Run command `finkel bar`. 3. Edit file buzz. 4. Run command `finkel quux`. ### Expected What you expected to see and happen. ### Actual What actually happened. If you suspect that a finkel command misbehaved, please include the output of that command in `debug` mode. If the output is larger than a page please paste the output in a [Gist](https://gist.github.com/). ``` $ FNK_DEBUG=1 finkel ``` ### Finkel version and environment information Finkel version could be obtained with below command. ``` $ finkel version ``` * OS name and version * ... etc ### Method of installation * Via cabal-install * Via stack * Other (please specify) ================================================ FILE: .github/dependabot.yml ================================================ version: 2 updates: - package-ecosystem: "github-actions" directory: "/" schedule: interval: "weekly" ================================================ FILE: .github/workflows/cabal-install.yml ================================================ name: cabal-install on: workflow_call: inputs: cache-version: description: cache key version required: true type: string defaults: run: shell: bash jobs: cabal-install: name: ghc ${{ matrix.plan.ghc }} with ${{ matrix.plan.flags }} strategy: matrix: os: - ubuntu-latest # - macos-latest # - windows-latest plan: - ghc: "9.0.2" cabal: "3.10.3.0" flags: "-O0" - ghc: "9.2.8" cabal: "latest" flags: "-O0" # Running tests in ghc 9.4.8 was approximately 2x slower than 9.4.7 - ghc: "9.4.7" cabal: "latest" flags: "-O0" - ghc: "9.6.5" cabal: "latest" flags: "-O0" - ghc: "9.8.2" cabal: "latest" flags: "-O0" - ghc: "9.10.1" cabal: "latest" flags: "-O0" - ghc: "9.10.1" cabal: "latest" flags: "-O2" runs-on: - ${{ matrix.os }} steps: - name: Checkout project repository uses: actions/checkout@v4 - name: Cache cabal package database uses: actions/cache@v4 with: path: ~/.cabal key: home-dot-cabal-${{ matrix.plan.ghc }}-${{ inputs.cache-version }} - name: Setup ghc and cabal-install uses: haskell-actions/setup@v2 with: ghc-version: ${{ matrix.plan.ghc }} cabal-version: ${{ matrix.plan.cabal }} - name: Show version and paths run: | ghc --version cabal --version # # XXX: In Windows, use of profiling libraries are not yet supported. # - name: Write cabal.project.local with v2-configure (windows) # if: matrix.os == 'windows-latest' # run: cabal v2-configure --disable-library-profiling ${{ matrix.plan.flags }} - name: Write cabal.project.local with v2-configure run: cabal v2-configure ${{ matrix.plan.flags }} --test-show-details=streaming - name: Build dependency packages run: cabal v2-build all -j --only-dependencies - name: Build packages run: cabal v2-build all - name: Run tests run: cabal v2-test all - name: Run haddock run: cabal v2-haddock all ================================================ FILE: .github/workflows/ci.yml ================================================ name: ci on: pull_request: push: paths-ignore: - '**.md' defaults: run: shell: bash jobs: pre-job: uses: ./.github/workflows/pre-job.yml stack: needs: pre-job if: ${{ needs.pre-job.outputs.run == 'true' }} uses: ./.github/workflows/stack.yml secrets: inherit with: cache-version: v16 cabal-install: needs: pre-job if: ${{ needs.pre-job.outputs.run == 'true' }} uses: ./.github/workflows/cabal-install.yml with: cache-version: v18 nix-build: needs: pre-job if: ${{ needs.pre-job.outputs.run == 'true' }} uses: ./.github/workflows/nix-build.yml secrets: inherit make-sdist-with-stack: needs: pre-job if: ${{ needs.pre-job.outputs.run == 'true' }} uses: ./.github/workflows/sdist.yml ================================================ FILE: .github/workflows/nix-build.yml ================================================ name: nix-build on: workflow_call: jobs: nix-build: name: Build with nix strategy: matrix: include: # - nixpkgs: "channel:nixos-20.03" # compiler: "ghc865" # - nixpkgs: "channel:nixos-20.09" # compiler: "ghc884" - nixpkgs: "channel:nixos-22.05" compiler: "ghc8107" # - nixpkgs: "channel:nixos-23.05" # compiler: "ghc92" # - nixpkgs: "channel:nixos-unstable" # compiler: "ghc8107" # - nixpkgs: "channel:nixos-unstable" # compiler: "ghc901" runs-on: - ubuntu-latest steps: - name: Checkout git repository uses: actions/checkout@v4 - name: Install nix uses: cachix/install-nix-action@v29 with: nix_path: nixpkgs=${{ matrix.nixpkgs }} - name: Build with nix-build run: nix-build --argstr compiler ${{ matrix.compiler }} - name: Build container image stream # if: matrix.compiler == 'ghc8107' && github.ref == 'refs/heads/master' if: github.ref == 'refs/heads/master' run: | nix-build --argstr compiler ${{ matrix.compiler }} ./nix/docker.nix echo "image_stream=$(readlink result)" >> $GITHUB_ENV - name: Push image to ghcr.io # if: matrix.compiler == 'ghc8107' && github.ref == 'refs/heads/master' if: github.ref == 'refs/heads/master' env: # Below `CRED' was used for credentials for ghcr.io, but not any more # since logging in with GITHUB_TOKEN is working. May be the # `GHCR_USER' and `GHCR_PAT' variables could be removed from the # secrets. # # CRED: ${{ secrets.GHCR_USER }}:${{ secrets.GHCR_PAT }} FROM: docker-archive:/dev/stdin TO: docker://ghcr.io/${{ github.repository }}:latest run: | echo ${{ secrets.GITHUB_TOKEN }} | skopeo login -u $ --password-stdin ghcr.io ${{ env.image_stream }} | gzip | skopeo --debug copy ${FROM} ${TO} ================================================ FILE: .github/workflows/pre-job.yml ================================================ name: pre-job on: workflow_call: outputs: run: description: \"true\" if running other jobs value: ${{ jobs.pre-job.outputs.run }} jobs: pre-job: name: Decide whether to run other jobs runs-on: ubuntu-latest outputs: run: >- ${{ steps.skip-check.outputs.should_skip != 'true' || github.ref_name == github.event.repository.default_branch }} steps: - id: skip-check uses: fkirc/skip-duplicate-actions@v5 with: concurrent_skipping: same_content_newer ================================================ FILE: .github/workflows/sdist.yml ================================================ name: sdist on: workflow_call: jobs: make-sdist-with-stack: name: Build *.tar.gz made via sdist runs-on: ubuntu-latest env: STACK: stack --resolver=lts-20 steps: - name: Checkout git repository uses: actions/checkout@v4 - name: Show versions run: | stack --version ghc --version cabal --version - name: Build finkel-setup # The "finkel-setup" is used by other packages in custom-setup stanza of # cabal configuration, building before running sdist command. run: $STACK build --fast finkel-setup - name: Run stack sdist run: | $STACK sdist \ finkel-kernel \ fkc \ fnkpp \ finkel-setup \ finkel-core \ finkel-tool \ finkel \ --tar-dir sdist - name: Emit temporary stack.yaml run: | cd sdist echo 'resolver: lts-0.0' > stack.yaml echo 'packages:' >> stack.yaml ls *.tar.gz | sed -e 's/\(.*\)\.tar.gz/ - \1/' >> stack.yaml cat stack.yaml - name: Build from tarballs with stack run: | cd sdist for t in `ls *.tar.gz`; do tar zxvf $t; done $STACK build --fast - name: Emit temporary cabal.project run: | cd sdist echo 'packages:' >> cabal.project ls *.tar.gz | sed -e 's/\(.*\)\.tar.gz/ \1/' >> cabal.project cat cabal.project - name: Install and set ghc 9.2.8 via ghcup run: | ghcup install ghc 9.2.8 ghcup set ghc 9.2.8 - name: Build from tarballs with cabal-install run: | cd sdist cabal v2-update cabal v2-build all - name: Upload package tarballs uses: actions/upload-artifact@v4 with: name: finkel-srcs path: | sdist/*.tar.gz sdist/stack.yaml sdist/cabal.project ================================================ FILE: .github/workflows/stack.yml ================================================ name: stack on: workflow_call: inputs: cache-version: description: cache key version required: true type: string defaults: run: shell: bash jobs: stack: name: ${{ matrix.resolver }} under ${{ matrix.os }} strategy: matrix: include: # - os: ubuntu-latest # resolver: lts-11 # - os: ubuntu-latest # resolver: lts-12 # - os: ubuntu-latest # resolver: lts-14 # - os: ubuntu-latest # resolver: lts-16 # - os: ubuntu-latest # resolver: lts-18 - os: ubuntu-latest resolver: lts-22 - os: macos-latest resolver: lts-22 - os: windows-latest resolver: lts-22 env: STACK: stack --resolver=${{ matrix.resolver }} runs-on: - ${{ matrix.os }} steps: - name: Checkout git repository uses: actions/checkout@v4 - name: Cache stack related directories uses: 8c6794b6/playing-with-github/.github/actions/setup-stack-cache@main with: cache-key: ${{ matrix.os }}-${{ matrix.resolver }}-${{ inputs.cache-version }} - name: Setup haskell uses: haskell-actions/setup@v2.7.3 with: enable-stack: true stack-no-global: true - name: Setup stack run: $STACK setup - name: Show versions run: | $STACK --version $STACK exec -- ghc --version - name: Install dependency packages run: $STACK build -j 2 --test --only-dependencies - name: Build packages run: $STACK build --fast --test --coverage --no-run-tests - name: Run tests run: | RESOLVER=${{ matrix.resolver }} $STACK --jobs 1 build \ --fast --test --coverage - name: Generate coverage report uses: 8c6794b6/hpc-codecov-action@v4 with: target: stack:all - name: Send coverage report uses: codecov/codecov-action@v4 with: name: stack-${{ matrix.os }}-${{ matrix.resolver }} token: ${{ secrets.CODECOV_TOKEN }} ================================================ FILE: .gitignore ================================================ *~ *.hi *.hie *.hscpp *.o *.dyn_o *.dyn_hi *.p_o *.p_hi *.info *.prof *.html *.hp *.tix *.yaml.lock .ghc.environment.* result* TAGS a.out cabal.project.local finkel-kernel/include/finkel_kernel_config.h finkel-kernel/test/data/main/m00? finkel-kernel/test/data/make/main? finkel-kernel/test/data/make/gen finkel-kernel/test/data/plugin/p?? finkel-kernel/test/data/syntax/*.h .stack-work/ dist/ dist-newstyle/ doc/_build doc/_static doc/_templates doc/include/finkel-executable/hello doc/include/macros/quasiquote doc/include/macros/require ================================================ FILE: .hlint.yaml ================================================ # HLint configuration file # https://github.com/ndmitchell/hlint ########################## # This file contains a template configuration file, which is typically # placed as .hlint.yaml in the root of your project # Specify additional command line arguments # # - arguments: [--color, --cpp-simple, -XQuasiQuotes] # Control which extensions/flags/modules/functions can be used # # - extensions: # - default: false # all extension are banned by default # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module # # - flags: # - {name: -w, within: []} # -w is allowed nowhere # # - modules: # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' # - {name: Control.Arrow, within: []} # Certain modules are banned entirely # # - functions: # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules # Add custom hints for this project # # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} # Turn on hints that are off by default # # Ban "module X(module X) where", to require a real export list # - warn: {name: Use explicit module export list} # # Replace a $ b $ c with a . b $ c # - group: {name: dollar, enabled: true} # # Generalise map to fmap, ++ to <> # - group: {name: generalise, enabled: true} # Ignore some builtin hints # - ignore: {name: Use let} # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules - ignore: {name: Use fewer imports} - ignore: { name: Use camelCase, within: [ Language.Finkel.Emit, Language.Finkel.Syntax.HBind, Language.Finkel.Syntax.HDecl, Language.Finkel.Syntax.HExpr, Language.Finkel.Syntax.HImpExp, Language.Finkel.Syntax.HPat, Language.Finkel.Syntax.HType, Language.Finkel.SpecialForms ] } # Define some custom infix operators # - fixity: infixr 3 ~^#^~ # To generate a suitable file for HLint do: # $ hlint --default > .hlint.yaml ================================================ FILE: .readthedocs.yaml ================================================ version: 2 sphinx: configuration: doc/conf.py python: version: 3.8 install: - requirements: doc/requirements.txt ================================================ FILE: .stylish-haskell.yaml ================================================ # stylish-haskell configuration file # ================================== # The stylish-haskell tool is mainly configured by specifying steps. These steps # are a list, so they have an order, and one specific step may appear more than # once (if needed). Each file is processed by these steps in the given order. steps: # Convert some ASCII sequences to their Unicode equivalents. This is disabled # by default. # - unicode_syntax: # # In order to make this work, we also need to insert the UnicodeSyntax # # language pragma. If this flag is set to true, we insert it when it's # # not already present. You may want to disable it if you configure # # language extensions using some other method than pragmas. Default: # # true. # add_language_pragma: true # Align the right hand side of some elements. This is quite conservative # and only applies to statements where each element occupies a single # line. All default to true. - simple_align: cases: true top_level_patterns: true records: true # Import cleanup - imports: # There are different ways we can align names and lists. # # - global: Align the import names and import list throughout the entire # file. # # - file: Like global, but don't add padding when there are no qualified # imports in the file. # # - group: Only align the imports per group (a group is formed by adjacent # import lines). # # - none: Do not perform any alignment. # # Default: global. align: file # The following options affect only import list alignment. # # List align has following options: # # - after_alias: Import list is aligned with end of import including # 'as' and 'hiding' keywords. # # > import qualified Data.List as List (concat, foldl, foldr, head, # > init, last, length) # # - with_alias: Import list is aligned with start of alias or hiding. # # > import qualified Data.List as List (concat, foldl, foldr, head, # > init, last, length) # # - with_module_name: Import list is aligned `list_padding` spaces after # the module name. # # > import qualified Data.List as List (concat, foldl, foldr, head, # init, last, length) # # This is mainly intended for use with `pad_module_names: false`. # # > import qualified Data.List as List (concat, foldl, foldr, head, # init, last, length, scanl, scanr, take, drop, # sort, nub) # # - new_line: Import list starts always on new line. # # > import qualified Data.List as List # > (concat, foldl, foldr, head, init, last, length) # # Default: after_alias list_align: after_alias # Right-pad the module names to align imports in a group: # # - true: a little more readable # # > import qualified Data.List as List (concat, foldl, foldr, # > init, last, length) # > import qualified Data.List.Extra as List (concat, foldl, foldr, # > init, last, length) # # - false: diff-safe # # > import qualified Data.List as List (concat, foldl, foldr, init, # > last, length) # > import qualified Data.List.Extra as List (concat, foldl, foldr, # > init, last, length) # # Default: true pad_module_names: true # Long list align style takes effect when import is too long. This is # determined by 'columns' setting. # # - inline: This option will put as much specs on same line as possible. # # - new_line: Import list will start on new line. # # - new_line_multiline: Import list will start on new line when it's # short enough to fit to single line. Otherwise it'll be multiline. # # - multiline: One line per import list entry. # Type with constructor list acts like single import. # # > import qualified Data.Map as M # > ( empty # > , singleton # > , ... # > , delete # > ) # # Default: inline long_list_align: inline # Align empty list (importing instances) # # Empty list align has following options # # - inherit: inherit list_align setting # # - right_after: () is right after the module name: # # > import Vector.Instances () # # Default: inherit empty_list_align: inherit # List padding determines indentation of import list on lines after import. # This option affects 'long_list_align'. # # - : constant value # # - module_name: align under start of module name. # Useful for 'file' and 'group' align settings. # # Default: 4 list_padding: 4 # Separate lists option affects formatting of import list for type # or class. The only difference is single space between type and list # of constructors, selectors and class functions. # # - true: There is single space between Foldable type and list of it's # functions. # # > import Data.Foldable (Foldable (fold, foldl, foldMap)) # # - false: There is no space between Foldable type and list of it's # functions. # # > import Data.Foldable (Foldable(fold, foldl, foldMap)) # # Default: true separate_lists: true # Space surround option affects formatting of import lists on a single # line. The only difference is single space after the initial # parenthesis and a single space before the terminal parenthesis. # # - true: There is single space associated with the enclosing # parenthesis. # # > import Data.Foo ( foo ) # # - false: There is no space associated with the enclosing parenthesis # # > import Data.Foo (foo) # # Default: false space_surround: false # Language pragmas - language_pragmas: # We can generate different styles of language pragma lists. # # - vertical: Vertical-spaced language pragmas, one per line. # # - compact: A more compact style. # # - compact_line: Similar to compact, but wrap each line with # `{-#LANGUAGE #-}'. # # Default: vertical. style: vertical # Align affects alignment of closing pragma brackets. # # - true: Brackets are aligned in same column. # # - false: Brackets are not aligned together. There is only one space # between actual import and closing bracket. # # Default: true align: true # stylish-haskell can detect redundancy of some language pragmas. If this # is set to true, it will remove those redundant pragmas. Default: true. remove_redundant: true # Replace tabs by spaces. This is disabled by default. # - tabs: # # Number of spaces to use for each tab. Default: 8, as specified by the # # Haskell report. # spaces: 8 # Remove trailing whitespace - trailing_whitespace: {} # Squash multiple spaces between the left and right hand sides of some # elements into single spaces. Basically, this undoes the effect of # simple_align but is a bit less conservative. # - squash: {} # A common setting is the number of columns (parts of) code will be wrapped # to. Different steps take this into account. Default: 80. columns: 80 # By default, line endings are converted according to the OS. You can override # preferred format here. # # - native: Native newline format. CRLF on Windows, LF on other OSes. # # - lf: Convert to LF ("\n"). # # - crlf: Convert to CRLF ("\r\n"). # # Default: native. newline: native # Sometimes, language extensions are specified in a cabal file or from the # command line instead of using language pragmas in the file. stylish-haskell # needs to be aware of these, so it can parse the file correctly. # # No language extensions are enabled by default. language_extensions: - TemplateHaskell # - QuasiQuotes # Attempt to find the cabal file in ancestors of the current directory, and # parse options (currently only language extensions) from that. # # Default: true cabal: true ================================================ FILE: .travis.yml ================================================ language: c branches: only: - /^travis-.*/ git: depth: 3 cache: directories: - $HOME/.stack - $HOME/.cabal/packages - $HOME/.cabal/store - $HOME/.ghcup - $HOME/AppData/Local/Programs/stack - $HOME/AppData/Roaming/stack addons: apt: packages: - libgmp-dev homebrew: # Workaround for "Unknown command: bundle", see: https://bit.ly/32d3V2d update: true jobs: include: - os: linux env: EXEC=stack RESOLVER=lts-11 - os: linux env: EXEC=stack RESOLVER=lts-12 - os: linux env: EXEC=stack RESOLVER=lts-14 - os: linux env: EXEC=stack RESOLVER=lts-16 - os: linux env: EXEC=cabal GHC=8.10.2 FLAGS="-O0" - os: linux env: EXEC=cabal GHC=8.10.2 FLAGS="-O2" - os: osx env: EXEC=stack RESOLVER=lts-16 - os: windows env: EXEC=stack RESOLVER=lts-14 allow_failures: - os: windows env: EXEC=stack RESOLVER=lts-16 before_install: - . scripts/travis.sh install: - travis_install script: - travis_script after_success: - travis_after_success notification: email: false ================================================ FILE: CODE_OF_CONDUCT.md ================================================ # Contributor Covenant Code of Conduct ## Our Pledge We as members, contributors, and leaders pledge to make participation in our community a harassment-free experience for everyone, regardless of age, body size, visible or invisible disability, ethnicity, sex characteristics, gender identity and expression, level of experience, education, socio-economic status, nationality, personal appearance, race, religion, or sexual identity and orientation. We pledge to act and interact in ways that contribute to an open, welcoming, diverse, inclusive, and healthy community. ## Our Standards Examples of behavior that contributes to a positive environment for our community include: * Demonstrating empathy and kindness toward other people * Being respectful of differing opinions, viewpoints, and experiences * Giving and gracefully accepting constructive feedback * Accepting responsibility and apologizing to those affected by our mistakes, and learning from the experience * Focusing on what is best not just for us as individuals, but for the overall community Examples of unacceptable behavior include: * The use of sexualized language or imagery, and sexual attention or advances of any kind * Trolling, insulting or derogatory comments, and personal or political attacks * Public or private harassment * Publishing others' private information, such as a physical or email address, without their explicit permission * Other conduct which could reasonably be considered inappropriate in a professional setting ## Enforcement Responsibilities Community leaders are responsible for clarifying and enforcing our standards of acceptable behavior and will take appropriate and fair corrective action in response to any behavior that they deem inappropriate, threatening, offensive, or harmful. Community leaders have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, and will communicate reasons for moderation decisions when appropriate. ## Scope This Code of Conduct applies within all community spaces, and also applies when an individual is officially representing the community in public spaces. Examples of representing our community include using an official e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. ## Enforcement Instances of abusive, harassing, or otherwise unacceptable behavior may be reported to the community leaders responsible for enforcement at [INSERT CONTACT METHOD]. All complaints will be reviewed and investigated promptly and fairly. All community leaders are obligated to respect the privacy and security of the reporter of any incident. ## Enforcement Guidelines Community leaders will follow these Community Impact Guidelines in determining the consequences for any action they deem in violation of this Code of Conduct: ### 1. Correction **Community Impact**: Use of inappropriate language or other behavior deemed unprofessional or unwelcome in the community. **Consequence**: A private, written warning from community leaders, providing clarity around the nature of the violation and an explanation of why the behavior was inappropriate. A public apology may be requested. ### 2. Warning **Community Impact**: A violation through a single incident or series of actions. **Consequence**: A warning with consequences for continued behavior. No interaction with the people involved, including unsolicited interaction with those enforcing the Code of Conduct, for a specified period of time. This includes avoiding interactions in community spaces as well as external channels like social media. Violating these terms may lead to a temporary or permanent ban. ### 3. Temporary Ban **Community Impact**: A serious violation of community standards, including sustained inappropriate behavior. **Consequence**: A temporary ban from any sort of interaction or public communication with the community for a specified period of time. No public or private interaction with the people involved, including unsolicited interaction with those enforcing the Code of Conduct, is allowed during this period. Violating these terms may lead to a permanent ban. ### 4. Permanent Ban **Community Impact**: Demonstrating a pattern of violation of community standards, including sustained inappropriate behavior, harassment of an individual, or aggression toward or disparagement of classes of individuals. **Consequence**: A permanent ban from any sort of public interaction within the community. ## Attribution This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 2.0, available at https://www.contributor-covenant.org/version/2/0/code_of_conduct.html. Community Impact Guidelines were inspired by [Mozilla's code of conduct enforcement ladder](https://github.com/mozilla/diversity). [homepage]: https://www.contributor-covenant.org For answers to common questions about this code of conduct, see the FAQ at https://www.contributor-covenant.org/faq. Translations are available at https://www.contributor-covenant.org/translations. ================================================ FILE: CONTRIBUTING.md ================================================ # Contributing First of all, thanks for your interest in contributing to Finkel! We want to make contributing to this project as easy and transparent as possible, whether it's: - Reporting a bug - Discussing the current state of the code - Submitting a fix - Proposing new features - Becoming a maintainer Finkel is an open source project. Following these guidelines helps to communicate that you respect the time of the developers managing and developing this open source project. In return, they should reciprocate that respect in addressing your issue, assessing changes, and helping you finalize your pull requests. ## Code of Conduct All members of our community are expected to follow our [Code of Conduct][coc]. Please make sure you are welcoming and friendly in all of our spaces. [coc]: https://github.com/finkel-lang/finkel/blob/master/CODE_OF_CONDUCT.md ## Getting started with Finkel source Please see the [Building And Installing][doc-install] section of the documentation for detailed instruction. In short: ``` $ git clone https://github.com/finkel-lang/finkel $ cd finkel $ stack build ``` [doc-install]: https://finkel.readthedocs.io/en/latest/contents/install.html ## Issues We use the [github issue tracker][ghissue] to manage issues. Please do some searches in the existing issues before creating a new one. When sending a bug report, please make sure that you are using the latest version of Finkel built from the source. [ghissue]: https://github.com/finkel-lang/finkel/issues ## Pull Requests ### Style guide / Coding conventions We believe every one has its taste in coding style. However, the following provides some suggestions: - By default, all source codes are written with max 80 characters per line, but there are some exceptions, e.g. use of long string constants in URL. - For Haskell source code, use 2 spaces for indentations. We use [hlint][hlint] and [stylish-haskell][stylish-haskell] with the configuration files in the repository root directory. It is totally fine to make changes to the configuration files, just please tell us why. - For Finkel source code, not much to say at the moment, since the language is still young. However, try to follow the style used in the file when you modify the existing file. - Please consider writing [a good Git commit message][gitcommit]. [hlint]: https://github.com/ndmitchell/hlint [stylish-haskell]: https://github.com/jaspervdj/stylish-haskell [gitcommit]: https://chris.beams.io/posts/git-commit/#seven-rules ### Running tests Please make sure that the tests are passing with your modifications. For example, to test with [stack][stack], run: ``` $ stack build --test ``` [stack]: https://docs.haskellstack.org/en/stable/README/ ### Trivial changes Small contributions such as fixing spelling errors, can be also submitted by a contributor as a pull request. As a rule of thumb, changes are obvious fixes if they do not introduce any new functionality or creative thinking. As long as the change does not affect functionality, some likely examples include the following: - Spelling/grammar fixes - Typo correction, white space and formatting changes - Comment clean up - Changes to *metadata* files like ``.gitignore``, etc. ### License In short, when you submit code changes, your submissions are understood to be under the same [BSD 3-clause License][bsd3] that covers the project. [bsd3]: https://choosealicense.com/licenses/bsd-3-clause/ ================================================ FILE: LICENSE ================================================ Copyright 8c6794b6 (c) 2017-2020 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: README.md ================================================ # Finkel [![CI status][ci-badge]][ci] [![Documentation][doc-badge]][doc] [![Codecov][codecov-badge]][codecov] Finkel is a statically typed, purely functional, and non-strict-by-default [LISP][lisp] flavored programming language. Or in other words, **[Haskell][haskell] in S-expression**. ## Features - Integration with existing Haskell modules. - Building Haskell-compatible [Cabal][cabal] packages. - Documentation generation with [Haddock][haddock]. - Lisp style macro system. - Tool executable, including interactive REPL. ## Example ### Sample code ```clojure ;;;; File: fib.hs (:doc "Simple example module to show fibonacci number. The compiled executable takes an integer argument from command line input and print the fibonacci number of the argument.") (defmodule Main (import (System.Environment [getArgs]))) (defn (:: main (IO ())) "The main entry point function." (>>= getArgs (. print fib read head))) (defn (:: fib (-> Int Int)) "Naive fibonacci function." [0] 0 [1] 1 [n] (+ (fib (- n 1)) (fib (- n 2)))) ``` ### Compiling an executable ```console $ finkel make -o fib fib.hs [1 of 1] Compiling Main ( fib.hs, fib.o ) Linking fib $ ./fib 10 55 ``` ### Running REPL ```console $ finkel repl Hit `Ctrl-d' or type ,q to quit, type ,? for help. > ,load fib.hs [1 of 1] Compiling Main ( fib.hs, interpreted ) ; loaded fib.hs > ,info fib fib :: Int -> Int -- Defined at fib.hs:16:11 > (map fib [1 .. 10]) [1,1,2,3,5,8,13,21,34,55] > (System.Environment.withArgs ["10"] main) 55 > ,q ``` ## Further resources See the [documentation][doc] for more details. ## Contributing Contributions are welcome. Please see the [CONTRIBUTING.md][contrib]. [ci-badge]: https://img.shields.io/github/actions/workflow/status/finkel-lang/finkel/ci.yml?logo=github&label=ci [ci]: https://github.com/finkel-lang/finkel/actions/workflows/ci.yml [doc-badge]: http://readthedocs.org/projects/finkel/badge/?version=latest [doc]: https://finkel.readthedocs.io/en/latest/ [codecov-badge]: https://codecov.io/gh/finkel-lang/finkel/branch/master/graph/badge.svg [codecov]: https://codecov.io/gh/finkel-lang/finkel [cabal]: https://www.haskell.org/cabal/ [contrib]: https://github.com/finkel-lang/finkel/blob/master/CONTRIBUTING.md [haddock]: https://www.haskell.org/haddock/ [haskell]: https://haskell.org [lisp]: https://en.wikipedia.org/wiki/Lisp_(programming_language) ================================================ FILE: cabal.project ================================================ packages: -- Main components finkel-kernel/ fkc/ fnkpp/ finkel-setup/ finkel-core/ finkel-tool/ finkel/ -- For test doc/ doc/include/building-package/my-first-package doc/include/building-package/my-second-package doc/include/building-package/my-new-package tests: True benchmarks: True library-profiling: True package finkel-kernel flags: +dev ================================================ FILE: default.nix ================================================ { nixpkgs ? , compiler ? "ghc8106" }: let pkgs = import ./nix/finkel-packages.nix { inherit compiler nixpkgs; }; in pkgs.finkelPackages ================================================ FILE: doc/LICENSE ================================================ Copyright 8c6794b6 (c) 2020-2022 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: doc/Makefile ================================================ # Minimal makefile for Sphinx documentation # # You can set these variables from the command line. SPHINXOPTS = SPHINXBUILD = sphinx-build SOURCEDIR = . BUILDDIR = _build # Put it first so that "make" without argument is like "make help". help: @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) .PHONY: help Makefile # Catch-all target: route all unknown targets to Sphinx using the new # "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). %: Makefile @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) ================================================ FILE: doc/Setup.hs ================================================ import Distribution.Simple (defaultMain) main = defaultMain ================================================ FILE: doc/conf.py ================================================ # -*- coding: utf-8 -*- # # Configuration file for the Sphinx documentation builder. # # This file does only contain a selection of the most common options. For a # full list see the documentation: # http://www.sphinx-doc.org/en/master/config # -- Path setup -------------------------------------------------------------- # If extensions (or modules to document with autodoc) are in another directory, # add these directories to sys.path here. If the directory is relative to the # documentation root, use os.path.abspath to make it absolute, like shown here. # # import os # import sys # sys.path.insert(0, os.path.abspath('.')) # -- Project information ----------------------------------------------------- project = 'Finkel' copyright = '2019-2022, 8c6794b6' author = '8c6794b6' # The short X.Y version version = '' # The full version, including alpha/beta/rc tags release = '' # -- General configuration --------------------------------------------------- # If your documentation needs a minimal Sphinx version, state it here. # # needs_sphinx = '1.0' # Add any Sphinx extension module names here, as strings. They can be # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom # ones. extensions = [ ] # Add any paths that contain templates here, relative to this directory. templates_path = ['_templates'] # The suffix(es) of source filenames. # You can specify multiple suffix as a list of string: # # source_suffix = ['.rst', '.md'] source_suffix = '.rst' # The master toctree document. master_doc = 'index' # The language for content autogenerated by Sphinx. Refer to documentation # for a list of supported languages. # # This is also used if you do content translation via gettext catalogs. # Usually you set "language" from the command line for these cases. language = 'en' # List of patterns, relative to source directory, that match files and # directories to ignore when looking for source files. # This pattern also affects html_static_path and html_extra_path. exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store'] # The name of the Pygments (syntax highlighting) style to use. # pygments_style = None # pygments_style = 'colorful' # pygments_style = 'default' # pygments_style = 'emacs' pygments_style = 'friendly' # -- Options for HTML output ------------------------------------------------- # The theme to use for HTML and HTML Help pages. See the documentation for # a list of builtin themes. # html_theme = 'sphinx_rtd_theme' # html_theme = 'alabaster' # html_theme = 'furo' # html_theme = 'sphinx_material' # html_theme = 'pydata_sphinx_theme' # html_theme = 'sphinx_book_theme' # html_theme = 'sphinx_typlog_theme' # html_theme = 'insipid' # Theme options are theme-specific and customize the look and feel of a theme # further. For a list of options available for each theme, see the # documentation. # html_theme_options = {} # For 'alabaster' theme # html_theme_options = { # 'fixed_sidebar': True, # 'show_relbars': True, # } # For 'rtd' theme # html_theme_options = { # 'display_version': True, # 'prev_next_buttons_location': 'bottom', # 'style_nav_header_background': '#2980b9', # } # For 'sphinx_material' theme # html_theme_options = { # 'base_url': 'http://finkel.readthedocs.io/', # 'repo_url': 'https://github.com/finkel-lang/finkel/', # 'repo_name': 'Finkel', # # 'google_analytics_account': 'UA-XXXXX', # # 'html_minify': True, # # 'css_minify': True, # # 'nav_title': 'The Finkel Documentation', # # 'logo_icon': '', # # 'logo_icon': '', # 'logo_icon': '', # 'globaltoc_depth': 1, # 'globaltoc_collapse': True, # 'color_primary': 'teal', # } # For furo # html_theme_options = { # "light_css_variables": { # "font-stack": "Arial, sans-serif", # "font-stack--monospace": "Courier, monospace", # }, # } # Add any paths that contain custom static files (such as style sheets) here, # relative to this directory. They are copied after the builtin static files, # so a file named "default.css" will overwrite the builtin "default.css". html_static_path = ['_static'] # Custom sidebar templates, must be a dictionary that maps document names # to template names. # # The default sidebars (for documents that don't match any pattern) are # defined by theme itself. Builtin themes are using these templates by # default: ``['localtoc.html', 'relations.html', 'sourcelink.html', # 'searchbox.html']``. # # html_sidebars = {} # html_sidebars = { # "**": [ # "globaltoc.html", # "localtoc.html", # "searchbox.html", # ] # } # For material # html_sidebars = { # "**": [ # "logo-text.html", # "globaltoc.html", # "localtoc.html", # "searchbox.html", # ] # } # -- Options for HTMLHelp output --------------------------------------------- # Output file base name for HTML help builder. htmlhelp_basename = 'Finkeldoc' # -- Options for LaTeX output ------------------------------------------------ latex_elements = { # The paper size ('letterpaper' or 'a4paper'). # # 'papersize': 'letterpaper', # The font size ('10pt', '11pt' or '12pt'). # # 'pointsize': '10pt', # Additional stuff for the LaTeX preamble. # # 'preamble': '', # Latex figure (float) alignment # # 'figure_align': 'htbp', } # Grouping the document tree into LaTeX files. List of tuples # (source start file, target name, title, # author, documentclass [howto, manual, or own class]). latex_documents = [ (master_doc, 'Finkel.tex', 'Finkel Documentation', '8c6794b6', 'manual'), ] # -- Options for manual page output ------------------------------------------ # One entry per manual page. List of tuples # (source start file, name, description, authors, manual section). man_pages = [ (master_doc, 'finkel', 'Finkel Documentation', [author], 1) ] # -- Options for Texinfo output ---------------------------------------------- # Grouping the document tree into Texinfo files. List of tuples # (source start file, target name, title, author, # dir menu entry, description, category) texinfo_documents = [ (master_doc, 'Finkel', 'Finkel Documentation', author, 'Finkel', 'Lisp Flavored Haskell', 'Miscellaneous'), ] # -- Options for Epub output ------------------------------------------------- # Bibliographic Dublin Core info. epub_title = project # The unique identifier of the text. This can be a ISBN number # or the project homepage. # # epub_identifier = '' # A unique identification for the text. # # epub_uid = '' # A list of files that should not be packed into the epub file. epub_exclude_files = ['search.html'] # -- Custom setup function from pygments.lexer import RegexLexer, bygroups from pygments import token from pygments.token import Text, Comment, Number, String, Keyword, \ Name, Operator, Punctuation from pygments import unistring as uni from sphinx.highlighting import lexers import re class FinkelLexer(RegexLexer): name = 'finkel' reserved = ( # Haskell 2010 'case', 'class', 'data', 'default', 'deriving', 'do', 'family', 'if', 'infix', 'infixl', 'infixr', 'instance', 'let', 'newtype', 'type', 'where', '_', '=', '=>', '<-', '->', '::', # Finkel kernel special forms ':begin', ':eval-when-compile', ':quote', ':quasiquote', ':unquote', ':unquote-splice', # Finkel core 'eval-when', 'macrolet', ) ascii = ('NUL', 'SOH', '[SE]TX', 'EOT', 'ENQ', 'ACK', 'BEL', 'BS', 'HT', 'LF', 'VT', 'FF', 'CR', 'S[OI]', 'DLE', 'DC[1-4]', 'NAK', 'SYN', 'ETB', 'CAN', 'EM', 'SUB', 'ESC', '[FGRU]S', 'SP', 'DEL') tokens = { 'root': [ # Whitespace: (r'\s+', Text), # Pragma: (r'%p\(.*', token.Comment), # Comment: (r'{-', Comment.Multiline, 'multiline-comment'), (r';.*', Comment.Single), (r'%_', Comment.Single), # Numbers (r'-?\d+\.\d+', Number.Float), (r'-?\d(_*\d)*_*[eE][+-]?\d(_*\d)*', Number.Float), (r'0[oO]_*[0-7](_*[0-7])*', Number.Oct), (r'0[xX]_*[\da-fA-F](_*[\da-fA-F])*', Number.Hex), (r'-?\d+', Number.Integer), # Characters: (r"#'", String.Char, 'character'), # String literal (r'"', String, 'string'), # Core macros (r"(defn)(\s+\(?)(::)?(\s+)?([^\s]+)", bygroups(Keyword.Reserved, Text, Keyword.Reserved, Text, Name.Function)), (r"(defmacro)(\s+)([^\s]+)", bygroups(Keyword.Reserved, Text, Name.Function)), (r"(defmodule)(\s+)([A-Z]\w+)", bygroups(Keyword.Reserved, Text, Name.Namespace), 'defmodule'), # Module header (r"(module)(\s+)([^\s]+)", bygroups(Keyword.Reserved, Text, Name.Namespace)), # Macro specific keywords (r':compile', String), (r':load', String), # Keywords ('(%s)' % '|'.join(re.escape(e) + ' ' for e in reserved), Keyword.Reserved), # Import (r'(import|:require)(\s+)(qualified)?(\s+)?([A-Z][\w\.]+)(\s+)?(as|hiding)?', bygroups(Keyword.Reserved, Text, Keyword.Reserved, Text, Name.Namespace, Text, Keyword.Reserved), 'funclist'), # Types (r'([A-Z][0-9a-zA-Z\-_]*)', Keyword.Type), # Operators (r'([!@$%^&*-=+?/<>\|~]+)', Operator), (r'(,@|,)', Operator), # Variable identifier (r'[_a-z][\w\']*', Name), # Lambda (r'\\', Keyword.Reserved), # Puctuation (r'(\(|\))', Punctuation), (r'(\[|\])', Punctuation), (r'(\{|\})', Punctuation), (r'`', Punctuation), (r"'", Punctuation), ], 'character': [ (r"[^\\]", String.Char, '#pop'), (r"\\", String.Escape, 'escape'), (r" ", String.Char, '#pop'), ], 'string': [ (r'[^\\"]+', String), (r"\\", String.Escape, 'escape'), ('"', String, '#pop'), ], 'escape': [ (r'[abfnrtv"\'&\\]', String.Escape, '#pop'), (r'\^[][' + uni.Lu + r'@^_]', String.Escape, '#pop'), ('|'.join(ascii), String.Escape, '#pop'), (r'o[0-7]+', String.Escape, '#pop'), (r'x[\da-fA-F]+', String.Escape, '#pop'), (r'\d+', String.Escape, '#pop'), (r'\s+\\', String.Escape, '#pop'), (r'', String.Escape, '#pop'), ], 'defmodule': [ (r'\s+', Text), (r'export', Keyword.Reserved, 'funclist'), (r'(import-when)(\s+)(\[)(:compile|:load)+(\])(\s+)', bygroups(Keyword.Reserved, Text, Punctuation, String, Punctuation, Text), 'import-body'), (r'import', Keyword.Reserved, 'import-body'), (r'require', Keyword.Reserved, 'import-body'), (r'\(', Punctuation, '#push'), (r'\)', Punctuation, '#pop'), (r'', Text, '#pop'), ], 'import-body': [ (r'\s+', Text), (r'(as|hiding)', Keyword.Reserved), (r'[A-Za-z_.]+', Name.Namespace, 'funclist'), (r'\(', Punctuation, '#push'), (r'\)', Punctuation, '#pop'), (r'', Text, '#pop'), ], 'funclist': [ (r'\s+', Text), (r'(_[\w\']+|[' + uni.Ll + r'][\w\'-]*)', Name.Function), (r'\(', Punctuation, '#push'), (r'\)', Punctuation, '#pop'), (r'', Text, '#pop'), ], 'multiline-comment': [ (r'{-', Comment.Multiline, '#push'), (r'-}', Comment.Multiline, '#pop'), (r'[^-}]+', Comment.Multiline), (r'[-}]', Comment.Multiline), ] } def setup(sphinx): sphinx.add_lexer("finkel", FinkelLexer) ================================================ FILE: doc/contents/building-package.rst ================================================ Building Cabal Package ====================== To build a cabal package with Finkel, make a cabal configuration file as in the Haskell cabal package, but with some build tool and package dependencies. .. note:: This documentation assumes the readers are using the `stack `_ build tool for building cabal packages. Those who prefer other tools such as `cabal-install `_ may translate the invoked commands and modify the file contents as necessary. Building My First Package ------------------------- Make a directory named ``my-first-package``, and create a file named ``package.yaml`` under the directory with following contents: .. literalinclude:: ../include/building-package/my-first-package/package.yaml :language: yaml And a simple ``Setup.hs`` script: .. literalinclude:: ../include/building-package/my-first-package/Setup.hs :language: haskell And a Finkel source code ``src/MyFirstPackage.hs`` for exposed module: .. literalinclude:: ../include/building-package/my-first-package/src/MyFirstPackage.hs :language: finkel And a ``stack.yaml``: .. literalinclude:: ../include/building-package/my-first-package/stack.template.yaml :language: yaml At this point the files under the ``my-first-project`` directory should look like below: :: my-first-package ├── package.yaml ├── Setup.hs ├── src │ └── MyFirstPackage.hs └── stack.yaml Now one can build the ``my-first-package`` package with ``stack``: .. code-block:: console $ stack build my-first-package ... Output messages omitted ... [1 of 2] Compiling Main [2 of 2] Compiling StacksetupShim ... More output messages ... [1 of 1] Compiling MyFirstPackage .. tip:: To build a package containing Finkel source codes with the latest ``finkel`` built from source, one can specify the packages from `finkel git repository `_ as extra dependencies. For example, the following ``stack.yaml`` is set to build a package in the current directory with ``finkel`` from the git repository: .. literalinclude:: ../include/building-package/my-first-package/stack.git.yaml :language: yaml See the `stack documentation `_ and the `Cabal User Guide `_ for more information about using remote git repository for extra dependencies. Mixing Finkel And Haskell Source Codes -------------------------------------- One can mix Finkel source codes and Haskell source codes in a package. This time, making a package ``my-second-package`` with ``stack new`` command using Finkel specific template: .. code-block:: console $ stack new my-second-package https://raw.githubusercontent.com/finkel-lang/finkel/master/finkel-tool/finkel.hsfiles .. warning:: At the time of writing, one may encounter messages similar to the following when running ``stack new`` with the above template: .. code-block:: console Selecting the best among 17 snapshots... * Partially matches lts-15.7 finkel-setup not found - my-second-pkg requires -any * Partially matches nightly-2020-03-04 finkel-setup not found - my-second-pkg requires -any ... Selected resolver: lts-15.7 Resolver 'lts-15.7' does not have all the packages to match your requirements. finkel-setup not found - my-second-pkg requires -any This may be resolved by: - Using '--omit-packages' to exclude mismatching package(s). - Using '--resolver' to specify a matching snapshot/resolver This is because the packages for ``finkel`` is not yet uploaded to `stackage `_. As the message indicates, one can pass ``--omit-packages`` option or ``--resolver`` option to ``stack new`` until the ``finkel`` dependency packages are uploaded to the upstream, and add the git repository to ``stack.yaml``. The above command will make a directory named ``my-second-package`` with a cabal configuration file, ``Setup.hs`` script, and a stub Finkel source code file. Directory contents of ``my-second-package`` should look like below: :: my-second-package ├── app │ └── Main.hs ├── LICENSE ├── my-second-package.cabal ├── README.md ├── Setup.hs ├── src │ └── Lib.hs └── test └── Spec.hs Add a new file named ``my-second-package/src/FnkCodes.hs``, with Finkel source codes: .. literalinclude:: ../include/building-package/my-second-package/src/FnkCodes.hs :language: finkel And another new file named ``my-second-package/src/HsCodes.hs``, with Haskell source codes: .. literalinclude:: ../include/building-package/my-second-package/src/HsCodes.hs :language: haskell Modify the ``library`` stanza of the file ``my-second-package.cabal`` and add ``HsCodes`` and ``FnkCodes`` modules as shown below: .. literalinclude:: ../include/building-package/my-second-package/my-second-package.cabal :lines: 22-29 The functions exported from ``HsCodes`` module could be used from ``Lib`` module, as in compilation of cabal package without Finkel codes. Modify the file ``my-second-package/src/Lib.hs`` to import ``hsfactorial`` and ``fnkfactorial`` functions from ``HsCodes``: .. literalinclude:: ../include/building-package/my-second-package/src/Lib.hs :language: finkel One can build the ``my-second-package`` with ``stack build`` command, as before: .. code-block:: console $ stack build my-second-package .. note:: It is also possible to use a library package containing Finkel code from other Haskell packages as a build dependency since the resulting object codes are compiled by compatible ``ghc`` version. Executable, Test, Coverage, And Haddock --------------------------------------- The ``my-second-package`` cabal package contains an executable named ``my-second-package``. The executable simply invokes the ``Lib.someFunc`` function. To compile and run the executable: .. code-block:: console $ stack run my-second-package:my-second-package From `Lib.someFunc': hsfactorial 10 : 3628800 fnkfactorial 10 : 3628800 To run tests, invoke ``stack test`` or ``stack build --test``: .. code-block:: console $ stack build --test my-second-package To generate code coverage report, add ``--coverage`` option when running test: .. code-block:: console $ stack build --test --coverage my-second-package And, to generate haddock documentation of the package, add ``--haddock`` option to ``stack build`` command: .. code-block:: console $ stack build --haddock my-second-package ================================================ FILE: doc/contents/finkel-executable.rst ================================================ Using The Finkel Executable =========================== The ``finkel`` executable from the ``finkel`` package contains sub-commands to work with Finkel source codes. Compiling with Finkel Make -------------------------- To compile a Finkel source code file, one can use the ``make`` sub-command. Open a file named ``hello.hs`` with your favorite editor and save the file with the following contents: .. literalinclude:: ../include/finkel-executable/hello.hs :language: finkel Then invoke ``finkel make`` to compile the file. The command shown in the following line will compile the file as an executable named ``hello``: .. literalinclude:: ../include/finkel-executable/hello.console :language: console The ``make`` sub-command understands most of the options for the ``ghc`` executable ``--make`` mode: .. literalinclude:: ../include/finkel-executable/hello-prof.console :language: console The compiled executable understands RTS options: .. code-block:: console $ ./hello +RTS -s -p Hello, World! 56,992 bytes allocated in the heap 4,864 bytes copied during GC 46,040 bytes maximum residency (1 sample(s)) 23,592 bytes maximum slop 0 MB total memory in use (0 MB lost due to fragmentation) Tot time (elapsed) Avg pause Max pause Gen 0 0 colls, 0 par 0.000s 0.000s 0.0000s 0.0000s Gen 1 1 colls, 0 par 0.000s 0.000s 0.0001s 0.0001s INIT time 0.000s ( 0.000s elapsed) MUT time 0.000s ( 0.000s elapsed) GC time 0.000s ( 0.000s elapsed) RP time 0.000s ( 0.000s elapsed) PROF time 0.000s ( 0.000s elapsed) EXIT time 0.000s ( 0.000s elapsed) Total time 0.000s ( 0.001s elapsed) %GC time 0.0% (0.0% elapsed) Alloc rate 0 bytes per MUT second Productivity 100.0% of total user, 22.7% of total elapsed Running REPL ------------ From shell ^^^^^^^^^^ The ``finkel`` executable has ``repl`` sub-command to run an interactive *read-eval-print-loop* (a.k.a. REPL). To start a REPL from a shell, invoke ``finkel repl``: .. code-block:: console $ finkel repl Hit `Ctrl-d' or type ,q to quit, type ,? for help. > (+ 41 1) 42 > ,type foldr foldr :: Foldable t => (a -> b -> b) -> b -> t a -> b > ,info Rational type Rational = GHC.Real.Ratio Integer -- Defined in ‘GHC.Real’ > ,load hello.hs [1 of 1] Compiling Main ( hello.hs, interpreted ) ; loaded hello.hs > main Hello, World! > ,q From Emacs ^^^^^^^^^^ There is a major mode named ``finkel-mode`` for the `Emacs `_ editor, with functionality to run an interactive REPL session from Emacs. See the README file in the `finkel-mode repository `_ for more details. Getting More Help ----------------- The ``finkel`` executable contains a ``help`` sub-command to show brief usages of available commands: .. literalinclude:: ../include/finkel-executable/finkel-help-make.console :language: console ================================================ FILE: doc/contents/install.rst ================================================ Building And Installing ======================= .. note:: At the time of writing, Finkel related packages are not yet uploaded to `hackage `_ and `stackage `_. Container Image --------------- There is a container image with the ``finkel`` executable built from the latest source code with accompanying Haskell libraries and some development tools. The main use case of the container image is to play with ``finkel`` without setting up a working Haskell environment. For instance, one can run ``finkel`` with ``docker`` by followings: .. code-block:: console $ docker pull ghcr.io/finkel-lang/finkel:latest $ docker run --rm -it ghcr.io/finkel-lang/finkel:latest / # finkel eval '(putStrLn "Hello, Finkel!")' Hello, Finkel! See the `GitHub package page `_ for more info. Building From Source -------------------- Getting The Latest Source ^^^^^^^^^^^^^^^^^^^^^^^^^ Clone the Finkel repository with ``git``: .. code-block:: console $ git clone https://github.com/finkel-lang/finkel.git Building With ``stack`` ^^^^^^^^^^^^^^^^^^^^^^^ One can use ``stack`` to build the packages. To build and test with ``stack``: .. code-block:: console $ cd finkel $ stack build --test And to install the ``finkel`` executable: .. code-block:: console $ stack build --copy-bins finkel Building With ``cabal-install`` ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ .. note:: As of ``cabal-install`` version 3.4.0.0, installing with ``cabal v2-install`` does not work. This is `a known issue `_ related to the file extension used by Finkel. To install with ``cabal-install``, use the ``cabal v1-install`` command or the ``setup`` executable built under the ``dist-newstyle`` directory. To build and test with ``cabal-install``: .. code-block:: console $ cd finkel $ cabal v2-build all $ cabal v2-test all Building With ``nix`` ^^^^^^^^^^^^^^^^^^^^^ The git repository contains ``default.nix`` file. Building and testing with `nix `_ could be done with: .. code-block:: console $ nix-build ================================================ FILE: doc/contents/language-syntax.rst ================================================ Language Syntax =============== The Finkel language is made from Finkel kernel keywords and Finkel core keywords. The Finkel kernel keywords are designed to be compatible with `Haskell 2010 `_, with few exceptions. The syntax for literal values and function applications are also defined in the Finkel kernel. The rest of this section will go through the Finkel kernel language syntax with small example codes. Each Finkel code is compared to an equivalent Haskell code. The Finkel core keywords are implemented as macros. Details of the Finkel core keywords are described in the `haddock API documentation `_ of the ``finkel-core`` package. Literals -------- Comments ^^^^^^^^ Line contents after ``;`` are treated as comments. .. literalinclude:: ../include/language-syntax/expr/line-comment.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/line-comment.hs :language: haskell Block style comment is supported with ``{-`` and ``-}``. .. literalinclude:: ../include/language-syntax/expr/block-comment.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/block-comment.hs :language: haskell Form after ``%_`` is ignored: .. literalinclude:: ../include/language-syntax/expr/discard-prefix.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/discard-prefix.hs :language: haskell Variable identifier ^^^^^^^^^^^^^^^^^^^ Finkel accepts valid variable identifiers defined in Haskell 2010, and variable identifiers containing hyphens which starting with a non-operator character. Hyphens in variable identifiers are internally converted to underscores. For instance, ``foo-bar-buzz`` will be converted to ``foo_bar_buzz``: .. literalinclude:: ../include/language-syntax/expr/varid.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/varid.hs :language: haskell The hyphen conversion will be triggered only when the first letter of a variable identifier was a non-operator character. Operators like ``-:-``, ``*+-``, ``$-$``, etc are kept as-is. Numeric ^^^^^^^ As described in the `Numeric Literals `_ section of the Haskell 2010 report, decimal, octal, hexadecimal integers and float with exponent are supported. .. literalinclude:: ../include/language-syntax/expr/numeric.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/numeric.hs :language: haskell Character And String ^^^^^^^^^^^^^^^^^^^^ A character literal in Finkel starts with ``#'`` instead of surrounding with single quotes. Other than that, Finkel mostly follows the `Characters and String Literals `_ section in the Haskell 2010 report. Following code prints single lower case character ``a``: .. literalinclude:: ../include/language-syntax/expr/char-a.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/char-a.hs :language: haskell Following code prints backslash and single quote: .. literalinclude:: ../include/language-syntax/expr/char-escape.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/char-escape.hs :language: haskell Some characters like newline, space, NUL, etc. are expressed with escape character and specific character sequences. .. literalinclude:: ../include/language-syntax/expr/char-special.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/char-special.hs :language: haskell Characters could be expressed with their numeric code in decimal, octal, and hexadecimal: .. literalinclude:: ../include/language-syntax/expr/char-ncode.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/char-ncode.hs :language: haskell String literals are written between double-quotes. Special characters are escaped with ``\``. Finkel also supports the **gap** feature, to ignore the string contents between two backslashes. .. literalinclude:: ../include/language-syntax/expr/string.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/string.hs :language: haskell Expressions ----------- Function Applications ^^^^^^^^^^^^^^^^^^^^^ Function application in Finkel is done with parentheses: .. literalinclude:: ../include/language-syntax/expr/funapp.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/funapp.hs :language: haskell Unlike some other lisps, extra parentheses are ignored. For instance: .. literalinclude:: ../include/language-syntax/expr/funapp-pars.fnk :language: finkel is simplified to: .. literalinclude:: ../include/language-syntax/expr/funapp-pars.hs :language: haskell Operator Applications ^^^^^^^^^^^^^^^^^^^^^ Finkel does not have native support for infix operator applications. However, a form applying operator function will be expanded to a form taking all of its arguments, with two operands for each. For example, adding numbers from 1 to 5 could be written as: .. literalinclude:: ../include/language-syntax/expr/opexp-add.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/opexp-add.hs :language: haskell Operator expansion understands right and left associativity. Operator precedence in Finkel is explicitly specified with parentheses. .. literalinclude:: ../include/language-syntax/expr/opexp-app.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/opexp-app.hs :language: haskell The compiler treats the above expression as: .. code-block:: haskell ((pure foldr <*> Just (+)) <*> pure 1) <*> pure [2, 3] -- Haskell because the ``<*>`` operator is left-associative. When a single argument has been passed to operator function, the resulting expression is partial application: .. literalinclude:: ../include/language-syntax/expr/map-mul2.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/map-mul2.hs :language: haskell To apply more than two arguments to an operator function, one needs to explicitly surround the operator with parenthesis. Suppose that there is an operator function ``*+`` which takes three arguments: .. literalinclude:: ../include/language-syntax/expr/muladd.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/muladd.hs :language: haskell Unary Operator Application ^^^^^^^^^^^^^^^^^^^^^^^^^^ The operator ``-`` is always treated as a binary operator in Finkel. In below Finkel example, ``(- 1)`` is a partially applied function: .. literalinclude:: ../include/language-syntax/expr/map-unary.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/map-unary.hs :language: haskell Lambda ^^^^^^ Lambda expression starts with ``\``. The last form in the lambda expression the body expression of entire lambda abstraction, others forms are argument patterns: .. literalinclude:: ../include/language-syntax/expr/lambda.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/lambda.hs :language: haskell Conditionals ^^^^^^^^^^^^ An ``if`` expression does not take ``then`` and ``else``: .. literalinclude:: ../include/language-syntax/expr/if.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/if.hs :language: haskell A guard starts with ``|``, and supports pattern, local declaration, and boolean: .. literalinclude:: ../include/language-syntax/expr/guard.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/guard.hs :language: haskell See also `cond `_ in ``finkel-core``. Tuples ^^^^^^ Tuple constructor expression uses single comma. At least one space after the comma is required: .. literalinclude:: ../include/language-syntax/expr/tup2.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/tup2.hs :language: haskell Single comma works for tuples with more than two elements: .. literalinclude:: ../include/language-syntax/expr/tup5.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/tup5.hs :language: haskell To express tuple data and type constructor, use consecutive commas without spaces: .. literalinclude:: ../include/language-syntax/expr/tupfn.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/tupfn.hs :language: haskell Unit ^^^^ Unit is expressed with empty parentheses: .. literalinclude:: ../include/language-syntax/expr/unit.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/unit.hs :language: haskell See also `nil `_ to express an empty form. Lists ^^^^^ List expression does not take commas: .. literalinclude:: ../include/language-syntax/expr/list-const.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/list-const.hs :language: haskell Arithmetic sequences use ``..``. Space on each side of ``..`` are required: .. literalinclude:: ../include/language-syntax/expr/list-range.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/list-range.hs :language: haskell List comprehensions use ``|`` to separate the resulting expression. Space between ``|`` and the result is required. .. literalinclude:: ../include/language-syntax/expr/list-comp.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/list-comp.hs :language: haskell Let ^^^ A let expression is expressed with ``let`` without ``in``: .. literalinclude:: ../include/language-syntax/expr/let.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/let.hs :language: haskell Case ^^^^ A case expression is expressed with ``case`` without ``of`` and ``->``: .. literalinclude:: ../include/language-syntax/expr/case.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/case.hs :language: haskell Do ^^^ Do expression is expressed with ``do``, and bindings inside do-expressions are expressed with ``<-``: .. literalinclude:: ../include/language-syntax/expr/do.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/do.hs :language: haskell Datatypes with field labels ^^^^^^^^^^^^^^^^^^^^^^^^^^^ Field labels are enclosed with ``{`` and ``}``: .. literalinclude:: ../include/language-syntax/expr/fieldlabels.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/fieldlabels.hs :language: haskell Expression Type-Signatures ^^^^^^^^^^^^^^^^^^^^^^^^^^ Type signature uses ``::``: .. literalinclude:: ../include/language-syntax/expr/sige.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/sige.hs :language: haskell Pattern Matching ^^^^^^^^^^^^^^^^ A non-variable pattern requires parentheses, as in ``Just`` shown below: .. literalinclude:: ../include/language-syntax/expr/pat-maybe.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/pat-maybe.hs :language: haskell As pattern """""""""" As pattern uses ``@``: .. literalinclude:: ../include/language-syntax/expr/pat-as.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/pat-as.hs :language: haskell Irrefutable pattern """"""""""""""""""" Irrefutable patterns are expressed with ``~``: .. literalinclude:: ../include/language-syntax/expr/pat-irf.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/pat-irf.hs :language: haskell Operator expansion """""""""""""""""" The Operator expansion rule applies to patterns. For instance, the ``:`` constructor for a list is expanded with its pattern arguments: .. literalinclude:: ../include/language-syntax/expr/pat-opexp.fnk :language: finkel .. literalinclude:: ../include/language-syntax/expr/pat-opexp.hs :language: haskell Declarations And Bindings ------------------------- Algebraic Datatype ^^^^^^^^^^^^^^^^^^ Algebraic datatype declaration uses ``data``. It does not use ``=`` and ``|``. Optional ``deriving`` form may appear at the last element of the ``data`` form: .. literalinclude:: ../include/language-syntax/decl/data-d1.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/data-d1.hs :language: haskell Constructor with labeled fields are supported with ``{`` and ``}``: .. literalinclude:: ../include/language-syntax/decl/data-d2.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/data-d2.hs :language: haskell Type Synonym ^^^^^^^^^^^^ Type synonym declaration uses ``type``. It does not use ``=``: .. literalinclude:: ../include/language-syntax/decl/tysym.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/tysym.hs :language: haskell Datatype Renamings ^^^^^^^^^^^^^^^^^^ Newtype declaration uses ``newtype``: .. literalinclude:: ../include/language-syntax/decl/newtype.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/newtype.hs :language: haskell Class ^^^^^ Type class declaration uses ``class``: .. literalinclude:: ../include/language-syntax/decl/class.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/class.hs :language: haskell Class instance declaration uses ``instance``: .. literalinclude:: ../include/language-syntax/decl/instance.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/instance.hs :language: haskell Defaults for Overloaded Numeric Operations ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Default declaration is done with ``default``: .. literalinclude:: ../include/language-syntax/decl/default.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/default.hs :language: haskell Type Signatures ^^^^^^^^^^^^^^^ Type signature uses ``::``: .. literalinclude:: ../include/language-syntax/decl/tysig-one.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/tysig-one.hs :language: haskell Single type signature could be used for multiple variables: .. literalinclude:: ../include/language-syntax/decl/tysig-many.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/tysig-many.hs :language: haskell Constraints in type signature are expressed with ``=>``. The last element of the form ``=>`` should be a type: .. literalinclude:: ../include/language-syntax/decl/tysig-constraints.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/tysig-constraints.hs :language: haskell Fixity ^^^^^^ It is possible to declare fixity and precedence with ``infix``, ``infixl``, and ``infixr``. Assuming ``$+$`` as a binary operator: .. literalinclude:: ../include/language-syntax/decl/fixity.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/fixity.hs :language: haskell Note that Finkel syntax is affected by the left and right associativity of operators, but not by the precedence of operators. Bindings ^^^^^^^^ Function binding declaration uses ``=``. The form after ``=`` is the function name, the last form is the expression body. Rest of the forms are argument patterns: .. literalinclude:: ../include/language-syntax/decl/bind-simpl.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/bind-simpl.hs :language: haskell Keyword ``where`` can appear in the right-hand side: .. literalinclude:: ../include/language-syntax/decl/bind-where.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/bind-where.hs :language: haskell Pattern bindings are similarly done with ``=``: .. literalinclude:: ../include/language-syntax/decl/bind-pat.fnk :language: finkel .. literalinclude:: ../include/language-syntax/decl/bind-pat.hs :language: haskell Modules ------- Top-level module definition does not use ``where``: .. literalinclude:: ../include/language-syntax/module/simpl.fnk :language: finkel .. literalinclude:: ../include/language-syntax/module/simpl.hs :language: haskell See also `defmodule `_ in ``finkel-core``. Export Lists ^^^^^^^^^^^^ Module definition can contain an explicit export list. Entities in the export list can contain bindings, type and data constructors, type classes, and modules: .. literalinclude:: ../include/language-syntax/module/export-list.fnk :language: finkel .. literalinclude:: ../include/language-syntax/module/export-list.hs :language: haskell Import Declarations ^^^^^^^^^^^^^^^^^^^ Module import declarations use ``import``: .. literalinclude:: ../include/language-syntax/import/simpl.fnk :language: finkel .. literalinclude:: ../include/language-syntax/import/simpl.hs :language: haskell Qualified import declarations use ``qualified`` and optional ``as``: .. literalinclude:: ../include/language-syntax/import/qualified-as.fnk :language: finkel .. literalinclude:: ../include/language-syntax/import/qualified-as.hs :language: haskell Entity lists use list: .. literalinclude:: ../include/language-syntax/import/entity-list.fnk :language: finkel .. literalinclude:: ../include/language-syntax/import/entity-list.hs :language: haskell Hiding specified entities with ``hiding``. Form after ``hiding`` is a list of entity names to hide: .. literalinclude:: ../include/language-syntax/import/hiding.fnk :language: finkel .. literalinclude:: ../include/language-syntax/import/hiding.hs :language: haskell Altogether: .. literalinclude:: ../include/language-syntax/import/altogether.fnk :language: finkel .. literalinclude:: ../include/language-syntax/import/altogether.hs :language: haskell Foreign Function Interfaces --------------------------- Foreign Import ^^^^^^^^^^^^^^ Foreign import declarations start with ``foreign`` ``import``: .. literalinclude:: ../include/language-syntax/ffi/import.fnk :language: finkel .. literalinclude:: ../include/language-syntax/ffi/import.hs :language: haskell Foreign Export ^^^^^^^^^^^^^^ Foreign export declarations start with ``foreign`` ``export``: .. literalinclude:: ../include/language-syntax/ffi/export.fnk :language: finkel .. literalinclude:: ../include/language-syntax/ffi/export.hs :language: haskell Compiler Pragmas ---------------- All pragmas use ``%p(..)`` form. Inlining ^^^^^^^^ Pragmas to control inlining of codes use ``INLINE`` and ``NOINLINE``: .. code-block:: finkel %p(INLINE foo) ; Finkel .. code-block:: haskell {-# INLINE foo #-} -- Haskell GHC specific phase controls are also supported: .. code-block:: finkel %p(INLINE [1] bar) ; Finkel %p(NOINLINE [~2] buzz) .. code-block:: haskell {-# INLINE [1] bar #-} -- Haskell {-# NOINLINE [~2] buzz #-} Specialization ^^^^^^^^^^^^^^ Pragmas to control specialization of overloaded function use ``SPECIALIZE``: .. code-block:: finkel %p(SPECIALIZE (:: factorial (-> Int Int))) ; Finkel .. code-block:: haskell {-# SPECIALIZE factorial :: Int -> Int #-} -- Haskell Language extensions ^^^^^^^^^^^^^^^^^^^ Pragma for language extensions use ``LANGUAGE``: .. code-block:: finkel %p(LANGUAGE GADTs OverloadedStrings) ; Finkel .. code-block:: haskell {-# LANGUAGE GADTs, OverloadedStrings #-} -- Haskell .. Overlaps ^^^^^^^^ This is GHC specific ... .. .. rubric:: Footnotes .. [#f1] With few exceptions. Perhaps the most notable exception is the lack of native infix function support, but has operator expansion instead. ================================================ FILE: doc/contents/macros.rst ================================================ Macros In Finkel ================ This section shows how to write and use macros. Macros in Finkel are similar to macros in Common Lisp and Clojure. Macros in Finkel are implemented as a function taking codes and returning a code. Understanding Compilation Phases -------------------------------- During compilation, the compiler executable parses the contents of the source code. If the parsed code was a list, and the first element of the list was a symbol of known macro name, the rest of the elements in the list will be passed to the macro. Resulting forms will be replaced with the original list form of the macro. This replacement of the code with macro function is often called *macro expansion*. The expanded result will again get expanded until it cannot be expanded anymore. During macro expansion, the compiler can use predefined functions in the executable. To add functions to use during macro expansion, one needs to explicitly tell so. Defining Macro With ``eval-when`` And ``defmacro`` -------------------------------------------------- One way to tell a new macro to the compiler is to define a macro inside ``eval-when (compile)``. The ``eval-when`` is a macro that specifies the phase of declaration in its body form. The phase ``compile`` will evaluate the contents while compiling the parsed source code. Open a new file and save following contents to a file named ``eval-when.fnk``: .. literalinclude:: ../include/macros/eval-when.fnk :language: finkel In the above example, ``(import-when [:compile] (Finkel.Prelude))`` is added in the ``defmodule`` to import functions and data types for writing while compiling the ``Main`` module. The ``eval-when`` macro can take multiple forms. Two forms are passed to ``eval-when`` in the above example, one to define a macro named ``say-hello`` , and another to define a macro named ``say-bye``. The ``say-hello`` macro takes no argument, and the body of the macro simply returns a quoted form with a single quote (i.e. ``'``). Similarly, the ``say-bye`` macro takes no argument and returns a form to prints out a message. The ``main`` function contains the ``say-hello`` and ``say-bye`` macros. Unlike functions, macros taking no arguments need to be surrounded by parentheses. One can run the compiler with the ``-ddump-parsed`` option to observe the parsed Haskell representation: .. literalinclude:: ../include/macros/eval-when.console :language: console Defining Macro With ``macrolet`` -------------------------------- One can add a temporary macro with the ``macrolet`` macro. Following ``macrolet.fnk`` example do similar work done in the previous example, but using ``macrolet`` instead of ``eval-when`` and ``defmacro``. .. literalinclude:: ../include/macros/macrolet.fnk :language: finkel Note that single ``macrolet`` form can define multiple temporary macros. .. literalinclude:: ../include/macros/macrolet.console :language: console Loading Macros With ``require`` ------------------------------- Another way to add macros to the current module is to ``require`` a module containing macros. Open a file named ``RequireMe.fnk`` and save the following code: .. literalinclude:: ../include/macros/RequireMe.fnk :language: finkel Note that the ``RequireMe`` module has the ``import`` of ``Finkel.Prelude`` inside ``defmodule``. This is because the macros defined in ``RequireMe`` are not for itself, but other modules. Next, open and edit another file named ``require.fnk`` to require the ``RequireMe`` module: .. literalinclude:: ../include/macros/require.fnk :language: finkel Compilation output: .. literalinclude:: ../include/macros/require.console :language: console Unlike the previous two examples, one needs to generate an object code of the ``RequireMe`` module so that the macro functions defined in ``RequireMe`` could be used in the file ``require.fnk``. .. note:: As of finkel version 0.1, one may need to add ``-dynamic-too`` option to the ``finkel`` executable when compiling a source code file containing ``require``. Quasiquote, Unquote, And Unquote-Splice --------------------------------------- Macro can *unquote* and *unquote-splice* a form inside *quasiquote*. Open a new file named ``unquote.fnk`` and save the following contents: .. literalinclude:: ../include/macros/unquote.fnk :language: finkel The example defines two macros: ``uq1`` and ``uq2``. Both macros use ````` (back-tick) instead of ``'`` (single quote) in body expression. In ``uq1``, the macro argument ``arg`` is unquoted with ``,``, and the unquoted form is passed as the second argument of ``++`` function. In ``uq2`` the expression ``(++ "uq2: arg = " (show arg))`` is unquoted with ``,``. Observing parsed result with ``-ddump-parsed``: .. literalinclude:: ../include/macros/unquote.console :language: console Parsed Haskell representation shows ``++`` in the expanded form of ``uq1`` macro. Expanded result of ``uq2`` evaluates ``++`` at the time of macro expansion, so the resulting form of ``uq2`` is a literal ``String``. Inside the quasi-quoted form, ``,@`` is used to unquote-splice a list form. The ``,@`` can unquote-splice a quoted list and a Haskell list. .. literalinclude:: ../include/macros/unquote-splice.fnk :language: finkel Observing parsed Haskell code: .. literalinclude:: ../include/macros/unquote-splice.console :language: console Getting Macro Arguments As A List --------------------------------- Macro can take its entire argument as a list form. Below example codes show a macro which takes entire arguments passed to it as a list named ``args``: .. literalinclude:: ../include/macros/arglist.fnk :language: finkel Parsed Haskell code: .. literalinclude:: ../include/macros/arglist.console :language: console Getting Values From Macro Arguments ----------------------------------- One can obtain Haskell values from arguments passed to macro: .. literalinclude:: ../include/macros/fib-macro.fnk :language: finkel The above example applies the ``fromCode`` function to the macro argument to get an ``Int`` value from the code object. To return the code object, the ``fib-macro`` applies ``toCode`` to the ``Int`` value evaluated by the ``fib`` function. Note that the ``fib`` function needs to be defined inside ``eval-when`` so that ``fib-macro`` can use the function during macro expansion. Sample compilation output: .. literalinclude:: ../include/macros/fib-macro.console :language: console Special forms ------------- The Finkel core keywords are implemented as macros made from Finkel kernel. Details of Finkel core keywords are described in the `haddock API documentation `_ of the ``finkel-core`` package. This section explains built-in macros in the Finkel kernel language. These built-in macros are sometimes called *special forms*. All special forms start with ``:``, followed by lower case alphabetic character, to avoid name conflict with existing Haskell functions. :begin ^^^^^^ The ``:begin`` special form is basically for writing a macro returning multiple top-level declarations. Following code shows an example use of ``:begin``, to return type synonym declarations from the ``nat-types`` macro: .. literalinclude:: ../include/macros/begin.fnk :language: finkel Observing parsed Haskell code: .. literalinclude:: ../include/macros/begin.console :language: console :eval-when-compile ^^^^^^^^^^^^^^^^^^ The ``:eval-when-compile`` special form is used to implement ``eval-when`` macro in the core language. Basically, ``(:eval-when-compile BODY1 BODY2 ...)`` is the same as ``(eval-when (compile) BODY1 BODY2 ...)``. The following code shows sample use of ``:eval-when-compile``. The function ``wrap-actions`` is defined inside ``:eval-when-compile``, so that later the compiler can use the function in the ``doactions`` macro. .. literalinclude:: ../include/macros/eval-when-compile.fnk :language: finkel Parsed Haskell code: .. literalinclude:: ../include/macros/eval-when-compile.console :language: console :quote ^^^^^^ The ``:quote`` special form is used for quoting the given value as a code object. The ``'`` is syntax sugar of this special form. Internally, quoted values are passed to functions exported from the ``finkel-kernel`` package. Following code shows how underlying Finkel kernel functions are applied to literal values in source code: .. literalinclude:: ../include/macros/quote.fnk :language: finkel Parsed Haskell source: .. literalinclude:: ../include/macros/quote.console :language: console :quasiquote ^^^^^^^^^^^ The ``:quasiquote`` is the underlying special form for the ````` syntax sugar. Inside a quasi-quoted form, ``:unquote`` and ``:unquote-splice`` could be used for getting the value from the code. Indeed, ``,`` is a syntax sugar of ``:unquote``, and ``,@`` is a syntax sugar of ``:unquote-splice``. .. literalinclude:: ../include/macros/quasiquote.fnk :language: finkel Above example prints ``True``: .. literalinclude:: ../include/macros/quasiquote.console :language: console :require ^^^^^^^^ The ``:require`` is for adding a module to the compiler during macro expansion. It also adds macros defined in the required module to the current compiler environment. This special form is used by the ``defmodule`` macro. .. literalinclude:: ../include/macros/raw-require.fnk :language: finkel Parsed Haskell code: .. literalinclude:: ../include/macros/raw-require.console :language: console :with-macro ^^^^^^^^^^^ The ``:with-macro`` is the underlying special form for ``macrolet`` macro. This special form is perhaps not useful unless one wants to write an alternative implementation of the ``macrolet`` macro. See the source code of ``Finkel.Core`` module for usage. ================================================ FILE: doc/doc.cabal ================================================ cabal-version: 2.0 name: doc version: 0.0.0 synopsis: Internal test for Finkel documentation license: BSD3 license-file: LICENSE author: 8c6794b6 maintainer: 8c6794b6@gmail.com copyright: 2020-2022 8c6794b6 category: Language build-type: Simple description: Internal package to test the codes in the Finkel documentation. flag dynamic description: Dynamically link executables (except Windows) default: True manual: True test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs other-modules: Doc Doc.TestAux Doc.FinkelExecutable Doc.BuildingPackage Doc.Macros Doc.LanguageSyntax build-depends: base >= 4.14 && < 5 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.6 , ghc >= 8.10.0 && < 9.11 , process >= 1.6 && < 1.7 , hspec >= 2.4.8 && < 2.12 , QuickCheck >= 2.10.1 && < 2.16 -- , finkel-core == 0.0.0 , finkel-kernel == 0.0.0 build-tool-depends: finkel:finkel == 0.0.0 , fnkpp:fnkpp == 0.0.0 default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts -- Skipping the whole test under Windows, since it's too slow. if os(windows) buildable: False else if flag(dynamic) ghc-options: -dynamic build-tool-depends: fnkpp:fnkpp == 0.0.0 ghc-options: -F -pgmF fnkpp -optF --no-warn-interp -fplugin Finkel.Core.Plugin if impl (ghc >= 9.6) ghc-options: -keep-hscpp-files source-repository head type: git location: https://github.com/finkel-lang/doc.git subdir: doc ================================================ FILE: doc/include/building-package/my-first-package/Setup.hs ================================================ -- File: my-first-package/Setup.hs import Distribution.Simple (defaultMain) main = defaultMain ================================================ FILE: doc/include/building-package/my-first-package/my-first-package.cabal ================================================ cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack -- -- hash: 5f8c819490edb2e9673637f8df651684d12bbc5294a98b1a63b820025e8792cd name: my-first-package version: 0.1.0.0 build-type: Simple library exposed-modules: MyFirstPackage other-modules: Paths_my_first_package hs-source-dirs: src ghc-options: -F -pgmF fnkpp -optF --no-warn-interp -fplugin Finkel.Core.Plugin build-tool-depends: fnkpp:fnkpp build-depends: base , finkel-core default-language: Haskell2010 ================================================ FILE: doc/include/building-package/my-first-package/package.yaml ================================================ # File: my-first-package/package.yaml name: my-first-package version: 0.1.0.0 library: source-dirs: src exposed-modules: MyFirstPackage ghc-options: - -F -pgmF fnkpp -optF --no-warn-interp - -fplugin Finkel.Core.Plugin build-tools: - fnkpp:fnkpp dependencies: - base - finkel-core ================================================ FILE: doc/include/building-package/my-first-package/src/MyFirstPackage.hs ================================================ ;;;; File: my-first-package/src/MyFirstPackage.hs (defmodule MyFirstPackage (export factorial)) (defn (:: factorial (-> Integer Integer)) "Compute factorial of the given number. This function does not support negative numbers. If the argument was negative, constantly returns @-1@. ==== __Example__ >>> (factorial 10) 3628800 >>> (factorial -42) 1 " [n] (if (<= n 1) 1 (* n (factorial (- n 1))))) ================================================ FILE: doc/include/building-package/my-first-package/stack.git.yaml ================================================ resolver: lts-22.31 packages: - . extra-deps: - git: https://github.com/finkel-lang/finkel commit: f7913be75db03beec66b9a029c538c95cdbb05a8 subdirs: - finkel-kernel - fkc - finkel-setup - finkel-core - finkel-tool - finkel ================================================ FILE: doc/include/building-package/my-first-package/stack.template.yaml ================================================ resolver: lts-22.31 packages: - . ================================================ FILE: doc/include/building-package/my-new-package/LICENSE ================================================ Copyright Author name here (c) 2024 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: doc/include/building-package/my-new-package/README.md ================================================ # my-new-package ================================================ FILE: doc/include/building-package/my-new-package/Setup.hs ================================================ import Distribution.Simple (defaultMain) main = defaultMain ================================================ FILE: doc/include/building-package/my-new-package/app/Main.hs ================================================ module Main where import Lib main :: IO () main = someFunc ================================================ FILE: doc/include/building-package/my-new-package/my-new-package.cabal ================================================ cabal-version: 3.0 name: my-new-package version: 0.1.0.0 -- synopsis: -- description: homepage: http://www.example.org license: BSD-3-Clause license-file: LICENSE author: Author name here maintainer: example@example.com copyright: 2024 Author name here category: Data build-type: Simple extra-source-files: README.md common finkel build-depends: finkel-core build-tool-depends: fnkpp:fnkpp ghc-options: -F -pgmF fnkpp -optF --no-warn-interp -fplugin Finkel.Core.Plugin library import: finkel hs-source-dirs: src exposed-modules: Lib build-depends: base >= 4.7 && < 5 default-language: Haskell2010 executable my-new-package hs-source-dirs: app main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base , my-new-package default-language: Haskell2010 test-suite my-new-package-test import: finkel type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs build-depends: base , my-new-package ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 -- source-repository head -- type: git -- location: https://github.com/githubuser/my-new-package ================================================ FILE: doc/include/building-package/my-new-package/src/Lib.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Lib (export someFunc)) (defn (:: someFunc (IO ())) (putStrLn "Hello from my-new-package")) ================================================ FILE: doc/include/building-package/my-new-package/stack.yaml ================================================ # This file was automatically generated by 'stack init' # # Some commonly used options have been documented as comments in this file. # For advanced use and comprehensive documentation of the format, please see: # https://docs.haskellstack.org/en/stable/yaml_configuration/ # A warning or info to be displayed to the user on config load. user-message: | Warning (added by new or init): Some packages were found to be incompatible with the resolver and have been left commented out in the packages section. You can omit this message by removing it from stack.yaml # Resolver to choose a 'specific' stackage snapshot or a compiler version. # A snapshot resolver dictates the compiler version and the set of packages # to be used for project dependencies. For example: # # resolver: lts-3.5 # resolver: nightly-2015-09-21 # resolver: ghc-7.10.2 # # The location of a snapshot can be provided as a file or url. Stack assumes # a snapshot provided as a file might change, whereas a url resource does not. # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml resolver: lts-22.31 # User packages to be built. # Various formats can be used as shown in the example below. # # packages: # - some-directory # - https://example.com/foo/bar/baz-0.0.2.tar.gz # subdirs: # - auto-update # - wai packages: [] # The following packages have been ignored due to incompatibility with the # resolver compiler, dependency conflicts with other packages # or unsatisfied dependencies. #- . # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: # # extra-deps: # - acme-missiles-0.3 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # # extra-deps: [] # Override default flag values for local packages and extra-deps # flags: {} # Extra package databases containing global packages # extra-package-dbs: [] # Control whether we use the GHC we find on the path # system-ghc: true # # Require a specific version of stack, using version ranges # require-stack-version: -any # Default # require-stack-version: ">=2.3" # # Override the architecture used by stack, especially useful on Windows # arch: i386 # arch: x86_64 # # Extra directories used by stack for building # extra-include-dirs: [/path/to/dir] # extra-lib-dirs: [/path/to/dir] # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor ================================================ FILE: doc/include/building-package/my-new-package/test/Spec.hs ================================================ main :: IO () main = putStrLn "Test suite not yet implemented" ================================================ FILE: doc/include/building-package/my-second-package/LICENSE ================================================ Copyright Author name here (c) 2019 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Author name here nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: doc/include/building-package/my-second-package/README.md ================================================ # my-second-package ================================================ FILE: doc/include/building-package/my-second-package/Setup.hs ================================================ import Distribution.Simple (defaultMain) main = defaultMain ================================================ FILE: doc/include/building-package/my-second-package/app/Main.hs ================================================ module Main where import Lib main :: IO () main = someFunc ================================================ FILE: doc/include/building-package/my-second-package/my-second-package.cabal ================================================ cabal-version: 3.0 name: my-second-package version: 0.1.0.0 -- synopsis: -- description: homepage: http://www.example.org license: BSD-3-Clause license-file: LICENSE author: Author name here maintainer: example@example.com copyright: 2019 Author name here category: Data build-type: Simple extra-source-files: README.md common finkel build-depends: finkel-core build-tool-depends: fnkpp:fnkpp ghc-options: -F -pgmF fnkpp -optF --no-warn-interp -fplugin Finkel.Core.Plugin library import: finkel hs-source-dirs: src exposed-modules: Lib HsCodes FnkCodes build-depends: base >= 4.7 && < 5 default-language: Haskell2010 executable my-second-package hs-source-dirs: app main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base , my-second-package default-language: Haskell2010 test-suite my-second-package-test import: finkel type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs other-modules: FactorialTest build-depends: base , my-second-package build-tool-depends: fnkpp:fnkpp ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 -- source-repository head -- type: git -- location: https://github.com/githubuser/my-second-package ================================================ FILE: doc/include/building-package/my-second-package/src/FnkCodes.hs ================================================ ;;;; File: my-second-package/src/FnkCodes.hs (defmodule FnkCodes (export fnkfactorial)) (defn (:: fnkfactorial (-> Int Int)) [n] (if (<= n 1) n (* n (fnkfactorial (- n 1))))) ================================================ FILE: doc/include/building-package/my-second-package/src/HsCodes.hs ================================================ -- File: my-second-package/src/HsCodes.hs module HsCodes ( hsfactorial , fnkfactorial ) where import FnkCodes hsfactorial :: Int -> Int hsfactorial = fnkfactorial ================================================ FILE: doc/include/building-package/my-second-package/src/Lib.hs ================================================ ;;;; File: my-second-package/src/Lib.hs (defmodule Lib (export someFunc) (import (HsCodes [hsfactorial fnkfactorial]))) (defn (:: someFunc (IO ())) (putStrLn (++ "From `Lib.someFunc':\n" " hsfactorial 10 : " (show (hsfactorial 10)) "\n" " fnkfactorial 10 : " (show (fnkfactorial 10))))) ================================================ FILE: doc/include/building-package/my-second-package/test/FactorialTest.hs ================================================ ;;;; File: FactorialTest.hs (defmodule FactorialTest (export test) (import (HsCodes) (System.Exit (exitFailure)))) (defn (:: test (IO ())) (if (== (fnkfactorial 10) (hsfactorial 10)) (return ()) exitFailure)) ================================================ FILE: doc/include/building-package/my-second-package/test/Spec.hs ================================================ import FactorialTest main :: IO () main = test ================================================ FILE: doc/include/finkel-executable/finkel-help-make.console ================================================ $ finkel help make USAGE: finkel make [command-line-options-and-files] HELP OPTIONS: --fnk-help Show this help and exit. --fnk-languages Show supported language extensions and exit. --fnk-version Show Finkel version and exit. DEBUG OPTIONS: --fnk-verbose=INT Set verbosity level to INT. --fnk-hsdir=DIR Set Haskell code output directory to DIR. --fnk-dump-dflags Dump DynFlags settings. --fnk-dump-expand Dump expanded code. --fnk-dump-hs Dump Haskell source code. --fnk-dump-session Dump session information. --fnk-trace-expand Trace macro expansion. --fnk-trace-session Trace session env. --fnk-trace-make Trace make function. --fnk-trace-spf Trace builtin special forms. Other options are passed to ghc. ================================================ FILE: doc/include/finkel-executable/hello-prof.console ================================================ $ finkel make -o hello -fforce-recomp -prof -fprof-auto hello.fnk [1 of 1] Compiling Main ( hello.hs, hello.o ) Linking hello ... ================================================ FILE: doc/include/finkel-executable/hello.console ================================================ $ finkel make -o hello hello.hs [1 of 1] Compiling Main ( hello.hs, hello.o ) Linking hello ... $ ./hello Hello, World! ================================================ FILE: doc/include/finkel-executable/hello.hs ================================================ ;;;; File: hello.hs (defn main (putStrLn "Hello, World!")) ================================================ FILE: doc/include/finkel-executable/hello904.console ================================================ $ finkel make -o hello hello.hs [1 of 2] Compiling Main ( hello.hs, hello.o ) [2 of 2] Linking hello $ ./hello Hello, World! ================================================ FILE: doc/include/language-syntax/decl/bind-pat.fnk ================================================ (= (Just x) (lookup k vs)) ; Finkel ================================================ FILE: doc/include/language-syntax/decl/bind-pat.hs ================================================ Just x = lookup k vs -- Haskell ================================================ FILE: doc/include/language-syntax/decl/bind-simpl.fnk ================================================ (= f1 x y z (+ x (* y z))) ; Finkel ================================================ FILE: doc/include/language-syntax/decl/bind-simpl.hs ================================================ f1 x y z = x + (y * z) -- Haskell ================================================ FILE: doc/include/language-syntax/decl/bind-where.fnk ================================================ (= f2 n ; Finkel (where body (= body (+ n 1)))) ================================================ FILE: doc/include/language-syntax/decl/bind-where.hs ================================================ f2 n = body -- Haskell where body = n + 1 ================================================ FILE: doc/include/language-syntax/decl/class.fnk ================================================ (class (=> (Ord a) (C1 a)) ; Finkel (:: m1 (-> a Int)) (= m1 _ 0)) ================================================ FILE: doc/include/language-syntax/decl/class.hs ================================================ class Ord a => C1 a where -- Haskell m1 :: a -> Int m1 _ = 0 ================================================ FILE: doc/include/language-syntax/decl/data-d1.fnk ================================================ (data (D1 a b) ; Finkel C1 (C2 a) (C3 b) (deriving Eq Show)) ================================================ FILE: doc/include/language-syntax/decl/data-d1.hs ================================================ data D1 a b -- Haskell = C1 | C2 a | C3 b deriving (Eq, Show) ================================================ FILE: doc/include/language-syntax/decl/data-d2.fnk ================================================ (data (D2 a b) ; Finkel (D2 {(:: f1 a) (:: f2 b) (:: f3 Int)})) ================================================ FILE: doc/include/language-syntax/decl/data-d2.hs ================================================ data D2 a b -- Haskell = D2 { f1 :: a , f2 :: b , f3 :: Int } ================================================ FILE: doc/include/language-syntax/decl/default.fnk ================================================ (default Int Double) ; Finkel ================================================ FILE: doc/include/language-syntax/decl/default.hs ================================================ default (Int, Double) -- Haskell ================================================ FILE: doc/include/language-syntax/decl/fixity.fnk ================================================ (infixr 6 $+$) ================================================ FILE: doc/include/language-syntax/decl/fixity.hs ================================================ infixr 6 $+$ ================================================ FILE: doc/include/language-syntax/decl/instance.fnk ================================================ (instance (C1 Int) ; Finkel (= m1 n (+ n 1))) ================================================ FILE: doc/include/language-syntax/decl/instance.hs ================================================ instance C1 Int where -- Haskell m1 n = n + 1 ================================================ FILE: doc/include/language-syntax/decl/newtype.fnk ================================================ (newtype N (N {(:: unN Int)})) ; Finkel ================================================ FILE: doc/include/language-syntax/decl/newtype.hs ================================================ newtype N = N {unN :: Int} -- Haskell ================================================ FILE: doc/include/language-syntax/decl/tysig-constraints.fnk ================================================ (:: f (=> (Eq a) (Ord a) (Show a) (Num a) (-> a a))) ; Finkel ================================================ FILE: doc/include/language-syntax/decl/tysig-constraints.hs ================================================ f :: (Eq a, Ord a, Show a, Num a) => a -> a -- Haskell ================================================ FILE: doc/include/language-syntax/decl/tysig-many.fnk ================================================ (:: f g h (-> Int Int)) ; Finkel ================================================ FILE: doc/include/language-syntax/decl/tysig-many.hs ================================================ f, g, h :: Int -> Int -- Haskell ================================================ FILE: doc/include/language-syntax/decl/tysig-one.fnk ================================================ (:: f (-> Int Int Int)) ; Finkel ================================================ FILE: doc/include/language-syntax/decl/tysig-one.hs ================================================ f :: Int -> Int -> Int -- Haskell ================================================ FILE: doc/include/language-syntax/decl/tysym.fnk ================================================ (type (T1 a) (Maybe (, a Bool String))) ; Finkel ================================================ FILE: doc/include/language-syntax/decl/tysym.hs ================================================ type T1 a = Maybe (a, Bool, String) -- Haskell ================================================ FILE: doc/include/language-syntax/expr/block-comment.fnk ================================================ (putStrLn {- Finkel block comment -} "bar") ================================================ FILE: doc/include/language-syntax/expr/block-comment.hs ================================================ putStrLn {- Haskell block comment -} "bar" ================================================ FILE: doc/include/language-syntax/expr/case.fnk ================================================ (case n ; Finkel 0 "zero" 1 "one" _ "many") ================================================ FILE: doc/include/language-syntax/expr/case.hs ================================================ case n of -- Haskell 0 -> "zero" 1 -> "one" _ -> "many" ================================================ FILE: doc/include/language-syntax/expr/char-a.fnk ================================================ (putChar #'a) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/char-a.hs ================================================ putChar 'a' -- Haskell ================================================ FILE: doc/include/language-syntax/expr/char-escape.fnk ================================================ (print [#'\ #'']) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/char-escape.hs ================================================ print ['\\', '\''] -- Haskell ================================================ FILE: doc/include/language-syntax/expr/char-ncode.fnk ================================================ (print [#'\97 #'\o141 #'\x61]) ; Finkel, prints "aaa" ================================================ FILE: doc/include/language-syntax/expr/char-ncode.hs ================================================ print ['\97', '\o141', '\x61'] -- Haskell, prints "aaa" ================================================ FILE: doc/include/language-syntax/expr/char-special.fnk ================================================ (print [#'\n #' #'\NUL #'\^L]) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/char-special.hs ================================================ print ['\n', ' ', '\NUL', '\^L'] -- Haskell ================================================ FILE: doc/include/language-syntax/expr/discard-prefix.fnk ================================================ (do (print True) ; Finkel %_(this list (is ignored)) (print %_ignored False %_ "ignored")) ================================================ FILE: doc/include/language-syntax/expr/discard-prefix.hs ================================================ do print True -- Haskell, ignored forms removed print False ================================================ FILE: doc/include/language-syntax/expr/do.fnk ================================================ (do (putStr "x: ") ; Finkel (<- l getLine) (return (words l))) ================================================ FILE: doc/include/language-syntax/expr/do.hs ================================================ do putStr "x: " -- Haskell l <- getLine return (words l) ================================================ FILE: doc/include/language-syntax/expr/fieldlabels.fnk ================================================ (Constr1 {(= field1 1) (= field2 True) (= field3 "abc")}) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/fieldlabels.hs ================================================ Constr1 {field1=1, field2=True, field3="abc"} -- Haskell ================================================ FILE: doc/include/language-syntax/expr/funapp-pars.fnk ================================================ (((((putStrLn)) "hello"))) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/funapp-pars.hs ================================================ putStrLn "hello" -- Haskell, redundant parentheses removed ================================================ FILE: doc/include/language-syntax/expr/funapp.fnk ================================================ (putStrLn "hello") ; Finkel ================================================ FILE: doc/include/language-syntax/expr/funapp.hs ================================================ putStrLn "hello" -- Haskell ================================================ FILE: doc/include/language-syntax/expr/guard.fnk ================================================ (case expr ; Finkel (Just y) (| ((even y) r1) ((odd y) (< y 10) r2) ((<- (Just z) (lookup y kvs)) (let ((= z' (* z 2)))) (r3 z')) (otherwise r4))) ================================================ FILE: doc/include/language-syntax/expr/guard.hs ================================================ case expr of -- Haskell Just y | even y -> r1 | odd y, y < 10 -> r2 | Just z <- lookup y kvs , let z' = z * 2 -> r3 z' | otherwise -> r4 ================================================ FILE: doc/include/language-syntax/expr/if.fnk ================================================ (if test true-expr false-expr) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/if.hs ================================================ if test then true_expr else false_expr -- Haskell ================================================ FILE: doc/include/language-syntax/expr/lambda.fnk ================================================ (zipWith (\x y (* x (+ y 1))) [1 2 3] [4 5 6]) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/lambda.hs ================================================ zipWith (\x y -> x * (y + 1)) [1, 2, 3] [4, 5, 6] -- Haskell ================================================ FILE: doc/include/language-syntax/expr/let.fnk ================================================ (let ((:: a Int) ; Finkel (:: b c Int) (= a 10) (= b 4) (= c 2)) (print [a b c])) ================================================ FILE: doc/include/language-syntax/expr/let.hs ================================================ let a :: Int -- Haskell b, c :: Int a = 10 b = 4 c = 2 in print [a, b, c] ================================================ FILE: doc/include/language-syntax/expr/line-comment.fnk ================================================ (putStrLn "foo") ; single-line comment in Finkel ================================================ FILE: doc/include/language-syntax/expr/line-comment.hs ================================================ putStrLn "foo" -- single-line comment in Haskell ================================================ FILE: doc/include/language-syntax/expr/list-comp.fnk ================================================ [x | (<- x [1 .. 10]) (even x)] ; Finkel ================================================ FILE: doc/include/language-syntax/expr/list-comp.hs ================================================ [x | x <- [1 .. 10], even x] -- Haskell ================================================ FILE: doc/include/language-syntax/expr/list-const.fnk ================================================ (print [1 2 3]) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/list-const.hs ================================================ print [1, 2, 3] -- Haskell ================================================ FILE: doc/include/language-syntax/expr/list-range.fnk ================================================ (print [1 3 .. 9]) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/list-range.hs ================================================ print [1, 3 .. 9] -- Haskell ================================================ FILE: doc/include/language-syntax/expr/map-mul2.fnk ================================================ (map (* 2) [1 2 3]) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/map-mul2.hs ================================================ map ((*) 2) [1, 2, 3] -- Haskell ================================================ FILE: doc/include/language-syntax/expr/map-unary.fnk ================================================ (map (- 1) [1 2 3]) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/map-unary.hs ================================================ map ((-) 1) [1, 2, 3] -- Haskell ================================================ FILE: doc/include/language-syntax/expr/muladd.fnk ================================================ ((*+) 2 3 4) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/muladd.hs ================================================ (*+) 2 3 4 -- Haskell ================================================ FILE: doc/include/language-syntax/expr/numeric.fnk ================================================ (do (print 1) ; decimal integer in Finkel (print 0o77) ; octal integer (print 0xff) ; hexadecimal integer (print 2.34) ; float (print 1e-2)) ; float with exponent ================================================ FILE: doc/include/language-syntax/expr/numeric.hs ================================================ do print 1 -- decimal integer in Haskell print 0o77 -- octal integer print 0xff -- hexadecimal integer print 2.34 -- float print 1e-2 -- float with exponent ================================================ FILE: doc/include/language-syntax/expr/opexp-add.fnk ================================================ (+ 1 2 3 4 5) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/opexp-add.hs ================================================ 1 + 2 + 3 + 4 + 5 -- Haskell ================================================ FILE: doc/include/language-syntax/expr/opexp-app.fnk ================================================ (<*> (pure foldr) (Just +) (pure 1) (pure [2 3])) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/opexp-app.hs ================================================ pure foldr <*> Just (+) <*> pure 1 <*> pure [2, 3] -- Haskell ================================================ FILE: doc/include/language-syntax/expr/pat-as.fnk ================================================ (let ((= (@ x (Just n)) expr)) ; Finkel (+ n 1)) ================================================ FILE: doc/include/language-syntax/expr/pat-as.hs ================================================ let x@(Just n) = expr -- Haskell in n + 1 ================================================ FILE: doc/include/language-syntax/expr/pat-irf.fnk ================================================ (let ((= ~(, a ~(, b c)) expr)) ; Finkel (+ a (* b c))) ================================================ FILE: doc/include/language-syntax/expr/pat-irf.hs ================================================ let ~(a, ~(b, c)) = expr -- Haskell in a + (b * c) ================================================ FILE: doc/include/language-syntax/expr/pat-maybe.fnk ================================================ (case expr ; Finkel (Just x) (+ x 1) Nothing 0) ================================================ FILE: doc/include/language-syntax/expr/pat-maybe.hs ================================================ case expr of -- Haskell Just x -> x + 1 Nothing -> 0 ================================================ FILE: doc/include/language-syntax/expr/pat-opexp.fnk ================================================ (case expr ; Finkel (: a1 a2 _) (+ a1 a2) _ 0) ================================================ FILE: doc/include/language-syntax/expr/pat-opexp.hs ================================================ case expr of -- Haskell a1 : a2 : _ -> a1 + a2 _ -> 0 ================================================ FILE: doc/include/language-syntax/expr/sige.fnk ================================================ (:: 42 Int) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/sige.hs ================================================ (42 :: Int) -- Haskell ================================================ FILE: doc/include/language-syntax/expr/string.fnk ================================================ "Here is a backslant \\ as well as \137, \ \a numeric escape character, and \^X, a control character." ; Finkel ================================================ FILE: doc/include/language-syntax/expr/string.hs ================================================ "Here is a backslant \\ as well as \137, \ \a numeric escape character, and \^X, a control character." -- Haskell ================================================ FILE: doc/include/language-syntax/expr/tup2.fnk ================================================ (print (, True #'x)) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/tup2.hs ================================================ print (True, 'x') -- Haskell ================================================ FILE: doc/include/language-syntax/expr/tup5.fnk ================================================ (print (, True #'x 42 1.23 "foo")) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/tup5.hs ================================================ print (True, 'x', 42, 1.23, "foo") -- Haskell ================================================ FILE: doc/include/language-syntax/expr/tupfn.fnk ================================================ (<*> (pure (,,,)) (Just 1) (Just 2) (Just 3) (Just 4)) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/tupfn.hs ================================================ pure (,,,) <*> Just 1 <*> Just 2 <*> Just 3 <*> Just 4 -- Haskell ================================================ FILE: doc/include/language-syntax/expr/unit.fnk ================================================ (return ()) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/unit.hs ================================================ return () -- Haskell ================================================ FILE: doc/include/language-syntax/expr/varid.fnk ================================================ (foo-bar-buzz quux) ; Finkel ================================================ FILE: doc/include/language-syntax/expr/varid.hs ================================================ foo_bar_buzz quux -- Haskell ================================================ FILE: doc/include/language-syntax/ffi/export.fnk ================================================ (foreign export ccall "addInt" (:: + (-> Int Int Int))) ================================================ FILE: doc/include/language-syntax/ffi/export.hs ================================================ foreign export ccall "addInt" (+) :: Int -> Int -> Int ================================================ FILE: doc/include/language-syntax/ffi/import.fnk ================================================ (foreign import ccall safe "string.h strlen" ; Finkel (:: cstrlen (-> (Ptr CChar) (IO CSize)))) ================================================ FILE: doc/include/language-syntax/ffi/import.hs ================================================ foreign import ccall safe "string.h strlen" -- Haskell cstrlen :: Ptr CChar -> IO CSize ================================================ FILE: doc/include/language-syntax/import/altogether.fnk ================================================ (import qualified Data.Maybe as Mb hiding (fromJust)) ; Finkel ================================================ FILE: doc/include/language-syntax/import/altogether.hs ================================================ import qualified Data.Maybe as Mb hiding (fromJust) -- Haskell ================================================ FILE: doc/include/language-syntax/import/entity-list.fnk ================================================ (import Data.Maybe (catMaybes fromMaybe)) ; Finkel ================================================ FILE: doc/include/language-syntax/import/entity-list.hs ================================================ import Data.Maybe (catMaybes, fromMaybe) -- Haskell ================================================ FILE: doc/include/language-syntax/import/hiding.fnk ================================================ (import Data.Maybe hiding (fromJust fromMaybe)) ; Finkel ================================================ FILE: doc/include/language-syntax/import/hiding.hs ================================================ import Data.Maybe hiding (fromJust, fromMaybe) -- Haskell ================================================ FILE: doc/include/language-syntax/import/qualified-as.fnk ================================================ (import qualified Data.Maybe as Mb) ; Finkel ================================================ FILE: doc/include/language-syntax/import/qualified-as.hs ================================================ import qualified Data.Maybe as Mb -- Haskell ================================================ FILE: doc/include/language-syntax/import/simpl.fnk ================================================ (import Data.Maybe) ; Finkel ================================================ FILE: doc/include/language-syntax/import/simpl.hs ================================================ import Data.Maybe -- Haskell ================================================ FILE: doc/include/language-syntax/module/export-list.fnk ================================================ (module M2 ; Finkel f1 ; Value, field name, or class method T1 ; Type constructor only (T2 ..) ; Type constructor and all of its data constructors (T3 T3a T3b) ; Type constructor and specified data constructors (T4 t4f1) ; Type constructor and field label (module Data.Char) ; Module reexport (Mb.Maybe Just Nothing) ; Reexport with a qualified name ) (import Data.Maybe as Mb) ;; ... more module contents ... ================================================ FILE: doc/include/language-syntax/module/export-list.hs ================================================ module M2 -- Haskell ( f1 -- Value, field name, or class method , T1 -- Type constructor only , T2(..) -- Type constructor and all of its data constructors , T3(T3a, T3b) -- Type constructor and specified data constructors , T4(t4f1) -- Type constructor and field label , module Data.Char -- Module reexport , Mb.Maybe(Just, Nothing) -- Reexport with a qualified name ) where import Data.Maybe as Mb -- ... more module contents ... ================================================ FILE: doc/include/language-syntax/module/simpl.fnk ================================================ (module M1) ; Finkel (= x 1) (= y 2) ================================================ FILE: doc/include/language-syntax/module/simpl.hs ================================================ module M1 where -- Haskell x = 1 y = 2 ================================================ FILE: doc/include/macros/RequireMe.fnk ================================================ ;;;; File: RequireMe.fnk (defmodule RequireMe (export say-hello say-bye) (import (Finkel.Prelude))) (defmacro say-hello [] '(putStrLn "Hello macro!")) (defmacro say-bye [] '(putStrLn "Goodbye.")) ================================================ FILE: doc/include/macros/arglist.console ================================================ $ finkel make -fno-code -ddump-parsed arglist.fnk ==================== Parser ==================== module Main where main :: IO () main = putStrLn (unwords ["foo", "bar", "buzz"]) [1 of 1] Compiling Main ( arglist.fnk, nothing ) ================================================ FILE: doc/include/macros/arglist.fnk ================================================ ;;;; File: arglist.fnk (defmodule Main (import-when [:compile] (Finkel.Prelude))) (eval-when [:compile] (defmacro puts args `(putStrLn (unwords [,@args])))) (defn (:: main (IO ())) (puts "foo" "bar" "buzz")) ================================================ FILE: doc/include/macros/begin.console ================================================ $ finkel make -fno-code -ddump-parsed begin.fnk ==================== Parser ==================== module Main where import Data.Proxy data Nat = Zero | Succ Nat type N0 = 'Zero type N1 = 'Succ 'Zero type N2 = 'Succ ('Succ 'Zero) type N3 = 'Succ ('Succ ('Succ 'Zero)) type N4 = 'Succ ('Succ ('Succ ('Succ 'Zero))) type N5 = 'Succ ('Succ ('Succ ('Succ ('Succ 'Zero)))) type N6 = 'Succ ('Succ ('Succ ('Succ ('Succ ('Succ 'Zero))))) main :: IO () main = print (Proxy :: Proxy N6) [1 of 1] Compiling Main ( begin.fnk, nothing ) ================================================ FILE: doc/include/macros/begin.fnk ================================================ ;;;; File: begin.fnk %p(LANGUAGE DataKinds) (defmodule Main (import-when [:compile] (Finkel.Prelude)) (import (Data.Proxy))) (data Nat Zero (Succ Nat)) (macrolet ((nat-types [n] (let ((:: go (-> Int Code Int [Code])) (= go stop body i (if (< stop i) [] (let ((= name (make-symbol (++ "N" (show i)))) (= next `('Succ ,body))) (: `(type ,name ,body) (go stop next (+ i 1))))))) (case (fromCode n) (Just m) `(:begin ,@(go m ''Zero 0)) Nothing (error "not an integer"))))) (nat-types 6)) (defn (:: main (IO ())) (print (:: Proxy (Proxy N6)))) ================================================ FILE: doc/include/macros/eval-when-compile.console ================================================ $ finkel make -fno-code -ddump-parsed eval-when-compile.fnk ==================== Parser ==================== module Main where foo :: Int -> IO () foo n = do putStrLn "from foo" print (n + 1) bar :: Int -> Int -> IO () bar a b = do putStrLn "from bar" print (a + (b * 2)) main :: IO () main = do foo 41 bar 10 16 [1 of 1] Compiling Main ( eval-when-compile.fnk, nothing ) ================================================ FILE: doc/include/macros/eval-when-compile.fnk ================================================ ;;;; File: eval-when-compile.fnk (defmodule Main (import-when [:compile] (Finkel.Prelude))) (:eval-when-compile (defn (:: wrap-actions (-> [Code] Code)) [actions] `(do ,@actions))) (macrolet ((doactions [xs] (case (unCode xs) (HsList actions) (wrap-actions actions) _ (error "doactions: expecting HsList")))) (defn (:: foo (-> Int (IO ()))) [n] (doactions [(putStrLn "from foo") (print (+ n 1))])) (defn (:: bar (-> Int Int (IO ()))) [a b] (doactions [(putStrLn "from bar") (print (+ a (* b 2)))]))) (defn (:: main (IO ())) (do (foo 41) (bar 10 16))) ================================================ FILE: doc/include/macros/eval-when.console ================================================ $ finkel make -fno-code -ddump-parsed eval-when.fnk ==================== Parser ==================== module Main where main :: IO () main = do putStrLn ";;; eval-when ;;;" putStrLn "Hello macro!" putStrLn "Goodbye." [1 of 1] Compiling Main ( eval-when.fnk, nothing ) ================================================ FILE: doc/include/macros/eval-when.fnk ================================================ ;;; File: eval-when.fnk (defmodule Main (import-when [:compile] (Finkel.Prelude))) (eval-when [:compile] (defmacro say-hello [] '(putStrLn "Hello macro!")) (defmacro say-bye [] '(putStrLn "Goodbye."))) (defn (:: main (IO ())) (do (putStrLn ";;; eval-when ;;;") (say-hello) (say-bye))) ================================================ FILE: doc/include/macros/fib-macro.console ================================================ $ finkel make -fno-code -ddump-parsed fib-macro.fnk ==================== Parser ==================== module Main where main :: IO () main = print 55 [1 of 1] Compiling Main ( fib-macro.fnk, nothing ) ================================================ FILE: doc/include/macros/fib-macro.fnk ================================================ ;;;; File: fib-macro.fnk (defmodule Main (import-when [:compile] (Finkel.Prelude))) (eval-when [:compile] (defn (:: fib (-> Int Int)) [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (defmacro fib-macro [n] (case (fromCode n) (Just i) (toCode (fib i)) Nothing (error "fib-macro: not an integer literal")))) (defn (:: main (IO ())) (print (fib-macro 10))) ================================================ FILE: doc/include/macros/macrolet.console ================================================ $ finkel make -fno-code -ddump-parsed macrolet.fnk ==================== Parser ==================== module Main where main :: IO () main = do putStrLn ";;; macrolet ;;;" putStrLn "Hello macro!" putStrLn "Goodbye." [1 of 1] Compiling Main ( macrolet.fnk, nothing ) ================================================ FILE: doc/include/macros/macrolet.fnk ================================================ ;;;; File: macrolet.fnk (defmodule Main (import-when [:compile] (Finkel.Prelude))) (macrolet ((say-hello [] '(putStrLn "Hello macro!")) (say-bye [] '(putStrLn "Goodbye."))) (defn (:: main (IO ())) (do (putStrLn ";;; macrolet ;;;") (say-hello) (say-bye)))) ================================================ FILE: doc/include/macros/quasiquote.console ================================================ $ finkel make -o quasiquote quasiquote.fnk [1 of 1] Compiling Main ( quasiquote.fnk, quasiquote.o ) Linking quasiquote ... $ ./quasiquote True ================================================ FILE: doc/include/macros/quasiquote.fnk ================================================ ;;;; File: quasiquote.fnk (defmodule Main (import (Finkel.Prelude))) (defn (:: with-sugar [Code]) [`(foo ,(length "123") bar) `(foo ,@[True False] bar)]) (defn (:: without-sugar [Code]) [(:quasiquote (foo (:unquote (length "123")) bar)) (:quasiquote (foo (:unquote-splice [True False]) bar))]) (defn (:: main (IO ())) (print (== with-sugar without-sugar))) ================================================ FILE: doc/include/macros/quasiquote904.console ================================================ $ finkel make -o quasiquote quasiquote.fnk [1 of 2] Compiling Main ( quasiquote.fnk, quasiquote.o ) [2 of 2] Linking quasiquote $ ./quasiquote True ================================================ FILE: doc/include/macros/quote.console ================================================ $ finkel make -fno-code -ddump-parsed quote.fnk ==================== Parser ==================== module Main where import Finkel.Prelude main :: IO () main = do putStrLn ";;; quote ;;;" print (qSymbol "foo" "quote.fnk" 8 15 8 18) print (qSymbol "foo" "quote.fnk" 9 22 9 25) print (qInteger 42 "quote.fnk" 10 15 10 17) print (qInteger 42 "quote.fnk" 11 22 11 24) print (qString "string" "quote.fnk" 12 15 12 23) print (qString "string" "quote.fnk" 13 22 13 30) [1 of 1] Compiling Main ( quote.fnk, nothing ) ================================================ FILE: doc/include/macros/quote.fnk ================================================ ;;;; File: quote.fnk (defmodule Main (import (Finkel.Prelude))) (defn (:: main (IO ())) (do (putStrLn ";;; quote ;;;") (print 'foo) (print (:quote foo)) (print '42) (print (:quote 42)) (print '"string") (print (:quote "string")))) ================================================ FILE: doc/include/macros/raw-require.console ================================================ $ finkel make -fno-code -ddump-parsed raw-require.fnk ==================== Parser ==================== module Main where main :: IO () main = do putStrLn ";;; raw-require.fnk ;;;" putStrLn "Hello macro!" putStrLn "Goodbye." [1 of 1] Compiling Main ( raw-require.fnk, nothing ) ================================================ FILE: doc/include/macros/raw-require.fnk ================================================ ;;;; File: raw-require.fnk (:require Finkel.Prelude) (defmodule Main) (eval-when [:compile] (defmacro say-hello [] '(putStrLn "Hello macro!")) (defmacro say-bye [] '(putStrLn "Goodbye."))) (defn (:: main (IO ())) (do (putStrLn ";;; raw-require.fnk ;;;") (say-hello) (say-bye))) ================================================ FILE: doc/include/macros/require.console ================================================ $ finkel make -no-link -fno-code require.fnk (*) [1 of 1] Compiling RequireMe ( RequireMe.fnk, interpreted ) ==================== Parser ==================== module Main where main :: IO () main = do putStrLn ";;; require ;;;" putStrLn "Hello macro!" putStrLn "Goodbye." [1 of 1] Compiling Main ( require.fnk, nothing ) ================================================ FILE: doc/include/macros/require.fnk ================================================ ;;;; File: require.fnk %p(OPTIONS_GHC -ddump-parsed) (defmodule Main (require (RequireMe (say-hello say-bye)))) (defn (:: main (IO ())) (do (putStrLn ";;; require ;;;") (say-hello) (say-bye))) ================================================ FILE: doc/include/macros/unquote-splice.console ================================================ $ finkel make -fno-code -ddump-parsed unquote-splice.fnk ==================== Parser ==================== module Main where main :: IO () main = do putStrLn (concat ["foo", "bar", "buzz"]) putStrLn (concat ["foo", "bar", "buzz"]) [1 of 1] Compiling Main ( unquote-splice.fnk, nothing ) ================================================ FILE: doc/include/macros/unquote-splice.fnk ================================================ ;;;; File: unquote-splice.fnk (defmodule Main (import-when [:compile] (Finkel.Prelude))) (eval-when [:compile] (defmacro uqs [arg] `(putStrLn (concat [,@arg])))) (defn (:: main (IO ())) (do (uqs ("foo" "bar" "buzz")) (uqs ["foo" "bar" "buzz"]))) ================================================ FILE: doc/include/macros/unquote.console ================================================ $ finkel make -fno-code -ddump-parsed unquote.fnk ==================== Parser ==================== module Main where main :: IO () main = do putStrLn ("uq1: arg = " ++ show "foo") putStrLn "uq2: arg = \"bar\"" [1 of 1] Compiling Main ( unquote.fnk, nothing ) ================================================ FILE: doc/include/macros/unquote.fnk ================================================ ;;;; File: unquote.fnk (defmodule Main (import-when [:compile] (Finkel.Prelude))) (eval-when [:compile] (defmacro uq1 [arg] `(putStrLn (++ "uq1: arg = " (show ,arg)))) (defmacro uq2 [arg] `(putStrLn ,(++ "uq2: arg = " (show arg))))) (defn (:: main (IO ())) (do (uq1 "foo") (uq2 "bar"))) ================================================ FILE: doc/index.rst ================================================ The Finkel Documentation ======================== Introduction ------------ Finkel is a statically typed, purely functional, and non-strict-by-default `LISP `_ flavored programming language. Or in other words, `Haskell `_ **in S-expression**. [#f1]_ Finkel has the following features: * Integration with existing Haskell modules. * Building Haskell-compatible `Cabal `_ packages. * Documentation generation with `Haddock `_. * Lisp style macro system. * Tool executable, including interactive REPL. .. And following anti-features: * CPP language extension The capital lettered term Finkel is used to refer to the programming language itself, and the quoted ``finkel`` is used to refer an executable program to work with the language. This documentation briefly introduces the ``finkel`` executable and the language, just enough to get started. Readers of this documentation are assumed to have some basic knowledge of the Unix-like environment and have some programming experiences with Haskell. .. toctree:: :maxdepth: 2 :caption: Contents: contents/install.rst contents/finkel-executable.rst contents/building-package.rst contents/macros.rst contents/language-syntax.rst .. ================== Indices and tables ================== * :ref:`genindex` * :ref:`search` .. rubric:: Footnotes .. [#f1] More precisely, `GHC `_ in S-expression. ================================================ FILE: doc/make.bat ================================================ @ECHO OFF pushd %~dp0 REM Command file for Sphinx documentation if "%SPHINXBUILD%" == "" ( set SPHINXBUILD=sphinx-build ) set SOURCEDIR=. set BUILDDIR=_build if "%1" == "" goto help %SPHINXBUILD% >NUL 2>NUL if errorlevel 9009 ( echo. echo.The 'sphinx-build' command was not found. Make sure you have Sphinx echo.installed, then set the SPHINXBUILD environment variable to point echo.to the full path of the 'sphinx-build' executable. Alternatively you echo.may add the Sphinx directory to PATH. echo. echo.If you don't have Sphinx installed, grab it from echo.http://sphinx-doc.org/ exit /b 1 ) %SPHINXBUILD% -M %1 %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% goto end :help %SPHINXBUILD% -M help %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% :end popd ================================================ FILE: doc/requirements.txt ================================================ sphinx==3.5.3 sphinx_rtd_theme==0.5.2 ================================================ FILE: doc/test/Doc/BuildingPackage.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Test codes for "building-package.rst". (defmodule Doc.BuildingPackage (export spec) (import ;; base (Control.Exception [bracket]) (Control.Monad [zipWithM_]) (Data.Char (isSpace)) (Data.Function [on]) (Data.List [isPrefixOf sort]) (System.Exit [(ExitCode ..)]) (System.Process [(CreateProcess ..) createProcess proc waitForProcess]) ;; directory (System.Directory [canonicalizePath doesDirectoryExist doesFileExist getTemporaryDirectory listDirectory removeDirectoryRecursive]) ;; filepath (System.FilePath [ takeExtension takeFileName]) ;; hspec (Test.Hspec [(Spec) describe expectationFailure it pendingWith shouldBe]) ;; Internal (Doc.TestAux))) ;;; Spec (defn (:: spec Spec) (describe "building cabal package" (it "matches package made with hsfiles template" (case-do get-build-tool Cabal (pendingWith "not running with cabal-install") Raw (pendingWith "not running with raw build") Stack compare-new-package)))) ;;; Auxiliary (defn (:: compare-new-package (IO ())) (bracket make-tmp-dir remove-tmp-dir compare-package-dirs)) (defn (:: make-tmp-dir (IO (, FilePath String))) (fmap (flip (,) "my-new-package") getTemporaryDirectory)) (defn (:: remove-tmp-dir (-> (, FilePath String) (IO ()))) (. removeDirectoryRecursive (uncurry ))) (defn (:: compare-package-dirs (-> (, FilePath String) (IO ()))) [(, tmpdir pkgname)] (case-do (stack-new tmpdir pkgname) ;; Ignoring "stack.yaml", since the file contains version number of the ;; stack executable, which may change when the stack was upgraded. ;; ;; XXX: This approach will make the tests to pass. However, cannot detect ;; the validity of stack.yaml file, so consider taking different way to pass ;; the test. (Right ExitSuccess) (compare-directory-contents ["stack.yaml"] ( "include" "building-package" pkgname) ( tmpdir pkgname)) (Right ec) (expectationFailure (++ "stack new failed with " (show ec))) (Left msg) (expectationFailure msg))) (defn (:: compare-directory-contents (-> [FilePath] FilePath FilePath (IO ()))) "Recursively compare directory contents." [ignored path1 path2] (if (elem (takeFileName path1) ignored) (return ()) (do (<- path1-is-file (doesFileExist path1)) (<- path2-is-file (doesFileExist path2)) (if (&& path1-is-file path2-is-file (notElem (takeFileName path1) ignored)) (do (<- contents1 (readFile path1)) (<- contents2 (readFile path2)) (on shouldBe trim contents1 contents2)) (do (<- path1-is-dir (doesDirectoryExist path1)) (<- path2-is-dir (doesDirectoryExist path2)) (if (&& path1-is-dir path2-is-dir) (do (<- ls1 (list-directory path1)) (<- ls2 (list-directory path2)) (lept [add-dir (. map ) ls1' (add-dir path1 ls1) ls2' (add-dir path2 ls2)]) (zipWithM- (compare-directory-contents ignored) ls1' ls2')) (expectationFailure (++ "differed: " path1 ", " path2)))))))) (defn (:: trim (-> String String)) "Trim white spaces at the beginning and end." (. (dropWhile isSpace) reverse (dropWhile isSpace) reverse)) (defn (:: list-directory (-> FilePath (IO [FilePath]))) "List directory contents, filter outs some ignored files." (lefn [(ignored [path] (&& (/= ".stack-work" path) (/= ".tix" (takeExtension path))))] (. (fmap (. sort (filter ignored))) listDirectory))) (defn (:: stack-new (-> FilePath String (IO (Either String ExitCode)))) "Run stack new command to generate new package." [dir pkgname] (do (<- template get-template-path) (<- mb-resolver (get-resolver-version pkgname)) (case mb-resolver (Just resolver) (fmap Right (run (Just dir) "stack" ["--resolver" resolver "--silent" "new" pkgname "--omit-packages" template])) Nothing (return (Left "Failed to get the resolver version"))))) (defn (:: get-template-path (IO FilePath)) "Get canonicalized template path." ;; XXX: May move template to separate repository to support ;; `github:finkel-lang/simple' style template argument. ;; ;; See: https://docs.haskellstack.org/en/stable/GUIDE/#templates ;; (canonicalizePath ( ".." "finkel-tool" "finkel.hsfiles"))) (defn (:: get-resolver-version (-> String (IO (Maybe String)))) "Get stack resolver version from YAML file used in `my-new-package'." [pkgname] (lept [yaml-path ( "include" "building-package" pkgname "stack.yaml") resolver-line (. (concatMap words) (filter (isPrefixOf "resolver:")) lines)] (case-do (fmap resolver-line (readFile yaml-path)) [_ version] (return (Just version)) _ (return Nothing)))) (defn (:: run (-> (Maybe String) String [String] (IO ExitCode))) "Run command and wait." [mb-dir cmd args] (do (<- (, _mbin _mbout _mberr ph) (createProcess ((proc cmd args) {(= cwd mb-dir)}))) (waitForProcess ph))) ================================================ FILE: doc/test/Doc/FinkelExecutable.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Test codes for "finkel-executable.rst". (defmodule Doc.FinkelExecutable (export spec) (import ;; base (Data.Version [makeVersion]) (System.Info [os]) ;; filepath (System.FilePath []) ;; hspc (Test.Hspec [(Spec) before_ describe]) ;; Internal (Doc.TestAux))) (defn (:: spec Spec) (lept [dir ( "include" "finkel-executable") const2 (\ x _ _ x) is-osx (== os "darwin") is-win (== os "mingw32") ghc904 (makeVersion [9 4 0]) skips [(, "finkel-help-make.console" (const2 is-win)) (, "hello.console" (\version _ (|| is-osx is-win (< ghc904 version)))) (, "hello904.console" (\version _ (|| is-osx is-win (< version ghc904)))) (, "hello-prof.console" (\ version _build-tool ;; XXX: Always skipping (|| is-win ;; Skipping in ghc >= 9.0 ... (<= (makeVersion [9 0]) version))))]] (before_ (remove-compiled [( dir "hello")]) (describe "using the finkel executable" (run-console-tests dir skips))))) ================================================ FILE: doc/test/Doc/LanguageSyntax.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Test codes for "language-syntax.rst" ;;; This module contains codes to tests the code snippets shown in the "Language ;;; Syntax" chapter of the documentation. The tests parses expressions and ;;; declarations from file, and parse the Haskell code and Finkel code, then ;;; compare the parsed results with `showPpr'. (defmodule Doc.LanguageSyntax (export spec) (import-when [:compile] ;; finkel-lang (Finkel.Prelude)) (import ;; base (Data.List [sort]) ;; directory (System.Directory [listDirectory]) ;; filepath (System.FilePath [ <.> dropExtension takeExtension]) ;; finkel-kernel (Language.Finkel.Builder [(Builder) evalBuilder]) (Language.Finkel.Reader [parseSexprs]) (qualified Language.Finkel.Syntax as FnkParser) ;; hspec (Test.Hspec [(Spec) (SpecWith) beforeAll describe expectationFailure it runIO shouldBe]) ;; Internal (Doc.TestAux))) ;; ghc (import GHC (DynFlags getSessionDynFlags runGhc)) (cond-expand [(<= 902 :ghc) (import GHC.Driver.Ppr (showPpr))] [(<= 900 :ghc) (import GHC.Utils.Outputable (showPpr))] [otherwise (import Outputable (showPpr))]) (cond-expand [(<= 900 :ghc) (:begin (import GHC.Data.FastString (fsLit)) (import GHC.Utils.Outputable ((Outputable ..))) (import GHC.Parser.Lexer ((P ..) (ParseResult ..))) (import GHC.Types.SrcLoc ((GenLocated ..) mkRealSrcLoc interactiveSrcSpan)) (import GHC.Data.StringBuffer (hGetStringBuffer)) (import qualified GHC.Parser as GhcParser) (import qualified GHC.Parser.Lexer as GhcLexer))] [otherwise (:begin (import FastString (fsLit)) (import Outputable ((Outputable ..))) (import Lexer ((P ..) (ParseResult ..))) (import SrcLoc ((GenLocated ..) mkRealSrcLoc interactiveSrcSpan)) (import StringBuffer (hGetStringBuffer)) (import qualified Parser as GhcParser) (import qualified Lexer as GhcLexer))]) (cond-expand [(<= 904 :ghc) (:begin (import GHC.Driver.Config.Parser (initParserOpts)) (import GHC.Parser.PostProcess ((ECP ..) runPV)))] [(<= 902 :ghc) (:begin (import GHC.Driver.Config (initParserOpts)) (import GHC.Parser.PostProcess ((ECP ..) runPV)))] [(<= 900 :ghc) (import GHC.Parser.PostProcess (runECP-P))] [otherwise (import RdrHsSyn (runECP-P))]) ;;; Functions (defn (:: spec Spec) (beforeAll ;; Running `runGhc' to set the `unsafeGlobalDynFlags' with `initGhcMonad'. (do (<- mb-ghc-lib get-ghc-lib) (runGhc mb-ghc-lib getSessionDynFlags)) (describe "language syntax" (do (lept [expFromECP (cond-expand ;; The function `runECP_P' was added in ghc 8.10.x, ;; and removed in ghc 9.2.1. Using explicit lambda ;; for `runPV' and `unECP' to make the type ;; concrete. [(<= 902 :ghc) (\p (runPV (unECP p)))] [otherwise runECP-P])]) (describe "expression" (parser-tests "expr" (Parsers (>>= GhcParser.parseExpression expFromECP) FnkParser.parseExpr))) (describe "declaration" (parser-tests "decl" (Parsers (fmap pure GhcParser.parseDeclaration) FnkParser.parseTopDecls))) (describe "module" (parser-tests "module" (Parsers GhcParser.parseModule (fmap (L interactiveSrcSpan) FnkParser.parseModule)))) (describe "import" (parser-tests "import" (Parsers (fmap pure GhcParser.parseImport) FnkParser.parseImports))) (describe "ffi" (parser-tests "ffi" (Parsers (fmap pure GhcParser.parseDeclaration) FnkParser.parseTopDecls))))))) (defn (:: parser-tests (=> (Outputable a) (-> FilePath (Parsers a) (SpecWith DynFlags)))) [subdir parsers] (do (lefn [(run-it [name] (it (++ "should parse tests in " name) (\dflags (parser-test dflags parsers ( (language-dir subdir) name)))))]) (<- files (runIO (list-base-names (language-dir subdir)))) (mapM_ run-it files))) (data (Parsers a) (Parsers {(:: hs-parser (P a)) (:: fnk-parser (Builder a))})) (defn (:: parser-test (=> (Outputable a) (-> DynFlags (Parsers a) FilePath (IO ())))) [dflags parsers basename] (do (lept [fnk (<.> basename "fnk") hs (<.> basename "hs")]) (<- buf (hGetStringBuffer hs)) (lept [loc (mkRealSrcLoc (fsLit "") 1 1) ps (cond-expand [(<= 902 :ghc) (GhcLexer.initParserState (initParserOpts dflags) buf loc)] [otherwise (GhcLexer.mkPState dflags buf loc)]) ]) (case (GhcLexer.unP (hs-parser parsers) ps) (POk _st hres) (do (<- fstr (parse-fnk dflags parsers fnk)) (shouldBe fstr (showPpr dflags hres))) _ (expectationFailure "failed to parse haskell code")))) (defn (:: parse-fnk (=> (Outputable a) (-> DynFlags (Parsers a) FilePath (IO String)))) [dflags parser path] (do (<- buf (hGetStringBuffer path)) (<- (, forms _sp) (parseSexprs (Just path) buf)) (case (evalBuilder dflags False (fnk-parser parser) forms) (Right fexp) (return (showPpr dflags fexp)) (Left err) (return (show err))))) (defn (:: language-dir (-> String FilePath)) [subdir] ( "include" "language-syntax" subdir)) (defn (:: list-base-names (-> FilePath (IO [FilePath]))) [dir] (do (<- files (listDirectory dir)) (return (sort [(dropExtension file) | (<- file files) (== ".fnk" (takeExtension file))])))) ================================================ FILE: doc/test/Doc/Macros.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Test codes for "macros.rst" (defmodule Doc.Macros (export spec) (import ;; base (Data.Version [makeVersion]) (System.Info [os]) ;; filepath (System.FilePath []) ;; hspec (Test.Hspec [(Spec) beforeAll_ describe]) ;; Internal (Doc.TestAux))) (defn (:: spec Spec) (lept [dir ( "include" "macros") is-osx-or-win (|| (== os "darwin") (== os "mingw32")) skips [(, "begin.console" (\version _ (> (makeVersion [8 8 0]) version))) (, "quasiquote.console" (\version _ (|| is-osx-or-win (<= (makeVersion [9 4 0]) version)))) (, "quasiquote904.console" (\version _ (|| is-osx-or-win (< version (makeVersion [9 4 0])))))]] (beforeAll_ (remove-compiled [( dir "quasiquote") ( dir "require") ( dir "RequireMe")]) (describe "macros in finkel" (run-console-tests dir skips))))) ================================================ FILE: doc/test/Doc/TestAux.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Auxiliary codes for tests. (defmodule Doc.TestAux (export (BuildTool ..) get-build-tool get-stack-resolver get-ghc-lib run-console-tests run-console-test remove-compiled) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Exception [catch throw]) (Control.Monad [unless when]) (Data.List [isSubsequenceOf isPrefixOf sort]) (Data.Maybe [fromMaybe]) (Data.Version [(Version ..) parseVersion]) (System.Environment [getExecutablePath lookupEnv]) (System.Exit [(ExitCode ..)]) (System.IO [hGetContents hGetLine]) (Text.ParserCombinators.ReadP [readP-to-S]) ;; directory (System.Directory [listDirectory removeFile]) (System.Directory.Internal.Prelude [isDoesNotExistError]) ;; filepath (System.FilePath [ <.> takeExtension]) ;; hspc (Test.Hspec [(Expectation) (Spec) expectationFailure it pendingWith runIO shouldBe]) ;; process (System.Process [(CreateProcess ..) (StdStream ..) createProcess proc waitForProcess]))) (cond-expand [(<= 900 :ghc) (import GHC.Settings.Config (cProjectVersion))] [otherwise (import Config (cProjectVersion))]) ;;; Exported (defn (:: remove-compiled (-> [String] (IO ()))) "Remove given compiled files if exist. Remove the given file @FILE@, @FILE.o@, and @FILE.hi@." [name] (lefn [(go0 [exe] (mapM go1 [exe (<.> exe "o") (<.> exe "hi") (<.> exe "dyn_o") (<.> exe "dyn_hi")])) (go1 [file] (catch (removeFile file) (\e (unless (isDoesNotExistError e) (throw e)))))] (mapM_ go0 name))) (defn (:: get-build-tool (IO BuildTool)) "Get the running `BuildTool'." (do (<- me getExecutablePath) (pure (cond [(isSubsequenceOf ".stack" me) Stack] [(isSubsequenceOf "dist-newstyle" me) Cabal] [otherwise Raw])))) (defn (:: get-stack-resolver (IO String)) "Return @RESOLVER@ environment variable." (fmap (fromMaybe "lts-16") (lookupEnv "RESOLVER"))) (defn (:: get-ghc-lib (IO (Maybe FilePath))) (do (<- build-tool get-build-tool) (<- p0 (case build-tool Cabal (return (proc "cabal" ["v2-exec" "--" "ghc" "--print-libdir"])) Stack (do (<- resolver get-stack-resolver) (return (proc "stack" ["--resolver" resolver "exec" "--" "ghc" "--print-libdir"]))) Raw (return (proc "ghc" ["--print-libdir"])))) (lept [p1 (p0 {(= std-out CreatePipe)})]) (<- (, _mb-in mb-out _mb-err ph) (createProcess p1)) (<- _ec (waitForProcess ph)) (case mb-out (Just out) (fmap pure (hGetLine out)) Nothing (return Nothing)))) (:doc "List of pair of name and condition for skipping console test. Pair of cosole filename (without the directory, with extension) and a function taking GHC version. If the function evaluates to `True', the console test will be skipped.") (type ConsoleSkip [(, String (-> Version BuildTool Bool))]) (defn (:: get-console-files (-> FilePath (IO [FilePath]))) (lept [is-console-file (. (== ".console") takeExtension)] (. (fmap (. sort (filter is-console-file))) listDirectory))) (defn (:: run-console-tests (-> FilePath ConsoleSkip Spec)) "Run test for @*.console@ files in given directory." [dir skips] (do (lefn [(test [build-tool file] (it (++ "runs " file " successfully") (case (do (<- f (lookup file skips)) (<- v mb-ghc-version) (return (f v build-tool))) (Just True) (pendingWith "skipped") _ (run-console-test dir file)))) (mb-ghc-version (case (filter (. null snd) (readP-to-S parseVersion cProjectVersion)) (: (, v _) _) (Just v) _ Nothing))]) (<- console-files (runIO (get-console-files dir))) (<- build-tool (runIO get-build-tool)) (mapM_ (test build-tool) console-files))) (data BuildTool ;; | This package is build with `cabal-install'. Cabal ;; | This package is build with `stack'. Stack ;; | This package is build with raw invokation of available commands. Raw (deriving Eq)) (defn (:: run-console-test (-> FilePath ; ^ Directory to run the command. FilePath ; ^ Console file. Expectation)) [dir file] (do (<- contents (readFile ( dir file))) (<- build-tool get-build-tool) (<- finkel (case build-tool Cabal (return (, "cabal" ["v2-exec" "-v0" "--" "finkel"])) Stack (do (<- resolver get-stack-resolver) (return (, "stack" ["--resolver" resolver "--silent" "exec" "--" "finkel"]))) Raw (return (, "finkel" [])))) (lept [tests (parse-console contents) aliases [(, "finkel" finkel)]]) (mapM_ (run-console dir aliases) tests))) (data ConsoleTest (ConsoleTest String ; ^ The command. [String] ; ^ Arguments passed to the command. [String]) ; ^ Expected output lines. (deriving Eq Show)) (defn (:: run-console (-> String ; ^ Directory to run the test [(, String (, String [String]))] ; ^ Alias for command. ConsoleTest ; ^ The test. (IO ()))) [dir aliases (ConsoleTest cmd args expected)] (do (lept [(, cmd' args') (case (lookup cmd aliases) (Just (, rc ra)) (, rc (++ ra args)) Nothing (, cmd args))]) (<- (, _mbin mbout mberr ph) (createProcess ((proc cmd' args') {(= cwd (Just dir)) (= std-out CreatePipe)}))) (<- ec (waitForProcess ph)) (<- errs (case mberr (Just hdl) (hGetContents hdl) Nothing (return ""))) (when (not (null errs)) (putStrLn (++ "stderr: " errs))) (<- outs0 (case mbout (Just out) (fmap lines (hGetContents out)) Nothing (return []))) (lept [outs1 (remove-loaded-package-env outs0)]) (case ec ExitSuccess (shouldBe (unlines outs1) (unlines expected)) _ (expectationFailure (++ "Got exit code " (show ec)))))) (defn (:: remove-loaded-package-env (-> [String] [String])) "In ghc-8.10.1, the `Loaded package environment from ...' message has changd its output from stderr to stdout. Removing the message line from command outputs." (filter (. not (isPrefixOf "Loaded package environment from")))) (defn (:: parse-console (-> String [ConsoleTest])) "Parse the contents of console file." (lefn [(go [ls] (case (span is-cmd-line ls) (, (: cl _) r0) (case (words (drop 1 cl)) (: cmd args) (case (break is-cmd-line r0) (, os r1) (: (ct cmd args os) (go r1))) _ (go r0)) _ [])) (ct ConsoleTest)] (. go lines))) (defn (:: is-cmd-line (-> String Bool)) "True if the line starts with @$@." [(: #'$ _)] True [_] False) ================================================ FILE: doc/test/Doc.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Doc (export main) (import ;; hspec (Test.Hspec (hspec)) ;; Internal (qualified Doc.FinkelExecutable) (qualified Doc.BuildingPackage) (qualified Doc.Macros) (qualified Doc.LanguageSyntax))) (defn (:: main (IO ())) (hspec (do Doc.FinkelExecutable.spec Doc.BuildingPackage.spec Doc.Macros.spec Doc.LanguageSyntax.spec))) ================================================ FILE: doc/test/Spec.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Main (import (qualified Doc))) (defn (:: main (IO ())) Doc.main) ================================================ FILE: finkel/CHANGELOG.md ================================================ # Revision history for finkel ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. ================================================ FILE: finkel/LICENSE ================================================ Copyright (c) 2020-2022, 8c6794b6 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: finkel/Main.hs ================================================ import Finkel.Tool.Main (defaultMain) main :: IO () main = defaultMain ================================================ FILE: finkel/README.md ================================================ # finkel Package for the @finkel@ executable. See the [documentation](https://finkel.readthedocs.org) for more info ================================================ FILE: finkel/Setup.hs ================================================ import Distribution.Simple main = defaultMain ================================================ FILE: finkel/finkel.cabal ================================================ cabal-version: 2.0 name: finkel version: 0.0.0 synopsis: Haskell in S-expression license: BSD3 license-file: LICENSE author: 8c6794b6 maintainer: 8c6794b6@gmail.com copyright: 2020-2022 8c6794b6 category: Language build-type: Simple extra-source-files: CHANGELOG.md README.md description: Package for the @finkel@ executable. . See the for more info. executable finkel main-is: Main.hs build-depends: base >= 4.14 && < 5 , finkel-tool == 0.0.0 default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts=all "-with-rtsopts=-K512M -H -I5 -T" source-repository head type: git location: https://github.com/finkel-lang/finkel.git subdir: finkel ================================================ FILE: finkel-core/LICENSE ================================================ Copyright (c) 2017-2022, 8c6794b6 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: finkel-core/README.md ================================================ # finkel-core Core language macro for Finkel. See the [documentation][doc] for more details. [doc]: https://finkel.readthedocs.io/en/latest/ ================================================ FILE: finkel-core/Setup.hs ================================================ import Distribution.Simple (defaultMain) main = defaultMain ================================================ FILE: finkel-core/finkel-core.cabal ================================================ cabal-version: 2.0 name: finkel-core version: 0.0.0 synopsis: Finkel language core description: Finkel language core macros and functions . See the for more info. homepage: https://github.com/finkel-core/finkel#readme license: BSD3 license-file: LICENSE author: 8c6794b6 maintainer: 8c6794b6@gmail.com copyright: 2017-2022 8c6794b6 category: Language build-type: Simple extra-source-files: README.md -- test/data/plugin/*.hs tested-with: GHC == 8.10.7 , GHC == 9.0.1 , GHC == 9.2.8 , GHC == 9.4.7 , GHC == 9.6.5 , GHC == 9.8.2 , GHC == 9.10.1 library hs-source-dirs: src exposed-modules: Finkel.Core Finkel.Core.Functions Finkel.Core.Internal Finkel.Core.Plugin Finkel.Prelude Paths_finkel_core other-modules: Finkel.Core.Internal.Stage0 Finkel.Core.Internal.Stage1 Finkel.Core.Internal.Stage2 Finkel.Core.Internal.Ghc Finkel.Core.Internal.Ghc.Compat Finkel.Core.Internal.Ghc.Version autogen-modules: Paths_finkel_core build-depends: base >= 4.14 && < 5 , ghc >= 8.10.0 && < 9.11 , finkel-kernel == 0.0.0 -- To import "GHC.PackageDb.packageVersion" if impl (ghc <= 9.0.0) build-depends: ghc-boot >= 8.2.0 && < 9 default-language: Haskell2010 build-tool-depends: fnkpp:fnkpp == 0.0.0 ghc-options: -Wall -F -pgmF fnkpp -optF --no-warn-interp -fplugin Language.Finkel.Plugin if impl (ghc >= 9.6.0) ghc-options: -keep-hscpp-files test-suite finkel-core-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs other-modules: Orphan CoreTest FunctionTest PluginTest TestAux build-depends: base , ghc , finkel-core , finkel-kernel -- , QuickCheck >= 2.10.1 && < 2.16 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.6 , hspec >= 2.4.8 && < 2.12 default-language: Haskell2010 -- Known not to work ..., disabling the test under Windows with ghc >= 9.4. -- The test requires object files of this package built with "-dynamic" -- option, which does not work well under Windows. if impl (ghc >= 9.4.0) && os(windows) buildable: False build-tool-depends: fnkpp:fnkpp == 0.0.0 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -F -pgmF fnkpp -optF --warn-interp=False -fplugin Language.Finkel.Plugin if impl (ghc >= 9.6.0) ghc-options: -keep-hscpp-files source-repository head type: git location: https://github.com/finkel-lang/finkel.git subdir: finkel-core ================================================ FILE: finkel-core/src/Finkel/Core/Functions.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Exported functions defined in this package (:doc "Module for exporting functions defined in the @finkel-core@ package. This module does not export macros, but exports some of the functions to work with code values when writing macros.") (module Finkel.Core.Functions (:dh1 "Predicates") is-atom is-pair is-list is-hslist is-symbol is-string is-char is-integer is-fractional is-unit caris (:dh1 "Atom constructors") make-symbol (:dh1 "Atom extractors") mb-symbol-name mb-symbol-name-fs (:dh1 "Code constructors") cons list (Listable ..) (:dh1 "CXrs") (:dh2 "Basic cXrs") car cdr (:dh2 "Composed cXrs") (:doc$ cxr) caar cadr caaar caadr cadar caddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdar cddr cdaar cdadr cddar cdddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr (:dh1 "Converting") curve rev unsnoc (:dh1 "Higher order functions") reduce reduce1 map1 keep trav1 omni omniM (:dh1 "Exceptions") (FinkelListException ..) unsafeFinkelSrcError) ;; Internal (import Finkel.Core.Internal.Stage0) (import Finkel.Core.Internal.Stage2) (:doc$ cxr "The `car' and `cdr' are the basic of /cxr/ functions. Rest of the /cxr/ functions are composed from `car' and `cdr'. E.g., definition of `cadr' is: > (cadr x) == (car (cdr x)) and the definition of `cdadr' is: > (cdadr x) == (cdr (car (cdr x)))") ================================================ FILE: finkel-core/src/Finkel/Core/Internal/Ghc/Compat.hs ================================================ {-# LANGUAGE CPP #-} -- Module to re-export functions from ghc module Finkel.Core.Internal.Ghc.Compat ( -- GHC getModuleInfo, lookupModule, lookupName, modInfoExports, -- GHC.Data.FastString FastString, fsLit, unpackFS, nullFS, -- GHC.Driver.Env HscEnv(..), -- GHC.Driver.Monad GhcMonad(..), -- GHC.Driver.Ppr showSDoc, -- GHC.Plugin Plugin(..), -- GHC.Types.SourceText SourceText(..), -- GHC.Types.TyThing TyThing(..), -- GHC.Types.Var varName, -- GHC.Unit.Module mkModuleName, -- GHC.Utils.Lexeme isLexCon, -- GHC.Utils.Outputable ppr ) where import GHC (getModuleInfo, lookupModule, lookupName, modInfoExports) #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Types.SourceText import GHC.Types.TyThing #elif MIN_VERSION_ghc(9,0,0) import GHC.Driver.Types import GHC.Types.Basic import GHC.Types.Var import GHC.Unit.Module import GHC.Utils.Outputable #endif #if MIN_VERSION_ghc(9,0,0) import GHC.Data.FastString import GHC.Driver.Monad import GHC.Plugins import GHC.Utils.Lexeme #else import BasicTypes import FastString import GhcMonad import HscTypes import Lexeme import Module import Outputable import Plugins import Var #endif ================================================ FILE: finkel-core/src/Finkel/Core/Internal/Ghc/Version.hs ================================================ {-# LANGUAGE CPP #-} -- | Wrapper module to export version related functions. module Finkel.Core.Internal.Ghc.Version ( __glasgow_haskell__ , getPackageVersion ) where -- base import Data.Version (Version) -- finkel-kernel import Language.Finkel (Code, Fnk, finkelSrcError, fromCode) -- ghc #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env (hsc_units) #elif MIN_VERSION_ghc(9,0,0) import GHC.Driver.Session (unitState) #endif #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,4,0) import GHC.Unit.Types (indefUnit) #endif #if MIN_VERSION_ghc(9,0,0) import GHC.Unit.State (PackageName (..), lookupPackageName, lookupUnitId, unitPackageVersion) #else import Module (componentIdToInstalledUnitId) import Packages (PackageName (..), lookupInstalledPackage, lookupPackageName) -- ghc-boot import GHC.PackageDb (packageVersion) #endif -- Internal import Finkel.Core.Internal.Ghc.Compat -- | Function version of @__GLASGOW_HASKELL__@ C preprocessor macro. __glasgow_haskell__ :: Int __glasgow_haskell__ = __GLASGOW_HASKELL__ getPackageVersion :: HscEnv -> Code -> Fnk Version getPackageVersion hsc_env form = let err = finkelSrcError form in case fromCode form of Nothing -> err ("want package name `String' value but got: " ++ show form) Just name -> case lookupPackageVersion hsc_env name of Nothing -> err ("cannot find package: " ++ name) Just v -> pure v lookupPackageVersion :: HscEnv -> String -> Maybe Version #if MIN_VERSION_ghc(9,4,0) lookupPackageVersion hsc_env name = -- XXX: Is GHC.Driver.Env.hscActiveUnitId related? do let pname = PackageName (fsLit name) us = hsc_units hsc_env uid <- lookupPackageName us pname uinfo <- lookupUnitId us uid pure $ unitPackageVersion uinfo #elif MIN_VERSION_ghc(9,2,0) lookupPackageVersion hsc_env name = do let pname = PackageName (fsLit name) us = hsc_units hsc_env indef_uid <- lookupPackageName us pname uid <- lookupUnitId us (indefUnit indef_uid) pure $ unitPackageVersion uid #elif MIN_VERSION_ghc(9,0,0) lookupPackageVersion hsc_env name = do let pname = PackageName (fsLit name) ust = unitState (hsc_dflags hsc_env) indef_uid <- lookupPackageName ust pname uid <- lookupUnitId ust (indefUnit indef_uid) pure $ unitPackageVersion uid #else lookupPackageVersion hsc_env name = do let pname = PackageName (fsLit name) component_id <- lookupPackageName (hsc_dflags hsc_env) pname let iuid = componentIdToInstalledUnitId component_id conf <- lookupInstalledPackage (hsc_dflags hsc_env) iuid pure $ packageVersion conf #endif ================================================ FILE: finkel-core/src/Finkel/Core/Internal/Ghc.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Module for ghc related functions (:doc "Internal module for @ghc@ related functions.") (module Finkel.Core.Internal.Ghc __glasgow_haskell__ (module Finkel.Core.Internal.Ghc.Compat)) (import Finkel.Core.Internal.Ghc.Compat) (import Finkel.Core.Internal.Ghc.Version) ================================================ FILE: finkel-core/src/Finkel/Core/Internal/Stage0.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Stage0 - functions used in stage 1. ;;; This module contains few functions and type to work with `Code', just enough ;;; to define some macros in the next `Finkel.Core.Internal.Stage1' module. (module Finkel.Core.Internal.Stage0 ;; Exported from other modules. (FinkelListException ..) car cdr cons ;; Internal, used in this package only. non-list the-macro-arg) ;; base (import Control.Exception ((Exception ..) throw)) ;; finkel-kernel (import Language.Finkel) (import Language.Finkel.Form (mkLocatedForm)) ;;; Exception (:doc "List related exception.") (data FinkelListException (NonListValue Code String)) (instance (Show FinkelListException) (= show (NonListValue _ str) str)) (instance (Exception FinkelListException)) (:doc "Throw a `NonListValue' with label and cause.") (:: non-list (-> String Code a)) (= non-list fname what (let ((= msg (++ fname ": non-list value `" (show what) "'"))) (throw (NonListValue what msg)))) %p(INLINE non-list) ;;; CONS, CAR, CDR (:doc "Extend the second argument with the first argument by appending to the tip. Consing to 'HsList' will result in 'List', and consing to non-list value will create a new 'List' instead of a /dotted-pair/. ==== __Examples__ >>> (cons 'a '(b c)) (a b c) >>> (cons 'a '[b c]) (a b c) >>> (cons '(a b) '(c d)) ((a b) c d) >>> (cons '[a b] '[c d]) ([a b] c d) >>> (cons 'a 'b) (a b)") (:: cons (=> (Homoiconic a) (Homoiconic b) (-> a b Code))) (= cons a b (let ((= (@ hd (LForm (L l0 _))) (toCode a)) (= (@ whole (LForm (L _ xs))) (toCode b))) (LForm (L l0 (case xs (List xs') (List (: hd xs')) (HsList xs') (List (: hd xs')) _ (List [hd whole])))))) %p(INLINABLE cons) (:doc "Get the first element of given 'Code'. The function 'car' returns the first element of 'List' and 'HsList' constructor, or 'nil' value when the 'List' or 'HsList' were empty. Throws a 'NonListValue' when the given argument was non-list value. ==== __Examples__ >>> (car '(a b c)) a >>> (car '[a b c]) a >>> (car nil) nil >>> (car 'foo) *** Exception: car: non-list value `foo'") (:: car (-> Code Code)) (= car (@ lform (LForm (L l form))) (case form (List (: x _)) x (List []) lform (HsList (: x _)) x (HsList []) (LForm (L l (List []))) _ (non-list "car" lform))) %p(INLINABLE car) (:doc "Get a list without the first element. The function 'cdr' returns list value without the first element of 'List' or 'HsList' argument. When the argument is a 'HsList', returned value is converted to a 'List'. Like 'car', throws 'NonListValue' when the argument were non-list value. ==== __Examples__ >>> (cdr '(a b c)) (b c) >>> (cdr '[a b c]) (b c) >>> (cdr nil) nil >>> (cdr 'foo) *** Exception: cdr: non-list value `foo' ") (:: cdr (-> Code Code)) (= cdr (@ lform (LForm (L l form))) (let ((= f xs (case (mkLocatedForm xs) (L l1 _) (LForm (L l1 (List xs)))))) (case form (List (: _ xs)) (f xs) (List []) (LForm (L l (List []))) (HsList (: _ xs)) (f xs) (HsList []) (LForm (L l (List []))) _ (non-list "cdr" lform)))) %p(INLINABLE cdr) ;;; Special symbol (:doc "The symbol used for entire argument in macro function.") (:: the-macro-arg Code) (= the-macro-arg '__form__) %p(INLINE the-macro-arg) ================================================ FILE: finkel-core/src/Finkel/Core/Internal/Stage1.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Stage1 - fundamental macros ;;; This module contains codes of some fundamental macros, such as `defmacro', ;;; `defmodule', `eval-when', `macrolet' ... etc, just enough to start writing ;;; other macros and function in `Finkel.Core.Stage2'. (module Finkel.Core.Internal.Stage1 defmacro defmacro' defmacro- defmacroM defmacroM' defmacroM- macrolet macroletM defn defn' defn- eval-when eval-and-compile) ;;; Imports ;; base (import Control.Monad (foldM)) ;; finkel-kernel (import Language.Finkel) ;; Internal (import Finkel.Core.Internal.Stage0) (import Finkel.Core.Internal.Ghc.Compat) ;;; [Internally used macros] ;;; ~~~~~~~~~~~~~~~~~~~~~~~~ ;;; ;;; First, defining `eval-when-compile-and-load' macro, to define functions and ;;; macros in current compilation context and compiled result. Then this module ;;; defines some auxiliary functions, and then a macro `define-macro'' to define ;;; macros for this module itself and compiled result. (:eval-when-compile ;; base (import Prelude) ;; finkel-kernel (import Language.Finkel) (:: eval-when-compile-and-load Macro) (= eval-when-compile-and-load (Macro (\form (case (unCode form) (List (: _ rest)) (return `(:begin (:eval-when-compile ,@rest) ,@rest)) _ (finkelSrcError form "eval-when-compile-and-load")))))) (eval-when-compile-and-load (:doc "Code transformer function for macro declaration.") (:: macro-decl (-> Code Code Code (Fnk Code))) (= macro-decl name arg body (do (<- tmp (gensym' "tmp")) ;; XXX: Test the behaviour when the type signature in below is removed. (return `(= ,name (let ((:: ,tmp (-> Code (Fnk Code))) (= ,tmp ,arg ,body)) (Macro ,tmp)))))) %p(INLINABLE macro-decl) (:doc "Body function of /macro-defining-macro/.") (:: dmac (-> Code (Fnk Code))) (= dmac form (let ((:: make-tsig (-> Code Code)) (= make-tsig name `(:: ,name Macro))) (case (unCode form) (List [_ name arg body]) (do (<- decl (macro-decl name arg body)) (return `(:begin ,(make-tsig name) ,decl))) (List [_ name (@ doc (LForm (L _ (Atom (AString {}))))) arg body]) (do (<- decl (macro-decl name arg body)) (return `(:begin ,(make-tsig name) (:doc^ ,doc) ,decl))) _ (finkelSrcError form "dmac: malformed macro")))) %p(INLINABLE dmac) (:doc "Function for body of `macrolet'.") (:: lmac (-> Code (Fnk Code))) (= lmac form (let ((= f x (case (unCode x) (List [name arg body]) (macro-decl name arg body) _ (finkelSrcError x "lmac: malformed macro")))) (case (unCode form) (List (: _ (LForm (L _l (List ms))) rest)) (do (<- ms' (mapM f ms)) (return `(:with-macro (,@ms') ,@rest))) _ (finkelSrcError form "lmac: malformed args")))) %p(INLINABLE lmac)) (:eval-when-compile (:doc "Simple macro for defining macro. This macro is used internally in \"Finkel.Core\" module to define other macros. ==== __Syntax__ > DEFINE-MACRO ::= 'define-macro' NAME [DOC] ARGS BODY > NAME ::= varid > DOC ::= '\"' comment '\"' > ARGS ::= varid | '[' varid* ']' | '(' varid* ')' > BODY ::= form ==== __Examples__ Without documentation comment: @ (define-macro m1a form (case (unCode form) (List [_ x]) (return `(print ,x)))) @ With documentation comment: @ (define-macro m1b \"Documentation comment\" form (case (unCode form) (List [_ x]) (return `(print ,x)))) @ ") (:: define-macro Macro) (= define-macro (Macro dmac))) ;;; Exported codes (:doc "Macro to specify the /PHASE/s of evaluation of /BODY/ codes. Valid phases are __@:compile@__ and __@:load@__. The @:compile@ phase evaluates the body forms at the time of compilation, so that the compilation context can refer to the function and macros definied in the /BODY/ forms. The @:load@ phase simply emit the body forms to compiled result. ==== __Syntax__ > EVAL-WHEN ::= 'eval-when' PHASES BODY+ > PHASES ::= '[' PHASE+ ']' | '(' PHASE+ ')' > PHASE ::= ':compile' | ':load' > BODY ::= form ==== __Example__ In following module, the function @f@ is defined inside 'eval_when', so that the function could be called from the function @g@ at run-time, and temporally macro @m@ at compilation time. @ (defmodule Main (import-when [:compile :load] (Finkel.Prelude))) (eval-when [:compile :load] (defn (:: f (-> Code Code)) [x] `(print ,x))) (defn (:: g (-> Code (IO ()))) [x] (print (f x))) (macrolet ((m [x] (f x))) (defn (:: main (IO ())) (do (g 'foo) (m 'bar)))) @ ") (define-macro eval-when form (let ((:: at-compile (-> [Code] Bool)) (= at-compile (elem ':compile)) (:: at-load (-> [Code] Bool)) (= at-load (elem ':load)) (:: emit (-> [Code] [Code] (Fnk Code))) (= emit phases body (| ((&& (at-compile phases) (at-load phases)) (do (<- expanded (expands body)) (return (cons ':begin (cons (cons ':eval-when-compile expanded) expanded))))) ((at-compile phases) (return `(:eval-when-compile ,@body))) ((at-load phases) (return `(:begin ,@body))) (otherwise (finkelSrcError form (++ "eval-when: invalid phase: " (show phases))))))) (case (unCode form) (List (: _ (LForm (L _ lst)) body)) (| ((<- (List phases) lst) (emit phases body)) ((<- (HsList phases) lst) (emit phases body))) _ (finkelSrcError form (++ "eval-when: invalid form: " (show form)))))) (:doc "Same as 'eval_when' macro with __@:compile@__ and __@:load@__ phases. ==== __Syntax__ > EVAL-AND-COMPILE ::= 'eval-and-compile' BODY* ==== __Example__ See 'eval_when'.") (define-macro eval-and-compile form (return `(eval-when [:compile :load] ,@(cdr form)))) ;;; Auxiliary functions for `defmacro' (:: subst-gensyms (-> [(, Atom Atom)] Code Code)) (= subst-gensyms kvs (fmap (\x (case (lookup x kvs) (Just y) y Nothing x)))) %p(INLINE subst-gensyms) (:: replace-hyphens (-> String String)) (= replace-hyphens (map (\x (if (== x #'-) #'_ x)))) %p(INLINE replace-hyphens) (:: acc-gensym-names (-> [(, Atom Atom)] Atom (Fnk [(, Atom Atom)]))) (= acc-gensym-names acc form (case form (ASymbol sym) (| ((<- (: #'$ (@ cs (: c _))) (unpackFS sym)) (elem c [#'a .. #'z]) (<- Nothing (lookup form acc)) (do (<- x (gensym' (replace-hyphens cs))) (return (case (unCode x) (Atom gsym) (: (, form gsym) acc) _ acc))))) _ (return acc))) %p(INLINE acc-gensym-names) (:: gensymfy (-> Code (Fnk Code))) (= gensymfy form (do (<- kvs (foldM acc-gensym-names [] form)) (return (subst-gensyms kvs form)))) %p(INLINE gensymfy) ;; Function to make body of macro. ;; ;; XXX: Currently does not suuport lambda-list like pattern match in ;; macro argument. (:: make-macro-body (-> String Code Code Code Code (Fnk Code))) (= make-macro-body label whole name0 arg0 body0 (let ((:: err (-> Code Code Code)) (= err form-name name `(finkelSrcError ,form-name (++ ,(++ "in macro `" (show name) "'\ninvalid form: `") (show ,the-macro-arg) "'"))) (:: atom-arg-body (-> Code Code Code Code Code)) (= atom-arg-body name arg body form-name `(case ,form-name (LForm (L $loc (List (: _ __arg__)))) (let ((= ,arg (LForm (L $loc (List __arg__)))) (= $tmp ,body)) $tmp) _ ,(err form-name name))) (:: list-arg-body (-> SrcSpan Code [Code] Code Code Code)) (= list-arg-body l1 name args body form-name (let ((:: abind Code) (= abind `(LForm (L _loc (List [_ ,@(LForm (L l1 (List args)))]))))) `(case ,form-name ,abind (let ((= $tmp ,body)) $tmp) _ ,(err form-name name))))) (case (unLForm arg0) (L l1 (Atom AUnit)) (gensymfy (list-arg-body l1 name0 [] body0 the-macro-arg)) (L l1 (List args)) (gensymfy (list-arg-body l1 name0 args body0 the-macro-arg)) (L l1 (HsList args)) (gensymfy (list-arg-body l1 name0 args body0 the-macro-arg)) (L _ (Atom (ASymbol _))) (gensymfy (atom-arg-body name0 arg0 body0 the-macro-arg)) _ (finkelSrcError whole (++ label ": invalid args"))))) %p(INLINE make-macro-body) ;; Function to make body expression of `defmacroM' and `defmacro'. (:: make-defmacro-body (-> String Code (-> Code Code) (Fnk Code))) (= make-defmacro-body label whole f (let ((:: emit (-> Code (Maybe Code) Code Code (Fnk Code))) (= emit name mb-doc arg body0 (do (let ((= body1 (f body0)) (= docs (maybe [] pure mb-doc)))) (<- body2 (make-macro-body label whole name arg body1)) (dmac `(_ ,name ,@docs ,the-macro-arg ,body2))))) (case (unCode whole) (List [_ name (@ doc (LForm (L _ (Atom (AString {}))))) arg body]) (emit name (Just doc) arg body) (List [_ name arg body]) (emit name Nothing arg body) _ (finkelSrcError whole (++ label ": invalid form"))))) %p(INLINE make-defmacro-body) ;; Function to make body expression of `macrolet-m' and `macrolet'. (:: make-macrolet-body (-> String Code (-> Code Code) (Fnk Code))) (= make-macrolet-body label whole f (let ((:: make-macro (-> Code (Fnk Code))) (= make-macro code (case code (LForm (L l (List [name arg body0]))) (do (let ((= body1 (f body0)))) (<- body2 (make-macro-body label code name arg body1)) (return (LForm (L l (List [name the-macro-arg body2]))))) _ (finkelSrcError code (++ label ": invalid form")))) (:: emit (-> SrcSpan [Code] [Code] (Fnk Code))) (= emit l ms body (do (<- macros (mapM make-macro ms)) (lmac `(:with-macro ,(LForm (L l (List macros))) ,@body))))) (case (unCode whole) (List (: _ (LForm (L l macs)) rest)) (| ((<- (List forms) macs) (emit l forms rest)) ((<- (HsList forms) macs) (emit l forms rest))) _ (finkelSrcError whole (++ label ": invalid form"))))) %p(INLINE make-macrolet-body) (:doc "Variant of 'macrolet', the body of each macro need to be a 'Code' value wrapped in 'Fnk'. This macro has full access to 'Fnk' in compilation context. ==== __Syntax__ See 'macrolet'. ==== __Example__ Rewrite of the example shown in 'macrolet': @ (macrolet-m ((m1 [x] (return `(+ ,x 1))) (m2 [a b] (return `[(m1 ,a) (m1 ,b)]))) (m2 19 20)) ;;; ==> [20,21] @ ") (define-macro macroletM form (make-macrolet-body "macroletM" form id)) (:doc "Define temporary macros named /NAME/. The defined macros could be referred from /BODY/. Each macro takes /ARGS/ parameter, and results in /EXPR/. The parameter /ARGS/ works as in 'defmacro'. ==== __Syntax__ > MACROLET ::= 'macrolet' '(' MACRO* ')' BODY > MACRO ::= NAME ARGS EXPR > NAME ::= varid > ARGS ::= '(' varid* ')' | '[' varid* ']' | varid > EXPR ::= form > BODY ::= form ==== __Examples__ Temporary macros can refer other temporary macros: @ (macrolet ((m1 [x] `(+ ,x 1)) (m2 [a b] `[(m1 ,a) (m1 ,b)])) (m2 19 20)) ;;; ==> [20,21] @ ") (define-macro macrolet form (make-macrolet-body "macrolet" form (\body `(return ,body)))) (:doc "A macro similar to 'defmacro', but the body expression need to be a value of type 'Fnk' 'Code'. This macro has full access to the 'Fnk' environment in compilation context. ==== __Syntax__ See 'defmacro'. ==== __Examples__ A macro to read a file contents during compilation: @ (defmacroM m1 [path] (| ((<- (Just path') (fromCode path)) (do (<- contents (liftIO (readFile path'))) (return `(putStrLn ,contents)))) (otherwise (finkelSrcError path \"m1: not a file path.\")))) @ Sample expansion: >>> (macroexpand '(m1 \"/path/to/a/file.txt\") (putStrLn \"... contents of the file ...\") ") (define-macro defmacroM form (make-defmacro-body "defmacroM" form id)) (:doc "Variant of 'defmacroM', wrapped in 'eval_and_compile'. ==== __Syntax__ See 'defmacro'. ==== __Examples__ See 'defmacro' and 'defmacroM'.") (define-macro defmacroM' form (return `(eval-and-compile (defmacroM ,@(cdr form))))) (:doc "Variant of 'defmacroM', wrapped in @:eval_when_compile@. ==== __Syntax__ See 'defmacro'. ==== __Examples__ See 'defmacro' and 'defmacroM'. ") (define-macro defmacroM- form (return `(:eval-when-compile (defmacroM ,@(cdr form))))) (:doc "Macro to define a macro named /NAME/, similar to the macro with same name found in other Lisps, such as Common Lisp, Clojure, LFE, Hy ... etc. The 'defmacro' can take an optional /DOC/ comment string in second parameter. Next parameter is either a list of /ARGS/, or a single varid to refer the entire parameter as a list of 'Code's. The last parameter is a /BODY/ expression, which need to be a value of 'Code' type. Note that the 'defmacro' does not add the defined macro to REPL session. To add macros in REPL session, use 'defmacro'' or write the macro definition inside 'eval_when'. ==== __Syntax__ > DEFMACRO ::= 'defmacro' NAME [DOC] ARGS BODY > NAME ::= varid > DOC ::= '\"' comment '\"' > ARGS ::= '(' varid* ')' | '[' varid* ']' | varid > BODY ::= form ==== __Examples__ Macro taking single parameter named /x/, returns a form with 'print' applied to the given parameter: > (defmacro m1a [x] > `(print ,x)) Sample expansion: >>> (macroexpand '(m1a False)) (print False) Parameters could be enclosed in parentheses or brackets: > (defmacro m1b (x) > `(print ,x)) Macro with documentation comment: > (defmacro m2 > \"Documentation comment.\" > [a b] > `(do (print ,a) > (print ,b))) Sample expansion: >>> (macroexpand '(m2 False #'x)) (do (print False) (print #'x)) Macro taking parameter as a list of 'Code': @ (defmacro m3 args (case args (List [a]) `(print ,a) (List [a b]) `(>> (print ,a) (print ,b)) (List xs) `(do ,@(map (\\\\ x `(print ,x)) xs)))) @ Expansions of /m3/: >>> (macroexpand '(m3 False)) (print False) >>> (macroexpand '(m3 False #'x)) (>> (print False) (print #'x)) >>> (macroexpand '(m3 False #'x \"bar\")) (do (print False) (print #'x) (print \"bar\")) ") (define-macro defmacro form (make-defmacro-body "defmacro" form (\x `(return ,x)))) (define-macro defmacro' "Variant of 'defmacro', wrapped in 'eval_and_compile'. ==== __Syntax__ See 'defmacro'. ==== __Examples__ See 'defmacro'. " form (return `(eval-and-compile (defmacro ,@(cdr form))))) (define-macro defmacro- "Variant of 'defmacro', wrapped in @:eval-when-compile@. ==== __Syntax__ See 'defmacro'. ==== __Examples__ See 'defmacro'." form (return `(:eval-when-compile (defmacro ,@(cdr form))))) (define-macro defn "Macro for defining function. Supports optional function type signature /SIG/, which could be a name symbol or a list of name symbol and type signature form. Parameter /ARGS/ could be enclosed in parantheses or brackets. When multiple pairs of /ARGS/ and /BODY/ were given, does expand to function definition with argument pattern matchings. ==== __Syntax__ > DEFN ::= 'defn' SIG [DOC] [ARGS] BODY ARGBODY* > SIG ::= varid | '(' varid typesig ')' | '(' '::' varid typesig ')' > DOC ::= '\"' comment '\"' > ARGS ::= '(' varid* ')' | '[' varid* ']' > BODY ::= form > ARGBODY ::= ARGS BODY ==== __Examples__ Function without arguments: > (defn v1 42) Function without arguments, with type signature: > (defn (:: v2 Int) 43) Function with arguments, type signature, and documentation comment: @ (defn (:: fib1 (-> Int Int)) \"Documentation comment\" [n] (case n 0 0 1 1 _ (+ (fib1 (- n 1)) (fib1 (- n 2))))) @ Function with pattern matched arguments, type signature, and documentation comment: @ (defn (:: fib2 (-> Int Int)) \"Documentation comment\" [0] 0 [1] 1 [n] (+ (fib2 (- n 1)) (fib2 (- n 2)))) @ The last /fib2/ example is same as below: @ (:: fib2 (-> Int Int)) (:doc^ \"Documentation comment\") (= fib2 0 0) (= fib2 1 1) (= fib2 n (+ (fib2 (- n 1)) (fib2 (- n 2)))) @ " form (let ((:: build-decls (-> Code [Code] (Fnk [Code]))) (= build-decls name (let ((= go (: args body rest) (do (<- bodies (go rest)) (return (: `(= ,name ,@args ,body) bodies)))) (= go [] (pure [])) (= go _ (finkelSrcError name "defn: wrong number of forms"))) go)) (:: build-doc (-> (Maybe Code) Code)) (= build-doc mb-doc (case mb-doc (Just doc) `((:doc^ ,doc)) Nothing nil)) (:: is-tuple (-> FastString Bool)) (= is-tuple (== (fsLit ","))) (:: is-con (-> Code Bool)) (= is-con name (case (unCode name) (Atom (ASymbol n)) (|| (isLexCon n) (is-tuple n)) _ False)) (:: build-sig (-> Code Code (Maybe Code) [Code] (Fnk Code))) (= build-sig name ty mb-doc bodies0 (do (<- bodies1 (build-decls name bodies0)) (return `(:begin (:: ,name ,ty) ,@(build-doc mb-doc) ,@bodies1)))) (:: build-nosig (-> Code (Maybe Code) [Code] (Fnk Code))) (= build-nosig name mb-doc bodies0 (let ((= go bodies (case mb-doc Nothing (| ((<- [body] bodies) (return body))) _ (return `(:begin ,@bodies ,@(build-doc mb-doc)))))) (>>= (build-decls name bodies0) go))) (:: build (-> Code (Maybe Code) [Code] (Fnk Code))) (= build sig mb-doc bodies (case (unCode sig) (List [dc name ty]) (| ((== dc '::) (build-sig name ty mb-doc bodies))) (List (: name _)) (| ((is-con name) (build-nosig sig mb-doc bodies))) (Atom _) (build-nosig sig mb-doc bodies) (HsList _) (build-nosig sig mb-doc bodies) _ (finkelSrcError sig "defn: invalid signature")))) (case (unCode form) ;; Declaration of string without documentation need to pattern match ;; before declarations with documentation, to support defining plain ;; string value without documentation. (List [_ sig body]) (build sig Nothing [nil body]) (List [_ sig (@ doc (LForm (L _ (Atom (AString {}))))) body]) (build sig (Just doc) [nil body]) (List (: _ sig (@ doc (LForm (L _ (Atom (AString {}))))) rest)) (build sig (Just doc) rest) (List (: _ sig arg rest)) (build sig Nothing (: arg rest)) _ (finkelSrcError form "defn: invalid form")))) (define-macro defn' "Macro to define a function for both of compilation time and load time. This macro uses 'eval_and_compile' and 'defn'. ==== __Syntax__ See 'defn'. ==== __Examples__ See 'defn'." form (return `(eval-and-compile (defn ,@(cdr form))))) (define-macro defn- "Macro to define a compilation time only function. This macro uses @:eval-when-compile@ and 'defn'. ==== __Syntax__ See 'defn'. ==== __Examples__ See 'defn'." form (return `(:eval-when-compile (defn ,@(cdr form))))) ================================================ FILE: finkel-core/src/Finkel/Core/Internal/Stage2.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Stage2 - module containing more macros and functions. %p(LANGUAGE FlexibleInstances TypeSynonymInstances) (module Finkel.Core.Internal.Stage2 ;; Macros defmodule macroexpand macroexpand-1 exported-macros cond-expand macro-error case-do cond heredoc lcase lefn lept ;; Functions is-atom is-pair is-list is-hslist is-symbol is-string is-char is-integer is-fractional is-unit make-symbol mb-symbol-name mb-symbol-name-fs list (Listable ..) caar cadr caaar caadr cadar caddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdar cddr cdaar cdadr cddar cdddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr map1 reduce reduce1 keep curve rev unsnoc trav1 omni omniM caris unsafeFinkelSrcError) ;; base (import Control.Exception (throw)) (import Control.Monad (>=> foldM)) (import Data.Version ((Version ..))) (import qualified System.Info) ;; finkel-kernel (import Language.Finkel) (import Language.Finkel.Form (mkLocatedForm aSymbol genSrc)) ;; Internal (import Finkel.Core.Internal.Stage0) (import Finkel.Core.Internal.Ghc.Version) (import Finkel.Core.Internal.Ghc.Compat) (:require Finkel.Core.Internal.Stage1) (eval-when [:compile] ;; base (import Prelude) ;; finkel-kernel (import Language.Finkel) (import Language.Finkel.Form (aSymbol genSrc))) ;;; ------------------------------------------------------------------------ ;;; ;;; Macros ;;; ;;; ------------------------------------------------------------------------ (defmacro macro-error "Macro for showing error in macro function. Shows an error message with the location of entire macro form. ==== __Syntax__ > MACRO-ERROR ::= 'macro-error' string ==== __Example__ Show error with non-integer literals: > (defmacro e1 [a] > (case (fromCode a) > (Just n) (toCode (:: (+ n 1) Int)) > _ (macro-error \"got non-integer literal\"))) Sample runs: >>> (macroexpand '(e1 9)) 10 >>> (macroexpand '(e1 foo)) :2:15: error: got non-integer literal " [msg] `(unsafeFinkelSrcError ,the-macro-arg ,msg)) ;;; Expression (defmacro cond "The 'cond' macro, found in many Lisp languages. The behaviour is same as wrapping the body with @case@ expression with dummy unit, or @if@ with @MultiWayIf@ GHC language extension. ==== __Syntax__ > COND ::= 'cond' CLAUSE+ > CLAUSE ::= '(' guard+ expr ')' | '[' guard+ expr ']' ==== __Examples__ Simple function with weird tests: @ (defn (:: c01 (-> Int Int Int)) [a b] (cond [(even b) b] [(odd b) (> a b) b] [otherwise a])) @ Sample run: >>> (map (c01 5) [1 .. 10]) [1,2,3,4,5,6,5,8,5,10] " body `(case () _ ,(cons '| (map1 curve body)))) (defmacroM lcase "Same as @\\\\case@ enabled with the @LambdaCase@ extension. ==== __Syntax __ > LCASE ::= PAT-EXPR+ > PAT-EXPR ::= PATTERN EXPR ==== __Example__ >>> (map (lcase 0 \"zero\" 1 \"one\" _ \"many\") [0 1 2 3] [\"zero\", \"one\", \"many\",\"many\"] " args (do (<- tmp (gensym' "lcasearg")) (pure `(\,tmp ,(cons 'case (cons tmp args)))))) (defmacroM case-do "Like @case@, but takes an expression with 'Monad' type. ==== __Syntax__ > CASE-DO ::= 'case-do' EXPR PAT-EXPR+ > PAT-EXPR ::= PATTERN EXPR ==== __Example__ Following code: @ (case-do getLine \"hello\" (putStrLn \"Hi!\") line (putStrLn (++ \"Got: \" line))) @ Is same as: @ (do (<- tmp getLine) (case tmp \"hello\" (putStrLn \"Hi!\") line (putStrLn (++ \"Got: \" line)))) @ " args (do (<- tmp gensym) (return `(do (<- ,tmp ,(car args)) (case ,tmp ,@(cdr args)))))) (defmacro lefn "Let-fn macro. Like @let@, but bindings take forms used in 'Finkel.Core.Stage1.defn'. ==== __Syntax__ > LEFN ::= 'lefn' BINDINGS BODY > BINDINGS ::= '[' BINDING* ']' | '(' BINDING* ')' > BINDING ::= '(' VAR [ARGS] expr ')' | SIG > VAR ::= varid | SIG > SIG ::= '(' '::' varid type ')' > ARGS ::= '[' varid* ']' | '(' varid* ')' ==== __Examples__ Following expresion: @ (lefn [(x 100) (:: f (-> Int Int Int)) (f [a b] (+ (* a b) 2)) ((:: g (-> Int Int)) [0] 0 [n] (+ n 1))] (g (f x 3))) @ expands to: @ (let ((= x 100) (:: f (-> Int Int Int)) (= f a b (+ (* a b) 2)) (:: g (-> Int Int)) (= g 0 0) (= g n (+ n 1))) (g (f x 3))) @" args ;; Allow empty body to support `lefn' inside `do' syntax. (let ((= binds0 (car args)) (= binds1 (if (|| (is-unit binds0) (null binds0)) '() (curve (map1 (\bind (if (caris ':: bind) bind (cons 'defn (curve bind)))) binds0)))) (= body (cdr args))) (cons 'let (cons binds1 body)))) (defmacro lept "Let-pattern macro. Like @let@, but for pattern bindings only, does not support function bindings. Patterns and expressions are concatenated to make a flat bindings list with even number of elements. The pattern in the bindings list could be a varid symbol, or a type signature list form. ==== __Syntax__ > lept ::= 'lept' BINDINGS expr > BINDINGS ::= '[' BINDING+ ']' | '(' BINDING+ ')' > BINDING ::= PATTERN expr > PATTERN ::= varid | '(' '::' varid type ')' ==== __Example__ Following expression: @ (lept [a 1 (:: b Int) 2 (, c d) (, 3 4) f (\\\\ w x y z (+ w (* x (+ y z))))] (f a b c d)) @ expands to: @ (let ((= a 1) (:: b Int) (= b 2) (= (, c d) (, 3 4)) (= f (\\\\ w x y z (+ w (* x (+ y z)))))) (f a b c d)) @" args (let ((= body (cdr args)) (= f x (, mb-expr acc) (case mb-expr (Just expr) (, Nothing (if (caris ':: x) (: x `(= ,(cadr x) ,expr) acc) (: `(= ,x ,expr) acc))) Nothing (, (Just x) acc))) (= z (, Nothing [])) (= binds ($ curve toCode snd (reduce f z) car args))) (cons 'let (cons binds body)))) ;; Auxiliary type for `heredoc'. (data DocElem (Lit String) (Var String)) ;; Auxliary functions for `heredoc'. ;;; Note [Brace character codes] ;;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;;; ;;; Using #'\123 for `{', and #'\125 for `}'. These use of character codes are ;;; workaround for text editor to avoid mismatching parentheses containing forms ;;; with literal `{' and `}' characters. When literal characters were handling ;;; properly, character codes could be replaced with literal braces. (defn (:: subst (-> Code String [DocElem])) [orig str] (let ((= go acc xs (case xs [] acc (: #'$ #'$ #'\123 rest) (case (go acc rest) (, tmp ss) (, (: #'$ #'\123 tmp) ss)) (: #'$ #'\123 rest) (let ((= (, var ys) (break (== #'\125) rest)) (= (, lit ss) (go acc (drop 1 ys)))) (if (null var) (err "empty variable") (if (null ys) (err "missing `}'") (, [] (: (Var var) (if (null lit) ss (: (Lit lit) ss))))))) (: c rest) (case (go acc rest) (, tmp ss) (, (: c tmp) ss)))) (= err (unsafeFinkelSrcError orig))) (case (go (, [] []) str) (, xs ss) (if (null xs) ss (: (Lit xs) ss))))) (defn (:: doc-elem-to-code (-> DocElem Code)) [(Lit s)] (toCode s) [(Var v)] (make-symbol v)) (defn (:: hdoc (-> [DocElem] Code)) [es] (case es [] (toCode "") [e] (doc-elem-to-code e) _ `(<> ,@(map doc-elem-to-code es)))) (defn (:: heredoc-aux (-> Code String Code)) [orig] (. hdoc (subst orig))) (defmacroM heredoc "Macro for writing literal string value with variable replacements. The `heredoc' macro takes single literal string parameter. The format of the macro expanded result preserves newlines and spaces in the input string. Additionally, special syntax @${FOO}@ could be used to embed the value of the variable named @FOO@ in the literal string. To write literal @${@, use @$${@. Literal strings, new lines and variables are concatenated with `<>'. This will enable using other type than `String' which is an instance of `Data.String.IsString' and `Semigroup' with @OverloadedStrings@ language extension. ==== __Syntax__ > HEREDOC ::= 'heredoc' string ==== __Example__ The code: > (defn main > (putStrLn (heredoc \"foo > bar > buzz\"))) will print: > foo > bar > buzz And the code: > (defn main > (lept [foo \"FOO\" > bar \"BAR\"] > (putStrLn (heredoc \"foo is ${foo} and bar is ${bar}\")))) will print: > foo is FOO and bar is BAR Using `Data.ByteString.ByteString' with @OverloadedStrings@ language extension: > %p(LANGUAGE OverloadedStrings) > > (defmodule Main > (import > (qualified Data.ByteString.Char8))) > > (defn main > (lept [foo \"overloaded bytestring\"] > (Data.ByteString.Char8.putStrLn (heredoc \"foo is ${foo}\")))) will print: > foo is overloaded bytestring " [form] (case (fromCode form) (Just s) (pure (heredoc-aux form s)) _ (finkelSrcError form "not a string"))) ;;;; Module header (defmacroM defmodule "Macro to define header of module named /NAME/. The /IMPEXP/ are forms for imports and exports. Imports and exports forms can appear in any order, and starts with one of the following symbols: [@import@]: The form elements expand to @import@ declaration. [@import-when@]: Like @import@, but the form elements are wrapped with @eval-when@ with given phases. [@require@]: The form elements expand to @:require@ declaration. [@require-and-import@]: The form elements are expanded to both @import@ and @:require@. [@export@]: The form elements expand to export entities. ==== __Syntax__ > DEFMODULE ::= 'defmodule' NAME IMPEXP* > NAME ::= modid > IMPEXP ::= '(' 'import' form+ ')' > | '(' 'import-when' phases form+ ')' > | '(' 'require' form+ ')' > | '(' 'require-and-import' form+ ')' > | '(' 'export' form* ')' ==== __Examples__ Sample module header: @ (defmodule Foo (require (Finkel.Prelude hiding (head tail))) (import-when [:compile] (Control.Monad (foldM))) (import (Control.Monad (when)) (qualified Data.ByteString as BS)) (export foo bar buzz)) @ Expands to: @ (:begin (:require Finkel.Prelude hiding (head tail)) (module Foo foo bar buzz) (eval-when [:compile] (import Control.Monad (foldM))) (import Control.Monad (when)) (import qualified Data.ByteString as BS) (import Control.Monad (foldM))) @ " form (case (unCode form) (List [name]) (return `(module ,name)) (List (: name rest1)) (do (let ((= merge-sections acc lst (let ((= label (car lst)) (= payload (cdr lst))) (case () _ (| ((== label 'export) (return (if (null (cdr lst)) (: (, 'export (cons '() nil)) acc) (: (, 'export payload) acc)))) ((|| (== label 'use) (== label 'import)) (return (: (, 'import (map1 (\es `(import ,@(curve-el es))) payload)) acc))) ((|| (== label 'load) (== label 'require)) (return (: (, ':require (map1 (\es `(:require ,@es)) payload)) acc))) ((|| (== label 'require-and-import) (== label 'load-use)) (return (: (, 'require-and-import payload) acc))) ((== label 'import-when) (let ((= phases (car payload)) (= body0 (cdr payload)) (= body1 (map1 (\e `(import ,@(curve-el e))) body0))) (return (: (, 'eval-when (cons phases body1)) acc)))) (otherwise (finkelSrcError lst "defmodule: unknown section")))))) (= curve-el (map1 curve)))) (<- alist (foldM merge-sections [] rest1)) (let ((= emit add-load-too header (let ((= e1 (maybe nil id (lookup header alist))) (= e2 (maybe nil (map1 (\es `(,header ,@es))) (lookup 'require-and-import alist)))) (if add-load-too (mappend e1 e2) e1))))) (return `(:begin ,@(emit True ':require) (module ,name ,@(emit False 'export)) ,@(let ((= evalwhens (filter (\ (, k _) (== k 'eval-when)) alist)) (= f (, _ phases-mdls) (let ((= phases (car phases-mdls)) (= mdls (cdr phases-mdls))) `(eval-when ,phases ,@mdls)))) (map f evalwhens)) ,@(emit True 'import)))) _ (finkelSrcError form "defmodule: invalid form"))) ;;; Compilation context macros (defn (:: cond-expand-aux (-> HscEnv Code (Fnk Code))) "Auxiliary function for `cond-expand'." [hsc-env] (let ((= f x (case () _ (| ((== x ':ghc) (pure `(:: ,__glasgow_haskell__ Int))) ((== x ':os) (pure `(:: ,(toCode System.Info.os) String))) ((== x ':arch) (pure `(:: ,(toCode System.Info.arch) String))) ((caris ':min-version x) (do (<- v (getPackageVersion hsc-env (cadr x))) (pure `(<= (:: [,@(cddr x)] [Int]) ,(versionBranch v))))) (otherwise (pure x)))))) (omniM f))) (defmacroM cond-expand "Macro for conditional compilation. The `cond-expand' macro has same syntax as the `cond' macro, but the evaluation of the tests are done at compilation time. To gather compilation context information, the tests sections in the `cond-expand' macro uses special keywords for getting such information. These keywords are replaced by the described values: [@:ghc@]: An `Int' value from @__GLASGOW_HASKELL__@, which is the major version of the @ghc@ used during the compilation. [@:arch@]: A `String' value from `System.Info.arch'. [@:os@]: A `String' value from `System.Info.os'. [@(:min-version \"@PKGNAME@\" V1 V2 V3 ...)@]: An expression resulting as a `Bool' value. Compares the version of @PKGNAME@ with the version made from integer values @V1@, @V2@, @V3@ and so on. This keyword resembles to the @MIN_VERSION@ CPP macro. ==== __Syntax__ See `cond'. ==== __Examples__ Simple usage to show message: @ (defn (:: msg String) (cond-expand [(<= 810 :ghc) \"ghc is newer than 8.10.0\"] [(== 808 :ghc) (== :arch \"x86_64\") (== :os \"linux\") \"ghc version 8.8.x, x86_64-linux\"] [(:min-version \"base\" 4 0 0) \"base version newer than or equals to 4.0.0\"] [otherwise \"unknown\"])) @ When compiling above with ghc version @8.8.4@ on @x86_64@ machine running @Linux@, the second test will pass and the expanded result would be: @ (defn (:: msg String) \"ghc version 8.8.x, x86_64-linux\" @ " forms (do (<- tmp (gensym' "cond-expand-tmp")) (<- hsc-env getSession) (let ((= make-quoted-last branches (case (unsnoc branches) (, bs b) (do (<- bs2 (cond-expand-aux hsc-env bs)) (pure `(,bs2 ',b))))))) (<- body (trav1 make-quoted-last forms)) (pure `(macrolet [(,tmp [] (cond ,@body))] (,tmp))))) ;;; Macros for macros (defmacroM macroexpand-1 "Expand given form if the given form is a macro, otherwise return the given form. Note that 'macroexpand_1' and 'macroexpand' are macros, not functions. ==== __Syntax__ > MACROEXPAND-1 ::= 'macroexpand-1' form ==== __Examples__ >>> (macroexpand-1 '(defmacrom' m1 [x] `(+ ,x 1))) (eval_and_compile (defmacro m1 [x] (:quasiquote (+ (:unquote x) 1)))) " [form] (case (unCode form) (List [q x]) (| ((|| (== q ':quote) (== q ':quasiquote)) (do (<- expanded (expand1 x)) (return `',expanded)))) _ (return form))) (defmacroM macroexpand "Macro for expanding macro. This macro recursively expands all sub forms. ==== __Syntax__ > MACROEXPAND ::= 'macroexpand' form ==== __Examples__ >>> (macroexpand '(defn (:: foo (-> Int Int Int)) [a b] (+ a (* b 2)))) (:begin (:: foo (-> Int Int Int)) (= foo a b (+ a (* b 2)))) " [form] (case (unCode form) (List [q x]) (| ((|| (== q ':quote) (== q ':quasiquote)) (let ((= go expr (do (<- expr' (expand1 expr)) (if (== expr expr') (return `',expr) (go expr'))))) (go x)))) _ (return form))) (defmacroM exported-macros "Macro to return macro names exported from given module as a list of 'String'. ==== __Syntax__ > EXPORTED-MACROS ::= 'exported-macros' modid ==== __Examples__ Listing exported macros in \"Finkel.Core\" module: >>> (exported-macros Finkel.Core) [\"eval_when\",\"eval_and_compile\", ...] " [name] (let ((= f hsc-env mb-thing acc (case mb-thing (Just (@ thing (AnId var))) (| ((isMacro hsc-env thing) (: (showSDoc (hsc-dflags hsc-env) (ppr (varName var))) acc))) _ acc)) (= get-exported-names name-str (do (<- mdl (lookupModule (mkModuleName name-str) Nothing)) (<- mb-mod-info (getModuleInfo mdl)) (case mb-mod-info Nothing (return []) (Just mi) (do (<- mb-things (mapM lookupName (modInfoExports mi))) (<- hsc-env getSession) (return (foldr (f hsc-env) [] mb-things)))))) (= invalid-err (++ "exported-macros: got non-module name symbol `" (show name) "'")) (= toCodes (. toCode (map toCode)))) (case (mb-symbol-name name) (Just name-str) (do (<- names (get-exported-names name-str)) (return `(:: ,(toCodes names) [String]))) Nothing (finkelSrcError name invalid-err)))) ;;; ------------------------------------------------------------------------ ;;; ;;; Functions ;;; ;;; ------------------------------------------------------------------------ ;;; Predicates (defn (:: is-atom (-> Code Bool)) "True when the argument is an 'Atom' or 'nil'. ==== __Examples__ >>> (is-atom \'foo) True >>> (is-atom nil) True >>> (is-atom '(a b c)) False >>> (is-atom '[a b c]) False" [(LForm (L _ form))] (case form (Atom _) True (List []) True _ False)) %p(INLINABLE is-atom) (defn (:: is-pair (-> Code Bool)) "True when the argument is a non-nil 'List'." [(LForm (L _ (List (: _ _))))] True [_] False) %p(INLINABLE is-pair) (macrolet [(defpred [doc name pat] `(:begin (:doc ,doc) (:: ,name (-> Code Bool)) (= ,name (LForm (L _ form)) (case form ,pat True _ False))))] (defpred "True when the argument is a `List'." is-list (List _)) (defpred "True when the argument is a `HsList'." is-hslist (HsList _)) (defpred "True when the argument is an `Atom' of `ASymbol'." is-symbol (Atom (ASymbol _))) (defpred "True when the argument is an `Atom' of `AString'." is-string (Atom (AString _ _))) (defpred "True when the argument is an `Atom' of `AChar'." is-char (Atom (AChar _ _))) (defpred "True when the argument is an `Atom' of `AInteger'." is-integer (Atom (AInteger _))) (defpred "True when the argument is an `Atom' of `AFractional'." is-fractional (Atom (AFractional _))) (defpred "True when the argument is an `Atom' of `AUnit'." is-unit (Atom AUnit))) (defn (:: caris (-> Code Code Bool)) "`True' when the first argument equal to the `car' of the second argument. ==== __Examples__ >>> (caris 'foo '(foo bar buzz)) True >>> (caris 'foo '(a b c)) False >>> (caris 'foo 'foo) False" [x lst] (&& (is-list lst) (== (car lst) x))) %p(INLINABLE caris) ;;; Symbol functions (defn (:: make-symbol (-> String Code)) "Make an `Atom' of `ASymbol' from given `String'." (. LForm genSrc Atom aSymbol)) %p(INLINABLE make-symbol) (defn (:: mb-symbol-name (-> Code (Maybe String))) "Extract string from given symbol. Get `Just' `String' when the argument code was an `ASymbol', otherwise `Nothing'." (. (fmap unpackFS) mb-symbol-name-fs)) %p(INLINABLE mb-symbol-name) (defn (:: mb-symbol-name-fs (-> Code (Maybe FastString))) "Extract `FastString' from given symbol. Like `mb_symbol_name', but returns `FastString'" [form] (case form (LForm (L _ (Atom (ASymbol name)))) (Just name) _ Nothing)) %p(INLINABLE mb-symbol-name-fs) ;;; Constructing list (:doc "Type class for constructing 'List' with polyvariadic function.") (class (Listable l) (:: list_ (-> [Code] l))) (instance (Listable Code) (= list_ xs (case (mkLocatedForm (reverse xs)) (L l ys) (LForm (L l (List ys)))))) (instance (=> (Homoiconic elem) (Listable l) (Listable (-> elem l))) (= list_ acc (\x (list_ (: (toCode x) acc))))) (defn (:: list (=> (Listable lst) lst)) "Make a list from given arguments. This function can take variable number of arguments, but requires resulting type to be a concrete type. ==== __Examples__ >>> (:: (list \'a \'b \'c) Code) (a b c) >>> (:: (list \'a #\'b \"c\" (:: 0xd Int)) Code) (a #\'b \"c\" 13)" (list_ [])) ;;; CXR (:doc$ cxr "Rest of /cxr/ functions are composed from 'car' and 'cdr'. E.g., definition of 'cadr' is: > (cadr x) == (car (cdr x)) and the definition of 'cdadr' is: > (cdadr x) == (cdr (car (cdr x))) ") (eval-when [:compile] (defn (:: ads [String]) (let ((= f (concatMap (\x [(: #'a x) (: #'d x)])))) (concat (take 3 (drop 1 (iterate f [[#'a] [#'d]])))))) (defn (:: cxr-name (-> String Code)) [x] ($ LForm genSrc Atom aSymbol concat ["c" x "r"])) (defn (:: doc (-> String Code)) [xs] (let ((= f x (++ "`c" x "r'")) (= g ys (foldr1 (\y acc (++ y " of " acc)) (map (. f pure) ys)))) (toCode (++ "Get the " (g xs) ".")))) (defn (:: cxr (-> String [Code])) [xs] (let ((= name (cxr-name xs))) (case xs (: hd tl) [`(:doc ,(doc xs)) `(:: ,name (-> Code Code)) `(= ,name (. ,(cxr-name [hd]) ,(cxr-name tl))) `%p(INLINABLE ,name)] _ (error (++ "cxr: invalid arg: " xs))))) (defmacro cxrs [] `(:begin ,@(concatMap cxr ads)))) (cxrs) ;;; List and HsList functions (defn (:: make-list-fn (-> (-> Code b) (-> (-> [(LForm a)] (LForm a)) [Code] b) Code b)) "Auxiliary function for making higher order function. Make a function taking `SrcSpan' and a list of `Code' from given arguments." [g f (@ orig (LForm (L l form)))] (case form (List xs) (f (. LForm (L l) List) xs) (HsList xs) (f (. LForm (L l) HsList) xs) _ (g orig))) %p(INLINE make-list-fn) (defn (:: map1 (-> (-> Code Code) Code Code)) "Like `map', but for `Code'. @map f x@ applies the function @f@ to each element of @x@ when the @x@ is `List' or `HsList'. Otherwise directly applies @f@ to @x@. ==== __Examples__ >>> (map1 (\\ x `(x is ,x)) '(foo bar buzz)) ((x is foo) (x is bar) (x is buzz)) >>> (map1 (\\ x `(x is ,x)) 'foo) (x is foo)" [f] (make-list-fn f (\c (. c (map f))))) %p(INLINABLE map1) (defn (:: reduce (-> (-> Code a a) a Code a)) "Like `foldr', but for `Code'. If the second argument was not a list, applies the function to the second argument and the initial value. ==== __Examples__ >>> (reduce cons nil '(a b c)) (a b c) >>> (reduce (\\ x acc (cons `(x is ,x) acc)) nil '(a b c)) ((x is a) (x is b) (x is c)) >>> (reduce + 0 '(1 2 3 4 5)) 15 >>> (reduce cons nil 'foo) (foo)" [f z] (make-list-fn (flip f z) (\_ (foldr f z)))) %p(INLINABLE reduce) (defn (:: reduce1 (-> (-> Code Code Code) Code Code)) "Like `foldr1', but for `Code'. Throws an exception if the second argument was not a list. ==== __Examples__ >>> (reduce1 cons '(a b c)) (a b c) >>> (reduce1 (\\ x acc (cons `(x is ,x) acc)) '(a b c)) ((x is a) (x is b) c) >>> (reduce1 cons 'foo) *** Exception: reduce1: non-list value `foo'" [f] (make-list-fn (non-list "reduce1") (\_ (foldr1 f)))) %p(INLINABLE reduce1) (defn (:: keep (-> (-> Code Bool) Code Code)) "Like `filter', but for `Code'. Filter out immediate elements of `List' if the test result is `False'. ==== __Examples__ >>> (keep (/= 'a) '(a b r a c a d a b r a)) (b r c d b r) >>> (keep (/= 'a) 'foo) *** Exception: keep: non-list value `foo'" [test] (make-list-fn (non-list "keep") (\c (. c (filter test))))) %p(INLINABLE keep) (defn (:: curve (-> Code Code)) "Convert `HsList' to `List'. The original value is retained if the given argument was not a `HsList' value. ==== __Examples__ >>> (curve '[a b c]) (a b c) >>> (curve 'foo) foo" [(@ orig (LForm (L l form)))] (case form (HsList xs) (LForm (L l (List xs))) _ orig)) %p(INLINABLE curve) (defn (:: rev (-> Code Code)) "Like `reverse', but for `Code'. Reverse the given `List' or `HsList'. Other values are kept as-is. ==== __Examples__ >>> (rev '(a b c)) (c b a) >>> (rev 'foo) foo" (make-list-fn id (\c (. c reverse)))) %p(INLINABLE rev) (defn (:: unsnoc (-> Code (, Code Code))) "Split `List' and `HsList' to the elements but last and the last element. ==== __Examples__ >>> (unsnoc '(a b c d e)) ((a b c d),e)" [form] (case (rev form) mrof (, (rev (cdr mrof)) (car mrof)))) %p(INLINABLE unsnoc) (defn (:: trav1 (=> (Applicative f) (-> (-> Code (f Code)) Code (f Code)))) "Like `traverse', but for `Code'. Applies given function to the direct element of the given `Code'. ==== __Examples__ >>> (trav1 (\\ x (>> (print x) (pure x))) '(a (b c) d)) a (b c) d (a (b c) d) >>> (trav1 Just 'foo) Just foo" [f] (make-list-fn f (\c (. (fmap c) (traverse f))))) %p(INLINABLE trav1) (defn (:: omni (-> (-> Code Code) Code Code)) "Applies given function to every elements. ==== __Examples__ >>> (omni (\\ x (if (== 'foo x) 'bar x)) '(a foo (foo b c) (d foo))) (a bar (bar b c) (d bar)) >>> (omni (\\ x (if (caris 'foo x) (cons 'bar (cdr x)) x)) '(a foo (foo b c) (d foo))) (a foo (bar b c) (d foo)) >>> (omni (\\ x (if (== x 'foo) 'bar x)) 'foo) bar >>> (omni (\\ x (if (== x 'foo) 'bar x)) nil) nil" [f] (make-list-fn f (\c (. f c (map (omni f)))))) %p(INLINABLE omni) (defn (:: omniM (=> (Monad m) (-> (-> Code (m Code)) Code (m Code)))) "Applies given monadic function to every elements. ==== __Examples__ >>> (omniM (\\ x (>> (print x) (return x))) '(a (b c) d)) a b c (b c) d (a (b c) d) (a (b c) d) " [f] (make-list-fn f (\c (>=> (traverse (omniM f)) (. f c))))) %p(INLINABLE omniM) ;;; Error (defn (:: unsafeFinkelSrcError (-> Code String a)) "Throw exception with 'FinkelSrcError', with given code and message. This function uses `Control.Exception.throw' from the @base@ package." (. (fmap throw) FinkelSrcError)) ================================================ FILE: finkel-core/src/Finkel/Core/Internal.hs ================================================ ;;; -*- mode: finkel -*- ;;;; For internal types and functions (:doc "Module to re-export internal types and functions. The intended usage is for internal use only, from test codes and from the @finkel-tool@ package.") (module Finkel.Core.Internal (:dh1 "For GHC") (module Finkel.Core.Internal.Ghc)) (import Finkel.Core.Internal.Ghc) ================================================ FILE: finkel-core/src/Finkel/Core/Plugin.hs ================================================ ;;; -*- mode: finkel -*- (:doc "GHC plugin for compiling Finkel source codes.") (module Finkel.Core.Plugin plugin coreFnkEnv) ;;; finkel-kernel (import Language.Finkel (defaultFnkEnv)) (import Language.Finkel.Fnk ((FnkEnv ..) (FnkInvokedMode ..) makeEnvMacros mergeMacros)) (import Language.Finkel.Plugin (pluginWith)) (import Language.Finkel.SpecialForms (specialForms)) ;;; Internal (import Finkel.Core) (import Finkel.Core.Internal.Ghc) ;;; Compile time modules (:require Finkel.Core) (:eval-when-compile (import Prelude) (import Language.Finkel) (import Finkel.Core.Internal.Stage2)) ;;; The plugin function (:doc "The plugin to compile Finkel source code. This plugin could not be loaded before the /downsweep/ phase of the ghc compilation manager, need other way to parse the module header to resolve the home package module dependencies.") (:: plugin Plugin) (= plugin (pluginWith "Finkel.Core.Plugin" coreFnkEnv)) (:doc "The `FnkEnv' containing the macros from `Finkel.Core'.") (:: coreFnkEnv FnkEnv) (= coreFnkEnv (macrolet [(core-macros () `[,@(map (\mac `(, ,mac ,(make-symbol mac))) (exported-macros Finkel.Core))])] (let ((= coreMacros (makeEnvMacros (core-macros))) (= myMacros (mergeMacros specialForms coreMacros))) (defaultFnkEnv {(= envMacros myMacros) (= envDefaultMacros myMacros) (= envInvokedMode GhcPluginMode)})))) ================================================ FILE: finkel-core/src/Finkel/Core.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Finkel core language macros (:doc "Core language macros. Macros exported from this module are available in the @finkel@ executable by default, i.e., available without /require/-ing the \"Finkel.Core\" module.") (module Finkel.Core (:dh1 "Phase control") eval-when eval-and-compile (:dh1 "Module header") defmodule (:dh1 "Macro for macros") defmacro defmacro' defmacro- defmacroM defmacroM' defmacroM- (:dh1 "Temporary macros") macrolet macroletM (:dh1 "Declaring functions") defn defn' defn- (:dh1 "Expanding macros") macroexpand macroexpand-1 exported-macros (:dh1 "Compilation context macros") cond-expand (:dh1 "Error macro") macro-error (:dh1 "Expressions") case-do cond heredoc lcase lefn lept) ;; Internal (import Finkel.Core.Internal.Stage1) (import Finkel.Core.Internal.Stage2) ================================================ FILE: finkel-core/src/Finkel/Prelude.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Prelude module for Finkel. (:doc "Module exporting fundamental functions to work with Finkel macros. This module does not export macros, but functions to work with `Code' values for defining macros. Intended usage is to import during compilation: > (defmodule MyModule > (import-when [:compile] > (Finkel.Prelude)) > ...) to use functions for `Code', such as `cons', `car', `cdr', and so on.") (module Finkel.Prelude (:dh1 "Re-exported modules") (module Me)) (import Prelude as Me) ; base (import Language.Finkel as Me) ; finkel-kernel (import Finkel.Core.Functions as Me) ; Internal ================================================ FILE: finkel-core/test/CoreTest.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Module to test macros. (:require Finkel.Core) (defmodule CoreTest (export coreTests macroTests) (require ;; Internal (TestAux)) (import-when [:compile] ;; Internal (Finkel.Prelude)) (import ;; base (Control.Exception [(SomeException)]) (Data.List [isSubsequenceOf]) (System.Info [os arch]) ;; hspec (Test.Hspec) ;; finkel-kernel (Language.Finkel) (Language.Finkel.Form [aString aIntegral]) (Language.Finkel.Fnk [(FnkEnv ..) makeEnvMacros mergeMacros]) ;; finkel-core (Finkel.Core) (Finkel.Core.Functions [cadr]) (Finkel.Core.Internal) ;; Internal (TestAux))) (defn (:: coreTests Spec) (describe "Macro" macroTests)) (defn (:: subseqErr (-> String SomeException Bool)) [str e] (isSubsequenceOf str (show e))) (defn (:: macroTests Spec) (do (describe "eval-when" (do (it "should expand to (:begin (:eval-when-compile ...) ...)" (expandTo (eval-when (:compile :load) (:: foo Int) (= foo 42)) (:begin (:eval-when-compile (:: foo Int) (= foo 42)) (:: foo Int) (= foo 42)))) (it "should expand to (:eval-when-compile ...)" (expandTo (eval-when (:compile) (:: foo Int) (= foo 42)) (:eval-when-compile (:: foo Int) (= foo 42)))) (it "should expand to (:begin ...)" (expandTo (eval-when (:load) (:: foo Int) (= foo 42)) (:begin (:: foo Int) (= foo 42)))) (it "should support phases in bracket" (expandTo (eval-when [:compile :load] (= foo True)) (:begin (:eval-when-compile (= foo True)) (= foo True)))) (it "throws an exception with unknown phase" (expandFailureWith (eval-when (:foo :bar :buzz) (:: foo Int) (= foo 42)) (subseqErr "invalid phase"))) (it "throws and exception on non-list phase" (expandFailureWith (eval-when :compile (:: foo Int) (= foo 42)) (subseqErr "eval-when"))))) (describe "eval-and-compile" (it "should expand to (eval-when ...)" (expandTo (eval-and-compile (:: foo Int) (= foo 42)) (eval-when [:compile :load] (:: foo Int) (= foo 42))))) (describe "defmacroM" (do (it "should expand to Macro" (expandTo (defmacroM m1 (a) (return `(putStrLn (++ "hello, " ,a)))) (:begin (:: m1 Macro) (= m1 (let ((:: $tmp (-> Code (Fnk Code))) (= $tmp __form__ (case __form__ (LForm (L _loc (List [_ a]))) (let ((= $tmp (return (:quasiquote (putStrLn (++ "hello, " (:unquote a))))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `m1'\ninvalid form: `" (show __form__) "'"))))) (Macro $tmp)))))) (it "should replace nil arg with _" (expandTo (defmacroM m1 () (return `(print True))) (:begin (:: m1 Macro) (= m1 (let ((:: $tmp (-> Code (Fnk Code))) (= $tmp __form__ (case __form__ (LForm (L _loc (List [_]))) (let ((= $tmp (return (:quasiquote (print True))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `m1'\ninvalid form: `" (show __form__) "'"))))) (Macro $tmp)))))) (it "should expand symbol arg to rest" (expandTo (defmacroM m1 args (return `(print ,@args))) (:begin (:: m1 Macro) (= m1 (let ((:: $tmp (-> Code (Fnk Code))) (= $tmp __form__ (case __form__ (LForm (L $loc (List (: _ __arg__)))) (let ((= args (LForm (L $loc (List __arg__)))) (= $tmp (return (:quasiquote (print (:unquote-splice args)))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `m1'\ninvalid form: `" (show __form__) "'"))))) (Macro $tmp)))))) (it "should allow names with operator symbol" (expandTo (defmacroM $$$ () (return `(print True))) (:begin (:: $$$ Macro) (= $$$ (let ((:: $tmp (-> Code (Fnk Code))) (= $tmp __form__ (case __form__ (LForm (L _loc (List [_]))) (let ((= $tmp (return (:quasiquote (print True))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `$$$'\ninvalid form: `" (show __form__) "'"))))) (Macro $tmp)))))) (it "should replace gensym name with hyphens" (expandTo (defmacroM m1 [a] (return `(let ((= $b-c-d (* ,a 2))) (+ $b-c-d $b-c-d)))) (:begin (:: m1 Macro) (= m1 (let ((:: $tmp (-> Code (Fnk Code))) (= $tmp __form__ (case __form__ (LForm (L _loc (List [_ a]))) (let ((= $tmp (return (:quasiquote (let ((= $b_c_d (* (:unquote a) 2))) (+ $b_c_d $b_c_d)))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `m1'\ninvalid form: `" (show __form__) "'"))))) (Macro $tmp)))))) (it "should not replace operator starting with `$'" (expandTo (defmacroM m1 [a] (return `($$ print show ,a))) (:begin (:: m1 Macro) (= m1 (let ((:: $tmp (-> Code (Fnk Code))) (= $tmp __form__ (case __form__ (LForm (L _loc (List [_ a]))) (let ((= $tmp (return (:quasiquote ($$ print show (:unquote a)))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `m1'\ninvalid form: `" (show __form__) "'"))))) (Macro $tmp)))))) (it "should expand documentation arg" (expandTo (defmacroM m1 "doccomments" [] (return '(print True))) (:begin (:: m1 Macro) (:doc^ "doccomments") (= m1 (let ((:: $tmp (-> Code (Fnk Code))) (= $tmp __form__ (case __form__ (LForm (L _loc (List [_]))) (let ((= $tmp (return (:quote (print True))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `m1'\ninvalid form: `" (show __form__) "'"))))) (Macro $tmp_12Jw)))))) (it "should detect invalid arg" (expandFailureWith (defmacroM m1 "string" (return 'True)) (subseqErr "defmacroM"))) (it "should detect invalid form" (expandFailure (defmacroM m1 too many parameters passed))) (it "should detect invalid doc arg" (expandFailure (defmacroM m1 [a b] [c d] `[,a ,b ,c ,d]))))) (describe "defmacroM'" (it "expands to (eval-when (...) (defmacroM ...))" (expandTo (defmacroM' m1 (a) `(return (putStrLn ,a))) (eval-and-compile (defmacroM m1 (a) (:quasiquote (return (putStrLn (:unquote a))))))))) (describe "defmacroM-" (it "expands to (:eval-when-compile (defmacroM ...)" (expandTo (defmacroM- m1 [a] (return `(putStrLn ,a))) (:eval-when-compile (defmacroM m1 [a] (return (:quasiquote (putStrLn (:unquote a))))))))) (describe "defmacro" (do (it "should expand to defmacroM" (expandTo (defmacro m1 (a) `(putStrLn (++ "hello, " ,a))) (:begin (:: m1 Macro) (= m1 (let ((:: $tmp (-> Code (Fnk Code))) (= $tmp __form__ (case __form__ (LForm (L _loc (List [_ a]))) (let ((= $tmp (return (:quasiquote (putStrLn (++ "hello, " (:unquote a))))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `m1'\ninvalid form: `" (show __form__) "'"))))) (Macro $tmp)))))) (it "should fail with invalid form" (expandFailureWith (defmacro m1 [arg1 arg2] too many body forms) (subseqErr "defmacro"))))) (describe "defmacro'" (it "expands to (eval-and-compile (...) (defmacro ...))" (expandTo (defmacro' m1 (a) `(putStrLn ,a)) (eval-and-compile (defmacro m1 (a) (:quasiquote (putStrLn (:unquote a)))))))) (describe "defmacro-" (it "expands to (:eval-when-compile (...) (defmacro ...))" (expandTo (defmacro- m1 (a) `(putStrLn ,a)) (:eval-when-compile (defmacro m1 (a) (:quasiquote (putStrLn (:unquote a)))))))) (describe "macro containing `$foo'" (it "should replace `$foo' with gensym" (do (let ((= f code (runFnk (macroFunction defmacroM code) defaultFnkEnv)))) (<- e (f '(defmacroM m1 (a b) (let ((= $foo (+ ,a ,b))) (return $foo))))) (shouldNotBe (elem (ASymbol (fsLit "$foo")) e) True)))) (describe "macroletM" (do (it "should expand to :with-macro" (expandTo (macroletM [(m1 [a b] (return `(+ ,a ,b)))] (m1 20 22)) (:with-macro ((= m1 (let ((:: $m1 (-> Code (Fnk Code))) (= $m1 __form__ (case __form__ (LForm (L _loc (List [_ a b]))) (let ((= $tmp (return (:quasiquote (+ (:unquote a) (:unquote b)))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `m1'\ninvalid form: `" (show __form__) "'"))))) (Macro $m1)))) (m1 20 22)))) (it "should replace () arg with _" (expandTo (macroletM ((m1 () (return `(print #'x)))) (m1)) (:with-macro ((= m1 (let ((:: $m1 (-> Code (Fnk Code))) (= $m1 __form__ (case __form__ (LForm (L _loc (List [_]))) (let ((= $tmp (return (:quasiquote (print #'x))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `m1'\ninvalid form: `" (show __form__) "'"))))) (Macro $m1)))) (m1)))) (it "should detect invalid form" (expandFailureWith (macroletM) (subseqErr "macroletM"))) (it "should detect invalid local macro form" (expandFailureWith (macroletM ((m1 () foo bar buzz)) (m1)) (subseqErr "invalid form"))))) (describe "macrolet" (do (it "should expand to macro with `return'" (expandTo (macrolet ((m (a b) `(+ ,a ,b))) (m 20 22)) (:with-macro ((= m (let ((:: $m (-> Code (Fnk Code))) (= $m __form__ (case __form__ (LForm (L _loc (List [_ a b]))) (let ((= $tmp (return (:quasiquote (+ (:unquote a) (:unquote b)))))) $tmp) _ (finkelSrcError __form__ (++ "in macro `m'\ninvalid form: `" (show __form__) "'"))))) (Macro $m)))) (m 20 22)))) (it "should detect invalid form" (expandFailureWith (macrolet) (subseqErr "macrolet"))))) (describe "macro-error" (it "should expand to (unsafeFinkelSrcError ...)" (expandTo (macro-error "message") (unsafeFinkelSrcError __form__ "message")))) (describe "defn" (do (it "should expand to function declaration" (expandTo (defn foo (a b) (+ a b)) (= foo a b (+ a b)))) (it "should expand to function with type signature" (expandTo (defn (:: foo (-> Int Int Int)) (a b) (+ a b)) (:begin (:: foo (-> Int Int Int)) (= foo a b (+ a b))))) (it "should expand to function with no arguments" (expandTo (defn foo 42) (= foo 42))) (it "should expand to string" (expandTo (defn foo "bar") (= foo "bar"))) (it "should expand to pattern match for `Just'" (expandTo (defn (Just foo) (pure True)) (= (Just foo) (pure True)))) (it "should expand to pattern match for list" (expandTo (defn [a b c] ["foo" "bar" "buzz"]) (= [a b c] ["foo" "bar" "buzz"]))) (it "should expand to pattern match for list with rest" (expandTo (defn (: a b c _) [1 2 ..]) (= (: a b c _) [1 2 ..]))) (it "should expand to pattern match for tuple" (expandTo (defn (, a b c) (, True #'x "string")) (= (, a b c) (, True #'x "string")))) (it "should expand argument patterns" (expandTo (defn foo [a 0] (* a 2) [a b] (+ a b)) (:begin (= foo a 0 (* a 2)) (= foo a b (+ a b))))) (it "should expand argument patterns with type signature" (expandTo (defn (:: foo (-> Int Int Int)) [a 0] (* a 2) [a b] (+ a b)) (:begin (:: foo (-> Int Int Int)) (= foo a 0 (* a 2)) (= foo a b (+ a b))))) (it "should expand doc without type signature" (expandTo (defn foo "doc" 42) (:begin (= foo 42) (:doc^ "doc")))) (it "should expand doc with type signature" (expandTo (defn (:: foo Int) "doc" 42) (:begin (:: foo Int) (:doc^ "doc") (= foo 42)))) (it "should detect invalid form" (expandFailureWith (defn foo) (subseqErr "defn"))) (it "should fail on invalid signature" (expandFailureWith (defn (foo (Int) (Int)) (a b) (+ a b)) (subseqErr "invalid signature"))) (it "should fail on odd number of body forms" (expandFailureWith (defn (:: foo (-> Int Int)) 0 1 2 3 4) (subseqErr "wrong number of forms"))))) (describe "defn'" (it "should expand to (eval-and-compile (..) (defn ...))" (expandTo (defn' foo (a b) (+ a b)) (eval-and-compile (defn foo (a b) (+ a b)))))) (describe "defn-" (it "should expand to (:eval-when-compile (defn ...))" (expandTo (defn- foo [a b] (+ a b)) (:eval-when-compile (defn foo [a b] (+ a b)))))) (describe "cond" (it "should expand to case" (expandTo (cond [(even x) 0] [otherwise 1]) (case () _ (| ((even x) 0) (otherwise 1)))))) (describe "lcase" (it "should expand to lambda with case" (expandTo (lcase (Right a) "a" (Left b) "b") (\ $tmp (case $tmp (Right a) "a" (Left b) "b"))))) (describe "case-do" (it "should expand to do with case" (expandTo (case-do getLine "hello" (putStrLn "hi") line (putStrLn (++ "Got: " line))) (do (<- $tmp getLine) (case $tmp "hello" (putStrLn "hi") line (putStrLn (++ "Got: " line))))))) (describe "heredoc" (do (it "should expand to literal string" (expandTo (heredoc "literal string") "literal string")) (it "should concat multiple lines" (cond-expand [(== :os "mingw32") (expandTo (heredoc "foo bar buzz") "foo\r\n bar\r\n buzz")] [otherwise (expandTo (heredoc "foo bar buzz") "foo\n bar\n buzz")])) (it "should preserve newline at the end" (cond-expand [(== :os "mingw32") (expandTo (heredoc "foo ") "foo\r\n")] [otherwise (expandTo (heredoc "foo ") "foo\n")])) (it "should replace variable" (expandTo (heredoc "foo is ${foo}") (<> "foo is " foo))) (it "should replace multiple variables" (expandTo (heredoc "foo=${foo} bar=${bar} buzz=${buzz}") (<> "foo=" foo " bar=" bar " buzz=" buzz))) (it "should replace variable without literal" (expandTo (heredoc "${foo}") foo)) (it "should escape variable replacement" (expandTo (heredoc "escaping $${var}") "escaping ${var}")) (it "should result to empty string" (expandTo (heredoc "") "")) (it "should show error with empty variable name" (expandFailureWith (heredoc "empty var ${}") (subseqErr "empty variable"))) (it "should show error with unbalanced brace" (expandFailureWith (heredoc "unbalanced ${foo") (subseqErr "missing"))) (it "should show error on non-string parameters" (expandFailureWith (heredoc 42) (subseqErr "not a string"))))) (describe "lefn" (do (it "should expand to let" (expandTo (lefn [(v1 1) ((:: v2 Int) 2) (:: f (-> Int Int)) (f [0] 0 [1] 1 [n] (+ (f (- n 1)) (f (- n 2)))) ((:: g (-> Int Int)) [n] (+ n 1))] (f (g (+ v1 v2)))) (let ((defn v1 1) (defn (:: v2 Int) 2) (:: f (-> Int Int)) (defn f [0] 0 [1] 1 [n] (+ (f (- n 1)) (f (- n 2)))) (defn (:: g (-> Int Int)) [n] (+ n 1))) (f (g (+ v1 v2)))))) (it "should expand to let without body" (expandTo (lefn [(a 1) (b 2)]) (let ((defn a 1) (defn b 2))))) (it "should expand to let with empty binds" (expandTo (lefn [] True) (let () True))) (it "should expand to let with units" (expandTo (lefn () True) (let () True))))) (describe "lept" (do (it "should expand to let" (expandTo (lept [a 1 b 2 c 3] (+ a b c)) (let ((= a 1) (= b 2) (= c 3)) (+ a b c)))) (it "should expand to let with signatures" (expandTo (lept [(:: a Int) 1 (:: b Double) 1] (>> (print a) (print b))) (let ((:: a Int) (= a 1) (:: b Double) (= b 1)) (>> (print a) (print b))))))) (describe "macroexpand-1" (do (it "should expand to '(toCode 3)" (expandTo (macroexpand-1 '(:quasiquote (:unquote 3))) '(toCode 3))) (it "should expand to '(toCode 4)" (expandTo (macroexpand-1 `(:quasiquote (:unquote 4))) '(toCode 4))) (it "should expand to (car nil)" (expandTo (macroexpand-1 (car nil)) (car nil))) (it "should expand to itself" (expandTo (macroexpand-1 42) 42)) (it "should expand to form containing :begin" (lept [m1 (Macro (\form (return `(:begin (:: foo String) (= foo ,(show (cadr form))))))) my-macros (mergeMacros (envMacros defaultFnkEnv) (makeEnvMacros [(, "m1" m1)])) my-env (defaultFnkEnv {(= envMacros my-macros)})] (expand-form-with-env my-env shouldBe macroexpand-1 '(macroexpand-1 '(m1 True)) '(:quote (:begin (:: foo String) (= foo "True")))))))) (describe "macroexpand" (do (it "should expand to '(toCode 3)" (expandTo (macroexpand '(:quasiquote (:unquote 3))) '(toCode 3))) (it "should expand to '(toCode 4)" (expandTo (macroexpand `(:quasiquote (:unquote 4))) '(toCode 4))) (it "should expand to (car nil)" (expandTo (macroexpand (car nil)) (car nil))) (it "should expand to itself" (expandTo (macroexpand 42) 42)))) (describe "defmodule" (do (it "should expand to module header" (expandTo (defmodule Foo (export (FooClass ..) f1 f2) (require (Data.Maybe) (Data.List)) (require-and-import (Control.Monad)) (import (qualified Foo.Types as Types) (Foo.Buzz (buzz1 buzz2)))) (:begin (:require Data.Maybe) (:require Data.List) (:require Control.Monad) (module Foo (FooClass ..) f1 f2) (import qualified Foo.Types as Types) (import Foo.Buzz (buzz1 buzz2)) (import Control.Monad)))) (it "should ignore export when not given" (expandTo (defmodule Foo (require (Data.Maybe)) (import (Control.Monad))) (:begin (:require Data.Maybe) (module Foo) (import Control.Monad)))) (it "should import when compile" (expandTo (defmodule Foo (import-when [:compile] (Prelude) (Language.Finkel)) (import (Control.Monad))) (:begin (module Foo) (eval-when [:compile] (import Prelude) (import Language.Finkel)) (import Control.Monad)))) (it "should export nothing" (expandTo (defmodule Foo (import (Control.Monad)) (export)) (:begin (module Foo ()) (import Control.Monad)))) (it "should expand to plain (module ...)" (expandTo (defmodule Foo) (module Foo))) (it "should convert [] to () for entity list" (expandTo (defmodule Foo (import (Prelude [tail head read]))) (:begin (module Foo) (import Prelude (tail head read))))) (it "should fail on unknown section" (expandFailureWith (defmodule Foo (bar-buzz-quux (Control.Monad))) (subseqErr "unknown section"))) (it "should fail on too few parameters" (expandFailure (defmodule))))) (describe "cond-expand" (do (it "should contain compile time information" (expandWithPackageDbSatisfy (cond-expand [(<= 700 :ghc) (== :arch "x86_64") (== :os "linux") (:min-version "base" 3 99 99) "ghc newer than 7.0.0, x86_64-linux, base > 3.99.99"] [otherwise "other"]) (\form (&& (elem (aIntegral __glasgow_haskell__) form) (elem (aString NoSourceText arch) form) (elem (aString NoSourceText os) form) (elem (aString NoSourceText "other") form) ;; Below test works when using "base-4.x.x" package. (elem (aIntegral (:: 4 Int)) form))))) (it "should fail with non-string package" (expandFailureWith (cond-expand [(:min-version 0xdeadbeaf 1 2 3) "3735928495"] [otherwise "No such package"]) (\e (&& (subseqErr "want package name" e) (subseqErr "3735928495" e))))) (it "should fail with non-existing package" (expandWithPackageDbFailure (cond-expand [(:min-version "no-such-package" 2 4 0) "Found no-such-package"] [otherwise "No such package"]) (\e (&& (subseqErr "cannot find package" e) (subseqErr "no-such-package" e))))))))) ================================================ FILE: finkel-core/test/FunctionTest.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Module to test functions (:require Finkel.Core) (defmodule FunctionTest (export functionTests cxrTests listTests) (require ;; finkel-core (Finkel.Core.Internal)) (import ;; base (Data.List [isSubsequenceOf]) ;; finkel-kernel (Language.Finkel) ;; hspec (Test.Hspec) ;; quickcheck (Test.QuickCheck) ;; Internal (Finkel.Prelude) (Orphan []))) (defn (:: functionTests Spec) (do (describe "Error" errorTests) (describe "Cxr" cxrTests) (describe "List" listTests))) (defn (:: errorTests Spec) (describe "unsafeFinkelSrcError" (it "should throw src error" (lept [(:: srcError (-> FinkelException Bool)) (. (isSubsequenceOf "foo") show)] (shouldThrow (unsafeFinkelSrcError nil "foo") srcError))))) (defn (:: cxrTests Spec) (do (lept [d describe t 't tt '(t t) caxr (. (it "should be t") (== 't)) cdxr (. (it "should be (t t)") (== '(t t)))]) (d "car" (do (caxr (car (cons t tt))) (it "returns t when arg was '[t t]" (== (car '[t t]) t)) (it "returns nil when arg was nil" (== (car nil) nil)) (it "returns nil when arg was '[]" (== (car '[]) nil)) (it "should show error when applied to non-list" (expectFailure (=== nil (car 'foo)))))) (d "cdr" (do (cdxr (cdr (cons t tt))) (it "returns '(t) when arg was '[t t]" (== (cdr '[t t]) '(t))) (it "returns nil when arg was nil" (== (cdr nil) nil)) (it "returns nil when arg was '[]" (== (cdr '[]) nil)) (it "should show error when applied to non-list" (expectFailure (=== nil (cdr 'foo)))))) (d "caar" (caxr (caar '((t _) _ _ _)))) (d "cadr" (caxr (cadr '(_ t _ _ _)))) (d "cdar" (cdxr (cdar '((_ t t) _ _ _)))) (d "cddr" (cdxr (cddr '((_ _ _) _ t t)))) (d "caaar" (caxr (caaar '(((t _) _ _) _ _ _)))) (d "caadr" (caxr (caadr '(_ (t _ _) _ _)))) (d "cadar" (caxr (cadar '((_ t _) _ _ _)))) (d "caddr" (caxr (caddr '(_ _ t _)))) (d "cdaar" (cdxr (cdaar '(((_ t t) _) _)))) (d "cdadr" (cdxr (cdadr '(_ (_ t t) _)))) (d "cddar" (cdxr (cddar '((_ _ t t) _)))) (d "cdddr" (cdxr (cdddr '(_ _ _ t t)))) (d "caaaar" (caxr (caaaar '((((t _) _) _) _)))) (d "caaadr" (caxr (caaadr '(_ ((t _) _))))) (d "caadar" (caxr (caadar '((_ (t _)) _)))) (d "caaddr" (caxr (caaddr '(_ _ (t _))))) (d "cadaar" (caxr (cadaar '(((_ t) _))))) (d "cadadr" (caxr (cadadr '(_ ((_ _) t))))) (d "caddar" (caxr (caddar '((_ _ t))))) (d "cadddr" (caxr (cadddr '(_ _ _ t)))) (d "cdaaar" (cdxr (cdaaar '((((_ t t) _) _) _)))) (d "cdaadr" (cdxr (cdaadr '(_ ((_ t t) _))))) (d "cdadar" (cdxr (cdadar '((_ (_ t t)) _)))) (d "cdaddr" (cdxr (cdaddr '(_ _ (_ t t))))) (d "cddaar" (cdxr (cddaar '(((_ _ t t) _) _)))) (d "cddadr" (cdxr (cddadr '(_ (_ _ t t))))) (d "cdddar" (cdxr (cdddar '((_ _ _ t t) _)))) (d "cddddr" (cdxr (cddddr '(_ _ _ _ t t)))))) (defn (:: listTests Spec) (do (let ((= d describe))) (d "list of x, y, and z" (it "should be a list" (let ((:: f (-> Int Char String Bool)) (= f x y z (is-list (list x y z)))) (property f)))) (d "filtering pair" (it "should be pair" (property (\x (or [(&& (is-atom x) (not (is-pair x))) (&& (== nil x) (not (is-pair x))) (&& (is-hslist x) (not (is-pair x))) (is-pair x)]))))) (d "filtering string" (it "should be AString" (property (\x (==> (is-string (toCode x)) (case x (AString _ _) True _ False)))))) (d "filtering char" (it "should be AChar" (property (\x (==> (is-char (toCode x)) (case x (AChar _ _) True _ False)))))) (d "filtering integer" (it "should be AInteger" (property (\x (==> (is-integer (toCode x)) (case x (AInteger _) True _ False)))))) (d "filtering fractional" (it "should be AFractional" (property (\x (==> (is-fractional (toCode x)) (case x (AFractional _) True _ False)))))) (d "filtering ()" (it "should be AUnit" (property (\x (==> (is-unit (toCode x)) (case x AUnit True _ False)))))) (d "length of atom" (it "should be 1 or nil" (let ((:: f (-> Code Property)) (= f x (==> (is-atom x) (|| (== 1 (length x)) (null x))))) (property f)))) (d "cons" (do (let ((= x 'x) (= ret1 (cons x '[b c d])) (= ret2 (cons x 'b)))) (it "returns a List when consing to List" (is-list (cons 'a '(b c d)))) (it "returns a List when consing to HsList" (is-list ret1)) (it "has x at car of HsList-consed-list" (&& (== (car ret1) x) (== (cdr ret1) '(b c d)))) (it "returns a List when consing to Atom" (is-list ret2)) (it "has x at car of atom-consed-list" (&& (== (car ret2) x) (== (cdr ret2) '(b)))))) (d "caris" (do (it "returns True" (== (caris 'a '(a b c)) True)) (it "returns False" (== (caris 'a '(c b a)) False)))) (d "make-symbol" (it "returns a symbol" (== (make-symbol "foo") 'foo))) (d "mb-symbol-name" (do (it "returns a Just String from symbol" (== (mb-symbol-name 'foo) (Just "foo"))) (it "returns a Nothing from non-symbol" (== Nothing (mb-symbol-name '(foo bar buzz)))))) (d "curve" (do (it "returns list from hslist" (== (curve '[a b c]) '(a b c))) (it "returns original value otherwise" (== 'foo (curve 'foo))))) (d "list" (do (it "returns list" (== (list 'a 'b 'c) '(a b c))) (it "returns nil with no arguments" (== nil (list))))) (d "reduce" (do (it "returns the original list" (== (reduce cons nil '(a b c d e)) '(a b c d e))) (it "should apply given function on non-list" (== (reduce cons nil 'foo) '(foo))))) (d "reduce1" (do (it "returns the original list" (== (reduce1 cons '(a b c d e)) '(a b c d e))) (it "should throw exception on non-list" (expectFailure (shouldBe (reduce1 cons 'foo) nil))))) (d "map1" (do (it "replaces non-symbols" (== (map1 (\x (if (is-symbol x) x '_)) '(foo bar (a b c) buzz 3 "string")) '(foo bar _ buzz _ _))) (it "replaces non-symbols in HsList" (== (map1 (\x (if (is-symbol x) x '_)) '[foo bar (a b c) buzz 3 "string"]) '[foo bar _ buzz _ _])) (it "apply given function on non-list arg2" (== (map1 (\x (cons x x)) 'foo) '(foo foo))))) (d "keep" (do (it "removes non atom" (== (keep is-atom '(a (b c) d e (f g h))) '(a d e))) (it "throws an exception on non-list" (expectFailure (shouldBe (keep is-atom '"string") nil))))) (d "rev" (do (it "reverses List" (== (rev '(a b c)) '(c b a))) (it "reverses HsList" (== (rev '[a b c]) '[c b a])) (it "does nothing to non-list values" (== (rev 'foo) 'foo)))) (d "unsnoc" (it "should split the last element" (== (unsnoc '(a b c d e)) (, '(a b c d) 'e)))) (d "trav1" (do (it "should traverse list" (== (trav1 Just '(a b c)) (Just '(a b c)))) (it "should apply given function on non-list" (== (trav1 Just 'foo) (Just 'foo))))) (d "omni" (do (it "should replace `a' to `b'" (== (omni (\x (if (== 'a x) 'b x)) '(a a (x a x) [y a y] a)) '(b b (x b x) [y b y] b))) (it "should apply given function on non-list argument" (== (omni (\x (cons x x)) 'foo) '(foo foo))))) (d "omniM" (do (it "should print all elements" (== (omniM Just '(a a (x a x) [y a y] a)) (Just '(a a (x a x) [y a y] a)))) (it "should apply given function to non-list argument" (== (omniM Just 'foo) (Just 'foo))))))) ================================================ FILE: finkel-core/test/Orphan.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Orphan instances for QuickCheck ;;; This module contains duplicated codes with `Orphan' module used by ;;; finkel-kernel test. At the moment, could not find a nice way to ;;; avoid adding QuickCheck package dependency without code ;;; duplication. %p(OPTIONS_GHC -fno-warn-orphans) (:require Finkel.Core) (defmodule Orphan (import ;; QuickCheck (Test.QuickCheck [(Arbitrary ..) (Gen) arbitraryUnicodeChar elements getUnicodeString listOf oneof scale]) ;; finkel-kernel (Language.Finkel.Form))) (instance (Arbitrary Atom) (defn arbitrary (lept [headChars (++ [#'A .. #'Z] [#'a .. #'z] "_!$%*+./<=>?@^~:") tailChars (++ headChars "0123456789'-") symbolG (<*> (pure :) (elements headChars) (listOf (elements tailChars))) stringG (fmap getUnicodeString arbitrary)] (oneof [(return AUnit) (fmap aSymbol symbolG) (fmap (AChar NoSourceText) arbitraryUnicodeChar) (fmap (aString NoSourceText) stringG) (fmap aIntegral (:: arbitrary (Gen Integer))) (fmap aFractional (:: arbitrary (Gen Double)))])))) (instance (=> (Arbitrary a) (Arbitrary (Form a))) (defn arbitrary (oneof [(fmap Atom arbitrary) (fmap List (listOf (scale (flip div 3) arbitrary))) (fmap HsList (listOf (scale (flip div 3) arbitrary)))])) (defn shrink [x] (case x (Atom _) [] (List xs) (++ (map unCode xs) (map List (shrink xs))) (HsList xs) (++ (map unCode xs) (map HsList (shrink xs))) TEnd []))) (instance (=> (Arbitrary a) (Arbitrary (LForm a))) (defn arbitrary (fmap (. LForm genSrc) arbitrary))) ================================================ FILE: finkel-core/test/PluginTest.hs ================================================ ;;; -*- mode: finkel -*- (module PluginTest) ;; hspec (import Test.Hspec) ;;; Compile time home package modules (:require Finkel.Core) (:eval-when-compile (import Finkel.Prelude)) ;;; Imports ;; base (import Control.Monad (void)) (import Control.Monad.IO.Class ((MonadIO ..))) ;; ghc (import GHC ((LoadHowMuch ..) DynFlags (GhcMonad ..) guessTarget parseDynamicFlags load setTargets noLoc runGhc succeeded setSessionDynFlags)) ;; filepath (import System.FilePath ()) ;; finkel-kernel (import Language.Finkel.Fnk (getLibDirFromGhc)) (import Language.Finkel.Plugin (setFinkelPluginWithArgs)) ;; Internal (import Finkel.Core.Plugin (plugin)) (cond-expand [(<= 902 :ghc) (import GHC.Driver.Env.Types ((HscEnv ..)))] [(<= 900 :ghc) (import GHC.Driver.Types ((HscEnv ..)))] [otherwise (import HscTypes ((HscEnv ..)))]) ;;; Tests (defn (:: pluginTests Spec) (describe "plugin" (compile "c01.hs"))) (defn (:: compile (-> String Spec)) [file] (lept [go (do (<- hsc-env0-b getSession) (void (setSessionDynFlags (hsc-dflags hsc-env0-b))) (<- hsc-env2 getSession) (lept [pp-args ["-F" "-pgmF" "fnkpp"] fnk-args (++ pp-args ["-fno-code" (++ "-i" pdir)])]) (<- dflags1 (parseDynFlags hsc-env2 fnk-args)) (void (setSessionDynFlags dflags1)) (setFinkelPluginWithArgs plugin []) (<- t (cond-expand [(<= 904 :ghc) (guessTarget ( pdir file) Nothing Nothing)] [otherwise (guessTarget ( pdir file) Nothing)])) (setTargets [t]) (load LoadAllTargets))] (it (++ "should compile " file) (do (<- libdir getLibDirFromGhc) (<- success-flag (runGhc (Just libdir) go)) (shouldBe (succeeded success-flag) True))))) (defn (:: pdir FilePath) ( "test" "data" "plugin")) (defn (:: parseDynFlags (=> (MonadIO m) (-> HscEnv [String] (m DynFlags)))) [hsc-env args] (do (cond-expand [(<= 902 :ghc) (<- (, df _ _) (parseDynamicFlags (hsc-logger hsc-env) (hsc-dflags hsc-env) (map noLoc args)))] [otherwise (<- (, df _ _) (parseDynamicFlags (hsc-dflags hsc-env) (map noLoc args)))]) (pure df))) ================================================ FILE: finkel-core/test/Spec.hs ================================================ ;;; -*- mode: finkel -*- ;;; Main entry point of Finkel tests. (module Main) ;;; hspec (import Test.Hspec) ;;; Internal (import CoreTest) (import FunctionTest) (import PluginTest) (:: main (IO ())) (= main (hspec (do functionTests coreTests pluginTests))) ================================================ FILE: finkel-core/test/TestAux.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Auxiliary macros for test %p(LANGUAGE TypeApplications) (:require Finkel.Core) (defmodule TestAux (export (GensymCode ..) expand-form expand-form-satisfies expand-form-with expand-form-with-env expand-form-with-package-db-satisfies expand-form-with-package-db-failure expandTo expandFailure expandFailureWith expandSatisfy expandWithPackageDbSatisfy expandWithPackageDbFailure) (import ;; base (Control.Exception [(SomeException ..) try]) (Control.Monad [unless]) (Data.Function [on]) ;; hspec (Test.Hspec [Expectation expectationFailure shouldBe shouldSatisfy]) ;; finkel-kernel (Language.Finkel.Make [initSessionForMake]) (Language.Finkel.Fnk [(FnkEnv ..)]) ;; finkel-core (Finkel.Prelude) (Finkel.Core.Internal))) ;;; Types ;; Using a newtype to compare 'Code's containing symbols generated ;; with `gensym'. (newtype GensymCode (GensymCode Code) (deriving Show)) (instance (Eq GensymCode) (= == eqGensymCode)) (defn (:: eqGensymCode (-> GensymCode GensymCode Bool)) [(GensymCode a) (GensymCode b)] (eqGensymCode1 a b)) (defn (:: eqGensymCode1 (-> Code Code Bool)) [a b] (eqGensymCode2 (unCode a) (unCode b))) (defn (:: eqGensymCode2 (-> (Form Atom) (Form Atom) Bool)) [(Atom (@ asym (ASymbol a))) (Atom (@ bsym (ASymbol b)))] (| ((nullFS a) (nullFS b)) ((<- (: #'$ _) (show asym)) True) ((<- (: #'$ _) (show bsym)) True) (otherwise (== a b))) [(List as) (List bs)] (eqGensymCodes as bs) [(HsList as) (HsList bs)] (eqGensymCodes as bs) [a b] (== a b)) (defn (:: eqGensymCodes (-> [Code] [Code] Bool)) [[] []] True [[] _] False [ _ []] False [(: x xs) (: y ys)] (&& (eqGensymCode1 x y) (eqGensymCodes xs ys))) ;;; Functions (defn (:: expand-form (-> Macro Code Code Expectation)) (expand-form-with (on shouldBe GensymCode))) (defn (:: expand-form-satisfies (-> Macro Code (-> Code Bool) Expectation)) [macro in-form test] (expand-form-with (\a _ (shouldSatisfy a test)) macro in-form nil)) (defn (:: expand-form-with (-> (-> Code Code Expectation) Macro Code Code Expectation)) (expand-form-with-env defaultFnkEnv)) (defn (:: expand-form-with-env (-> FnkEnv (-> Code Code Expectation) Macro Code Code Expectation)) [fnk-env test macro in-form out-form] (lept [p (either (. expectationFailure show) (flip test out-form))] (expand-form-with-pre (pure ()) fnk-env p macro in-form))) (defn (:: expand-form-with-package-db-satisfies (-> Macro Code (-> Code Bool) Expectation)) [macro in-form test] (lept [p (either (. expectationFailure show) (flip shouldSatisfy test))] (expand-form-with-package-db defaultFnkEnv p macro in-form))) (defn (:: expand-form-with-package-db-failure (-> Macro Code (-> SomeException Bool) Expectation)) [macro in-form test] (lept [p (either (\e (unless (test e) (expectationFailure "test function failed"))) (const (expectationFailure "no exception thrown")))] (expand-form-with-package-db defaultFnkEnv p macro in-form))) (defn (:: expand-form-with-package-db (-> FnkEnv (-> (Either SomeException Code) Expectation) Macro Code Expectation)) (expand-form-with-pre initSessionForMake)) (defn (:: expand-form-with-pre (-> (Fnk ()) FnkEnv (-> (Either SomeException Code) Expectation) Macro Code Expectation)) [pre fnk-env test macro in-form] (>>= (try (runFnk (do pre (macroFunction macro in-form)) fnk-env)) test)) ;;; Macros (defmacro expandTo [in-form out] `(expand-form ,(car in-form) ',in-form ',out)) (defmacro expandFailureWith [in-form test] `(let ((= act (do (<- r (runFnk (macroFunction ,(car in-form) ',in-form) defaultFnkEnv)) (seq r (pure r))))) (shouldThrow act ,test))) (defmacro expandFailure [in-form] `(expandFailureWith ,in-form anyException)) (defmacro expandSatisfy [in-form test] `(expand-form-satisfies ,(car in-form) ',in-form ,test)) (defmacro expandWithPackageDbSatisfy [in-form test] `(expand-form-with-package-db-satisfies ,(car in-form) ',in-form ,test)) (defmacro expandWithPackageDbFailure [in-form test] `(expand-form-with-package-db-failure ,(car in-form) ',in-form ,test)) ================================================ FILE: finkel-core/test/data/plugin/ImportMe.hs ================================================ ;;; -*- mode: finkel -*- (defmodule ImportMe) (defn (:: f1 (-> Int (IO ()))) [n] (putStrLn (if (even n) "even" "odd"))) ================================================ FILE: finkel-core/test/data/plugin/c01.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Main (import (Control.Monad [forM-]) (ImportMe [f1]))) (defn (:: main (IO ())) (forM- (Just 3) f1)) ================================================ FILE: finkel-kernel/LICENSE ================================================ Copyright (c) 2017-2022, 8c6794b6 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: finkel-kernel/README.md ================================================ finkel-kernel ============= Package for Finkel language kernel. See the [documentation][doc] for more details. [doc]: https://finkel.readthedocs.io/en/latest/ ================================================ FILE: finkel-kernel/Setup.hs ================================================ -- | Custom setup script to pass command line options to happy and alex. -- -- Passing "--ghc" option to alex and happy manually. When stack add -- supports for passing command line options to arbitrary program used -- during build, this script could be removed. -- module Main where -- base import Data.Char (isSpace) import Data.Function (on) import Data.List (unionBy) -- Cabal import Distribution.Simple (UserHooks (..), defaultMainWithHooks, simpleUserHooks) import Distribution.Simple.Build (build) import Distribution.Simple.BuildPaths (autogenComponentModulesDir) import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess (knownSuffixHandlers) import Distribution.Simple.Program (getDbProgramOutput, ghcProgram) import Distribution.Simple.Program.Db (lookupProgram, updateProgram) import Distribution.Simple.Program.Types (ConfiguredProgram (..), ProgramLocation (..), programPath, simpleConfiguredProgram) import Distribution.Simple.Setup (ConfigFlags (..), fromFlag) import Distribution.Simple.Utils (createDirectoryIfMissingVerbose) import Distribution.Types.PackageDescription (PackageDescription) import Distribution.Verbosity (Verbosity) -- filepath import System.FilePath (()) -- | Main function for setup. -- -- Setup some addicional flags for /alex/ and /happy/, and emit C -- header files with C macros for all components. main :: IO () main = defaultMainWithHooks myHooks where myHooks = simpleUserHooks {buildHook = myBuildHooks ,postConf = myPostConf} myBuildHooks pkg_descr lbi hooks flags = build pkg_descr lbi' flags (allSuffixHandlers hooks) where lbi' = lbi {withPrograms = updateProgram happy (updateProgram alex (withPrograms lbi))} alex = alex' { programOverrideArgs = ["--ghc"] } alex' = simpleConfiguredProgram "alex" (FoundOnSystem "alex") happy = happy' { programOverrideArgs = ["-a", "-g", "-c"] -- Happy can take `--strict' flag, which adds -- strictness to happy parser. -- -- ["-a", "-c", "-g", "--strict"] } happy' = simpleConfiguredProgram "happy" (FoundOnSystem "happy") allSuffixHandlers hooks = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers where overridesPP = unionBy ((==) `on` fst) myPostConf _args flags pkg_descr lbi = writeFinkelKernelConfig pkg_descr lbi flags writeFinkelKernelConfig :: PackageDescription -> LocalBuildInfo -> ConfigFlags -> IO () writeFinkelKernelConfig pkg_descr lbi flags = do -- FINKEL_KERNEL_LIBDIR and FINKEL_KERNEL_GHC are obtained with -- similar way done in "ghc-paths" package. let verbosity = fromFlag (configVerbosity flags) libdir0 <- getLibDir verbosity lbi let bdpref = configDistPref flags bdpref_path = fromFlag bdpref def name str = "#define " ++ name ++ ' ':show str libdir1 = reverse (dropWhile isSpace (reverse libdir0)) ghc = case lookupProgram ghcProgram (withPrograms lbi) of Just p -> programPath p Nothing -> error "ghc was not found" config_h = ["/* Auto generated by Setup.hs */" ,"" ,"/* Path for inplace package lookup */" ,def "FINKEL_KERNEL_CONFIG_DISTPREF" bdpref_path ,"" ,"/* Path for the GHC library directory */" ,def "FINKEL_KERNEL_LIBDIR" libdir1 ,"" ,"/* Path for the GHC executable */" ,def "FINKEL_KERNEL_GHC" ghc ] gen comp clbi = let autogen_dir = autogenComponentModulesDir lbi clbi dest_path = autogen_dir "finkel_kernel_config.h" work = do createDirectoryIfMissingVerbose verbosity True autogen_dir writeFile dest_path (unlines config_h) in case comp of CLib _ -> work CTest _ -> work _ -> return () withAllComponentsInBuildOrder pkg_descr lbi gen -- | Function to get GHC library directory path. getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi = getDbProgramOutput verbosity ghcProgram (withPrograms lbi) ["--print-libdir"] ================================================ FILE: finkel-kernel/exec/fnkc.hs ================================================ -- | Simple wrapper for main compiler function. module Main where import Language.Finkel.Main main :: IO () main = defaultMain ================================================ FILE: finkel-kernel/exec/profile.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-} -- | Simple executable for profiling. -- -- Simple executable to wrap some simple actions. module Main where #include "ghc_modules.h" -- base import Control.Monad.IO.Class (MonadIO (..)) import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (Handle, stdout) -- filepath import qualified System.FilePath as FilePath -- ghc import qualified GHC as GHC import GHC_Data_StringBuffer (hGetStringBuffer) import GHC_Driver_Ppr (printForUser) import GHC_Driver_Session (DynFlags, GeneralFlag (..), HasDynFlags (..), gopt_set) import GHC_Types_Basic (SuccessFlag (..)) import GHC_Types_SrcLoc (mkGeneralLocated) import GHC_Utils_Outputable (Outputable (..), SDoc, neverQualify) #if MIN_VERSION_ghc(9,8,0) import GHC.Types.Error (defaultDiagnosticOpts) #elif MIN_VERSION_ghc(9,6,0) import GHC.Types.Error (Diagnostic (..)) #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Driver.Errors.Types (GhcMessage) import GHC.Utils.Outputable (NamePprCtx) #else import GHC_Utils_Outputable (PrintUnqualified) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Config.Diagnostic (initDiagOpts) import GHC.Driver.Errors (printMessages) #else import GHC_Driver_Errors (printBagOfErrors) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Utils.Logger (HasLogger (..)) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Utils_Outputable (Depth (..)) #endif -- finkel-kernel import qualified Language.Finkel.Builder as Builder import qualified Language.Finkel.Emit as Emit import qualified Language.Finkel.Expand as Expand import qualified Language.Finkel.Fnk as Fnk import qualified Language.Finkel.Lexer as Lexer import qualified Language.Finkel.Make as Make import qualified Language.Finkel.Reader as Reader import qualified Language.Finkel.SpecialForms as SpecialForms import qualified Language.Finkel.Syntax as Syntax main :: IO () main = do args <- getArgs case args of -- ["count", file] -> countTokens file ["expand", file] -> printExpandedForms file ["parse", file] -> printForms file ["ppr", file] -> pprFile file ["hsrc", file] -> printHsrc file ["lex", file] -> printTokens file "make" : files -> doMake files _ -> usage usage :: IO () usage = putStrLn (unlines ["usage: profile MODE ARGS" ,"" ,"MODE:" -- ," count - count number of forms" ," expand - print expanded forms" ," parse - parse input file and print resulting forms" ," ppr - pretty print haskell or finkel module with `ppr'" ," hsrc - convert Finkel source to Haskell source" ," lex - lex input file and print resulting tokens" ," make - compile given files to object code"]) printExpandedForms :: FilePath -> IO () printExpandedForms path = Fnk.runFnk go SpecialForms.defaultFnkEnv where go = do Make.initSessionForMake contents <- liftIO (hGetStringBuffer path) (forms, _) <- Reader.parseSexprs (Just path) contents forms' <- Make.withExpanderSettings (Expand.expands forms) liftIO (mapM_ print forms') printForms :: FilePath -> IO () printForms path = do contents <- hGetStringBuffer path case Lexer.evalSP Reader.sexprs (Just path) contents of Right forms -> mapM_ print forms Left err -> print err pprFile :: FilePath -> IO () pprFile path | ext == ".fnk" = pprFnkModule path | ext == ".hs" = pprHsModule path | otherwise = putStrLn "ppr: expeting .fnk or .hs file" where ext = FilePath.takeExtension path pprFnkModule :: FilePath -> IO () pprFnkModule = parseFnkModuleWith (\m _ -> do dflags <- getDynFlags liftIO (prForUser dflags stdout neverQualify (ppr m))) pprHsModule :: FilePath -> IO () pprHsModule path = Fnk.runFnk go SpecialForms.defaultFnkEnv where go = do Make.initSessionForMake contents <- liftIO (readFile path) dflags0 <- getDynFlags #if MIN_VERSION_ghc(9,2,0) logger <- getLogger #endif let dflags1 = gopt_set dflags0 Opt_Haddock #if MIN_VERSION_ghc(9,6,0) ddopts = defaultDiagnosticOpts @GhcMessage pboe = printMessages logger ddopts (initDiagOpts dflags1) #elif MIN_VERSION_ghc(9,4,0) pboe = printMessages logger (initDiagOpts dflags1) #elif MIN_VERSION_ghc(9,2,0) pboe = printBagOfErrors logger dflags1 #else pboe = printBagOfErrors dflags1 #endif (_warnings, ret) = GHC.parser contents dflags1 path liftIO $ case ret of Right lmdl -> prForUser dflags1 stdout neverQualify (ppr lmdl) Left err -> putStrLn "pprHsModule: error" >> pboe err #if MIN_VERSION_ghc(9,6,0) prForUser :: DynFlags -> Handle -> NamePprCtx -> SDoc -> IO () #else prForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () #endif #if MIN_VERSION_ghc(9,0,0) prForUser df hdl qual sdoc = printForUser df hdl qual AllTheWay sdoc #else prForUser = printForUser #endif printHsrc :: FilePath -> IO () printHsrc = parseFnkModuleWith (\mdl sp -> do fnk_str <- Emit.genHsSrc sp (Emit.Hsrc mdl) liftIO (putStrLn fnk_str)) parseFnkModuleWith :: (Builder.HModule -> Lexer.SPState -> Fnk.Fnk ()) -> FilePath -> IO () parseFnkModuleWith act path = Fnk.runFnk go SpecialForms.defaultFnkEnv where go = do Make.initSessionForMake contents <- liftIO (hGetStringBuffer path) case Lexer.runSP Reader.sexprs (Just path) contents of Right (forms, sp) -> do forms' <- Make.withExpanderSettings (Expand.expands forms) dflags <- getDynFlags case Builder.evalBuilder dflags False Syntax.parseModule forms' of Right mdl -> act mdl sp Left err -> liftIO (putStrLn ("error: " ++ Builder.syntaxErrMsg err)) Left err -> liftIO (print err) printTokens :: FilePath -> IO () printTokens path = do contents <- hGetStringBuffer path case Lexer.lexTokens (Just path) contents of Right toks -> mapM_ (print . GHC.unLoc) toks Left err -> print err -- countTokens :: FilePath -> IO () -- countTokens path = do -- contents <- hGetStringBuffer path -- -- contents <- BL.readFile path -- let f x acc = -- let n = x `seq` length x -- in n `seq` acc `seq` n + acc -- case Lexer.incrSP Reader.psexpr f 0 (Just path) contents of -- Right (n, _) -> print n -- Left err -> putStrLn err doMake :: [FilePath] -> IO () doMake files = do let act = do Make.initSessionForMake Make.make (zipWith f files (repeat Nothing)) False Nothing f file phase = (mkGeneralLocated "commandline" file, phase) success_flag <- Fnk.runFnk act SpecialForms.defaultFnkEnv case success_flag of Failed -> exitFailure Succeeded -> return () ================================================ FILE: finkel-kernel/finkel-kernel.cabal ================================================ cabal-version: 2.0 name: finkel-kernel version: 0.0.0 synopsis: Finkel kernel language and compiler description: Finkel kernel language and compiler . See the for more info. homepage: https://github.com/finkel-lang/finkel#readme license: BSD3 license-file: LICENSE author: 8c6794b6 maintainer: 8c6794b6@gmail.com copyright: 2017-2022 8c6794b6 category: Language build-type: Custom extra-source-files: README.md include/*.h -- test/data/eval/*.fnk test/data/syntax/*.hs test/data/main/*.c test/data/main/*.hs test/data/make/*.c test/data/make/*.hs test/data/make/*.hs.2 test/data/make/M4/*.hs test/data/make/M6/*.hs tested-with: GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.7 , GHC == 9.6.5 , GHC == 9.8.2 , GHC == 9.10.1 custom-setup setup-depends: base >= 4.14 && < 5 , Cabal >= 2.0 && < 3.13 , filepath >= 1.4 && < 1.6 flag dev description: Flag for internal development default: False manual: True library hs-source-dirs: src exposed-modules: Paths_finkel_kernel Language.Finkel Language.Finkel.Builder Language.Finkel.Emit Language.Finkel.Error Language.Finkel.Eval Language.Finkel.Exception Language.Finkel.Expand Language.Finkel.Form Language.Finkel.Homoiconic Language.Finkel.Hooks Language.Finkel.Lexer Language.Finkel.Make Language.Finkel.Main Language.Finkel.Options Language.Finkel.Plugin Language.Finkel.Preprocess Language.Finkel.Reader Language.Finkel.Fnk Language.Finkel.SpecialForms Language.Finkel.Syntax other-modules: Language.Finkel.Data.Fractional Language.Finkel.Data.FastString Language.Finkel.Data.SourceText Language.Finkel.Make.Cache Language.Finkel.Make.Recompile Language.Finkel.Make.Session Language.Finkel.Make.Summary Language.Finkel.Make.TargetSource Language.Finkel.Make.Trace Language.Finkel.ParsedResult Language.Finkel.Syntax.Extension Language.Finkel.Syntax.Location Language.Finkel.Syntax.Utils Language.Finkel.Syntax.HBind Language.Finkel.Syntax.HDecl Language.Finkel.Syntax.HExpr Language.Finkel.Syntax.HImpExp Language.Finkel.Syntax.HPat Language.Finkel.Syntax.HType autogen-modules: Paths_finkel_kernel includes: ghc_modules.h include-dirs: include c-sources: include/hooks.c build-depends: array >= 0.5 && < 0.6 , base >= 4.14 && < 5 , binary >= 0.8 && < 0.9 , bytestring >= 0.10 && < 0.13 , containers >= 0.6 && < 0.8 , deepseq >= 1.4 && < 1.6 , directory >= 1.3 && < 1.4 , exceptions >= 0.10 && < 0.11 , filepath >= 1.4 && < 1.6 , ghc >= 8.10.0 && < 9.11.0 , ghc-boot >= 8.10.0 && < 9.11.0 , ghci >= 8.10.0 && < 9.11.0 , process >= 1.6 && < 1.7 , time >= 1.9 && < 1.14 build-tool-depends: alex:alex >= 3.1 && < 3.6 , happy:happy >= 1.19 && < 1.23 default-language: Haskell2010 ghc-options: -Wall executable finkel-profile if !flag(dev) buildable: False hs-source-dirs: exec main-is: profile.hs ghc-options: -Wall -threaded -rtsopts includes: ghc_modules.h include-dirs: include build-depends: base , bytestring , filepath , ghc , finkel-kernel default-language: Haskell2010 test-suite finkel-kernel-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs other-modules: FormTest FnkTest EmitTest EvalTest ExceptionTest MainTest MakeTest PluginTest PreprocessTest SyntaxTest Orphan TestAux Paths_finkel_kernel includes: ghc_modules.h include-dirs: include build-depends: base , binary , bytestring , containers , deepseq , directory , exceptions , filepath , ghc , process , finkel-kernel -- , QuickCheck >= 2.10.1 && < 2.16 , hspec >= 2.4.8 && < 2.12 , silently >= 1.2 && < 1.3 , transformers >= 0.5.2 && < 0.7 -- The "Linker.c" codes in the "rts" package bundled with ghc 8.10.3 had -- problem when running the tests with "+RTS -N", disabling. if impl (ghc >= 8.10.3) ghc-options: -Wall -threaded -rtsopts else ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 source-repository head type: git location: https://github.com/finkel-lang/finkel.git subdir: finkel-kernel ================================================ FILE: finkel-kernel/include/ghc_modules.h ================================================ /** * CPP macros to manage module names in ghc. */ #pragma once /* Changes happend from ghc 9.0 to 9.2. Also defining the module aliases for ghc older than 9.0. */ #if __GLASGOW_HASKELL__ >= 902 #define GHC_Driver_Env GHC.Driver.Env #define GHC_Driver_Env_Types GHC.Driver.Env.Types #define GHC_Driver_Errors GHC.Driver.Errors #define GHC_Driver_Ppr GHC.Driver.Ppr #define GHC_Platform_Ways GHC.Platform.Ways #define GHC_Runtime_Context GHC.Runtime.Context #define GHC_Types_Error GHC.Types.Error #define GHC_Types_Fixity GHC.Types.Fixity #define GHC_Types_SourceError GHC.Types.SourceError #define GHC_Types_SourceFile GHC.Types.SourceFile #define GHC_Types_SourceText GHC.Types.SourceText #define GHC_Types_Target GHC.Types.Target #define GHC_Types_TyThing GHC.Types.TyThing #define GHC_Types_TyThing_Ppr GHC.Types.TyThing.Ppr #define GHC_Unit_Finder GHC.Unit.Finder #define GHC_Unit_Home_ModInfo GHC.Unit.Home.ModInfo #define GHC_Unit_Module_Deps GHC.Unit.Module.Deps #define GHC_Unit_Module_Graph GHC.Unit.Module.Graph #define GHC_Unit_Module_ModIface GHC.Unit.Module.ModIface #define GHC_Unit_Module_ModSummary GHC.Unit.Module.ModSummary #elif __GLASGOW_HASKELL__ >= 900 #define GHC_Driver_Env GHC.Driver.Types #define GHC_Driver_Env_Types GHC.Driver.Types #define GHC_Driver_Errors GHC.Utils.Error #define GHC_Driver_Ppr GHC.Utils.Outputable #define GHC_Platform_Ways GHC.Driver.Ways #define GHC_Runtime_Context GHC.Driver.Types #define GHC_Types_Error GHC.Utils.Error #define GHC_Types_Fixity GHC.Types.Basic #define GHC_Types_SourceError GHC.Driver.Types #define GHC_Types_SourceFile GHC.Driver.Phases #define GHC_Types_SourceText GHC.Types.Basic #define GHC_Types_Target GHC.Driver.Types #define GHC_Types_TyThing GHC.Driver.Types #define GHC_Types_TyThing_Ppr GHC.Core.Ppr.TyThing #define GHC_Unit_Finder GHC.Driver.Finder #define GHC_Unit_Home_ModInfo GHC.Driver.Types #define GHC_Unit_Module_Deps GHC.Driver.Types #define GHC_Unit_Module_Graph GHC.Driver.Types #define GHC_Unit_Module_ModIface GHC.Driver.Types #define GHC_Unit_Module_ModSummary GHC.Driver.Types #else /* __GLASGOW_HASKELL__ < 900 */ #define GHC_Driver_Env HscTypes #define GHC_Driver_Env_Types HscTypes #define GHC_Driver_Errors ErrUtils #define GHC_Driver_Ppr Outputable #define GHC_Platform_Ways DynFlags #define GHC_Runtime_Context HscTypes #define GHC_Types_Error ErrUtils #define GHC_Types_Fixity BasicTypes #define GHC_Types_SourceError HscTypes #define GHC_Types_SourceFile DriverPhases #define GHC_Types_SourceText BasicTypes #define GHC_Types_Target HscTypes #define GHC_Types_TyThing HscTypes #define GHC_Types_TyThing_Ppr PprTyThing #define GHC_Unit_Finder Finder #define GHC_Unit_Home_ModInfo HscTypes #define GHC_Unit_Module_Deps HscTypes #define GHC_Unit_Module_Graph HscTypes #define GHC_Unit_Module_ModIface HscTypes #define GHC_Unit_Module_ModSummary HscTypes #endif /* Changes happened from ghc 8.10 to ghc 9.0. From ghc 9.0.1, ghc uses "GHC.*" name space for its modules. */ #if __GLASGOW_HASKELL__ >= 900 #define GHC_Builtin_Types GHC.Builtin.Types #define GHC_Builtin_Types_Prim GHC.Builtin.Types.Prim #define GHC_Core_Class GHC.Core.Class #define GHC_Core_DataCon GHC.Core.DataCon #define GHC_Core_TyCo_Rep GHC.Core.TyCo.Rep #define GHC_Core_TyCo_Tidy GHC.Core.TyCo.Tidy #define GHC_Data_Bag GHC.Data.Bag #define GHC_Data_FastString GHC.Data.FastString #define GHC_Data_EnumSet GHC.Data.EnumSet #define GHC_Data_Maybe GHC.Data.Maybe #define GHC_Data_OrdList GHC.Data.OrdList #define GHC_Data_StringBuffer GHC.Data.StringBuffer #define GHC_Driver_Flags GHC.Driver.Flags #define GHC_Driver_Main GHC.Driver.Main #define GHC_Driver_Make GHC.Driver.Make #define GHC_Driver_Monad GHC.Driver.Monad #define GHC_Driver_Phases GHC.Driver.Phases #define GHC_Driver_Pipeline GHC.Driver.Pipeline #define GHC_Driver_Session GHC.Driver.Session #define GHC_Driver_Types GHC.Driver.Types #define GHC_Driver_Ways GHC.Driver.Ways #define GHC_Hs_Stats GHC.Hs.Stats #define GHC_Iface_Load GHC.Iface.Load #define GHC_Iface_Make GHC.Iface.Make #define GHC_Iface_Recomp GHC.Iface.Recomp #define GHC_Iface_Recomp_Binary GHC.Iface.Recomp.Binary #define GHC_Iface_Recomp_Flags GHC.Iface.Recomp.Flags #define GHC_IfaceToCore GHC.IfaceToCore #define GHC_Parser_Annotation GHC.Parser.Annotation #define GHC_Parser_CharClass GHC.Parser.CharClass #define GHC_Parser_Header GHC.Parser.Header #define GHC_Parser_Lexer GHC.Parser.Lexer #define GHC_Parser_PostProcess GHC.Parser.PostProcess #define GHC_Plugins GHC.Plugins #define GHC_Runtime_Eval GHC.Runtime.Eval #define GHC_Runtime_Linker GHC.Runtime.Linker #define GHC_Runtime_Loader GHC.Runtime.Loader #define GHC_Settings_Config GHC.Settings.Config #define GHC_Tc_Module GHC.Tc.Module #define GHC_Tc_Utils_Monad GHC.Tc.Utils.Monad #define GHC_Tc_Utils_Zonk GHC.Tc.Utils.Zonk #define GHC_Types_Basic GHC.Types.Basic #define GHC_Types_FieldLabel GHC.Types.FieldLabel #define GHC_Types_ForeignCall GHC.Types.ForeignCall #define GHC_Types_Name GHC.Types.Name #define GHC_Types_Name_Occurrence GHC.Types.Name.Occurrence #define GHC_Types_Name_Reader GHC.Types.Name.Reader #define GHC_Types_SrcLoc GHC.Types.SrcLoc #define GHC_Types_Unique_Set GHC.Types.Unique.Set #define GHC_Types_Unique_Supply GHC.Types.Unique.Supply #define GHC_Types_Var GHC.Types.Var #define GHC_Types_Var_Env GHC.Types.Var.Env #define GHC_Unit_Module GHC.Unit.Module #define GHC_Unit_State GHC.Unit.State #define GHC_Unit_Types GHC.Unit.Types #define GHC_Utils_Encoding GHC.Utils.Encoding #define GHC_Utils_Error GHC.Utils.Error #define GHC_Utils_Exception GHC.Utils.Exception #define GHC_Utils_Fingerprint GHC.Utils.Fingerprint #define GHC_Utils_Lexeme GHC.Utils.Lexeme #define GHC_Utils_Misc GHC.Utils.Misc #define GHC_Utils_Outputable GHC.Utils.Outputable #define GHC_Utils_Panic GHC.Utils.Panic #define GHC_Utils_Ppr GHC.Utils.Ppr #else /* __GLASGOW_HASKELL__ < 900 */ #define GHC_Builtin_Types TysWiredIn #define GHC_Builtin_Types_Prim TysPrim #define GHC_Core_Class Class #define GHC_Core_DataCon DataCon #define GHC_Core_TyCo_Rep TyCoRep #define GHC_Core_TyCo_Tidy TyCoTidy #define GHC_Data_Bag Bag #define GHC_Data_FastString FastString #define GHC_Data_EnumSet EnumSet #define GHC_Data_Maybe Maybes #define GHC_Data_OrdList OrdList #define GHC_Data_StringBuffer StringBuffer #define GHC_Driver_Flags DynFlags #define GHC_Driver_Main HscMain #define GHC_Driver_Make GhcMake #define GHC_Driver_Monad GhcMonad #define GHC_Driver_Phases DriverPhases #define GHC_Driver_Pipeline DriverPipeline #define GHC_Driver_Session DynFlags #define GHC_Driver_Types HscTypes #define GHC_Hs_Stats HscStats #define GHC_Iface_Load LoadIface #define GHC_Iface_Make MkIface #define GHC_Iface_Recomp MkIface #define GHC_Iface_Recomp_Binary BinFingerprint #define GHC_Iface_Recomp_Flags FlagChecker #define GHC_IfaceToCore TcIface #define GHC_Parser_Annotation ApiAnnotation #define GHC_Parser_CharClass Ctype #define GHC_Parser_Header HeaderInfo #define GHC_Parser_Lexer Lexer #define GHC_Parser_PostProcess RdrHsSyn #define GHC_Plugins Plugins #define GHC_Runtime_Eval InteractiveEval #define GHC_Runtime_Linker Linker #define GHC_Runtime_Loader DynamicLoading #define GHC_Settings_Config Config #define GHC_Tc_Module TcRnDriver #define GHC_Tc_Utils_Monad TcRnMonad #define GHC_Tc_Utils_Zonk TcHsSyn #define GHC_Types_Basic BasicTypes #define GHC_Types_FieldLabel FieldLabel #define GHC_Types_ForeignCall ForeignCall #define GHC_Types_Name Name #define GHC_Types_Name_Occurrence OccName #define GHC_Types_Name_Reader RdrName #define GHC_Types_SrcLoc SrcLoc #define GHC_Types_Unique_Set UniqSet #define GHC_Types_Unique_Supply UniqSupply #define GHC_Types_Var Var #define GHC_Types_Var_Env VarEnv #define GHC_Unit_Module Module #define GHC_Unit_State Packages #define GHC_Unit_Types HscTypes #define GHC_Utils_Encoding Encoding #define GHC_Utils_Error ErrUtils #define GHC_Utils_Exception Exception #define GHC_Utils_Fingerprint Fingerprint #define GHC_Utils_Lexeme Lexeme #define GHC_Utils_Misc Util #define GHC_Utils_Outputable Outputable #define GHC_Utils_Panic Panic #define GHC_Utils_Ppr Pretty #endif /* Modules which changed its name between 8.10.x and 9.0.x. */ #if __GLASGOW_HASKELL__ >= 900 #define GHC_Hs_Type GHC.Hs.Type #define GHC_Utils_CliOption GHC.Utils.CliOption #else #define GHC_Hs_Type GHC.Hs.Types #define GHC_Utils_CliOption CliOption #endif /* From ghc 8.10.1, modules for AST were moved under 'GHC.Hs.*'. Defining aliases for import declarations. For more info about module renaming, see: https://gitlab.haskell.org/ghc/ghc/issues/13009 */ #define GHC_Hs GHC.Hs #define GHC_Hs_Binds GHC.Hs.Binds #define GHC_Hs_Decls GHC.Hs.Decls #define GHC_Hs_Doc GHC.Hs.Doc #define GHC_Hs_Dump GHC.Hs.Dump #define GHC_Hs_Expr GHC.Hs.Expr #define GHC_Hs_Extension GHC.Hs.Extension #define GHC_Hs_ImpExp GHC.Hs.ImpExp #define GHC_Hs_Lit GHC.Hs.Lit #define GHC_Hs_Pat GHC.Hs.Pat #define GHC_Hs_Utils GHC.Hs.Utils ================================================ FILE: finkel-kernel/include/hooks.c ================================================ /** * Slim variant of "hschooks.c" found in ghc source */ #include "Rts.h" #include "HsFFI.h" void initGCStatistics (void) { if (RtsFlags.GcFlags.giveStats == NO_GC_STATS) { RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS; } } ================================================ FILE: finkel-kernel/src/Language/Finkel/Builder.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | Builder functions for Haskell syntax data type. -- -- This module contains 'Builder' data type and Haskell AST type synonyms. The -- 'Builder' data type is used by Happy parser for building various AST types. -- -- The main purpose of AST type synonyms defined in this module are for managing -- ghc version compatibility. -- module Language.Finkel.Builder ( -- * Builders type and functions Builder(..) , BState(..) , SyntaxError(..) , syntaxErrMsg , syntaxErrCode , builderError , evalBuilder , failB , formLexer , getBState , parse , putBState , setLastToken , runBuilder -- * Type synonyms for ghc version compatibility -- $typesynonym , PARSED , HBind , HBinds , HCCallConv , HConDecl , HConDeclGADTDetails , HConDeclH98Details , HConDeclField , HDecl , HDeriving , HDerivStrategy , HExpr , HGRHS , HGuardLStmt , HIE , HIEWrappedName , HImportDecl , HKind , HLocalBinds , HMatch , HModule , HPat , HSig , HSigType , HSigWcType , HStmt , HTyVarBndr , HTyVarBndrSpecific , HTyVarBndrVis , HType -- * Function names for @:quote@ , Quote , qListS , qHsListS , qSymbolS , qCharS , qStringS , qIntegerS , qFractionalS , qUnitS , quoteWith ) where #include "ghc_modules.h" -- ghc import GHC_Data_Bag (Bag) import GHC_Data_FastString (FastString, appendFS) import GHC_Driver_Session (DynFlags) import GHC_Hs (HsModule) import GHC_Hs_Binds (HsLocalBinds, LHsBind, LSig) import GHC_Hs_Decls (HsDeriving, LConDecl, LDerivStrategy, LHsDecl) import GHC_Hs_Expr (ExprLStmt, GuardLStmt, LGRHS, LHsExpr, LMatch) import GHC_Hs_Extension (GhcPs) import GHC_Hs_ImpExp (LIE, LIEWrappedName, LImportDecl) import GHC_Hs_Pat (LPat) import GHC_Hs_Type (LConDeclField, LHsSigType, LHsSigWcType, LHsTyVarBndr, LHsType) import GHC_Parser_Lexer (PState (..)) import GHC_Types_ForeignCall (CCallConv (..)) import GHC_Types_SrcLoc (Located, noLoc) #if MIN_VERSION_ghc(9,8,0) import GHC.Hs.Type (HsBndrVis (..)) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Config.Parser (initParserOpts) #elif MIN_VERSION_ghc(9,2,0) import GHC.Driver.Config (initParserOpts) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Hs.Decls (HsConDeclGADTDetails, HsConDeclH98Details) import GHC_Parser_Lexer (initParserState) #else import GHC_Hs_Decls (HsConDeclDetails) import GHC_Parser_Lexer (mkPState) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Types_Var (Specificity (..)) #endif -- Internal import Language.Finkel.Form -- ------------------------------------------------------------------- -- -- Builder data type -- -- ------------------------------------------------------------------- -- | State for 'Builder'. data BState = BState { -- | Input tokens to parse. inputs :: [Code] -- | The 'PState' used for parser from GHC. , ghcPState :: PState -- | Last token, for error message. , lastToken :: Maybe Code -- | Whether to use qualified functions when quoting. , qualifyQuote :: Bool } -- | Wrapper data for syntax error. data SyntaxError = SyntaxError Code String deriving (Eq, Show) -- | Newtype wrapper for parsing list of 'Code' with Happy. -- -- Implements simple state monad with result value wrapped with 'Either', to -- terminate parsing computation with 'SyntaxError'. newtype Builder a = Builder { unBuilder :: BState -> Either SyntaxError (a, BState) } instance Functor Builder where fmap f (Builder m) = Builder (\st0 -> do (a, st1) <- m st0 return (f a, st1)) {-# INLINE fmap #-} instance Applicative Builder where pure x = Builder (\st -> pure (x, st)) {-# INLINE pure #-} Builder f <*> Builder m = Builder (\st0 -> do (g, st1) <- f st0 (v, st2) <- m st1 return (g v, st2)) {-# INLINE (<*>) #-} instance Monad Builder where Builder m >>= k = Builder (\st0 -> do (a, st1) <- m st0 unBuilder (k a) st1) {-# INLINE (>>=) #-} -- | Run given 'Builder' with using given list of 'Code' as input. runBuilder :: DynFlags -> Bool -> Builder a -> [Code] -> Either SyntaxError (a, [Code]) runBuilder dflags qualify bld toks = let buf = error "PState StringBuffer is empty" rl = error "PState RealSrcLoc is empty" #if MIN_VERSION_ghc(9,2,0) ps = initParserState (initParserOpts dflags) buf rl #else ps = mkPState dflags buf rl #endif in case unBuilder bld (BState toks ps Nothing qualify) of Right (a, st) -> Right (a, inputs st) Left err -> Left err -- | Like 'runBuilder', but discards left over 'Code's. evalBuilder :: DynFlags -> Bool -> Builder a -> [Code] -> Either SyntaxError a evalBuilder dflags qualify bld toks = fmap fst (runBuilder dflags qualify bld toks) -- | Fail builder computation with given message. failB :: String -> Builder a failB err = do mb_tok <- fmap lastToken getBState let tok = case mb_tok of Just t -> t Nothing -> LForm (noLoc (Atom AUnit)) Builder (const (Left (SyntaxError tok err))) -- | Extract message from 'SyntaxError'. syntaxErrMsg :: SyntaxError -> String syntaxErrMsg (SyntaxError _ msg) = msg -- | Extract code from 'SyntaxError'. syntaxErrCode :: SyntaxError -> Code syntaxErrCode (SyntaxError code _) = code -- | Get current 'BState'. getBState :: Builder BState getBState = Builder (\st -> Right (st,st)) {-# INLINABLE getBState #-} -- | Put current 'BState'. putBState :: BState -> Builder () putBState st = Builder (\_ -> Right ((), st)) {-# INLINABLE putBState #-} -- | Set last token to given 'Code'. setLastToken :: Code -> Builder () setLastToken code = do st <- getBState putBState (st {lastToken = Just code}) {-# INLINABLE setLastToken #-} -- | Parse with builder using given tokens, continue on successful parse. parse :: Builder a -> [Code] -> Builder a parse bld toks = do bstate <- getBState let pstate = ghcPState bstate qualify = qualifyQuote bstate case unBuilder bld (BState toks pstate Nothing qualify) of Right (a, _) -> return a Left err -> Builder (const (Left err)) -- | Simple lexer to parse forms. formLexer :: (Code -> Builder a) -> Builder a formLexer cont = do st <- getBState case inputs st of [] -> cont (LForm (noLoc TEnd)) x:xs -> do putBState (st {inputs = xs, lastToken = Just x}) cont x {-# INLINABLE formLexer #-} -- | Show simple syntax error message with current 'Code'. builderError :: Builder a builderError = do st <- getBState case lastToken st of Nothing -> failB "Syntax error" Just x -> failB ("Syntax error on input `" ++ show x ++ "'") -- --------------------------------------------------------------------- -- -- Type synonyms -- -- --------------------------------------------------------------------- -- $typesynonym -- -- Type synonyms for managing GHC version compatibility. -- -- This 'PARSED' type synonym is wrapped with CPP macro detecting the ghc -- package version at compilation time. At the time of initial development of -- finkel-kernel package, ghc source codes were not under the /Trees that Grow/ -- modifications. When updating from ghc 8.2.x to 8.4.x, 'PARSED' were added to -- handle the AST argument type modification. -- -- See -- -- for more information of \"Trees that Grow\". -- type PARSED = GhcPs type HBind = LHsBind PARSED type HBinds = Bag (LHsBind PARSED) type HCCallConv = Located CCallConv type HConDecl = LConDecl PARSED #if MIN_VERSION_ghc(9,2,0) type HConDeclH98Details = HsConDeclH98Details PARSED type HConDeclGADTDetails = HsConDeclGADTDetails PARSED #else -- In ghc < 9.2, constructor details were not saparated, internal -- representations are same. type HConDeclH98Details = HsConDeclDetails PARSED type HConDeclGADTDetails = HsConDeclDetails PARSED #endif type HConDeclField = LConDeclField PARSED type HDecl = LHsDecl PARSED type HDeriving = HsDeriving PARSED type HDerivStrategy = LDerivStrategy PARSED type HExpr = LHsExpr PARSED type HGRHS = LGRHS PARSED HExpr type HGuardLStmt = GuardLStmt PARSED type HIE = LIE PARSED type HIEWrappedName = LIEWrappedName PARSED type HImportDecl = LImportDecl PARSED type HKind = HType #if MIN_VERSION_ghc(9,2,0) type HLocalBinds = HsLocalBinds PARSED #else type HLocalBinds = Located (HsLocalBinds PARSED) #endif type HMatch = LMatch PARSED HExpr #if MIN_VERSION_ghc(9,6,0) type HModule = HsModule PARSED #elif MIN_VERSION_ghc(9,0,0) type HModule = HsModule #else type HModule = HsModule PARSED #endif type HPat = LPat PARSED type HSig = LSig PARSED type HSigType = LHsSigType PARSED type HSigWcType = LHsSigWcType PARSED type HStmt = ExprLStmt PARSED #if MIN_VERSION_ghc(9,8,0) type HTyVarBndr = LHsTyVarBndr () PARSED type HTyVarBndrSpecific = LHsTyVarBndr Specificity PARSED type HTyVarBndrVis = LHsTyVarBndr (HsBndrVis PARSED) PARSED #elif MIN_VERSION_ghc(9,0,0) type HTyVarBndr = LHsTyVarBndr () PARSED type HTyVarBndrSpecific = LHsTyVarBndr Specificity PARSED type HTyVarBndrVis = HTyVarBndr #else type HTyVarBndr = LHsTyVarBndr PARSED type HTyVarBndrSpecific = HTyVarBndr type HTyVarBndrVis = HTyVarBndr #endif type HType = LHsType PARSED -- --------------------------------------------------------------------- -- -- Function names for ":quote" -- -- --------------------------------------------------------------------- -- Note: [Qualified names for quoting functions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- Quoting functions can use qualified name after expansion, to support quote in -- REPL without importing the "Language.Finkel" module. See how -- "Opt_ImplicitImportQualified" flag is set in initialization code of Finkel -- REPL in "finkel-tool" package. type Quote = Bool -> FastString quoteWith :: FastString -> Quote quoteWith name qualify = if qualify then appendFS "Language.Finkel." name else name {-# INLINABLE quoteWith #-} qListS :: Quote qListS = quoteWith "qList" {-# INLINABLE qListS #-} qHsListS :: Quote qHsListS = quoteWith "qHsList" {-# INLINABLE qHsListS #-} qSymbolS :: Quote qSymbolS = quoteWith "qSymbol" {-# INLINABLE qSymbolS #-} qCharS :: Quote qCharS = quoteWith "qChar" {-# INLINABLE qCharS #-} qStringS :: Quote qStringS = quoteWith "qString" {-# INLINABLE qStringS #-} qIntegerS :: Quote qIntegerS = quoteWith "qInteger" {-# INLINABLE qIntegerS #-} qFractionalS :: Quote qFractionalS = quoteWith "qFractional" {-# INLINABLE qFractionalS #-} qUnitS :: Quote qUnitS = quoteWith "qUnit" {-# INLINABLE qUnitS #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Data/FastString.hs ================================================ {-# LANGUAGE CPP #-} -- | Version compatibility module for GHC.Data.FastString module Language.Finkel.Data.FastString ( module FS , module Language.Finkel.Data.FastString ) where #include "ghc_modules.h" -- binary import Data.Binary (Binary (..), Get, Put) -- ghc import GHC_Data_FastString as FS #if !MIN_VERSION_ghc(9,2,0) unconsFS :: FastString -> Maybe (Char, FastString) unconsFS fs = case unpackFS fs of [] -> Nothing (c : cs) -> Just (c, mkFastString cs) {-# INLINABLE unconsFS #-} #endif -- ------------------------------------------------------------------------ -- For Data.Binary.Binary -- ------------------------------------------------------------------------ #if MIN_VERSION_ghc(9,0,0) putFastString :: FastString -> Put putFastString = put . FS.fastStringToShortByteString getFastString :: Get FastString getFastString = fmap FS.mkFastStringShortByteString get #else putFastString :: FastString -> Put putFastString = put . FS.bytesFS getFastString :: Get FastString getFastString = fmap FS.mkFastStringByteString get #endif {-# INLINABLE getFastString #-} {-# INLINABLE putFastString #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Data/Fractional.hs ================================================ {-# LANGUAGE CPP #-} -- | Module for version compatible fractional literal value. module Language.Finkel.Data.Fractional ( FractionalLit(..) , mkFractionalLit' , showFractionalList #if MIN_VERSION_ghc(9,2,0) -- XXX: Rename 'fl_value' with 'rationalFromFractionalLit'? , fl_value #endif , readFractionalLit , putFractionalLit , getFractionalLit ) where #include "ghc_modules.h" -- binary import Data.Binary (Binary (..), Get, Put) #if MIN_VERSION_ghc(9,2,0) import Data.Binary (getWord8, putWord8) #endif -- ghc #if MIN_VERSION_ghc(9,8,0) import GHC.Data.FastString (unpackFS) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Types.SourceText (FractionalExponentBase (..), FractionalLit (..), SourceText (..), mkSourceFractionalLit, mkTHFractionalLit, rationalFromFractionalLit) import GHC.Utils.Misc (readSignificandExponentPair) #else import GHC_Types_Basic (FractionalLit (..), SourceText (..), mkFractionalLit) import GHC_Utils_Misc (readRational) #endif -- Internal import Language.Finkel.Data.SourceText -- | Make a 'FractionalLit' from given real value. mkFractionalLit' :: Real a => a -> FractionalLit {-# INLINE mkFractionalLit' #-} #if MIN_VERSION_ghc(9,2,0) mkFractionalLit' = mkTHFractionalLit . toRational #else mkFractionalLit' = mkFractionalLit #endif -- | Get string representation of 'FractionalLit'. showFractionalList :: FractionalLit -> String {-# INLINE showFractionalList #-} #if MIN_VERSION_ghc(9,8,0) showFractionalList fl = case fl_text fl of NoSourceText -> error "fractional literal with no source" SourceText s -> unpackFS s #else showFractionalList fl = case fl_text fl of NoSourceText -> error "fractional literal with no source" SourceText s -> s #endif #if MIN_VERSION_ghc(9,2,0) -- | Get rational value from 'FractionalLit'. fl_value :: FractionalLit -> Rational fl_value = rationalFromFractionalLit {-# INLINE fl_value #-} #endif -- | Read a given string as base 10 'FractionalLit'. readFractionalLit :: String -> FractionalLit #if MIN_VERSION_ghc(9,2,0) readFractionalLit str = mkSourceFractionalLit str is_neg i e b where is_neg = startsWithMinus str (i, e) = readSignificandExponentPair str b = Base10 #else readFractionalLit str = FL stxt is_neg rat where is_neg = startsWithMinus str rat = readRational str stxt = SourceText str #endif {-# INLINABLE readFractionalLit #-} -- | Compare the first character of given string with minis sign. startsWithMinus :: String -> Bool startsWithMinus str = case str of '-': _ -> True _ -> False {-# INLINE startsWithMinus #-} putFractionalLit :: FractionalLit -> Put getFractionalLit :: Get FractionalLit {-# INLINABLE putFractionalLit #-} {-# INLINABLE getFractionalLit #-} #if MIN_VERSION_ghc(9,2,0) putFractionalLit fl = putSourceText (fl_text fl) *> put (fl_neg fl) *> put (fl_signi fl) *> put (fl_exp fl) *> putFEB (fl_exp_base fl) getFractionalLit = FL <$> getSourceText <*> get <*> get <*> get <*> getFEB putFEB :: FractionalExponentBase -> Put putFEB base = case base of Base2 -> putWord8 0 Base10 -> putWord8 1 {-# INLINE putFEB #-} getFEB :: Get FractionalExponentBase getFEB = do t <- getWord8 case t of 0 -> pure Base2 1 -> pure Base10 _ -> error ("get (FractionalExponentBase): unknown tag " ++ show t) {-# INLINE getFEB #-} #else putFractionalLit fl = putSourceText (fl_text fl) *> put (fl_neg fl) *> put (fl_value fl) getFractionalLit = FL <$> getSourceText <*> get <*> get #endif ================================================ FILE: finkel-kernel/src/Language/Finkel/Data/SourceText.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -- | Version compatibility module for 'SourceText'. module Language.Finkel.Data.SourceText ( SourceText , IsSourceText(..) , toQuotedSourceText , fsToSourceText , strToSourceText , putSourceText , getSourceText ) where #include "ghc_modules.h" -- binary import Data.Binary (Get, Put, getWord8, putWord8) #if !MIN_VERSION_ghc(9,8,0) import Data.Binary (Binary (..)) #endif -- ghc import GHC_Data_FastString (FastString) import GHC_Types_SourceText (SourceText (..)) #if MIN_VERSION_ghc(9,8,0) import GHC_Data_FastString (fsLit) #else import GHC_Data_FastString (unpackFS) #endif -- Internal #if MIN_VERSION_ghc(9,8,0) import Language.Finkel.Data.FastString (getFastString, putFastString) #endif -- ------------------------------------------------------------------------ -- Type class -- ------------------------------------------------------------------------ class IsSourceText s where toSourceText :: s -> SourceText instance IsSourceText String where toSourceText = strToSourceText {-# INLINE toSourceText #-} instance IsSourceText FastString where toSourceText = fsToSourceText {-# INLINE toSourceText #-} -- | Make a 'SourceText' quoted with double quotes, uses 'show' function. toQuotedSourceText :: Show a => a -> SourceText toQuotedSourceText = toSourceText . show {-# INLINE toQuotedSourceText #-} -- ------------------------------------------------------------------------ -- For Data.Binary.Binary -- ------------------------------------------------------------------------ putSourceText :: SourceText -> Put putSourceText st = case st of #if MIN_VERSION_ghc(9,8,0) SourceText str -> putWord8 0 >> putFastString str #else SourceText str -> putWord8 0 >> put str #endif NoSourceText -> putWord8 1 {-# INLINABLE putSourceText #-} getSourceText :: Get SourceText getSourceText = do t <- getWord8 case t of #if MIN_VERSION_ghc(9,8,0) 0 -> SourceText <$> getFastString #else 0 -> SourceText <$> get #endif 1 -> pure NoSourceText _ -> error $ "getSourceText: unknown tag " ++ show t {-# INLINABLE getSourceText #-} -- ------------------------------------------------------------------------ -- Converting to SourceText -- ------------------------------------------------------------------------ fsToSourceText :: FastString -> SourceText #if MIN_VERSION_ghc(9,8,0) fsToSourceText = SourceText #else fsToSourceText = SourceText . unpackFS #endif {-# INLINABLE fsToSourceText #-} strToSourceText :: String -> SourceText #if MIN_VERSION_ghc(9,8,0) strToSourceText = SourceText . fsLit #else strToSourceText = SourceText #endif {-# INLINABLE strToSourceText #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Emit.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Emit Haskell source code from Haskell AST value. -- -- This module contains types and functions for generating Haskell source code -- from AST data types defined in ghc package. -- -- The main purpose is to emit Haskell source code annotated with documentation -- comments understood by hadddock, so the generated result could be messy. -- -- Most of the implementations are defined with 'ppr' function from 'Outputable' -- type class. -- module Language.Finkel.Emit ( HsSrc(..) , Hsrc(..) , genHsSrc , putHsSrc ) where #include "ghc_modules.h" -- base import Control.Monad.IO.Class (MonadIO (..)) import System.IO (Handle) #if MIN_VERSION_ghc(9,6,0) import Data.Foldable (toList) #endif #if !MIN_VERSION_ghc(9,2,0) import Data.Maybe (fromMaybe) #endif #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif -- ghc import GHC (OutputableBndrId) import GHC_Data_Bag (bagToList, isEmptyBag) import GHC_Driver_Env (HscEnv (..)) import GHC_Driver_Monad (GhcMonad (..)) import GHC_Driver_Ppr (printForUser, showSDocForUser) import GHC_Hs (HsModule (..)) import GHC_Hs_Binds (LHsBinds, LSig, Sig (..), pprDeclList) import GHC_Hs_Decls (ConDecl (..), DocDecl (..), FamEqn (..), FamilyDecl (..), FamilyInfo (..), FamilyResultSig (..), HsDataDefn (..), HsDecl (..), InjectivityAnn (..), LConDecl, LDocDecl, LFamilyDecl, LTyFamDefltDecl, TyClDecl (..), TyFamInstEqn, pprHsFamInstLHS, pprTyFamInstDecl) import GHC_Hs_Extension (GhcPass) import GHC_Hs_ImpExp (IE (..), LIE) import GHC_Hs_Type (ConDeclField (..), HsConDetails (..), HsContext, HsType (..), HsWildCardBndrs (..), LConDeclField, LHsContext, LHsQTyVars (..), pprHsForAll) import GHC_Types_Basic (TopLevelFlag (..)) import GHC_Types_Fixity (LexicalFixity (..)) import GHC_Types_Name_Reader (RdrName) import GHC_Types_SrcLoc (GenLocated (..), sortLocated, unLoc) import GHC_Utils_Outputable (Outputable (..), OutputableBndr (..), SDoc, braces, char, comma, darrow, dcolon, dot, empty, equals, forAllLit, fsep, hang, hsep, interpp'SP, interppSP, lparen, nest, parens, pprWithCommas, punctuate, sep, text, vbar, vcat, ($$), ($+$), (<+>), (<>)) #if MIN_VERSION_ghc(9,6,0) import GHC (getNamePprCtx) #else import GHC (getPrintUnqual) #define getNamePprCtx getPrintUnqual #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Hs (XModulePs (..)) import GHC.Hs.Extension (GhcPs) import Language.Haskell.Syntax.Decls (DataDefnCons (..), dataDefnConsNewOrData) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Hs.Doc (LHsDoc, hsDocString) #else import GHC_Hs_Doc (LHsDocString) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env (hsc_units) import GHC.Hs (XRec) import GHC.Hs.Decls (FunDep (..), HsConDeclGADTDetails (..)) import GHC.Hs.Type (HsSigType (..), pprHsOuterSigTyVarBndrs) import GHC.Parser.Annotation (noAnn) #else import GHC_Core_Class (pprFundeps) import GHC_Hs_Type (HsImplicitBndrs (..), LHsType) import GHC_Types_SrcLoc (Located, noLoc) #endif #if MIN_VERSION_ghc(9,2,0) import GHC_Hs_Type (pprLHsContext) #else import GHC_Hs_Type (noLHsContext, pprLHsContext) #endif #if MIN_VERSION_ghc(9,2,0) import GHC_Utils_Outputable (arrow) #else import GHC_Utils_Outputable (arrow, pprPanic) #endif #if MIN_VERSION_ghc(9,2,0) import Language.Haskell.Syntax.Extension (IdP) #else import GHC_Hs_Extension (IdP) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Hs_Type (HsForAllTelescope (..), HsScaled (..), hsScaledThing, mkHsForAllInvisTele) import GHC_Utils_Outputable (Depth (..)) #else import GHC_Types_Var (ForallVisFlag (..)) #endif #if !MIN_VERSION_ghc(9,0,0) import GHC_Hs_Type (LHsTyVarBndr) #endif #if MIN_VERSION_ghc(9,4,0) import GHC_Hs_Doc (HsDocString, renderHsDocString) #else import GHC_Hs_Doc (HsDocString, unpackHDS) #endif -- Internal import Language.Finkel.Lexer import Language.Finkel.Syntax.Location -- --------------------------------------------------------------------- -- -- Constraints for Outputable -- -- --------------------------------------------------------------------- type OUTPUTABLE a pr = (OutputableBndrId pr, a ~ GhcPass pr) -- --------------------------------------------------------------------- -- -- Annotation dictionary -- -- --------------------------------------------------------------------- {- isDocComment :: Located AnnotationComment -> Bool isDocComment x = case unLoc x of AnnDocCommentNext _ -> True AnnDocCommentPrev _ -> True AnnDocCommentNamed _ -> True AnnDocSection _ _ -> True _ -> False buildDocMap :: [Located AnnotationComment] -> DocMap buildDocMap acs = go (Map.empty, Nothing, []) (sortLocated acs) where go :: ( Map.Map SrcSpan [AnnotationComment] , Maybe SrcSpan , [AnnotationComment] ) -> [Located AnnotationComment] -> DocMap go (acc, keySpan, block) [] = case keySpan of Nothing -> acc Just k -> Map.insert k (reverse block) acc go (acc, keySpan, block) (com:coms) = case keySpan of Just k -> case (k, getLoc com) of (RealSrcSpan k', RealSrcSpan com') -> if (srcSpanEndLine k' + 1) == srcSpanStartLine com' then go ( acc , Just (combineSrcSpans k (getLoc com)) , unLoc com:block ) coms else let acc' = Map.insert k (reverse block) acc isDoc = isDocComment com keySpan' | isDoc = Just (getLoc com) | otherwise = Nothing block' | isDoc = [unLoc com] | otherwise = [] in go (acc', keySpan', block') coms _ -> go (acc, Nothing, []) coms Nothing -> if isDocComment com then go (acc, Just (getLoc com), [unLoc com]) coms else go (acc, Nothing, block) coms spanStartLine :: SrcSpan -> Int spanStartLine l = case l of RealSrcSpan s -> srcSpanStartLine s _ -> -1 spanEndLine :: SrcSpan -> Int spanEndLine l = case l of RealSrcSpan s -> srcSpanEndLine s _ -> -1 -- | Lookup previous documentation comment. -- -- Here @previous@ means the end line of documentation comment matches -- to the start line of reference span - offset. -- lookupPrevDoc :: Int -> SrcSpan -> DocMap -> Maybe [AnnotationComment] lookupPrevDoc offset l = let line = spanStartLine l f k a | spanEndLine k == line - offset = Just a | otherwise = Nothing in Map.foldMapWithKey f emitPrevDoc :: SPState -> Located a -> SDoc emitPrevDoc = emitPrevDocWithOffset 1 emitPrevDocWithOffset :: Int -> SPState -> Located a -> SDoc emitPrevDocWithOffset offset st ref = case lookupPrevDoc offset (getLoc ref) (docMap st) of Nothing -> empty Just as -> vcat (map f as) where f annotated = case annotated of AnnDocCommentNext doc -> case lines doc of c:cs -> vcat ((text "-- | " <> text c): map (\ x -> text "--" <> text x) cs) [] -> empty AnnLineComment doc -> text "-- " <> text doc _ -> ppr annotated #if !MIN_VERSION_ghc(8,4,0) -- | 'whenPprDebug' does not exist in ghc 8.2. Defining one with -- 'ifPprDebug'. Also, number of arguments in 'ifPprDebug' changed in -- ghc 8.4. whenPprDebug :: SDoc -> SDoc whenPprDebug d = ifPprDebug d #endif -} -- --------------------------------------------------------------------- -- -- HsSrc class -- -- --------------------------------------------------------------------- -- | Type class for generating textual source code. class HsSrc a where toHsSrc :: SPState -> a -> SDoc -- | A wrapper type to specify instance of 'HsSrc'. newtype Hsrc a = Hsrc {unHsrc :: a} -- | Generate textual source code from given data. genHsSrc :: (GhcMonad m, HsSrc a) => SPState -> a -> m String genHsSrc st0 x = do hsc_env <- getSession let dflags = hsc_dflags hsc_env unqual <- getNamePprCtx #if MIN_VERSION_ghc(9,2,0) return (showSDocForUser dflags (hsc_units hsc_env) unqual (toHsSrc st0 x)) #else return (showSDocForUser dflags unqual (toHsSrc st0 x)) #endif -- | Print textual source code of given data to given 'Handle'. putHsSrc :: (GhcMonad m, HsSrc a, MonadIO m) => Handle -> SPState -> a -> m () putHsSrc hdl st0 x = do hsc_env <- getSession unqual <- getNamePprCtx let dflags = hsc_dflags hsc_env #if MIN_VERSION_ghc(9,0,1) render = printForUser dflags hdl unqual AllTheWay #else render = printForUser dflags hdl unqual #endif liftIO (render (toHsSrc st0 x)) -- --------------------------------------------------------------------- -- -- Instances -- -- --------------------------------------------------------------------- instance HsSrc RdrName where toHsSrc _ = ppr instance (HsSrc b) => HsSrc (GenLocated a b) where toHsSrc st (L _ e) = toHsSrc st e -- Some CPP macros to pattern match with constructors of HsModule. #if MIN_VERSION_ghc(9,6,0) #define HSMODEXT modExt #define HSMODDEPREC {- no hsmodDeprecMessage -} #define HSMODMBDOC {- no hsmodHaddockModHeader -} #else #define HSMODEXT {- no hsmodExt -} #define HSMODDEPREC deprec #define HSMODMBDOC mbDoc #endif #if !MIN_VERSION_ghc(9,2,0) || MIN_VERSION_ghc(9,6,0) #define HSMODANN {- no hsmodAnn -} #else #define HSMODANN _hsmodAnn #endif #if !MIN_VERSION_ghc(9,0,0) || MIN_VERSION_ghc(9,6,0) #define LAYOUTINFO {- no LayoutInfo -} #else #define LAYOUTINFO _layout_info #endif -- HsModule used had an argument until 9.0, and then the argument came back in -- 9.6. #if MIN_VERSION_ghc(9,6,0) instance HsSrc (Hsrc (HsModule GhcPs)) where #elif MIN_VERSION_ghc(9,0,0) instance HsSrc (Hsrc HsModule) where #else instance OUTPUTABLE a pr => HsSrc (Hsrc (HsModule a)) where #endif toHsSrc st a = case unHsrc a of HsModule HSMODEXT HSMODANN LAYOUTINFO mb_name exports imports decls HSMODDEPREC HSMODMBDOC -> vcat ([ pp_headerPragmas st , pp_mbdocn mbDoc ] ++ mb_header ++ [ pp_nonnull imports , hsSrc_nonnull st (map unLoc decls) , text "" ]) where mb_header = case mb_name of Nothing -> [] Just name -> [ case exports of Nothing -> pp_header name (text "where") Just es -> vcat [ pp_header name lparen , nest 8 (pp_lies st (unLoc es)) , nest 4 (text ") where") ]] pp_header name rest = case deprec of Nothing -> pp_modname name <+> rest Just d -> vcat [pp_modname name, ppr d, rest] pp_modname name = text "module" <+> ppr name #if MIN_VERSION_ghc(9,6,0) mbDoc = hsmodHaddockModHeader modExt deprec = hsmodDeprecMessage modExt #endif instance OUTPUTABLE a pr => HsSrc (Hsrc (IE a)) where toHsSrc _st (Hsrc ie) = case ie of IEGroup _ n doc -> commentWithHeader ("-- " ++ replicate n '*') (getHsDocString doc) IEDoc _ doc -> commentWithHeader "-- |" (getHsDocString doc) IEDocNamed _ doc -> text ("-- $" ++ doc) _ -> ppr ie -- -------------------------------------------------------------------- -- -- Top level declarations -- ----------------------------------------------------------------------- instance OUTPUTABLE a pr => HsSrc (HsDecl a) where toHsSrc st decl = case decl of SigD _ sig -> toHsSrc st sig TyClD _ tycld -> toHsSrc st tycld DocD _ doc -> toHsSrc st doc _ -> ppr decl -- -------------------------------------------------------------------- -- -- Type signature -- ----------------------------------------------------------------------- instance OUTPUTABLE a pr => HsSrc (Sig a) where toHsSrc st sig = case sig of TypeSig _ vars ty -> pprVarSig (map unLoc vars) (toHsSrc st ty) ClassOpSig _ is_dflt vars ty | is_dflt -> text "default" <+> pprVarSig (map unLoc vars) (toHsSrc st ty) | otherwise -> pprVarSig (map unLoc vars) (toHsSrc st ty) _ -> ppr sig #if MIN_VERSION_ghc(9,2,0) instance (OUTPUTABLE a pr) => HsSrc (HsSigType a) where toHsSrc st (HsSig { sig_bndrs = outer_bndrs, sig_body = body}) = pprHsOuterSigTyVarBndrs outer_bndrs <+> toHsSrc st body #endif instance (OUTPUTABLE a pr, Outputable thing, HsSrc thing) => HsSrc (HsWildCardBndrs a thing) where toHsSrc st wc = case wc of HsWC { hswc_body = ty } -> toHsSrc st ty #if !MIN_VERSION_ghc(9,0,0) _ -> ppr wc #endif #if !MIN_VERSION_ghc(9,2,0) instance (OUTPUTABLE a pr) => HsSrc (HsImplicitBndrs a (LHsType a)) where toHsSrc st ib = case ib of HsIB { hsib_body = ty } -> toHsSrc st ty # if !MIN_VERSION_ghc(9,0,0) _ -> ppr ib # endif #endif instance (OUTPUTABLE a pr) => HsSrc (HsType a) where toHsSrc st ty = case ty of #if MIN_VERSION_ghc(9,0,0) HsForAllTy {hst_tele=tele, hst_body=ty1} -> sep [pprHsTele tele, hsrc ty1] #else HsForAllTy {hst_bndrs=tvs, hst_body=ty1} -> sep [pprHsForAllTvs tvs, hsrc ty1] #endif #if MIN_VERSION_ghc(9,4,0) HsQualTy {hst_ctxt=ctxt, hst_body=ty1} -> sep [ pprHsContextAlways (unLoc ctxt) , hsrc ty1 ] #elif MIN_VERSION_ghc(9,2,0) HsQualTy {hst_ctxt=ctxt, hst_body=ty1} -> sep [ maybe (parens empty <+> darrow) (pprHsContextAlways . unLoc) ctxt , hsrc ty1] #else HsQualTy {hst_ctxt=L _ ctxt, hst_body=ty1} -> sep [pprHsContextAlways ctxt, hsrc ty1] #endif #if MIN_VERSION_ghc(9,0,0) HsFunTy _ _arrow ty1 ty2 -> t_arr_t ty1 ty2 #else HsFunTy _ ty1 ty2 -> t_arr_t ty1 ty2 #endif HsDocTy _ ty1 (L _ docstr) -> #if MIN_VERSION_ghc(9,4,0) ppr ty1 $+$ commentWithHeader "-- ^" (hsDocString docstr) #else ppr ty1 $+$ commentWithHeader "-- ^" docstr #endif HsParTy _ ty1 -> parens (hsrc ty1) _ -> ppr ty where t_arr_t t1 t2 = sep [hsrc t1, text "->", hsrc t2] hsrc :: HsSrc a => a -> SDoc hsrc = toHsSrc st #if MIN_VERSION_ghc(9,0,0) instance (HsSrc a) => HsSrc (HsScaled pass a) where toHsSrc st (HsScaled _cnt t) = toHsSrc st t #endif #if MIN_VERSION_ghc(9,0,0) pprHsTele :: OutputableBndrId p => HsForAllTelescope (GhcPass p) -> SDoc pprHsTele hsfat = case hsfat of HsForAllVis {hsf_vis_bndrs=_bndrs}-> error "pprHsTele: HsForAllVis NYI" HsForAllInvis {hsf_invis_bndrs=bndrs} -> forAllLit <+> interppSP bndrs <> dot #else pprHsForAllTvs :: OUTPUTABLE n pr => [LHsTyVarBndr n] -> SDoc pprHsForAllTvs qtvs | null qtvs = forAllLit <+> dot | otherwise = forAllLit <+> interppSP qtvs <> dot #endif -- From 'HsBinds.pprVarSig'. pprVarSig :: OutputableBndr id => [id] -> SDoc -> SDoc pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] where pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) -- From 'HsTypes.pprHsContextAlways'. pprHsContextAlways :: OUTPUTABLE n pr => HsContext n -> SDoc pprHsContextAlways [] = parens empty <+> darrow pprHsContextAlways [L _ ty] = ppr ty <+> darrow pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow -- -------------------------------------------------------------------- -- -- TyClDecl -- -- -------------------------------------------------------------------- instance OUTPUTABLE a pr => HsSrc (TyClDecl a) where toHsSrc st tcd = case tcd of SynDecl { tcdLName = ltycon, tcdTyVars = tyvars , tcdFixity = fixity, tcdRhs = rhs } -> hang (text "type" <+> #if MIN_VERSION_ghc(9,2,0) pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> #else pp_vanilla_decl_head ltycon tyvars fixity [] <+> #endif equals) 4 (toHsSrc st rhs) DataDecl { tcdLName = ltycon, tcdTyVars = tyvars , tcdFixity = fixity, tcdDataDefn = defn } -> pp_data_defn st (pp_vanilla_decl_head ltycon tyvars fixity) defn ClassDecl { tcdCtxt = context, tcdLName = lclas , tcdTyVars = tyvars, tcdFixity = fixity , tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods , tcdATs = ats, tcdATDefs = at_defs , tcdDocs = docs } | null sigs && isEmptyBag methods && null ats && null at_defs -> top_matter | otherwise -> vcat [ top_matter <+> text "where" , nest 2 (pprDeclList (ppr_cdecl_body st ats at_defs methods sigs docs))] where top_matter = text "class" #if MIN_VERSION_ghc(9,2,0) <+> pp_vanilla_decl_head lclas tyvars fixity context #else <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context) #endif <+> pprFundeps (map unLoc fds) _ -> ppr tcd #if MIN_VERSION_ghc(9,2,0) -- Until ghc 9.0.2, GHC.Core.pprFundeps were reused. pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc pprFundeps [] = empty pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) pprFunDep :: OutputableBndrId p => FunDep (GhcPass p) -> SDoc pprFunDep (FunDep _ us vs) = hsep [interppSP us, arrow, interppSP vs] #endif -- -------------------------------------------------------------------- -- -- For SynDecl and DataDecl -- -- -------------------------------------------------------------------- pp_data_defn :: OUTPUTABLE n pr => SPState #if MIN_VERSION_ghc(9,2,0) -> (Maybe (LHsContext n) -> SDoc) #else -> (HsContext n -> SDoc) #endif -> HsDataDefn n -> SDoc pp_data_defn st pp_hdr HsDataDefn { dd_cType = mb_ct, dd_kindSig = mb_sig #if !MIN_VERSION_ghc(9,6,0) , dd_ND = new_or_data #endif #if MIN_VERSION_ghc(9,2,0) , dd_ctxt = context #else , dd_ctxt = L _ context #endif , dd_cons = condecls , dd_derivs = derivings } | null condecls = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig <+> pp_derivings derivings | otherwise = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig) 2 (pp_cds condecls $$ pp_derivings derivings) where #if MIN_VERSION_ghc(9,6,0) new_or_data = dataDefnConsNewOrData condecls pp_cds cds = case cds of -- The _bool field in `DataTypeCOns' is for TypeData language extension -- introduced in ghc 9.6.1. NewTypeCon c -> text "=" <+> pprConDecl st (unLoc c) DataTypeCons _bool cs -> pp_condecls st cs #else pp_cds = pp_condecls st #endif pp_ct = maybe empty ppr mb_ct pp_sig = maybe empty ((dcolon <+>) . ppr) mb_sig #if MIN_VERSION_ghc(9,2,0) pp_derivings ds = vcat (map ppr ds) #else pp_derivings (L _ ds) = vcat (map ppr ds) #endif #if !MIN_VERSION_ghc(9,0,0) pp_data_defn _ _ (XHsDataDefn x) = ppr x #endif -- Modified version of 'HsDecls.pp_condecls', no space in front of "|", -- taking 'SPState' as first argument. pp_condecls :: (OUTPUTABLE n pr) => SPState -> [LConDecl n] -> SDoc pp_condecls st cs@(L _ ConDeclGADT {} : _) = hang (text "where") 2 (vcat (map (pprConDecl st . unLoc) cs)) pp_condecls st cs = equals <+> sep (punctuate (text " |") (map (pprConDecl st . unLoc) cs)) -- For pattern match of 'PrefixCon' in below 'pprConDecl' function. #if MIN_VERSION_ghc(9,2,0) #define _TYARGS _ #else #define _TYARGS {- no [tyargs] -} #endif -- Modified version of 'HsDecls.pprConDecl'. This function does the pretty -- printing of documentation for constructors. -- -- Although the syntax parser for constructor documentation accepts ":doc^" -- form, this function emit documentation before the constructor declaration, to -- support documentation for constructor argument. This is because haddock may -- concatenate the docstring for the last constructor argument and the docstring -- for constructor itself. pprConDecl :: OUTPUTABLE n pr => SPState -> ConDecl n -> SDoc pprConDecl st condecl@ConDeclH98 {} = pp_mbdocn doc $+$ sep [hforall, ppr_details details] where #if MIN_VERSION_ghc(9,2,0) hforall = pprHsForAll' (mkHsForAllInvisTele noAnn tvs) mcxt #elif MIN_VERSION_ghc(9,0,0) hforall = pprHsForAll' (mkHsForAllInvisTele tvs) cxt cxt = fromMaybe (noLoc []) mcxt #else hforall = pprHsForAll' tvs cxt cxt = fromMaybe (noLoc []) mcxt #endif ConDeclH98 { con_name = L _ con , con_ex_tvs = tvs , con_mb_cxt = mcxt , con_args = details , con_doc = doc } = condecl #if MIN_VERSION_ghc(9,0,0) ppr_details (InfixCon t1 t2) = hsep [hsrc (hsScaledThing t1), pprInfixOcc con, hsrc (hsScaledThing t2)] ppr_details (PrefixCon _TYARGS tys) = sep (pprPrefixOcc con : map (hsrc . unLoc . hsScaledThing) tys) #else ppr_details (InfixCon t1 t2) = hsep [hsrc t1, pprInfixOcc con, hsrc t2] ppr_details (PrefixCon tys) = sep (pprPrefixOcc con : map (hsrc . unLoc) tys) #endif ppr_details (RecCon fields) = pprPrefixOcc con <+> pprConDeclFields (unLoc fields) hsrc :: HsSrc a => a -> SDoc hsrc = toHsSrc st pprConDecl st ConDeclGADT { con_names = cons #if MIN_VERSION_ghc(9,2,0) , con_bndrs = L _ outer_bndrs , con_g_args = args #else , con_qvars = qvars , con_args = args #endif , con_mb_cxt = mcxt , con_res_ty = res_ty , con_doc = doc } = pp_mbdocn doc $+$ ppr_con_names cons' <+> dcolon <+> sep [hforall -- pprHsForAll' (hsq_explicit qvars) cxt ,ppr_arrow_chain (get_args args ++ [hsrc res_ty])] where #if MIN_VERSION_ghc(9,6,0) cons' = toList cons #else cons' = cons #endif #if MIN_VERSION_ghc(9,2,0) hforall = pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt #elif MIN_VERSION_ghc(9,0,0) hforall = pprHsForAll' (mkHsForAllInvisTele qvars) cxt cxt = fromMaybe (noLoc []) mcxt #else hforall = pprHsForAll' (hsq_explicit qvars) cxt cxt = fromMaybe (noLoc []) mcxt #endif #if MIN_VERSION_ghc(9,10,0) get_args (PrefixConGADT _x csts) = map hsrc csts get_args (RecConGADT _ fields) = [pprConDeclFields (unLoc fields)] #elif MIN_VERSION_ghc(9,4,0) get_args (PrefixConGADT csts) = map hsrc csts get_args (RecConGADT fields _) = [pprConDeclFields (unLoc fields)] #elif MIN_VERSION_ghc(9,2,0) get_args (PrefixConGADT csts) = map hsrc csts get_args (RecConGADT fields) = [pprConDeclFields (unLoc fields)] #else get_args (PrefixCon as) = map hsrc as get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons) #endif ppr_arrow_chain [] = empty ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) hsrc :: HsSrc a => a -> SDoc hsrc = toHsSrc st #if !MIN_VERSION_ghc(9,0,0) pprConDecl _ con = ppr con #endif -- From 'HsDecls.ppr_con_names'. #if MIN_VERSION_ghc(9,2,0) ppr_con_names :: OutputableBndr a => [GenLocated l a] -> SDoc #else ppr_con_names :: OutputableBndr a => [Located a] -> SDoc #endif ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) -- Modified version of 'HsTypes.pprConDeclFields', to emit documentation -- comments of fields in record data type. pprConDeclFields :: OUTPUTABLE n pr => [LConDeclField n] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ ConDeclField { cd_fld_names = ns , cd_fld_type = ty , cd_fld_doc = mb_doc }) = ppr_names ns <+> dcolon <+> ppr ty $+$ pp_mbdocp mb_doc $+$ text "" ppr_fld (L _ (XConDeclField x)) = ppr x ppr_names [n] = ppr n ppr_names ns = sep (punctuate comma (map ppr ns)) -- From 'HsDecls.pp_vanilla_decl_head'. pp_vanilla_decl_head :: (OUTPUTABLE n pr) #if MIN_VERSION_ghc(9,2,0) => XRec n (IdP n) #else => Located (IdP n) #endif -> LHsQTyVars n -> LexicalFixity #if MIN_VERSION_ghc(9,2,0) -> Maybe (LHsContext n) #else -> HsContext n #endif -> SDoc pp_vanilla_decl_head thing HsQTvs {hsq_explicit=tyvars} fixity context = hsep [pprHsContext context, pp_tyvars tyvars] where pp_tyvars (varl:varsr) | fixity == Infix, varsr_hd:varsr_tl <- varsr = hsep [ char '(', ppr (unLoc varl), pprInfixOcc (unLoc thing) , ppr (unLoc varsr_hd), char ')' , hsep (map (ppr . unLoc) varsr_tl) ] | fixity == Infix = hsep [ ppr (unLoc varl), pprInfixOcc (unLoc thing) , hsep (map (ppr . unLoc) varsr) ] | otherwise = hsep [ pprPrefixOcc (unLoc thing) , hsep (map (ppr . unLoc) (varl: varsr)) ] pp_tyvars [] = pprPrefixOcc (unLoc thing) #if !MIN_VERSION_ghc(9,0,0) pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x #endif -- -------------------------------------------------------------------- -- -- For ClassDecl -- -- -------------------------------------------------------------------- ppr_cdecl_body :: OUTPUTABLE n pr => SPState -> [LFamilyDecl n] #if MIN_VERSION_ghc(8,10,1) -> [LTyFamDefltDecl n] #else -> [LTyFamDefltEqn n] #endif -> LHsBinds n -> [LSig n] #if MIN_VERSION_ghc(9,2,0) -> [LDocDecl n] #else -> [LDocDecl] #endif -> [SDoc] ppr_cdecl_body st ats at_defs methods sigs docs = body where body = map unLoc (sortLocated body0) body0 = map (reLoc . fmap (pprFamilyDecl NotTopLevel)) ats ++ #if MIN_VERSION_ghc(9,2,0) map (reLoc . fmap (pprTyFamInstDecl NotTopLevel)) at_defs ++ #else map (\d@(L l _) -> L l (ppr_fam_deflt_eqn d)) at_defs ++ #endif map (reLoc . fmap (toHsSrc st)) sigs ++ map (reLoc . fmap ppr) (bagToList methods) ++ map (reLoc . fmap (toHsSrc st)) docs #if MIN_VERSION_ghc(9,2,0) #define XCINJECTIVITYANN unused #define _XCINJECTIVITYANN _ #else #define XCINJECTIVITYANN {- no XCInjectivityAnn -} #define _XCINJECTIVITYANN {- no XCInjectivityAnn -} #endif -- From 'HsDecls.pprFamilyDecl'. Used during pretty printing type class body -- contents, with first argument set to 'NonTopLevel'. pprFamilyDecl :: (OUTPUTABLE n pr) => TopLevelFlag -> FamilyDecl n -> SDoc pprFamilyDecl top_level FamilyDecl { fdInfo = info , fdLName = ltycon , fdTyVars = tyvars , fdFixity = fixity , fdResultSig = L _ result , fdInjectivityAnn = mb_inj } = vcat [ pprFlavour info <+> pp_top_level <+> #if MIN_VERSION_ghc(9,2,0) pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> #else pp_vanilla_decl_head ltycon tyvars fixity [] <+> #endif pp_kind <+> pp_inj <+> pp_where , nest 2 pp_eqns ] where pp_top_level = case top_level of TopLevel -> text "family" NotTopLevel -> empty pp_kind = case result of NoSig _ -> empty KindSig _ kind -> dcolon <+> ppr kind TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr #if !MIN_VERSION_ghc(9,0,0) XFamilyResultSig x -> ppr x #endif pp_inj = case mb_inj of Just (L _ (InjectivityAnn _XCINJECTIVITYANN lhs rhs)) -> hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] Nothing -> empty (pp_where, pp_eqns) = case info of ClosedTypeFamily mb_eqns -> ( text "where" , case mb_eqns of Nothing -> text ".." Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) _ -> (empty, empty) #if !MIN_VERSION_ghc(9,0,0) pprFamilyDecl _ (XFamilyDecl x) = ppr x #endif -- From 'HsDecls.pprFlavour'. pprFlavour :: FamilyInfo pass -> SDoc pprFlavour DataFamily = text "data" pprFlavour OpenTypeFamily = text "type" pprFlavour ClosedTypeFamily {} = text "type" -- From 'HsDecls.ppr_fam_inst_eqn' ppr_fam_inst_eqn :: (OUTPUTABLE n pr) => TyFamInstEqn n -> SDoc #if MIN_VERSION_ghc(9,2,0) ppr_fam_inst_eqn (FamEqn { feqn_tycon = L _ tycon , feqn_bndrs = bndrs , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = rhs }) = pprHsFamInstLHS tycon bndrs pats fixity Nothing <+> equals <+> ppr rhs #else ppr_fam_inst_eqn HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon , feqn_bndrs = bndrs , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = rhs }} = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs # if !MIN_VERSION_ghc(9,0,0) ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x ppr_fam_inst_eqn _ = error "ppr_fam_inst_eqn" # endif #endif -- From 'HsDecls.ppr_fam_deflt_eqn' #if !MIN_VERSION_ghc(9,2,0) ppr_fam_deflt_eqn :: OUTPUTABLE n pr => LTyFamDefltDecl n -> SDoc ppr_fam_deflt_eqn (L _ tfdd) = pprTyFamInstDecl NotTopLevel tfdd #endif -- --------------------------------------------------------------------- -- -- DocDecl -- -- --------------------------------------------------------------------- #if MIN_VERSION_ghc(9,4,0) #define DOCDECL (DocDecl pass) #else #define DOCDECL DocDecl #endif instance HsSrc DOCDECL where toHsSrc _st d = case d of DocCommentNext ds -> text "" $+$ commentWithHeader "-- |" (getHsDocString ds) DocCommentPrev ds -> text "" $+$ commentWithHeader "-- ^" (getHsDocString ds) $+$ text "" DocCommentNamed name ds -> namedDoc name (getHsDocString ds) DocGroup n ds -> let stars = replicate n '*' in commentWithHeader ("-- " ++ stars) (getHsDocString ds) where namedDoc name doc = let body = map (\x -> text "--" <+> text x) (lines (unpackHDS' doc)) in vcat (text "" : text ("-- $" ++ name) : text "--" : body) -- ------------------------------------------------------------------- -- -- Auxiliary -- -- ------------------------------------------------------------------- pp_nonnull :: Outputable t => [t] -> SDoc pp_nonnull [] = empty pp_nonnull xs = vcat (map ppr xs) #if MIN_VERSION_ghc(9,4,0) pp_mbdocn :: Maybe (LHsDoc pass) -> SDoc pp_mbdocn = maybe empty (commentWithHeader "-- |" . getHsDocString) pp_mbdocp :: Maybe (LHsDoc pass) -> SDoc pp_mbdocp = maybe empty (commentWithHeader "-- ^" . getHsDocString) #else pp_mbdocn :: Maybe LHsDocString -> SDoc pp_mbdocn = maybe empty (commentWithHeader "-- |" . unLoc) pp_mbdocp :: Maybe LHsDocString -> SDoc pp_mbdocp = maybe empty (commentWithHeader "-- ^" . unLoc) #endif pp_headerPragmas :: SPState -> SDoc pp_headerPragmas sp = vcat sorted_pragmas where sorted_pragmas = map unLoc (sortLocated pragmas) pragmas = map lang (langExts sp) ++ map ghc_opt (ghcOptions sp) ++ map haddock_opt (haddockOptions sp) lang (L l e) = L l (gen "LANGUAGE" e) ghc_opt (L l o) = L l (gen "OPTIONS_GHC" o) haddock_opt (L l o) = L l (gen "OPTIONS_HADDOCK" o) gen label x = text "{-#" <+> text label <+> text x <+> text "#-}" hsSrc_nonnull :: HsSrc a => SPState -> [a] -> SDoc hsSrc_nonnull st xs = case xs of [] -> empty _ -> vcat (map (toHsSrc st) xs) commentWithHeader :: String -> HsDocString -> SDoc commentWithHeader header doc = case lines (unpackHDS' doc) of [] -> empty d:ds -> vcat ((text header <+> text d): map (\ x -> text "--" <+> text x) ds) -- | Format located export elements. -- -- This function converts module export elements and comments to 'SDoc'. -- Export elements are punctuated with commas, and newlines are inserted -- between documentation comments. pp_lies :: OUTPUTABLE a pr => SPState -> [LIE a] -> SDoc pp_lies st = go where go [] = empty go ds = case break (isDocIE . unLoc) ds of (nondocs, rest) -> let sdoc = fsep (punctuate comma (map (toHsSrc st . Hsrc . unLoc) nondocs)) sdoc' = case nondocs of [] -> sdoc _ -> sdoc <> comma in case rest of [] -> sdoc doc:rest' -> sdoc' $+$ toHsSrc st (Hsrc (unLoc doc)) $+$ go rest' -- | 'True' when the argument is for documentation. isDocIE :: IE a -> Bool isDocIE ie = case ie of IEGroup {} -> True IEDoc {} -> True IEDocNamed {} -> True _ -> False -- | GHC version compatible function for unpacking 'HsDocString'. unpackHDS' :: HsDocString -> String #if MIN_VERSION_ghc(9,4,0) -- XXX: Consider using 'exactPrintHsDocString' or 'pprHsDocString'. unpackHDS' = renderHsDocString #else unpackHDS' = unpackHDS #endif -- | GHC version compatible function for pretty printing 'HsContext'. #if MIN_VERSION_ghc(9,2,0) pprHsContext :: OUTPUTABLE a pr => Maybe (LHsContext a) -> SDoc pprHsContext = pprLHsContext #else pprHsContext :: OUTPUTABLE n a => HsContext (GhcPass a) -> SDoc pprHsContext = pprLHsContext . noLoc #endif -- | GHC version compatible function for pretty printing @forall@. #if MIN_VERSION_ghc(9,2,0) pprHsForAll' :: OUTPUTABLE a pr => HsForAllTelescope a -> Maybe (LHsContext a) -> SDoc pprHsForAll' = pprHsForAll #elif MIN_VERSION_ghc(9,0,0) pprHsForAll' :: OUTPUTABLE a pr => HsForAllTelescope a -> LHsContext a -> SDoc pprHsForAll' = pprHsForAll #else pprHsForAll' :: OUTPUTABLE a pr => [LHsTyVarBndr a] -> LHsContext a -> SDoc pprHsForAll' = pprHsForAll ForallInvis #endif #if MIN_VERSION_ghc(9,4,0) getHsDocString :: LHsDoc pass -> HsDocString getHsDocString = hsDocString . unLoc #else getHsDocString :: HsDocString -> HsDocString getHsDocString = id #endif {-# INLINABLE getHsDocString #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Error.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | Version compatible variant of error message type and functions. module Language.Finkel.Error ( -- * Simple SDoc error message WrappedMsg , mkWrappedMsg , mkPlainWrappedMsg -- * For printing error message , HasLogger(..), Logger, WARNINGs , printLocatedString , printOrThrowDiagnostics' ) where #include "ghc_modules.h" -- base import Control.Monad.IO.Class (MonadIO (..)) #if MIN_VERSION_ghc(9,4,0) import Data.Typeable (Typeable) #endif -- ghc import GHC_Data_Bag (unitBag) import GHC_Driver_Session (DynFlags) import GHC_Types_SrcLoc (SrcSpan) import GHC_Utils_Outputable (SDoc, neverQualify, text) #if MIN_VERSION_ghc(9,8,0) import GHC.Driver.Errors (printOrThrowDiagnostics) #elif MIN_VERSION_ghc(9,2,0) import GHC.Driver.Errors (handleFlagWarnings) #else import GHC_Driver_Types (handleFlagWarnings) #endif #if MIN_VERSION_ghc(9,8,0) import GHC.Driver.Errors.Types (DriverMessage) import GHC.Types.Error (Messages, defaultDiagnosticOpts) #elif MIN_VERSION_ghc(9,0,0) import GHC.Driver.CmdLine (Warn) #else import CmdLineParser (Warn) #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Types.Error (NoDiagnosticOpts (..)) import GHC.Utils.Outputable (NamePprCtx) #else import GHC_Utils_Outputable (PrintUnqualified) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Config.Diagnostic (initDiagOpts) import GHC.Driver.Errors (printMessages) import GHC.Types.Error (mkMessages) #else import GHC_Driver_Errors (printBagOfErrors) #endif #if MIN_VERSION_ghc(9,4,0) -- For "instance Diagnostic GhcMessage" import GHC.Driver.Errors.Ppr () import GHC.Driver.Errors.Types (GhcMessage (..), ghcUnknownMessage) import GHC.Types.Error (Diagnostic (..), DiagnosticReason (..), mkSimpleDecorated, noHints) import GHC.Utils.Error (MsgEnvelope, mkErrorMsgEnvelope, mkPlainErrorMsgEnvelope) #elif MIN_VERSION_ghc(9,2,0) import GHC.Types.Error (DecoratedSDoc, MsgEnvelope, mkMsgEnvelope, mkPlainMsgEnvelope) #else import GHC_Utils_Error (ErrMsg, mkErrMsg, mkPlainErrMsg) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Utils.Logger (HasLogger (..), Logger) #endif -- ------------------------------------------------------------------------ -- Wrapper type for SDoc -- ------------------------------------------------------------------------ #if MIN_VERSION_ghc(9,4,0) newtype SDocWrapper = SDocWrapper {unSDocWrapper :: SDoc} deriving (Typeable) instance Diagnostic SDocWrapper where #if MIN_VERSION_ghc(9,6,0) type DiagnosticOpts SDocWrapper = NoDiagnosticOpts diagnosticMessage _no_diagnostic_opts = mkSimpleDecorated . unSDocWrapper # if !MIN_VERSION_ghc(9,8,0) defaultDiagnosticOpts = NoDiagnosticOpts # endif -- XXX: May worth adding Finkel specific diagnostic code. diagnosticCode _ = Nothing #else diagnosticMessage = mkSimpleDecorated . unSDocWrapper #endif diagnosticReason = const ErrorWithoutFlag diagnosticHints = const noHints wrapSDoc :: SDoc -> GhcMessage wrapSDoc = ghcUnknownMessage . SDocWrapper #endif -- | Synonym for message with 'SDoc'. #if MIN_VERSION_ghc(9,4,0) type WrappedMsg = MsgEnvelope GhcMessage #elif MIN_VERSION_ghc(9,2,0) type WrappedMsg = MsgEnvelope DecoratedSDoc #else type WrappedMsg = ErrMsg #endif #if MIN_VERSION_ghc(9,6,0) mkWrappedMsg :: DynFlags -> SrcSpan -> NamePprCtx -> SDoc -> WrappedMsg #else mkWrappedMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> WrappedMsg #endif {-# INLINABLE mkWrappedMsg #-} mkPlainWrappedMsg :: DynFlags -> SrcSpan -> SDoc -> WrappedMsg {-# INLINABLE mkPlainWrappedMsg #-} #if MIN_VERSION_ghc(9,4,0) mkWrappedMsg _dflags sp pq sdoc = mkErrorMsgEnvelope sp pq (wrapSDoc sdoc) mkPlainWrappedMsg _dflags sp sdoc = mkPlainErrorMsgEnvelope sp (wrapSDoc sdoc) #elif MIN_VERSION_ghc(9,2,0) mkWrappedMsg = const mkMsgEnvelope mkPlainWrappedMsg = const mkPlainMsgEnvelope #else mkWrappedMsg = mkErrMsg mkPlainWrappedMsg = mkPlainErrMsg #endif -- ------------------------------------------------------------------------ -- For printing error messages -- ------------------------------------------------------------------------ printLocatedString :: MonadIO m => Logger -> DynFlags -> SrcSpan -> String -> m () printLocatedString _logger dflags l str = do let em = mkWrappedMsg dflags l neverQualify (text str) #if MIN_VERSION_ghc(9,6,0) let ghc_msg = mkMessages (unitBag em) diagnostic_opts = defaultDiagnosticOpts @GhcMessage diag_opts = initDiagOpts dflags liftIO (printMessages _logger diagnostic_opts diag_opts ghc_msg) #elif MIN_VERSION_ghc(9,4,0) let ghc_msg = mkMessages (unitBag em) liftIO (printMessages _logger (initDiagOpts dflags) ghc_msg) #elif MIN_VERSION_ghc(9,2,0) liftIO (printBagOfErrors _logger dflags (unitBag em)) #else liftIO (printBagOfErrors dflags (unitBag em)) #endif {-# INLINABLE printLocatedString #-} #if MIN_VERSION_ghc(9,8,0) type WARNINGs = Messages DriverMessage #else type WARNINGs = [Warn] #endif -- GHC.Utils.Logger did not exist until ghc 9.2. #if !MIN_VERSION_ghc(9,2,0) class HasLogger m where getLogger :: m Logger data Logger -- should never constructed. #endif -- | Version compatibility function for 'printOrThrowDiagnostics', former -- @handleFlagWarnings@ function. printOrThrowDiagnostics' :: MonadIO m => Logger -> DynFlags -> WARNINGs -> m () printOrThrowDiagnostics' _logger dflags warns = do #if MIN_VERSION_ghc(9,8,0) let diagnostic_opts = defaultDiagnosticOpts @GhcMessage diag_opts = initDiagOpts dflags msg = GhcDriverMessage <$> warns liftIO $ printOrThrowDiagnostics _logger diagnostic_opts diag_opts msg #elif MIN_VERSION_ghc(9,6,0) let diagnostic_opts = defaultDiagnosticOpts @GhcMessage diag_opts = initDiagOpts dflags liftIO $ handleFlagWarnings _logger diagnostic_opts diag_opts warns #elif MIN_VERSION_ghc(9,4,0) liftIO $ handleFlagWarnings _logger (initDiagOpts dflags) warns #elif MIN_VERSION_ghc(9,2,0) liftIO $ handleFlagWarnings _logger dflags warns #else liftIO $ handleFlagWarnings dflags warns #endif ================================================ FILE: finkel-kernel/src/Language/Finkel/Eval.hs ================================================ {-# LANGUAGE CPP #-} -- | Module containing functions for code evaluation. module Language.Finkel.Eval ( evalDecls , evalExpr , evalExprType , evalTypeKind ) where #include "ghc_modules.h" -- base import Control.Monad.IO.Class (MonadIO (..)) -- ghc import GHC_Core_TyCo_Rep (Kind, Type (..)) import GHC_Core_TyCo_Tidy (tidyType) import GHC_Driver_Env_Types (HscEnv (..)) import GHC_Driver_Main (hscParsedDecls) import GHC_Driver_Monad (GhcMonad (..), withSession) import GHC_Runtime_Context (InteractiveContext (..)) import GHC_Runtime_Eval (compileParsedExprRemote) import GHC_Tc_Module (TcRnExprMode (..), tcRnExpr, tcRnType) import GHC_Types_TyThing (TyThing (..)) import GHC_Types_Var_Env (emptyTidyEnv) import GHC_Utils_Error (Messages) #if MIN_VERSION_ghc(9,8,0) import GHC.Tc.Zonk.Env (ZonkFlexi (..)) #else import GHC_Tc_Utils_Zonk (ZonkFlexi (..)) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Errors.Types (GhcMessage, hoistTcRnMessage) import GHC.Tc.Errors.Types (TcRnMessage) #elif MIN_VERSION_ghc(9,2,0) import GHC_Types_Error (DecoratedSDoc) #endif #if MIN_VERSION_ghc(9,2,0) import GHC_Types_Error (partitionMessages) import GHC_Types_SourceError (throwErrors) #else import Control.Exception (throwIO) import GHC_Types_SourceError (mkSrcErr) #endif -- ghci import GHCi.RemoteTypes (HValue, localRef, withForeignRef) -- internal import Language.Finkel.Builder (HDecl, HExpr, HType) -- --------------------------------------------------------------------- -- -- Eval functions -- -- --------------------------------------------------------------------- -- | Evaluate given expression to haskell value. evalExpr :: GhcMonad m => HExpr -> m HValue evalExpr expr = do fhv <- compileParsedExprRemote expr liftIO (withForeignRef fhv localRef) {-# INLINABLE evalExpr #-} -- | Evaluate the type of given expression. evalExprType :: GhcMonad m => HExpr -> m Type evalExprType expr = do -- See `InteractiveEval.exprType' and `HscMain.hscTcExpr'. As in `evalDecls', -- taking HExpr instead of Haskell source code String. -- -- XXX: Currently, `TcRnExprMode' is hard coded as `TM_Inst' in below call to -- `tcRnExpr'. In ghci, user can type in and specify the mode from REPL -- session. -- hsc_env <- getSession ty <- ioMsgMaybe $ hoistTcRnMessage' $ tcRnExpr hsc_env TM_Inst expr return $ tidyType emptyTidyEnv ty {-# INLINABLE evalExprType #-} -- | Evaluate the kind of given type. Returned values is a pair of the -- argument type and the kind of that type. evalTypeKind :: GhcMonad m => HType -> m (Type, Kind) evalTypeKind ty = do -- See `InteractiveEval.typeKind' and `HscMain.hscKcType'. -- -- XXX: The second argument of `tcRnType' is hard coded as `True' in below -- code. -- hsc_env <- getSession ioMsgMaybe $ hoistTcRnMessage' $ tcRnType' hsc_env True ty {-# INLINABLE evalTypeKind #-} -- | Evaluate given declarations. The returned value is resulting 'TyThing's of -- declarations and updated interactive context. evalDecls :: GhcMonad m => [HDecl] -> m ([TyThing], InteractiveContext) evalDecls decls = withSession (\hsc_env -> liftIO (hscParsedDecls hsc_env decls)) -- --------------------------------------------------------------------- -- -- Auxiliary -- -- --------------------------------------------------------------------- -- Separation of TcRnMessage and GhcMessage was introduced in ghc 9.4. #if MIN_VERSION_ghc(9,4,0) hoistTcRnMessage' :: Monad m => m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a) hoistTcRnMessage' = hoistTcRnMessage #else hoistTcRnMessage' :: a -> a hoistTcRnMessage' = id #endif {-# INLINABLE hoistTcRnMessage' #-} -- | Like 'HscMain.ioMsgMaybe', but for 'Fnk'. #if MIN_VERSION_ghc(9,4,0) ioMsgMaybe :: MonadIO m => IO (Messages GhcMessage, Maybe a) -> m a #elif MIN_VERSION_ghc(9,2,0) ioMsgMaybe :: MonadIO m => IO (Messages DecoratedSDoc, Maybe a) -> m a #else ioMsgMaybe :: MonadIO m => IO (Messages, Maybe a) -> m a #endif #if MIN_VERSION_ghc(9,2,0) ioMsgMaybe ioA = do -- XXX: Log warning messages. (msgs, mb_r) <- liftIO ioA let (_warns, errs) = partitionMessages msgs maybe (throwErrors errs) pure mb_r #else ioMsgMaybe ioA = do ((_warns, errs), mb_r) <- liftIO ioA maybe (liftIO (throwIO (mkSrcErr errs))) return mb_r #endif {-# INLINABLE ioMsgMaybe #-} -- | GHC version compatibility helper for 'tcRnType'. #if MIN_VERSION_ghc(9,4,0) tcRnType' :: HscEnv -> Bool -> HType -> IO (Messages TcRnMessage, Maybe (Type, Kind)) #elif MIN_VERSION_ghc(9,2,0) tcRnType' :: HscEnv -> Bool -> HType -> IO (Messages DecoratedSDoc, Maybe (Type, Kind)) #else tcRnType' :: HscEnv -> Bool -> HType -> IO (Messages, Maybe (Type, Kind)) #endif tcRnType' hsc_env = tcRnType hsc_env DefaultFlexi {-# INLINABLE tcRnType' #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Exception.hs ================================================ {-# LANGUAGE CPP #-} -- | Exception related types and functions in @finkel-kernel@. module Language.Finkel.Exception ( FinkelException(..) , finkelExceptionLoc , readOrFinkelException , handleFinkelException , printFinkelException ) where #include "ghc_modules.h" -- base import Control.Exception (Exception (..), throw) import Control.Monad.IO.Class (MonadIO (..)) import System.IO (hPutStrLn, stderr) -- ghc import GHC_Driver_Session (HasDynFlags (..)) import GHC_Types_SrcLoc (GenLocated (..), SrcSpan) import GHC_Utils_Exception (ExceptionMonad) #if MIN_VERSION_ghc(9,0,0) -- exceptions import Control.Monad.Catch (handle) #else -- ghc import GHC_Utils_Exception (ghandle) #endif -- Internal import Language.Finkel.Error import Language.Finkel.Form -- --------------------------------------------------------------------- -- -- Type -- -- --------------------------------------------------------------------- -- | Exception for @finkel-kernel@@ package. data FinkelException = LexicalException SrcSpan Char -- ^ Lexical error. | InvalidUnquoteSplice Code -- ^ Invalid unquote splice with 'Code' value. | FinkelSrcError Code String -- ^ Error with 'Code' information and additional message. | FinkelException String -- ^ General exception with message. deriving (Eq, Show) instance Exception FinkelException where displayException = displayFinkelException {-# INLINE displayException #-} displayFinkelException :: FinkelException -> String displayFinkelException e = case e of LexicalException _ c -> "Lexical error near " ++ show c InvalidUnquoteSplice c -> "Invalid unquote splice: " ++ show c FinkelSrcError _ s -> s FinkelException s -> s {-# INLINEABLE displayFinkelException #-} -- | Get source location information if available. finkelExceptionLoc :: FinkelException -> Maybe SrcSpan finkelExceptionLoc fe = case fe of LexicalException l _ -> Just l InvalidUnquoteSplice (LForm (L l _)) -> Just l FinkelSrcError (LForm (L l _)) _ -> Just l _ -> Nothing {-# INLINABLE finkelExceptionLoc #-} readOrFinkelException :: Read s => String -> String -> String -> s readOrFinkelException what name str = case reads str of [(x, "")] -> x _ -> throw (FinkelException ("Expecting " ++ what ++ " for " ++ name ++ ", but got " ++ show str)) {-# INLINABLE readOrFinkelException #-} -- | Print 'FinkelException' with source code information when available. printFinkelException :: (HasLogger m, HasDynFlags m, MonadIO m) => FinkelException -> m () printFinkelException e = case finkelExceptionLoc e of Nothing -> liftIO $ hPutStrLn stderr msg Just l -> do logger <- getLogger dflags <- getDynFlags printLocatedString logger dflags l msg where msg = displayException e -- ------------------------------------------------------------------------ -- -- Type fixed variant functions -- -- ------------------------------------------------------------------------ handleFinkelException :: ExceptionMonad m => (FinkelException -> m a) -> m a -> m a #if MIN_VERSION_ghc(9,0,0) handleFinkelException = handle #else handleFinkelException = ghandle #endif ================================================ FILE: finkel-kernel/src/Language/Finkel/Expand.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | Module for macro expansion. module Language.Finkel.Expand ( expand , expand1 , expands , expands' ) where #include "ghc_modules.h" -- base import Data.Char (isLower) import Data.Foldable (foldlM) -- containers import qualified Data.Map as Map -- ghc import GHC_Types_SrcLoc (GenLocated (..)) import GHC_Utils_Outputable (Outputable (..), SDoc, cat, fsep, nest, vcat) -- Internal import Language.Finkel.Data.FastString (FastString, unconsFS) import Language.Finkel.Fnk import Language.Finkel.Form -- --------------------------------------------------------------------- -- -- Macro expander -- -- --------------------------------------------------------------------- -- | Returns a list of bounded names in let expression. boundedNames :: Code -> [FastString] boundedNames form = case unCode form of List xs -> concatMap boundedName xs Atom (ASymbol n) -> [n] _ -> [] {-# INLINABLE boundedNames #-} boundedName :: Code -> [FastString] boundedName form = case unCode form of List (LForm (L _ (Atom (ASymbol "="))):n:_) -> boundedNameOne n _ -> [] {-# INLINABLE boundedName #-} boundedNameOne :: Code -> [FastString] boundedNameOne form = case unCode form of Atom (ASymbol n) -> [n] List ns -> concatMap f ns HsList ns -> concatMap f ns _ -> [] where f x = case unCode x of Atom (ASymbol n) | startsWithLower n -> [n] _ -> [] {-# INLINABLE boundedNameOne #-} startsWithLower :: FastString -> Bool startsWithLower fs = case unconsFS fs of Just (c, _) -> isLower c _ -> False {-# INLINABLE startsWithLower #-} -- | Perform 'Fnk' action with temporary shadowed macro environment. withShadowing :: [FastString] -- ^ Names of macro to shadow. -> Fnk a -- ^ Action to perform. -> Fnk a withShadowing toShadow act = do fnk_env <- getFnkEnv let emacros = envMacros fnk_env tmacros = envTmpMacros fnk_env f name _ = unMacroName name `notElem` toShadow putFnkEnv fnk_env { envMacros = Map.filterWithKey f emacros , envTmpMacros = map (Map.filterWithKey f) tmacros } result <- act modifyFnkEnv (\e -> e { envMacros = emacros , envTmpMacros = tmacros }) return result -- | Expand forms, with taking care of @begin@ special form. expands :: [Code] -> Fnk [Code] expands forms = do fnk_env <- getFnkEnv let macro_names me = if null me then nest 2 "None" else nest 2 (fsep (map (ppr . unMacroName) (Map.keys me))) tmp_macros = Map.unions (envTmpMacros fnk_env) debug fnk_env Nothing [ "Global macros:", macro_names (envMacros fnk_env) , "Temporary macros:", macro_names tmp_macros ] expands' forms -- | Internal works for 'expands'. expands' :: [Code] -> Fnk [Code] expands' = fmap concat . mapM expand' {-# INLINABLE expands' #-} -- | Expand form to list of 'Code', supports special form /begin/. expand' :: Code -> Fnk [Code] expand' form = case unCode form of List (hd:_) | Atom (ASymbol ":quote") <- unCode hd -> return [form] _ -> do form' <- expand form case unCode form' of List (LForm (L _ (Atom (ASymbol ":begin"))):rest) -> case rest of [] -> return [] _ -> expands' rest _ -> return [form'] {-# INLINABLE expand' #-} -- | Recursively expands the given 'Code'. expand :: Code -> Fnk Code expand form = case unLForm form of L l (List forms) -> case forms of -- Expand `let' expression, `do' expression, `case' expression, lambda -- expression and function binding with shadowing the lexically bounded -- names. Expansion of other forms are done without name shadowing. -- This function does not expand quoted forms, to preserve the structure -- of the quoted forms containing `:begin'. kw@(LForm (L _ (Atom (ASymbol x)))):y:rest | x == "let" -> expandLet l kw y rest | x == "do" -> expandDo l kw (y:rest) | x == "case" -> expandCase l kw y rest | x == "where" -> expandWhere l kw y rest | x == "=" || x == "\\" -> expandFunBind l kw (y:rest) | x == ":quote" -> return form _ -> expandList l forms L l (HsList forms) -> -- Without recursively calling 'expand' on the result, cannot expand -- macro-generating macros. LForm . L l . HsList <$> expands' forms -- Non-list forms are untouched. _ -> return form where expandLet l kw binds body = do binds' <- expand binds let bounded = boundedNames binds' body' <- withShadowing bounded (expands' body) return $! LForm (L l (List (kw:binds':body'))) expandDo l kw body = do (_, body') <- foldlM expandInDo ([], []) body return $! LForm (L l (List (kw:reverse body'))) expandFunBind l kw rest = do let args = init rest body = last rest bounded = concatMap boundedNameOne args args' <- expands' args body' <- withShadowing bounded (expand body) return $! LForm (L l (List (kw:args'++[body']))) expandCase l kw expr rest = do let go acc xs = case xs of -- Pattern may have prefix (e.g. '~' for lazy pattern) pat_prefix:pat:expr0:rest0 | pat_prefix == tilde -> do pat' <- expand pat expr1 <- withShadowing (boundedNameOne pat') (expand expr0) go (expr1:pat':pat_prefix:acc) rest0 pat:expr0:rest0 -> do pat' <- expand pat expr1 <- withShadowing (boundedNameOne pat') (expand expr0) go (expr1:pat':acc) rest0 _ -> return acc tilde = LForm (L l (Atom (ASymbol "~"))) expr' <- expand expr rest' <- go [] rest return $! LForm (L l (List (kw:expr':reverse rest'))) expandWhere l kw expr rest = do rest' <- expands' rest let bounded = concatMap boundedName rest' expr' <- withShadowing bounded (expand expr) return $! LForm (L l (List (kw:expr':rest'))) expandList l forms = case forms of sym@(LForm (L _ (Atom (ASymbol k)))) : rest -> do fnk_env <- getFnkEnv case lookupMacro k fnk_env of Just m -> do_expand k (macroFunction m) >>= expand Nothing -> LForm . L l . List . (sym:) <$> expands' rest _ -> do forms' <- expands' forms return $! LForm (L l (List forms')) do_expand k f = do fnk_env <- getFnkEnv debug fnk_env Nothing [vcat ["Expanding:", nest 2 (ppr form)]] ret0 <- f form debug fnk_env Nothing [cat [ppr k, " ==>"], nest 2 (ppr ret0)] return ret0 expandInDo :: ([FastString], [Code]) -> Code -> Fnk ([FastString], [Code]) expandInDo (bounded, xs) x = do let newbind = case x of LForm (L _ (List (LForm (L _ (Atom (ASymbol sym))):n:_))) | sym == "<-" -> boundedNameOne n _ -> [] x' <- withShadowing bounded (expand x) return (newbind ++ bounded, x':xs) {-# INLINABLE expandInDo #-} -- | Expand given form once if the form is a macro form, otherwise -- return the given form. expand1 :: Code -> Fnk Code expand1 form = case unLForm form of L _l (List ((LForm (L _ (Atom (ASymbol k)))) : _)) -> do fnk_env <- getFnkEnv case lookupMacro k fnk_env of Just m -> macroFunction m form Nothing -> return form _ -> return form {-# INLINABLE expand1 #-} -- | Debug function fot macro expansion. debug :: FnkEnv -> Maybe SDoc -> [SDoc] -> Fnk () debug = debugWith Fnk_trace_expand {-# INLINABLE debug #-} debugWith :: FnkDebugFlag -> FnkEnv -> Maybe SDoc -> [SDoc] -> Fnk () debugWith debug_flag fnk_env mb_extra msgs0 = let msgs1 = maybe msgs0 (: msgs0) mb_extra in debugWhen fnk_env debug_flag msgs1 {-# INLINABLE debugWith #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Fnk.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Wrapper for Finkel code compilation monad. module Language.Finkel.Fnk ( -- * Finkel compiler monad Fnk(..) , FnkEnv(..) , FnkEnvRef(..) , FnkInvokedMode(..) , Macro(..) , MacroFunction , MacroName(..) , EnvMacros , FlagSet , runFnk , runFnk' , toGhc , fromGhc , emptyFnkEnv , initFnkEnv , getFnkEnv , putFnkEnv , modifyFnkEnv , setDynFlags , updateDynFlags , withTmpDynFlags , prepareInterpreter , useInterpreter -- * Error related functions , failFnk , finkelSrcError -- * GHC library directory , getLibDirFromGhc , initializeLibDirFromGhc -- * Debugging , FnkDebugFlag(..) , fopt , foptSet , setFnkVerbosity , debugWhen , debugWhen' , dumpDynFlags , dumpHscEnv , getFnkDebug -- * Macro related functions , emptyEnvMacros , insertMacro , lookupMacro , makeEnvMacros , mergeMacros , addMacro , deleteMacro , macroNames , isMacro , macroFunction -- * Gensym and UniqSupply , gensym , gensym' , initUniqSupply' -- * Re-export from 'exceptions' package , MonadCatch(..) , MonadThrow(..) , MonadMask(..) ) where #include "ghc_modules.h" -- base import Control.Concurrent (MVar, newMVar, withMVar) import Control.Exception (throw, throwIO) import Control.Monad (mplus, unless, when) import Control.Monad.IO.Class (MonadIO (..)) import Data.Bifunctor (first) import Data.Bits (setBit, testBit, zeroBits) import Data.Char (isSpace) import Data.IORef (IORef, atomicModifyIORef', atomicWriteIORef, newIORef, readIORef) import Data.Word (Word8) import System.Environment (getProgName, lookupEnv) import System.Exit (exitFailure) import System.IO (stderr) import System.IO.Unsafe (unsafePerformIO) #if MIN_VERSION_ghc(9,10,0) import Data.Word (Word64) #endif -- containers import qualified Data.Map as Map import System.Directory (canonicalizePath, doesFileExist, findExecutable) import System.FilePath (takeDirectory, ()) -- exceptions import Control.Monad.Catch (MonadCatch (..), MonadMask (..), MonadThrow (..)) #if MIN_VERSION_ghc(9,0,0) import Control.Monad.Catch (bracket) #else import GHC_Utils_Exception (ExceptionMonad (..)) #endif -- process import System.Process (readProcess) -- ghc import GHC (ModSummary (..), runGhc) import qualified GHC_Data_EnumSet as EnumSet import GHC_Data_FastString (FastString, fsLit, uniqueOfFS, unpackFS) import GHC_Driver_Env_Types (HscEnv (..)) import GHC_Driver_Main (Messager, batchMsg) import GHC_Driver_Monad (Ghc (..), GhcMonad (..), Session (..), modifySession) import GHC_Driver_Ppr (showSDocForUser) import GHC_Driver_Session (DynFlags (..), GeneralFlag (..), GhcLink (..), HasDynFlags (..), IncludeSpecs (..), gopt, gopt_set, gopt_unset, opt_P_signature, picPOpts, ways) import GHC_Platform_Ways (wayGeneralFlags, wayUnsetGeneralFlags) import GHC_Runtime_Context (InteractiveContext (..)) import GHC_Settings_Config (cProjectVersion) import GHC_Types_TyThing (TyThing (..)) import GHC_Types_Unique_Supply (MonadUnique (..), UniqSupply, initUniqSupply, mkSplitUniqSupply, splitUniqSupply, takeUniqFromSupply) import GHC_Types_Var (varType) import GHC_Unit_Home_ModInfo (pprHPT) import GHC_Utils_CliOption (showOpt) import GHC_Utils_Outputable (Outputable (..), SDoc, alwaysQualify, defaultErrStyle, nest, ppr, printSDocLn, sep, text, vcat, (<+>)) import qualified GHC_Utils_Ppr as Pretty #if MIN_VERSION_ghc(9,6,0) import GHC.Driver.Backend (interpreterBackend) #elif MIN_VERSION_ghc(9,2,0) import GHC.Driver.Backend (Backend (..)) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Env (hscSetFlags, hsc_HPT, hsc_HUG) import GHC.Driver.Hooks (Hooks (..)) import GHC.Driver.Make (ModIfaceCache, newIfaceCache) import GHC.Settings (ToolSettings (..)) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env (hsc_units) #else import GHC_Driver_Session (HscTarget (..)) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Driver_Session (initSDocContext, sccProfilingEnabled) import GHC_Platform_Ways (hostFullWays) #else import GHC_Platform_Ways (interpWays, updateWays) #endif -- Internal import Language.Finkel.Error import Language.Finkel.Exception import Language.Finkel.Form -- --------------------------------------------------------------------- -- -- Macro and Fnk monad -- -- --------------------------------------------------------------------- -- | Macro transformer function. -- -- A macro in Finkel is implemented as a function. The function takes a located -- code data argument, and returns a located code data wrapped in 'Fnk'. type MacroFunction = Code -> Fnk Code -- | Data type to distinguish user defined macros from built-in special forms. data Macro = Macro MacroFunction | SpecialForm MacroFunction instance Show Macro where showsPrec _ m = case m of Macro _ -> showString "" SpecialForm _ -> showString "" -- | Type synonym to express mapping of macro name to 'Macro' data. type EnvMacros = Map.Map MacroName Macro newtype MacroName = MacroName {unMacroName :: FastString} deriving (Eq) instance Ord MacroName where compare (MacroName a) (MacroName b) = compare (uniqueOfFS a) (uniqueOfFS b) {-# INLINE compare #-} -- | Data type for debug information. data FnkDebugFlag = Fnk_dump_dflags | Fnk_dump_expand | Fnk_dump_hs | Fnk_dump_session | Fnk_trace_expand | Fnk_trace_session | Fnk_trace_make | Fnk_trace_spf deriving (Eq, Show, Enum) -- | Type synonym for holding on/off of 'FnkDebugFlag'. type FlagSet = Word8 -- Word8 is enough for now. -- | Data type to hold how the compiler was invoked. data FnkInvokedMode = ExecMode -- ^ Standalone executable mode. | GhcPluginMode -- ^ GHC plugin mode. instance Outputable FnkInvokedMode where ppr im = case im of ExecMode -> "exec" GhcPluginMode -> "ghc-plugin" -- | Environment state in 'Fnk'. data FnkEnv = FnkEnv { -- | Macros accessible in current compilation context. envMacros :: EnvMacros -- | Temporary macros in current compilation context. , envTmpMacros :: [EnvMacros] -- | Default set of macros, these macros will be used when -- resetting 'FnkEnv'. , envDefaultMacros :: EnvMacros -- | Modules to import to context. , envContextModules :: [String] -- | The default 'DynFlags', possibly containing settings from command line. , envDefaultDynFlags :: !(Maybe DynFlags) -- | Messager used in make. , envMessager :: Messager -- | Required home package modules names in current target. , envRequiredHomeModules :: [ModSummary] -- | Directory to save generated Haskell source codes. , envHsOutDir :: !(Maybe FilePath) -- | Lib directory passed to 'runGhc'. , envLibDir :: !(Maybe FilePath) -- | Whether to use qualified name for primitive functions used in quoting -- codes. , envQualifyQuotePrimitives :: !Bool -- | The 'HscEnv' used by the byte-code interpreter for macro expansion. , envSessionForExpand :: !(Maybe HscEnv) -- | The 'UniqSupply' for 'gensym'. , envUniqSupply :: UniqSupply -- | Verbosity level for Fnk related messages. , envVerbosity :: {-# UNPACK #-} !Int -- | Dump flag settings. , envDumpFlags :: {-# UNPACK #-} !FlagSet -- | How the compiler was invoked. , envInvokedMode :: !FnkInvokedMode -- | ModIFaceCache used by GHC's load function, for interpreter. , envInterpModIfaceCache :: !(Maybe ModIfaceCache) } -- | Newtype wrapper for compiling Finkel code to Haskell AST. newtype Fnk a = Fnk {unFnk :: FnkEnvRef -> Ghc a} -- | Reference to 'FnkEnv'. newtype FnkEnvRef = FnkEnvRef (IORef FnkEnv) instance Functor Fnk where fmap f (Fnk m) = Fnk (fmap f . m) {-# INLINE fmap #-} instance Applicative Fnk where pure x = Fnk (\_ -> pure x) {-# INLINE pure #-} Fnk f <*> Fnk m = Fnk (\ref -> f ref <*> m ref) {-# INLINE (<*>) #-} instance Monad Fnk where Fnk m >>= k = Fnk (\ref -> m ref >>= \v -> unFnk (k v) ref) {-# INLINE (>>=) #-} instance MonadFail Fnk where fail = failFnk {-# INLINE fail #-} instance MonadIO Fnk where liftIO io = Fnk (\_ -> liftIO io) {-# INLINE liftIO #-} instance MonadCatch Fnk where catch m h = Fnk (\ref -> unFnk m ref `catch` \e -> unFnk (h e) ref) {-# INLINE catch #-} instance MonadThrow Fnk where throwM e = Fnk (\ _ -> throwM e) {-# INLINE throwM #-} instance MonadMask Fnk where mask f = Fnk (\ref -> mask (\r -> let r' m = Fnk (r . unFnk m) in unFnk (f r') ref)) {-# INLINE mask #-} uninterruptibleMask f = Fnk (\ref -> uninterruptibleMask (\r -> let r' m = Fnk (r . unFnk m) in unFnk (f r') ref)) {-# INLINE uninterruptibleMask #-} #if MIN_VERSION_exceptions(0,10,0) generalBracket acquire release use = Fnk (\ref -> let acquire' = unFnk acquire ref release' r err = unFnk (release r err) ref use' v = unFnk (use v) ref in generalBracket acquire' release' use') {-# INLINE generalBracket #-} #endif #if !MIN_VERSION_ghc(9,0,0) -- Note: [Orphan instances for type classes from Control.Monad.Catch] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- Manually defining instances instead of "deriving via" approach done in ghc -- 9.0.1, to support older version of ghc which does not have support of -- "DerivingVia" language extension. instance MonadThrow Ghc where throwM e = liftIO (throwM e) {-# INLINE throwM #-} instance MonadCatch Ghc where catch m h = Ghc (\he -> unGhc m he `catch` \e -> unGhc (h e) he) {-# INLINE catch #-} instance MonadMask Ghc where mask f = Ghc (\he -> mask (\ r -> let r' m = Ghc (r . unGhc m) in unGhc (f r') he)) {-# INLINE mask #-} uninterruptibleMask f = Ghc (\he -> uninterruptibleMask (\r -> let r' m = Ghc (r . unGhc m) in unGhc (f r') he)) {-# INLINE uninterruptibleMask #-} #if MIN_VERSION_exceptions(0,10,0) generalBracket acquire release use = Ghc (\he -> let acquire' = unGhc acquire he release' r err = unGhc (release r err) he use' v = unGhc (use v) he in generalBracket acquire' release' use') {-# INLINE generalBracket #-} #endif instance ExceptionMonad Fnk where gcatch m h = Fnk (\ref -> unFnk m ref `gcatch` \e -> unFnk (h e) ref) {-# INLINE gcatch #-} gmask f = Fnk (\ref -> gmask (\r -> let r' m = Fnk (r . unFnk m) in unFnk (f r') ref)) {-# INLINE gmask #-} #endif instance MonadUnique Fnk where getUniqueSupplyM = do fnk_env <- getFnkEnv let (us1, us2) = splitUniqSupply (envUniqSupply fnk_env) putFnkEnv $ fnk_env { envUniqSupply = us2 } return us1 {-# INLINE getUniqueSupplyM #-} getUniqueM = do fnk_env <- getFnkEnv let (u, us1) = takeUniqFromSupply (envUniqSupply fnk_env) putFnkEnv $ fnk_env { envUniqSupply = us1 } return u {-# INLINE getUniqueM #-} instance HasDynFlags Fnk where getDynFlags = Fnk (const getDynFlags) {-# INLINE getDynFlags #-} #if MIN_VERSION_ghc(9,2,0) instance HasLogger Fnk where getLogger = Fnk (const getLogger) {-# INLINE getLogger #-} #else instance HasLogger Fnk where getLogger = pure (error "getLogger (Fnk): no Logger") #endif instance GhcMonad Fnk where getSession = Fnk (const getSession) {-# INLINE getSession #-} setSession hsc_env = Fnk (\_ -> setSession hsc_env) {-# INLINE setSession #-} -- | Run 'Fnk' with given environment. -- -- Internally calls 'initFnkEnv' and 'runGhc'. runFnk :: Fnk a -> FnkEnv -> IO a runFnk m fnk_env0 = do fnk_env1 <- initFnkEnv fnk_env0 ref <- newIORef fnk_env1 runGhc (envLibDir fnk_env1) (toGhc m (FnkEnvRef ref)) -- | Run 'Fnk' with given 'FnkEnv' and 'HscEnv'. -- -- This function does /NOT/ call 'initFnkEnv', uses 'unGhc' instead of 'runGhc'. runFnk' :: Fnk a -> FnkEnv -> HscEnv -> IO a runFnk' m fnk_env hsc_env = do fer <- FnkEnvRef <$> newIORef fnk_env session <- Session <$> newIORef hsc_env unGhc (toGhc m fer) session {-# INLINABLE runFnk' #-} -- | Extract 'Ghc' from 'Fnk'. toGhc :: Fnk a -> FnkEnvRef -> Ghc a toGhc = unFnk {-# INLINABLE toGhc #-} -- | Lift 'Ghc' to 'Fnk'. fromGhc :: Ghc a -> Fnk a fromGhc m = Fnk (const m) {-# INLINABLE fromGhc #-} -- | Get current 'FnkEnv'. getFnkEnv :: Fnk FnkEnv getFnkEnv = Fnk (\(FnkEnvRef ref) -> liftIO $! readIORef ref) {-# INLINABLE getFnkEnv #-} -- | Set current 'FnkEnv' to given argument. putFnkEnv :: FnkEnv -> Fnk () putFnkEnv fnk_env = Fnk (\(FnkEnvRef ref) -> liftIO $! atomicWriteIORef ref fnk_env) {-# INLINABLE putFnkEnv #-} -- | Update 'FnkEnv' with applying given function to current 'FnkEnv'. modifyFnkEnv :: (FnkEnv -> FnkEnv) -> Fnk () modifyFnkEnv f = Fnk (\(FnkEnvRef ref) -> liftIO $! atomicModifyIORef' ref (\fnk_env -> (f fnk_env, ()))) {-# INLINABLE modifyFnkEnv #-} -- | Throw 'FinkelException' with given message. failFnk :: MonadIO m => String -> m a failFnk = liftIO . throwIO . FinkelException {-# INLINABLE failFnk #-} -- | Throw 'FinkelSrcError' with given 'Code' and message. finkelSrcError :: (Monad m, MonadIO m) => Code -> String -> m a finkelSrcError code = liftIO . throwIO . FinkelSrcError code {-# INLINABLE finkelSrcError #-} -- | Initialize 'FnkEnv'. initFnkEnv :: FnkEnv -> IO FnkEnv initFnkEnv fnk_env = do uniqSupply <- mkSplitUniqSupply '_' libdir <- maybe getLibDirFromGhc pure (envLibDir fnk_env) interpModIfaceCache <- getNewModIfaceCache pure fnk_env { envLibDir = Just libdir , envUniqSupply = uniqSupply , envInterpModIfaceCache = Just interpModIfaceCache } {-# INLINABLE initFnkEnv #-} -- ModIfaceCache does not exist in ghc < 9.4. #if MIN_VERSION_ghc(9,4,0) getNewModIfaceCache :: MonadIO m => m ModIfaceCache getNewModIfaceCache = liftIO newIfaceCache #else type ModIfaceCache = () getNewModIfaceCache :: MonadIO m => m ModIfaceCache getNewModIfaceCache = pure () #endif {-# INLINABLE getNewModIfaceCache #-} -- | Empty 'FnkEnv' for performing computation with 'Fnk'. emptyFnkEnv :: FnkEnv emptyFnkEnv = FnkEnv { envMacros = emptyEnvMacros , envTmpMacros = [] , envDefaultMacros = emptyEnvMacros , envContextModules = [] , envDefaultDynFlags = Nothing , envMessager = batchMsg , envRequiredHomeModules = [] , envHsOutDir = Nothing , envLibDir = Nothing , envQualifyQuotePrimitives = False , envSessionForExpand = Nothing , envUniqSupply = uninitializedUniqSupply , envVerbosity = 1 , envDumpFlags = zeroBits , envInvokedMode = ExecMode , envInterpModIfaceCache = Nothing } where uninitializedUniqSupply :: UniqSupply uninitializedUniqSupply = throw (FinkelException "FnkEnv: UniqSupply not initialized") {-# INLINABLE emptyFnkEnv #-} -- | Set current 'DynFlags' to given argument. This function also sets the -- 'DynFlags' in interactive context. setDynFlags :: GhcMonad m => DynFlags -> m () setDynFlags dflags = modifySession (updateDynFlags dflags) {-# INLINABLE setDynFlags #-} -- | Update 'DynFlags' to given argument. This function also sets the 'DynFlags' -- in interactive context. updateDynFlags :: DynFlags -> HscEnv -> HscEnv updateDynFlags dflags hsc_env = -- From ghc 9.4, HomeUnitEnv data type contains its own homeUnitEnv_dflags -- field. HomeUnitEnv data type could be reached from hsc_unit_env field of -- HscEnv. Using 'hscSetFlags' function to update hsc_dflags and -- homeUnitEnv_dflags at once. #if MIN_VERSION_ghc(9,4,0) hscSetFlags dflags (hsc_env {hsc_IC = (hsc_IC hsc_env) {ic_dflags = dflags}}) #else hsc_env { hsc_dflags = dflags , hsc_IC = (hsc_IC hsc_env) {ic_dflags = dflags}} #endif -- | Run given action with temporary 'DynFlags'. withTmpDynFlags :: GhcMonad m => DynFlags -> m a -> m a withTmpDynFlags dflags act = wrap (\_ -> setDynFlags dflags >> act) where #if MIN_VERSION_ghc(9,0,0) wrap = bracket getDynFlags setDynFlags #else wrap = gbracket getDynFlags setDynFlags #endif {-# INLINABLE withTmpDynFlags #-} -- | Prepare 'DynFlags' for interactive evaluation. prepareInterpreter :: GhcMonad m => m () prepareInterpreter = do -- See: "main''" in "ghc/Main.hs". hsc_env <- getSession let dflags0 = ic_dflags (hsc_IC hsc_env) dflags4 = useInterpreter dflags0 setDynFlags dflags4 {-# INLINABLE prepareInterpreter #-} -- | Update given 'DynFlags' to use interpreter. useInterpreter :: DynFlags -> DynFlags useInterpreter dflags0 = let platform = targetPlatform dflags0 upd_gopt setter get_flags df = foldl setter df (concatMap (get_flags platform) (ways df)) dflags1 = dflags0 { ghcLink = LinkInMemory , verbosity = 1 } #if MIN_VERSION_ghc(9,6,0) dflags2 = dflags1 { backend = interpreterBackend , targetWays_ = hostFullWays } #elif MIN_VERSION_ghc(9,2,0) dflags2 = dflags1 { backend = Interpreter , targetWays_ = hostFullWays } #elif MIN_VERSION_ghc(9,0,0) dflags2 = dflags1 { hscTarget = HscInterpreted , ways = hostFullWays } #else dflags2 = updateWays (dflags1 { hscTarget = HscInterpreted , ways = hostFullWays }) hostFullWays = interpWays #endif dflags3 = upd_gopt gopt_set wayGeneralFlags dflags2 dflags4 = upd_gopt gopt_unset wayUnsetGeneralFlags dflags3 in dflags4 {-# INLINABLE useInterpreter #-} -- | Insert new macro. This function will override existing macro. insertMacro :: FastString -> Macro -> Fnk () insertMacro k v = modifyFnkEnv (\e -> e {envMacros = addMacro k v (envMacros e)}) {-# INLINABLE insertMacro #-} -- | Lookup macro by name. -- -- Lookup macro from persistent and temporary macros. When macros with -- conflicting name exist, the latest temporary macro wins. lookupMacro :: FastString -> FnkEnv -> Maybe Macro lookupMacro name fnk_env = go (envTmpMacros fnk_env) where go [] = Map.lookup (MacroName name) (envMacros fnk_env) go (t:ts) = Map.lookup (MacroName name) t `mplus` go ts {-# INLINABLE lookupMacro #-} -- | Empty 'EnvMacros'. emptyEnvMacros :: EnvMacros emptyEnvMacros = Map.empty -- | Make 'EnvMacros' from list of macro name and value pairs. makeEnvMacros :: [(String, Macro)] -> EnvMacros makeEnvMacros = Map.fromList . map (first (MacroName . fsLit)) {-# INLINABLE makeEnvMacros #-} -- | Merge macros. mergeMacros :: EnvMacros -> EnvMacros -> EnvMacros mergeMacros = Map.union {-# INLINABLE mergeMacros #-} -- | Delete macro by macro name. deleteMacro :: FastString -> EnvMacros -> EnvMacros deleteMacro fs = Map.delete (MacroName fs) {-# INLINABLE deleteMacro #-} addMacro :: FastString -> Macro -> EnvMacros -> EnvMacros addMacro fs = Map.insert (MacroName fs) {-# INLINABLE addMacro #-} -- | All macros in given macro environment, filtering out the special -- forms. macroNames :: EnvMacros -> [String] macroNames = Map.foldrWithKey f [] where f k m acc = case m of Macro _ -> unpackFS (unMacroName k) : acc _ -> acc {-# INLINABLE macroNames #-} -- | 'True' when given 'TyThing' is a 'Macro'. isMacro :: HscEnv -> TyThing -> Bool isMacro hsc_env thing = do let dflags = hsc_dflags hsc_env #if MIN_VERSION_ghc(9,2,0) tystr = showSDocForUser dflags us alwaysQualify . ppr . varType us = hsc_units hsc_env #else tystr = showSDocForUser dflags alwaysQualify . ppr . varType #endif case thing of AnId var -> tystr var == "Language.Finkel.Fnk.Macro" _ -> False {-# INLINABLE isMacro #-} -- | Extract function from macro and apply to given code. Uses 'emptyFnkEnv' -- with 'specialForms' to unwrap the macro from 'Fnk'. macroFunction :: Macro -> Code -> Fnk Code macroFunction mac = case mac of Macro f -> f SpecialForm f -> f {-# INLINABLE macroFunction #-} -- ------------------------------------------------------------------------ -- -- Gensym -- -- ------------------------------------------------------------------------ #if MIN_VERSION_ghc(9,10,0) type InitialUnique = Word64 #elif MIN_VERSION_ghc(9,2,0) type InitialUnique = Word #else type InitialUnique = Int #endif -- | Generate unique symbol with @gensym'@. gensym :: MonadUnique m => m Code gensym = gensym' "gensym_var" {-# INLINABLE gensym #-} -- | Generate unique symbol with given prefix. -- -- Note that although this function does not generate same symbol twice, -- generated symbol has a chance to have a same name from symbols entered from -- codes written by arbitrary users. gensym' :: MonadUnique m => String -> m Code gensym' prefix = do u <- getUniqueM return (LForm (genSrc (Atom (aSymbol (prefix ++ show u))))) {-# INLINABLE gensym' #-} -- Note: [Initialization of UniqSupply] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- Test codes in finkel-kernel packages are calling the 'defaultMain' function -- multiple times. To avoid initialization of UniqSupply multiple times, using -- top-level IORef to detect whether the initializatio has been done or not. -- | Variant of 'initUniqSupply' which does initialization only once. initUniqSupply' :: InitialUnique -> Int -> IO () initUniqSupply' ini incr = do is_initialized <- readIORef uniqSupplyInitialized unless is_initialized (do initUniqSupply ini incr atomicModifyIORef' uniqSupplyInitialized (const (True, ()))) {-# INLINABLE initUniqSupply' #-} -- | Top level 'IORef' for book keeping 'UniqSupply' initialization, obtained -- with 'unsafePerformIO'. uniqSupplyInitialized :: IORef Bool uniqSupplyInitialized = unsafePerformIO (newIORef False) {-# NOINLINE uniqSupplyInitialized #-} -- ------------------------------------------------------------------------ -- -- GHC lib directory -- -- ------------------------------------------------------------------------ -- | Read cached ghc libdir from top-level 'IORef'. -- -- If the libdir is not cached, invoke /ghc/ command to get the libdir. getLibDirFromGhc :: IO FilePath getLibDirFromGhc = do mb_path <- readIORef globalLibDirRef case mb_path of Just path -> pure path Nothing -> do path <- initializeLibDirFromGhc atomicModifyIORef' globalLibDirRef $ const (Just path, path) {-# INLINABLE getLibDirFromGhc #-} -- | Get ghc lib directory by file layout lookup or invoking @ghc -- --print-libdir@. initializeLibDirFromGhc :: IO FilePath initializeLibDirFromGhc = do -- Manually lookup the path of "ghc" executable, then try finding the -- "settings" file in installed ghc. Assuming file layouts are: -- is located at: -- -- .../bin/ghc <- symlink to ghc wrapper script -- .../lib/ghc-X.Y.Z <- $topdir -- -- To confirm that the "ghc-X.Y.Z" is indeed the library directory to return, -- checking the existence of "settings" file in the directory. If the -- "settings" file was not found, delegating the work by invoking the "ghc" -- command with "--print-libdir". This is slower than additional directory and -- file lookups, but should be safer and more reliable. -- -- See "GHC.BaseDir.getBaseDir" in "ghc-boot" package, which is doing similar -- work but using "getExecutablePath". mb_ghc_script <- findExecutable "ghc" >>= mapM canonicalizePath case mb_ghc_script of Nothing -> exitWithGhcNotFound Just ghc_script -> do let ghc_top_dir = takeDirectory (takeDirectory ghc_script) ghc_lib_dir0 = ghc_top_dir "lib" "ghc-" ++ cProjectVersion #if MIN_VERSION_ghc(9,4,0) -- Output of "ghc --print-libdir" changed in ghc 9.4. ghc_lib_dir1 = ghc_lib_dir0 "lib" #else ghc_lib_dir1 = ghc_lib_dir0 #endif settings_found <- doesFileExist (ghc_lib_dir1 "settings") if settings_found then return ghc_lib_dir1 else do out <- readProcess "ghc" ["--print-libdir"] "" return (reverse (dropWhile isSpace (reverse out))) {-# INLINABLE initializeLibDirFromGhc #-} -- | Show ghc not found message and exit with 'exitFailure'. exitWithGhcNotFound :: IO a exitWithGhcNotFound = do me <- getProgName putStrLn $ me ++ ": Cannot find GHC executable in current PATH" exitFailure {-# INLINABLE exitWithGhcNotFound #-} -- Note: This global ghc libdir is obtained and cached at runtime, not at -- compile time. globalLibDirRef :: IORef (Maybe FilePath) globalLibDirRef = unsafePerformIO $ newIORef Nothing {-# NOINLINE globalLibDirRef #-} -- --------------------------------------------------------------------- -- -- Debug related functions -- -- --------------------------------------------------------------------- -- | 'True' when the given 'FnkDebugFlag' is turned on. fopt :: FnkDebugFlag -> FnkEnv -> Bool fopt flag fnk_env = testBit (envDumpFlags fnk_env) (fromEnum flag) || envVerbosity fnk_env >= verbosity_to_enable where verbosity_to_enable = case flag of -- Dump options Fnk_dump_dflags -> 2 Fnk_dump_expand -> 2 Fnk_dump_hs -> 2 Fnk_dump_session -> 2 -- Trace options Fnk_trace_expand -> 3 Fnk_trace_make -> 3 Fnk_trace_session -> 3 Fnk_trace_spf -> 3 {-# INLINABLE fopt #-} -- | Turn on the given 'FnkDebugFlag'. foptSet :: FnkDebugFlag -> FnkEnv -> FnkEnv foptSet flag fnk_env = fnk_env {envDumpFlags = setBit (envDumpFlags fnk_env) (fromEnum flag)} {-# INLINABLE foptSet #-} -- | Update the 'envVerbosity' to given value. setFnkVerbosity :: Int -> FnkEnv -> FnkEnv setFnkVerbosity v fnk_env = fnk_env {envVerbosity = v} {-# INLINABLE setFnkVerbosity #-} -- | Dump 'SDoc's when the given 'FnkDebugFlag' is turned on. debugWhen :: (MonadIO m, HasDynFlags m) => FnkEnv -> FnkDebugFlag -> [SDoc] -> m () debugWhen fnk_env flag mdocs = getDynFlags >>= \dflags -> debugWhen' dflags fnk_env flag mdocs {-# INLINABLE debugWhen #-} debugWhen' :: MonadIO m => DynFlags -> FnkEnv -> FnkDebugFlag -> [SDoc] -> m () debugWhen' dflags fnk_env flag mdocs = when (fopt flag fnk_env) (dumpSDocs dflags mdocs) {-# INLINABLE debugWhen' #-} dumpSDocs :: MonadIO m => DynFlags -> [SDoc] -> m () dumpSDocs dflags mdocs = liftIO $ withMVar globalDumpSDocsLock $ const (pr (vcat mdocs)) where #if MIN_VERSION_ghc(9,2,0) pr = printSDocLn (initSDocContext dflags err_style) (Pretty.PageMode False) stderr err_style = defaultErrStyle #elif MIN_VERSION_ghc(9,0,0) pr = printSDocLn (initSDocContext dflags err_style) Pretty.PageMode stderr err_style = defaultErrStyle #else pr = printSDocLn Pretty.PageMode dflags stderr err_style err_style = defaultErrStyle dflags #endif {-# INLINABLE dumpSDocs #-} -- | Get finkel debug setting from environment variable /FNK_DEBUG/. getFnkDebug :: MonadIO m => m Bool getFnkDebug = do mb_debug <- liftIO (lookupEnv "FNK_DEBUG") case mb_debug of Nothing -> return False Just _ -> return True {-# INLINABLE getFnkDebug #-} -- | Show some fields in 'DynFlags'. dumpDynFlags :: MonadIO m => FnkEnv -> SDoc -> DynFlags -> m () dumpDynFlags fnk_env label dflags = debugWhen' dflags fnk_env Fnk_dump_dflags msgs where msgs = [ label , " ghcLink:" <+> text (show (ghcLink dflags)) , " ghcMode:" <+> ppr (ghcMode dflags) #if MIN_VERSION_ghc(9,2,0) , " backend:" <+> text (show (backend dflags)) #else , " hscTarget:" <+> text (show (hscTarget dflags)) #endif #if MIN_VERSION_ghc(9,2,0) , " ways:" <+> text (show (ways dflags)) #else , " ways:" <+> text (show (ways dflags)) #endif , " forceRecomp:" <+> text (show (gopt Opt_ForceRecomp dflags)) #if MIN_VERSION_ghc(9,0,0) , " hostFullWays:" <+> text (show hostFullWays) #else , " interpWays:" <+> text (show interpWays) #endif , " importPaths:" <+> sep (map text (importPaths dflags)) #if MIN_VERSION_ghc(9,4,0) , " workingDirectory:" <+> text (show (workingDirectory dflags)) , " num_plugins:" <+> text (show (length (pluginModNames dflags))) , " opt_pp:" <+> text (show (gopt Opt_Pp dflags)) , " pgmF:" <+> text (toolSettings_pgm_F (toolSettings dflags)) #endif #if !MIN_VERSION_ghc(9,4,0) , " optLevel:" <+> text (show (optLevel dflags)) #endif #if MIN_VERSION_ghc(9,2,0) , " homeUnitId_:" <+> ppr (homeUnitId_ dflags) #elif MIN_VERSION_ghc(9,0,0) , " homeUnitId:" <+> ppr (homeUnitId dflags) #else , " thisInstallUnitId:" <+> ppr (thisInstalledUnitId dflags) #endif , " ldInputs:" <+> sep (map (text . showOpt) (ldInputs dflags)) #if MIN_VERSION_ghc(9,2,0) , " mainModuleNameIs:" <+> ppr (mainModuleNameIs dflags) #else , " mainModIs:" <+> ppr (mainModIs dflags) #endif #if !MIN_VERSION_ghc(9,6,0) , " mainFunIs:" <+> ppr (mainFunIs dflags) #endif , " safeHaskell:" <+> text (show (safeHaskell dflags)) , " lang:" <+> ppr (language dflags) , " extensionFlags:" <+> ppr (EnumSet.toList (extensionFlags dflags)) , " includePathsQuote:" <+> vcat (map text (includePathsQuote (includePaths dflags))) , " includePathsGlobal:" <+> vcat (map text (includePathsGlobal (includePaths dflags))) , " picPOpts:" <+> sep (map text (picPOpts dflags)) #if MIN_VERSION_ghc(9,6,0) , " opt_P_signature:" <+> ppr (snd (opt_P_signature dflags)) #else , " opt_P_signature:" <+> ppr (opt_P_signature dflags) #endif , " hcSuf:" <+> text (hcSuf dflags) #if MIN_VERSION_ghc(9,0,0) , " sccProfilingOn:" <+> text (show (sccProfilingEnabled dflags)) #else , " sccProfilingOn:" <+> text (show (gopt Opt_SccProfilingOn dflags)) #endif , " ticky:" <+> ppr (map (`gopt` dflags) [ Opt_Ticky , Opt_Ticky_Allocd , Opt_Ticky_LNE , Opt_Ticky_Dyn_Thunk ]) , " debugLevel:" <+> ppr (debugLevel dflags) ] -- | Show 'HomeModInfo' in 'HomePackageTable' (and 'HomeUnitGraph' in ghc >= -- 9.4). dumpHscEnv :: MonadIO m => FnkEnv -> SDoc -> HscEnv -> m () dumpHscEnv fnk_env label hsc_env = debugWhen' (hsc_dflags hsc_env) fnk_env Fnk_dump_session msgs where msgs = label : map (nest 2) [ "hsc_targets:" <+> ppr (hsc_targets hsc_env) , "hsc_hpt:" <+> pprHPT (hsc_HPT hsc_env) #if MIN_VERSION_ghc(9,4,0) , "home_unit_graph:" <+> ppr (hsc_HUG hsc_env) , "hsc_type_env_vars:" <+> ppr (hsc_type_env_vars hsc_env) , "hsc_hooks (runPhaseHook):" <+> ppr (fmap (const ("" :: SDoc)) (runPhaseHook (hsc_hooks hsc_env))) #endif ] -- XXX: Unsafe global lock to avoid mixing up messages in concurrent settings. -- When FnkEnv is shared, better to add a MVar field in the shared FnkEnv for -- such purpose (But FnkEnv is not shared in parsedResultAction). globalDumpSDocsLock :: MVar () globalDumpSDocsLock = unsafePerformIO (newMVar ()) {-# NOINLINE globalDumpSDocsLock #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Form.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -- | S-expression form data. module Language.Finkel.Form ( -- * Types Code , Atom(..) , Form(..) , LForm(..) -- * Constructor functions , QuoteFn , qSymbol , qChar , qString , qInteger , qFractional , qUnit , qList , qHsList , nil -- * Auxiliary functions , aFractional , aIntegral , aSymbol , aString , genSrc , mkLocatedForm , showLoc , toListL , unCode , withLocInfo , asLocOf -- * Re-export , IntegralLit (..) , mkIntegralLit , FractionalLit(..) #if MIN_VERSION_ghc(9,2,0) , fl_value #endif , SourceText(..) ) where #include "ghc_modules.h" -- base import Control.Applicative (Alternative (..)) import Control.Monad (MonadPlus (..)) import Data.Data (Data, Typeable) import Data.Function (on) import Data.Maybe (fromMaybe) import GHC.Generics (Generic) -- binary import Data.Binary (Binary (..), Get, Put, getWord8, putWord8) -- ghc import GHC_Data_FastString (FastString, fsLit, unpackFS) import GHC_Types_SourceText (SourceText (..)) import GHC_Types_SrcLoc (GenLocated (..), Located, RealSrcSpan (..), SrcSpan (..), combineLocs, combineSrcSpans, mkRealSrcLoc, mkRealSrcSpan, mkSrcLoc, mkSrcSpan, srcSpanEndCol, srcSpanEndLine, srcSpanFile, srcSpanFileName_maybe, srcSpanStartCol, srcSpanStartLine) import GHC_Utils_Outputable (Outputable (..), brackets, cat, char, double, doubleQuotes, fsep, integer, parens, text) #if MIN_VERSION_ghc(9,4,0) import qualified GHC.Data.Strict as Strict #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Types_SrcLoc (BufPos (..), BufSpan (..), UnhelpfulSpanReason (..), unhelpfulSpanFS) #endif import GHC_Types_SourceText (IntegralLit (..), mkIntegralLit) -- deepseq import Control.DeepSeq (NFData (..)) -- Internal import Language.Finkel.Data.FastString (getFastString, putFastString) import Language.Finkel.Data.Fractional import Language.Finkel.Data.SourceText (getSourceText, putSourceText) -- ------------------------------------------------------------------- -- -- Form data type -- -- ------------------------------------------------------------------- -- | Atom in tokens. data Atom = AUnit | ASymbol {-# UNPACK #-} !FastString | AChar SourceText {-# UNPACK #-} !Char | AString SourceText {-# UNPACK #-} !FastString | AInteger {-# UNPACK #-} !IntegralLit | AFractional {-# UNPACK #-} !FractionalLit deriving (Data, Typeable, Generic) instance Eq Atom where AUnit == AUnit = True ASymbol x == ASymbol y = x == y AChar _ x == AChar _ y = x == y AString _ x == AString _ y = x == y AInteger x == AInteger y = x == y AFractional x == AFractional y = x == y _ == _ = False {-# INLINE (==) #-} instance Show Atom where showsPrec d x = case x of AUnit -> showString "()" ASymbol s -> showString (unpackFS s) AChar _ c -> showString $ case c of '\a' -> "#'\\BEL" '\b' -> "#'\\BS" '\f' -> "#'\\FF" '\n' -> "#'\\LF" '\r' -> "#'\\CR" '\t' -> "#'\\HT" '\v' -> "#'\\VT" ' ' -> "#'\\SP" _ -> ['#', '\'', c] AString _ s -> showsPrec d s AInteger il -> showsPrec d (il_value il) AFractional f -> showString (showFractionalList f) instance NFData Atom where rnf x = case x of AUnit -> () ASymbol fs -> seq fs () AChar _ c -> seq c () AString _ str -> seq str () AInteger i -> rnf (il_value i) AFractional y -> seq y () instance Outputable Atom where ppr form = case form of AUnit -> ppr () ASymbol x -> ppr x AChar _ x -> cat [text "#'", char x] AString _ x -> doubleQuotes (ppr x) AInteger x -> integer (il_value x) AFractional x -> double (fromRational (fl_value x)) -- | Form type. Also used as token. Elements of recursive structures -- contain location information. data Form a = Atom a -- ^ S-expression atom. | List [LForm a] -- ^ S-expression list. | HsList [LForm a] -- ^ Haskell list. | TEnd -- ^ End of token. deriving (Eq, Data, Typeable, Generic) -- | Newtype wrapper for located 'Form'. newtype LForm a = LForm {unLForm :: Located (Form a)} deriving (Data, Typeable, Generic) -- | Type synonym for code data. -- -- The 'Code' data is the fundamental data type used in the entire compilation -- work. The 'Code' is used to represed data from parsed source file, and used -- for input and output of macros transformer functions. List of 'Code' data are -- converted to Haskell AST via syntax parser. -- -- Since 'Code' is returned from parsed source file, source code location -- information is attached to 'Code'. -- type Code = LForm Atom -- ------------------------------------------------------------------------ -- -- Instances -- -- ------------------------------------------------------------------------ instance Eq a => Eq (LForm a) where LForm (L _ a) == LForm (L _ b) = a == b {-# INLINE (==) #-} instance Show a => Show (Form a) where showsPrec d form = case form of Atom a -> showsPrec d a List xs -> showL (Just "nil") '(' ')' xs HsList xs -> showL Nothing '[' ']' xs TEnd -> showString "TEnd" where showL mb_nil open close xs next = case xs of [] -> maybe (open : close : next) (++ next) mb_nil x:xs' -> open : shows x (showL' close xs' next) showL' close xs next = case xs of [] -> close : next y:ys -> ' ' : shows y (showL' close ys next) instance Show a => Show (LForm a) where showsPrec d (LForm (L _ a)) = showsPrec d a {-# INLINE showsPrec #-} instance Functor Form where fmap f form = case form of Atom a -> Atom (f a) List xs -> List (map (fmap f) xs) HsList xs -> HsList (map (fmap f) xs) TEnd -> TEnd {-# INLINE fmap #-} instance Functor LForm where fmap f (LForm (L l a)) = LForm (L l (fmap f a)) {-# INLINE fmap #-} instance Applicative Form where pure = Atom {-# INLINE pure #-} Atom f <*> Atom a = Atom (f a) Atom f <*> List as = List (map (fmap f) as) Atom f <*> HsList as = HsList (map (fmap f) as) List fs <*> a@(Atom _) = List (fmap apLF fs <*> [a]) List fs <*> List as = List (fmap (<*>) fs <*> as) List fs <*> HsList as = List (fmap (<*>) fs <*> as) HsList fs <*> a@(Atom _) = HsList (fmap apLF fs <*> [a]) HsList fs <*> List as = HsList (fmap (<*>) fs <*> as) HsList fs <*> HsList as = HsList (fmap (<*>) fs <*> as) TEnd <*> _ = TEnd _ <*> TEnd = TEnd {-# INLINE (<*>) #-} instance Applicative LForm where pure = LForm . genSrc . pure {-# INLINE pure #-} LForm (L l f) <*> LForm (L _ a) = LForm (L l (f <*> a)) {-# INLINE (<*>) #-} instance Monad Form where m >>= k = case m of Atom a -> k a List as -> List (map (liftLF (>>= k)) as) HsList as -> HsList (map (liftLF (>>= k)) as) TEnd -> TEnd {-# INLINE (>>=) #-} instance Monad LForm where LForm (L l a) >>= k = LForm (L l (a >>= (unCode . k))) {-# INLINE (>>=) #-} instance Foldable Form where foldr f z form = case form of TEnd -> z Atom x -> f x z List xs -> case xs of [] -> z y:ys -> foldr f (foldr f z (List ys)) (unCode y) HsList xs -> case xs of [] -> z y:ys -> foldr f (foldr f z (HsList ys)) (unCode y) {-# INLINE foldr #-} instance Foldable LForm where foldr f z (LForm (L _ form)) = foldr f z form {-# INLINE foldr #-} instance Traversable Form where traverse f form = case form of Atom x -> fmap Atom (f x) List xs -> fmap List (traverse (traverse f) xs) HsList xs -> fmap HsList (traverse (traverse f) xs) TEnd -> pure TEnd {-# INLINE traverse #-} instance Traversable LForm where traverse f (LForm (L l form)) = fmap (LForm . L l) (traverse f form) {-# INLINE traverse #-} instance NFData a => NFData (Form a) where rnf x = case x of Atom a -> rnf a List as -> rnf as HsList as -> rnf as TEnd -> () instance NFData a => NFData (LForm a) where rnf (LForm (L l a)) = rnf l `seq` rnf a instance Outputable a => Outputable (Form a) where ppr x = case x of Atom a -> ppr a List xs -> parens (fsep (map ppr xs)) HsList xs -> brackets (fsep (map ppr xs)) TEnd -> text "" instance Outputable a => Outputable (LForm a) where ppr (LForm (L _ a)) = ppr a instance Semigroup (Form a) where Atom a <> Atom b = List [atomForm a, atomForm b] Atom a <> List bs = List (atomForm a : bs) Atom a <> HsList bs = List (atomForm a : bs) List as <> Atom b = List (as <> [atomForm b]) List as <> List bs = List (as <> bs) List as <> HsList bs = List (as <> bs) HsList as <> Atom b = List (as <> [atomForm b]) HsList as <> List bs = List (as <> bs) HsList as <> HsList bs = List (as <> bs) TEnd <> b = b a <> TEnd = a {-# INLINE (<>) #-} instance Semigroup (LForm a) where LForm (L l a) <> LForm (L r b) = LForm (L (combineSrcSpans l r) (a <> b)) {-# INLINE (<>) #-} instance Monoid (Form a) where mempty = List [] {-# INLINE mempty #-} instance Monoid (LForm a) where mempty = LForm (genSrc mempty) {-# INLINE mempty #-} instance Alternative Form where empty = mempty {-# INLINE empty #-} (<|>) = mappend {-# INLINE (<|>) #-} instance Alternative LForm where empty = mempty {-# INLINE empty #-} (<|>) = mappend {-# INLINE (<|>) #-} instance MonadPlus Form instance MonadPlus LForm instance Num (Form Atom) where (+) = nop2 aIntegral (+) (+) {-# INLINE (+) #-} (*) = nop2 aIntegral (*) (*) {-# INLINE (*) #-} negate = nop1 aIntegral negate negate {-# INLINE negate #-} abs = nop1 aIntegral abs abs {-# INLINE abs #-} signum = nop1 aIntegral signum signum {-# INLINE signum #-} fromInteger = Atom . aIntegral {-# INLINE fromInteger #-} instance Num Code where (+) = liftLF2 (+) {-# INLINE (+) #-} (*) = liftLF2 (*) {-# INLINE (*) #-} negate = liftLF negate {-# INLINE negate #-} abs = liftLF abs {-# INLINE abs #-} signum = liftLF signum {-# INLINE signum #-} fromInteger = LForm . genSrc . fromInteger {-# INLINE fromInteger #-} instance Fractional (Form Atom) where (/) = nop2 aDouble ((/) `on` fromIntegral) (/) {-# INLINE (/) #-} recip = nop1 aDouble (recip . fromInteger) recip {-# INLINE recip #-} fromRational = Atom . aDouble. fromRational {-# INLINE fromRational #-} instance Fractional Code where (/) = liftLF2 (/) {-# INLINE (/) #-} recip = liftLF recip {-# INLINE recip #-} fromRational = LForm . genSrc . fromRational {-# INLINE fromRational #-} -- ------------------------------------------------------------------- -- -- Instances for classes from binary package -- -- ------------------------------------------------------------------- instance Binary Atom where put x = case x of AUnit -> putWord8 0 ASymbol fs -> putWord8 1 >> putFastString fs AChar st c -> putWord8 2 >> putSourceText st >> put c AString st fs -> putWord8 3 >> putSourceText st >> putFastString fs AInteger il -> putWord8 4 >> putIntegralLit il AFractional fl -> putWord8 5 >> putFractionalLit fl {-# INLINE put #-} get = do t <- getWord8 case t of 0 -> pure AUnit 1 -> ASymbol <$> getFastString 2 -> AChar <$> getSourceText <*> get 3 -> AString <$> getSourceText <*> getFastString 4 -> AInteger <$> getIntegralLit 5 -> AFractional <$> getFractionalLit _ -> error $ "get: unknown tag " ++ show t {-# INLINE get #-} putIntegralLit :: IntegralLit -> Put putIntegralLit il = putSourceText (il_text il) *> put (il_neg il) *> put (il_value il) {-# INLINABLE putIntegralLit #-} getIntegralLit :: Get IntegralLit getIntegralLit = IL <$> getSourceText <*> get <*> get {-# INLINABLE getIntegralLit #-} instance Binary a => Binary (Form a) where put form = case form of Atom x -> putWord8 0 *> put x List xs -> putWord8 1 *> put xs HsList xs -> putWord8 2 *> put xs TEnd -> putWord8 3 {-# INLINE put #-} get = do t <- getWord8 case t of 0 -> Atom <$> get 1 -> List <$> get 2 -> HsList <$> get 3 -> pure TEnd _ -> error $ "getForm: unknown tag " ++ show t {-# INLINE get #-} instance Binary a => Binary (LForm a) where put (LForm (L l a)) = putSrcSpan l *> put a {-# INLINE put #-} get = LForm <$> (L <$> getSrcSpan <*> get) {-# INLINE get #-} #if MIN_VERSION_ghc(9,0,0) putSrcSpan :: SrcSpan -> Put putSrcSpan s = case s of RealSrcSpan p mb -> putWord8 0 *> putRealSrcSpan p *> putMbBufSpan mb UnhelpfulSpan reason -> putWord8 1 *> putUnhelpfulSpanReason reason getSrcSpan :: Get SrcSpan getSrcSpan = do t <- getWord8 case t of 0 -> RealSrcSpan <$> getRealSrcSpan <*> getMbBufSpan 1 -> UnhelpfulSpan <$> getUnhelpfulSpanReason _ -> error $ "getSrcSpan: unknown tag " ++ show t # if MIN_VERSION_ghc(9,4,0) putMbBufSpan :: Strict.Maybe BufSpan -> Put putMbBufSpan mb_bs = case mb_bs of Strict.Just (BufSpan s e) -> putWord8 0 *> putBufPos s *> putBufPos e Strict.Nothing -> putWord8 1 getMbBufSpan :: Get (Strict.Maybe BufSpan) getMbBufSpan = do t <- getWord8 case t of 0 -> Strict.Just <$> (BufSpan <$> getBufPos <*> getBufPos) 1 -> pure Strict.Nothing _ -> error $ "getMbBufSpan: unknown tag " ++ show t # else putMbBufSpan :: Maybe BufSpan -> Put putMbBufSpan mb_bs = case mb_bs of Just (BufSpan s e) -> putWord8 0 *> putBufPos s *> putBufPos e Nothing -> putWord8 1 getMbBufSpan :: Get (Maybe BufSpan) getMbBufSpan = do t <- getWord8 case t of 0 -> Just <$> (BufSpan <$> getBufPos <*> getBufPos) 1 -> pure Nothing _ -> error $ "getMbBufSpan: unknown tag " ++ show t # endif {-# INLINABLE putMbBufSpan #-} {-# INLINABLE getMbBufSpan #-} putBufPos :: BufPos -> Put putBufPos (BufPos p) = put p {-# INLINABLE putBufPos #-} getBufPos :: Get BufPos getBufPos = BufPos <$> get {-# INLINABLE getBufPos #-} putUnhelpfulSpanReason :: UnhelpfulSpanReason -> Put putUnhelpfulSpanReason r = case r of UnhelpfulNoLocationInfo -> putWord8 0 UnhelpfulWiredIn -> putWord8 1 UnhelpfulInteractive -> putWord8 2 UnhelpfulGenerated -> putWord8 3 UnhelpfulOther fs -> putWord8 4 *> putFastString fs {-# INLINABLE putUnhelpfulSpanReason #-} getUnhelpfulSpanReason :: Get UnhelpfulSpanReason getUnhelpfulSpanReason = do t <- getWord8 case t of 0 -> pure UnhelpfulNoLocationInfo 1 -> pure UnhelpfulWiredIn 2 -> pure UnhelpfulInteractive 3 -> pure UnhelpfulGenerated 4 -> UnhelpfulOther <$> getFastString _ -> error $ "getUnhelpfulSpanReason: unknown tag " ++ show t {-# INLINABLE getUnhelpfulSpanReason #-} #else putSrcSpan :: SrcSpan -> Put putSrcSpan s = case s of RealSrcSpan rs -> putWord8 0 *> putRealSrcSpan rs UnhelpfulSpan fs -> putWord8 1 *> putFastString fs getSrcSpan :: Get SrcSpan getSrcSpan = do t <- getWord8 case t of 0 -> RealSrcSpan <$> getRealSrcSpan 1 -> UnhelpfulSpan <$> getFastString _ -> error $ "getSrcSpan: unknown tag " ++ show t #endif {-# INLINABLE putSrcSpan #-} {-# INLINABLE getSrcSpan #-} putRealSrcSpan :: RealSrcSpan -> Put putRealSrcSpan rs = do putFastString (srcSpanFile rs) put (srcSpanStartLine rs) put (srcSpanStartCol rs) put (srcSpanEndLine rs) put (srcSpanEndCol rs) {-# INLINEABLE putRealSrcSpan #-} getRealSrcSpan :: Get RealSrcSpan getRealSrcSpan = do fs <- getFastString mkRealSrcSpan <$> (mkRealSrcLoc fs <$> get <*> get) <*> (mkRealSrcLoc fs <$> get <*> get) {-# INLINEABLE getRealSrcSpan #-} -- ------------------------------------------------------------------- -- -- Constructor functions -- -- ------------------------------------------------------------------- -- | Type synonym for functions for quoting form. type QuoteFn = String -- ^ File name. -> Int -- ^ Start line. -> Int -- ^ Start column. -> Int -- ^ End line. -> Int -- ^ End column. -> Code -- | Make quoted symbol from 'String'. qSymbol :: String -> QuoteFn qSymbol = quotedWithLoc . Atom . aSymbol {-# INLINABLE qSymbol #-} -- | Make quoted char from 'Char'. qChar :: Char -> QuoteFn qChar = quotedWithLoc . Atom . AChar NoSourceText {-# INLINABLE qChar #-} -- | Make quoted string from 'String'. qString :: String -> QuoteFn qString = quotedWithLoc . Atom . aString NoSourceText {-# INLINABLE qString #-} -- | Make quoted integer from 'Integer'. qInteger :: Integer -> QuoteFn qInteger = quotedWithLoc . Atom . AInteger . mkIntegralLit {-# INLINABLE qInteger #-} -- | Make quoted fractional from 'Real' value. qFractional :: (Real a, Show a) => a -> QuoteFn qFractional = quotedWithLoc . Atom . aFractional {-# INLINABLE qFractional #-} -- | Make quoted unit. qUnit :: QuoteFn qUnit = quotedWithLoc (Atom AUnit) {-# INLINABLE qUnit #-} -- | Make quoted list from list of 'Code'. qList :: [Code] -> QuoteFn qList = quotedWithLoc . List {-# INLINABLE qList #-} -- | Make quoted haskell list from list of 'Code'. qHsList :: [Code] -> QuoteFn qHsList = quotedWithLoc . HsList {-# INLINABLE qHsList #-} -- -- | Make quoted symbol from 'String'. -- | Auxiliary function to construct 'ASymbol' atom. aSymbol :: String -> Atom aSymbol = ASymbol . fsLit {-# INLINABLE aSymbol #-} -- | Auxiliary function to construct 'AString' atom. aString :: SourceText -> String -> Atom aString st = AString st . fsLit {-# INLINABLE aString #-} -- | Auxiliary function to construct an 'Atom' containing -- 'FractionalLit' value from literal fractional numbers. aFractional :: (Real a, Show a) => a -> Atom aFractional x = AFractional $! mkFractionalLit' x {-# SPECIALIZE aFractional :: Double -> Atom #-} {-# SPECIALIZE aFractional :: Float -> Atom #-} -- | Type fixed variant of 'aFractional'. aDouble :: Double -> Atom aDouble = aFractional {-# INLINABLE aDouble #-} aIntegral :: Integral a => a -> Atom aIntegral x = AInteger $! mkIntegralLit x {-# SPECIALIZE aIntegral :: Integer -> Atom #-} {-# SPECIALIZE aIntegral :: Int -> Atom #-} -- | A form with empty 'List'. nil :: Code nil = LForm (genSrc (List [])) {-# INLINABLE nil #-} quotedWithLoc :: Form Atom -> QuoteFn quotedWithLoc x file start_line start_col end_line end_col = let file_fs = fsLit file span_start = mkSrcLoc file_fs start_line start_col span_end = mkSrcLoc file_fs end_line end_col l = mkSrcSpan span_start span_end in LForm (L l x) {-# INLINABLE quotedWithLoc #-} -- From ghc 9.0.1, a new field with 'Maybe Int' was added to RealSrcSpan -- constructor of SrcLoc data type. #if __GLASGOW_HASKELL__ >= 900 #define _MB_BUF_POS _ #else #define _MB_BUF_POS {- empty -} #endif -- | Apply given functions to file name, start line, start column, end line, and -- end column. withLocInfo :: SrcSpan -- ^ Source code span to get location info. -> (FastString -> a) -- ^ Function applied to file name. -> (Int -> b) -- ^ Function applied to lines and columns. -> (a, b, b, b, b) withLocInfo l f_file f_n = let file = f_file (fromMaybe (fsLit "") (srcSpanFileName_maybe l)) sl = get_n srcSpanStartLine sc = get_n srcSpanStartCol el = get_n srcSpanEndLine ec = get_n srcSpanEndCol get_n getter = case l of RealSrcSpan rspan _MB_BUF_POS -> f_n $! getter rspan _ -> f_n 0 in (file, sl, sc, el, ec) {-# INLINABLE withLocInfo #-} -- | Return the first arg, with location information from the second arg. asLocOf :: Code -> Code -> Code asLocOf (LForm (L _ a)) (LForm (L l _)) = LForm (L l a) {-# INLINABLE asLocOf #-} -- ------------------------------------------------------------------- -- -- Auxiliary -- -- ------------------------------------------------------------------- finkelUnhelpfulSpan :: SrcSpan #if MIN_VERSION_ghc(9,0,0) finkelUnhelpfulSpan = UnhelpfulSpan (UnhelpfulOther (fsLit "")) #else finkelUnhelpfulSpan = UnhelpfulSpan (fsLit "") #endif {-# INLINABLE finkelUnhelpfulSpan #-} -- | String representation of located data. showLoc :: LForm a -> String showLoc (LForm (L l _)) = case l of RealSrcSpan r _MB_BUF_POS -> unpackFS (srcSpanFile r) ++ ":" ++ show (srcSpanStartLine r) ++ ":" ++ show (srcSpanStartCol r) ++ ": " #if MIN_VERSION_ghc(9,0,0) UnhelpfulSpan uh -> unpackFS (unhelpfulSpanFS uh) ++ ": " #else UnhelpfulSpan fs -> unpackFS fs ++ ": " #endif {-# INLINABLE showLoc #-} -- | Make 'List' from given code. When the given argument was already a 'List', -- the given 'List' is returned. If the argument was 'HsList', converted to -- 'List'. Otherwise, 'List' with single element. toListL :: Code -> Code toListL orig@(LForm (L l form)) = case form of List _ -> orig HsList xs -> LForm (L l (List xs)) _ -> LForm (L l (List [orig])) {-# INLINABLE toListL #-} -- | Unwrap 'LForm' to 'Form'. unCode :: LForm a -> Form a unCode (LForm (L _ a)) = a {-# INLINABLE unCode #-} -- | Attach location to mark generated code. genSrc :: a -> Located a genSrc = L finkelUnhelpfulSpan {-# INLINABLE genSrc #-} -- | Make located list from list of located elements. -- -- When the argument is not null, the resulting list has a combined location of -- locations in the argument list elements. mkLocatedForm :: [LForm a] -> Located [LForm a] mkLocatedForm [] = genSrc [] mkLocatedForm ms@(hd:_) = L (combineLocs (unLForm hd) (unLForm (last ms))) ms {-# INLINABLE mkLocatedForm #-} -- | Lift given argument to 'LForm'. atomForm :: a -> LForm a atomForm = LForm . genSrc . Atom {-# INLINABLE atomForm #-} -- | Apply function taking single 'Form' to 'LForm'. liftLF :: (Form a -> Form b) -> LForm a -> LForm b liftLF f (LForm (L l a)) = LForm (L l (f a)) {-# INLINABLE liftLF #-} -- | Apply function taking two 'Form's to 'LForm's. liftLF2 :: (Form a -> Form b -> Form c) -> LForm a -> LForm b -> LForm c liftLF2 f (LForm (L l1 a)) (LForm (L _l2 b)) = LForm (L l1 (f a b)) {-# INLINABLE liftLF2 #-} -- | Apply functoni in 'LForm' to 'Form'. apLF :: LForm (a -> b) -> Form a -> LForm b apLF (LForm (L l f)) b = LForm (L l (f <*> b)) {-# INLINABLE apLF #-} -- | Unary numeric operation helper. nop1 :: (a -> Atom) -> (Integer -> a) -> (Rational -> Rational) -> Form Atom -> Form Atom nop1 c f _ (Atom (AInteger il)) = Atom (c (f (il_value il))) nop1 _ _ f (Atom (AFractional fl)) = Atom (aFractional (f (fl_value fl))) nop1 _ _ _ _ = List [] {-# INLINABLE nop1 #-} -- | Binary numeric operation helper. nop2 :: (a -> Atom) -> (Integer -> Integer -> a) -> (Rational -> Rational -> Rational) -> Form Atom -> Form Atom -> Form Atom nop2 c f _ (Atom (AInteger il1)) (Atom (AInteger il2)) = Atom (c (on f il_value il1 il2)) nop2 _ _ f (Atom (AFractional fl1)) (Atom (AInteger il2)) = Atom (aFractional (f (fl_value fl1) (fromIntegral (il_value il2)))) nop2 _ _ f (Atom (AInteger il1)) (Atom (AFractional fl2)) = Atom (aFractional (f (fromIntegral (il_value il1)) (fl_value fl2))) nop2 _ _ f (Atom (AFractional fl1)) (Atom (AFractional fl2)) = Atom (aFractional (on f fl_value fl1 fl2)) nop2 _ _ _ _ _ = List [] {-# INLINABLE nop2 #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Homoiconic.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -- | Module containing 'Homoiconic' and 'FromCode' type classes and its instance -- declarations. module Language.Finkel.Homoiconic ( -- * Homoiconic class Homoiconic(..) , fromCode , Result(..) -- * Generic functions , genericToCode , genericFromCode , genericParseCode -- * Generic classes , GToCode(..) , GParseCode(..) -- * Data.Data function , dataToCode ) where #include "ghc_modules.h" -- base import Control.Applicative (Alternative (..)) import Data.Complex (Complex (..)) import Data.Data import Data.Fixed (Fixed (..)) import Data.Functor.Compose (Compose (..)) import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) import Data.Int (Int16, Int32, Int64, Int8) import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid (All (..), Alt (..), Any (..), Dual (..), First (..), Last (..), Product (..), Sum (..)) import Data.Ratio (Ratio, denominator, numerator, (%)) import Data.Version (Version (..)) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Generics (C, Constructor (..), D, Generic (..), K1 (..), M1 (..), S, U1 (..), V1, (:*:) (..), (:+:) (..)) import Numeric.Natural (Natural) import qualified Data.Functor.Product as Product import qualified Data.Functor.Sum as Sum import qualified Data.Semigroup as Semigroup -- ghc import GHC_Data_FastString (FastString, unpackFS) import GHC_Types_SrcLoc (GenLocated (..), SrcSpan, getLoc) -- Internal import Language.Finkel.Form -- ------------------------------------------------------------------- -- -- Homoiconic type class -- -- ------------------------------------------------------------------- -- | Class for handling Haskell value as 'Code'. -- -- Instance of 'Homoiconic' should satisfy the law: -- -- @ -- 'parseCode' ('toCode' x) ≡ 'Success' x -- @ -- -- The function 'listToCode' and 'parseHsListCode' are used when handling -- Haskell list values specially (e.g., 'Char'). These functions have default -- implementations, which simply applies 'toCode' to elements of the argument -- list, and which parses elements of 'HsList', respectively. -- -- One can implement 'Homoiconic' instance with 'GHC.Generics.Generic', e.g.: -- -- @ -- {-# LANGUAGE DeriveGeneric #-} -- -- data MyData -- = MyInt Int -- | MyChar Char -- deriving (Generic) -- -- instance Homoiconic MyData -- @ -- -- Sample snippet using above @MyData@: -- -- >>> toCode (MyInt 42) -- (MyInt 42) -- >>> fromCode (toCode (MyChar 'a')) :: Maybe MyData -- Just (MyChar 'a') --- class Homoiconic a where -- | Convert Haskell value to 'Code'. toCode :: a -> Code {-# INLINE toCode #-} default toCode :: (Generic a, GToCode (Rep a)) => a -> Code toCode = genericToCode -- | Convert list of Haskell values to 'Code'. listToCode :: [a] -> Code listToCode xs = let xs' = map toCode xs l = getLoc (mkLocatedForm xs') in LForm (L l (HsList xs')) {-# INLINE listToCode #-} -- | Convert 'Code' to Haskell value, or 'Failure' if the code could -- not be converted. parseCode :: Code -> Result a {-# INLINE parseCode #-} default parseCode :: (Generic a, GParseCode (Rep a)) => Code -> Result a parseCode = genericParseCode -- | Convert 'Code' to list of Haskell values, or 'Failure' if the code -- could not be converted. parseHsListCode :: Code -> Result [a] parseHsListCode xs = case unCode xs of HsList as -> mapM parseCode as _ -> fail "got non HsList value" {-# INLINE parseHsListCode #-} -- | Like 'parseCode', but the result wrapped with 'Maybe' instead of 'Result'. fromCode :: Homoiconic a => Code -> Maybe a fromCode code = case parseCode code of Success a -> Just a _ -> Nothing -- ------------------------------------------------------------------- -- -- Instances of Homoiconic -- -- ------------------------------------------------------------------- -- -- Prelude -- instance Homoiconic () where toCode _ = LForm (genSrc (Atom AUnit)) parseCode a = case unCode a of Atom AUnit -> pure () _ -> failedToParse "()" instance Homoiconic Char where toCode = LForm . genSrc . Atom . AChar NoSourceText listToCode = LForm . genSrc . Atom . aString NoSourceText parseCode a = case unCode a of Atom (AChar _ x) -> pure x _ -> failedToParse "Char" parseHsListCode a = case unCode a of Atom (AString _ s) -> pure (unpackFS s) _ -> failedToParse "String" instance Homoiconic Int where toCode = integralToCode parseCode = integralFromCode instance Homoiconic Word where toCode = integralToCode parseCode = integralFromCode instance Homoiconic Integer where toCode = integralToCode parseCode = integralFromCode instance Homoiconic Float where toCode = realFracToCode parseCode = fractionalFromCode instance Homoiconic Double where toCode = realFracToCode parseCode = fractionalFromCode instance Homoiconic a => Homoiconic [a] where toCode = listToCode parseCode = parseHsListCode instance Homoiconic Bool where toCode = showAsSymbolCode parseCode a = case unCode a of Atom (ASymbol sym) | sym == "True" -> pure True | sym == "False" -> pure False _ -> failedToParse "Bool" instance Homoiconic Ordering where toCode = showAsSymbolCode parseCode a = case unCode a of Atom (ASymbol sym) | sym == "EQ" -> pure EQ | sym == "LT" -> pure LT | sym == "GT" -> pure GT _ -> failedToParse "Ordering" instance Homoiconic a => Homoiconic (Maybe a) where toCode a = case a of Nothing -> toCode (aSymbol "Nothing") Just x -> toCode1 "Just" x parseCode a = case unCode a of Atom (ASymbol "Nothing") -> pure Nothing List [LForm (L _ (Atom (ASymbol "Just"))), x] -> pure <$> parseCode x _ -> failedToParse "Maybe" instance (Homoiconic a, Homoiconic b) => Homoiconic (Either a b) where toCode a = case a of Right x -> toCode1 "Right" x Left x -> toCode1 "Left" x parseCode a = case unCode a of List [LForm (L _ (Atom (ASymbol x))), y] | x == "Right" -> fmap Right (parseCode y) | x == "Left" -> fmap Left (parseCode y) _ -> failedToParse "Either" instance (Homoiconic a, Homoiconic b) => Homoiconic (a, b) where toCode (a1, a2) = toCode2 "," a1 a2 parseCode = parseCode2 "," (,) instance (Homoiconic a, Homoiconic b, Homoiconic c) => Homoiconic (a, b, c) where toCode (a1, a2, a3) = toCode (List [symbolCode ",", toCode a1, toCode a2, toCode a3]) parseCode a = case unCode a of List [LForm (L _ (Atom (ASymbol ","))), a1, a2, a3] -> (,,) <$> parseCode a1 <*> parseCode a2 <*> parseCode a3 _ -> failedToParse "(,,)" instance (Homoiconic a, Homoiconic b, Homoiconic c, Homoiconic d) => Homoiconic (a, b, c, d) where toCode (a1, a2, a3, a4) = toCode (List [ symbolCode ",", toCode a1, toCode a2, toCode a3 , toCode a4]) parseCode a = case unCode a of List [LForm (L _ (Atom (ASymbol ","))), a1, a2, a3, a4] -> (,,,) <$> parseCode a1 <*> parseCode a2 <*> parseCode a3 <*> parseCode a4 _ -> failedToParse "(,,,)" instance (Homoiconic a, Homoiconic b, Homoiconic c, Homoiconic d, Homoiconic e) => Homoiconic (a, b, c, d, e) where toCode (a1, a2, a3, a4, a5) = toCode (List [ symbolCode ",", toCode a1, toCode a2, toCode a3 , toCode a4, toCode a5]) parseCode a = case unCode a of List [LForm (L _ (Atom (ASymbol ","))), a1, a2, a3, a4, a5] -> (,,,,) <$> parseCode a1 <*> parseCode a2 <*> parseCode a3 <*> parseCode a4 <*> parseCode a5 _ -> failedToParse "(,,,,)" instance (Homoiconic a, Homoiconic b, Homoiconic c, Homoiconic d, Homoiconic e, Homoiconic f) => Homoiconic (a, b, c, d, e, f) where toCode (a1, a2, a3, a4, a5, a6) = toCode (List [ symbolCode ",", toCode a1, toCode a2, toCode a3 , toCode a4, toCode a5, toCode a6]) parseCode a = case unCode a of List [LForm (L _ (Atom (ASymbol ","))), a1, a2, a3, a4, a5, a6] -> (,,,,,) <$> parseCode a1 <*> parseCode a2 <*> parseCode a3 <*> parseCode a4 <*> parseCode a5 <*> parseCode a6 _ -> failedToParse "(,,,,,)" -- -- Data.Complex -- instance Homoiconic a => Homoiconic (Complex a) where toCode (a :+ b) = toCode2 ":+" a b parseCode = parseCode2 ":+" (:+) -- -- Data.Fixed -- instance Homoiconic (Fixed a) where toCode (MkFixed a) = toCode1 "MkFixed" a parseCode = parseCode1 "MkFixed" MkFixed -- -- Data.Functor.Compose instance Homoiconic (f (g a)) => Homoiconic (Compose f g a) where toCode (Compose a) = toCode1 "Compose" a parseCode = parseCode1 "Compose" Compose -- -- Data.Functor.Const -- instance Homoiconic a => Homoiconic (Const a b) where toCode (Const a) = toCode1 "Const" a parseCode = parseCode1 "Const" Const -- -- Data.Functor.Identity -- instance Homoiconic a=> Homoiconic (Identity a) where toCode (Identity a) = toCode1 "Identity" a parseCode = parseCode1 "Identity" Identity -- -- Data.Functor.Product -- instance (Homoiconic (f a), Homoiconic (g a)) => Homoiconic (Product.Product f g a) where toCode (Product.Pair a b) = toCode2 "Pair" a b parseCode = parseCode2 "Pair" Product.Pair -- -- Data.Functor.Sum -- instance (Homoiconic (f a), Homoiconic (g a)) => Homoiconic (Sum.Sum f g a) where toCode a = case a of Sum.InL x -> toCode1 "InL" x Sum.InR x -> toCode1 "InR" x parseCode a = case unCode a of List [LForm (L _ (Atom (ASymbol tag))), b] | tag == "InL" -> Sum.InL <$> parseCode b | tag == "InR" -> Sum.InR <$> parseCode b _ -> failedToParse "Sum" -- -- Data.Int -- instance Homoiconic Int8 where toCode = integralToCode parseCode = integralFromCode instance Homoiconic Int16 where toCode = integralToCode parseCode = integralFromCode instance Homoiconic Int32 where toCode = integralToCode parseCode = integralFromCode instance Homoiconic Int64 where toCode = integralToCode parseCode = integralFromCode -- -- Data.List.NonEmpty -- instance Homoiconic a => Homoiconic (NonEmpty a) where toCode (a :| as) = toCode2 ":|" a as parseCode = parseCode2 ":|" (:|) -- -- Data.Monoid -- instance Homoiconic All where toCode (All a) = toCode1 "All" a parseCode = parseCode1 "All" All instance Homoiconic (f a) => Homoiconic (Alt f a) where toCode (Alt a) = toCode1 "Alt" a parseCode = parseCode1 "Alt" Alt instance Homoiconic Any where toCode (Any a) = toCode1 "Any" a parseCode = parseCode1 "Any" Any instance Homoiconic a => Homoiconic (Dual a) where toCode (Dual a) = toCode1 "Dual" a parseCode = parseCode1 "Dual" Dual instance Homoiconic a => Homoiconic (First a) where toCode (First a) = toCode1 "First" a parseCode = parseCode1 "First" First instance Homoiconic a => Homoiconic (Last a) where toCode (Last a) = toCode1 "Last" a parseCode = parseCode1 "Last" Last instance Homoiconic a => Homoiconic (Product a) where toCode (Product a) = toCode1 "Product" a parseCode = parseCode1 "Product" Product instance Homoiconic a => Homoiconic (Sum a) where toCode (Sum a) = toCode1 "Sum" a parseCode = parseCode1 "Sum" Sum -- -- Data.Proxy -- instance Homoiconic a => Homoiconic (Proxy a) where toCode _ = symbolCode "Proxy" parseCode a = case unCode a of Atom (ASymbol "Proxy") -> pure Proxy _ -> failedToParse "Proxy" -- -- Data.Version -- instance Homoiconic Version where toCode (Version b t) = toCode2 "Version" b t parseCode = parseCode2 "Version" Version -- -- Data.Ratio -- instance (Integral a, Homoiconic a) => Homoiconic (Ratio a) where toCode a = let n = toCode (numerator a) d = toCode (denominator a) in toCode (List [symbolCode ":%", n, d]) parseCode = parseCode2 ":%" (%) -- -- Data.Semigroup -- instance (Homoiconic a, Homoiconic b) => Homoiconic (Semigroup.Arg a b) where toCode (Semigroup.Arg a b) = toCode2 "Arg" a b parseCode = parseCode2 "Arg" Semigroup.Arg instance Homoiconic a => Homoiconic (Semigroup.First a) where toCode (Semigroup.First a) = toCode1 "First" a parseCode = parseCode1 "First" Semigroup.First instance Homoiconic a => Homoiconic (Semigroup.Last a) where toCode (Semigroup.Last a) = toCode1 "Last" a parseCode = parseCode1 "Last" Semigroup.Last instance Homoiconic a => Homoiconic (Semigroup.Max a) where toCode (Semigroup.Max a) = toCode1 "Max" a parseCode = parseCode1 "Max" Semigroup.Max instance Homoiconic a => Homoiconic (Semigroup.Min a) where toCode (Semigroup.Min a) = toCode1 "Min" a parseCode = parseCode1 "Min" Semigroup.Min #if !MIN_VERSION_ghc(9,0,0) instance Homoiconic a => Homoiconic (Semigroup.Option a) where toCode (Semigroup.Option a) = toCode1 "Option" a parseCode = parseCode1 "Option" Semigroup.Option #endif instance Homoiconic a => Homoiconic (Semigroup.WrappedMonoid a) where toCode (Semigroup.WrapMonoid a) = toCode1 "WrapMonoid" a parseCode = parseCode1 "WrapMonoid" Semigroup.WrapMonoid -- -- Data.Word -- instance Homoiconic Word8 where toCode = integralToCode parseCode = integralFromCode instance Homoiconic Word16 where toCode = integralToCode parseCode = integralFromCode instance Homoiconic Word32 where toCode = integralToCode parseCode = integralFromCode instance Homoiconic Word64 where toCode = integralToCode parseCode = integralFromCode -- -- Numeric.Natural -- instance Homoiconic Natural where toCode = integralToCode parseCode = integralFromCode -- -- Language.Finkel.Form -- instance Homoiconic Atom where toCode = LForm . genSrc . Atom parseCode a = case unCode a of Atom x -> pure x _ -> failedToParse "Atom" instance Homoiconic (Form Atom) where toCode = LForm . genSrc parseCode = pure . unCode instance Homoiconic (LForm Atom) where toCode = id parseCode = pure -- ------------------------------------------------------------------- -- -- Generic toCode -- -- ------------------------------------------------------------------- -- | Generic variant of 'toCode'. genericToCode :: (Generic a, GToCode (Rep a)) => a -> Code genericToCode = unCodeArgs . gToCode . from {-# INLINABLE genericToCode #-} -- | To distinguish arguments of constructor from non-argument. data CodeArgs = NonArg Code | Args [Code] unCodeArgs :: CodeArgs -> Code unCodeArgs ca = case ca of NonArg c -> c Args cs -> toCode (List cs) {-# INLINABLE unCodeArgs #-} instance Semigroup.Semigroup CodeArgs where Args xs <> Args ys = Args (xs Semigroup.<> ys) Args xs <> NonArg y = Args (xs Semigroup.<> [y]) NonArg x <> Args ys = Args (x : ys) NonArg x <> NonArg y = Args [x, y] {-# INLINE (<>) #-} -- | For making 'Code' with 'Generic' instances. class GToCode f where gToCode :: f a -> CodeArgs instance GToCode V1 where gToCode _ = NonArg undefined {-# INLINE gToCode #-} instance GToCode U1 where gToCode U1 = NonArg nil {-# INLINE gToCode #-} instance (GToCode f, GToCode g) => GToCode (f :+: g) where gToCode lr = case lr of L1 x -> gToCode x R1 x -> gToCode x {-# INLINE gToCode #-} instance (GToCode f, GToCode g) => GToCode (f :*: g) where gToCode (f :*: g) = gToCode f Semigroup.<> gToCode g {-# INLINE gToCode #-} instance Homoiconic c => GToCode (K1 i c) where gToCode (K1 x) = NonArg (toCode x) {-# INLINE gToCode #-} instance GToCode f => GToCode (M1 D c f) where gToCode (M1 x) = gToCode x {-# INLINE gToCode #-} instance (Constructor c, GToCode f) => GToCode (M1 C c f) where gToCode m1@(M1 x) = let constr = toCode (aSymbol (conName m1)) in case gToCode x of NonArg c -> if null c then NonArg constr else NonArg (toCode (List [constr, c])) Args cs -> NonArg (toCode (List (constr : cs))) {-# INLINE gToCode #-} instance GToCode f => GToCode (M1 S c f) where gToCode (M1 x) = gToCode x {-# INLINE gToCode #-} -- ------------------------------------------------------------------- -- -- Generic FromCode -- -- ------------------------------------------------------------------- -- | Generic variant of 'fromCode'. genericFromCode :: (Generic a, GParseCode (Rep a)) => Code -> Maybe a genericFromCode x = case genericParseCode x of Success a -> Just a _ -> Nothing {-# INLINABLE genericFromCode #-} -- | Generic function to get result value from 'Code'. genericParseCode :: (Generic a, GParseCode (Rep a)) => Code -> Result a genericParseCode = let f a xs = if null xs then pure (to a) else fail "Unexpected leftover" in runCodeP gParseCode fail f {-# INLINABLE genericParseCode #-} -- | For getting value from 'Code' with 'Generic' instances. class GParseCode f where gParseCode :: CodeP (f a) instance GParseCode V1 where gParseCode = pure undefined {-# INLINE gParseCode #-} instance GParseCode U1 where gParseCode = pure U1 {-# INLINE gParseCode #-} instance (GParseCode f, GParseCode g) => GParseCode (f :+: g) where gParseCode = fmap L1 gParseCode <|> fmap R1 gParseCode {-# INLINE gParseCode #-} instance (GParseCode f, GParseCode g) => GParseCode (f :*: g) where gParseCode = (:*:) <$> gParseCode <*> gParseCode {-# INLINE gParseCode #-} instance Homoiconic c => GParseCode (K1 i c) where gParseCode = unconsP (\l c cs -> case parseCode c of Success a -> contP (K1 a) (LForm (L l (List cs))) _ -> failP ("Unexpected: " ++ show c)) {-# INLINE gParseCode #-} instance GParseCode f => GParseCode (M1 D c f) where gParseCode = fmap M1 gParseCode {-# INLINE gParseCode #-} instance {-# OVERLAPPABLE #-} Constructor c => GParseCode (M1 C c U1) where gParseCode = let c1 :: M1 C c U1 a c1 = undefined in eqP (toCode (aSymbol (conName c1))) *> fmap M1 gParseCode {-# INLINE gParseCode #-} instance {-# OVERLAPPABLE #-} (Constructor c, GParseCode f) => GParseCode (M1 C c f) where gParseCode = let c1 :: M1 C c f a c1 = undefined in eqCarP (toCode (aSymbol (conName c1))) *> fmap M1 gParseCode {-# INLINE gParseCode #-} instance GParseCode f => GParseCode (M1 S c f) where gParseCode = fmap M1 gParseCode {-# INLINE gParseCode #-} -- ------------------------------------------------------------------- -- -- Code parser for GParseCode -- -- ------------------------------------------------------------------- -- | Dedicated data type to hold parsed result of 'Code'. -- -- Using dedicated data type when parsing 'Code' data type for 'parseCode'. This -- data type is intentionally not defined as an instance of 'Homoiconic', so -- that the user defined data types can tell the parse error from explicit -- failure constructor of the target type, e,g, 'Nothing' for 'Maybe', 'Left' -- for 'Either', ... etc. data Result a = Success a | Failure String deriving (Eq, Show) instance Functor Result where fmap f r = case r of Success a -> Success (f a) Failure e -> Failure e {-# INLINE fmap #-} instance Applicative Result where pure = Success {-# INLINE pure #-} f <*> m = f >>= flip fmap m {-# INLINE (<*>) #-} instance Monad Result where m >>= k = case m of Success a -> k a Failure e -> Failure e {-# INLINE (>>=) #-} instance MonadFail Result where fail = Failure {-# INLINE fail #-} failedToParse :: String -> Result a failedToParse ty = Failure ("Failed to parse " ++ ty) {-# INLINABLE failedToParse #-} -- | Simple parser for 'Code'. newtype CodeP a = CodeP {runCodeP :: forall r. (String -> r) -- On failure -> (a -> Code -> r) -- On success -> Code -- Input -> r} instance Functor CodeP where fmap f p = CodeP (\err go -> runCodeP p err (go . f)) {-# INLINE fmap #-} instance Applicative CodeP where pure a = CodeP (\_ go -> go a) {-# INLINE pure #-} f <*> p = f >>= flip fmap p {-# INLINE (<*>) #-} instance Monad CodeP where m >>= k = CodeP (\err go -> runCodeP m err (\a -> runCodeP (k a) err go)) {-# INLINE (>>=) #-} instance Alternative CodeP where empty = failP "Alternative.empty" {-# INLINE empty #-} p1 <|> p2 = CodeP (\err go cs -> runCodeP p1 (\_ -> runCodeP p2 err go cs) go cs) {-# INLINE (<|>) #-} failP :: String -> CodeP a failP msg = CodeP (\err _ _ -> err msg) {-# INLINABLE failP #-} contP :: a -> Code -> CodeP a contP a cs = CodeP (\_ go _ -> go a cs) {-# INLINEABLE contP #-} unconsP :: (SrcSpan -> Code -> [Code] -> CodeP a) -> CodeP a unconsP f = CodeP (\err go cs -> case cs of LForm (L l (List (x : xs))) -> runCodeP (f l x xs) err go cs _ -> err "Not a list") {-# INLINEABLE unconsP #-} eqP :: Code -> CodeP () eqP x = CodeP (\err go cs -> if cs == x then go () nil else err ("eqP: unexpected " ++ show cs)) {-# INLINABLE eqP #-} eqCarP :: Code -> CodeP () eqCarP x = unconsP (\l c cs -> if x == c then contP () (LForm (L l (List cs))) else failP ("eqCarP: unexpected " ++ show c)) {-# INLINABLE eqCarP #-} -- ------------------------------------------------------------------- -- -- Data to Code -- -- ------------------------------------------------------------------- dataToCode :: Data d => d -> Code dataToCode x = let constr = toConstr x isTupleStr cs = case cs of '(':cs1 -> go cs1 _ -> False where go xs = case xs of ',':xs' -> go xs' [')'] -> True _ -> False cstr = case showConstr constr of str | isTupleStr str -> "," | otherwise -> str hd = toCode (aSymbol cstr) in case constrRep constr of IntConstr n -> toCode (aIntegral n) FloatConstr f -> toCode (aFractional (fromRational f :: Double)) CharConstr c -> toCode c _ -> case gmapQ dataToCode x of [] -> hd _ -> toCode (List (hd:gmapQ dataToCode x)) -- ------------------------------------------------------------------- -- -- Auxiliary -- -- ------------------------------------------------------------------- realFracToCode :: (Real a, Show a) => a -> Code realFracToCode = LForm . genSrc . Atom . aFractional {-# INLINABLE realFracToCode #-} fractionalFromCode :: Fractional a => Code -> Result a fractionalFromCode a = case unCode a of Atom (AFractional x) -> pure (fromRational (fl_value x)) _ -> failedToParse "fractional" {-# INLINABLE fractionalFromCode #-} symbolCode :: String -> Code symbolCode = LForm . genSrc . Atom . aSymbol {-# INLINABLE symbolCode #-} showAsSymbolCode :: Show a => a -> Code showAsSymbolCode = symbolCode . show {-# INLINABLE showAsSymbolCode #-} integralToCode :: Integral a => a -> Code integralToCode = LForm . genSrc . Atom . aIntegral {-# INLINABLE integralToCode #-} integralFromCode :: Integral a => Code -> Result a integralFromCode a = case unCode a of Atom (AInteger n) -> pure (fromIntegral (il_value n)) _ -> failedToParse "integral" toCode1 :: Homoiconic a => FastString -> a -> Code toCode1 tag arg1 = toCode (List [LForm (genSrc (Atom (ASymbol tag))), toCode arg1]) {-# INLINABLE toCode1 #-} toCode2 :: (Homoiconic a, Homoiconic b) => FastString -> a -> b -> Code toCode2 tag arg1 arg2 = toCode (List [ LForm (genSrc (Atom (ASymbol tag))) , toCode arg1, toCode arg2 ]) {-# INLINABLE toCode2 #-} parseCode1 :: (Homoiconic a) => FastString -> (a -> h) -> Code -> Result h parseCode1 tag f a = case unCode a of List [LForm (L _ (Atom (ASymbol tag'))), x] | tag == tag' -> f <$> parseCode x _ -> failedToParse (unpackFS tag) {-# INLINABLE parseCode1 #-} parseCode2 :: (Homoiconic a, Homoiconic b) => FastString -> (a -> b -> h) -> Code -> Result h parseCode2 tag f a = case unCode a of List [LForm (L _ (Atom (ASymbol tag'))), x, y] | tag == tag' -> f <$> parseCode x <*> parseCode y _ -> failedToParse (unpackFS tag) {-# INLINABLE parseCode2 #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Hooks.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} -- Hooks, in HscEnv module Language.Finkel.Hooks ( finkelHooks ) where #if MIN_VERSION_ghc(9,6,0) -- base import Control.Exception (displayException) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (..)) import Data.Maybe (fromMaybe) import System.Console.GetOpt (ArgOrder (..), getOpt) import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStrLn, stderr) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif -- ghc import GHC.Driver.Env (HscEnv (..), hscSetFlags, runHsc') import GHC.Driver.Errors.Types (GhcMessage) import GHC.Driver.Hooks (Hooks (..)) import GHC.Driver.Main (hscTypecheckAndGetWarnings, hscTypecheckRename) import GHC.Driver.Phases (Phase (..)) import GHC.Driver.Pipeline.Execute (phaseOutputFilenameNew, runPhase) import GHC.Driver.Pipeline.Phases (PhaseHook (..), TPhase (..)) import GHC.Driver.Session (GeneralFlag (..), gopt) import GHC.Plugins (CommandLineOption) import GHC.Types.SourceError (throwOneError) import GHC.Types.SourceFile (HscSource (..)) import GHC.Types.SrcLoc (noLoc, noSrcSpan) import GHC.Unit.Module.Location (ModLocation (..)) import GHC.Unit.Module.ModSummary (ModSummary (..)) import GHC.Utils.Error (Messages) import GHC.Utils.Exception (ExceptionMonad) import GHC.Utils.Misc (getModificationUTCTime, modificationTimeIfExists) import GHC.Utils.Outputable (text) import GHC.Runtime.Context (InteractiveContext (..)) import GHC.Tc.Types (FrontendResult (..)) -- Internal import Language.Finkel.Error (mkPlainWrappedMsg) import Language.Finkel.Exception (finkelExceptionLoc, handleFinkelException) import Language.Finkel.Fnk (FnkEnv (..), FnkInvokedMode (..), initFnkEnv, runFnk') import Language.Finkel.Make (fnkSourceToSummary) import Language.Finkel.Make.Session (bcoDynFlags) import Language.Finkel.Make.Summary (TargetSummary (..)) import Language.Finkel.Make.TargetSource (TargetSource (..), findTargetSourceWithPragma) import Language.Finkel.Options (FnkPluginOptions (..), defaultFnkPluginOptions, fnkPluginOptions, fpoPragma, printPluginUsage) import Language.Finkel.Preprocess (PpOptions (..), mkPpOptions, preprocessOrCopy) -- | Add hooks for compiling Finkel source codes. -- -- This function will constantly turn on the 'Opt_Pp' flag in the 'DynFlags' of -- given 'HscEnv' to always trigger the preprocess phase. finkelHooks :: String -> FnkEnv -> [CommandLineOption] -> HscEnv -> IO HscEnv -- Actual implementation is for ghc >= 9.6, older versions are not supported. finkelHooks mod_name fnk_env0 cmd_line_opts hsc_env0 = do -- Always setting the Opt_Pp flag on for dflags_from_ic1 and dflags1, -- otherwise the hook for T_HsPp will not run. let dflags_from_ic = bcoDynFlags (ic_dflags (hsc_IC hsc_env0)) -- XXX: Update targets in expanding session? -- enable_pp_phase = -- setGeneralFlag' Opt_Pp . -- setGeneralFlag' Opt_UseBytecodeRatherThanObjects . -- setGeneralFlag' Opt_WriteIfSimplifiedCore . -- flip xopt_set TemplateHaskell -- XXX: File local plugin options are ignored. (os, _ls, errs) = getOpt Permute fnkPluginOptions cmd_line_opts fpo0 = foldl' (flip id) (defaultFnkPluginOptions fnk_env0) os fnk_env1 = fpoFnkEnv fpo0 fnk_env2 = fnk_env1 { envDefaultDynFlags = Just dflags_from_ic , envInvokedMode = GhcPluginMode } fnk_env3 <- initFnkEnv fnk_env2 let fpo1 = fpo0 {fpoFnkEnv = fnk_env3} phase_hook = PhaseHook (fnkPhaseHook fpo1) hooks = (hsc_hooks hsc_env0) {runPhaseHook = Just phase_hook} hsc_env1 = hsc_env0 {hsc_hooks = hooks} case errs of _ | fpoHelp fpo1 -> printPluginUsage mod_name >> exitSuccess _:_ -> mapM_ putStrLn errs >> exitFailure [] -> pure hsc_env1 -- ------------------------------------------------------------------------ -- -- Internal -- -- ------------------------------------------------------------------------ -- | Hooks for compiling Finkel source codes. -- -- The hook modifies 'T_HsPp' and 'T_Hsc' phases, other phases are delegated to -- 'runPhase'. -- -- The 'T_HsPp' phase is to get preprocessed module header, which is -- used during module dependency resolution. -- -- The 'T_Hsc' phase does the compilation of the body of the source code to get -- 'FrontendResult'. fnkPhaseHook :: FnkPluginOptions -> TPhase a -> IO a fnkPhaseHook fpo phase = do logStrLn fpo ("fnkPhaseHook: running " <> showTPhase phase) case phase of T_HsPp pipe_env hsc_env fp hsc_src -> do let next = HsPp HsSrcFile out_path <- phaseOutputFilenameNew next pipe_env hsc_env Nothing runFnkPpPhase fpo hsc_env fp hsc_src out_path T_Hsc hsc_env ms -> runFnkTcPhase fpo hsc_env ms _ -> runPhase phase showTPhase :: TPhase a -> String showTPhase phase = case phase of T_Unlit {} -> "T_Unlit" T_FileArgs _ path -> "T_FileArgs: " <> path T_Cpp {} -> "T_Cpp" T_HsPp _ _ o i -> "T_HsPp: " <> o <> " " <> i T_HscRecomp {} -> "T_HscRecomp" T_Hsc {} -> "T_Hsc" T_HscPostTc {} -> "T_HscPostTc" T_HscBackend {} -> "T_HscBackend" T_CmmCpp {} -> "T_CmmCpp" T_Cmm {} -> "T_Cmm" T_Cc {} -> "T_Cc" T_As {} -> "T_As" #if MIN_VERSION_ghc(9,6,0) T_Js {} -> "T_Js" T_ForeignJs {} -> "T_ForeignJs" #endif T_LlvmOpt {} -> "T_LlvmOpt" T_LlvmLlc {} -> "T_LlvmLlc" T_LlvmMangle {} -> "T_LlvmMangle" #if MIN_VERSION_ghc(9,10,0) T_LlvmAs {} -> "T_LlvmAs" #endif T_MergeForeign {} -> "T_MergeForeign" runFnkPpPhase :: FnkPluginOptions -> HscEnv -> FilePath -> FilePath -> FilePath -> IO FilePath runFnkPpPhase fpo hsc_env _orig_fn input_fn output_fn = do -- Not parsing command line argument in preprocess phase, the arguments are -- shared with fnkPluginOptions. let fnk_env = fpoFnkEnv fpo ppo0 = mkPpOptions "runFnkPpPhase" fnk_env ppo1 = ppo0 { ppoWarnInterp = False , ppoFnkSrcOptions = fpoSrcOptions fpo , ppoVerbosity = envVerbosity fnk_env } -- XXX: Not checking the dependency files (the 'mi_usages' field) stored in -- interface, will not preprocess this module when the macros in required -- modules were changed ... is it fine? input_mtime <- getModificationUTCTime input_fn mb_output_mtime <- modificationTimeIfExists output_fn let can_reuse_output = maybe False (input_mtime <) mb_output_mtime no_force_recomp = not $ gopt Opt_ForceRecomp (hsc_dflags hsc_env) if no_force_recomp && can_reuse_output then logStrLn fpo ("runFnkPpPhase: Reusing " <> output_fn) else withFinkelExceptionHandler hsc_env $ preprocessOrCopy (Just hsc_env) ppo1 input_fn (Just output_fn) pure output_fn runFnkTcPhase :: FnkPluginOptions -> HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage) runFnkTcPhase fpo hsc_env ms0 = case ml_hs_file (ms_location ms0) of Nothing -> error "runFnkTcPhase: no hs file ..." Just hs_file -> do let dflags = hsc_dflags hsc_env pragma = fpoPragma fpo fnk_env = fpoFnkEnv fpo ts <- findTargetSourceWithPragma pragma dflags (noLoc hs_file) case ts of FnkSource {} -> fnkTypecheckAndGetWarnings fnk_env hsc_env ts HsSource {} -> hscTypecheckAndGetWarnings hsc_env ms0 _ -> error "runFnkTcPhase: other source ..." -- See: GHC.Driver.Main.hsc_typecheck, which is not exported. fnkTypecheckAndGetWarnings :: FnkEnv -> HscEnv -> TargetSource -> IO (FrontendResult, Messages GhcMessage) fnkTypecheckAndGetWarnings fnk_env hsc_env ts = runHsc' hsc_env $ do ems <- liftIO $ withFinkelExceptionHandler hsc_env $ runFnk' (fnkSourceToSummary ts) fnk_env hsc_env case ems of -- XXX: Invoke hscFrontendHook as done in hscTypecheckAndGetWarings? EMS ms1 _ _ | Just pm <- ms_parsed_mod ms1 -> do let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms1) hsc_env (tc_gbl, _) <- liftIO $ hscTypecheckRename lcl_hsc_env ms1 pm pure $ FrontendTypecheck tc_gbl _ -> error "runFnkTcPhase: no parsed mod ..." logStrLn :: FnkPluginOptions -> String -> IO () logStrLn fpo msg = when (1 < envVerbosity (fpoFnkEnv fpo)) $ hPutStrLn stderr msg withFinkelExceptionHandler :: ExceptionMonad m => HscEnv -> m a -> m a withFinkelExceptionHandler hsc_env = handleFinkelException handler where handler e = throwOneError (mkPlainWrappedMsg (hsc_dflags hsc_env) (mb_loc e) (text (displayException e))) mb_loc = fromMaybe noSrcSpan . finkelExceptionLoc #else /* ghc < 9.6.0 */ -- Does nothing in ghc < 9.6. finkelHooks :: str -> fnk_env -> opts -> hsc_env -> IO hsc_env finkelHooks _name _fnk_env _cmd_line_opts = pure #endif ================================================ FILE: finkel-kernel/src/Language/Finkel/Lexer.x ================================================ -- -*- mode: haskell; -*- { {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE CPP #-} {-# LANGUAGE UnboxedTuples #-} -- | Lexical analyser of S-expression tokens. -- -- This file contains Alex lexical analyser for tokeninzing S-expression. -- Lexcial analyser is used by Happy parser in S-expression reader. module Language.Finkel.Lexer ( -- * Types Token(..) , LexicalError(..) -- * Lexer function , tokenLexer , lexTokens -- * S-expression parser monad , SP(..) , SPState(..) , initialSPState , runSP , evalSP -- , incrSP , errorSP , lexErrorSP , putSPState , getSPState , modifySPState ) where #include "ghc_modules.h" -- base import Control.Exception (Exception(..)) import Control.Monad (ap, liftM, msum) import Data.Char (GeneralCategory(..), chr, generalCategory, ord, isDigit, isOctDigit, isHexDigit, isSpace, toUpper) import Data.List (intercalate) import Data.Maybe (fromMaybe) import Data.Word (Word8) import qualified GHC.Char as Char -- bytestring import qualified Data.ByteString as W8 import qualified Data.ByteString.Char8 as C8 -- ghc import GHC_Data_FastString (FastString, bytesFS, fsLit, nullFS, mkFastStringByteString, unpackFS) import GHC_Data_StringBuffer (StringBuffer, atEnd, byteDiff, cur, currentChar, lexemeToFastString, lexemeToString, nextChar, prevChar, stepOn) import GHC_Parser_CharClass (is_space) import GHC_Utils_Encoding (utf8DecodeByteString) import GHC_Types_SrcLoc (GenLocated(..), Located, RealSrcLoc, SrcLoc(..), SrcSpan(..), advanceSrcLoc, mkRealSrcLoc, mkRealSrcSpan, srcLocCol, srcLocLine) import GHC_Utils_Lexeme (startsConSym, startsVarId, startsVarSym) import GHC_Utils_Misc (readRational) #if MIN_VERSION_ghc(9,4,0) import qualified GHC.Data.Strict as Strict #endif -- ghc-boot import qualified GHC.LanguageExtensions as LangExt -- Internal import Language.Finkel.Data.FastString (unconsFS) import Language.Finkel.Data.SourceText import Language.Finkel.Data.Fractional import Language.Finkel.Form } $nl = [\n\r\f] $white = [$nl\v\t\ ] $white_no_nl = $white # $nl $negative = \- $octit = [0-7] $digit = [0-9] $hexit = [$digit A-F a-f] $hsymhead = [^\(\)\[\]\{\}\;\'\`\,\"\#\%$digit$white] $hsymtail = [$hsymhead\'\#\%$digit] $hsymtail_no_qt = $hsymtail # \' $hsymtail_no_ub = $hsymtail # \_ @signed = $negative? @octal = $octit+ @decimal = $digit+ @hexadecimal = $hexit+ @exponent = [eE] [\-\+]? @decimal @frac = @decimal \. @decimal @exponent? | @decimal @exponent @hsymbol = $hsymhead $hsymtail* | \# $hsymtail_no_qt* @contdoc = $nl [\t\ ]* \;+ ~$nl+ tokens :- $white+ ; --- Comments \;+ $white+ \^ $white_no_nl+ ~$nl+ @contdoc* { tok_doc_prev } \;+ $white+ \| $white_no_nl+ ~$nl+ @contdoc* { tok_doc_next } \;+ $white+ \*+ $white_no_nl+ .* { tok_doc_group } \;+ $white+ \$ @hsymbol $white_no_nl* ~$nl* @contdoc* { tok_doc_named } \; .* { tok_line_comment } \{\- .* { tok_block_comment } --- Discard prefix \% \_ { tok_discard } --- Pragma and symbols starting with '%' \% $hsymtail_no_ub* { tok_percent } --- Parenthesized commas, handled before parentheses \( $white* \,+ $white* \) { tok_pcommas } --- Parentheses \( { tok_oparen } \) { tok_cparen } \[ { tok_obracket } \] { tok_cbracket } \{ { tok_ocurly } \} { tok_ccurly } -- Quote, unquote, quasiquote, and unquote splice \' { tok_quote } \` { tok_quasiquote } \,\ { tok_comma } \,\@ { tok_unquote_splice } \, { tok_unquote } -- Lambda \\ ~$white* { tok_lambda } --- Literal values \" { tok_string } \#\' { tok_char } @signed @decimal { tok_integer } @signed 0[oO] @octal { tok_integer } @signed 0[xX] @hexadecimal { tok_integer } @signed @frac { tok_fractional } -- Symbols @hsymbol { tok_symbol } { -- --------------------------------------------------------------------- -- -- Parser monad -- -- --------------------------------------------------------------------- -- | Data type to hold states while reading source code. data SPState = SPState { -- | Target file for lexical analysis. targetFile :: FastString -- | @{-# LANGUAGE ... #-}@ found in target file. , langExts :: [Located String] -- | @{-# GHC_OPTIONS ... #-}@ found in target file. , ghcOptions :: [Located String] -- | @{-# OPTIONS_HADDOCK ... #-}@ found in target file. , haddockOptions :: [Located String] -- | Buffer to hold current input. , buf :: StringBuffer -- | Current location of input stream. , currentLoc :: RealSrcLoc } -- | Initial empty state for 'SP'. initialSPState :: FastString -> Int -> Int -> SPState initialSPState file linum colnum = SPState { targetFile = file , langExts = [] , ghcOptions = [] , haddockOptions = [] , buf = error "SPState.buf not initialized" , currentLoc = mkRealSrcLoc file linum colnum } data SPResult a = SPOK {-# UNPACK #-} !SPState a | SPNG SrcLoc Char String -- | A state monad newtype to pass around 'SPstate'. newtype SP a = SP { unSP :: SPState -> SPResult a } instance Functor SP where fmap = liftM {-# INLINE fmap #-} instance Applicative SP where pure a = SP (\st -> SPOK st a) {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-} instance Monad SP where m >>= k = SP (\st -> case unSP m st of SPOK st' a -> unSP (k a) st' SPNG l c msg -> SPNG l c msg) {-# INLINE (>>=) #-} data AlexInput = AlexInput RealSrcLoc StringBuffer -- | Lexical error with location and message. data LexicalError = LexicalError SrcLoc Char String deriving (Eq, Show) instance Exception LexicalError where displayException (LexicalError _ _ m) = m {-# INLINE displayException #-} -- | Perform given 'SP' computation with target file name and input contents. runSP :: SP a -- ^ Computation to perform. -> Maybe FilePath -- ^ File name of target. If 'Nothing', assumed as -- anonymous target. -> StringBuffer -- ^ Input contents. -> Either LexicalError (a, SPState) runSP sp target input = let st0 = initialSPState target' 1 1 st1 = st0 {buf = input} target' = maybe (fsLit "anon") fsLit target in case unSP sp st1 of SPOK sp' a -> Right (a, sp') SPNG loc c msg -> Left (LexicalError loc c msg) -- | Like 'runSP', but discard resulting 'SPState'. evalSP :: SP a -> Maybe FilePath -> StringBuffer -> Either LexicalError a evalSP sp target input = fmap fst (runSP sp target input) -- | Update current 'SPState' to given value. putSPState :: SPState -> SP () putSPState st = SP (\_ -> SPOK st ()) {-# INLINABLE putSPState #-} -- | Get current 'SPState' value. getSPState :: SP SPState getSPState = SP (\st -> SPOK st st) {-# INLINABLE getSPState #-} -- | Modify current 'SPState' with given function. modifySPState :: (SPState -> SPState) -> SP () modifySPState f = SP (\st -> SPOK (f st) ()) {-# INLINABLE modifySPState #-} -- | Get previous character in buffer from given 'SPState'. prevCharSP :: SPState -> Char prevCharSP st = prevChar (buf st) '\n' {-# INLINABLE prevCharSP #-} -- -- | Incrementally perform computation with parsed result and given -- -- function. -- incrSP :: SP a -- ^ The partial parser. -- -> (a -> b -> b) -- ^ Function to apply. -- -> b -- ^ Initial argument to the function. -- -> Maybe FilePath -- ^ Filepath of the input. -- -> StringBuffer -- ^ Input contents. -- -> Either String (b, SPState) -- incrSP sp f z target input = go st1 z -- where -- go st acc = -- case unSP sp st of -- SPNG _loc msg -- | atEnd (buf st) -> Right (acc, st) -- | otherwise -> Left msg -- SPOK st' ret -> -- -- let st'' = st' {buf=C8.cons (prevChar st') (buf st')} -- let st'' = st' {} -- ... efficient way to cons prev char? -- in go st'' $! f ret acc -- st0 = initialSPState target' 1 1 -- st1 = st0 {buf = input} -- target' = maybe (fsLit "anon") fsLit target -- | Show alex error with location of given 'Code' and error message. errorSP :: Code -- ^ Code for showing location information. -> String -- ^ Error message to show. -> SP a errorSP code msg = alexError (showLoc code ++ msg) -- | Show error message with current input. lexErrorSP :: SP a lexErrorSP = do st <- getSPState AlexInput loc buf <- alexGetInput let lno = srcLocLine loc cno = srcLocCol loc trg = unpackFS (targetFile st) c = prevChar buf '\n' msg = trg ++ ": lexer error at line " ++ show lno ++ ", column " ++ show cno ++ ", near " ++ show c alexError msg alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) alexGetByte (AlexInput loc0 buf0) = if atEnd buf0 then Nothing else case nextChar buf0 of (c, buf1) -> let w = adjustChar c loc1 = advanceSrcLoc loc0 c in w `seq` loc1 `seq` buf1 `seq` Just (w, AlexInput loc1 buf1) {-# INLINABLE alexGetByte #-} alexGetChar :: AlexInput -> Maybe (Char, AlexInput) alexGetChar (AlexInput loc0 buf0) = if atEnd buf0 then Nothing else case nextChar buf0 of (c, buf1) -> let loc1 = advanceSrcLoc loc0 c in c `seq` loc1 `seq` buf1 `seq` Just (c, AlexInput loc1 buf1) {-# INLINABLE alexGetChar #-} alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (AlexInput _ buf) = prevChar buf '\NUL' {-# INLINABLE alexInputPrevChar #-} alexError :: String -> SP a #if MIN_VERSION_ghc(9,4,0) alexError msg = SP (\st -> let rloc = RealSrcLoc (currentLoc st) Strict.Nothing in SPNG rloc (prevCharSP st) msg) #elif MIN_VERSION_ghc(9,0,0) alexError msg = SP (\st -> SPNG (RealSrcLoc (currentLoc st) Nothing) (prevCharSP st) msg) #else alexError msg = SP (\st -> SPNG (RealSrcLoc (currentLoc st)) (prevCharSP st) msg) #endif {-# INLINABLE alexError #-} alexGetInput :: SP AlexInput alexGetInput = SP (\st@SPState {currentLoc=l,buf=b} -> SPOK st (AlexInput l b)) {-# INLINABLE alexGetInput #-} alexSetInput :: AlexInput -> SP () alexSetInput (AlexInput l b) = SP (\st -> SPOK (st {buf=b,currentLoc=l}) ()) {-# INLINABLE alexSetInput #-} -- --------------------------------------------------------------------- -- -- Token data and actions -- -- --------------------------------------------------------------------- -- | Data type for token. data Token = TOparen -- ^ Open parenthesis. | TCparen -- ^ Close parenthesis. | TObracket -- ^ Open bracket. | TCbracket -- ^ Close bracket. | TOcurly -- ^ Open curly. | TCcurly -- ^ Close curly. | TQuote -- ^ Quote. | TQuasiquote -- ^ Quasi-quote. | TUnquote -- ^ Unquote. | TUnquoteSplice -- ^ Unquote-splice. | TComment -- ^ Comment. | TSymbol FastString -- ^ Symbol data. | TChar SourceText Char -- ^ Character data. | TString SourceText String -- ^ Literal string data. | TInteger SourceText Integer -- ^ Literal integer number. | TFractional FractionalLit -- ^ Literal fractional number. | TPercent Char -- ^ Special prefix @%@. | TPcommas Int -- ^ Parenthesized commas with number of repeats. | TDocNext FastString -- ^ Documentation comment for next thing. | TDocPrev FastString -- ^ Documentation comment for previous thing. | TDocGroup Int FastString -- ^ Documentation comment for section. | TDocNamed FastString (Maybe FastString) -- ^ Documentation comment for named documentation. | TEOF -- ^ End of form. deriving (Eq, Show) type Action = AlexInput -> Int -> SP Token -- Tokenizer actions for documentation -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- Currently, documentation comment starting with `;'s are converted to 'Token' -- data during lexical analysis. Once the documentation string were converted to -- 'Token' data type, it cannot distinguish between block documentation comment -- and line documentation comment. From this reason, the documentation comments -- generated with "Language.Finkel.Emit" are always using single-line comment -- syntax. tok_oparen :: Action tok_oparen _ _ = return TOparen {-# INLINABLE tok_oparen #-} tok_cparen :: Action tok_cparen _ _ = return TCparen {-# INLINABLE tok_cparen #-} tok_obracket :: Action tok_obracket _ _ = return TObracket {-# INLINABLE tok_obracket #-} tok_cbracket :: Action tok_cbracket _ _ = return TCbracket {-# INLINABLE tok_cbracket #-} tok_ocurly :: Action tok_ocurly _ _ = return TOcurly {-# INLINABLE tok_ocurly #-} tok_ccurly :: Action tok_ccurly _ _ = return TCcurly {-# INLINABLE tok_ccurly #-} tok_quote :: Action tok_quote _ _ = return TQuote {-# INLINABLE tok_quote #-} tok_quasiquote :: Action tok_quasiquote _ _ = return TQuasiquote {-# INLINABLE tok_quasiquote #-} tok_pcommas :: Action tok_pcommas (AlexInput _ buf) l = do let commas0 = lexemeToFastString buf (fromIntegral l) commas1 = bytesFS commas0 commas2 = C8.filter (not . isSpace) commas1 return $! TPcommas (fromIntegral (C8.length commas1 - 2)) {-# INLINABLE tok_pcommas #-} tok_comma :: Action tok_comma _ _ = return $ TSymbol $! fsLit "," {-# INLINABLE tok_comma #-} tok_unquote :: Action tok_unquote _ _ = return TUnquote {-# INLINABLE tok_unquote #-} tok_unquote_splice :: Action tok_unquote_splice _ _ = return TUnquoteSplice {-# INLINABLE tok_unquote_splice #-} tok_percent :: Action tok_percent (AlexInput _ buf) l | l == 2 , let c = currentChar (snd (nextChar buf)) , not (startsVarSym c) , not (startsConSym c) = return $! TPercent c | otherwise = let fs = lexemeToFastString buf l in fs `seq` return $! TSymbol fs {-# INLINABLE tok_percent #-} tok_discard :: Action tok_discard _ _ = return (TPercent '_') {-# INLINABLE tok_discard #-} tok_line_comment :: Action tok_line_comment _ _ = return TComment {-# INLINABLE tok_line_comment #-} tok_block_comment :: Action tok_block_comment = tok_block_comment_with (const TComment) alexGetChar {-# INLINABLE tok_block_comment #-} tok_block_comment_with :: (String -> Token) -> (AlexInput -> Maybe (Char, AlexInput)) -> Action tok_block_comment_with tok ini inp0 _ = do case alexGetChar inp0 of Just ('{', inp1) | Just ('-', inp2) <- alexGetChar inp1 , Just (c, inp3) <- ini inp2 , Just (com, inp4) <- go inp3 c "" -> alexSetInput inp4 >> return (tok (reverse com)) _ -> alexError "tok_block_comment: panic" where go inp prev acc = case alexGetChar inp of Just (c, inp') | prev == '-', c == '}', _:tl <- acc -> Just (tl, inp') | otherwise -> go inp' c (c:acc) Nothing -> Nothing {-# INLINABLE tok_block_comment_with #-} tok_doc_prev :: Action tok_doc_prev = tok_doc_with TDocPrev '^' {-# INLINABLE tok_doc_prev #-} tok_doc_next :: Action tok_doc_next = tok_doc_with TDocNext '|' {-# INLINABLE tok_doc_next #-} tok_doc_with :: (FastString -> Token) -> Char -> Action tok_doc_with constr char (AlexInput _ s) l = do let fs0 = takeUtf8FS l s bs0 = bytesFS fs0 case C8.lines bs0 of line0:bss -> do let line1 = C8.tail (C8.dropWhile (/= char) line0) bs1 = C8.unlines (line1 : map dropCommentBeginning bss) fs1 = mkFastStringByteString bs1 return $! constr fs1 _ -> alexError "tok_doc_with: panic" {-# INLINABLE tok_doc_with #-} tok_doc_named :: Action tok_doc_named (AlexInput _ s) l = do let fs0 = takeUtf8FS l s bs0 = bytesFS fs0 case C8.lines bs0 of line1:bss -> do let line2 = C8.dropWhile isSpace (dropCommentBeginning line1) line3 = C8.tail line2 key = mkFastStringByteString line3 bs1 = map dropCommentBeginning bss fs1 = mkFastStringByteString (C8.unlines bs1) fs2 = case bss of [] -> Nothing _ -> Just fs1 return $! TDocNamed key fs2 _ -> alexError "panic: tok_doc_named" {-# INLINABLE tok_doc_named #-} tok_doc_group :: Action tok_doc_group (AlexInput _ s) l = let bs0 = bytesFS (takeUtf8FS l s) bs1 = C8.dropWhile isSpace (dropCommentBeginning bs0) (stars, bs2) = C8.span (== '*') bs1 level = C8.length stars fs0 = mkFastStringByteString (C8.tail bs2) in return $! TDocGroup level fs0 {-# INLINABLE tok_doc_group #-} tok_lambda :: Action tok_lambda inp0@(AlexInput _ buf) l = do let return_lam_sym = return $ TSymbol $! fsLit "\\" if l == 1 then return_lam_sym else case alexGetChar inp0 of Just (_, inp1) | Just (c, _) <- alexGetChar inp1 -> -- Decide whether the token is a varsym starting with "\", or lambda -- and argument pattern. if startsVarSym c then return $ TSymbol $! takeUtf8FS l buf else alexSetInput inp1 >> return_lam_sym _ -> error "tok_lambda: panic" {-# INLINABLE tok_lambda #-} -- | Make token symbol. When the given symbol starts with non-operatator -- character, replace hyphens with underscores. tok_symbol :: Action tok_symbol (AlexInput _ buf) l = let fs0 = takeUtf8FS l buf fs1 | c == '!', secondIsVarId fs0 = replaceHyphens fs0 | startsVarSym c || startsConSym c = fs0 | otherwise = replaceHyphens fs0 where c = currentChar buf in fs0 `seq` fs1 `seq` return $! TSymbol fs1 {-# INLINABLE tok_symbol #-} secondIsVarId :: FastString -> Bool secondIsVarId fs0 = case unconsFS fs0 of Just (_,fs1) | Just (c,_) <- unconsFS fs1 -> startsVarId c _ -> False {-# INLINABLE secondIsVarId #-} replaceHyphens :: FastString -> FastString replaceHyphens = mkFastStringByteString . C8.map (\c -> if c == '-' then '_' else c) . bytesFS {-# INLINABLE replaceHyphens #-} tok_char :: Action tok_char inp0 _ = do case alexGetChar inp0 of Just ('#', inp1) -> go0 inp1 _ -> alexError "tok_char: panic" where go0 inp = case alexGetChar inp of Just ('\'', inp') -> go1 inp' _ -> alexError "tok_char.go0: panic" go1 inp | Just (c, inp') <- alexGetChar inp = case c of '\\' -> case escapeChar inp' of Just (st, c', inp'') -> do alexSetInput inp'' return $! TChar st c' Nothing -> do alexSetInput inp' return $! TChar (strToSourceText "'\\\\'") '\\' _ -> do alexSetInput inp' let st | c == '\'' = '\'' : '\\' : c : "'" | otherwise = '\'' : c : "'" return $! TChar (strToSourceText st) c | otherwise = alexError "tok_char.go1: panic" {-# INLINABLE tok_char #-} tok_string :: Action tok_string inp@(AlexInput _ buf) _l = -- Currently String tokenizer does not update alex input per character. This -- makes the code a bit more effiicient, but getting unhelpful message on -- lexical error with literal string. case alexGetChar inp of Just ('"', inp1) | Just (TString _ str, inp2@(AlexInput _ buf2)) <- go inp1 "" -> -- Refill the source text with string extracted with updated buffer -- location. do alexSetInput inp2 #if MIN_VERSION_ghc(9,8,0) let lexeme = lexemeToFastString #else let lexeme = lexemeToString #endif let src = lexeme buf (cur buf2 - cur buf) return $! TString (SourceText src) str _ -> lexErrorSP where go inp0 acc = case alexGetChar inp0 of Nothing -> Nothing Just (c1, inp1) | c1 == '"' -> do let acc' = reverse acc return $! (TString NoSourceText acc', inp1) | c1 == '\\' -> case escapeChar inp1 of Just (_st, c1, inp2) -> go inp2 $! (c1:acc) _ -> case alexGetChar inp1 of Just (c2, inp2) | c2 == '&' -> go inp2 $! acc | is_space' c2 -> string_gap inp2 acc _ -> Nothing | otherwise -> go inp1 $! (c1:acc) string_gap inp0 acc = case alexGetChar inp0 of Just (c, inp1) | c == '\\' -> go inp1 acc | is_space' c -> string_gap inp1 acc _ -> Nothing {-# INLINABLE tok_string #-} -- See "lex_stringgap" in "compiler/parser/Lexer.x". is_space' :: Char -> Bool is_space' c = c <= '\x7f' && is_space c {-# INLINABLE is_space' #-} escapeChar :: AlexInput -> Maybe (SourceText, Char, AlexInput) escapeChar inp0 | Just (c1, inp1) <- alexGetChar inp0 = let ret x = Just $! (strToSourceText (show x), x, inp1) esc str = strToSourceText ('\'':'\\':str) numericChar test acc0 f = let lp inp acc = case alexGetChar inp of Just (c2, inp') | test c2 -> lp inp' (c2:acc) | otherwise -> let acc' = reverse acc in Just (esc (acc'++"'"), Char.chr (read (f acc')), inp) Nothing -> Nothing in lp inp1 acc0 controlChar | Just (c2, inp2) <- alexGetChar inp1 , c2 >= '@' && c2 <= '_' = Just (esc ('^':c2:"'"), chr (ord c2 - ord '@'), inp2) | otherwise = Nothing lkup cs = lookup (C8.pack cs) bstbl = map (\(str,c) -> (C8.pack str, c)) tbl2 = bstbl tbl2_str tbl2_str = [ ("BS", '\BS'), ("HT", '\HT'), ("LF", '\LF'), ("VT", '\VT') , ("FF", '\FF'), ("CR", '\CR'), ("SO", '\SO'), ("SI", '\SI') , ("EM", '\EM'), ("FS", '\FS'), ("GS", '\GS'), ("RS", '\RS') , ("US", '\US'), ("SP", '\SP') ] tbl3 = bstbl tbl3_str tbl3_str = [ ("NUL", '\NUL'), ("SOH", '\SOH'), ("STX", '\STX') , ("ETX", '\ETX'), ("EOT", '\EOT'), ("ENQ", '\ENQ') , ("ACK", '\ACK'), ("BEL", '\BEL'), ("DLE", '\DLE') , ("DC1", '\DC1'), ("DC2", '\DC2'), ("DC3", '\DC3') , ("DC4", '\DC4'), ("NAK", '\NAK'), ("SYN", '\SYN') , ("ETB", '\ETB'), ("CAN", '\CAN'), ("SUB", '\SUB') , ("ESC", '\ESC') , ("DEL", '\DEL') ] in case c1 of 'a' -> ret '\a' 'b' -> ret '\b' 'f' -> ret '\f' 'n' -> ret '\n' 'r' -> ret '\r' 't' -> ret '\t' 'v' -> ret '\v' '"' -> ret '\"' '\'' -> ret '\'' '\\' -> ret '\\' '^' -> controlChar 'x' -> numericChar isHexDigit [c1] ('0':) 'o' -> numericChar isOctDigit [c1] ('0':) _ | isDigit c1 -> numericChar isDigit [c1] id | Just (c2, inp2) <- alexGetChar inp1 , Just (c3, inp3) <- alexGetChar inp2 -> case lkup [c1,c2,c3] tbl3 of Just c -> Just (esc [c1,c2,c3,'\''], c, inp3) Nothing | Just c <- lkup [c1,c2] tbl2 -> Just (esc [c1,c2,'\''], c, inp2) _ -> Nothing | otherwise -> Nothing | otherwise = Nothing {-# INLINABLE escapeChar #-} tok_integer :: Action tok_integer (AlexInput _ buf) l = let str = lexemeToString buf (fromIntegral l) in return $ TInteger (strToSourceText str) $! read $! str {-# INLINABLE tok_integer #-} tok_fractional :: Action tok_fractional (AlexInput _ buf) l = let str = lexemeToString buf $! fromIntegral l in return $! TFractional $! readFractionalLit $! str {-# INLINABLE tok_fractional #-} -- --------------------------------------------------------------------- -- -- Lexer -- -- --------------------------------------------------------------------- -- | Lexical analyzer for S-expression. Intended to be used with a parser made -- from Happy. This functions will not pass comment tokens to continuation. tokenLexer :: (Located Token -> SP a) -> SP a tokenLexer cont = go where go = do ltok@(L _span tok) <- scanToken case tok of TComment -> go _ -> cont ltok {-# INLINABLE tokenLexer #-} scanToken :: SP (Located Token) scanToken = do inp0@(AlexInput loc0 _) <- alexGetInput let sc = 0 case alexScan inp0 sc of AlexToken inp1 len act -> do alexSetInput inp1 tok <- act inp0 len -- Getting current location again after invoking 'act', to update -- location information of String tokens. loc1 <- fmap currentLoc getSPState #if MIN_VERSION_ghc(9,4,0) let span = RealSrcSpan (mkRealSrcSpan loc0 loc1) Strict.Nothing #elif MIN_VERSION_ghc(9,0,0) let span = RealSrcSpan (mkRealSrcSpan loc0 loc1) Nothing #else let span = RealSrcSpan (mkRealSrcSpan loc0 loc1) #endif return (L span tok) AlexError (AlexInput loc1 buf) -> do sp <- getSPState let l = srcLocLine loc1 c = srcLocCol loc1 trg = unpackFS (targetFile sp) alexError (trg ++ ": lexical error at line " ++ show l ++ ", column " ++ show c ++ ", near " ++ show (currentChar buf)) AlexSkip inp1 _ -> do alexSetInput inp1 scanToken AlexEOF -> return (L undefined TEOF) {-# INLINABLE scanToken #-} -- | Lex the input to list of 'Token's. lexTokens :: Maybe FilePath -> StringBuffer -> Either LexicalError [Located Token] lexTokens = evalSP go where go = do tok <- tokenLexer return case tok of L _ TEOF -> return [] _ -> (tok :) <$> go -- --------------------------------------------------------------------- -- -- Auxiliary -- -- --------------------------------------------------------------------- takeUtf8 :: Int -> StringBuffer -> String takeUtf8 = go [] where go acc n buf = if n == 0 then reverse acc else case nextChar buf of (c, buf') -> let acc' = c: acc n' = n - 1 in acc' `seq` n' `seq` go acc' n' buf' {-# INLINABLE takeUtf8 #-} takeUtf8FS :: Int -> StringBuffer -> FastString takeUtf8FS n sb0 = lexemeToFastString sb0 diff where diff = byteDiff sb0 (step n sb0) step i sb = if i == 0 then sb else let i' = i -1 sb' = stepOn sb in i' `seq` sb' `seq` step i' sb' {-# INLINABLE takeUtf8FS #-} -- Taken from "compiler/parser/Lexer.x.source" ghc source. adjustChar :: Char -> Word8 adjustChar c = fromIntegral $ ord adj_c where non_graphic = '\x00' upper = '\x01' lower = '\x02' digit = '\x03' symbol = '\x04' space = '\x05' other_graphic = '\x06' uniidchar = '\x07' adj_c | c <= '\x07' = non_graphic | c <= '\x7f' = c -- Alex doesn't handle Unicode, so when Unicode character is -- encountered we output these values with the actual character value -- hidden in the state. | otherwise = -- NB: The logic behind these definitions is also reflected in -- basicTypes/Lexeme.hs Any changes here should likely be -- reflected there. case generalCategory c of UppercaseLetter -> upper LowercaseLetter -> lower TitlecaseLetter -> upper ModifierLetter -> uniidchar -- see #10196 OtherLetter -> lower -- see #1103 NonSpacingMark -> uniidchar -- see #7650 SpacingCombiningMark -> other_graphic EnclosingMark -> other_graphic DecimalNumber -> digit LetterNumber -> other_graphic OtherNumber -> digit -- see #4373 ConnectorPunctuation -> symbol DashPunctuation -> symbol OpenPunctuation -> other_graphic ClosePunctuation -> other_graphic InitialQuote -> other_graphic FinalQuote -> other_graphic OtherPunctuation -> symbol MathSymbol -> symbol CurrencySymbol -> symbol ModifierSymbol -> symbol OtherSymbol -> symbol Space -> space _other -> non_graphic {-# INLINABLE adjustChar #-} dropCommentBeginning :: C8.ByteString -> C8.ByteString dropCommentBeginning = C8.dropWhile (== ';') {-# INLINABLE dropCommentBeginning #-} } ================================================ FILE: finkel-kernel/src/Language/Finkel/Main.hs ================================================ {-# LANGUAGE CPP #-} -- | Main function for Finkel compiler. -- -- This module contains 'main' function, which does similar and simplified works -- done in @"ghc/Main.hs"@ found in ghc source. -- module Language.Finkel.Main ( defaultMain , defaultMainWith ) where #include "ghc_modules.h" -- base import Control.Exception (displayException, throwIO) import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO (..)) import Data.List (intercalate, partition) import Data.Version (showVersion) import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..), getOpt, usageInfo) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure, exitWith) import System.FilePath (normalise) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) import System.Process (CreateProcess (..), createProcess_, proc, waitForProcess) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif -- ghc import GHC (defaultErrorHandler, parseDynamicFlags) import GHC_Driver_Monad (printException) import GHC_Driver_Phases (isDynLibFilename, isObjectFilename) import GHC_Driver_Session (DynFlags (..), GeneralFlag (..), HasDynFlags (..), compilerInfo, defaultFatalMessager, defaultFlushOut, gopt) import GHC_Types_Basic (SuccessFlag (..)) import GHC_Types_SrcLoc (mkGeneralLocated, unLoc) import GHC_Utils_CliOption (Option (FileOption)) import GHC_Utils_Misc (looksLikeModuleName) import GHC_Utils_Panic (GhcException (..), throwGhcException) #if MIN_VERSION_ghc(9,2,0) import GHC.Types.SourceError (handleSourceError) #else import GHC_Driver_Types (handleSourceError) #endif #if MIN_VERSION_ghc(8,10,1) && !MIN_VERSION_ghc(8,10,3) import GHC_Driver_Session (HscTarget (..), gopt_set) #endif -- ghc-boot import GHC.HandleEncoding (configureHandleEncoding) -- internal import Language.Finkel.Error import Language.Finkel.Exception import Language.Finkel.Fnk import Language.Finkel.Make import Language.Finkel.Options import Language.Finkel.Reader (supportedLangExts) import Language.Finkel.SpecialForms (defaultFnkEnv) import qualified Paths_finkel_kernel -- --------------------------------------------------------------------- -- -- The main function -- -- --------------------------------------------------------------------- -- [Main entry point] -- ~~~~~~~~~~~~~~~~~~ -- -- Formerly, the Finkel compiler executable was written as ghc frontend -- plugin. However, passing conflicting options used in ghc's "--make" to the -- Finkel compiler executable was cumbersome, since frontend option cannot be -- used when ghc is invoked in /make/ mode. -- -- Functions exported from this module is doing almost the same work done in the -- "Main" module of the ghc executable, but command line argument handling works -- are simplified, since Finkel compiler delegates works done in non-make mode -- to the ghc executable. -- | Function used by the Finkel kernel compiler. defaultMain :: IO () defaultMain = defaultMainWith [] -- | Make a main compiler function from given list of macros. -- -- This functions does simplified command line argument parsing done in default -- @ghc@ mode (i.e., @make@ mode). defaultMainWith :: [(String, Macro)] -- ^ List of pairs of macro name and 'Macro' value loaded to -- macro expander. -> IO () defaultMainWith macros = do args0 <- getArgs if any (`elem` rawGhcOptions) args0 then rawGhc args0 else showBriefUsageOnException $ do (fnk_opts, args1) <- parseFinkelOption defaultFnkEnv args0 let fnk_env0 = finkelEnv fnk_opts -- Filtering out `--make' flag when exist. Otherwise make flag would be -- treated as input file, and Finkel flags as unknown flags from this -- point. args3 = filter (/= "--make") args1 -- Using the `macros' from argument as first argument to the -- 'mergeMacros' function, so that the caller of this function can -- have a chance to override the behaviour of special forms in -- 'defaultFnkEnv'. macros' = mergeMacros (makeEnvMacros macros) (envMacros defaultFnkEnv) fnk_env1 = fnk_env0 { envDefaultMacros = macros' , envMacros = macros' } next = maybe (main1 fnk_env1 args1 args3) printFinkelHelp (finkelHelp fnk_opts) next showBriefUsageOnException :: IO a -> IO a showBriefUsageOnException = handleFinkelException (\e -> do me <- getProgName putStrLn (me ++ ": " ++ displayException e) printBriefUsage exitFailure) main1 :: FnkEnv -> [String] -> [String] -> IO () main1 fnk_env orig_args ghc_args = do initGCStatistics hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering configureHandleEncoding defaultErrorHandler defaultFatalMessager defaultFlushOut (runFnk (handleFinkelException (\e -> do printFinkelException e liftIO exitFailure) (handleSourceError (\e -> do printException e liftIO exitFailure) (main2 orig_args ghc_args))) fnk_env) main2 :: [String] -> [String] -> Fnk () main2 orig_arg ghc_args = if "--info" `elem` ghc_args -- Show info and exit. Using the 'DynFlags' from the finkel compiler -- executable, not the delegated "ghc" executable. then getDynFlags >>= liftIO . showInfo else main3 orig_arg ghc_args main3 :: [String] -> [String] -> Fnk () main3 orig_args ghc_args = do dflags0 <- getDynFlags let largs = map on_the_cmdline ghc_args on_the_cmdline = mkGeneralLocated "on the commandline" dflags1 = dflags0 {verbosity = 1} #if MIN_VERSION_ghc(8,10,3) dflags1b = dflags1 #elif MIN_VERSION_ghc(8,10,1) -- Workaround for "-fbyte-code" command line option handling in ghc -- 8.10.1 and 8.10.2. The use of `noArgM' and `pure $ gopt_set ...' for -- "-fbyte-code" option in "compiler/main/DynFlags.hs" is ignoring the -- updated hscTarget ... dflags1b = if "-fbyte-code" `elem` ghc_args then gopt_set (dflags1 {hscTarget=HscInterpreted}) Opt_ByteCode else dflags1 #else dflags1b = dflags1 #endif -- From ghc 9.0, "interpretPackageEnv" is called from "parseDynamicFlags". In -- older versions, package environment initialization works were done by -- "setSessionDynFlags" via "initPackages". logger <- getLogger #if MIN_VERSION_ghc(9,2,0) (dflags2, lfileish, warnings) <- parseDynamicFlags logger dflags1b largs #else (dflags2, lfileish, warnings) <- parseDynamicFlags dflags1b largs #endif let fileish = map unLoc lfileish platform = targetPlatform dflags2 isObjeish x = isObjectFilename platform x || isDynLibFilename platform x -- Partition source-code-ish from object-ish in file-ish arguments. (objish, srcish) = partition isObjeish fileish -- Partition Finkel and Haskell source codes in args. Delegate to raw ghc -- when source codes were null. Don't bother with ldInput, delegate the -- linking work to raw ghc. (srcs, non_srcs) = partition isSourceTarget srcish case srcs of [] -> liftIO (rawGhc orig_args) _ -> do -- Update ld inputs with object file inputs, as done in Main.hs of ghc. let ld_inputs = map (FileOption "") objish ++ ldInputs dflags2 dflags3 = dflags2 {ldInputs = ld_inputs} -- Using 'setDynFlags' instead of 'setSessionDynFlags', since -- 'setSessionDynFlags' will be called from 'initSessionForMake' below. setDynFlags dflags3 -- Some IO works. Check unknown flags, and update uniq supply. See Note -- [Initialization of UniqSupply] in 'Language.Finkel.Fnk'. liftIO (do checkUnknownFlags fileish initUniqSupply' (initialUnique dflags3) (uniqueIncrement dflags3)) -- Show DynFlags warnings. handleSourceError (\e -> do printException e liftIO exitFailure) (printOrThrowDiagnostics' logger dflags3 warnings) -- Initialization works for Finkel. initSessionForMake -- At the moment, compiling with phase specification are not supported, -- phase is always set to 'Nothing'. let phased_srcs = map phase_it srcs phased_non_srcs = map phase_it non_srcs phased_inputs = phased_srcs ++ phased_non_srcs phase_it path = (on_the_cmdline (normalise path), Nothing) force_recomp = gopt Opt_ForceRecomp dflags3 #if MIN_VERSION_ghc(9,2,0) ofile = outputFile_ dflags3 #else ofile = outputFile dflags3 #endif -- Do the `make' work. success_flag <- make phased_inputs force_recomp ofile case success_flag of Succeeded -> return () Failed -> liftIO exitFailure -- --------------------------------------------------------------------- -- -- Finkel specific options -- -- --------------------------------------------------------------------- data FinkelOption = FinkelOption { finkelHelp :: Maybe FinkelHelp -- Using strict field to get exception soon after command line parsing, to -- show command line argument errors without GHC panic message. , finkelEnv :: !FnkEnv } data FinkelHelp = Languages | Usage | Version defaultFinkelOption :: FnkEnv -> FinkelOption defaultFinkelOption fnk_env = FinkelOption { finkelHelp = Nothing , finkelEnv = fnk_env } parseFinkelOption :: FnkEnv -> [String] -> IO (FinkelOption, [String]) parseFinkelOption fnk_env args0 = do let (fnk_args, other_args) = partitionFnkEnvOptions args0 case getOpt Permute finkelOptDescrs fnk_args of (o,_,es) -> if null es then do -- Strictly evaluating 'FinkelOption' to show error message early as -- possible. let fo = foldl' (flip id) (defaultFinkelOption fnk_env) o fo `seq` pure (fo, other_args) else throwIO (FinkelException (concat es)) finkelOptDescrs :: [OptDescr (FinkelOption -> FinkelOption)] finkelOptDescrs = helpOptDescrs ++ debugOptDescrs helpOptDescrs :: [OptDescr (FinkelOption -> FinkelOption)] helpOptDescrs = [ opt ["fnk-help"] (NoArg (\o -> o {finkelHelp = Just Usage})) "Show this help and exit." , opt ["fnk-languages"] (NoArg (\o -> o {finkelHelp = Just Languages})) "Show supported language extensions and exit." , opt ["fnk-version"] (NoArg (\o -> o {finkelHelp = Just Version})) "Show Finkel version and exit." ] where opt = Option [] debugOptDescrs :: [OptDescr (FinkelOption -> FinkelOption)] debugOptDescrs = fromFnkEnvOptions (\f o -> o {finkelEnv = f (finkelEnv o)}) printFinkelHelp :: FinkelHelp -> IO () printFinkelHelp fh = case fh of Languages -> printLanguages Usage -> printFinkelUsage Version -> printFinkelVersion printFinkelUsage :: IO () printFinkelUsage = do name <- getProgName putStrLn (unlines (message name)) where message name = [ "USAGE: " ++ name ++ " [command-line-options-and-files]" , "" , usageInfo "HELP OPTIONS:\n" helpOptDescrs , fnkEnvOptionsUsage "DEBUG OPTIONS:\n" , " Other options are passed to ghc." ] printBriefUsage :: IO () printBriefUsage = putStrLn "Usage: For basic information, try the `--fnk-help' option." printLanguages :: IO () printLanguages = mapM_ (putStrLn . snd) supportedLangExts printFinkelVersion :: IO () printFinkelVersion = putStrLn v where v = "finkel kernel compiler, version " ++ showVersion Paths_finkel_kernel.version -- --------------------------------------------------------------------- -- -- Auxiliary -- -- --------------------------------------------------------------------- rawGhc :: [String] -> IO () rawGhc args = do (_,_,_,p) <- createProcess_ "ghc" (proc "ghc" args) {delegate_ctlc=True} waitForProcess p >>= exitWith -- | When any of options listed here were found, invoke raw @ghc@ without using -- Finkel compiler. Otherwise @ghc@ will complain with error message. These -- options are listed in "ghc/Main.hs" as `mode_flags'. rawGhcOptions :: [String] rawGhcOptions = [ "-?" , "--help" , "-V" , "--version" , "--numeric-version" , "--show-options" , "--supported-languages" , "--supported-extensions" , "--show-packages" , "--show-iface" , "--backpack" , "--interactive" , "--abi-hash" , "-e" , "--frontend" ] -- | Throw 'UsageError' when unknown flag were found. checkUnknownFlags :: [String] -> IO () checkUnknownFlags fileish = do let unknowns = [f | f@('-':_) <- fileish] oneErr f = "unrecognised flag: " ++ f ++ "\n" unless (null unknowns) (throwGhcException (UsageError (concatMap oneErr unknowns))) -- | True if given 'String' was module name, Finkel source file, or -- Haskell source file. isSourceTarget :: String -> Bool isSourceTarget str = looksLikeModuleName str || isFnkFile str || isHsFile str -- | Show the information of given 'DynFlags', doing the same thing as done in -- the @Main.hs@ found in ghc-bin. showInfo :: DynFlags -> IO () showInfo dflags = do let sq x = " [" ++ x ++ "\n ]" putStrLn (sq (intercalate "\n ," (map show (compilerInfo dflags)))) foreign import ccall safe "initGCStatistics" initGCStatistics :: IO () ================================================ FILE: finkel-kernel/src/Language/Finkel/Make/Cache.hs ================================================ {-# LANGUAGE CPP #-} -- | Module for managing home module cache. -- -- When compiling a module containing nested :require form, the required module -- is expanded twice, once when pre-processing and again when compiling byte -- code. This module contains functions for caching the home module to avoid -- redundant recompilation. module Language.Finkel.Make.Cache ( ExpandedCode(..) , lookupExpandedCodeCache , addToExpandedCodeCache , clearExpandedCodeCache , storeHomeModCache , updateHomeModCache , clearHomeModCache ) where #include "ghc_modules.h" -- base import Control.Monad.IO.Class (MonadIO (..)) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) import System.IO.Unsafe (unsafePerformIO) -- containers import Data.Map (Map) import qualified Data.Map as Map -- ghc import GHC_Unit_Module_ModSummary (ModSummary (..)) -- Internal import Language.Finkel.Form (Code) import Language.Finkel.Lexer (SPState (..)) #if MIN_VERSION_ghc(9,4,0) import GHC_Driver_Make (ModIfaceCache (..), newIfaceCache) import Language.Finkel.Fnk (Fnk (..), FnkEnv (..), getFnkEnv, modifyFnkEnv) #endif -- ------------------------------------------------------------------------ -- ExpandedCode cache -- ------------------------------------------------------------------------ -- | Data type to represent parsed module from source code. data ExpandedCode = ExpandedCode { ec_sp :: !SPState -- ^ Header information of expanded code. , ec_forms :: ![Code] -- ^ Parsed module compiled from expanded code. , ec_required :: [ModSummary] -- ^ Required home module during expansion. } -- | Lookup 'ExpandedCode' in cache. lookupExpandedCodeCache :: MonadIO m => FilePath -> m (Maybe ExpandedCode) lookupExpandedCodeCache path = liftIO $ Map.lookup path <$> readIORef unsafeExpandedCodeCacheRef {-# INLINABLE lookupExpandedCodeCache #-} -- | Add 'ExpandedCode' to cache with 'FilePath' key. addToExpandedCodeCache :: MonadIO m => FilePath -> ExpandedCode -> m () addToExpandedCodeCache path ec = liftIO $ do atomicModifyIORef' unsafeExpandedCodeCacheRef $ \ec_map -> (Map.insert path ec ec_map, ()) {-# INLINABLE addToExpandedCodeCache #-} -- | Update the whole cache with empty 'Map.Map'. clearExpandedCodeCache :: MonadIO m => m () clearExpandedCodeCache = liftIO $ do atomicModifyIORef' unsafeExpandedCodeCacheRef $ \_ -> (Map.empty, ()) {-# INLINABLE clearExpandedCodeCache #-} -- A global ref, IORef with unsafePerformIO. unsafeExpandedCodeCacheRef :: IORef (Map FilePath ExpandedCode) unsafeExpandedCodeCacheRef = unsafePerformIO $ newIORef Map.empty {-# NOINLINE unsafeExpandedCodeCacheRef #-} -- ------------------------------------------------------------------------ -- Home ModIface cache -- ------------------------------------------------------------------------ #if MIN_VERSION_ghc(9,4,0) -- XXX: Unfortunately, home module caching is not working when compiled without -- @-dynamic@ or @-dynamic-too@ option. -- -- Seems like, when compiling byte code target, the module is always force -- compiled. -- | Store current 'HomeModCache' to private global reference. storeHomeModCache :: Fnk () storeHomeModCache = do mb_mic <- fmap envInterpModIfaceCache getFnkEnv liftIO $ do new_ifc <- case mb_mic of -- XXX: Copy the contents of ModIfaceCache? Just mic -> pure $ HomeModCache {ifc_mic = mic} Nothing -> newHomeModCache atomicModifyIORef' unsafeHomeModCacheRef $ \_ifc -> (new_ifc, ()) {-# INLINABLE storeHomeModCache #-} -- | Update 'HomeModCache' in current 'FnkEnv'. updateHomeModCache :: Fnk () updateHomeModCache = do HomeModCache {ifc_mic = mic} <- liftIO $ readIORef unsafeHomeModCacheRef modifyFnkEnv (\fnk_env -> fnk_env {envInterpModIfaceCache = Just mic}) {-# INLINABLE updateHomeModCache #-} -- | Clear 'HomeModCache' in privarte global reference. clearHomeModCache :: MonadIO m => m () clearHomeModCache = liftIO $ do mic <- newIfaceCache atomicModifyIORef' unsafeHomeModCacheRef $ \ifc -> (ifc {ifc_mic = mic}, ()) {-# INLINABLE clearHomeModCache #-} -- | Data type to store home module cache passed from pre-process phase. newtype HomeModCache = HomeModCache { ifc_mic :: ModIfaceCache } newHomeModCache :: IO HomeModCache newHomeModCache = fmap HomeModCache newIfaceCache {-# INLINABLE newHomeModCache #-} -- | Unsafe global IORef to share home module information from pre-process phase -- to hsc phase. unsafeHomeModCacheRef :: IORef HomeModCache unsafeHomeModCacheRef = unsafePerformIO $ do hmc <- newHomeModCache newIORef hmc {-# NOINLINE unsafeHomeModCacheRef #-} #else /* ghc < 9.4 */ -- ModIfaceCache does not exist in ghc < 9.4. Do nothing with dummy functions. storeHomeModCache :: Monad m => m () storeHomeModCache = pure () updateHomeModCache :: Monad m => m () updateHomeModCache = pure () clearHomeModCache :: Monad m => m () clearHomeModCache = pure () #endif /* ghc < 9.4 */ ================================================ FILE: finkel-kernel/src/Language/Finkel/Make/Recompile.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | Module containing types and functions for object code recompilation check. module Language.Finkel.Make.Recompile ( RecompM(..) , RecompState(..) , emptyRecompState , checkRecompileRequired , checkModSummary , adjustIncludePaths ) where #include "ghc_modules.h" -- base import Control.Monad (forM_, when) import Control.Monad.Fail (MonadFail (..)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Bifunctor (first) import GHC.Fingerprint (getFileHash) import System.IO (fixIO) #if MIN_VERSION_ghc(9,4,0) -- containers import qualified Data.Set as Set #endif -- filepath import System.FilePath (dropExtension, takeDirectory) -- ghc import GHC_Data_FastString (FastString) import GHC_Driver_Env_Types (HscEnv (..)) import GHC_Driver_Phases (Phase (..)) import GHC_Driver_Session (DynFlags (..), HasDynFlags (..), addQuoteInclude) import GHC_Iface_Load (readIface) import GHC_Iface_Recomp (checkOldIface) import GHC_Iface_Recomp_Binary (putNameLiterally) import GHC_Iface_Recomp_Flags (fingerprintDynFlags) import GHC_IfaceToCore (typecheckIface) import GHC_Tc_Module (getModuleInterface) import GHC_Tc_Utils_Monad (initIfaceLoad) import GHC_Types_SrcLoc (Located, noLoc, unLoc) import GHC_Types_Unique_Set (UniqSet, addOneToUniqSet, elementOfUniqSet, emptyUniqSet) import GHC_Unit_Finder (findObjectLinkableMaybe) import GHC_Unit_Home_ModInfo (HomeModInfo (..), addToHpt, lookupHpt) import GHC_Unit_Module (ModLocation (..), ModuleName, mkModuleName, moduleName, moduleNameString) import GHC_Unit_Module_Deps (Dependencies (..), Usage (..)) import GHC_Unit_Module_ModIface (ModIface, ModIface_ (..), mi_flag_hash, mi_mod_hash) import GHC_Unit_Module_ModSummary (ModSummary (..), msHiFilePath, ms_mod_name) import GHC_Unit_State (LookupResult (..), lookupModuleWithSuggestions) import GHC_Unit_Types (IsBootInterface) import GHC_Utils_Exception (handleIO) import GHC_Utils_Fingerprint (Fingerprint) import GHC_Utils_Outputable (Outputable (..), SDoc, text, (<+>)) import qualified GHC_Data_Maybe as Maybes #if MIN_VERSION_ghc(9,8,0) import GHC.Data.FastString (unpackFS) #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Unit.Home.ModInfo (HomeModLinkable (..), emptyHomeModInfoLinkable) #endif #if MIN_VERSION_ghc(9,6,0) import GHC.SysTools.Cpp (offsetIncludePaths) #elif MIN_VERSION_ghc(9,4,0) import GHC.Driver.Pipeline.Execute (offsetIncludePaths) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Env (hscUpdateHPT, hsc_HPT) import GHC.Iface.Recomp (MaybeValidated (..)) import GHC.Rename.Names (renamePkgQual) import GHC.Types.PkgQual (PkgQual (..)) #elif MIN_VERSION_ghc(9,2,0) import GHC.Types.SourceFile (SourceModified (..)) #else import GHC_Driver_Types (SourceModified (..)) #endif #if !MIN_VERSION_ghc(9,4,0) import GHC_Iface_Recomp (RecompileRequired (..)) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env (hsc_units) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Unit_Types (GenWithIsBoot (..), ModuleNameWithIsBoot) #endif -- internal import Language.Finkel.Error import Language.Finkel.Fnk import Language.Finkel.Make.Summary import Language.Finkel.Make.TargetSource import Language.Finkel.Make.Trace -- ------------------------------------------------------------------------ -- -- Recompilation check for ModSummary -- -- ------------------------------------------------------------------------ checkModSummary :: MonadIO m => HscEnv -> ModSummary -> m Bool checkModSummary hsc_env ms = do let mb_usages = do old_hmi <- lookupHpt (hsc_HPT hsc_env) (ms_mod_name ms) return (mi_usages (hm_iface old_hmi)) maybe (pure False) runUsageFileCheck mb_usages -- | Simple function to check whther the 'UsageFile' is up to date. runUsageFileCheck :: MonadIO m => [Usage] -> m Bool runUsageFileCheck = go -- See: 'MkIface.checkModUsage'. where go us = case us of [] -> return True u:us' -> do ret <- check u if ret then go us' else return False check u = case u of UsageFile {usg_file_path = file ,usg_file_hash = old_hash} -> liftIO (handleIO (const (return False)) (fmap (== old_hash) (getFileHash' file))) _ -> return True #if MIN_VERSION_ghc(9,8,0) getFileHash' = getFileHash . unpackFS #else getFileHash' = getFileHash #endif -- ------------------------------------------------------------------------ -- -- Recompilation check for interface file -- -- ------------------------------------------------------------------------ -- | State used for recompilation check. data RecompState = RecompState { rs_hsc_env :: !HscEnv , rs_outdated :: !ModuleNameSet } type ModuleNameSet = UniqSet ModuleName emptyRecompState :: HscEnv -> RecompState emptyRecompState hsc_env = RecompState hsc_env emptyUniqSet {-# INLINABLE emptyRecompState #-} addOutdated :: ModuleName -> RecompState -> RecompState addOutdated name rs = rs {rs_outdated = addOneToUniqSet (rs_outdated rs) name} {-# INLINABLE addOutdated #-} elemOutdated :: ModuleName -> RecompState -> Bool elemOutdated name rs = name `elementOfUniqSet` rs_outdated rs {-# INLINABLE elemOutdated #-} -- "RecompM a" is same as "FnkT (ExceptT SDoc (State RecompState)) a". -- | Newtype for recompilation check, state monad combined with Fnk with either -- value. newtype RecompM a = RecompM {unRecompM :: RecompState -> Fnk (Either SDoc a, RecompState)} instance Functor RecompM where fmap f (RecompM m) = RecompM (fmap (first (fmap f)) . m) {-# INLINE fmap #-} instance Applicative RecompM where pure a = RecompM (\st0 -> pure (pure a, st0)) {-# INLINE pure #-} f <*> m = f >>= flip fmap m {-# INLINE (<*>) #-} instance Monad RecompM where RecompM m >>= k = RecompM (\st0 -> do (et1, st1) <- m st0 case et1 of Left why -> st1 `seq` return (Left why, st1) Right a -> st1 `seq` unRecompM (k a) st1) {-# INLINE (>>=) #-} instance MonadFail RecompM where fail e = RecompM (\_ -> Control.Monad.Fail.fail e) {-# INLINE fail #-} instance MonadThrow RecompM where throwM e = RecompM (\_ -> throwM e) {-# INLINE throwM #-} instance MonadIO RecompM where liftIO io = RecompM (\st -> liftIO io >>= \a -> pure (Right a, st)) {-# INLINE liftIO #-} instance HasDynFlags RecompM where getDynFlags = RecompM (\st -> pure (Right (hsc_dflags (rs_hsc_env st)), st)) {-# INLINE getDynFlags #-} instance HasLogger RecompM where #if MIN_VERSION_ghc(9,2,0) getLogger = RecompM (\st -> pure (Right (hsc_logger (rs_hsc_env st)), st)) {-# INLINE getLogger #-} #else getLogger = pure (error "getLogger (RecompM): no Logger") #endif -- | Check whether recompilation is required. checkRecompileRequired :: FnkEnv -> TargetUnit -> RecompM ModSummary checkRecompileRequired fnk_env tu = do hsc_env <- getHscEnv ms0 <- mkModSummaryForRecompile hsc_env tu checkOutdatedCache (ms_mod_name ms0) checkObjDate ms0 iface0 <- lookupOrLoadIface ms0 checkUsagePackageModules (mi_usages iface0) ms1 <- refillHomeImports fnk_env ms0 iface0 iface1 <- doCheckOldIface ms1 iface0 hsc_env1 <- getHscEnv hmi <- mkHomeModInfo hsc_env1 ms0 iface1 addHomeModInfo (ms_mod_name ms0) hmi return ms1 getRecompState :: RecompM RecompState getRecompState = RecompM (\st -> pure (Right st, st)) {-# INLINABLE getRecompState #-} getHscEnv :: RecompM HscEnv getHscEnv = RecompM (\st -> pure (Right (rs_hsc_env st), st)) {-# INLINABLE getHscEnv #-} recomp :: SDoc -> RecompM a recomp why = RecompM (\st -> pure (Left why, st)) {-# INLINABLE recomp #-} outdate :: ModuleName -> SDoc -> RecompM a outdate name why = RecompM (\st0 -> pure (Left why, addOutdated name st0)) {-# INLINABLE outdate #-} outdateToo :: ModuleName -> RecompM a -> RecompM a outdateToo name (RecompM r) = RecompM $ \st0 -> do et_a <- r st0 case et_a of (Left why, st1) -> pure (Left why, addOutdated name st1) (Right a, st1) -> pure (Right a, st1) {-# INLINABLE outdateToo #-} addHomeModInfo :: ModuleName -> HomeModInfo -> RecompM () addHomeModInfo name hmi = RecompM (\rs0 -> let hsc_env0 = rs_hsc_env rs0 hpt1 = addToHpt (hsc_HPT hsc_env0) name hmi #if MIN_VERSION_ghc(9,4,0) hsc_env1 = hscUpdateHPT (const hpt1) hsc_env0 #else hsc_env1 = hsc_env0 {hsc_HPT = hpt1} #endif rs1 = rs0 {rs_hsc_env = hsc_env1} in pure (Right (), rs1)) {-# INLINABLE addHomeModInfo #-} checkOutdatedCache :: ModuleName -> RecompM () checkOutdatedCache mname = do st <- getRecompState when (elemOutdated mname st) (recomp (text (moduleNameString mname ++ " in outdated cache"))) {-# INLINABLE checkOutdatedCache #-} checkObjDate :: ModSummary -> RecompM () #if MIN_VERSION_ghc(9,4,0) -- ms_hs_date disappeared in ghc 9.4. -- XXX: Should check with Fingerprint in ms_hs_hash field? checkObjDate _ms = pure () #else checkObjDate ms = do let name = ms_mod_name ms hdate = ms_hs_date ms out str = outdate name (text (moduleNameString name) <+> text "has" <+> text str) case ms_obj_date ms of Just odate | hdate < odate -> return () Just _ -> out "outdated object code" _ -> out "no object code" #endif {-# INLINABLE checkObjDate #-} lookupOrLoadIface :: ModSummary -> RecompM ModIface lookupOrLoadIface ms = do rs <- getRecompState case lookupHpt (hsc_HPT (rs_hsc_env rs)) (ms_mod_name ms) of Just hmi -> return (hm_iface hmi) Nothing -> loadIface (rs_hsc_env rs) ms {-# INLINABLE lookupOrLoadIface #-} -- | Check whether 'UsagePackageModule' elements are up to date or not. checkUsagePackageModules :: [Usage] -> RecompM () checkUsagePackageModules usages = getHscEnv >>= forM_ usages . go -- Since RecompM might use a ModSummary without parsing source code, import -- declarations of external modules are not filled in the ModSummary. This -- function is for manually checking the status of imported modules from -- external package. where -- Checking the Usage for external package modules, to decide whether the -- source code file should be parsed or not. go hsc_env u = case u of UsagePackageModule {usg_mod=mdl,usg_mod_hash=old_hash} -> do let mname = moduleName mdl mname_str = moduleNameString mname check_mod_hash = do -- External package modules are also stored in outdated cache, -- looking up the cache before loading the interface. checkOutdatedCache mname (_, mb_iface) <- liftIO (getModuleInterface hsc_env mdl) case mb_iface of Nothing -> outdate mname (text (mname_str ++ " iface not found")) Just iface -> when (miModHash' iface /= old_hash) (outdate mname (text (mname_str ++ " hash changed"))) #if MIN_VERSION_ghc(9,2,0) lmws_arg1 = hsc_units #elif MIN_VERSION_ghc(9,0,0) lmws_arg1 = unitState . hsc_dflags #else lmws_arg1 = hsc_dflags #endif -- case lookupModuleWithSuggestions (lmws_arg1 hsc_env) mname Nothing of #if MIN_VERSION_ghc(9,4,0) no_pkgq = NoPkgQual #else no_pkgq = Nothing #endif case lookupModuleWithSuggestions (lmws_arg1 hsc_env) mname no_pkgq of LookupFound {} -> check_mod_hash LookupMultiple {} -> check_mod_hash LookupHidden {} -> check_mod_hash LookupUnusable {} -> outdate mname (text (mname_str ++ " unusable")) LookupNotFound {} -> outdate mname (text (mname_str ++ " not found")) _ -> return () -- | Refill 'ms_textual_imps' field with 'UsageHomeModule' in interface. refillHomeImports :: FnkEnv -> ModSummary -> ModIface -> RecompM ModSummary refillHomeImports fnk_env ms mi = do -- XXX: At the moment cannot find any clue to get textual imports of external -- packages from ModIface, recompilation due to changes in external package -- modules are done with "checkUsagePackageModules". let dmods0 = get_dep_mods (mi_deps mi) #if MIN_VERSION_ghc(9,4,0) get_dep_mods = dep_direct_mods #else get_dep_mods = dep_mods #endif dmods1 = mapDMS unDeps dmods0 tr = traceMake fnk_env "refillHomeImports" mname = ms_mod_name ms tr [ "dep_mods mi_deps of" <+> ppr mname , nvcOrNone (dmsToList (mapDMS fst dmods1)) ] -- Marking this module as outdated when any of the imported home package -- module was outdated, and at the same time, preserving the state with -- outdated home package module. imps0 <- outdateToo mname (mapM (collectOldIface fnk_env) (dmsToList dmods1)) #if MIN_VERSION_ghc(9,4,0) hsc_env <- getHscEnv let imps1 = map rename imps0 rename (mb_fs, lmname) = (renamePkgQual unit_env (unLoc lmname) mb_fs, lmname) unit_env = hsc_unit_env hsc_env #else let imps1 = imps0 #endif return (ms {ms_textual_imps=imps1}) #if MIN_VERSION_ghc(9,4,0) unDeps :: (a, ModuleNameWithIsBoot) -> (ModuleName, IsBootInterface) unDeps (_, mnwib) = (gwib_mod mnwib, gwib_isBoot mnwib) #elif MIN_VERSION_ghc(9,0,0) unDeps :: ModuleNameWithIsBoot -> (ModuleName, IsBootInterface) unDeps gwib = (gwib_mod gwib, gwib_isBoot gwib) #else unDeps :: a -> a unDeps = id #endif {-# INLINABLE unDeps #-} -- | Load old interface when usable and not yet loaded. collectOldIface :: FnkEnv -> (ModuleName, IsBootInterface) -> RecompM (Maybe FastString, Located ModuleName) collectOldIface fnk_env (mname, _is_boot) = do hsc_env <- getHscEnv let tr = traceMake fnk_env "collectOldIface" -- Lookup HomeModInfo in current HomePackageTable. If not found, updating -- HomeModInfo, so that the later "checkOlfIface" can lookup the interface -- files in HomePackageTable. If the interface were not added, fake interface -- would be added to PIT by the "checkOldIface" via "LoadIface.loadInterface". case lookupHpt (hsc_HPT hsc_env) mname of Just _hmi -> do tr ["Found iface of" <+> ppr mname <+> "in HPT"] return (Nothing, noLoc mname) Nothing -> do -- Before doing any other check, lookup the outdated cache. checkOutdatedCache mname -- Checking the existence of the old module, could be deleted. tu <- checkTargetUnit (noLoc (moduleNameString mname), Nothing) dep_ms <- mkModSummaryForRecompile hsc_env tu checkObjDate dep_ms -- Comparing the DynFlags hash at this point, to trigger recompilation -- with changes in the DynFlag. iface <- loadIface hsc_env dep_ms checkFlagHash hsc_env dep_ms iface -- External packages are not in textual import of ModSummary when reusing -- interface, checking now. checkUsagePackageModules (mi_usages iface) tr ["Collecting old iface of" <+> ppr mname] hmi <- mkHomeModInfo hsc_env dep_ms iface addHomeModInfo mname hmi return (Nothing, noLoc mname) -- | Check whether recompile is required or not via 'checkOldIface'. doCheckOldIface :: ModSummary -> ModIface -> RecompM ModIface doCheckOldIface ms iface0 = do hsc_env0 <- getHscEnv let dflags_with_new_paths = adjustIncludePaths (ms_hspp_opts ms) ms hsc_env1 = hsc_env0 {hsc_dflags = dflags_with_new_paths} mb_iface0 = Just iface0 mname = ms_mod_name ms #if MIN_VERSION_ghc(9,4,0) -- 'SourceModified' data type disappeared in ghc 9.4. mbv_iface <- liftIO (checkOldIface hsc_env1 ms mb_iface0) case mbv_iface of UpToDateItem iface -> pure iface OutOfDateItem reason _ -> outdate mname (ppr reason) #else -- Delegating the interface test to "checkOldIface", except for the -- up-to-date-ness of source code by comparing the timestamps of the source -- code file and object code file. let src_modified = case ms_obj_date ms of Just odate | ms_hs_date ms < odate -> SourceUnmodified _ -> SourceModified recompileReason rr = case rr of UpToDate -> text "up to date" MustCompile -> text "must compile" RecompBecause why -> text why (rr, mb_iface1) <- liftIO (checkOldIface hsc_env1 ms src_modified mb_iface0) let why = recompileReason rr case rr of UpToDate | Just iface <- mb_iface1 -> return iface _ -> outdate mname why #endif checkTargetUnit :: (Located String, Maybe Phase) -> RecompM TargetUnit checkTargetUnit name_and_mb_phase@(lname, _) = do dflags <- hsc_dflags <$> getHscEnv let name = unLoc lname mname = mkModuleName (asModuleName name) mb_tu <- findTargetUnitMaybe dflags name_and_mb_phase case mb_tu of Nothing -> outdate mname (text ("Source of " ++ name ++ " not found")) Just tu -> return tu {-# INLINABLE checkTargetUnit #-} checkFlagHash :: HscEnv -> ModSummary -> ModIface -> RecompM () checkFlagHash _he ms iface = do -- See "checkFlagHash" function in "MkIface". let old_hash = miFlagHash' iface dflags0 = ms_hspp_opts ms dflags1 = adjustIncludePaths dflags0 ms mdl = mi_module iface #if MIN_VERSION_ghc(9,2,0) new_hash <- let he1 = _he {hsc_dflags = dflags1} in liftIO (fingerprintDynFlags he1 mdl putNameLiterally) #else new_hash <- liftIO (fingerprintDynFlags dflags1 mdl putNameLiterally) #endif when (old_hash /= new_hash) (outdate (moduleName mdl) "flag hash changed") {-# INLINABLE checkFlagHash #-} -- | Wrapper function to load interface file with 'readIface'. loadIface :: HscEnv -> ModSummary -> RecompM ModIface loadIface hsc_env ms = do let mdl = ms_mod ms mname = moduleName mdl mname_str = moduleNameString mname #if MIN_VERSION_ghc(9,4,0) let load_iface = readIface (hsc_dflags hsc_env) (hsc_NC hsc_env) mdl (msHiFilePath ms) read_result <- liftIO (initIfaceLoad hsc_env (liftIO load_iface)) #else let load_iface = readIface mdl (msHiFilePath ms) read_result <- liftIO (initIfaceLoad hsc_env load_iface) #endif case read_result of Maybes.Failed _e -> outdate mname (text ("no iface for " ++ mname_str)) Maybes.Succeeded iface -> pure iface -- | Make 'HomeModInfo' for object code recompilation. mkHomeModInfo :: MonadIO m => HscEnv -> ModSummary -> ModIface -> m HomeModInfo mkHomeModInfo hsc_env0 ms iface0 = liftIO $ do let mdl = ms_mod ms mloc = ms_location ms #if MIN_VERSION_ghc(9,4,0) update_hpt = hscUpdateHPT #else update_hpt f he = he {hsc_HPT = f (hsc_HPT he)} #endif #if MIN_VERSION_ghc(9,6,0) empty_home_mod_info_linkable = emptyHomeModInfoLinkable asObjLinkable mb_linkable = HomeModLinkable { homeMod_object = mb_linkable , homeMod_bytecode = Nothing } #else empty_home_mod_info_linkable = Nothing asObjLinkable = id #endif -- See Note [Knot-tying typecheckIface] in GhcMake. knot_tying hsc_env mname iface = fixIO $ \details' -> do let hmi = HomeModInfo iface details' empty_home_mod_info_linkable hsc_env1 = update_hpt (\hpt -> addToHpt hpt mname hmi) hsc_env initIfaceLoad hsc_env1 (typecheckIface iface) details <- knot_tying hsc_env0 (ms_mod_name ms) iface0 mb_linkable <- findObjectLinkableMaybe mdl mloc return $! HomeModInfo iface0 details (asObjLinkable mb_linkable) -- | Adjust the 'includePaths' field in given 'DynFlags' to prepare for getting -- flag hash value. adjustIncludePaths :: DynFlags -> ModSummary -> DynFlags adjustIncludePaths dflags0 ms = -- See: "DriverPipeline.compileOne'", it is doing similar work for updating -- the "includePaths" of the "DynFlags" used in "checkOldInterface". case ml_hs_file (ms_location ms) of Nothing -> dflags0 Just path -> let old_paths = includePaths dflags0 current_dir = takeDirectory (dropExtension path) new_paths0 = addQuoteInclude old_paths [current_dir] #if MIN_VERSION_ghc(9,4,0) new_paths1 = offsetIncludePaths dflags0 new_paths0 #else new_paths1 = new_paths0 #endif in dflags0 {includePaths = new_paths1} miModHash', miFlagHash' :: ModIface -> Fingerprint miModHash' = mi_mod_hash . mi_final_exts miFlagHash' = mi_flag_hash . mi_final_exts {-# INLINABLE miModHash' #-} {-# INLINABLE miFlagHash' #-} -- ------------------------------------------------------------------------ -- -- GHC version compatibility functions -- -- ------------------------------------------------------------------------ -- Fields in Dependency module set -- -- Data type for dependency module is defined in GHC.Unit.Module.Deps as -- `Dependencies'. Some of the fields in this data type has changed to use `Set' -- from plain list. Following `DepModSet' tries to absorb the modification. mapDMS :: (Ord a, Ord b) => (a -> b) -> DepModSet a -> DepModSet b {-# INLINABLE mapDMS #-} dmsToList :: DepModSet a -> [a] {-# INLINABLE dmsToList #-} #if MIN_VERSION_ghc(9,4,0) type DepModSet a = Set.Set a mapDMS = Set.map dmsToList = Set.toList #else type DepModSet a = [a] mapDMS = map dmsToList = id #endif ================================================ FILE: finkel-kernel/src/Language/Finkel/Make/Session.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | Module to manage HscEnv for macro expansion. module Language.Finkel.Make.Session ( withExpanderSettings , setExpanding , isExpanding , bcoDynFlags , isInterpreted , discardInteractiveContext , clearGlobalSession , expandContents ) where #include "ghc_modules.h" -- base import Control.Concurrent (MVar, modifyMVar, newMVar) import Control.Monad.IO.Class (MonadIO (..)) import Data.Foldable (for_) import Data.IORef (atomicModifyIORef', newIORef) import Data.List (intercalate) import Data.Maybe (isJust) import System.IO.Unsafe (unsafePerformIO) #if MIN_VERSION_ghc(9,0,0) import qualified Data.Set as Set #endif -- exception import Control.Monad.Catch (bracket) -- ghc import GHC_Data_StringBuffer (hGetStringBuffer) import GHC_Driver_Env_Types (HscEnv (..)) import GHC_Driver_Main (newHscEnv) import GHC_Driver_Monad (Ghc (..), GhcMonad (..), Session (..), getSession, setSession) import GHC_Driver_Session (DynFlags (..), GeneralFlag (..), GhcLink (..), HasDynFlags (..), WarningFlag (..), setGeneralFlag', updOptLevel, wopt_unset) import GHC_Utils_Outputable (Outputable (..), fsep, nest, text, (<+>)) #if MIN_VERSION_ghc(9,8,0) import GHC.Driver.DynFlags (ParMakeCount (..)) #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Driver.Backend (backendWritesFiles) import GHC.Driver.Session (topDir, unSetGeneralFlag') #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Driver.Backend (backendCanReuseLoadedCode, interpreterBackend) #elif MIN_VERSION_ghc(9,2,0) import GHC.Driver.Backend (Backend (..)) #else import GHC_Driver_Session (HscTarget (..)) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Env (discardIC) #else import GHC_Runtime_Context (InteractiveContext (..), emptyInteractiveContext) import GHC_Types_Name (nameIsFromExternalPackage) #endif #if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,4,0) import GHC.Driver.Env (hsc_home_unit) #endif #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) import GHC_Driver_Session (homeUnit) #endif #if MIN_VERSION_ghc(9,0,0) import GHC (setSessionDynFlags) import GHC_Platform_Ways (Way (..), hostFullWays) #else import GHC_Driver_Session (Way (..), interpWays, thisPackage) #endif #if MIN_VERSION_ghc(9,0,0) import GHC.Runtime.Loader (initializePlugins) #else import DynamicLoading (initializePlugins) #endif -- Internal import Language.Finkel.Expand (expands) import Language.Finkel.Fnk import Language.Finkel.Make.Cache import Language.Finkel.Reader (parseSexprs) -- --------------------------------------------------------------------- -- -- Expanded home module form -- -- --------------------------------------------------------------------- -- | Get expanded module form of given file path. -- -- This function first lookup the global cache with using the file path as the -- key of the cache. If not found in cache, read the file, expand macros, and -- cache the result. expandContents :: FilePath -> Fnk ExpandedCode expandContents path = do fnk_env <- getFnkEnv dflags <- getDynFlags let tr = debugWhen' dflags fnk_env Fnk_trace_session path_text = text path mb_ec <- lookupExpandedCodeCache path case mb_ec of Just ec -> do tr ["expandContents: reusing expanded code in" <+> path_text] pure ec _other -> do -- XXX: When to reset macros to envDefaultMacros? Or, no need for -- resetting since the expansion happens in pre-processing phase? tr ["expandContents: expanding" <+> path_text <+> "..."] buf <- liftIO $ hGetStringBuffer path (forms0, sp) <- parseSexprs (Just path) buf forms1 <- withExpanderSettings $ expands forms0 reqs <- envRequiredHomeModules <$> getFnkEnv resetRequiredHomeModules let ec = ExpandedCode sp forms1 reqs tr ["expandContents: adding cache for" <+> path_text] addToExpandedCodeCache path ec pure ec resetRequiredHomeModules :: Fnk () resetRequiredHomeModules = modifyFnkEnv $ \fnk_env -> fnk_env {envRequiredHomeModules = []} {-# INLINABLE resetRequiredHomeModules #-} -- --------------------------------------------------------------------- -- -- Session management -- -- --------------------------------------------------------------------- -- | Perform given action with 'HscEnv' updated for macroexpansion with -- interactive evaluation, then reset to the preserved original 'HscEnv'. withExpanderSettings :: Fnk a -> Fnk a withExpanderSettings act = do fnk_env <- getFnkEnv dflags <- getDynFlags debugWhen' dflags fnk_env Fnk_trace_session ["withExpanderSettings: envInvokedMode:" <+> ppr (envInvokedMode fnk_env)] case envInvokedMode fnk_env of ExecMode -> withExpanderSettingsE act GhcPluginMode -> withExpanderSettingsG act -- | Like 'withExpanderSettings', but takes a flag to discard interactive -- context in the session used for the expansion. withExpanderSettingsE :: Fnk a -> Fnk a withExpanderSettingsE act = do dflags <- getDynFlags -- Switching to the dedicated 'HscEnv' for macro expansion when compiling -- object code. If not, assuming current session is using the bytecode -- interpreter, using the given action as-is. if isInterpreted dflags then act else bracket prepare restore (const act) where prepare = do fnk_env <- getFnkEnv hsc_env_old <- getSession -- Reusing previous 'HscEnv' for macro expansion if exist, or making a new -- 'HscEnv'. When reusing, discarding the previous 'InteractiveContext', -- to avoid file local compile time functions to affect other modules. case envSessionForExpand fnk_env of Just he -> setSession $! discardInteractiveContext he Nothing -> do he1 <- newHscEnvForExpand fnk_env hsc_env_old setSession he1 postSetSession he2 <- getSession modifyFnkEnv (\e -> e {envSessionForExpand = Just he2}) return hsc_env_old restore hsc_env_old = do hsc_env_new <- getSession modifyFnkEnv (\e -> e {envSessionForExpand = Just hsc_env_new}) setSession hsc_env_old #if MIN_VERSION_ghc(9,0,0) -- To set the "hsc_interp" field in the new session. postSetSession = getDynFlags >>= setSessionDynFlags #else postSetSession = return () #endif -- | Make new 'HscEnv' from given 'DynFlags'. -- -- Adjusting the 'DynFlags' used by the macro expansion session, to support -- evaluating expressions in dynamic and non-dynamic builds of the Finkel -- compiler executable. newHscEnvForExpand :: MonadIO m => FnkEnv -> HscEnv -> m HscEnv newHscEnvForExpand fnk_env orig_hsc_env = do let tr = debugWhen' dflags0 fnk_env Fnk_trace_session dflags0 = hsc_dflags orig_hsc_env -- XXX: Constantly updating the backend to interpreter, the original -- backend information is gone. If the 'bcoDynFlags' was not applied, -- compilation of finkel-core package failed in ghc <= 8.10. dflags1 = bcoDynFlags dflags0 dflags2 = if interpHasNoWayDyn then removeWayDyn dflags1 else dflags1 tr [ "newHscEnvForExpand.hsc_targets" , nest 2 (fsep (map ppr (hsc_targets orig_hsc_env)))] #if MIN_VERSION_ghc(9,6,0) -- In ghc 9.6, arguments of newHscEnv takes top directory of ghc library path. new_hsc_env_0 <- liftIO $! newHscEnv (topDir dflags2) dflags2 #else new_hsc_env_0 <- liftIO $! newHscEnv dflags2 #endif #if MIN_VERSION_ghc(9,4,0) -- From ghc 9.4, plugins (loaded and static) are stored in HscEnv instead of -- DynFlags. Updating the hsc_plugins and hsc_hooks fields from old hsc_env -- value. let new_hsc_env_1 = new_hsc_env_0 { hsc_plugins = hsc_plugins orig_hsc_env , hsc_hooks = hsc_hooks orig_hsc_env } #elif MIN_VERSION_ghc(9,2,0) -- From ghc 9.2, hsc_env has separate fields for loaded plugins and static -- plugins. let new_hsc_env_1 = new_hsc_env_0 { hsc_plugins = hsc_plugins orig_hsc_env , hsc_static_plugins = hsc_static_plugins orig_hsc_env } #else -- No need to update hsc_env, plugins are stored in DynFlags. let new_hsc_env_1 = new_hsc_env_0 #endif pure new_hsc_env_1 -- | Run given 'Fnk' action with macro expansion settings for 'GhcPluginMode'. withExpanderSettingsG :: Fnk a -> Fnk a withExpanderSettingsG act = do dflags <- getDynFlags fnk_env <- getFnkEnv let tr = debugWhen' dflags fnk_env Fnk_trace_session if isExpanding dflags then do -- Clearing the current target, but not using 'withGlobalSession'. The -- 'withGlobalSesion' function locks the top level MVar, using it will -- cause a dead lock. tr ["withExpanderSettingsG: clearing hsc_targets for nested call"] tr ["withExpanderSettingsG: keys" <+> text (showExpanding dflags)] withEmptyTargets act else do tr ["withExpanderSettingsG: withGlobalSession"] withGlobalSession act -- Run given action with empty 'hsc_targets', restores the original target after -- running. withEmptyTargets :: Fnk a -> Fnk a withEmptyTargets act0 = bracket prepare restore act1 where prepare = do hsc_env <- getSession let orig_targets = hsc_targets hsc_env setSession (hsc_env {hsc_targets = []}) pure orig_targets restore orig_targets = do hsc_env <- getSession setSession (hsc_env {hsc_targets = orig_targets}) act1 _ = act0 -- Note: [Global HscEnv for plugin] -- -------------------------------- -- -- When compiling with ghc plugin, FnkEnv is unwrapped with "toGhc" and "unGhc" -- to perform the inner IO action. This way of invokation could not share the -- FnkEnv when compiling multiple module, so reading from and writing to a -- global MVar to pass around the "Session" to avoid redundant module compilation -- when using home package modules during macro expansion. -- | Wrapper to perform given action with global 'Session', to share the -- underlying 'HscEnv' when compiling as ghc plugin. withGlobalSession :: Fnk a -> Fnk a withGlobalSession act0 = do fer <- Fnk pure fenv0 <- getFnkEnv orig_hsc_env <- getSession let tr = debugWhen' (hsc_dflags orig_hsc_env) fenv0 Fnk_trace_session prepare do_init = do hsc_env <- if do_init then initializeGlobalSession else getSession dumpHscEnv fenv0 "withGlobalSession (prepare)" hsc_env pure hsc_env restore hsc_env_orig = do hsc_env <- getSession dumpHscEnv fenv0 "withGlobalSession (restore):" hsc_env setSession hsc_env_orig act1 do_init = bracket (prepare do_init) restore $ \mex0 -> do let mex1 = discardInteractiveContext mex0 setSession mex1 modifyFnkEnv (\e -> e {envSessionForExpand = Just mex1}) retval <- act0 mex2 <- getSession modifyFnkEnv (\e -> e {envSessionForExpand = Just mex2}) fnk_env <- getFnkEnv pure (retval, fnk_env) (retval, fnk_env) <- liftIO $ do modifyMVar globalSessionVar $ \mb_s0 -> do (do_init, s1@(Session r1)) <- case mb_s0 of Just s0 -> do tr ["withGlobalSession: global session already initialized"] pure (False, s0) Nothing -> do tr ["withGlobalSession: invoking newHscEnvForExpand"] new_hsc_env <- newHscEnvForExpand fenv0 orig_hsc_env r0 <- newIORef new_hsc_env pure (True, Session r0) (retval, fnk_env) <- unGhc (toGhc (act1 do_init) fer) s1 for_ (envSessionForExpand fnk_env) $ \he -> atomicModifyIORef' r1 (const (he, ())) pure (Just s1, (retval, fnk_env)) putFnkEnv fnk_env liftIO $ tr ["withGlobalSession: clearing expanded code cache"] clearExpandedCodeCache pure retval -- | Clear the contents of global 'MVar' containing 'HscEnv' for macro -- expansion. clearGlobalSession :: IO () clearGlobalSession = modifyMVar globalSessionVar $ const $ pure (Nothing, ()) {-# INLINABLE clearGlobalSession #-} initializeGlobalSession :: GhcMonad m => m HscEnv initializeGlobalSession = do #if MIN_VERSION_ghc(9,0,0) -- To set the "hsc_interp" field in the new session. _ <- getDynFlags >>= setSessionDynFlags #endif getSession >>= initializePlugin' {-# INLINABLE initializeGlobalSession #-} -- Version compatible variant of 'initializePlugins'. initializePlugin' :: MonadIO m => HscEnv -> m HscEnv #if MIN_VERSION_ghc(9,2,0) initializePlugin' = liftIO . initializePlugins #else initializePlugin' hsc_env = do plugin_dflags <- liftIO $ initializePlugins hsc_env (hsc_dflags hsc_env) return (updateDynFlags plugin_dflags hsc_env) #endif {-# INLINABLE initializePlugin' #-} -- | Unsafe global 'MVar' to share the 'HscEnv' when compiling as plugin. globalSessionVar :: MVar (Maybe Session) globalSessionVar = unsafePerformIO (newMVar Nothing) {-# NOINLINE globalSessionVar #-} -- XXX: Workaround for passing state to recursively called "load'" function -- defined in GHC driver. Modifying the "rawSettings" field in the DynFlags with -- dummy String value, so that recursive call to the "load'" function can tell -- whether current module is compiled for macro expansion or not. -- -- The "parMakeCount" field update is a wokaround for concurrent build. Current -- approach does not work with "-j" ghc option, which could cause race -- conditions when multiple mudoles were requiring same home package module, -- since the HscEnv is shared between all home package modules. -- | Modify given 'DynFlags' as in macro expansion state. setExpanding :: DynFlags -> DynFlags setExpanding dflags0 = let raw_settings = rawSettings dflags0 #if MIN_VERSION_ghc(9,8,0) dflags1 = dflags0 {parMakeCount = Just (ParMakeThisMany 1)} #else dflags1 = dflags0 {parMakeCount = Just 1} #endif dflags2 = dflags1 {rawSettings = expandingKey : raw_settings} in dflags2 {-# INLINABLE setExpanding #-} -- | 'True' if given 'DynFlags' is in macro expansion state. isExpanding :: DynFlags -> Bool isExpanding = isJust . lookup (fst expandingKey) . rawSettings {-# INLINABLE isExpanding #-} -- | Internally used key value pair to mark macro expansion state. expandingKey :: (String, String) expandingKey = ("FNK_MEX", "1") {-# INLINABLE expandingKey #-} -- | Show expanding key. showExpanding :: DynFlags -> String showExpanding dflags = let keys = [ k <> "=" <> v | kv@(k, v) <- rawSettings dflags, kv == expandingKey] in intercalate " " keys {-# INLINABLE showExpanding #-} removeWayDyn :: DynFlags -> DynFlags #if MIN_VERSION_ghc(9,2,0) removeWayDyn df = df {targetWays_ = removeDynFromWays (targetWays_ df)} #else removeWayDyn df = df {ways = removeDynFromWays (ways df)} #endif {-# INLINABLE removeWayDyn #-} #if MIN_VERSION_ghc(9,0,0) removeDynFromWays :: Set.Set Way -> Set.Set Way removeDynFromWays = Set.filter (/= WayDyn) #else removeDynFromWays :: [Way] -> [Way] removeDynFromWays = filter (/= WayDyn) #endif {-# INLINABLE removeDynFromWays #-} -- | From `discardIC'. discardInteractiveContext :: HscEnv -> HscEnv #if MIN_VERSION_ghc(9,4,0) discardInteractiveContext = discardIC #else discardInteractiveContext hsc_env = let dflags = hsc_dflags hsc_env empty_ic = emptyInteractiveContext dflags new_ic_monad = keep_external_name ic_monad old_ic = hsc_IC hsc_env keep_external_name ic_name = if nameIsFromExternalPackage this_pkg old_name then old_name else ic_name empty_ic where old_name = ic_name old_ic # if MIN_VERSION_ghc(9,2,0) this_pkg = hsc_home_unit hsc_env # elif MIN_VERSION_ghc(9,0,0) this_pkg = homeUnit dflags # else this_pkg = thisPackage dflags # endif in hsc_env {hsc_IC = empty_ic {ic_monad = new_ic_monad}} #endif {-# INLINABLE discardInteractiveContext #-} -- | Setup 'DynFlags' for interactive evaluation. bcoDynFlags :: DynFlags -> DynFlags -- XXX: See: 'GhcMake.enableCodeGenForUnboxedTupleOrSums'. bcoDynFlags dflags0 = let dflags1 = dflags0 { ghcLink = LinkInMemory #if MIN_VERSION_ghc(9,6,0) , backend = interpreterBackend #elif MIN_VERSION_ghc(9,2,0) , backend = Interpreter #else , hscTarget = HscInterpreted #endif } #if MIN_VERSION_ghc(9,6,0) -- See 'GHC.Driver.Main.hscMaybeWriteIface'. The function will panic if -- writing simple interface file with dyanmic-too option enabled. The -- simple interface is written from -- "GHC.Driver.Pipeline.Execute.runHscBackendPhase" if backend does not -- write files. -- -- XXX: Not sure whether possible to have -dynamic-too with -- non-file-writing backend, confirm it. dflags2 | not (backendWritesFiles (backend dflags0)) = unSetGeneralFlag' Opt_BuildDynamicToo dflags1 | otherwise = dflags1 #else dflags2 = dflags1 #endif #if MIN_VERSION_ghc(9,6,0) -- In ghc 9.6, seems like `Opt_ByteCode' is not in use any more. dflags3 = setGeneralFlag' Opt_UseBytecodeRatherThanObjects dflags2 #elif MIN_VERSION_ghc(9,2,0) dflags3 = setGeneralFlag' Opt_ByteCode dflags2 #elif MIN_VERSION_ghc(8,10,3) dflags3 = setGeneralFlag' Opt_ByteCodeIfUnboxed dflags2 #elif MIN_VERSION_ghc(8,10,1) dflags3 = setGeneralFlag' Opt_ByteCode dflags2 #else dflags3 = dflags2 #endif dflags4 = setGeneralFlag' Opt_IgnoreOptimChanges $ setGeneralFlag' Opt_IgnoreHpcChanges $ updOptLevel 0 dflags3 -- XXX: Warning message for missing home package module is shown with -- -Wall option, suppressing for now ... dflags5 = wopt_unset dflags4 Opt_WarnMissingHomeModules in dflags5 {-# INLINABLE bcoDynFlags #-} interpHasNoWayDyn :: Bool #if MIN_VERSION_ghc(9,0,0) interpHasNoWayDyn = WayDyn `notElem` hostFullWays #else interpHasNoWayDyn = WayDyn `notElem` interpWays #endif {-# INLINABLE interpHasNoWayDyn #-} -- | 'True' when the 'DynFlags' is using interpreter. isInterpreted :: DynFlags -> Bool #if MIN_VERSION_ghc(9,6,0) -- As of ghc 9.6.2, interpreter backend is the only backend which can reuse -- loaded code. isInterpreted = backendCanReuseLoadedCode . backend #elif MIN_VERSION_ghc(9,2,0) isInterpreted dflags = backend dflags == Interpreter #else isInterpreted dflags = hscTarget dflags == HscInterpreted #endif {-# INLINABLE isInterpreted #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Make/Summary.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -- | Internal module for 'ModSummary'. module Language.Finkel.Make.Summary ( -- * Target summary TargetSummary(..) , plainEMS -- * ModSummary helpers , summariseTargetUnit , mkModSummaryForRecompile , updateSummaryTimestamps , compileFnkFile , dumpParsedAST , dumpModSummary -- * Builder helpers , buildHsSyn -- * GHC version compatibility , mkModuleGraph' , mgModSummaries' , mgElemModule' , extendMG' , withTiming' , isObjectBackend -- * Re-export , Option(..) ) where #include "ghc_modules.h" -- base import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (..)) import Data.Foldable (find) import Data.List (nub) import Data.Maybe (isJust) import System.IO (IOMode (..), withFile) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif -- container #if !MIN_VERSION_ghc(9,2,0) import qualified Data.Map as Map #endif -- date import Data.Time (UTCTime) -- directory import System.Directory (createDirectoryIfMissing) -- filepath import System.FilePath (takeBaseName, takeDirectory, (<.>), ()) -- ghc import GHC_Data_FastString (fsLit) import GHC_Data_StringBuffer (StringBuffer, hGetStringBuffer) import GHC_Driver_Env_Types (HscEnv (..)) import GHC_Driver_Monad (GhcMonad (..)) import GHC_Driver_Phases (Phase (..)) import GHC_Driver_Pipeline (compileFile, preprocess) import GHC_Driver_Ppr (printForUser) import GHC_Driver_Session (DumpFlag (..), DynFlags (..), HasDynFlags (..), parseDynamicFilePragma) import GHC_Hs (HsModule (..)) import GHC_Hs_Dump (BlankSrcSpan (..), showAstData) import GHC_Hs_ImpExp (ImportDecl (..)) import GHC_Hs_Stats (ppSourceStats) import GHC_Parser_Header (getImports) import GHC_Types_SourceError (throwErrors, throwOneError) import GHC_Types_SourceFile (HscSource (..)) import GHC_Types_SrcLoc (GenLocated (..), Located, mkSrcLoc, mkSrcSpan, unLoc) import GHC_Unit_Finder (addHomeModuleToFinder, mkHomeModLocation) import GHC_Unit_Home_ModInfo (HomeModInfo (..), lookupHpt) import GHC_Unit_Module (ModLocation (..), Module, ModuleName, mkModuleName, moduleName, moduleNameSlashes, moduleNameString) import GHC_Unit_Module_Deps (Usage (..)) import GHC_Unit_Module_Graph (ModuleGraph, mgLookupModule, mgModSummaries, mkModuleGraph) import GHC_Unit_Module_ModIface (ModIface_ (..)) import GHC_Unit_Module_ModSummary (ModSummary (..), ms_mod_name) import GHC_Utils_CliOption (Option (..)) import GHC_Utils_Misc (looksLikeModuleName, modificationTimeIfExists) import GHC_Utils_Outputable (Outputable (..), SDoc, hcat, quotes, text, vcat, ($$), (<+>)) #if MIN_VERSION_ghc(9,8,0) import GHC.Data.FastString (unpackFS) #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Runtime.Context (icNamePprCtx) #else import GHC_Runtime_Context (icPrintUnqual) #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Driver.Backend (backendWritesFiles) #elif MIN_VERSION_ghc(9,2,0) import GHC.Driver.Backend (backendProducesObject) #else import GHC_Driver_Session (isObjectTarget) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Env (hscSetFlags, hsc_HPT) import GHC.Driver.Phases (StopPhase (..)) import GHC.Parser.Header (mkPrelImports) import GHC.Rename.Names (renameRawPkgQual) import GHC.Types.PkgQual (PkgQual (..), RawPkgQual (..)) import GHC.Unit.Module.Graph (ModuleGraphNode (..)) import qualified GHC.Unit.Module.Graph as Graph import GHC.Unit.Module.ModSummary (ms_imps) import GHC.Utils.Fingerprint (getFileHash) #else import GHC_Data_FastString (FastString) import GHC_Driver_Pipeline (writeInterfaceOnlyMode) import GHC_Unit_Module_Graph (mgElemModule) import GHC_Utils_Misc (getModificationUTCTime) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Errors.Types (GhcMessage (..)) import GHC.Utils.Logger (putDumpFileMaybe) #elif MIN_VERSION_ghc(9,2,0) import GHC.Driver.Config (initParserOpts) import GHC.Parser.Errors.Ppr (pprError) import GHC.Utils.Logger (dumpIfSet_dyn) #else import GHC_Utils_Error (dumpIfSet_dyn) #endif #if !MIN_VERSION_ghc(9,4,0) import GHC_Unit_Module_ModSummary (ms_home_allimps) #endif #if !MIN_VERSION_ghc(9,4,0) && MIN_VERSION_ghc(9,2,0) import GHC.Unit.Module.ModSummary (extendModSummaryNoDeps) #endif #if !MIN_VERSION_ghc(9,4,0) import GHC_Unit_Module_Graph (extendMG) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env (hsc_home_unit) import GHC.Driver.Session (xopt) import GHC.Hs.Dump (BlankEpAnnotations (..)) import GHC.LanguageExtensions (Extension (ImplicitPrelude)) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Hs (HsParsedModule (..)) #else import GHC_Driver_Types (HsParsedModule (..)) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Unit.Home (mkHomeModule) #elif MIN_VERSION_ghc(9,0,0) import GHC_Driver_Session (homeUnit) import GHC_Unit_Module (mkModule) #else import GHC_Driver_Session (thisPackage) import GHC_Unit_Module (mkModule) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Utils.Logger (DumpFormat (..)) #elif MIN_VERSION_ghc(9,0,0) import GHC_Parser_Annotation (ApiAnns (..)) import GHC_Utils_Error (DumpFormat (..)) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Monad (withTimingM) #else import GHC_Utils_Error (withTimingD) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Utils_Outputable (Depth (..)) #endif -- Internal import Language.Finkel.Builder import Language.Finkel.Emit import Language.Finkel.Error import Language.Finkel.Fnk import Language.Finkel.Form import Language.Finkel.Lexer import Language.Finkel.Make.Cache import Language.Finkel.Make.Session import Language.Finkel.Make.TargetSource import Language.Finkel.Reader import Language.Finkel.Syntax import Language.Finkel.Syntax.Location -- | Data type to represent summarised 'TargetSource'. data TargetSummary = -- | Expanded 'ModSummary', from 'FnkSource' and 'HsSource'. EMS !ModSummary -- ^ Summary of itself !(Maybe SPState) -- ^ Parsed state for FnkSource [ModSummary] -- ^ Required home package modules for FnkSource -- | Link time file option, from 'OtherSource'. | LdInput !Option #if !MIN_VERSION_ghc(9,4,0) -- PkgQual and RawPkgQual did not exist until ghc 9.4, instead, Maybe FastString -- were used for both types of package qualified imports. type PkgQual = Maybe FastString type RawPkgQual = Maybe FastString #endif -- | Make 'EMS' with no 'SPState' and empty list of required 'ModSummary'. plainEMS :: ModSummary -> TargetSummary plainEMS ms = EMS ms Nothing [] -- | Make a 'TargetSummary' from given 'TargetUnit'. summariseTargetUnit :: TargetUnit -> Fnk TargetSummary summariseTargetUnit (tsrc, mbphase) = case tsrc of FnkSource path mn -> compileFnkFile path mn HsSource path _ -> compileHsFile path mbphase OtherSource path -> compileOtherFile path -- | Compile Finkel source. compileFnkFile :: FilePath -> ModuleName -> Fnk TargetSummary compileFnkFile path modname = do fnk_env0 <- getFnkEnv hsc_env <- getSession ExpandedCode {ec_sp=sp, ec_forms=forms, ec_required=reqs} <- expandContents path dflags1 <- getDynFlagsFromSPState hsc_env sp let tr = traceSummary fnk_env0 "compileFnkFile" mname_str = moduleNameString modname mname_sdoc = text (mname_str ++ ":") tr ["path:" <+> text path] -- Compile the form with local DynFlags to support file local pragmas. mdl <- withTmpDynFlags dflags1 $ withTiming' ("FinkelModule [" ++ mname_str ++ "]") $ do -- Reset current FnkEnv. No need to worry about managing DynFlags, this -- action is wrapped with 'withTmpDynFlags' above. resetEnvMacros compileFnkModuleForm forms tr ["reqs in" <+> mname_sdoc <+> ppr (map ms_mod_name reqs)] let rreqs = reverse reqs -- XXX: Pass the Bool value for ms_ghc_prim_import somehow. ms <- mkModSummary hsc_env dflags1 path mdl rreqs -- Dump the module contents as Haskell source code when any of the dump -- options was set and this is the first time for compiling the target module. dumpHsSourceCode fnk_env0 hsc_env (Just sp) ms -- Also showing the parsed AST to support -ddump-parsed-ast option. dumpParsedAST hsc_env (ms_hspp_opts ms) ms return $! EMS ms (Just sp) rreqs -- | Parse the file header LANGUAGE pragmas and update given 'DynFlags'. parseFnkFileHeader :: (HasLogger m, MonadIO m, MonadThrow m) => HscEnv -> FilePath -> m DynFlags parseFnkFileHeader hsc_env path = do contents <- liftIO (hGetStringBuffer path) (_, sp) <- parseHeaderPragmas (Just path) contents getDynFlagsFromSPState hsc_env sp -- | Compile 'HModule' from given list of 'Code'. compileFnkModuleForm :: [Code] -> Fnk HModule compileFnkModuleForm form = do fnk_env <- getFnkEnv let colons = replicate 19 ';' debugWhen fnk_env Fnk_dump_expand [ text "" , text colons <+> text "Expanded" <+> text colons , vcat (map ppr form) , text ""] buildHsSyn parseModule form -- | Get language extensions in current 'Fnk' from given 'SPState'. getDynFlagsFromSPState :: (HasLogger m, MonadIO m) => HscEnv -> SPState -> m DynFlags getDynFlagsFromSPState hsc_env sp = do -- Adding "-X" to 'String' representation of 'LangExt' data type, as done in -- 'HeaderInfo.checkExtension'. let dflags0 = hsc_dflags hsc_env mkx = fmap ("-X" ++) exts = map mkx (langExts sp) logger <- getLogger (dflags1,_,warns1) <- parseDynamicFilePragma dflags0 exts printOrThrowDiagnostics' logger dflags1 warns1 (dflags2,_,warns2) <- parseDynamicFilePragma dflags1 (ghcOptions sp) printOrThrowDiagnostics' logger dflags2 warns2 return dflags2 resetEnvMacros :: Fnk () resetEnvMacros = modifyFnkEnv (\fnk_env -> fnk_env {envMacros = envDefaultMacros fnk_env}) {-# INLINABLE resetEnvMacros #-} compileHsFile :: FilePath -> Maybe Phase -> Fnk TargetSummary compileHsFile path mb_phase = do -- Not fully parsing the Haskell source code, it will be parsed by the "load'" -- function later. hsc_env <- getSession (dflags, pp_path) <- liftIO (preprocess' hsc_env (path, mb_phase)) sbuf <- liftIO (hGetStringBuffer pp_path) (simps, timps, ghc_prim_import, L _l mname) <- liftIO (getImports' dflags sbuf pp_path path) let simps' = fmap (rnRPQI hsc_env) simps timps' = fmap (rnRPQI hsc_env) timps ms <- mkModSummary' hsc_env dflags path mname simps' timps' Nothing (Just sbuf) ghc_prim_import return $! plainEMS ms -- | Rename raw package qualified import. See -- 'GHC.Driver.Make.getPreprocessedImports', which is not exported. rnRPQI :: HscEnv -> (RawPkgQual, Located ModuleName) -> (PkgQual, Located ModuleName) #if MIN_VERSION_ghc(9,4,0) rnRPQI hsc_env (pk, lmn@(L _ mn)) = (renameRawPkgQual (hsc_unit_env hsc_env) mn pk, lmn) #else rnRPQI _ = id #endif {-# INLINABLE rnRPQI #-} compileOtherFile :: FilePath -> Fnk TargetSummary compileOtherFile path = do hsc_env <- getSession fnk_env <- getFnkEnv traceSummary fnk_env "compileOtherFile" ["Compiling OtherSource:" <+> text path] #if MIN_VERSION_ghc(9,4,0) -- ghc 9.4, introduced StopPhase data type. Before that, Phase data type was -- directly used as stopping phase. let phase_to_stop = NoStop #else let phase_to_stop = StopLn #endif o_file0 <- liftIO (compileFile hsc_env phase_to_stop (path, Nothing)) #if MIN_VERSION_ghc(9,4,0) -- Resulting type of compileFile changed in ghc 9.4 from 'FilePath' to 'Maybe -- FilePath'. let o_file1 = maybe "" id o_file0 #else let o_file1 = o_file0 #endif return $! LdInput (FileOption "" o_file1) -- Note [Avoiding Recompilation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- See below for details of how GHC avoid recompilation: -- -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance -- -- To support recompiling the target module when the required modules were -- changed, checking the file paths of home package modules are stored as -- "UsageFile" in "mi_usages", via "hpm_src_files" field in "HsParsedModule" -- used when making "ModSummary" data. -- -- Currently, dependencies of required home package module are chased with plain -- file path, since the information of required module is stored as a plain file -- path, not as a module. This is to avoid compiling required modules as object -- code, because macro expansions are done with byte code interpreter. -- | Make 'ModSummary'. mkModSummary :: HscEnv -- ^ Current session. -> DynFlags -- ^ File local 'DynFlags'. -> FilePath -- ^ The source code path. -> HModule -- ^ Parsed module. -> [ModSummary] -- ^ List of required 'ModSummary' in home package. -> Fnk ModSummary mkModSummary hsc_env dflags file mdl reqs = do let mod_name = case hsmodName mdl of Just name -> unLoc name Nothing -> mkModuleName "Main" r_s_loc = mkSrcLoc (fsLit file) 1 1 r_s_span = mkSrcSpan r_s_loc r_s_loc -- XXX: PackageImports language extension not yet supported. See -- 'HscTypes.ms_home_imps' rn_idecl = reLoc . ideclName . unLoc imports0 = hsmodImports mdl #if MIN_VERSION_ghc(9,4,0) implicit_prelude = xopt ImplicitPrelude dflags imports1 = mkPrelImports mod_name r_s_span implicit_prelude imports0 imports2 = map (\lm -> (NoPkgQual, rn_idecl lm)) (imports1 ++ imports0) #else imports2 = map (\lm -> (Nothing, rn_idecl lm)) imports0 #endif -- Adding file path of the required modules and file paths of imported home -- package modules to "hpm_src_files" to support recompilation. req_srcs <- requiredDependencies reqs let pm = HsParsedModule { hpm_module = L r_s_span mdl , hpm_src_files = req_srcs #if !MIN_VERSION_ghc(9,2,0) -- The hpm_annotations field disappeared in ghc 9.2. , hpm_annotations = mkEmptyApiAnns #endif } mkModSummary' hsc_env dflags file mod_name [] imports2 (Just pm) Nothing False #if !MIN_VERSION_ghc(9,2,0) # if MIN_VERSION_ghc(9,0,0) mkEmptyApiAnns :: ApiAnns mkEmptyApiAnns = ApiAnns { apiAnnItems = Map.empty , apiAnnEofPos = Nothing , apiAnnComments = Map.empty , apiAnnRogueComments = [] } # else mkEmptyApiAnns :: (Map.Map a b, Map.Map c d) mkEmptyApiAnns = (Map.empty, Map.empty) # endif #endif -- | Make 'ModSummary' for recompilation check done with 'doCheckOldIface'. mkModSummaryForRecompile :: (HasLogger m, MonadIO m, MonadThrow m) => HscEnv -> TargetUnit -> m ModSummary mkModSummaryForRecompile hsc_env tu@(tsource, _) = do let path = targetSourcePath tsource mod_name = targetUnitName tu dflags1 <- case tsource of FnkSource {} -> parseFnkFileHeader hsc_env path _ -> return (hsc_dflags hsc_env) mkModSummary' hsc_env dflags1 path mod_name [] [] Nothing Nothing False -- | Make 'ModSummary' from source file, module name, and imports. mkModSummary' :: MonadIO m => HscEnv -> DynFlags -- Potentially file local DynFlags -> FilePath -> ModuleName -> [(PkgQual, Located ModuleName)] -> [(PkgQual, Located ModuleName)] -> Maybe HsParsedModule -> Maybe StringBuffer -> Bool -> m ModSummary mkModSummary' hsc_env dflags file mod_name srcimps txtimps mb_pm mb_buf _ghc_prim_import = do -- Throw an exception on module name mismatch. assertModuleNameMatch dflags file mb_pm let tryGetObjectDate path = if isObjectBackend dflags then modificationTimeIfExists path else return Nothing #if MIN_VERSION_ghc(9,4,0) let mkMLoc df mname path = pure (mkHomeModLocation (initFinderOpts df) mname path) addHomeMod henv = addHomeModuleToFinder (hsc_FC henv) (hsc_home_unit henv) #else let mkMLoc = mkHomeModLocation addHomeMod = addHomeModuleToFinder #endif liftIO (do mloc <- mkMLoc dflags mod_name file mmod <- addHomeMod hsc_env mod_name mloc obj_date <- tryGetObjectDate (ml_obj_file mloc) #if MIN_VERSION_ghc(9,4,0) src_hash <- getFileHash file dyn_obj_date <- modificationTimeIfExists (ml_dyn_obj_file mloc) #else hs_date <- getModificationUTCTime file #endif iface_date <- maybeGetIfaceDate dflags mloc hie_date <- modificationTimeIfExists (ml_hie_file mloc) return ModSummary { ms_mod = mmod , ms_hsc_src = HsSrcFile , ms_location = mloc #if MIN_VERSION_ghc(9,4,0) , ms_hs_hash = src_hash , ms_dyn_obj_date = dyn_obj_date , ms_ghc_prim_import = _ghc_prim_import #else , ms_hs_date = hs_date #endif , ms_obj_date = obj_date , ms_iface_date = iface_date , ms_hie_date = hie_date , ms_parsed_mod = mb_pm , ms_srcimps = srcimps , ms_textual_imps = txtimps , ms_hspp_file = file , ms_hspp_opts = dflags , ms_hspp_buf = mb_buf }) -- | Update timestamps of given 'ModSummary'. updateSummaryTimestamps :: MonadIO m => DynFlags -> Bool -> ModSummary -> m ModSummary updateSummaryTimestamps dflags obj_allowed ms = do -- Check timestamps, update the obj_data, iface_date, and hie_date to reflect -- the changes in file system from last compilation. See -- 'GhcMake.checkSummaryTimestamp' called during down sweep, which does -- similar works. let ms_loc = ms_location ms obj_date <- if isObjectBackend dflags || obj_allowed then liftIO (modificationTimeIfExists (ml_obj_file ms_loc)) else return Nothing iface_date <- liftIO (maybeGetIfaceDate dflags ms_loc) hie_date <- liftIO (modificationTimeIfExists (ml_hie_file ms_loc)) -- XXX: Fill in the list of required ModSummary. return (ms { ms_obj_date = obj_date , ms_iface_date = iface_date , ms_hie_date = hie_date }) -- See: "GhcMake.summariseModule" assertModuleNameMatch :: MonadIO m => DynFlags -> FilePath -> Maybe HsParsedModule -> m () assertModuleNameMatch dflags file mb_pm = case mb_pm of Just pm | Just lsaw <- hsmodName (unLoc (hpm_module pm)) , let wanted = asModuleName file , let saw = moduleNameString (unLoc lsaw) , saw /= "Main" , saw /= wanted -> let msg = text "File name does not match module" $$ text "Saw:" <+> quotes (text saw) $$ text "Expected:" <+> quotes (text wanted) loc = getLocA lsaw in throwOneError (mkPlainWrappedMsg dflags loc msg) _ -> return () -- See: GhcMake.maybeGetIfaceDate maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) maybeGetIfaceDate dflags location = if writeIface dflags then modificationTimeIfExists (ml_hi_file location) else return Nothing where #if MIN_VERSION_ghc(9,4,0) writeIface = const True #else writeIface = writeInterfaceOnlyMode #endif -- | Dump the Haskell source code of given 'ModSummary' if options in 'FnkEnv' -- are set. Will not dump when the 'ModSummary' was found in current home -- package table. dumpHsSourceCode :: (MonadIO m, HasDynFlags m) => FnkEnv -> HscEnv -> Maybe SPState -> ModSummary -> m () dumpHsSourceCode fnk_env hsc_env mb_sp ms = when (fopt Fnk_dump_hs fnk_env || isJust (envHsOutDir fnk_env)) $ case lookupHpt (hsc_HPT hsc_env) (ms_mod_name ms) of Nothing -> dumpModSummary fnk_env hsc_env mb_sp ms Just _ -> return () -- | Dump the module contents of given 'ModSummary'. dumpModSummary :: (MonadIO m, HasDynFlags m) => FnkEnv -> HscEnv -> Maybe SPState -> ModSummary -> m () dumpModSummary fnk_env hsc_env mb_sp ms = case mb_sp of Just sp | Just pm <- ms_parsed_mod ms -> work sp pm _ -> return () where work sp pm = do let hsrc = gen sp pm hdr = text (unwords [colons, orig_path, colons]) debugWhen fnk_env Fnk_dump_hs ["", hdr, "" , hsrc, ""] mapM_ (doWrite hsrc) (envHsOutDir fnk_env) doWrite hsrc dir = do let out_path = get_out_path dir out_dir = takeDirectory out_path traceSummary fnk_env "dumpModSummary" ["Writing to" <+> text out_path] let dflags = hsc_dflags hsc_env #if MIN_VERSION_ghc(9,6,0) unqual = icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) #elif MIN_VERSION_ghc(9,2,0) unqual = icPrintUnqual (hsc_unit_env hsc_env) (hsc_IC hsc_env) #else unqual = icPrintUnqual dflags (hsc_IC hsc_env) #endif #if MIN_VERSION_ghc(9,0,0) emit hdl = printForUser dflags hdl unqual AllTheWay hsrc #else emit hdl = printForUser dflags hdl unqual hsrc #endif liftIO (do createDirectoryIfMissing True out_dir withFile out_path WriteMode emit) get_out_path dir = let mname = moduleName (ms_mod ms) bname = takeBaseName orig_path file_name = if looksLikeModuleName bname then moduleNameSlashes mname else bname in dir file_name <.> "hs" gen sp pm = toHsSrc sp (Hsrc (unLoc (hpm_module pm))) orig_path = ms_hspp_file ms colons = replicate 20 ';' -- See: "hscParse'" in GHC.Driver.Main (or main/HscMain.hs in ghc < 9). dumpParsedAST :: MonadIO m => HscEnv -> DynFlags -> ModSummary -> m () dumpParsedAST _hsc_env dflags ms = liftIO (case ms_parsed_mod ms of Just pm -> do let rdr_module = hpm_module pm dumpIfSet_dyn_hs dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) dumpIfSet_dyn_hs dflags Opt_D_dump_parsed_ast "Parser AST" (show_ast_data NoBlankSrcSpan rdr_module) dumpIfSet_dyn_txt dflags Opt_D_source_stats "Source Statistic" (ppSourceStats False rdr_module) Nothing -> return ()) where #if MIN_VERSION_ghc(9,2,0) show_ast_data sp = showAstData sp NoBlankEpAnnotations #else show_ast_data = showAstData #endif #if MIN_VERSION_ghc(9,4,0) dumpIfSet_dyn_hs = putDumpFileMaybe_for FormatHaskell dumpIfSet_dyn_txt = putDumpFileMaybe_for FormatText putDumpFileMaybe_for format df flag label sdoc = let hsc_env = hscSetFlags df _hsc_env in putDumpFileMaybe (hsc_logger hsc_env) flag label format sdoc #elif MIN_VERSION_ghc(9,2,0) dumpIfSet_dyn_hs = dumpIfSet_dyn_with FormatHaskell dumpIfSet_dyn_txt = dumpIfSet_dyn_with FormatText dumpIfSet_dyn_with format df flag label sdoc = dumpIfSet_dyn (hsc_logger _hsc_env) df flag label format sdoc #elif MIN_VERSION_ghc(9,0,0) dumpIfSet_dyn_hs = dumpIfSet_dyn_with FormatHaskell dumpIfSet_dyn_txt = dumpIfSet_dyn_with FormatText dumpIfSet_dyn_with format df flag label sdoc = dumpIfSet_dyn df flag label format sdoc #else dumpIfSet_dyn_hs = dumpIfSet_dyn dumpIfSet_dyn_txt = dumpIfSet_dyn #endif -- Note [Chasing dependencies of required home package module] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- When home package module were required, recompilation happen when any of the -- required module was changed. -- -- The required modules lives in a dedicated HscEnv (the one stored at -- `envSessionForExpand' field in 'FnkEnv') which uses bytecode interpreter. -- Required modules are stored as 'UsageFile' in the 'mi_usages' field of -- 'ModIface', not as 'UsageHomeModule', because if stored as 'UsageHomeModule', -- required modules will compiled as object codes, which is not used by the -- macro expander at the moment. -- -- To chase dependencies of the required home package modules, the -- "requiredDependencies" functions temporary switch to the macro expansion -- session and recursively chases the file paths of imported modules and -- required modules. requiredDependencies :: [ModSummary] -> Fnk [FilePath] requiredDependencies mss = do hsc_env0 <- getSession let getDeps he = pure $! nub $! foldl' (requiredDependency he) [] mss if isExpanding (hsc_dflags hsc_env0) then getDeps hsc_env0 else do mb_hsc_env <- envSessionForExpand <$> getFnkEnv case mb_hsc_env of Just hsc_env -> getDeps hsc_env Nothing -> getDeps hsc_env0 requiredDependency :: HscEnv -> [FilePath] -> ModSummary -> [FilePath] requiredDependency hsc_env = go where go acc ms = case ml_hs_file (ms_location ms) of Nothing -> acc Just me -> dep_files (me : acc) ms dep_files acc ms = let mg = hsc_mod_graph hsc_env hpt = hsc_HPT hsc_env acc1 = find_require_paths hpt acc ms in foldl' (find_import_path mg) acc1 (msHomeAllimps ms) find_import_path mg acc mod_name = let mdl = mkModuleFromHscEnv hsc_env mod_name in maybe acc (go acc) (mgLookupModule' mg mdl) find_require_paths hpt acc ms = case lookupHpt hpt (ms_mod_name ms) of Nothing -> acc Just hmi -> foldl' req_paths acc (mi_usages (hm_iface hmi)) req_paths acc usage = case usage of -- Recursively calling `go' with the ModSummary referred by the usage -- file path, but only for Haskell and Finkel source codes. -- -- It is important to track only those "UsageFile"s of source code that -- potentially containing macro definitions. Otherwise the compilation -- time of modules containing ":require" of home package module was -- noticeably slow in ghc 9.4.2. UsageFile {usg_file_path = path_fs} | isFnkFile path || isHsFile path -> let mb_ms1 = find is_my_path mss is_my_path = (Just path ==) . ml_hs_file . ms_location mss = mgModSummaries' (hsc_mod_graph hsc_env) acc1 = path : acc in maybe acc1 (go acc1) mb_ms1 where path = unpackFSFor908 path_fs _ -> acc #if MIN_VERSION_ghc(9,8,0) unpackFSFor908 = unpackFS #else unpackFSFor908 = id #endif mkModuleFromHscEnv :: HscEnv -> ModuleName -> Module mkModuleFromHscEnv hsc_env = #if MIN_VERSION_ghc(9,2,0) mkHomeModule (hsc_home_unit hsc_env) #elif MIN_VERSION_ghc(9,0,0) mkModule (homeUnit (hsc_dflags hsc_env)) #else mkModule (thisPackage (hsc_dflags hsc_env)) #endif -- | Trace function for this module. traceSummary :: (MonadIO m, HasDynFlags m) => FnkEnv -> SDoc -> [SDoc] -> m () traceSummary fnk_env name msgs0 = let msgs1 = hcat [";;; [Language.Finkel.Make.Summary.", name, "]:"] : msgs0 in debugWhen fnk_env Fnk_trace_make msgs1 -- | Run given builder. buildHsSyn :: Builder a -- ^ Builder to use. -> [Code] -- ^ Input codes. -> Fnk a buildHsSyn bldr forms = do dflags <- getDynFlags qualify <- envQualifyQuotePrimitives <$> getFnkEnv case evalBuilder dflags qualify bldr forms of Right a -> return a Left (SyntaxError code msg) -> finkelSrcError code msg -- ------------------------------------------------------------------------ -- ModuleGraph -- ------------------------------------------------------------------------ extendMG' :: ModuleGraph -> ModSummary -> ModuleGraph {-# INLINABLE extendMG' #-} mgElemModule' :: ModuleGraph -> Module -> Bool {-# INLINABLE mgElemModule' #-} mkModuleGraph' :: [ModSummary] -> ModuleGraph {-# INLINABLE mkModuleGraph' #-} mgModSummaries' :: ModuleGraph -> [ModSummary] {-# INLINABLE mgModSummaries' #-} mgLookupModule' :: ModuleGraph -> Module -> Maybe ModSummary {-# INLINABLE mgLookupModule' #-} #if MIN_VERSION_ghc(9,4,0) extendMG' g ms = Graph.extendMG' g (ModuleNode [] ms) mgElemModule' mg m = moduleName m `elem` map ms_mod_name (mgModSummaries mg) mkModuleGraph' = mkModuleGraph . map (\ms -> ModuleNode [] ms) mgModSummaries' = mgModSummaries mgLookupModule' = mgLookupModule #elif MIN_VERSION_ghc(9,2,0) extendMG' g ms = extendMG g (extendModSummaryNoDeps ms) mgElemModule' = mgElemModule mkModuleGraph' = mkModuleGraph . map extendModSummaryNoDeps mgModSummaries' = mgModSummaries mgLookupModule' = mgLookupModule #else extendMG' = extendMG mgElemModule' = mgElemModule mkModuleGraph' = mkModuleGraph mgModSummaries' = mgModSummaries mgLookupModule' = mgLookupModule #endif -- The `ms_home_allimps' function did not exist until ghc 8.10.x, and removed in -- ghc 9.4.x. #if MIN_VERSION_ghc(9,4,0) -- XXX: Use 'GHC.Unit.Module.ModSummary.home_imps' ? msHomeAllimps :: ModSummary -> [ModuleName] msHomeAllimps = map (unLoc . snd) . ms_imps #else msHomeAllimps :: ModSummary -> [ModuleName] msHomeAllimps = ms_home_allimps #endif -- ------------------------------------------------------------------------ -- Header parser -- ------------------------------------------------------------------------ preprocess' :: HscEnv -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath) {-# INLINABLE preprocess' #-} preprocess' hsc_env (path, mb_phase) = do et_result <- preprocess hsc_env path Nothing mb_phase case et_result of # if MIN_VERSION_ghc(9,4,0) Left err -> throwErrors (fmap GhcDriverMessage err) # else Left err -> throwErrors err # endif Right pair -> return pair getImports' :: DynFlags -> StringBuffer -> FilePath -> FilePath -> IO ([(RawPkgQual, Located ModuleName)], [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName) {-# INLINABLE getImports' #-} #if MIN_VERSION_ghc(9,4,0) getImports' dflags sbuf pp_path path = do let imp_prelude = xopt ImplicitPrelude dflags popts = initParserOpts dflags et_ret <- getImports popts imp_prelude sbuf pp_path path either (throwErrors . fmap GhcPsMessage) pure et_ret #elif MIN_VERSION_ghc(9,2,0) getImports' dflags sbuf pp_path path = do let imp_prelude = xopt ImplicitPrelude dflags popts = initParserOpts dflags et_ret <- getImports popts imp_prelude sbuf pp_path path case et_ret of Right (simps, timps, lm) -> pure (simps, timps, False, lm) Left err -> throwErrors (fmap pprError err) #else getImports' dflags sbuf pp_path path = do et_ret <- getImports dflags sbuf pp_path path case et_ret of Right (simps, timps, lm) -> pure (simps, timps, False, lm) Left err -> throwErrors err #endif -- ------------------------------------------------------------------------ -- Timing -- ------------------------------------------------------------------------ -- | Label and wrap the given action with 'withTiming'. withTiming' :: String -> Fnk a -> Fnk a #if MIN_VERSION_ghc(9,2,0) withTiming' label = withTimingM (text label) (const ()) #else withTiming' label = withTimingD (text label) (const ()) #endif {-# INLINABLE withTiming' #-} -- | 'True' if the backend used by given 'DynFlags' produces object code. isObjectBackend :: DynFlags -> Bool #if MIN_VERSION_ghc(9,6,0) isObjectBackend = backendWritesFiles . backend #elif MIN_VERSION_ghc(9,2,0) isObjectBackend = backendProducesObject . backend #else isObjectBackend = isObjectTarget . hscTarget #endif {-# INLINEABLE isObjectBackend #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Make/TargetSource.hs ================================================ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} -- | Module for source code file path look up. module Language.Finkel.Make.TargetSource ( -- * Target unit TargetUnit , emptyTargetUnit , findTargetUnit , findTargetUnitMaybe , targetUnitName -- * Target source , TargetSource(..) , targetSourcePath -- * Finder functions , findTargetModuleName , findTargetModuleNameMaybe , findTargetSource , findTargetSourceMaybe , findTargetSourceWithPragma -- * File type related functions , asModuleName , isFnkFile , isHsFile , findPragmaString ) where #include "ghc_modules.h" -- base import Control.Applicative (Alternative (..)) import Control.Exception (SomeException, try) import Control.Monad.IO.Class (MonadIO (..)) import Data.Char (isUpper) import Data.List (isSubsequenceOf) -- directory import System.Directory (doesFileExist) -- filepath import System.FilePath (dropExtension, normalise, pathSeparator, replaceExtension, splitPath, takeExtension, (<.>), ()) -- ghc import GHC_Data_StringBuffer (StringBuffer, atEnd, hGetStringBuffer, nextChar) import GHC_Driver_Phases (Phase) import GHC_Driver_Session (DynFlags (..)) import GHC_Types_SourceError (throwOneError) import GHC_Types_SrcLoc (GenLocated (..), Located) import GHC_Unit_Module (ModuleName, mkModuleName, moduleNameSlashes, moduleNameString) import GHC_Utils_Misc (looksLikeModuleName) import GHC_Utils_Outputable (Outputable (..), sep, text) #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Session (augmentByWorkingDirectory) #endif -- Internal import Language.Finkel.Error -- --------------------------------------------------------------------- -- -- Target unit -- -- --------------------------------------------------------------------- -- | Unit for compilation target. -- -- Simply a 'TargetSource' paired with 'Maybe' 'Phase'. type TargetUnit = (TargetSource, Maybe Phase) -- | Make empty 'TargetUnit' from 'TargetSource' emptyTargetUnit :: TargetSource -> TargetUnit emptyTargetUnit ts = (ts, Nothing) -- | Get 'TargetUnit' from pair of module name or file path, and phase. findTargetUnit :: MonadIO m => DynFlags -> (Located String, Maybe Phase) -> m TargetUnit findTargetUnit dflags (lpath,mbp) = (,) <$> findTargetSource dflags lpath <*> pure mbp findTargetUnitMaybe :: MonadIO m => DynFlags -> (Located String, Maybe Phase) -> m (Maybe TargetUnit) findTargetUnitMaybe dflags (lpath,mbp) = fmap (, mbp) <$> findTargetSourceMaybe dflags lpath -- | Get 'ModuleName' from given 'TargetUnit'. targetUnitName :: TargetUnit -> ModuleName targetUnitName (ts, _) = case ts of FnkSource _ mn -> mn HsSource _ mn -> mn _ -> mkModuleName "module-name-unknown" -- --------------------------------------------------------------------- -- -- Target source -- -- --------------------------------------------------------------------- -- | Data type to represent target source. data TargetSource = FnkSource FilePath ModuleName -- ^ Finkel source with file path of the source code and module name. | HsSource FilePath ModuleName -- ^ Haskell source with file path of the source code and module name. | OtherSource FilePath -- ^ Other source with file path of other contents. instance Show TargetSource where show s = case s of FnkSource path _ -> "FnkSource " ++ show path HsSource path _ -> "HsSource " ++ show path OtherSource path -> "OtherSource " ++ show path instance Outputable TargetSource where ppr s = case s of FnkSource path mdl -> sep [text "FnkSource", text path, ppr mdl] HsSource path _ -> sep [text "HsSource", text path] OtherSource path -> sep [text "OtherSource", text path] -- | Get the file path of given 'TargetSource'. targetSourcePath :: TargetSource -> FilePath targetSourcePath mt = case mt of FnkSource path _ -> path HsSource path _ -> path OtherSource path -> path -- | True if given file has Finkel extension. isFnkFile :: FilePath -> Bool isFnkFile path = takeExtension path == ".fnk" -- | True if given file has Haskell extension. isHsFile :: FilePath -> Bool isHsFile path = takeExtension path `elem` [".hs", ".lhs"] -- | Construct module name from given 'String'. asModuleName :: String -> String asModuleName name = if looksLikeModuleName name then name else map sep_to_dot (concat names) where -- Taking the directory names from last to first, to support auto generated -- modules made by stack. names = reverse (takeWhile startsWithUpper (reverse (splitPath (dropExtension name)))) startsWithUpper cs = case cs of [] -> False c:_ -> isUpper c sep_to_dot c = if c == pathSeparator then '.' else c -- | Find source code file path by module name. -- -- Current approach for source code lookup is search for file with @*.fnk@ -- suffix first. Return it if found, otherwise search file with @*.hs@ suffix. -- -- This searching strategy can used when compiling cabal package containing -- mixed codes with '*.fnk' and '*.hs' suffixes. -- findFileInImportPaths :: MonadIO m => [FilePath] -- ^ Directories to look for. -> String -- ^ Module name or file name. -> m (Maybe FilePath) -- ^ File path of the module, if found. findFileInImportPaths dirs modName = do let suffix = takeExtension modName moduleFileName = moduleNameSlashes (mkModuleName modName) moduleFileName' = if suffix `elem` [".fnk", ".hs", ".c"] then modName else moduleFileName <.> "fnk" search mb_hs ds = case ds of [] -> return mb_hs d:ds' -> do -- Extension not yet sure for `aPath', so searching both '.fnk' and -- '.hs' files. let aPath = normalise (d moduleFileName') hsPath = replaceExtension aPath ".hs" exists <- liftIO (doesFileExist aPath) if exists then return (Just aPath) else do exists' <- liftIO (doesFileExist hsPath) if exists' then search (mb_hs <|> Just hsPath) ds' else search mb_hs ds' dirs' = if "." `elem` dirs then dirs else dirs ++ ["."] search Nothing dirs' -- | Like 'findTargetSource', but takes 'ModuleName' argument. findTargetModuleName :: MonadIO m => DynFlags -> Located ModuleName -> m TargetSource findTargetModuleName dflags = findTargetSource dflags . fmap moduleNameString -- | Like 'findTargetSourceMaybe', but takes 'ModuleName' argument. findTargetModuleNameMaybe :: MonadIO m => DynFlags -> Located ModuleName -> m (Maybe TargetSource) findTargetModuleNameMaybe dflags = findTargetSourceMaybe dflags . fmap moduleNameString -- | Like 'findTargetSource', but the result wrapped in 'Maybe'. findTargetSourceMaybe :: MonadIO m => DynFlags -> Located String -> m (Maybe TargetSource) findTargetSourceMaybe dflags modName = do et_ret <- liftIO (try (findTargetSource dflags modName)) case et_ret of Right found -> return (Just found) Left _err -> let _err' = _err :: SomeException in return Nothing -- | Find 'TargetSource' from command line argument. This function throws -- 'SourceError' when the target source was not found. findTargetSource :: MonadIO m => DynFlags -> Located String -> m TargetSource findTargetSource = findTargetSourceWithPragma ";;;" -- | Like 'findTargetSource', but with given pragma string. findTargetSourceWithPragma :: MonadIO m => String -> DynFlags -> Located String -> m TargetSource findTargetSourceWithPragma pragma dflags (L l modNameOrFilePath)= do let import_paths0 = importPaths dflags #if MIN_VERSION_ghc(9,4,0) -- See GHC.Unit.Finder.augmentImports which is not exported. import_paths1 = map (augmentByWorkingDirectory dflags) import_paths0 #else import_paths1 = import_paths0 #endif mb_inputPath <- findFileInImportPaths import_paths1 modNameOrFilePath let detectSource path | isFnkFile path = return (FnkSource path modName) | isHsFile path = do buf <- liftIO (hGetStringBuffer path) if findPragmaString pragma buf then return (FnkSource path modName) else return (HsSource path modName) | otherwise = return (OtherSource path) where modName = mkModuleName (asModuleName path) case mb_inputPath of Just path -> detectSource path Nothing -> let doc = text ("cannot find target source: " ++ modNameOrFilePath) in throwOneError (mkPlainWrappedMsg dflags l doc) -- ------------------------------------------------------------------------ -- -- Finkel buffer detection -- -- ------------------------------------------------------------------------ findPragmaString :: String -> StringBuffer -> Bool findPragmaString pragma buf = findInFirstNLines buf 3 (isSubsequenceOf pragma) {-# INLINABLE findPragmaString #-} findInFirstNLines :: StringBuffer -> Int -> (String -> Bool) -> Bool findInFirstNLines buf n test = go n buf where -- False when the source code contained less number of lines than -- the number specified by the argument. go i buf0 = not (i == 0 || atEnd buf0) && (case getStringBufferLine buf0 of (l, buf1) -> test l || go (i-1) buf1) {-# INLINABLE findInFirstNLines #-} getStringBufferLine :: StringBuffer -> (String, StringBuffer) getStringBufferLine = go [] where go !acc buf0 = let (c, buf1) = nextChar buf0 in if c == '\n' then (reverse acc, buf1) else go (c:acc) buf1 {-# INLINABLE getStringBufferLine #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Make/Trace.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Language.Finkel.Make.Trace ( traceMake , traceMake' , nvcOrNone ) where #include "ghc_modules.h" -- base import Control.Monad.IO.Class (MonadIO (..)) -- ghc import GHC_Driver_Session (DynFlags, HasDynFlags (..)) import GHC_Utils_Outputable (Outputable (..), SDoc, hcat, nest, vcat) -- Internal import Language.Finkel.Fnk (FnkDebugFlag (..), FnkEnv, debugWhen') -- | Trace function for 'make' related modules. traceMake :: (MonadIO m, HasDynFlags m) => FnkEnv -> SDoc -> [SDoc] -> m () traceMake fnk_env fn_name msgs0 = getDynFlags >>= \df -> traceMake' df fnk_env fn_name msgs0 -- | Like 'traceMake', but takes 'DynFlags' from argument. traceMake' :: MonadIO m => DynFlags -> FnkEnv -> SDoc -> [SDoc] -> m () traceMake' dflags fnk_env fn_name msgs0 = let msgs1 = (hcat [";;; [Language.Finkel.Make.", fn_name, "]:"] : msgs0) in debugWhen' dflags fnk_env Fnk_trace_make msgs1 -- | Nested 'vcat' or text @"none"@. nvcOrNone :: Outputable a => [a] -> SDoc nvcOrNone xs = nest 2 sdoc where sdoc = if null xs then "none" else vcat (map ppr xs) ================================================ FILE: finkel-kernel/src/Language/Finkel/Make.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | Make mode for Finkel compiler. module Language.Finkel.Make ( -- * Make functions make , makeFromRequire , makeFromRequirePlugin , simpleMake -- * Summary , fnkSourceToSummary -- * Session related functions , initSessionForMake , setContextModules , discardInteractiveContext -- * Macro expander session related functions , withExpanderSettings , clearGlobalSession , clearExpandedCodeCache -- * Syntax builder utility , buildHsSyn -- * Target unit utilities , TargetUnit , TargetSource(..) , findTargetModuleName , findTargetModuleNameMaybe , findTargetSource , findTargetSourceMaybe , asModuleName , isFnkFile , isHsFile -- * ParsedResult , mkParsedResult ) where #include "ghc_modules.h" -- base import Control.Monad (foldM, unless, void, (>=>)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Bifunctor (first) import Data.Foldable (find) #if MIN_VERSION_ghc(9,4,0) import Data.Maybe (catMaybes) -- Module GHC.Fingerprint is from package 'base'. import GHC.Fingerprint (getFileHash) #endif -- container #if MIN_VERSION_ghc(9,4,0) import qualified Data.Map as Map #endif -- filepath import System.FilePath (splitExtension) -- ghc import GHC (guessTarget, setSessionDynFlags, setTargets) import GHC_Driver_Env (HscEnv (..), runHsc) import GHC_Driver_Main (Messager) import GHC_Driver_Make (LoadHowMuch (..), load') import GHC_Driver_Monad (GhcMonad (..)) import GHC_Driver_Phases (Phase (..)) import GHC_Driver_Session (DynFlags (..), GeneralFlag (..), GhcMode (..), HasDynFlags (..), gopt, gopt_set, gopt_unset) import GHC_Hs_ImpExp (simpleImportDecl) import GHC_Plugins (Plugin (..), withPlugins) import GHC_Runtime_Context (InteractiveImport (..)) import GHC_Runtime_Eval (setContext) import GHC_Runtime_Loader (initializePlugins) import GHC_Types_Basic (SuccessFlag (..)) import GHC_Types_SourceError (throwOneError) import GHC_Types_SrcLoc (GenLocated (..), Located, getLoc, unLoc) import GHC_Unit_Finder (FindResult (..), findExposedPackageModule) import GHC_Unit_Module (ModuleName, mkModuleName) import GHC_Unit_Module_Graph (ModuleGraph) import GHC_Unit_Module_ModSummary (ModSummary (..), ms_mod_name) import GHC_Utils_Outputable (Outputable (..), SDoc, brackets, nest, text, vcat, (<+>)) #if MIN_VERSION_ghc(9,8,0) import GHC.Driver.Config.Diagnostic (initIfaceMessageOpts) import GHC.Iface.Errors.Ppr (missingInterfaceErrorDiagnostic) import GHC.Types.Error (mkUnknownDiagnostic) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Env (hscActiveUnitId, hscSetFlags, hsc_HUG, hsc_units) import GHC.Driver.Plugins (ParsedResult (..), PsMessages (..)) import GHC.Driver.Session (GhcLink (..)) import GHC.Hs (HsParsedModule) import GHC.Types.Error (emptyMessages) import GHC.Types.PkgQual (PkgQual (..)) import GHC.Unit.Env (homeUnitEnv_dflags, unitEnv_foldWithKey) import GHC.Unit.Module.Graph (ModNodeKeyWithUid (..), ModuleGraphNode (..), NodeKey (..), mkModuleGraph, mkNodeKey, moduleGraphNodeUnitId, msKey) import GHC.Unit.Module.ModSummary (ms_imps) import GHC.Unit.Types (GenWithIsBoot (..), IsBootInterface (..)) #else import GHC_Utils_Misc (getModificationUTCTime) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Session (ways) import GHC.Platform.Ways (Way (..), hasWay) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Iface.Load (cannotFindModule) #else import GHC_Unit_Finder (cannotFindModule) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Unit_Types (moduleUnit) #else import GHC_Unit_Module (Module (..), moduleUnitId) #endif import GHC_Driver_Make (depanal) import GHC_Types_Target (Target (..), TargetId (..)) -- internal import Language.Finkel.Error import Language.Finkel.Fnk import Language.Finkel.Make.Cache import Language.Finkel.Make.Recompile import Language.Finkel.Make.Session import Language.Finkel.Make.Summary import Language.Finkel.Make.TargetSource import Language.Finkel.Make.Trace -- --------------------------------------------------------------------- -- -- The make function -- -- --------------------------------------------------------------------- -- Note [Requiring home package module] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- The problem in dependency resolution when requiring home package module is, -- we need module imports list to make ModSummary, but modules imports could not -- be obtained unless the source code is macro expanded. However, -- macro-expansion may use macros from other home package modules, which are not -- loaded to GHC session yet. -- -- Currently, compilation is done with recursively calling 'make' function from -- 'require' macro, during macro-expansion. -- -- Once these dependency resolution works were tried with custom user hooks in -- cabal setup script. However, as of Cabal version 1.24.2, building part of -- some modules from contents of cabal configuration file were not so -- easy. Though when cabal support multiple libraraies, situation might change. -- | Finkel variant of @"ghc --make"@. make :: [(Located FilePath, Maybe Phase)] -- ^ List of pairs of input file and phase. -> Bool -- ^ Force recompilation when 'True'. -> Maybe FilePath -- ^ Output file, if any. -> Fnk SuccessFlag make infiles force_recomp mb_output = do -- Setting ghcMode as done in ghc's "Main.hs". -- -- Also setting the force recompilation field from the argument, since the -- current ghc may running in OneShot mode instead of CompManager mode until -- this point. Some of the dump flags will turn the force recompilation flag -- on. Ghc does this in DynFlags.{setDumpFlag',forceRecompile}. dflags0 <- getDynFlags let dflags1 = set_outputFile mb_output $ dflags0 {ghcMode = CompManager} dflags2 = if force_recomp then gopt_set dflags1 Opt_ForceRecomp else gopt_unset dflags1 Opt_ForceRecomp #if MIN_VERSION_ghc(9,2,0) set_outputFile f d = d { outputFile_ = f } #else set_outputFile f d = d { outputFile = f } #endif setDynFlags dflags2 dflags3 <- getDynFlags fnk_env <- getFnkEnv dumpDynFlags fnk_env "Language.Finkel.Make.make" dflags3 -- Decide the kind of sources of the inputs, inputs arguments could be file -- paths, or module names. targets <- mapM (findTargetUnit dflags3) infiles -- Do the compilation work. old_summaries <- fmap (mgModSummaries' . hsc_mod_graph) getSession make1 LoadAllTargets old_summaries targets -- | Calls 'GHC.setSessionDynFlags' and do some works to initialize session. initSessionForMake :: Fnk () initSessionForMake = do dflags0 <- getDynFlags -- Initializing the DynFlags for plugin at this point, to avoid repeated calls -- of "initializePlugins" before applying plugin action "parsedResultAction". -- The 'setSessionDynFlags' changes the current 'DynFlags', so getting the -- updated "DynFlags". Returned list of 'InstalledUnitId's are ignored. _preload0 <- setSessionDynFlags dflags0 hsc_env <- getSession #if MIN_VERSION_ghc(9,2,0) hsc_env1 <- liftIO $! initializePlugins hsc_env setSession hsc_env1 let dflags1 = hsc_dflags hsc_env1 #else let dflags0' = hsc_dflags hsc_env dflags1 <- liftIO $! initializePlugins hsc_env dflags0' #endif -- Mangle the function name in "mainFunIs" field, to support mangled name, -- e.g. to support "foo-bar-buzz" instead of "foo_bar_buzz". let mangle = map (\c -> if c == '-' then '_' else c) dflags2 = dflags1 { mainFunIs = fmap mangle (mainFunIs dflags1) } -- ... And setting and getting the DynFlags again. _preload1 <- setSessionDynFlags dflags2 dflags3 <- getDynFlags -- Load module names in FnkEnv to current interactive context. fnk_env <- getFnkEnv let ctx_modules = envContextModules fnk_env unless (null ctx_modules) (setContextModules ctx_modules) -- Verbosity level could be specified from environment variable and command -- line option. debug0 <- getFnkDebug let vrbs1 = envVerbosity fnk_env vrbs2 = if debug0 then max 3 vrbs1 else vrbs1 -- Updating the debug settings. Also setting the default 'DynFlag' at this -- point. putFnkEnv (fnk_env { envVerbosity = vrbs2 , envDefaultDynFlags = Just dflags3 }) -- | Set context modules in current session to given modules. setContextModules :: GhcMonad m => [String] -> m () setContextModules = setContext . map (IIDecl . simpleImportDecl . mkModuleName) {-# INLINABLE setContextModules #-} -- | Simple make function returning compiled home module information. Intended -- to be used in 'require' macro. makeFromRequire :: Located ModuleName -> Fnk SuccessFlag makeFromRequire lmname = do fnk_env <- getFnkEnv hsc_env <- getSession let old_summaries = mgModSummaries' (hsc_mod_graph hsc_env) tr = traceMake fnk_env "makeFromRequire" dflags = hsc_dflags hsc_env tr ["old summaries:", nvcOrNone old_summaries] tr ["required module:" <+> ppr (unLoc lmname)] tu <- emptyTargetUnit <$> findTargetModuleName dflags lmname success_flag <- withTmpDynFlags (setExpanding dflags) $ make1 LoadAllTargets old_summaries [tu] mgraph <- hsc_mod_graph <$> getSession let mod_summaries = mgModSummaries' mgraph tr ["summaries:", nvcOrNone mod_summaries] pure success_flag -- An adhoc CPP macro for 'Maybe UnitId' argument of 'guessTarget'. #if MIN_VERSION_ghc(9,4,0) #define MAYBE_UNITID Nothing #else #define MAYBE_UNITID {- nothing -} #endif -- | Simple function to perform module dependency analysis and loading. simpleMake :: [(Located FilePath, Maybe Phase)] -> Bool -> Maybe FilePath -> Fnk SuccessFlag simpleMake infiles _force_recomp _mb_output = do -- See: function 'doMake' in "ghc/Main.hs". let guess_target (L _ modname_or_path, mb_phase) = guessTarget modname_or_path MAYBE_UNITID mb_phase new_targets <- mapM guess_target infiles setTargets new_targets msgr <- envMessager <$> getFnkEnv mg <- depanal [] False doLoad LoadAllTargets (Just msgr) mg -- | Make function used when the Finkel compiler was invoked as a ghc plugin. makeFromRequirePlugin :: Located ModuleName -> Fnk SuccessFlag makeFromRequirePlugin lmname = do fnk_env <- getFnkEnv hsc_env <- getSession let mname = unLoc lmname dflags = hsc_dflags hsc_env -- XXX: Not sure when the target can use object code. Add some tests for -- combination of "-fno-code" and newly added options, -- Opt_ByteCodeAndObjectCode, and Opt_WriteIfSimplifiedCore. -- -- XXX: Under certain condition in ghc 9.6, it is possible to allow object -- codes when the backend does not write files (for -fno-code -- option). Though at the moment, the backend at this point is always set -- to interpreter. Find out a way to get the backend of the original -- DynFlags, at this point, the backend of `dflags' is always set to -- interpreter. See 'Language.Finkel.Expand.newHscEnvForExpand'. -- -- XXX: Find out a way to support compiling with "-fno-code" option in ghc -- 9.6, which is used when generating documentations with haddock. -- -- allow_obj_code = -- case envDefaultDynFlags fnk_env of -- Just df -> not (backendWritesFiles (backend df)) || -- ways df `hasWay` WayDyn || gopt Opt_BuildDynamicToo df -- Nothing -> False -- -- XXX: In ghc 9.4, see 'GHC.Driver.Pipeline.compileOne'', when the -- targetAllowObjCode is set to False, Opt_ForceRecomp of the local -- dynflags is always turned on. When the GHCi is built to prefer dynamic -- object, and when dynamic object of home package module did not exist, -- interpreter may try to load non-dynamic object and shows an error -- during macro expansion. -- -- For ghc >= 9.2, allowing object code when current compilation contains -- "-dynamic" or "-dynamic-too". #if MIN_VERSION_ghc(9,2,0) allow_obj_code = case envDefaultDynFlags fnk_env of Just df -> ways df `hasWay` WayDyn || gopt Opt_BuildDynamicToo df Nothing -> False #else allow_obj_code = False #endif target = Target { targetId = TargetModule mname , targetAllowObjCode = allow_obj_code #if MIN_VERSION_ghc(9,4,0) , targetUnitId = hscActiveUnitId hsc_env #endif , targetContents = Nothing } old_targets = hsc_targets hsc_env messager = envMessager fnk_env tr = traceMake fnk_env "makeFromRequirePlugin" new_targets = target : old_targets hsc_env_new = hsc_env {hsc_targets = new_targets} #if MIN_VERSION_ghc(9,2,0) let extra_dump = case envDefaultDynFlags fnk_env of Just default_dflags -> [ "ways:" <+> text (show (ways dflags)) , "ways (fnk):" <+> text (show (ways default_dflags)) , "backend:" <+> text (show (backend dflags)) , "backend (fnk):" <+> text (show (backend default_dflags)) ] Nothing -> [] #else let extra_dump = [] #endif tr ([ "target:" <+> ppr target , "old_targets:" <+> nvcOrNone old_targets , "new_targets:" <+> nvcOrNone new_targets , "allowObjCode:" <+> text (show (allow_obj_code)) ] <> extra_dump) setSession hsc_env_new -- XXX: Using hardcoded additional import paths `src' -- -- For haskell-language-server to work with finkel-core library and -- finkel-tool library. However, tests in the packages need to take "test" -- directory instead of "src", the directory name is specified by the -- 'hs-source-dirs' in the cabal configuration file. But, currently not sure -- how to get the value of 'hs-source-dirs'. -- -- Also, when "src" is added, compiling the tests in finkel-core and -- finkel-tool will fail, because these tests will search files under src -- instead of importing from its internal library. -- let adjust_dynflags df = -- (setExpanding df) {importPaths = "src" : importPaths df} let adjust_dynflags = setExpanding dumpHscEnv fnk_env "makeFromRequirePlugin (before load):" hsc_env_new success_flag <- withTmpDynFlags (adjust_dynflags dflags) $ do tmp_dflags <- fmap hsc_dflags getSession dumpDynFlags fnk_env "makeFromRequirePlugin (withTmpDynFlags)" tmp_dflags mg <- depanal [] False doLoad LoadAllTargets (Just messager) mg hsc_env_after <- getSession dumpHscEnv fnk_env "makeFromRequirePlugin (after load):" hsc_env_after tr ["isExpanding:" <+> ppr (isExpanding (hsc_dflags hsc_env_after))] pure success_flag -- | Make new 'TargetSummary' from given 'TargetUnit'. fnkSourceToSummary :: TargetSource -> Fnk TargetSummary fnkSourceToSummary ts = do fnk_env <- getFnkEnv hsc_env <- getSession let tu = emptyTargetUnit ts fst <$> unMakeM (makeNewSummary fnk_env hsc_env tu) emptyMkSt -- --------------------------------------------------------------------- -- -- Internal of make -- -- --------------------------------------------------------------------- -- | Compile 'TargetUnit' to interface file and object code. -- -- This function does macro expansion, convert 'TargetUnit' to 'ModSummary', and -- pass the results to 'GhcMake.load''. -- make1 :: LoadHowMuch -> [ModSummary] -> [TargetUnit] -> Fnk SuccessFlag make1 how_much old_summaries targets = do fnk_env <- getFnkEnv let tr = traceMake fnk_env "make1" targets_sdoc = nest 2 (vcat (map ppr targets)) total = length targets tr [ "total:" <+> text (show total) , "targets:", targets_sdoc , "old summaries:", nvcOrNone old_summaries] hsc_env <- getSession (mss0, options) <- summariseTargets hsc_env old_summaries targets unless (null options) (updateFlagOptions options) -- Make new ModuleGrpah from expanded summaries, then update the old mod -- summaries if the summaries were missing. #if MIN_VERSION_ghc(9,4,0) let updateMG ms acc = if any (\old -> ms_mod_name old == ms_mod_name ms) acc then acc else ms : acc mnodes0 = foldr updateMG mss0 old_summaries -- Additionally, fill in the NodeKeys for topological sort, and link node -- to support compiling executable. mnodes1 = fillInNodeKeys mnodes0 mnodes2 = addLinkNodesIfAny hsc_env mnodes1 mgraph0 = mkModuleGraph mnodes2 #else let updateMG ms mg = if mgElemModule' mg (ms_mod ms) then mg else extendMG' mg ms mgraph0 = foldr updateMG (mkModuleGraph' mss0) old_summaries #endif tr ["new summaries:", nvcOrNone (mgModSummaries' mgraph0)] -- Pass the merged ModuleGraph to the "load'" function, delegate the hard -- works to it. success_flag <- doLoad how_much (Just (envMessager fnk_env)) mgraph0 tr ["done:", targets_sdoc] return success_flag updateFlagOptions :: [Option] -> Fnk () updateFlagOptions options = do hsc_env <- getSession let dflags0 = hsc_dflags hsc_env dflags1 = dflags0 {ldInputs = options ++ ldInputs dflags0} void (setSessionDynFlags dflags1) #if MIN_VERSION_ghc(9,4,0) -- See: local functions 'loopSummaries' and 'loopImports' in 'downsweep' in -- GHC.Driver.Make. fillInNodeKeys :: [ModSummary] -> [ModuleGraphNode] fillInNodeKeys mss = let home_mod_map :: Map.Map ModuleName NodeKey home_mod_map = Map.fromList [ (ms_mod_name ms, NodeKey_Module (msKey ms)) | ms <- mss ] get_node_key (_, L _ mname) = Map.lookup mname home_mod_map get_node_keys ms = catMaybes (map get_node_key (ms_imps ms)) convert ms = ModuleNode (get_node_keys ms) ms in map convert mss -- See: 'linkNodes' in GHC.Driver.Make. addLinkNodesIfAny :: HscEnv -> [ModuleGraphNode] -> [ModuleGraphNode] addLinkNodesIfAny hsc_env mg0 = unitEnv_foldWithKey f mg0 hug where hug = hsc_HUG hsc_env f nodes uid hue = maybe id (:) (linkOne mg0 uid hue) nodes linkOne mg uid hue = let dflags = homeUnitEnv_dflags hue pre_nodes = filter ((== uid) . moduleGraphNodeUnitId) mg unit_nodes = map mkNodeKey pre_nodes no_hs_main = gopt Opt_NoHsMain dflags gwib = GWIB (mainModuleNameIs dflags) NotBoot isMainModule = (== NodeKey_Module (ModNodeKeyWithUid gwib uid)) main_sum = any isMainModule unit_nodes do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib in if ghcLink dflags /= NoLink && do_linking then Just (LinkNode unit_nodes uid) else Nothing #endif -- ------------------------------------------------------------------------ -- -- For summarising TargetUnit -- -- ------------------------------------------------------------------------ -- See 'GhcMake.{summariseModule,summariseFile}'. -- -- Seems like 'addDependentFile' method used by Template Haskell is not working -- well in GHCi (as of ghc 8.8), see: -- -- https://gitlab.haskell.org/ghc/ghc/-/issues/18330 -- | Newtype to summaries list of 'TargetUnit'. newtype MakeM a = MakeM {unMakeM :: MkSt -> Fnk (a, MkSt)} instance Functor MakeM where fmap f (MakeM k) = MakeM (fmap (first f) . k) {-# INLINE fmap #-} instance Applicative MakeM where pure a = MakeM (\st -> pure (a, st)) {-# INLINE pure #-} f <*> m = f >>= flip fmap m {-# INLINE (<*>) #-} instance Monad MakeM where MakeM m >>= k = MakeM (m >=> \(a,s) -> unMakeM (k a) s) {-# INLINE (>>=) #-} instance MonadIO MakeM where liftIO io = MakeM (\s -> liftIO io >>= \a -> pure (a, s)) {-# INLINE liftIO #-} -- | State for 'MakeM'. data MkSt = MkSt { -- | Resulting list of 'ModSummary'. mks_summarised :: ![ModSummary] -- | Resulting list of 'Option'. , mks_flag_options :: ![Option] -- | List of 'TargetUnit' to compile. , mks_to_summarise :: ![TargetUnit] -- | Old ModSummary from last run, if any. , mks_old_summaries :: ![ModSummary] } emptyMkSt :: MkSt emptyMkSt = MkSt { mks_summarised = [] , mks_flag_options = [] , mks_to_summarise = [] , mks_old_summaries = [] } getMkSt :: MakeM MkSt getMkSt = MakeM (\s -> pure (s,s)) {-# INLINABLE getMkSt #-} putMkSt :: MkSt -> MakeM () putMkSt s = MakeM (\_ -> pure ((),s)) {-# INLINABLE putMkSt #-} toMakeM :: Fnk a -> MakeM a toMakeM fnk = MakeM (\st -> fnk >>= \a -> pure (a,st)) {-# INLINABLE toMakeM #-} -- | Make a list of 'ModSummary' and 'Option' from the given 'TargetUnit's. -- -- Purpose is similar to the 'downsweep' function, but does less work (e.g., -- does not detect circular module dependencies). summariseTargets :: HscEnv -- ^ Current session. -> [ModSummary] -- ^ List of old 'ModSummary'. -> [TargetUnit] -- ^ List of 'TargetUnit' to compile. -> Fnk ([ModSummary], [Option]) -- ^ A pair of list of 'ModSummary' and list of file option. summariseTargets hsc_env old_summaries tus_to_summarise = withTiming' "summariseTargets [Finkel]" $ do fnk_env <- getFnkEnv let mks0 = emptyMkSt { mks_to_summarise = tus_to_summarise , mks_old_summaries = old_summaries } rs0 = emptyRecompState hsc_env (_, mks1) <- unMakeM (summariseAll fnk_env hsc_env rs0) mks0 return (mks_summarised mks1, reverse (mks_flag_options mks1)) -- | 'MakeM' action to summarise all 'TargetUnit's. summariseAll :: FnkEnv -> HscEnv -> RecompState -> MakeM RecompState summariseAll fnk_env hsc_env = go where -- When compiling object codes, macro expander will update HomePackageTable -- to check old interface read from file. Recursively passing the -- RecompState to use the updated HomePackageTable. go rs = do s0 <- getMkSt case mks_to_summarise s0 of [] -> return rs t:ts -> do putMkSt (s0 {mks_to_summarise = ts}) summariseOne fnk_env hsc_env t rs >>= go -- | Summarise one 'TargetUnit'. summariseOne :: FnkEnv -> HscEnv -> TargetUnit -> RecompState -> MakeM RecompState summariseOne fnk_env hsc_env tu rs0 = do mks@MkSt{ mks_summarised = summarised , mks_flag_options = flag_options , mks_to_summarise = to_summarise } <- getMkSt let summarised_names = map ms_mod_name summarised names_to_summarise = map targetUnitName to_summarise reqs_not_in_mss = filter (\r -> ms_mod_name r `notElem` summarised_names) not_yet_ready ms = foldr (\(_, lmn) acc -> if unLoc lmn `elem` names_to_summarise || unLoc lmn `elem` summarised_names then acc else lmn:acc) [] (ms_textual_imps ms) -- Skip the expansion when earlier modules already saw this TargetUnit. if targetUnitName tu `elem` summarised_names then return rs0 else do (tsum, rs1) <- makeTargetSummary fnk_env rs0 tu case tsum of -- Linker option, not a module. LdInput fo -> putMkSt (mks {mks_flag_options=fo:flag_options}) -- Expanded to ModSummary, add imported home modules if not added yet. -- Adding the required ModSummary to the accumulator when using -- interpreter, since it could be reused. EMS ms _ reqs -> do not_compiled <- filterNotCompiled fnk_env hsc_env (not_yet_ready ms) putMkSt (mks { mks_summarised = if isInterpreted (hsc_dflags hsc_env) then ms:reqs_not_in_mss reqs ++ summarised else ms:summarised , mks_to_summarise = not_compiled ++ to_summarise }) return rs1 -- | Returns 'Just' pair of compiled 'ModSummary' and the required home package -- module 'ModSummary' for 'FnkSource' and 'HsSource', or 'Nothing' for -- 'OtherSource'. makeTargetSummary :: FnkEnv -> RecompState -> TargetUnit -> MakeM (TargetSummary, RecompState) makeTargetSummary fnk_env rs0 tu@(tsource,_) = do -- To maximize recompilation avoidance when compiling object codes, seems like -- it is required to first scan all the home package interfaces on file system -- to mark outdated "ModSummary"s, and then do the expansion to avoid parsing -- the source codes. -- -- Perhaps the "checkOldIface" function is designed to work with topologically -- sorted list of "ModSummary", not to be called during macro expansion of -- Finkel module source code. 'MkIface.getFromModIface' is calling -- 'loadInterface', which is adding empty interface to PIT when loading non -- hi-boot interface for home package module. To avoid loading dummy -- interfaces, recompilation checks done in "RecompM" is reading interfaces -- and updating HPT before invoking 'checkOldIface'. old_summaries <- mks_old_summaries <$> getMkSt let tr = traceMake' dflags fnk_env "makeTargetSummary" hsc_env = rs_hsc_env rs0 dflags = hsc_dflags hsc_env this_mod_name = targetUnitName tu by_mod_name = (== this_mod_name) . ms_mod_name update_summary obj_allowed rs ms0 = do ms1 <- updateSummaryTimestamps dflags obj_allowed ms0 return (plainEMS ms1, rs) new_summary rs why = do tr ["Making new summary for" <+> ppr this_mod_name <+> brackets why] tsum <- makeNewSummary fnk_env hsc_env tu return (tsum, rs) -- XXX: In below, `obj_allowed' argument is constantly 'False' at the -- moment, it will be nice to pass this arg from REPL. reuse_summary rs ms0 = do tr ["Reusing old summary for" <+> ppr this_mod_name] update_summary False rs ms0 reuse_iface rs ms0 = do tr ["Reusing iface file for" <+> ppr this_mod_name] update_summary True rs ms0 if gopt Opt_ForceRecomp dflags then new_summary rs0 "force recomp" else case find by_mod_name old_summaries of -- Old summaries did not contain this module, checking whether the -- interface file and object code file are reusable when compiling to -- object code. Nothing -> if not (isObjectBackend dflags) then new_summary rs0 "non object target" else do (et_ms, rs1) <- runRecompilationCheck fnk_env rs0 tu case et_ms of Left why -> new_summary rs1 why Right ms -> reuse_iface rs1 ms -- Checking whether recompilation is required or not at this point, since -- when reompiling, may need to parse the source code to reflect the -- changes in macros from home package modules. Just ms -> do file_modified <- liftIO (isFileModified ms (targetSourcePath tsource)) if file_modified then new_summary rs0 "source code is new" else do summary_ok <- checkModSummary hsc_env ms if not summary_ok then new_summary rs0 "out of date usages" else reuse_summary rs0 ms isFileModified :: ModSummary -> FilePath -> IO Bool #if MIN_VERSION_ghc(9,4,0) isFileModified ms = fmap (/= ms_hs_hash ms) . getFileHash #else isFileModified ms = fmap (ms_hs_date ms <) . getModificationUTCTime #endif -- | Make new 'TargetSummary'. makeNewSummary :: FnkEnv -> HscEnv -> TargetUnit -> MakeM TargetSummary makeNewSummary fnk_env hsc_env tu = toMakeM $ do tsum <- summariseTargetUnit tu case tsum of LdInput _option -> return tsum EMS ms0 mb_sp reqs -> do dumpDynFlags fnk_env "makeNewSummary" (ms_hspp_opts ms0) -- Since the entire compilation work does not use DriverPipeline, -- setting the dumpPrefix at this point. setDumpPrefix (ms_hspp_file ms0) -- XXX: The dumpParsedAST is evaluated in 'compileFnkFile', which is -- before setting the dump prefix, is this fine? -- To support parsedResultAction in plugin. See "HscMain.hscParse'" ms1 <- case ms_parsed_mod ms0 of Nothing -> return ms0 Just pm -> do let do_action p opts = parsedResultAction p opts ms0 dflags0 = hsc_dflags hsc_env dflags1 = adjustIncludePaths dflags0 ms0 hsc_env' = hsc_env {hsc_dflags = dflags1} #if MIN_VERSION_ghc(9,4,0) plugins = hsc_plugins (hscSetFlags dflags1 hsc_env) act = parsedResultModule <$> withPlugins plugins do_action (mkParsedResult pm) #elif MIN_VERSION_ghc(9,2,0) act = withPlugins (hsc_env {hsc_dflags=dflags1}) do_action pm #else act = withPlugins dflags1 do_action pm #endif parsed_mod <- liftIO (runHsc hsc_env' act) return $! ms0 {ms_parsed_mod = Just parsed_mod} return $! EMS ms1 mb_sp reqs #if MIN_VERSION_ghc(9,4,0) -- XXX: Always using empty messages mkParsedResult :: HsParsedModule -> ParsedResult mkParsedResult pm = let msgs = PsMessages { psWarnings = emptyMessages , psErrors = emptyMessages } in ParsedResult { parsedResultModule = pm , parsedResultMessages = msgs } #else mkParsedResult :: a -> a mkParsedResult = id #endif {-# INLINABLE mkParsedResult #-} -- | Set 'dumpPrefix' from file path. setDumpPrefix :: GhcMonad m => FilePath -> m () setDumpPrefix path = do dflags0 <- getDynFlags let (basename, _suffix) = splitExtension path #if MIN_VERSION_ghc(9,4,0) dflags1 = dflags0 {dumpPrefix = basename ++ "."} #else dflags1 = dflags0 {dumpPrefix = Just (basename ++ ".")} #endif setDynFlags dflags1 {-# INLINABLE setDumpPrefix #-} -- | Run the recompilation check. runRecompilationCheck :: FnkEnv -> RecompState -> TargetUnit -> MakeM (Either SDoc ModSummary, RecompState) runRecompilationCheck fnk_env rs tu = toMakeM (unRecompM (checkRecompileRequired fnk_env tu) rs) {-# INLINABLE runRecompilationCheck #-} -- | Return a list of 'TargetUnit' to compile for given 'ModuleName's. filterNotCompiled :: MonadIO m => FnkEnv -> HscEnv -> [Located ModuleName] -> m [TargetUnit] filterNotCompiled fnk_env hsc_env = foldM find_not_compiled [] where dflags = hsc_dflags hsc_env tr = traceMake' dflags fnk_env "filterNotCompiled" find_not_compiled acc lmname = do let mname = unLoc lmname mb_ts <- findTargetModuleNameMaybe dflags lmname case mb_ts of Just ts -> do tr ["Found" <+> ppr mname <+> "at" <+> text (targetSourcePath ts)] return $! (emptyTargetUnit ts : acc) Nothing -> do #if MIN_VERSION_ghc(9,4,0) let fc = hsc_FC hsc_env units = hsc_units hsc_env fopts = initFinderOpts dflags fr <- liftIO (findExposedPackageModule fc fopts units mname NoPkgQual) #else fr <- liftIO (findExposedPackageModule hsc_env mname Nothing) #endif case fr of Found _ mdl -> do #if MIN_VERSION_ghc(9,0,0) let mod_unit = moduleUnit mdl #else let mod_unit = moduleUnitId mdl #endif tr ["Found" <+> ppr mname <+> "in" <+> ppr mod_unit] return acc _ -> do let err = mkPlainWrappedMsg dflags (getLoc lmname) doc #if MIN_VERSION_ghc(9,8,0) doc = missingInterfaceErrorDiagnostic opts body opts = initIfaceMessageOpts dflags body = cannotFindModule hsc_env mname fr #elif MIN_VERSION_ghc(9,2,0) doc = cannotFindModule hsc_env mname fr #else doc = cannotFindModule dflags mname fr #endif throwOneError err -- From ghc 9.4, the `load'' function takes ModIface cache. -- -- From ghc 9.8, the `load'' function takes (GhcMessage -> AnyGhcDiagnostic) -- function. doLoad :: LoadHowMuch -> Maybe Messager -> ModuleGraph -> Fnk SuccessFlag #if MIN_VERSION_ghc(9,4,0) doLoad lhm mb_msgr mg = do dflags <- getDynFlags fnk_env <- getFnkEnv -- ModIfaceCache is used by interpreter only. let mb_hmi_cache = if isInterpreted dflags then envInterpModIfaceCache fnk_env else Nothing # if MIN_VERSION_ghc(9,8,0) load' mb_hmi_cache lhm mkUnknownDiagnostic mb_msgr mg # else load' mb_hmi_cache lhm mb_msgr mg # endif #else doLoad = load' #endif ================================================ FILE: finkel-kernel/src/Language/Finkel/Options.hs ================================================ -- | Codes for command line options. module Language.Finkel.Options ( -- * Plugin options FnkPluginOptions(..) , defaultFnkPluginOptions , fnkPluginOptions , fpoPragma , fpoIgnore , printPluginUsage -- * Fnk source options , FnkSrcOptions (..) , defaultFnkSrcOptions , fromFnkSrcOptions -- * FnkEnv options , fnkEnvOptions , fnkEnvOptionsWithLib , partitionFnkEnvOptions , fromFnkEnvOptions , fnkEnvOptionsUsage ) where -- base import Data.Char (toLower) import Data.List (isPrefixOf, partition) import System.Console.GetOpt (ArgDescr (..), OptDescr (..), usageInfo) import System.Environment (getProgName) -- Internal import Language.Finkel.Exception import Language.Finkel.Fnk -- ------------------------------------------------------------------------ -- -- Options for plugin -- -- ------------------------------------------------------------------------ data FnkPluginOptions = FnkPluginOptions { fpoHelp :: Bool , fpoSrcOptions :: FnkSrcOptions , fpoFnkEnv :: FnkEnv } defaultFnkPluginOptions :: FnkEnv -> FnkPluginOptions defaultFnkPluginOptions fnk_env = FnkPluginOptions { fpoHelp = False , fpoSrcOptions = defaultFnkSrcOptions , fpoFnkEnv = fnk_env } fpoPragma :: FnkPluginOptions -> String fpoPragma = fsrcPragma . fpoSrcOptions fpoIgnore :: FnkPluginOptions -> Bool fpoIgnore = fsrcIgnore . fpoSrcOptions fnkPluginOptions :: [OptDescr (FnkPluginOptions -> FnkPluginOptions)] fnkPluginOptions = help : sopts ++ eopts where help = Option [] ["help"] (NoArg (\o -> o {fpoHelp = True})) "Show this help and exit." eopts = adjustFnkEnvOptions (fromFnkEnvOptions wenv) wenv f o = o {fpoFnkEnv = f (fpoFnkEnv o)} sopts = fromFnkSrcOptions wsrc wsrc f o = o {fpoSrcOptions = f (fpoSrcOptions o)} adjustFnkEnvOptions :: [OptDescr a] -> [OptDescr a] adjustFnkEnvOptions = foldr f [] where f opt@(Option so lo ad descr) acc = if is_removed_option opt then acc else Option so (map dropFnk lo) ad descr : acc dropFnk = drop (length "fnk-") is_removed_option (Option so _ _ _) = so == ['B'] printPluginUsage :: String -> IO () printPluginUsage mod_name = do prog <- getProgName let fplugin_opt = "-fplugin-opt=" ++ mod_name ++ ":OPTION" header = unlines [ "USAGE:" , "" , " " ++ prog ++ " ... [" ++ fplugin_opt ++ "]" , "" , "OPTIONS:" ] putStrLn (usageInfo header fnkPluginOptions) -- ------------------------------------------------------------------------ -- -- Options for finkel source code -- -- ------------------------------------------------------------------------ data FnkSrcOptions = FnkSrcOptions { fsrcPragma :: !String -- ^ String to be searched at the beginning section of a file to detect -- Finkel source code. , fsrcIgnore :: !Bool -- ^ Flag for ignoring the given file. } defaultFnkSrcOptions :: FnkSrcOptions defaultFnkSrcOptions = FnkSrcOptions { fsrcPragma = ";;;" , fsrcIgnore = False } fnkSrcOptions :: [OptDescr (FnkSrcOptions -> FnkSrcOptions)] fnkSrcOptions = [ Option [] ["pragma"] (ReqArg (\i o -> o {fsrcPragma = i}) "STR") (unlines [ "Searched string to detect Finkel source file." , "(default: " ++ fsrcPragma defaultFnkSrcOptions ++ ")" ]) , Option [] ["ignore"] (NoArg (\o -> o {fsrcIgnore = True})) "Ignore this file." ] fromFnkSrcOptions :: ((FnkSrcOptions -> FnkSrcOptions) -> a) -> [OptDescr a] fromFnkSrcOptions f = map (fmap f) fnkSrcOptions -- --------------------------------------------------------------------- -- -- FnkEnv options -- -- --------------------------------------------------------------------- -- | Separate Finkel debug options from others. partitionFnkEnvOptions :: [String] -- ^ Flag inputs, perhaps given as command line arguments. -> ([String], [String]) -- ^ Pair of @(finkel_flags, other_flags)@. partitionFnkEnvOptions = partition test where -- The "-B" option is to update the ghc libdir in FnkEnv. test arg = "--fnk-" `isPrefixOf` arg || "-B" `isPrefixOf` arg -- | Command line option handlers to update 'FnkDumpFlag' in 'FnkEnv'. fnkEnvOptions :: [OptDescr (FnkEnv -> FnkEnv)] fnkEnvOptions = [ opt ["fnk-verbose"] (ReqArg (\i o -> o {envVerbosity = parseVerbosity i}) "INT") "Set verbosity level to INT." , opt ["fnk-hsdir"] (ReqArg (\path o -> o {envHsOutDir = Just path}) "DIR") "Set Haskell code output directory to DIR." -- Dump and trace options , debug_opt Fnk_dump_dflags "Dump DynFlags settings." , debug_opt Fnk_dump_expand "Dump expanded code." , debug_opt Fnk_dump_hs "Dump Haskell source code." , debug_opt Fnk_dump_session "Dump session information." , debug_opt Fnk_trace_expand "Trace macro expansion." , debug_opt Fnk_trace_session "Trace session env." , debug_opt Fnk_trace_make "Trace make function." , debug_opt Fnk_trace_spf "Trace builtin special forms." ] where opt = Option [] debug_opt flag = opt [to_str flag] (NoArg (foptSet flag)) to_str = map replace . show replace '_' = '-' replace c = toLower c parseVerbosity = readOrFinkelException "INT" "verbosity" -- | Options for @FnkEnv@ with an option to set ghc @libdir@. fnkEnvOptionsWithLib :: [OptDescr (FnkEnv -> FnkEnv)] fnkEnvOptionsWithLib = lib_option : fnkEnvOptions where lib_option = Option ['B'] [] (ReqArg (\path o -> o {envLibDir = Just path}) "DIR") "Set ghc library directory to DIR." -- | Convert 'fnkEnvOptions' to list of 'OptDescr' taking a function modifying -- 'FnkEnv'. fromFnkEnvOptions :: ((FnkEnv -> FnkEnv) -> a) -> [OptDescr a] fromFnkEnvOptions f = map (fmap f) fnkEnvOptionsWithLib -- | Usage information for 'fnkEnvOptions', without @-B@ option. fnkEnvOptionsUsage :: String -> String fnkEnvOptionsUsage = flip usageInfo fnkEnvOptions ================================================ FILE: finkel-kernel/src/Language/Finkel/ParsedResult.hs ================================================ {-# LANGUAGE CPP #-} module Language.Finkel.ParsedResult ( fnkParsedResultAction ) where #if MIN_VERSION_ghc(8,6,0) #include "ghc_modules.h" -- base import Control.Exception (displayException, throwIO) import Control.Monad.IO.Class (MonadIO (..)) import Data.Maybe (fromMaybe) import System.Console.GetOpt (ArgOrder (..), getOpt) import System.Environment (getProgName) import System.Exit (exitFailure, exitSuccess) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif -- ghc import GHC_Driver_Env (Hsc (..), HscEnv (..)) import GHC_Driver_Main (getHscEnv) import GHC_Plugins (CommandLineOption) import GHC_Runtime_Context (InteractiveContext (..)) import GHC_Types_SourceError (throwOneError) import GHC_Types_SrcLoc (noLoc, noSrcSpan) import GHC_Unit_Module (ModLocation (..)) import GHC_Unit_Module_ModSummary (ModSummary (..), ms_mod_name) import GHC_Utils_Outputable (text) #if MIN_VERSION_ghc(9,4,0) import GHC.Plugins (ParsedResult) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Hs (HsParsedModule (..)) #else import GHC_Driver_Types (HsParsedModule (..)) #endif -- Internal import Language.Finkel.Error (mkPlainWrappedMsg) import Language.Finkel.Exception (FinkelException (..), finkelExceptionLoc, handleFinkelException) import Language.Finkel.Fnk (FnkEnv (..), FnkInvokedMode (..), dumpDynFlags, initFnkEnv, runFnk') import Language.Finkel.Make (mkParsedResult) import Language.Finkel.Make.Summary (TargetSummary (..), compileFnkFile) import Language.Finkel.Make.TargetSource (TargetSource (..), findTargetSourceWithPragma) import Language.Finkel.Options (FnkPluginOptions (..), defaultFnkPluginOptions, fnkPluginOptions, fpoIgnore, fpoPragma, printPluginUsage) -- ------------------------------------------------------------------------ -- -- Exported -- -- ------------------------------------------------------------------------ #if MIN_VERSION_ghc(9,4,0) fnkParsedResultAction :: String -> FnkEnv -> [CommandLineOption] -> ModSummary -> ParsedResult -> Hsc ParsedResult #else fnkParsedResultAction :: String -> FnkEnv -> [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule #endif fnkParsedResultAction mod_name fnk_env0 args0 ms pm = case getOpt Permute fnkPluginOptions (concatMap words args0) of (_, _, es@(_:_)) -> liftIO (exitWithBriefUsage mod_name es) (os, _ls, []) -> do let fpo = foldl' (flip id) (defaultFnkPluginOptions fnk_env0) os if fpoHelp fpo then liftIO (printPluginUsage mod_name >> exitSuccess) else if fpoIgnore fpo then pure pm else case ml_hs_file (ms_location ms) of Nothing -> pure pm Just path -> do let pragma = fpoPragma fpo lpath = noLoc path fnk_env1 = fpoFnkEnv fpo dflags = ms_hspp_opts ms mkPR = mkParsedResult fnk_env2 <- liftIO $ initFnkEnv fnk_env1 ts <- findTargetSourceWithPragma pragma dflags lpath case ts of FnkSource {} -> mkPR <$> parseFnkModule fnk_env2 path ms _ -> pure pm -- ------------------------------------------------------------------------ -- -- Internal -- -- ------------------------------------------------------------------------ parseFnkModule :: FnkEnv -> FilePath -> ModSummary -> Hsc HsParsedModule parseFnkModule fenv0 path ms = do henv <- getHscEnv let mb_loc = fromMaybe noSrcSpan . finkelExceptionLoc mname = ms_mod_name ms dflags = hsc_dflags henv dflags_in_ic = ic_dflags (hsc_IC henv) -- Setting the default DynFlags of FnkEnv to the DynFlags from interactive -- context, since the DynFlags from 'hsc_dflags' field of HscEnv is -- already updated with file local options at this point. This will -- prevent redundant recompilation when requireing home package modules. fenv1 = fenv0 { envInvokedMode = GhcPluginMode , envDefaultDynFlags = Just dflags_in_ic } handler e = throwOneError (mkPlainWrappedMsg dflags (mb_loc e) (text (displayException e))) fnk = handleFinkelException handler $ compileFnkFile path mname let dump_dyn_flags lbl = dumpDynFlags fenv1 (text lbl) dump_dyn_flags "parseFnkModule:dflags" dflags dump_dyn_flags "parseFnkModule:dflags_in_ic" dflags_in_ic summary <- liftIO $ runFnk' fnk fenv1 henv case summary of EMS ems _mb_sp _reqs | Just pm <- ms_parsed_mod ems -> pure pm _ -> liftIO (throwIO (FinkelException ("Failed to parse " ++ path))) exitWithBriefUsage :: String -> [String] -> IO a exitWithBriefUsage mod_name errs = do me <- getProgName let msgs = [ "Try:" , "" , " " ++ me ++ " -fplugin=" ++ mod_name ++ " -fplugin-opt=" ++ mod_name ++ ":--help" ++ " ..." , "" , "to see available options." ] putStr (unlines (errs ++ msgs)) exitFailure -- Note: [Workaround to support "-fno-code" option in ghc 9.6] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- When compiling with "-fno-code", home package module might required from -- other home package modules. In 'GHC.Driver.Make.enableCodeGenWhen', byte -- codes are generated when the TemplateHaskell language extension is turned -- on. However, at the moment finkel does not understand TemplateHaskell, so -- manually updating the 'HscEnv' with 'driverPlugin' plugin action. The three -- updates done to the 'DynFlags' are same as passing "-fprefer-byte-code", -- "-fwrite-if-simplified-core", and "-XTemplateHaskell" from command line. -- -- XXX: haddock generation is not working with ghc 9.6 yet. Seems like the -- GHC plugins are not initialized before module dependency analysis. -- fnkNoCodePlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv -- fnkNoCodePlugin _ hsc_env = do -- let dflags0 = hsc_dflags hsc_env -- generates_code = backendGeneratesCode (backend dflags0) -- if generates_code -- then pure hsc_env -- else do -- let update df = setGeneralFlag' Opt_UseBytecodeRatherThanObjects $ -- setGeneralFlag' Opt_WriteIfSimplifiedCore $ -- xopt_set df TemplateHaskell -- dflags1 = update dflags0 -- pure (hscSetFlags dflags1 hsc_env) #else /* ghc < 8.6.0 */ fnkParsedResultAction :: a fnkParsedResultAction = error "Unsupported GHC version, requires >= 8.6.0" #endif /* ghc < 8.6.0 */ ================================================ FILE: finkel-kernel/src/Language/Finkel/Plugin.hs ================================================ {-# LANGUAGE CPP #-} -- | Plugin version of the finkel compiler. module Language.Finkel.Plugin ( -- * Finkel plugin plugin , pluginWith , setFinkelPluginWithArgs ) where #include "ghc_modules.h" -- base #if MIN_VERSION_ghc(9,6,0) import Control.Monad.IO.Class (MonadIO (..)) #endif #if !MIN_VERSION_ghc(9,2,0) import Data.Functor (void) #endif -- ghc import GHC_Driver_Env (HscEnv (..)) import GHC_Driver_Monad (GhcMonad (..)) import GHC_Plugins (Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, flagRecompile) #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Plugins (Plugins (..)) #endif #if !MIN_VERSION_ghc(9,2,0) import GHC (setSessionDynFlags) import GHC_Driver_Session (DynFlags (..)) #endif -- Internal import Language.Finkel.Fnk (FnkEnv) import Language.Finkel.SpecialForms (defaultFnkEnv) #if MIN_VERSION_ghc(9,6,0) import Language.Finkel.Hooks (finkelHooks) #else import Language.Finkel.ParsedResult (fnkParsedResultAction) #endif -- | Finkel compiler plugin. plugin :: Plugin plugin = pluginWith "Language.Finkel.Plugin" defaultFnkEnv -- | Finkel compiler plugin with given 'FnkEnv'. pluginWith :: String -- ^ Plugin module name. -> FnkEnv -- ^ The environment used by the plugin. -> Plugin pluginWith mod_name fnk_env = #if MIN_VERSION_ghc(9,6,0) defaultPlugin { driverPlugin = finkelHooks mod_name fnk_env , pluginRecompile = flagRecompile } #else defaultPlugin { parsedResultAction = fnkParsedResultAction mod_name fnk_env , pluginRecompile = flagRecompile } #endif -- | Initialize finkel plugin with given arguments. setFinkelPluginWithArgs :: GhcMonad m => Plugin -> [String] -> m () setFinkelPluginWithArgs plgn args = do hsc_env <- getSession #if MIN_VERSION_ghc(9,6,0) -- In ghc >= 9.6, updating current session with driverPlugin, because -- `GHC.Loader.initializePlugins' does not check the addition of static -- plugins, according to the comment in the function. hsc_env' <- liftIO $ driverPlugin plgn args hsc_env let sp = StaticPlugin (PluginWithArgs plgn args) old_plugins = hsc_plugins hsc_env' old_static_plugins = staticPlugins old_plugins new_static_plugins = sp : old_static_plugins new_plugins = old_plugins {staticPlugins = new_static_plugins} setSession (hsc_env' {hsc_plugins = new_plugins}) #elif MIN_VERSION_ghc(9,4,0) let sp = StaticPlugin (PluginWithArgs plgn args) old_plugins = hsc_plugins hsc_env old_static_plugins = staticPlugins old_plugins new_static_plugins = sp : old_static_plugins new_plugins = old_plugins {staticPlugins = new_static_plugins} setSession (hsc_env {hsc_plugins = new_plugins}) #elif MIN_VERSION_ghc(9,2,0) -- In ghc < 9.6, adding static plugin. From ghc 9.2, plugins are stored in -- HscEnv. Before 9.2, plugins are stored in DynFlags. let sp = StaticPlugin (PluginWithArgs plgn args) old_static_plugins = hsc_static_plugins hsc_env new_static_plugins = sp : old_static_plugins setSession (hsc_env {hsc_static_plugins = new_static_plugins}) #else let sp = StaticPlugin (PluginWithArgs plgn args) old_dflags = hsc_dflags hsc_env old_staticPlugins = staticPlugins old_dflags new_staticPlugins = sp : old_staticPlugins new_dflags = old_dflags {staticPlugins = new_staticPlugins} void (setSessionDynFlags new_dflags) #endif ================================================ FILE: finkel-kernel/src/Language/Finkel/Preprocess.hs ================================================ {-# LANGUAGE CPP #-} -- Module header preprocessor module Language.Finkel.Preprocess ( -- Preprocessor functions defaultPreprocess , defaultPreprocessEnv , defaultPreprocessWith -- Auxiliary , preprocessOrCopy , PpOptions(..) , ppOptions , mkPpOptions ) where #include "ghc_modules.h" -- base import Control.Exception (Exception (..), throw) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (..)) import Data.Char (toLower) import Data.Maybe (fromMaybe) import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..), getOpt, usageInfo) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.IO (IOMode (..), hPutStrLn, stderr, stdout, withFile) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif -- directory import System.Directory (copyFile) -- ghc import GHC_Data_Bag (unitBag) import GHC_Data_FastString (fsLit) import GHC_Data_StringBuffer (hGetStringBuffer) import GHC_Driver_Env (HscEnv (..)) import GHC_Types_SrcLoc (GenLocated (..)) import GHC_Utils_Outputable (text, ($$), (<>)) #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Config.Diagnostic (initDiagOpts) import GHC.Driver.Errors.Types (ghcUnknownMessage) import GHC.Types.Error (DiagnosticReason (..), mkMessages, mkPlainDiagnostic, noHints) import GHC.Utils.Error (mkPlainMsgEnvelope) import GHC_Driver_Monad (logDiagnostics) #else import GHC (getPrintUnqual) import GHC_Driver_Flags (WarnReason (..)) import GHC_Driver_Monad (logWarnings) import GHC_Utils_Error (makeIntoWarning, mkWarnMsg) #endif #if !MIN_VERSION_ghc(9,2,0) || MIN_VERSION_ghc(9,4,0) import GHC_Driver_Session (HasDynFlags (..)) #endif -- finkel-kernel import Language.Finkel.Emit (Hsrc (..), putHsSrc) import Language.Finkel.Exception (FinkelException (..), handleFinkelException, printFinkelException, readOrFinkelException) import Language.Finkel.Fnk (FnkEnv (..), Macro (..), addMacro, lookupMacro, macroFunction, makeEnvMacros, mergeMacros, modifyFnkEnv, runFnk, runFnk') import Language.Finkel.Form (Form (..), LForm (..), aSymbol, unCode) import Language.Finkel.Make.Cache import Language.Finkel.Make.Session (expandContents) import Language.Finkel.Make.Summary (buildHsSyn, withTiming') import Language.Finkel.Make.TargetSource (findPragmaString) import Language.Finkel.SpecialForms (defaultFnkEnv, emptyForm, specialForms) import Language.Finkel.Syntax (parseHeader, parseModule) import Language.Finkel.Options (FnkSrcOptions (..), defaultFnkSrcOptions, fromFnkSrcOptions) -- ------------------------------------------------------------------------ -- -- Exported -- -- ------------------------------------------------------------------------ -- | Default main function for preprocessor. defaultPreprocess :: IO () defaultPreprocess = getArgs >>= defaultPreprocessWith defaultPreprocessEnv -- | 'FnkEnv' used in 'defaultPreprocess'. defaultPreprocessEnv :: FnkEnv defaultPreprocessEnv = defaultFnkEnv {envMacros=myMacros} where -- Adding ":require", ":with-macro", and ":eval-when-compile" special forms -- to empty macros with dummy contents, because the preprocessor does not -- know the module lookup paths from the command line argument. myMacros = foldr f z interpMacros f name = addMacro (fsLit name) emptyFormMacro z = addMacro (fsLit "defmodule") defmoduleForDownsweep specialForms interpMacros :: [String] interpMacros = [ ":eval-when-compile" , ":require" , ":with-macro" ] -- | Default main function for preprocessor, with given 'FnkEnv' and command -- line arguments. defaultPreprocessWith :: FnkEnv -- ^ Environment for running 'Fnk'. -> [String] -- ^ Command line arguments. -> IO () defaultPreprocessWith fnk_env args = case getOpt Permute ppOptions args of ( _, _, errs@(_:_)) -> exitWithErrors errs (opts, files, _ ) -> handleFinkelException handler $ do me <- getProgName let ppo = foldl' (flip id) myPpOptions opts myPpOptions = mkPpOptions me fnk_env go = preprocessOrCopy Nothing ppo if ppoHelp ppo then printUsage else do debug ppo 2 ("args: " ++ show args) case files of [isrc] -> go isrc Nothing [isrc, opath] -> go isrc (Just opath) [_, isrc, opath] -> go isrc (Just opath) _ -> exitWithErrors [] where handler e = do me <- getProgName hPutStrLn stderr (me ++ ": " ++ displayException e) exitFailure exitWithErrors es = do mapM_ putStrLn es printUsage exitFailure -- | Preprocess Finkel source code file with given 'FnkEnv', or copy -- the file if the file was a Haskell source code. preprocessOrCopy :: Maybe HscEnv -- ^ Environment used for expanding macros. -> PpOptions -- ^ Pre-processor options. -> FilePath -- ^ Path of input Finkel source code. -> Maybe FilePath -- ^ 'Just' path to write preprocessed output, or 'Nothing' for 'stdout'. -> IO () preprocessOrCopy mb_hsc_env ppo isrc mb_opath = do buf <- hGetStringBuffer isrc if not (ppoIgnore ppo) && findPragmaString (ppoPragma ppo) buf then do let opath = fromMaybe "stdout" mb_opath debug ppo 2 ("Preprocessing " ++ isrc ++ " to " ++ opath) writeModule mb_hsc_env ppo isrc mb_opath debug ppo 2 ("Finished wriitng " ++ isrc ++ " to " ++ opath) else do debug ppo 2 ("Skipping " ++ isrc) mapM_ (copyFile isrc) mb_opath -- ------------------------------------------------------------------------ -- -- Internal -- -- ------------------------------------------------------------------------ printUsage :: IO () printUsage = do me <- getProgName let header = unlines [ me ++ ": Finkel source code preprocessor" , "" , "USAGE:" , "" , " " ++ me ++ " [OPTIONS] INPATH" , " " ++ me ++ " [OPTIONS] INPATH OUTPATH" , " " ++ me ++ " [OPTIONS] ORIGPATH INPATH OUTPATH" , "" , "OPTIONS:" ] putStrLn (usageInfo header ppOptions) writeModule :: Maybe HscEnv -> PpOptions -> FilePath -> Maybe FilePath -> IO () writeModule mb_hsc_env ppo ipath mb_opath = case mb_opath of Nothing -> run stdout Just opath -> withFile opath WriteMode run where run hdl = case mb_hsc_env of -- When hsc_env is given, assuming that given FnkEnv is already -- initialized. Just hsc_env -> runFnk' (go hdl) fnk_env hsc_env Nothing -> runFnk (go hdl) fnk_env fnk_env = (ppoFnkEnv ppo) {envVerbosity=ppoVerbosity ppo} parser = if ppoFull ppo then parseModule else parseHeader warn_interp_macros = 0 < ppoVerbosity ppo && ppoWarnInterp ppo go hdl = withTiming' "writeModule" $ handleFinkelException handler $ do when warn_interp_macros $ modifyFnkEnv (replaceWithWarnings interpMacros) ExpandedCode {ec_sp=sp,ec_forms=forms1} <- expandContents ipath mdl <- buildHsSyn parser forms1 putHsSrc hdl sp (Hsrc mdl) handler e = do printFinkelException e liftIO exitFailure debug :: MonadIO m => PpOptions -> Int -> String -> m () debug ppo level msg = when (level < ppoVerbosity ppo) $ liftIO (hPutStrLn stderr (ppoExecName ppo ++ ": " ++ msg)) -- ------------------------------------------------------------------------ -- -- Macros -- -- ------------------------------------------------------------------------ -- Macro constantly returning empty form. emptyFormMacro :: Macro emptyFormMacro = Macro (const (pure emptyForm)) -- Variant of defmodule macro to support 'downsweep' function in ghc's make -- function. Actual implementation of 'defmodule' macro is written in -- finkel-core package. defmoduleForDownsweep :: Macro defmoduleForDownsweep = Macro (pure . f) where f (LForm (L l0 lst)) = case lst of List (_:name:rest) -> go name rest _ -> emptyForm where go name rest = if null rest then moduleForm name else begin (moduleForm name : foldr accImportForm [] rest) begin xs = mkL0 (List (sym ":begin" : xs)) accImportForm x acc = case unCode x of List (y : ys) | y == sym "import" -> foldr accModule acc ys | y == sym "import_when" , ps:ys' <- ys , hasLoadPhase ps -> foldr accModule acc ys' _ -> acc accModule x acc = case x of LForm (L l1 (List ys)) -> importForm l1 ys : acc _ -> acc hasLoadPhase xs = case unCode (curve xs) of List ys -> sym ":load" `elem` ys _ -> False moduleForm n = mkL0 (List [sym "module", n]) importForm l xs = LForm (L l (List (sym "import" : map curve xs))) curve x = case x of LForm (L l (HsList ys)) -> LForm (L l (List ys)) _ -> x sym = mkL0 . Atom . aSymbol mkL0 = LForm . L l0 -- Replace given macro names with original macro with warning message. replaceWithWarnings :: [String] -> FnkEnv -> FnkEnv replaceWithWarnings names fnk_env = fnk_env {envMacros=added} where added = mergeMacros replaced orig_macros orig_macros = envMacros fnk_env replaced = makeEnvMacros (foldr f [] names) f name acc = case lookupMacro (fsLit name) fnk_env of Just macro -> (name, Macro (addWarning name macro)) : acc Nothing -> acc addWarning name macro form@(LForm (L loc _)) = do let msg = text "Preprocessor does not interpret during macro expansion." $$ text "Replacing '(" <> text name <> text " ...)' with '(:begin)'." $$ text "Use \"--warn-interp=False\" to suppress this message." -- XXX: See "GHC.SysTools.Process.{builderMainLoop,readerProc}". -- -- Until ghc 9.4, the messages from the Finkel preprocessor command are -- parsed, and then hard coded "SevError" message is printed by the -- logger. Although the below "logWarnings" is using "SevWarning", the -- parsed message is shown with "SevError". #if MIN_VERSION_ghc(9,4,0) dflags <- getDynFlags let diag = mkPlainDiagnostic WarningWithoutFlag noHints msg warning = mkPlainMsgEnvelope (initDiagOpts dflags) loc diag logDiagnostics (mkMessages (unitBag (fmap ghcUnknownMessage warning))) #elif MIN_VERSION_ghc(9,2,0) unqual <- getPrintUnqual let wmsg = mkWarnMsg loc unqual msg warning = makeIntoWarning NoReason wmsg logWarnings (unitBag warning) #else dflags <- getDynFlags unqual <- getPrintUnqual let wmsg = mkWarnMsg dflags loc unqual msg warning = makeIntoWarning NoReason wmsg logWarnings (unitBag warning) #endif -- Deleget to the original function macroFunction macro form -- ------------------------------------------------------------------------ -- -- Options for preprocessor -- -- ------------------------------------------------------------------------ -- | Preprocessor options data PpOptions = PpOptions { ppoHelp :: Bool -- ^ Flag for showing help message. , ppoVerbosity :: !Int -- ^ Verbosity level. , ppoFull :: !Bool -- ^ Preprocess full module if 'True', otherwise parse module header only. , ppoWarnInterp :: !Bool -- ^ Flag for showing warning message for macros using interpreter. , ppoFnkSrcOptions :: !FnkSrcOptions -- ^ Finkel source code option for preprocessor. , ppoFnkEnv :: FnkEnv -- ^ The 'FnkEnv' to run 'Fnk'. , ppoExecName :: String -- ^ Executable name shown in debug message. } -- | Make 'PpOption' with some fields set to default value. mkPpOptions :: String -> FnkEnv -> PpOptions mkPpOptions exec_name fnk_env = PpOptions { ppoHelp = False , ppoVerbosity = 1 , ppoFull = False , ppoWarnInterp = True , ppoFnkSrcOptions = defaultFnkSrcOptions , ppoFnkEnv = fnk_env , ppoExecName = exec_name } ppoPragma :: PpOptions -> String ppoPragma = fsrcPragma . ppoFnkSrcOptions ppoIgnore :: PpOptions -> Bool ppoIgnore = fsrcIgnore . ppoFnkSrcOptions ppOptions :: [OptDescr (PpOptions -> PpOptions)] ppOptions = [ Option [] ["help"] (NoArg (\o -> o {ppoHelp = True})) "Show this help and exit." , Option [] ["verbose"] (ReqArg (\n o -> o {ppoVerbosity=readInt n}) "INT") "Set verbosity level to INT." , Option [] ["warn-interp"] (OptArg (\mb o -> o {ppoWarnInterp=maybe True parseBoolish mb}) "BOOL") ("Show warning in macros using interpreter.\n" ++ "(default: True)") , Option [] ["no-warn-interp"] (NoArg (\o -> o {ppoWarnInterp=False})) "Do not show warning in macros using interpreter." , Option [] ["full"] (NoArg (\o -> o {ppoFull = True})) "Parse full module instead of module header." ] ++ fnk_src_opts where fnk_src_opts = fromFnkSrcOptions wrap wrap f o = o {ppoFnkSrcOptions = f (ppoFnkSrcOptions o)} readInt = readOrFinkelException "INT" "verbosity" parseBoolish :: String -> Bool parseBoolish str | low_str `elem` trueish = True | low_str `elem` falsish = False | otherwise = throw (FinkelException msg) where low_str = map toLower str trueish = ["true", "yes", "1"] falsish = ["false", "no", "0"] msg = "Expecting boolean value but got \"" ++ str ++ "\"" ================================================ FILE: finkel-kernel/src/Language/Finkel/Reader.y ================================================ -- -*- mode: haskell; -*- { {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | S-expression reader. -- -- Parser functions in this module are written with Happy parser generator. -- module Language.Finkel.Reader ( parseSexprs , parseHeaderPragmas , sexpr , sexprs , psexpr , supportedLangExts ) where #include "ghc_modules.h" -- base import Data.Char (toLower) import Data.List (foldl') -- exceptions import Control.Monad.Catch (MonadThrow(..)) -- ghc import GHC_Data_FastString (FastString, fsLit, unpackFS) import GHC_Hs_ImpExp (ideclName) import GHC_Unit_Module (moduleNameString) import GHC_Types_SrcLoc (GenLocated(..), Located, SrcSpan, mkSrcSpan, combineSrcSpans) import GHC_Types_SourceText (SourceText(..)) import GHC_Data_StringBuffer (StringBuffer) -- ghc-boot import GHC.LanguageExtensions (Extension(..)) -- Internal import Language.Finkel.Data.SourceText import Language.Finkel.Form import Language.Finkel.Exception import Language.Finkel.Lexer } %name sexpr_ sexp %name sexprs_ sexps %partial psexpr_ sexp %partial pheader header %tokentype { Located Token } %monad { SP } { >>= } { return } %lexer { tokenLexer } { L _ TEOF } %token '(' { L _ TOparen } ')' { L _ TCparen } '[' { L _ TObracket } ']' { L _ TCbracket } '{' { L _ TOcurly } '}' { L _ TCcurly } 'quote' { L _ TQuote } '`' { L _ TQuasiquote } ',' { L _ TUnquote } ',@' { L _ TUnquoteSplice } '%_' { L _ (TPercent '_') } '%' { L _ (TPercent $$) } 'pcommas' { L _ (TPcommas _) } 'symbol' { L _ (TSymbol _) } 'char' { L _ (TChar _ _) } 'string' { L _ (TString _ _) } 'integer' { L _ (TInteger _ _) } 'frac' { L _ (TFractional _) } 'doc' { L _ (TDocNext _) } 'doc^' { L _ (TDocPrev _) } 'doch' { L _ (TDocGroup _ _) } 'doc$' { L _ (TDocNamed _ _) } %% -- Unit and List -- ~~~~~~~~~~~~~ -- -- Empty list will parsed as a unit (i.e. '()' in Haskell), non-empty lists are -- pased as 'List' value of 'Code'. Empty 'List' value of 'Code' could be -- referred with 'Language.Finkel.Form.nil'. sexp :: { Code } : atom { $1 } | 'quote' sexp { mkQuote $1 $2 } | '`' sexp { mkQuasiquote $1 $2 } | ',' sexp { mkUnquote $1 $2 } | ',@' sexp { mkUnquoteSplice $1 $2 } | '[' sexps ']' { mkHsList $1 $2 $3 } | 'pcommas' { mkPcommas $1 } | '(' sexps ')' { mkUnitOrList $1 $2 $3} | prag { $1 } sexps :: { [Code] } : rsexps { reverse $1 } rsexps :: { [Code] } : {- empty -} { [] } | rsexps sexp { $2 : $1 } | rsexps '%_' sexp { $1 } atom :: { Code } : 'symbol' { mkASymbol $1 } | 'char' { mkAChar $1 } | 'string' { mkAString $1 } | 'integer' { mkAInteger $1 } | 'frac' { mkAFractional $1 } | '{' { mkOcSymbol $1 } | '}' { mkCcSymbol $1 } | 'doc' { mkDoc $1 } | 'doc^' { mkDocp $1 } | 'doch' { mkDoch $1 } | 'doc$' { mkDock $1 } prag :: { Code } : '%' sexp {% rmac $1 $2 } header :: { [Code] } : {- empty -} { [] } | header prag { $2 : $1 } { atom :: SrcSpan -> Atom -> Code atom l x = LForm $ L l $ Atom x {-# INLINABLE atom #-} sym :: SrcSpan -> FastString -> Code sym l str = atom l $ ASymbol str {-# INLINABLE sym #-} li :: SrcSpan -> [Code] -> Code li l xs = LForm $ L l $ List xs {-# INLINABLE li #-} mkQuote :: Located Token -> Code -> Code mkQuote (L l _) body = li l [sym l ":quote", body] {-# INLINABLE mkQuote #-} mkQuasiquote :: Located Token -> Code -> Code mkQuasiquote (L l _) body = li l [sym l ":quasiquote", body] {-# INLINABLE mkQuasiquote #-} mkUnquote :: Located Token -> Code -> Code mkUnquote (L l _) body = li l [sym l ":unquote", body] {-# INLINABLE mkUnquote #-} mkUnquoteSplice :: Located Token -> Code -> Code mkUnquoteSplice (L l _) body = li l [sym l ":unquote-splice", body] {-# INLINABLE mkUnquoteSplice #-} mkHsList :: Located Token -> [Code] -> Located Token -> Code mkHsList (L lo _) body (L lc _) = LForm $ L (combineSrcSpans lo lc) $ HsList body {-# INLINABLE mkHsList #-} mkPcommas :: Located Token -> Code mkPcommas (L l (TPcommas n)) = li l [sym l (fsLit (replicate n ','))] {-# INLINABLE mkPcommas #-} mkUnitOrList :: Located Token -> [Code] -> Located Token -> Code mkUnitOrList (L lo _) body (L lc _) = let l = combineSrcSpans lo lc in case body of [] -> atom l AUnit _ -> li l body {-# INLINABLE mkUnitOrList #-} mkASymbol :: Located Token -> Code mkASymbol (L l (TSymbol x)) = atom l $ ASymbol x {-# INLINABLE mkASymbol #-} mkAChar :: Located Token -> Code mkAChar (L l (TChar st x)) = atom l $ AChar st x {-# INLINABLE mkAChar #-} mkAString :: Located Token -> Code mkAString (L l (TString st x)) = atom l $ aString st x {-# INLINABLE mkAString #-} mkAInteger :: Located Token -> Code mkAInteger (L l (TInteger st n)) = atom l $ AInteger lit where lit = IL { il_text = st , il_neg = n < 0 , il_value = n } {-# INLINABLE mkAInteger #-} mkAFractional :: Located Token -> Code mkAFractional (L l (TFractional x)) = atom l $ AFractional x {-# INLINABLE mkAFractional #-} mkOcSymbol :: Located Token -> Code mkOcSymbol (L l _) = sym l "{" {-# INLINABLE mkOcSymbol #-} mkCcSymbol :: Located Token -> Code mkCcSymbol (L l _) = sym l "}" {-# INLINABLE mkCcSymbol #-} mkDoc :: Located Token -> Code mkDoc (L l (TDocNext str)) = li l [sym l ":doc", atom l (AString (toSourceText str) str)] {-# INLINABLE mkDoc #-} mkDocp :: Located Token -> Code mkDocp (L l (TDocPrev str)) = li l [sym l ":doc^", atom l (AString (toSourceText str) str)] {-# INLINABLE mkDocp #-} mkDoch :: Located Token -> Code mkDoch (L l (TDocGroup n s)) = li l [sym l dh, atom l (AString st s)] where dh = case n of 1 -> ":dh1" 2 -> ":dh2" 3 -> ":dh3" _ -> ":dh4" st = toSourceText s {-# INLINABLE mkDoch #-} mkDock :: Located Token -> Code mkDock (L l (TDocNamed k mb_doc)) = case mb_doc of Nothing -> li l pre Just d -> li l (pre ++ [atom l (AString (toSourceText d) d)]) where pre = [sym l ":doc$", atom l (ASymbol k)] {-# INLINABLE mkDock #-} rmac :: Char -> Code -> SP Code rmac c expr = case c of 'p' -> pragma expr _ -> errorSP expr ("rmac: unsupported char " ++ show c) {-# INLINABLE rmac #-} -- Module from ghc package with codes related to language pragma: -- -- + libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs: The file containing -- definition of language extensions. -- -- + compiler/main/HeaderInfo.hs: Parses header information. -- -- + compiler/main/DynFlags.hs: Contains 'supportedExtensions :: [String]'. This -- is a list of language extension names, and the names with "No" -- prefix. 'xFlagsDeps' contains list of pair language extension and -- deprecation messages. -- pragma :: Code -> SP Code pragma orig@(LForm (L l form)) = case form of -- Pragma with no arguments. List [LForm (L _ (Atom (ASymbol sym)))] -- Return the UNPACK form as is. This pragma is handled by syntax parser -- of data constructor field. | normalize sym `elem` noArgPragmas -> return orig -- Pragma with arguments. List (LForm (L l' (Atom (ASymbol sym))):rest) | normalize sym `elem` inlinePragmas -> return orig | normalize sym == "language" -> do let (exts, invalids) = groupExts rest case invalids of [] -> do sp <- getSPState putSPState (sp {langExts = exts ++ langExts sp}) return (emptyBody l) _ -> errorSP orig ("Unsupported LANGUAGE pragma: " ++ show invalids) | normalize sym `elem` spcls -> do let specialize = LForm (L l' (Atom (ASymbol "SPECIALIZE"))) return (LForm (L l (List (specialize:rest)))) | normalize sym == "options_ghc" -> do modifySPState (\sp -> sp {ghcOptions = makeOptionFlags rest ++ ghcOptions sp}) return (emptyBody l) | normalize sym == "options_haddock" -> do modifySPState (\sp -> sp {haddockOptions = makeOptionFlags rest ++ haddockOptions sp}) return (emptyBody l) _ -> errorSP orig ("Unknown pragma: " ++ show form) where normalize = map toLower . unpackFS inlinePragmas = ["inline", "noinline", "inlinable"] spcls = ["specialize", "specialise"] noArgPragmas :: [String] noArgPragmas = [ "unpack" , "overlappable", "overlapping", "overlaps", "incoherent"] groupExts :: [Code] -> ([Located String],[Code]) groupExts = foldr f ([],[]) where f form (exts, invalids) = case form of LForm (L l (Atom (ASymbol sym))) | Just ext <- lookup sym supportedLangExts -> (L l ext:exts, invalids) _ -> (exts, form:invalids) supportedLangExts :: [(FastString, String)] supportedLangExts = f [ BangPatterns , DataKinds , DefaultSignatures , DeriveAnyClass , DeriveDataTypeable , DeriveFoldable , DeriveFunctor , DeriveGeneric , DeriveTraversable , DerivingStrategies , DerivingVia , EmptyCase , EmptyDataDeriving , ExistentialQuantification , ExplicitForAll , FlexibleContexts , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving , ImplicitPrelude , ImpredicativeTypes , KindSignatures , MultiParamTypeClasses , MonoLocalBinds , MonomorphismRestriction #if MIN_VERSION_ghc(9,4,0) , NamedFieldPuns #endif , OverloadedStrings , OverloadedLabels , OverloadedLists , PolyKinds , RankNTypes #if !MIN_VERSION_ghc(9,4,0) , RecordPuns #endif , RecordWildCards , ScopedTypeVariables , StandaloneKindSignatures , StandaloneDeriving , TypeApplications , TypeFamilies , TypeInType , TypeOperators , TypeSynonymInstances , UndecidableInstances ] where -- Adding `"No"' prefix, as done in `DynFlags.supportedExtensions'. Might -- worth looking up `DynFlags.xFlags' to get string representation of -- language extension instead of applying `show' function. f = concatMap g g ext = [(fsLit name, name), (fsLit noname, noname)] where #if MIN_VERSION_ghc(9,4,0) name = show ext #else -- Until ghc 9.4.0, NamedFieldPuns constructor did not exist -- in LanguageExtensions. name = case ext of RecordPuns -> "NamedFieldPuns" _ -> show ext #endif noname = "No" ++ name makeOptionFlags :: [Code] -> [Located String] makeOptionFlags = foldl' f [] where f acc code = case code of LForm (L l (Atom (ASymbol sym))) -> L l (unpackFS sym) : acc _ -> acc emptyBody :: SrcSpan -> Code emptyBody l = li l [sym l ":begin"] dispatch :: Located Token -> Code -> SP Code dispatch (L _ (TSymbol sym)) form = case sym of "." -> error "dispatch: dot" _ -> errorSP form "dispatch" happyError :: SP a happyError = lexErrorSP -- | Parse S-expressions. parseSexprs :: MonadThrow m => Maybe FilePath -- ^ Name of input file. -> StringBuffer -- ^ Contents to parse. -> m ([Code], SPState) parseSexprs = parseWith sexprs_ -- | Parse file header pragmas. parseHeaderPragmas :: MonadThrow m => Maybe FilePath -> StringBuffer -> m ([Code], SPState) parseHeaderPragmas = parseWith pheader parseWith :: MonadThrow m => SP a -> Maybe FilePath -> StringBuffer -> m (a, SPState) parseWith p mb_file contents = either (throwM . toLexicalException) pure (runSP p mb_file contents) where toLexicalException (LexicalError l c _) = LexicalException (mkSrcSpan l l) c {-# INLINABLE parseWith #-} -- | Parse single S-expression. sexpr :: SP Code sexpr = sexpr_ -- | Parse list of S-expressions. sexprs :: SP [Code] sexprs = sexprs_ -- | Partial S-expression parser. psexpr :: SP Code psexpr = psexpr_ } ================================================ FILE: finkel-kernel/src/Language/Finkel/SpecialForms.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | Special forms. module Language.Finkel.SpecialForms ( specialForms , unquoteSplice , defaultFnkEnv , emptyForm ) where #include "ghc_modules.h" -- base import Control.Exception (throw) import Control.Monad (foldM, unless, when) import Control.Monad.IO.Class (MonadIO (..)) import Data.Foldable (toList) import Data.Functor (void) import Data.Maybe (catMaybes) import GHC.Exts (unsafeCoerce#) #if MIN_VERSION_ghc(9,2,0) import GHC.Utils.Outputable ((<>)) import Prelude hiding ((<>)) #endif -- containers import Data.Map (fromList) -- exceptions import Control.Monad.Catch (bracket) -- ghc import GHC (ModuleInfo, getModuleInfo, lookupModule, lookupName, modInfoExports, setContext) import GHC_Data_FastString (FastString, fsLit, unpackFS) import GHC_Driver_Env_Types (HscEnv (..)) import GHC_Driver_Main (Messager, hscTcRnLookupRdrName, showModuleIndex) import GHC_Driver_Monad (GhcMonad (..), modifySession) import GHC_Driver_Ppr (showPpr) import GHC_Driver_Session (DynFlags (..), GeneralFlag (..), HasDynFlags (..), getDynFlags, unSetGeneralFlag') import GHC_Hs (HsModule (..)) import GHC_Hs_ImpExp (ImportDecl (..), ieName) import GHC_Iface_Recomp (RecompileRequired (..), recompileRequired) import GHC_Runtime_Context (InteractiveImport (..)) import GHC_Runtime_Eval (getContext) import GHC_Types_Name (nameOccName, occName) import GHC_Types_Name_Occurrence (occNameFS) import GHC_Types_Name_Reader (rdrNameOcc) import GHC_Types_SrcLoc (GenLocated (..), SrcSpan (..), unLoc) import GHC_Types_TyThing (TyThing (..)) import GHC_Types_Var (varName) import GHC_Unit_Finder (FindResult (..), findImportedModule) import GHC_Unit_Home_ModInfo (lookupHpt) import GHC_Unit_Module (Module, moduleNameString) import GHC_Unit_Module_Graph (ModuleGraph, mgLookupModule, showModMsg) import GHC_Unit_Module_ModSummary (ModSummary (..)) import GHC_Utils_Error (compilationProgressMsg) import GHC_Utils_Outputable (SDoc, fsep, nest, ppr, text, vcat, (<+>)) #if MIN_VERSION_ghc(9,6,0) import Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..)) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Env (hscActiveUnitId, hsc_HUG) import GHC.Unit.Env (lookupHug) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Env (hsc_HPT, hsc_units) import GHC.Iface.Recomp (CompileReason (..)) import GHC.Types.PkgQual (PkgQual (..)) import GHC.Unit.Module.Graph (ModuleGraphNode (..)) import GHC.Unit.State (pprWithUnitState) import GHC.Utils.Logger (logVerbAtLeast) import GHC.Utils.Outputable (empty) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Types_SrcLoc (UnhelpfulSpanReason (..)) #endif -- Internal import Language.Finkel.Builder import Language.Finkel.Data.SourceText import Language.Finkel.Eval import Language.Finkel.Exception import Language.Finkel.Expand (expand, expands') import Language.Finkel.Fnk import Language.Finkel.Form import Language.Finkel.Homoiconic import Language.Finkel.Make (findTargetModuleNameMaybe, makeFromRequire, makeFromRequirePlugin) import Language.Finkel.Make.Session (bcoDynFlags) import Language.Finkel.Make.TargetSource (targetSourcePath) import Language.Finkel.Syntax (parseExpr, parseLImport, parseModuleNoHeader) import Language.Finkel.Syntax.Utils -- --------------------------------------------------------------------- -- -- Quasiquote -- -- --------------------------------------------------------------------- -- Quasiquote is implemented as special form in Haskell. Though it could be -- implemented in Finkel code later. If done in Finkel code, lexer and reader -- still need to handle the special case for backtick, comma, and comma-at, -- because currently there's no way to define read macro. quasiquote :: Bool -> Code -> Code quasiquote qual orig@(LForm (L l form)) = case form of List [LForm (L _ (Atom (ASymbol ":unquote"))), x] | isUnquoteSplice x -> x | otherwise -> tList l [tSym l (toCodeS qual), x] List forms' | [q, body] <- forms' , q == tSym l ":quasiquote" -> qq (qq body) | any isUnquoteSplice forms' -> spliced qListS forms' | otherwise -> nonSpliced qListS forms' HsList forms' | any isUnquoteSplice forms' -> spliced qHsListS forms' | otherwise -> nonSpliced qHsListS forms' Atom _ -> tList l [tSym l ":quote", orig] TEnd -> orig where spliced tag forms = tList l [ tSym l (tag qual) , tList l [ tSym l (concatS qual) , tHsList l (go [] forms) ] , fname, sl, sc, el, ec ] nonSpliced tag forms = tList l [ tSym l (tag qual) , tHsList l (map qq forms) , fname, sl, sc, el, ec ] (fname, sl, sc, el, ec) = withLocInfo l (tString qq_l) (tInt qq_l) go acc forms = let (pre, post) = break isUnquoteSplice forms in case post of LForm (L ls (List (_:body))):post' -> go (acc ++ [tHsList l (map qq pre) ,tList ls [ tSym l (unquoteSpliceS qual) , tList l body]]) post' _ | null pre -> acc | otherwise -> acc ++ [tHsList l (map qq pre)] qq = quasiquote qual #if MIN_VERSION_ghc(9,0,0) qq_l = UnhelpfulSpan (UnhelpfulOther (fsLit "")) #else qq_l = UnhelpfulSpan (fsLit "") #endif isUnquoteSplice :: Code -> Bool isUnquoteSplice (LForm form) = case form of L _ (List (LForm (L _ (Atom (ASymbol ":unquote-splice"))):_)) -> True _ -> False {-# INLINABLE isUnquoteSplice #-} -- | Internally used by macro expander for @:unquote-splice@ special form. -- -- This functions throw 'InvalidUnquoteSplice' when the given argument could not -- be unquote spliced. unquoteSplice :: Homoiconic a => a -> [Code] unquoteSplice form = case unCode c of List xs -> xs HsList xs -> xs Atom AUnit -> [] Atom (AString _ xs) -> map toCode (unpackFS xs) _ -> throw (InvalidUnquoteSplice c) where c = toCode form -- --------------------------------------------------------------------- -- -- Macro -- -- --------------------------------------------------------------------- coerceMacro :: DynFlags -> Code -> Fnk Macro coerceMacro dflags name = case unCode name of Atom (ASymbol _) -> go _ -> failFnk "coerceMacro: expecting name symbol" where go = do qualify <- envQualifyQuotePrimitives <$> getFnkEnv case evalBuilder dflags qualify parseExpr [name] of Right hexpr -> unsafeCoerce# <$> evalExpr hexpr Left err -> failFnk (syntaxErrMsg err) {-# INLINABLE coerceMacro #-} -- CPP macro hack to support pattern matching with ImportListInterpretation -- introduced in ghc 9.6 to work with older version of ghc . #if !MIN_VERSION_ghc(9,6,0) #define EverythingBut True #define Exactly False #endif getTyThingsFromIDecl :: GhcMonad m => HImportDecl -> ModuleInfo -> m [TyThing] getTyThingsFromIDecl (L _ idecl) minfo = do -- 'toImportList' borrowed from local definition in -- 'TcRnDriver.tcPreludeClashWarn'. let exportedNames = modInfoExports minfo ieName' (dL->L l ie) = la2la (cL l (ieName ie)) toImportList (h, dL->L _ loc) = (h, map ieName' loc) #if MIN_VERSION_ghc(9,6,0) ideclImportList' = ideclImportList #else ideclImportList' = ideclHiding #endif getNames = case fmap toImportList (ideclImportList' idecl) of -- Import with `hiding' entities. Comparing 'Name' and 'RdrName' via -- OccName'. Just (EverythingBut, ns) -> do let f n acc = if nameOccName n `elem` ns' then acc else n : acc ns' = map (rdrNameOcc . unLoc) ns return (foldr f [] exportedNames) -- Import with explicit entities. Just (Exactly, ns) -> do hsc_env <- getSession let lkup_name = fmap toList . hscTcRnLookupRdrName hsc_env concat <$> mapM (liftIO . lkup_name) ns -- Import whole module. Nothing -> return exportedNames catMaybes <$> (getNames >>= mapM lookupName) addImportedMacro :: HscEnv -> TyThing -> Fnk () addImportedMacro hsc_env thing = go where go = case thing of AnId var -> do let name_str = showPpr dflags (varName var) name_sym = toCode (aSymbol name_str) coerceMacro dflags name_sym >>= insertMacro (fsLit name_str) _ -> failFnk "addImportedmacro" dflags = hsc_dflags hsc_env -- Note [Bytecode and object code for require and :eval_when_compile import] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- Use of object codes are not working well for importing home package modules -- when optimization option were enabled. Conservatively using bytecode by -- delegating further works to 'makeFromRequire' via 'withInternalLoad' for -- such cases. withInternalLoad :: Fnk a -> Fnk a withInternalLoad act = do -- 'DynFlags' in the current session might be updated by the file local -- pragmas. Using the 'DynFlags' from 'envDefaultDynFlags', which is -- initialized when entering the 'make' function in 'initSessionForMake' for -- ExecMode mode and 'newHscEnvForExpand' in GhcPluginMode. -- -- Updating the current context in HscEnv, to avoid home module import errors, -- which may happen when compiling with bytecode interpreter (e.g., done when -- generating Haddock documentation) in ghc 9.4.2. -- let acquire = (,,) <$> getContext <*> getDynFlags <*> getFnkEnv restore (context, dflags, fnk_env) = do setContext context setDynFlags dflags putFnkEnv fnk_env no_force_recomp = unSetGeneralFlag' Opt_ForceRecomp update = setDynFlags . no_force_recomp . bcoDynFlags bracket acquire restore $ \(_context, _dflags, fnk_env) -> do setContext [] -- XXX: Is haskell-language-server updating interactive dynflags? -- -- The envDefaultDynFlags field is initialized to the DynFlags from -- interactive context, in Language.Finkel.ParsedResult when initializing -- the plugin. mapM_ update (envDefaultDynFlags fnk_env) putFnkEnv fnk_env {envMessager = if 0 < envVerbosity fnk_env then internalLoadMessager else doNothingMessager} act internalLoadMessager :: Messager internalLoadMessager hsc_env mod_index recomp node = -- See: GHC.Driver.Main.batchMsg #if MIN_VERSION_ghc(9,4,0) case recomp of UpToDate -> when (logVerbAtLeast (hsc_logger hsc_env) 2) (showMsg (text "Skipping ") "") NeedsRecompile reason0 -> let herald = case node of LinkNode {} -> "Linking " InstantiationNode {} -> "Instantiating " ModuleNode {} -> "Compiling " in showMsg (text herald) $ case reason0 of MustCompile -> empty (RecompBecause reason1) -> let state = hsc_units hsc_env in text " [" <> pprWithUnitState state (ppr reason1) <> text "]" #else case recomp of MustCompile -> showMsg "Compiling " "" UpToDate -> when (verbosity dflags >= 2) (showMsg "Skipping " "") # if MIN_VERSION_ghc(9,2,0) RecompBecause why -> showMsg "Compiling " (" [" <> text why <> "]") # else RecompBecause why -> showMsg "Compiling " (" [" ++ why ++ "]") # endif #endif where dflags = hsc_dflags hsc_env showMsg msg reason = #if MIN_VERSION_ghc(9,4,0) compilationProgressMsg (hsc_logger hsc_env) (text "(*) " <> showModuleIndex mod_index <> msg <> showModMsg dflags (recompileRequired recomp) node <> reason) #elif MIN_VERSION_ghc(9,2,0) compilationProgressMsg (hsc_logger hsc_env) dflags (text "(*) " <> showModuleIndex mod_index <> msg <> showModMsg dflags (recompileRequired recomp) node <> reason) #else compilationProgressMsg dflags ("(*) " ++ showModuleIndex mod_index ++ msg ++ showModMsg dflags (hscTarget dflags) (recompileRequired recomp) node ++ reason) #endif doNothingMessager :: Messager doNothingMessager _hsc_env _mod_index _recomp _node = pure () makeMissingHomeMod :: HImportDecl -> Fnk () makeMissingHomeMod (L _ idecl) = do -- Try finding the required module. Delegate the work to 'makeFromRequire' -- function when the file is found in import paths. -- Look up module with "findTargetModuleNameMaybe" before "findImportedModule" -- is to avoid loading modules from own package when generating documentation -- with haddock. Always checking up-to-date ness via "makeFromRequire". -- -- N.B. 'findImportedModule' does not know ".fnk" file extension, so it will -- not return Finkel source files for home package modules. -- hsc_env <- getSession fnk_env <- getFnkEnv let mname = unLoc lmname lmname = reLoc (ideclName idecl) invoked = envInvokedMode fnk_env mk_fn = case invoked of ExecMode -> makeFromRequire -- Some attempts to get incrementally compiled home module info in ghc -- 9.6. One is to use the ModIfaceCache, another is to use hscUpdateHPT. -- -- GhcPluginMode -> \lm -> do -- -- XXX: keep old modiface cache, combine and update after calling -- -- makeFromRequirePlugin. -- old_caches <- getCachedIface -- makeFromRequirePlugin lm -- liftIO $ case envInterpModIfaceCache fnk_env of -- Just mic -> mapM_ (iface_addToCache mic) old_caches -- _ -> pure () -- -- -- let -- get the old hpt before invoking makeFromRequirePlugin ... -- -- update_hpt hpt = foldr addHomeModInfoToHpt hpt (eltsHpt old_hpt) -- -- new_hsc_env = hscUpdateHPT update_hpt hsc_env -- -- setSession new_hsc_env GhcPluginMode -> makeFromRequirePlugin smpl_mk = withInternalLoad (void $ mk_fn lmname) dflags = hsc_dflags hsc_env tr = debug fnk_env "makeMissinghomeMod" do_mk msgs = tr msgs >> smpl_mk dont_mk = tr -- XXX: See 'GHC.Driver.Make.enableCodeGenWhen', which is looking up dynflags -- from mod summary, and looking up node key from 'needs_codegen_map'. The -- 'needs_codegen_map' will filter out modules not containing TemplateHaskell -- language extension when backend does not generate codes (which means ghc -- invoked with "-fno-code" option). -- Alternate attemps to get incrementally added home modules in ghc 9.6, which -- did not work ...: -- -- mb_installed_mod <- do -- let installed_mod = mkModule (hscActiveUnitId hsc_env) mname -- FinderCache ref _ = hsc_FC hsc_env -- im_env <- liftIO (readIORef ref) -- pure (lookupInstalledModuleEnv im_env installed_mod) -- -- let by_mname ms = ms_mod_name ms == mname -- mb_installed_mod = find by_mname (mgModSummaries (hsc_mod_graph hsc_env)) let mb_installed_mod = lookupHpt (hsc_HPT hsc_env) mname case mb_installed_mod of -- When the compiler was invoked as ghc plugin, skipping compilation of home -- module when the module was found in current home package table. -- Otherwise, homeModError would be shown when loading interface file. Just _ -> case invoked of ExecMode -> do_mk ["Found" <+> ppr mname <+> "in HPT"] GhcPluginMode -> dont_mk ["Skipping" <+> ppr mname <+> "found in HPT"] _ -> do #if MIN_VERSION_ghc(9,4,0) tr ["No" <+> ppr mname <+> "in HPT"] case lookupHug (hsc_HUG hsc_env) (hscActiveUnitId hsc_env) mname of Just _ -> tr ["Found" <+> ppr mname <+> "in home unit graph"] _ -> tr ["No" <+> ppr mname <+> "in home unit graph"] #endif mb_ts <- findTargetModuleNameMaybe dflags lmname case mb_ts of Just ts -> do_mk ["Found file" <+> text (targetSourcePath ts)] Nothing -> do #if MIN_VERSION_ghc(9,4,0) let no_pkg_qual = NoPkgQual #else let no_pkg_qual = Nothing #endif fresult <- liftIO (findImportedModule hsc_env mname no_pkg_qual) case fresult of Found {} -> dont_mk ["Skipping" <+> ppr mname <+> "found in Finder"] _ -> do_mk ["Module" <+> ppr mname <+> "not found"] -- --------------------------------------------------------------------- -- -- Special forms -- -- --------------------------------------------------------------------- m_quasiquote :: MacroFunction m_quasiquote form = case unLForm form of L l (List [_,body]) -> do qualify <- fmap envQualifyQuotePrimitives getFnkEnv let LForm (L _ body') = quasiquote qualify body return (LForm (L l body')) _ -> finkelSrcError form "Malformed quasiquote" m_withMacro :: MacroFunction m_withMacro form = case unLForm form of L l1 (List (_:LForm (L _ (List forms)):rest)) -> do fnkc_env0 <- getFnkEnv hsc_env <- getSession -- Expand body of `with-macro' with temporary macros. macros <- fromList <$> evalMacroDefs hsc_env forms let tmpMacros0 = envTmpMacros fnkc_env0 putFnkEnv (fnkc_env0 {envTmpMacros = macros : tmpMacros0}) expanded <- expands' rest -- Getting 'FnkEnv' again, so that the persistent macros defined inside -- the `with-macro' body could be used from here. Then restoring tmporary -- macros to preserved value. fnkc_env1 <- getFnkEnv putFnkEnv (fnkc_env1 {envTmpMacros = tmpMacros0}) case expanded of [x] -> return x _ -> return (tList l1 (tSym l1 ":begin" : expanded)) _ -> finkelSrcError form ("with-macro: malformed args:\n" ++ show form) where evalMacroDefs hsc_env forms = do forms' <- mapM expand forms qualify <- envQualifyQuotePrimitives <$> getFnkEnv case evalBuilder (hsc_dflags hsc_env) qualify parseModuleNoHeader forms' of Right HsModule {hsmodDecls=decls} -> do (tythings, ic) <- evalDecls decls modifySession (\he -> he {hsc_IC=ic}) foldM (asMacro hsc_env) [] tythings Left err -> finkelSrcError form (syntaxErrMsg err) asMacro hsc_env acc tything = case tything of AnId var | isMacro hsc_env tything -> do let name_fs = occNameFS (occName (varName var)) name_sym = toCode (ASymbol name_fs) macro <- coerceMacro (hsc_dflags hsc_env) name_sym return ((MacroName name_fs, macro):acc) _ -> return acc m_require :: MacroFunction m_require form = -- The special form `require' modifies the HscEnv at the time of macro -- expansion, to update the context in compile time session. The `require' is -- implemented as special form, to support dependency analysis during -- compilation of multiple modules with `--make' command. -- -- Note that the form body of `require' is parsed twice, once in Reader, and -- again in this module. Parsing twice because the first parse is done before -- expanding macro, to analyse the module dependency graph of home package -- module. -- case form of LForm (L _ (List (_:code))) -> do dflags <- getDynFlags qualify <- envQualifyQuotePrimitives <$> getFnkEnv case evalBuilder dflags qualify parseLImport code of Right lidecl@(L _ idecl) -> do fnk_env <- getFnkEnv let tr = debug fnk_env "m_require" mname = unLoc (ideclName idecl) tr [ppr idecl] -- Handle home modules. makeMissingHomeMod lidecl context <- getContext tr (case context of [] -> ["Got empty context"] _ -> "Got context: " : [nest 2 (vcat (map ppr context))]) let new_context = IIDecl idecl : context tr ("Calling setContext with:" : [nest 2 (vcat (map ppr new_context))]) setContext new_context mgraph <- hsc_mod_graph <$> getSession tr ["Calling lookupModule"] mdl <- lookupModule mname Nothing -- Update required module names and compiled home modules in -- FnkEnv. These are used by the callee module (i.e. the module -- containing this 'require' form). let reqs0 = envRequiredHomeModules fnk_env reqs1 = case mgLookupModule' mgraph mdl of Just m -> m:reqs0 _ -> reqs0 modifyFnkEnv (\e -> e {envRequiredHomeModules = reqs1}) -- Look up Macros in parsed module, add to FnkEnv when found. tr ["Getting module info"] mb_minfo <- getModuleInfo mdl case mb_minfo of Just minfo -> do tr ["Getting TyThings from IDecl:" <+> ppr lidecl] things <- getTyThingsFromIDecl lidecl minfo hsc_env <- getSession let macros = filter (isMacro hsc_env) things tr ["Number of TyThings:" <+> text (show (length things))] tr ["Adding macros:", nest 2 (fsep (map ppr macros))] mapM_ (addImportedMacro hsc_env) macros return emptyForm Nothing -> finkelSrcError form ("require: module " ++ moduleNameString mname ++ " not found.") Left err -> finkelSrcError form ("require: " ++ syntaxErrMsg err) _ -> finkelSrcError form "require: malformed body" m_evalWhenCompile :: MacroFunction m_evalWhenCompile form = case unLForm form of L l (List (_ : body)) -> do expanded <- expands' body dflags <- getDynFlags qualify <- envQualifyQuotePrimitives <$> getFnkEnv case evalBuilder dflags qualify parseModuleNoHeader expanded of Right HsModule { hsmodDecls = decls , hsmodImports = limps } -> do -- If module imports were given, add to current interactive context. -- Compile home modules if not found. unless (null limps) $ do mapM_ makeMissingHomeMod limps context <- getContext setContext (map (IIDecl . unLoc) limps ++ context) -- Then evaluate the declarations and set the interactive context with -- the update `tythings'. If the compiled decls contain macros, add -- to current Finkel environment. unless (null decls) $ do (tythings, ic) <- evalDecls decls modifySession (\hsc_env -> hsc_env {hsc_IC=ic}) fnk_env <- getFnkEnv hsc_env <- getSession let macros = filter (isMacro hsc_env) tythings debug fnk_env "m_evalWhenCompile" ["Adding macros:", nest 2 (fsep (map ppr macros))] mapM_ (addImportedMacro hsc_env) macros return emptyForm Left err -> finkelSrcError (LForm (L l (List body))) (syntaxErrMsg err) _ -> finkelSrcError form ("eval-when-compile: malformed body: " ++ show form) -- | The special forms. The macros listed in 'specialForms' are used -- in default 'FnkEnv'. specialForms :: EnvMacros specialForms = makeEnvMacros [(":eval-when-compile", SpecialForm m_evalWhenCompile) ,(":with-macro", SpecialForm m_withMacro) ,(":quasiquote", SpecialForm m_quasiquote) ,(":require", SpecialForm m_require)] -- | Default 'FnkEnv'. defaultFnkEnv :: FnkEnv defaultFnkEnv = emptyFnkEnv { envMacros = specialForms , envDefaultMacros = specialForms } -- --------------------------------------------------------------------- -- -- Auxiliary -- -- --------------------------------------------------------------------- tSym :: SrcSpan -> FastString -> Code tSym l s = LForm (L l (Atom (ASymbol s))) {-# INLINABLE tSym #-} tString :: SrcSpan -> FastString -> Code tString l s = LForm (L l (Atom (AString (toQuotedSourceText s) s))) {-# INLINABLE tString #-} tInt :: SrcSpan -> Int -> Code tInt l i = LForm (L l (Atom (AInteger (mkIntegralLit i)))) {-# INLINABLE tInt #-} tList :: SrcSpan -> [Code] -> Code tList l forms = LForm (L l (List forms)) {-# INLINABLE tList #-} tHsList :: SrcSpan -> [Code] -> Code tHsList l forms = LForm (L l (HsList forms)) {-# INLINABLE tHsList #-} emptyForm :: Code emptyForm = LForm (genSrc (List [LForm (genSrc (Atom (ASymbol ":begin")))])) {-# INLINABLE emptyForm #-} toCodeS :: Quote toCodeS = quoteWith "toCode" {-# INLINABLE toCodeS #-} unquoteSpliceS :: Quote unquoteSpliceS = quoteWith "unquoteSplice" {-# INLINABLE unquoteSpliceS #-} concatS :: Quote concatS qual = if qual then "Data.Foldable.concat" else "concat" {-# INLINABLE concatS #-} -- | Debug function for this module debug :: (MonadIO m, HasDynFlags m) => FnkEnv -> SDoc -> [SDoc] -> m () debug fnk_env _fn = debugWhen fnk_env Fnk_trace_spf mgLookupModule' :: ModuleGraph -> Module -> Maybe ModSummary #if MIN_VERSION_ghc (8,4,0) mgLookupModule' = mgLookupModule #else mgLookupModule' mg mdl = go mg where go [] = Nothing go (ms:mss) = if ms_mod ms == mdl then Just ms else go mss #endif ================================================ FILE: finkel-kernel/src/Language/Finkel/Syntax/Extension.hs ================================================ {-# LANGUAGE CPP #-} -- | Modul for extenson field in Haskell AST. -- -- This module condains type class and instances for extension field in Haskell -- AST. It seemed better to create dedicated specific class for ignored -- extension field. -- module Language.Finkel.Syntax.Extension ( Unused(..) ) where #if MIN_VERSION_ghc(9,10,0) import GHC.Hs.Binds (AnnSig (..), NamespaceSpecifier (..)) import GHC.Hs.Expr (AnnsIf, EpAnnHsCase (..)) import GHC.Parser.Annotation (AddEpAnn (..), AnnList (..), AnnParen (..), EpLayout (..), EpToken (..), EpUniToken (..), NoAnn (..)) #elif MIN_VERSION_ghc(9,2,0) import GHC.Parser.Annotation (SrcSpanAnn' (..)) import GHC.Types.SrcLoc (noSrcSpan) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Parser.Annotation (AnnSortKey (..), EpAnn (..), EpAnnComments (..)) import Language.Haskell.Syntax.Extension (NoExtField (..), noExtField) #else import GHC.Hs.Extension (NoExtField (..), noExtField) #endif -- | Type class to represent field value which is not in use. class Unused a where -- | Unused value for extension field in AST data types. unused :: a #if MIN_VERSION_ghc(9,10,0) instance Unused (AnnSortKey tag) where unused = NoAnnSortKey {-# INLINE unused #-} instance Unused NamespaceSpecifier where unused = NoNamespaceSpecifier {-# INLINE unused #-} instance Unused EpLayout where unused = EpNoLayout {-# INLINE unused #-} instance NoAnn a => Unused (EpAnn a) where unused = noAnn {-# INLINE unused #-} instance Unused AddEpAnn where unused = noAnn {-# INLINE unused #-} instance Unused AnnList where unused = noAnn {-# INLINE unused #-} instance Unused AnnParen where unused = noAnn {-# INLINE unused #-} instance Unused AnnSig where unused = noAnn {-# INLINE unused #-} instance Unused (EpToken s) where unused = noAnn {-# INLINE unused #-} instance Unused (EpUniToken s t) where unused = noAnn {-# INLINE unused #-} instance Unused EpAnnHsCase where unused = noAnn {-# INLINE unused #-} instance Unused AnnsIf where unused = noAnn {-# INLINE unused #-} #elif MIN_VERSION_ghc(9,2,0) instance Unused (EpAnn a) where unused = EpAnnNotUsed {-# INLINE unused #-} instance Unused a => Unused (SrcSpanAnn' a) where unused = SrcSpanAnn {ann = unused, locA = noSrcSpan} {-# INLINE unused #-} instance Unused AnnSortKey where unused = NoAnnSortKey {-# INLINE unused #-} #endif #if MIN_VERSION_ghc(9,2,0) instance Unused EpAnnComments where unused = EpaComments {priorComments = []} {-# INLINE unused #-} instance Unused a => Unused [a] where unused = [] {-# INLINE unused #-} #endif instance Unused NoExtField where unused = noExtField {-# INLINE unused #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Syntax/HBind.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} -- | Syntax for binds. module Language.Finkel.Syntax.HBind where #include "ghc_modules.h" -- ghc import GHC_Data_Bag (listToBag) import GHC_Data_OrdList (toOL) import GHC_Hs_Binds (FixitySig (..), HsBind, HsBindLR (..), HsLocalBindsLR (..), HsValBindsLR (..), Sig (..), emptyLocalBinds) import GHC_Hs_Decls (HsDecl (..)) import GHC_Hs_Expr (GRHSs (..), LGRHS) import qualified GHC_Parser_PostProcess as PostProcess import GHC_Types_Fixity (Fixity) import GHC_Types_Name_Reader (RdrName) import GHC_Types_SrcLoc (GenLocated (..)) #if MIN_VERSION_ghc(9,10,0) import GHC_Hs_Binds (HsMultAnn (..)) #endif #if !MIN_VERSION_ghc(9,2,0) import GHC_Types_SrcLoc (SrcSpan) #endif -- Internal import Language.Finkel.Builder import Language.Finkel.Syntax.Utils mkPatBind_compat :: HPat -> [HGRHS] -> [HDecl] -> HsBind PARSED mkPatBind_compat (dL->L l pat) grhss decls = PatBind { pat_lhs = cL l pat , pat_rhs = mkGRHSs grhss decls l #if MIN_VERSION_ghc(9,10,0) -- XXX: Does not support HsMultAnn. , pat_mult = HsNoMultAnn unused #endif -- XXX: From ghc 9.6 (8.6?), the `pat_ext' field is used for holding -- former `pat_ticks' information. , pat_ext = unused #if !MIN_VERSION_ghc(9,6,0) , pat_ticks = ([], []) #endif } {-# INLINABLE mkPatBind_compat #-} mkHsValBinds :: HBinds -> [HSig] -> HsLocalBindsLR PARSED PARSED mkHsValBinds binds sigs = HsValBinds unused (ValBinds unused binds sigs) {-# INLINABLE mkHsValBinds #-} #if MIN_VERSION_ghc(9,2,0) mkGRHSs :: [LGRHS PARSED t] -> [HDecl] -> a -> GRHSs PARSED t #else mkGRHSs :: [LGRHS PARSED t] -> [HDecl] -> SrcSpan -> GRHSs PARSED t #endif mkGRHSs grhss decls l = GRHSs unused grhss (declsToBinds l decls) {-# INLINABLE mkGRHSs #-} -- | Build 'HLocalBinds' from list of 'HDecl's. #if MIN_VERSION_ghc(9,2,0) declsToBinds :: a -> [HDecl] -> HLocalBinds declsToBinds _ decls = binds' #else declsToBinds :: SrcSpan -> [HDecl] -> HLocalBinds declsToBinds l decls = L l binds' #endif where binds' = case decls of [] -> emptyLocalBinds _ -> mkHsValBinds (listToBag binds) sigs -- Using 'PostProcess.cvTopDecls' to group same names in where -- clause. Perhaps better to do similar things done in -- 'PostProcess.cvBindGroup', which is dedicated for 'P' monad ... decls' = PostProcess.cvTopDecls (toOL decls) (binds, sigs) = go ([],[]) decls' go (bs,ss) ds = case ds of [] -> (bs, ss) d:ds' -> case d of L ld (ValD _ b) -> go (L ld b:bs,ss) ds' L ld (SigD _ s) -> go (bs,L ld s:ss) ds' -- XXX: Ignoring. _ -> go (bs,ss) ds' {-# INLINABLE declsToBinds #-} mkFixSig :: [LocatedN RdrName] -> Fixity -> Sig PARSED -- XXX: Does not support NamespaceSpecifier. mkFixSig lnames fixity = FixSig unused (FixitySig unused lnames fixity) {-# INLINABLE mkFixSig #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Syntax/HDecl.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | Syntax for declaration. module Language.Finkel.Syntax.HDecl where #include "ghc_modules.h" -- base import Data.Maybe (fromMaybe) -- ghc import GHC_Core_DataCon (SrcStrictness (..)) import GHC_Data_FastString (FastString, unpackFS) import GHC_Data_OrdList (toOL) import GHC_Hs_Binds (Sig (..)) import GHC_Hs_Decls (ClsInstDecl (..), ConDecl (..), DataFamInstDecl (..), DefaultDecl (..), DerivDecl (..), DerivStrategy (..), DocDecl (..), FamEqn (..), FamilyDecl (..), FamilyInfo (..), FamilyResultSig (..), ForeignDecl (..), ForeignExport (..), HsDataDefn (..), HsDecl (..), HsDerivingClause (..), InstDecl (..), LTyFamDefltDecl, TyClDecl (..), TyFamInstDecl (..), TyFamInstEqn) import GHC_Hs_Doc (LHsDocString) import GHC_Hs_Expr (HsMatchContext (..), Match (..)) import GHC_Hs_Pat (Pat (..)) import GHC_Hs_Type (ConDeclField (..), HsArg (..), HsConDetails (..), HsTyVarBndr (..), HsType (..), HsWildCardBndrs (..), mkFieldOcc, mkHsQTvs) import GHC_Hs_Utils (mkClassOpSigs, mkFunBind) import GHC_Parser_Lexer (P (..), ParseResult (..)) import GHC_Parser_PostProcess (mkConDeclH98, mkGadtDecl, mkInlinePragma, mkStandaloneKindSig, parseCImport) import GHC_Types_Basic (Activation (..), InlineSpec (..), Origin (..), OverlapMode (..), PhaseNum, RuleMatchInfo (..)) import GHC_Types_Fixity (Fixity (..), FixityDirection (..), LexicalFixity (..)) import GHC_Types_ForeignCall (CCallConv (..), CExportSpec (..), Safety (..)) import GHC_Types_Name_Occurrence (dataName, tcName) import GHC_Types_Name_Reader (RdrName, mkUnqual) import GHC_Types_SrcLoc (GenLocated (..), Located, getLoc, noLoc, unLoc) #if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0) import GHC.Parser.PostProcess (mkTokenLocation) import Language.Haskell.Syntax.Concrete (HsUniToken (..)) #endif #if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0) import Language.Haskell.Syntax.Concrete (LayoutInfo (..)) #elif !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,0,0) import GHC_Types_SrcLoc (LayoutInfo (..)) #endif #if MIN_VERSION_ghc(9,8,0) import GHC.Data.FastString (fsLit) import Language.Haskell.Syntax.Type (HsBndrVis (..)) #endif #if MIN_VERSION_ghc(9,6,0) import Language.Haskell.Syntax.Decls (DataDefnCons (..)) #endif #if MIN_VERSION_ghc(9,6,0) import Language.Haskell.Syntax.Decls (NewOrData (..)) #else import GHC_Hs_Decls (NewOrData (..)) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Hs.Doc (LHsDoc) import GHC.Hs.DocString (HsDocStringDecorator (..)) import GHC.Parser.Annotation (l2l) #endif #if MIN_VERSION_ghc(9,2,0) import GHC_Hs_Decls (DerivClauseTys (..), XViaStrategyPs (..)) import GHC_Hs_Type (mkHsOuterImplicit) import GHC_Hs_Utils (hsTypeToHsSigType, hsTypeToHsSigWcType) import GHC_Parser_Annotation (AnnSortKey (..)) import GHC_Types_Basic (TopLevelFlag (..)) #else import GHC_Hs_Type (mkHsImplicitBndrs) import GHC_Hs_Utils (mkLHsSigType, mkLHsSigWcType) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Hs_Type (LHsTyVarBndr, hsLinear) import GHC_Types_Var (Specificity (..)) #endif -- Internal import Language.Finkel.Builder import Language.Finkel.Data.SourceText import Language.Finkel.Form import Language.Finkel.Syntax.HBind import Language.Finkel.Syntax.HType import Language.Finkel.Syntax.Utils -- --------------------------------------------------------------------- -- -- Declarations -- -- --------------------------------------------------------------------- b_dataD :: Code -> (FastString, [HTyVarBndrVis], Maybe HKind) -> (HDeriving, [HConDecl]) -> HDecl b_dataD = mkNewtypeOrDataD DataType {-# INLINABLE b_dataD #-} b_newtypeD :: Code -> (FastString, [HTyVarBndrVis], Maybe HKind) -> (HDeriving, [HConDecl]) -> HDecl b_newtypeD = mkNewtypeOrDataD NewType {-# INLINABLE b_newtypeD #-} mkNewtypeOrDataD :: NewOrData -> Code -> (FastString, [HTyVarBndrVis], Maybe HKind) -> (HDeriving, [HConDecl]) -> HDecl mkNewtypeOrDataD newOrData (LForm (L l _)) (name, tvs, ksig) (derivs, cs) = lA l (tyClD decl) where decl = DataDecl { tcdLName = lN l (mkUnqual tcName name) , tcdFixity = Prefix , tcdTyVars = mkHsQTvs tvs , tcdDataDefn = defn , tcdDExt = unused } defn = HsDataDefn { dd_cType = Nothing #if !MIN_VERSION_ghc(9,6,0) , dd_ND = newOrData #endif #if MIN_VERSION_ghc(9,2,0) , dd_ctxt = Nothing #else , dd_ctxt = noLoc [] #endif , dd_kindSig = ksig , dd_cons = condecls , dd_derivs = derivs , dd_ext = unused } #if MIN_VERSION_ghc(9,6,0) condecls = case newOrData of NewType | c:_ <- cs -> NewTypeCon c DataType -> DataTypeCons False cs -- XXX: Not sure reaching below is possible. _ -> error "mkNewTypeOrDataD:condecls" #else condecls = cs #endif {-# INLINABLE mkNewtypeOrDataD #-} b_typeD :: Code -> (FastString, [HTyVarBndrVis], Maybe HKind) -> HType -> HDecl b_typeD (LForm (L l _)) (name, tvs, _) ty = lA l (tyClD synonym) where synonym = SynDecl { tcdLName = lN l (mkUnqual tcName name) , tcdFixity = Prefix , tcdTyVars = mkHsQTvs tvs , tcdRhs = ty , tcdSExt = unused } {-# INLINABLE b_typeD #-} b_standaloneKindSigD :: Code -> (FastString, [a], Maybe HKind) -> Builder HDecl b_standaloneKindSigD (LForm (L l _)) (name, _tvs, mb_knd) = do -- StandaloneKindSignature is not supported in ghc < 8.10. Also the arguments -- of "mkStandaloneKindSig" differ from ghc 9.0.x to ghc 9.2.x. #if MIN_VERSION_ghc(9,2,0) knd <- maybe builderError (pure . hsTypeToHsSigType) mb_knd let sigP = mkStandaloneKindSig l (L l [lN l (mkRdrName name)]) knd [] #else knd <- maybe builderError pure mb_knd let sigP = mkStandaloneKindSig l (L l [lN l (mkRdrName name)]) knd #endif ps <- fmap ghcPState getBState case unP sigP ps of POk _ sig -> pure (lA l (KindSigD unused (unLoc sig))) PFailed _ -> builderError b_conD :: Code -> HConDeclH98Details -> Builder HConDecl b_conD form@(LForm (L l _)) details = do name <- getConId form let name' = lN l (mkUnqual dataName name) cxt = Nothing #if MIN_VERSION_ghc(9,2,0) pure (lA l (mkConDeclH98 unused name' Nothing cxt details)) #else pure (L l (mkConDeclH98 name' Nothing cxt details)) #endif {-# INLINABLE b_conD #-} b_qtyconD :: (HConDecl, [HType]) -> HConDecl b_qtyconD (whole@(L l decl), tys) = case tys of [] -> whole #if MIN_VERSION_ghc(9,10,0) _ -> L l (decl { con_mb_cxt = Just (mkLocatedListA tys) }) #else _ -> L l (decl { con_mb_cxt = Just (la2la (mkLocatedListA tys)) }) #endif {-# INLINABLE b_qtyconD #-} #if MIN_VERSION_ghc(9,0,0) b_forallD :: [LHsTyVarBndr Specificity PARSED] -> (HConDecl, [HType]) -> Builder HConDecl #else b_forallD :: [HTyVarBndr] -> (HConDecl, [HType]) -> Builder HConDecl #endif b_forallD vars (L l cdecl@ConDeclH98{}, cxts) = pure d where d = L l cdecl { con_ex_tvs = vars #if MIN_VERSION_ghc(9,2,0) , con_forall = True #else , con_forall = noLoc True #endif #if MIN_VERSION_ghc(9,10,0) , con_mb_cxt = Just (mkLocatedListA cxts) #else , con_mb_cxt = Just (la2la (mkLocatedListA cxts)) #endif } b_forallD _ _ = builderError {-# INLINABLE b_forallD #-} b_gadtD :: Code -> ([HType], HType) -> Builder HConDecl b_gadtD form@(LForm (L l1 _)) (ctxt, bodyty) = do name <- getConId form let name' = pure $ lN l1 (mkUnqual dataName name) #if MIN_VERSION_ghc(9,0,0) -- Removing parentheses of the body type, so that the 'mkGadtDecl' can -- split the internal elements. Parentheses are added to the body of GADT -- when it is HsForAllTy, to support documentation string. ty = case qty of HsParTy _ unpar_ty -> unpar_ty _ -> lA l1 qty #else ty = lA l1 qty #endif #if MIN_VERSION_ghc(9,10,0) qty = mkHsQualTy' (mkLocatedListA ctxt) bodyty #else qty = mkHsQualTy' (la2la (mkLocatedListA ctxt)) bodyty #endif #if MIN_VERSION_ghc(9,10,0) ldecl <- do ps <- fmap ghcPState getBState case unP (mkGadtDecl l1 name' unused (hsTypeToHsSigType ty)) ps of POk _ d -> pure d _ -> builderError #elif MIN_VERSION_ghc(9,6,0) ldecl <- do ps <- fmap ghcPState getBState let dcolon = L (mkTokenLocation l1) HsNormalTok case unP (mkGadtDecl l1 name' dcolon (hsTypeToHsSigType ty)) ps of POk _ d -> pure d _ -> builderError #elif MIN_VERSION_ghc(9,2,0) ldecl <- do ps <- fmap ghcPState getBState case unP (mkGadtDecl l1 name' (hsTypeToHsSigType ty) []) ps of POk _ d -> pure d _ -> builderError #elif MIN_VERSION_ghc(9,0,0) ldecl <- do ps <- fmap ghcPState getBState case unP (mkGadtDecl name' ty) ps of POk _ d -> pure (L l1 (fst d)) _ -> builderError #else let ldecl = L l1 (fst (mkGadtDecl name' ty)) #endif return ldecl {-# INLINABLE b_gadtD #-} b_conOnlyD :: Code -> Builder HConDecl b_conOnlyD name = b_conD name pcon where #if MIN_VERSION_ghc(9,2,0) pcon = PrefixCon [] [] #else pcon = PrefixCon [] #endif {-# INLINABLE b_conOnlyD #-} -- XXX: Infix data constructor not supported. -- XXX: Does not support liner types and unicode syntax (ghc >= 9.0) b_conDeclDetails :: [HType] -> HConDeclH98Details #if MIN_VERSION_ghc(9,2,0) b_conDeclDetails = PrefixCon [] . map (hsLinear . parTyApp) #elif MIN_VERSION_ghc(9,0,0) b_conDeclDetails = PrefixCon . map (hsLinear . parTyApp) #else b_conDeclDetails = PrefixCon . map parTyApp #endif {-# INLINABLE b_conDeclDetails #-} b_recFieldsD :: [HConDeclField] -> HConDeclH98Details #if MIN_VERSION_ghc(9,10,0) b_recFieldsD = RecCon . mkLocatedListA #else b_recFieldsD = RecCon . la2la . mkLocatedListA #endif {-# INLINABLE b_recFieldsD #-} b_recFieldD :: Maybe LHsDocString -> ([Code], HType) -> Builder HConDeclField b_recFieldD mb_doc (names, ty) = do let f (LForm (L l form)) = case form of Atom (ASymbol name) -> #if MIN_VERSION_ghc(9,4,0) return (reLocA (L l (mkFieldOcc (lN l (mkRdrName name))))) #else return (L l (mkFieldOcc (lN l (mkRdrName name)))) #endif _ -> builderError let mb_doc' = fmap lHsDocString2LHsDoc mb_doc names' <- mapM f names let field = ConDeclField { cd_fld_names = names' , cd_fld_ext = unused , cd_fld_type = ty , cd_fld_doc = mb_doc' } loc = getLoc (mkLocatedForm names) return (lA loc field) {-# INLINABLE b_recFieldD #-} b_derivD :: Maybe HDerivStrategy -> [HType] -> HDeriving b_derivD mb_strat tys = hds where #if MIN_VERSION_ghc(9,4,0) hds = [la2la (L l dc)] clauses = la2la (L l (DctMulti unused (map hsTypeToHsSigType tys))) #elif MIN_VERSION_ghc(9,2,0) hds = [reLoc (L l dc)] clauses = la2la (L l (DctMulti unused (map hsTypeToHsSigType tys))) #else hds = L l [L l dc] clauses = L l (map hsTypeToHsSigType tys) #endif dc = HsDerivingClause unused mb_strat clauses l = getLoc (mkLocatedListA' tys) {-# INLINABLE b_derivD #-} b_derivsD :: HDeriving -> HDeriving -> HDeriving #if MIN_VERSION_ghc(9,2,0) b_derivsD new acc = new ++ acc #else b_derivsD (dL->L _ new) (dL->L _ acc) = mkLocatedList (new ++ acc) #endif {-# INLINABLE b_derivsD #-} b_emptyDeriving :: HDeriving #if MIN_VERSION_ghc(9,2,0) b_emptyDeriving = [] #else b_emptyDeriving = noLoc [] #endif {-# INLINABLE b_emptyDeriving #-} b_viaD :: HType -> Builder (Maybe HDerivStrategy) #if MIN_VERSION_ghc(9,4,0) b_viaD ty@(L l _) = pure (Just (L (l2l l) (ViaStrategy (XViaStrategyPs unused sig)))) where sig = hsTypeToHsSigType ty #elif MIN_VERSION_ghc(9,2,0) b_viaD ty@(L l _) = pure (Just (reLoc (L l (ViaStrategy (XViaStrategyPs unused sig))))) where sig = hsTypeToHsSigType ty #else b_viaD ty@(dL->L l _) = pure (Just (lA l (ViaStrategy (hsTypeToHsSigType ty)))) #endif {-# INLINABLE b_viaD #-} b_standaloneD :: Maybe HDerivStrategy -> Maybe (Located OverlapMode) -> HType -> HDecl b_standaloneD mb_strategy mb_overlap ty0@(dL-> L l _) = L l (DerivD unused dd) where #if MIN_VERSION_ghc(9,10,0) -- XXX: Does not support WarningTxt. dd = DerivDecl (Nothing, unused) ty1 mb_strategy mb_overlap' #else dd = DerivDecl unused ty1 mb_strategy mb_overlap' #endif mb_overlap' = fmap reLocA mb_overlap ty1 = hsTypeToHsSigWcType ty0 {-# INCLUDE b_standaloneD #-} b_classD :: ([HType],HType) -> [HDecl] -> Builder HDecl b_classD (tys,ty) decls = do cd <- cvBindsAndSigs (toOL decls) let #if MIN_VERSION_ghc(9,10,0) userTV = UserTyVar unused (HsBndrRequired unused) kindedTV = KindedTyVar unused (HsBndrRequired unused) #elif MIN_VERSION_ghc(9,8,0) -- XXX: Does not support HsBndrInvisible userTV = UserTyVar unused HsBndrRequired kindedTV = KindedTyVar unused HsBndrRequired #elif MIN_VERSION_ghc(9,0,0) userTV = UserTyVar unused () kindedTV = KindedTyVar unused () #else userTV = UserTyVar unused kindedTV = KindedTyVar unused #endif -- Recursing in `HsAppTy' to support MultiParamTypeClasses. let unAppTy t = case t of L l (HsTyVar _ _ n) -> return (l, n, [L l (userTV n)]) L _ (HsAppTy _ t1 v) -> do (l1, n1, vs1) <- unAppTy t1 (_, _, vs2) <- unAppTy v return (l1, n1, vs2 ++ vs1) L _ (HsParTy _ t') -> unAppTy t' L l1 (HsKindSig _ t1 k) -> do (_, n, _) <- unAppTy t1 return (l1, n, [L l1 (kindedTV n k)]) _ -> builderError atdefs <- cd2atdefs cd (l, name, bndrs) <- unAppTy ty -- Note that the `bndrs' are gathered from left to right, -- re-ordering with reverse and removing the duplicated head at this -- point. bndrs' <- case reverse bndrs of [] -> builderError _:tl -> pure tl #if MIN_VERSION_ghc(9,10,0) let tcd_ctxt | null tys = Nothing | otherwise = Just (mkLocatedListA tys) #elif MIN_VERSION_ghc(9,2,0) let tcd_ctxt | null tys = Nothing | otherwise = Just (la2la (mkLocatedListA tys)) #else let tcd_ctxt = mkLocatedList tys #endif #if MIN_VERSION_ghc(9,10,0) let tcd_cext = (unused, unused, NoAnnSortKey) #elif MIN_VERSION_ghc(9,6,0) let tcd_cext = (unused, NoAnnSortKey) #elif MIN_VERSION_ghc(9,2,0) let tcd_cext = (unused, NoAnnSortKey, NoLayoutInfo) #elif MIN_VERSION_ghc(9,0,0) let tcd_cext = NoLayoutInfo #else let tcd_cext = unused #endif let cls = ClassDecl { tcdLName = name #if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0) , tcdLayout = NoLayoutInfo #endif , tcdCtxt = tcd_ctxt , tcdFixity = Prefix , tcdTyVars = mkHsQTvs bndrs' , tcdFDs = [] , tcdSigs = mkClassOpSigs (cd_sigs cd) , tcdMeths = cd_binds cd , tcdATs = cd_fds cd , tcdATDefs = atdefs , tcdDocs = cd_docs cd , tcdCExt = tcd_cext } return (L l (tyClD cls)) {-# INLINABLE b_classD #-} b_instD :: Maybe (Located OverlapMode) -> ([HType], HType) -> [HDecl] -> Builder HDecl b_instD mb_overlap (ctxts,ty@(L l _)) decls = do cd <- cvBindsAndSigs (toOL decls) let decl = ClsInstDecl { cid_poly_ty = hsTypeToHsSigType qty , cid_binds = cd_binds cd , cid_sigs = mkClassOpSigs (cd_sigs cd) , cid_tyfam_insts = cd_tfis cd , cid_datafam_insts = cd_dfis cd , cid_overlap_mode = fmap reLocA mb_overlap #if MIN_VERSION_ghc(9,10,0) -- XXX: Does not support WarningTxt , cid_ext = (Nothing, unused, NoAnnSortKey) #elif MIN_VERSION_ghc(9,2,0) , cid_ext = (unused, NoAnnSortKey) #else , cid_ext = unused #endif } #if MIN_VERSION_ghc(9,10,0) qty = L l (mkHsQualTy' (mkLocatedListA ctxts) ty) #else qty = L l (mkHsQualTy' (la2la (mkLocatedListA ctxts)) ty) #endif instD = InstD unused clsInstD = ClsInstD unused return (L l (instD (clsInstD decl))) {-# INLINABLE b_instD #-} b_datafamD :: Code -> (FastString, [HTyVarBndrVis], Maybe HType) -> HDecl b_datafamD = mkFamilyDecl DataFamily {-# INLINABLE b_datafamD #-} b_tyfamD :: [(Located FastString, [HType], HType)] -> Code -> (FastString, [HTyVarBndrVis], Maybe HType) -> HDecl b_tyfamD insts = if null insts then mkFamilyDecl OpenTypeFamily else mkFamilyDecl (ClosedTypeFamily (Just tfies)) where tfies = map f insts f (L l name, argtys, ty) = let rname = L l (mkUnqual tcName name) in lA l (mkTyFamInstEqn rname argtys ty) {-# INLINABLE b_tyfamD #-} -- See: "RdrHsSyn.mkFamDecl" and 'Convert.cvtDec'. mkFamilyDecl :: FamilyInfo PARSED -> Code -> (FastString, [HTyVarBndrVis], Maybe HType) -> HDecl mkFamilyDecl finfo (LForm (L l _)) (name, bndrs, mb_kind) = let fam = FamilyDecl { fdInfo = finfo , fdLName = lname , fdTyVars = hsqtyvars , fdFixity = Prefix #if MIN_VERSION_ghc(9,4,0) , fdResultSig = reLocA (L l rsig) #else , fdResultSig = L l rsig #endif , fdInjectivityAnn = Nothing , fdExt = unused #if MIN_VERSION_ghc(9,2,0) -- XXX: When to use 'NotTopLevel'? , fdTopLevel = TopLevel #endif } lname = lN l (mkUnqual tcName name) hsqtyvars = mkHsQTvs bndrs -- XXX: Does not support 'TyVarsig'. rsig = maybe (NoSig unused) (KindSig unused) mb_kind in lA l (TyClD unused (FamDecl unused fam)) {-# INLINABLE mkFamilyDecl #-} b_dfltSigD :: HDecl -> Builder HDecl b_dfltSigD (dL->L l decl) = case decl of SigD _ (TypeSig _ ids ty) -> return (cL l (sigD (ClassOpSig unused True ids (hswc_body ty)))) _ -> builderError {-# INLINABLE b_dfltSigD #-} -- See: "Convert.cvtDec". b_datainstD :: Code -> (Located FastString, [HType], Maybe HType) -> (HDeriving, [HConDecl]) -> HDecl b_datainstD = mk_data_or_newtype_instD DataType {-# INLINABLE b_datainstD #-} b_newtypeinstD :: Code -> (Located FastString, [HType], Maybe HType) -> (HDeriving, [HConDecl]) -> HDecl b_newtypeinstD = mk_data_or_newtype_instD NewType {-# INCLUDE b_newtypeinsD #-} mk_data_or_newtype_instD :: NewOrData -> Code -> (Located FastString, [HType], Maybe HType) -> (HDeriving, [HConDecl]) -> HDecl mk_data_or_newtype_instD new_or_data (LForm (L l _)) (L ln name, pats, mb_kind) (deriv, condecls) = let faminst = DataFamInstD { dfid_inst = inst , dfid_ext = unused } -- XXX: Contexts and kind signatures not supported. rhs = HsDataDefn { dd_cType = Nothing #if !MIN_VERSION_ghc(9,6,0) , dd_ND = new_or_data #endif #if MIN_VERSION_ghc(9,2,0) , dd_ctxt = Nothing #else , dd_ctxt = L l [] #endif , dd_kindSig = mb_kind , dd_cons = condecls' , dd_derivs = deriv , dd_ext = unused } tycon = L ln (mkUnqual tcName name) inst = mkDataFamInstDecl tycon pats rhs #if MIN_VERSION_ghc(9,6,0) condecls' = case new_or_data of NewType | c:_ <- condecls -> NewTypeCon c DataType -> DataTypeCons False condecls -- XXX: Again, not sure reaching below is possible. _ -> error "mk_data_or_newtype_instD:condecls'" #else condecls' = condecls #endif in lA l (InstD unused faminst) {-# INLINABLE mk_data_or_newtype_instD #-} b_tyinstD :: Code -> (Located FastString, [HType]) -> HType -> HDecl b_tyinstD (LForm (L l _)) (L ln name, pats) rhs = let rname = L ln (mkUnqual tcName name) inst = mkTyFamInstEqn rname pats rhs tyfaminstD = TyFamInstD unused tfid #if MIN_VERSION_ghc(9,2,0) tfid = TyFamInstDecl unused inst #else tfid = TyFamInstDecl inst #endif in lA l (InstD unused tyfaminstD) {-# INLINABLE b_tyinstD #-} b_overlapP :: Code -> Builder (Maybe (Located OverlapMode)) b_overlapP (LForm (L _ (List [LForm (L l (Atom (ASymbol mode)))]))) = pure $ case mode of "OVERLAPPABLE" -> pragma Overlappable "OVERLAPPING" -> pragma Overlapping "OVERLAPS" -> pragma Overlaps "INCOHERENT" -> pragma Incoherent _ -> Nothing where pragma con = Just (L l (con stxt)) -- XXX: Adding extra pragma comment header to support translation to -- Haskell source code. #if MIN_VERSION_ghc(9,8,0) stxt = SourceText (fsLit "{-# " <> mode) #else stxt = SourceText ("{-# " ++ unpackFS mode) #endif b_overlapP _ = builderError {-# INLINABLE b_overlapP #-} b_qtyclC :: [HType] -> Builder ([HType], HType) b_qtyclC ts = case ts of [] -> builderError _ -> case splitAt (length ts - 1) ts of (ctxt, [t]) -> return (ctxt, t) _ -> builderError {-# INLINABLE b_qtyclC #-} b_defaultD :: [HType] -> HDecl b_defaultD types = L l (defD (defaultDecl types)) where l = getLoc (mkLocatedListA types) defD = DefD unused defaultDecl = DefaultDecl unused {-# INLINABLE b_defaultD #-} b_fixityD :: FixityDirection -> Code -> [Code] -> Builder HDecl b_fixityD dir (LForm (L l form)) syms = case form of Atom (AInteger IL {il_value=n}) -> do let lname (LForm (L l0 x)) = case x of Atom (ASymbol name) -> return (lN l0 (mkRdrName name)) _ -> builderError fixity = Fixity dir' (fromIntegral n) dir dir' = case dir of InfixL -> strToSourceText "infixl" InfixR -> strToSourceText "infixr" InfixN -> strToSourceText "infix" names <- mapM lname syms return (lA l (sigD (mkFixSig names fixity))) _ -> builderError {-# INLINABLE b_fixityD #-} b_ffiD :: Code -> Code -> HCCallConv -> Maybe (Located Safety) -> Code -> (Code, HType) -> Builder HDecl b_ffiD (LForm (L l _)) imp_or_exp ccnv mb_safety ename (nm, ty) | LForm (L ln (Atom (ASymbol name))) <- nm , LForm (L _ls (Atom (AString _ ename'_fs))) <- ename = let lname = reLocA (L ln (mkRdrName name)) tsig = hsTypeToHsSigType ty ename' = unpackFS ename'_fs source = case ename' of "" -> L l NoSourceText _ -> L l (toQuotedSourceText ename'_fs) #if MIN_VERSION_ghc(9,10,0) safety = reLoc $ fromMaybe (noLoc PlaySafe) mb_safety ccnv' = reLoc ccnv #else safety = fromMaybe (noLoc PlaySafe) mb_safety ccnv' = ccnv #endif forD = ForD unused in case unCode imp_or_exp of Atom (ASymbol ie) | ie == "import" , Just ispec <- parseCImport ccnv' safety name ename' source -> do let fi = ForeignImport { fd_name = lname , fd_sig_ty = tsig , fd_i_ext = unused , fd_fi = ispec} return (lA l (forD fi)) | ie == "export" -> do let fe = ForeignExport { fd_name = lname , fd_sig_ty = tsig , fd_e_ext = unused , fd_fe = e } ces = CExportStatic stxt ename'_fs (unLoc ccnv) #if MIN_VERSION_ghc(9,8,0) stxt = SourceText ename'_fs #else stxt = SourceText ename' #endif #if MIN_VERSION_ghc(9,10,0) e = CExport (reLoc (L l stxt)) (reLoc (L l ces)) #elif MIN_VERSION_ghc(9,6,0) e = CExport (L l stxt) (L l ces) #else e = CExport (L l ces) (L l stxt) #endif return (lA l (forD fe)) _ -> builderError | otherwise = builderError {-# INLINABLE b_ffiD #-} b_callConv :: Code -> Builder (Located CCallConv) b_callConv (LForm (L l form)) = case form of Atom (ASymbol sym) | sym == "capi" -> r CApiConv | sym == "ccall" -> r CCallConv | sym == "prim" -> r PrimCallConv | sym == "javascript" -> r JavaScriptCallConv | sym == "stdcall" -> r StdCallConv _ -> builderError where r = return . L l {-# INLINABLE b_callConv #-} b_safety :: Code -> Builder (Located Safety) b_safety (LForm (L l form)) = case form of Atom (ASymbol sym) -> case sym of "interruptible" -> return (L l PlayInterruptible) "safe" -> return (L l PlaySafe) "unsafe" -> return (L l PlayRisky) _ -> builderError _ -> builderError {-# INLINABLE b_safety #-} b_funOrPatD :: Code -> [HPat] -> ([HGRHS], [HDecl]) -> Builder HDecl b_funOrPatD eq_form pats gxd@(grhss,decls) = case pats of [] -> setLastToken eq_form >> failB "Empty binding" lpat@(dL->L l (BangPat _ pat)):pats' -> case pats' of [] -> return (b_patBindD gxd lpat) _ -> let name = reLoc (L l (mkRdrName "!")) in b_funBindD name (pat:pats') grhss decls lpat@(dL->L _ pat):pats' | isVarPat pat -> do name <- varToName pat b_funBindD (reLoc name) pats' grhss decls | null pats' -> return (b_patBindD gxd lpat) | otherwise -> setLastToken eq_form >> failB "Malformed binding" where isVarPat VarPat {} = True isVarPat _ = False varToName (VarPat _ lname) = return lname varToName _ = failB "Invalid name" {-# INLINABLE b_funOrPatD #-} b_funBindD :: Located RdrName -> [HPat] -> [HGRHS] -> [HDecl] -> Builder HDecl b_funBindD lname0@(L l _) args grhss decls = do let body = mkGRHSs grhss decls l lname = reLocA lname0 match = lA l (Match unused ctxt args body) ctxt = FunRhs { mc_fun = lname , mc_fixity = Prefix -- XXX: Get strictness from ... where? , mc_strictness = NoSrcStrict } -- bind = mkFunBind_compat lname [match] bind = mkFunBind FromSource lname [match] return (lA l (ValD unused bind)) {-# INLINABLE b_funBindD #-} b_patBindD :: ([HGRHS],[HDecl]) -> HPat -> HDecl b_patBindD (grhss,decls) lpat@(dL->L l _pat) = let bind = mkPatBind_compat lpat grhss decls in L l (ValD unused bind) {-# INLINABLE b_patBindD #-} b_tsigD :: [Code] -> ([HType], HType) -> Builder HDecl b_tsigD names (ctxts,typ0) = do let typ' = hsTypeToHsSigWcType qtyp qtyp = if null ctxts then typ1 else lqty1 #if MIN_VERSION_ghc(9,10,0) lqty1 = lA l (mkHsQualTy' (mkLocatedListA ctxts) typ1) #else lqty1 = lA l (mkHsQualTy' (la2la (mkLocatedListA ctxts)) typ1) #endif typ1 = unParTy typ0 mkName form = case form of LForm (L l1 (Atom (ASymbol name))) -> return (lN l1 (mkRdrName name)) _ -> builderError l = getLoc (mkLocatedForm names) typeSig = TypeSig unused names' <- mapM mkName names return (lA l (sigD (typeSig names' typ'))) {-# INLINABLE b_tsigD #-} #if MIN_VERSION_ghc(9,4,0) b_inlineD :: (SourceText -> InlineSpec) -> Maybe Activation -> Code -> Builder HDecl #else b_inlineD :: InlineSpec -> Maybe Activation -> Code -> Builder HDecl #endif b_inlineD ispec mb_act (LForm (L l form)) = case form of Atom (ASymbol name) -> let inlineSig = InlineSig unused in return (lA l (sigD (inlineSig (lN l (mkRdrName name)) ipragma))) _ -> builderError where ipragma = mkInlinePragma stxt (ispec', FunLike) mb_act source = case ispec'' (strToSourceText "") of NoInline {} -> "{-# NOINLINE" Inlinable {} -> "{-# INLINABLE" _ -> "{-# INLINE" stxt = strToSourceText source #if MIN_VERSION_ghc(9,4,0) ispec' = ispec stxt ispec'' = ispec #else ispec' = ispec ispec'' = const ispec #endif {-# INLINABLE b_inlineD #-} b_activation :: (SourceText -> PhaseNum -> Activation) -> Code -> Builder Activation b_activation f code@(LForm (L _l atom)) | Atom (AInteger il) <- atom = return (f source (fromIntegral (il_value il))) -- Supporting symbols in "~N" form, where "N" is an integer. | Atom (ASymbol s) <- atom , '~':rest <- unpackFS s , [(n,"")] <- reads rest = return (f source n) | otherwise = builderError where source = strToSourceText (show code) {-# INLINABLE b_activation #-} b_specializeD :: Code -> Maybe Activation -> (Code, HType) -> Builder HDecl b_specializeD = specializeBuilder noUserInline "{-# SPECIALISE" {-# INLINABLE b_specializeD #-} b_specializeInlineD :: Code -> Maybe Activation -> (Code, HType) -> Builder HDecl #if MIN_VERSION_ghc(9,4,0) b_specializeInlineD = let str = "{-# SPECIALISE INLINE" in specializeBuilder (Inline (strToSourceText str)) str #else b_specializeInlineD = specializeBuilder Inline "{-# SPECIALISE INLINE" #endif {-# INLINABLE b_specializeInlineD #-} specializeBuilder :: InlineSpec -> String -> Code -> Maybe Activation -> (Code, HType) -> Builder HDecl specializeBuilder ispec txt (LForm (L l _)) mb_act (nsym, tsig) | LForm (L ln (Atom (ASymbol name))) <- nsym = do let lname = lN ln (mkRdrName name) ipragma = mkInlinePragma source (ispec, FunLike) mb_act source = strToSourceText txt specSig = SpecSig unused lname [hsTypeToHsSigType tsig] ipragma return (lA l (sigD specSig)) | otherwise = builderError {-# INLINABLE specializeBuilder #-} b_docnextD :: Code -> Builder HDecl b_docnextD = docDWith DocCommentNext hsDocStringNext {-# INLINABLE b_docnextD #-} b_docprevD :: Code -> Builder HDecl b_docprevD = docDWith DocCommentPrev hsDocStringPrevious {-# INLINABLE b_docprevD #-} #if MIN_VERSION_ghc(9,4,0) docDWith :: (LHsDoc PARSED -> DocDecl PARSED) -> HsDocStringDecorator -> Code -> Builder HDecl #else docDWith :: (LHsDoc PARSED -> DocDecl) -> HsDocStringDecorator -> Code -> Builder HDecl #endif docDWith constr deco (LForm (L l form)) = case form of Atom (AString _ str) -> -- Adding space to the beginning and the end of the given documentation -- content at this point, to ensure at least one space will appear between -- the doc body and decoration header/footer. Though more suitable place -- to add spaces should exist ... let doc = mkLHsDocWithDecorator deco l (wrapWithSpaces str) in pure $! lA l (DocD unused (constr doc)) _ -> builderError {-# INLINABLE docDWith #-} b_docGroupD :: Int -> Code -> Builder HDecl b_docGroupD n form@(LForm (L l _)) | List [_,doc_code] <- unCode form , Atom (AString _ doc) <- unCode doc_code = return $! lA l (DocD unused (DocGroup (fromIntegral n) (mkLHsDoc l doc))) | otherwise = setLastToken form >> failB "Invalid group doc" {-# INLINABLE b_docGroupD #-} b_docNamed :: Code -> Builder HDecl b_docNamed form@(LForm (L l body)) | List [_,name_code,doc_code] <- body , Atom (ASymbol name) <- unCode name_code , Atom (AString _ doc) <- unCode doc_code = let name' = unpackFS name in return $! lA l (DocD unused (DocCommentNamed name' (mkLHsDoc l doc))) | otherwise = setLastToken form >> failB "Invalid named doc" {-# INLINABLE b_docNamed #-} tyClD :: TyClDecl PARSED -> HsDecl PARSED tyClD = TyClD unused {-# INLINABLE tyClD #-} sigD :: Sig PARSED -> HsDecl PARSED sigD = SigD unused {-# INLINABLE sigD #-} mkDataFamInstDecl :: Located RdrName -> [HType] -> HsDataDefn PARSED -> DataFamInstDecl PARSED mkDataFamInstDecl tycon pats rhs = dfid where #if MIN_VERSION_ghc(9,2,0) dfid = DataFamInstDecl (mkFamEqn tycon pats rhs) #else dfid = DataFamInstDecl (mkHsImplicitBndrs (mkFamEqn tycon pats rhs)) #endif {-# INLINABLE mkDataFamInstDecl #-} mkTyFamInstEqn :: Located RdrName -> [HType] -> HType -> TyFamInstEqn PARSED mkTyFamInstEqn tycon pats rhs = #if MIN_VERSION_ghc(9,2,0) mkFamEqn tycon pats rhs #else mkHsImplicitBndrs (mkFamEqn tycon pats rhs) #endif {-# INLINABLE mkTyFamInstEqn #-} mkFamEqn :: Located RdrName -> [HType] -> rhs -> FamEqn PARSED rhs mkFamEqn tycon pats rhs = FamEqn { feqn_tycon = reLocA tycon , feqn_fixity = Prefix , feqn_rhs = rhs #if MIN_VERSION_ghc(9,10,0) , feqn_pats = map (HsValArg unused) pats , feqn_bndrs = mkHsOuterImplicit #elif MIN_VERSION_ghc(9,2,0) , feqn_pats = map HsValArg pats , feqn_bndrs = mkHsOuterImplicit #else , feqn_pats = map HsValArg pats , feqn_bndrs = Nothing #endif , feqn_ext = unused } {-# INLINABLE mkFamEqn #-} unParTy :: HType -> HType unParTy t0 = case t0 of L _ (HsParTy _ t1) -> t1 _ -> t0 {-# INLINABLE unParTy #-} noUserInline :: InlineSpec #if MIN_VERSION_ghc(9,2,0) noUserInline = NoUserInlinePrag #else noUserInline = NoUserInline #endif {-# INLINABLE noUserInline #-} cd2atdefs :: CategorizedDecls -> Builder [LTyFamDefltDecl PARSED] cd2atdefs = pure . cd_tfis {-# INLINABLE cd2atdefs #-} #if !MIN_VERSION_ghc(9,2,0) hsTypeToHsSigType :: HType -> HSigType hsTypeToHsSigType = mkLHsSigType {-# INLINABLE hsTypeToHsSigType #-} hsTypeToHsSigWcType :: HType -> HSigWcType hsTypeToHsSigWcType = mkLHsSigWcType {-# INLINABLE hsTypeToHsSigWcType #-} #endif ================================================ FILE: finkel-kernel/src/Language/Finkel/Syntax/HExpr.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | Syntax for expression. module Language.Finkel.Syntax.HExpr where #include "ghc_modules.h" -- base import Control.Arrow (first, second) import Data.Either (partitionEithers) import Data.List (foldl1') #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif -- ghc import GHC_Builtin_Types (tupleDataCon) import GHC_Data_OrdList (toOL) import GHC_Hs_Doc (HsDocString) import GHC_Hs_Expr (ArithSeqInfo (..), GRHS (..), HsExpr (..), HsMatchContext (..), HsTupArg (..), Match (..), StmtLR (..)) import GHC_Hs_Lit (HsLit (..), HsOverLit (..)) import GHC_Hs_Pat (HsRecFields (..), LHsRecField) import GHC_Hs_Type (mkHsWildCardBndrs) import GHC_Hs_Utils (mkBodyStmt, mkHsApp, mkHsComp, mkHsDo, mkHsFractional, mkHsIf, mkHsIntegral, mkLHsPar, mkLHsTupleExpr, mkMatchGroup) import GHC_Parser_PostProcess (mkRdrRecordCon) import GHC_Types_Basic (Arity, Boxity (..), Origin (..), opPrec) import GHC_Types_Name_Reader (RdrName, getRdrName) import GHC_Types_SrcLoc (GenLocated (..), Located, SrcSpan (..), getLoc, noLoc) import GHC_Utils_Lexeme (isLexCon, isLexSym, isLexVarId) #if MIN_VERSION_ghc(9,10,0) import Language.Haskell.Syntax.Expr (HsLamVariant (..)) #elif MIN_VERSION_ghc(9,6,0) import GHC.Hs.Extension (noHsTok) #endif #if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0) import Language.Haskell.Syntax.Concrete (HsToken (..)) #elif !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,4,0) import Language.Haskell.Syntax.Extension (HsToken (..)) #endif #if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,4,0) import GHC.Parser.PostProcess (mkTokenLocation) #endif #if MIN_VERSION_ghc(9,8,0) import Language.Haskell.Syntax.Expr (LHsRecUpdFields (..)) #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Hs.Pat (RecFieldsDotDot (..)) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Hs.DocString (HsDocStringDecorator (..)) import GHC.Hs.Expr (gHsPar) import Language.Haskell.Syntax.Expr (HsDoFlavour (..)) #else import GHC_Hs_Expr (HsStmtContext (..)) #endif #if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,6,0) import GHC_Parser_Annotation (locA) #endif #if MIN_VERSION_ghc(9,2,0) import GHC_Hs_Utils (hsTypeToHsSigWcType) #else import GHC_Hs_Utils (mkLHsSigWcType) import GHC_Parser_PostProcess (mkRdrRecordUpd) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Hs_Utils (mkPsBindStmt, mkSimpleMatch) import GHC_Types_SrcLoc (UnhelpfulSpanReason (..)) #else import GHC_Hs_Utils (mkBindStmt, mkHsLam) #endif import GHC_Hs_Expr (parenthesizeHsExpr) -- Internal import Language.Finkel.Builder import Language.Finkel.Data.FastString (FastString, fsLit, lengthFS, nullFS, unconsFS, unpackFS) import Language.Finkel.Data.SourceText import Language.Finkel.Form import Language.Finkel.Syntax.HBind import Language.Finkel.Syntax.HType import Language.Finkel.Syntax.Utils -- --------------------------------------------------------------------- -- -- Expression -- -- --------------------------------------------------------------------- b_ifE :: Code -> HExpr -> HExpr -> HExpr -> HExpr b_ifE (LForm (L l _)) p t f = #if MIN_VERSION_ghc(9,2,0) lA l (mkHsIf p t f unused) #else L l (mkHsIf p t f) #endif {-# INLINABLE b_ifE #-} b_lamE :: (HExpr,[HPat]) -> HExpr #if MIN_VERSION_ghc(9,0,0) b_lamE (body,pats) = mkLHsPar (lA l hsLam) -- Using 'mkHsLam' will make a 'MatchGroup' value with 'Generated' origin -- instead of 'FromSource', and contains 'noLoc' location. These were causing -- some issues when "-Wincomplete-patterns" flag was turned on. where # if MIN_VERSION_ghc(9,10,0) hsLam = HsLam unused LamSingle mg # else hsLam = HsLam unused mg # endif l = getLoc (reLoc body) mg = mkMatchGroup FromSource ms # if MIN_VERSION_ghc(9,10,0) ms = reLocA (L l [mkSimpleMatch (LamAlt LamSingle) pats body]) # elif MIN_VERSION_ghc(9,2,0) ms = reLocA (L l [mkSimpleMatch LambdaExpr pats body]) # else ms = [mkSimpleMatch LambdaExpr pats body] # endif #else b_lamE (body,pats) = mkHsLam pats body #endif {-# INLINABLE b_lamE #-} b_tupE :: Code -> [HExpr] -> HExpr b_tupE (LForm (L l _)) args = lA l e where e = explicitTuple (map mkArg args) Boxed #if MIN_VERSION_ghc(9,2,0) mkArg x = present x #else mkArg x@(L al _) = L al (present x) #endif explicitTuple = ExplicitTuple unused present = Present unused {-# INLINABLE b_tupE #-} -- Expression for tuple constructor function (i.e. the (,) -- function). See also 'b_varE' for tuples with more elements. b_tupConE :: Code -> HExpr b_tupConE (LForm (L l _)) = lA l (HsVar unused (lN l (tupConName Boxed 2))) {-# INLINABLE b_tupConE #-} b_letE :: Code -> [HDecl] -> HExpr -> Builder HExpr b_letE (LForm (L l _)) decls body = do cd <- cvBindsAndSigs (toOL decls) #if MIN_VERSION_ghc(9,2,0) let valbinds = mkHsValBinds (cd_binds cd) (cd_sigs cd) #else let valbinds = L l (mkHsValBinds (cd_binds cd) (cd_sigs cd)) #endif #if MIN_VERSION_ghc(9,10,0) pure (lA l (HsLet (unused, unused) valbinds body)) #elif MIN_VERSION_ghc(9,4,0) let tokLet = L (mkTokenLocation l) HsTok tokIn = L (mkTokenLocation l) HsTok return (lA l (HsLet unused tokLet valbinds tokIn body)) #else return (lA l (HsLet unused valbinds body)) #endif {-# INLINABLE b_letE #-} b_caseE :: Code -> HExpr -> [HMatch] -> HExpr b_caseE (LForm (L l _)) expr matches = lA l (hsCase expr mg) where hsCase = HsCase unused #if MIN_VERSION_ghc(9,2,0) mg = mkMatchGroup FromSource (lL l matches) #else mg = mkMatchGroup FromSource matches #endif {-# INLINABLE b_caseE #-} b_match :: HPat -> ([HGRHS],[HDecl]) -> HMatch b_match pat (grhss,decls) = L l (Match unused ctxt [pat] grhss') where grhss' = mkGRHSs grhss decls l ctxt = CaseAlt l = getLoc (dL pat) {-# INLINABLE b_match #-} b_hgrhs :: [HGRHS] -> (HExpr, [HGuardLStmt]) -> [HGRHS] b_hgrhs rhss (body, gs) = let lrhs = case gs of #if MIN_VERSION_ghc(9,10,0) [] -> reLocA (noLoc rhs) _ -> let l = getLoc (mkLocatedListA gs) in L l rhs #elif MIN_VERSION_ghc(9,4,0) [] -> reLocA (noLoc rhs) _ -> let l = getLoc (mkLocatedListA gs) in la2la (L l rhs) #else [] -> noLoc rhs _ -> let l = getLoc (mkLocatedListA gs) in reLoc (L l rhs) #endif rhs = b_GRHS gs body in (lrhs:rhss) {-# INLINABLE b_hgrhs #-} b_GRHS :: [HGuardLStmt] -> HExpr -> GRHS PARSED HExpr b_GRHS = GRHS unused {-# INLINABLE b_GRHS #-} b_doE :: Code -> [HStmt] -> HExpr -- XXX: Does not support "[ModuleName.].do" syntax yet. b_doE (LForm (L l _)) exprs = #if MIN_VERSION_ghc(9,2,0) lA l (mkHsDo (DoExpr Nothing) (reLocA (L l exprs))) #elif MIN_VERSION_ghc(9,0,0) L l (mkHsDo (DoExpr Nothing) exprs) #else L l (mkHsDo DoExpr exprs) #endif {-# INLINABLE b_doE #-} b_tsigE :: Code -> HExpr -> ([HType], HType) -> HExpr b_tsigE (LForm (L l _)) e0 (ctxt,t) = let t' = case ctxt of [] -> t #if MIN_VERSION_ghc(9,10,0) _ -> lA l (mkHsQualTy' (mkLocatedListA ctxt) t) #else _ -> lA l (mkHsQualTy' (la2la (mkLocatedListA ctxt)) t) #endif #if MIN_VERSION_ghc(9,2,0) e1 = ExprWithTySig unused e0 (hsTypeToHsSigWcType t') #else e1 = ExprWithTySig unused e0 (mkLHsSigWcType t') #endif in mkLHsPar (lA l e1) {-# INLINABLE b_tsigE #-} b_recConOrUpdE :: Code -> [Either Code (Located FastString, Maybe HExpr)] -> Builder HExpr b_recConOrUpdE whole@(LForm (L l form)) flds = case form of Atom (ASymbol name) | isLexCon name -> #if MIN_VERSION_ghc(9,2,0) pure (lA l (mkRdrRecordCon (lN l (mkVarRdrName name)) cflds unused)) #else pure (L l (mkRdrRecordCon (L l (mkVarRdrName name)) cflds)) #endif _ -> do v <- b_varE whole #if MIN_VERSION_ghc(9,8,0) -- XXX: Use mkRdrRecordUpd, runPV, and unP? pure (lA l (RecordUpd { rupd_ext = unused , rupd_expr = v , rupd_flds = RegularRecUpdFields { xRecUpdFields = unused , recUpdFields = uflds }})) #elif MIN_VERSION_ghc(9,2,0) pure (lA l (RecordUpd { rupd_ext = unused , rupd_expr = v , rupd_flds = Left uflds })) #else pure (L l (mkRdrRecordUpd v uflds)) #endif where cflds = HsRecFields { rec_flds = map mkcfld' non_wilds , rec_dotdot = mb_dotdot } uflds = map mkufld non_wilds mkufld = cfld2ufld . mkcfld' (wilds, non_wilds) = partitionEithers flds mb_dotdot = case wilds of [] -> Nothing #if MIN_VERSION_ghc(9,10,0) LForm (L wl _):_ -> Just (la2la (L wl (RecFieldsDotDot (length non_wilds)))) #elif MIN_VERSION_ghc(9,6,0) LForm (L wl _):_ -> Just (L wl (RecFieldsDotDot (length non_wilds))) #else LForm (L wl _):_ -> Just (L wl (length non_wilds)) #endif {-# INLINABLE b_recConOrUpdE #-} b_recUpdE :: Builder HExpr -> [PreRecField HExpr] -> Builder HExpr b_recUpdE expr flds = do expr' <- expr let uflds = map (cfld2ufld . mkcfld') non_wilds (wilds, non_wilds) = partitionEithers flds l = getLoc expr' case wilds of (_:_) -> builderError #if MIN_VERSION_ghc(9,8,0) -- XXX: Does not support OverloadedRecUpdFields. Use mkRdrRecordUpd, runPV, -- and unP? [] -> pure (L l (RecordUpd { rupd_ext = unused , rupd_expr = mkLHsPar expr' , rupd_flds = RegularRecUpdFields { xRecUpdFields = unused , recUpdFields = uflds }})) #elif MIN_VERSION_ghc(9,2,0) -- XXX: Does not support record dot syntax yet. The return type of -- 'mkRdrRecordUpd' function changed from previous ghc release, now the -- function returns 'PV (HsExpr GhcPs)', formerly it was 'HsExpr GhcPs'. [] -> pure (L l (RecordUpd { rupd_ext = unused , rupd_expr = mkLHsPar expr' , rupd_flds = Left uflds })) #else [] -> pure (L l (mkRdrRecordUpd (mkLHsPar expr') uflds)) #endif {-# INLINABLE b_recUpdE #-} mkcfld' :: (Located FastString, Maybe HExpr) -> LHsRecField PARSED HExpr mkcfld' (n,mb_e) = case mb_e of Just e -> mkcfld False (n, e) Nothing -> mkcfld True (n, punned) where punned = lA l (HsVar unused (lN l punRDR)) l = getLoc n {-# INLINABLE mkcfld' #-} b_opOrAppE :: Code -> ([HExpr], [HType]) -> Builder HExpr b_opOrAppE code (args, tys) = do fn <- b_varE code let fn' = mkAppTypes fn tys mkOp loc lhs rhs = lA loc (mkOpApp fn' lhs (mkLHsParOp rhs)) case code of -- Perform operator expansion, or delegate to `b_appE' if the head of the -- form was non-operator. LForm (L l (Atom (ASymbol name))) | let name' = maybe name snd (splitQualName name) , isLexSym name' , hd:rest@(_:_) <- args -> pure (foldl' (mkOp l) (mkLHsParOp hd) rest) _ -> pure (b_appE (fn':args, tys)) {-# INLINABLE b_opOrAppE #-} mkLHsParOp :: HExpr -> HExpr mkLHsParOp = parenthesizeHsExpr opPrec {-# INLINABLE mkLHsParOp #-} mkOpApp :: HExpr -> HExpr -> HExpr -> HsExpr PARSED mkOpApp op l = OpApp unused l op {-# INLINABLE mkOpApp #-} b_appE :: ([HExpr], [HType]) -> HExpr b_appE (args,_tys) = foldl1' f args where f a b = mkHsApp a (mkLHsPar b) {-# INLINABLE b_appE #-} mkAppTypes :: HExpr -> [HType] -> HExpr mkAppTypes = foldl' mkAppType {-# INLINABLE mkAppTypes #-} mkAppType :: HExpr -> HType -> HExpr mkAppType (dL->expr@(L l _)) ty = #if MIN_VERSION_ghc(9,10,0) L l (HsAppType unused expr (mkHsWildCardBndrs ty)) #elif MIN_VERSION_ghc(9,6,0) L l (HsAppType unused expr noHsTok (mkHsWildCardBndrs ty)) #elif MIN_VERSION_ghc(9,2,0) L l (HsAppType (locA l) expr (mkHsWildCardBndrs ty)) #else cL l (HsAppType unused expr (mkHsWildCardBndrs ty)) #endif b_charE :: Code -> Builder HExpr b_charE (LForm (L l form)) = case form of Atom (AChar st x) -> return (lA l (hsLit (HsChar st x))) _ -> builderError {-# INLINABLE b_charE #-} b_stringE :: Code -> Builder HExpr b_stringE (LForm (L l form)) = case form of Atom (AString st x) -> return (lA l (hsLit (HsString st x))) _ -> builderError {-# INLINABLE b_stringE #-} b_integerE :: Code -> Builder HExpr b_integerE (LForm (L l form)) = case form of Atom (AInteger x) | il_value x < 0 -> return (lA l (hsPar (expr x))) | otherwise -> return (expr x) _ -> builderError where expr x = lA l (hsOverLit $! mkHsIntegral x) {-# INLINABLE b_integerE #-} b_fracE :: Code -> Builder HExpr b_fracE (LForm (L l form)) = case form of Atom (AFractional x) | fl_value x < 0 -> return (lA l (hsPar (expr x))) | otherwise -> return (expr x) _ -> builderError where expr x = lA l (hsOverLit $! mkHsFractional x) {-# INLINABLE b_fracE #-} b_varE :: Code -> Builder HExpr b_varE (LForm (L l form)) | Atom (ASymbol x) <- form , not (nullFS x) , Just (hdchr,tlchrs) <- unconsFS x = case hdchr of -- Overloaded label starts with `#'. Tail characters need to be a valid -- variable identifier. '#' | isLexVarId tlchrs -> #if MIN_VERSION_ghc(9,6,0) ret (HsOverLabel unused (toQuotedSourceText tlchrs) tlchrs) #elif MIN_VERSION_ghc(9,2,0) ret (HsOverLabel unused tlchrs) #else ret (HsOverLabel unused Nothing tlchrs) #endif -- Tuple constructor function with more than two elements are written as -- symbol with sequence of commas, handling such case in this function. ',' | all (== ',') (unpackFS tlchrs) -> ret (var (tupConName Boxed (lengthFS x + 1))) -- Plain variable identifier. _ -> ret (var (mkVarRdrName x)) | otherwise = builderError where ret = return . lA l var n = HsVar unused (lN l n) {-# INLINABLE b_varE #-} b_unitE :: Code -> HExpr b_unitE (LForm (L l _)) = #if MIN_VERSION_ghc(9,2,0) case mkLHsTupleExpr [] unused of L _ t -> lA l t #else case mkLHsTupleExpr [] of L _ t -> L l t #endif {-# INLINABLE b_unitE #-} b_docStringNext :: Code -> Builder (Located HsDocString) b_docStringNext = docStringWith hsDocStringNext {-# INLINABLE b_docStringNext #-} b_docStringPrev :: Code -> Builder (Located HsDocString) b_docStringPrev = docStringWith hsDocStringPrevious {-# INLINABLE b_docStringPrev #-} docStringWith :: HsDocStringDecorator -> Code -> Builder (Located HsDocString) docStringWith deco (LForm (L l form)) = case form of Atom (AString _ x) -> pure $! L l (mkHsDocStringWithDecorator deco l x) _ -> builderError {-# INLINABLE docStringWith #-} b_hsListE :: Either HExpr [HExpr] -> HExpr b_hsListE expr = case expr of #if MIN_VERSION_ghc(9,2,0) Right exprs -> L l (ExplicitList unused exprs) #else Right exprs -> L l (ExplicitList unused Nothing exprs) #endif where l = getLoc (mkLocatedListA exprs) Left arithSeqExpr -> arithSeqExpr {-# INLINABLE b_hsListE #-} b_lcompE :: HExpr -> [HStmt] -> HExpr b_lcompE ret stmts = L l (mkHsComp ListComp stmts ret) where l = getLoc ret {-# INLINABLE b_lcompE #-} b_arithSeqE :: HExpr -> Maybe HExpr -> Maybe HExpr -> HExpr b_arithSeqE fromE thenE toE = L l (ArithSeq unused Nothing info) where info | Just thenE' <- thenE, Just toE' <- toE = FromThenTo fromE thenE' toE' | Just thenE' <- thenE = FromThen fromE thenE' | Just toE' <- toE = FromTo fromE toE' | otherwise = From fromE l = getLoc fromE {-# INLINABLE b_arithSeqE #-} b_quoteE :: Code -> Builder HExpr b_quoteE (LForm (L l form)) = do qualify <- fmap qualifyQuote getBState case form of Atom atom -> b_quoteAtomE l qualify atom List xs -> b_quoteLocListE l (qListS qualify) xs HsList xs -> b_quoteLocListE l (qHsListS qualify) xs _ -> builderError {-# INLINABLE b_quoteE #-} b_quoteAtomE :: SrcSpan -> Bool -> Atom -> Builder HExpr b_quoteAtomE l qualify atom = case atom of ASymbol s -> mk_lapp qSymbolS (mk_sym s) AChar st c -> mk_lapp qCharS (lA l (hsLit (HsChar st c))) AString st str -> mk_lapp qStringS (mk_str st str) AInteger _il -> b_integerE orig >>= mk_lapp qIntegerS AFractional _fl -> b_fracE orig >>= mk_lapp qFractionalS AUnit -> mk_unit where mk_sym s = lA l (hsLit (HsString (toQuotedSourceText s) s)) mk_str st str = lA l (hsLit (HsString st str)) orig = LForm (L l (Atom atom)) mk_lapp lname arg = do let (fname, sl, sc, el, ec) = getLocInfo l fn <- b_varE (LForm (L l (Atom (ASymbol (lname qualify))))) return (b_appE ([fn, arg, fname, sl, sc, el, ec], [])) mk_unit = do let (fname, sl, sc, el, ec) = getLocInfo l fn <- b_varE (LForm (L l (Atom (ASymbol (qUnitS qualify))))) return (b_appE ([fn, fname, sl, sc, el, ec], [])) {-# INLINABLE b_quoteAtomE #-} b_quoteLocListE :: SrcSpan -> FastString -> [Code] -> Builder HExpr b_quoteLocListE l fn_name xs = do mk_list <- b_varE (LForm (L l (Atom (ASymbol fn_name)))) args <- fmap (b_hsListE . Right) (mapM b_quoteE xs) let (fname, sl, sc, el, ec) = getLocInfo l return (b_appE ([mk_list, args, fname, sl, sc, el, ec], [])) {-# INLINABLE b_quoteLocListE #-} getLocInfo :: SrcSpan -> (HExpr, HExpr, HExpr, HExpr, HExpr) getLocInfo l = withLocInfo l fname mk_int where -- Using unhelpful location for file names, lines, and columns. Otherwise, -- hpc code coverage will mark the location information as non-evaluated -- expressions. fname fs = lA ql (hsLit (HsString (toQuotedSourceText fs) fs)) mk_int n = lA ql $! hsOverLit $! mkHsIntegral $! mkIntegralLit n #if MIN_VERSION_ghc(9,0,0) ql = UnhelpfulSpan (UnhelpfulOther (fsLit "")) #else ql = UnhelpfulSpan (fsLit "") #endif {-# INLINABLE getLocInfo #-} b_rapp :: Either a b -> ([a],[b]) -> ([a],[b]) b_rapp = either (first . (:)) (second . (:)) {-# INLINABLE b_rapp #-} b_exprOrTyArg :: Code -> Builder (Either HExpr HType) b_exprOrTyArg lform = case lform of LForm (L l (Atom (ASymbol sym))) | Just ('@', rest) <- unconsFS sym, not (nullFS rest) -> fmap Right (b_symT (LForm (L l (Atom (ASymbol rest))))) _ -> fmap Left (b_varE lform) {-# INLINABLE b_exprOrTyArg #-} -- ------------------------------------------------------------------------ -- -- Auxiliary -- -- ------------------------------------------------------------------------ hsLit :: HsLit PARSED -> HsExpr PARSED hsLit = HsLit unused {-# INLINABLE hsLit #-} hsPar :: HExpr -> HsExpr PARSED #if MIN_VERSION_ghc(9,4,0) hsPar = gHsPar #else hsPar = HsPar unused #endif {-# INLINABLE hsPar #-} hsOverLit :: HsOverLit PARSED -> HsExpr PARSED hsOverLit = HsOverLit unused {-# INLINABLE hsOverLit #-} tupConName :: Boxity -> Arity -> RdrName tupConName boxity arity = getRdrName (tupleDataCon boxity arity) {-# INLINABLE tupConName #-} -- --------------------------------------------------------------------- -- -- Statement -- -- --------------------------------------------------------------------- b_bindS :: Code -> HPat -> HExpr -> HStmt b_bindS (LForm (L l _)) pat expr = #if MIN_VERSION_ghc(9,2,0) lA l (mkPsBindStmt unused pat expr) #elif MIN_VERSION_ghc(9,0,0) L l (mkPsBindStmt pat expr) #else L l (mkBindStmt pat expr) #endif {-# INLINABLE b_bindS #-} b_letS :: Code -> [HDecl] -> Builder HStmt b_letS (LForm (L l _)) decls = do cd <- cvBindsAndSigs (toOL decls) let valbinds = mkHsValBinds (cd_binds cd) (cd_sigs cd) letStmt = LetStmt unused #if MIN_VERSION_ghc(9,2,0) return (lA l (letStmt valbinds)) #else return (L l (letStmt (L l valbinds))) #endif {-# INLINABLE b_letS #-} b_bodyS :: HExpr -> HStmt b_bodyS expr = L (getLoc expr) (mkBodyStmt expr) {-# INLINABLE b_bodyS #-} -- ------------------------------------------------------------------------ -- -- Parenthesizing -- -- ------------------------------------------------------------------------ -- Below note is for parenthesizing under ghc < 8.10, which won't hold any more: -- Note: [Parenthesizing HsExpr for patterns] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- Following "parenthesizeHsExpr'" is almost same as 'parenthesizeHsExpr' found -- in the source code of ghc 8.6.x and above, but will add parentheses for -- ELazyPat when given 'PprPrec' is equal or greater than 'appPrec'. This is to -- support lazy constructor patterns (e.g.: ~(Just n)) inside 'as' pattern. -- -- For instance, below codes: -- -- (@ foo (~(Just n))) ; Finkel -- -- foo@(~(Just n)) -- Haskell -- -- will fail to parse in Haskell when the "~(Just n)" is not surrounded by -- parentheses. ================================================ FILE: finkel-kernel/src/Language/Finkel/Syntax/HImpExp.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} -- | Syntax for module header, import and export entities. module Language.Finkel.Syntax.HImpExp where #include "ghc_modules.h" -- ghc import GHC_Data_FastString (FastString, unpackFS) import GHC_Data_OrdList (toOL) import GHC_Hs (HsModule (..)) import GHC_Hs_Doc (LHsDocString) import GHC_Hs_ImpExp (IE (..), IEWildcard (..), IEWrappedName (..), ImportDecl (..), simpleImportDecl) import GHC_Parser_PostProcess (cvTopDecls) import GHC_Types_Name_Occurrence (tcClsName) import GHC_Types_Name_Reader (RdrName, mkQual, mkUnqual) import GHC_Types_SrcLoc (GenLocated (..), SrcSpan) import GHC_Unit_Module (mkModuleNameFS) import GHC_Utils_Lexeme (isLexCon) import GHC_Hs_ImpExp (ImportDeclQualifiedStyle (..)) #if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0) import Language.Haskell.Syntax.Concrete (LayoutInfo (..)) #elif !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,0,0) import GHC_Types_SrcLoc (LayoutInfo (..)) #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Hs (XModulePs (..)) import Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..)) #endif -- Internal import Language.Finkel.Builder import Language.Finkel.Form import Language.Finkel.Syntax.Utils -- --------------------------------------------------------------------- -- -- Module -- -- --------------------------------------------------------------------- -- In GHC source code, there is a file "compiler/hsSyn/Convert.hs". -- This module contains codes converting Template Haskell data types to -- GHC's internal data type, which is a helpful resource for -- understanding the values and types for constructing Haskell AST data. type ModFn = Maybe LHsDocString -> [HImportDecl] -> [HDecl] -> HModule b_module :: Maybe Code -> [HIE] -> Builder ModFn b_module mb_form exports = case mb_form of Nothing -> return (modfn Nothing) Just (LForm (L l form)) | Atom (ASymbol name) <- form -> return (modfn (Just (lA l (mkModuleNameFS name)))) _ -> builderError where modfn mb_name mbdoc imports decls = HsModule { hsmodName = mb_name , hsmodExports = if null exports then Nothing #if MIN_VERSION_ghc(9,10,0) else Just (mkLocatedListA exports) #else else Just (la2la (mkLocatedListA exports)) #endif , hsmodImports = imports -- Function `cvTopDecls' is used for mergeing multiple top-level -- FunBinds, which may take different patterns in its arguments. , hsmodDecls = cvTopDecls (toOL decls) #if MIN_VERSION_ghc(9,6,0) , hsmodExt = XModulePs { hsmodAnn = unused # if MIN_VERSION_ghc(9,10,0) , hsmodLayout = unused # else , hsmodLayout = NoLayoutInfo # endif , hsmodDeprecMessage = Nothing , hsmodHaddockModHeader = fmap lHsDocString2LHsDoc mbdoc } #else -- XXX: Does not support DEPRECATED message. , hsmodDeprecMessage = Nothing # if MIN_VERSION_ghc(9,2,0) , hsmodAnn = unused # endif # if MIN_VERSION_ghc(9,0,0) , hsmodLayout = NoLayoutInfo # endif , hsmodHaddockModHeader = fmap lHsDocString2LHsDoc mbdoc #endif } {-# INLINABLE b_module #-} b_implicitMainModule :: Builder ([HImportDecl] -> [HDecl] -> HModule) b_implicitMainModule = b_module Nothing [] <*> pure Nothing {-# INLINABLE b_implicitMainModule #-} b_ieSym :: Code -> Builder HIE b_ieSym form@(LForm (L l _)) = do name <- getVarOrConId form let con = iEThingAbs l #if MIN_VERSION_ghc(9,10,0) let var x = lA l (IEVar Nothing (lA l (ieName l (mkRdrName x))) Nothing) #elif MIN_VERSION_ghc(9,8,0) let var x = lA l (IEVar Nothing (lA l (ieName l (mkRdrName x)))) #else let var x = lA l (IEVar unused (lA l (ieName l (mkRdrName x)))) #endif pure (if isLexCon name then con name else var name) {-# INLINABLE b_ieSym #-} b_ieGroup :: Int -> Code -> Builder HIE b_ieGroup n form@(LForm (L l body)) | List [_, doc_code] <- body , Atom (AString _ doc) <- unCode doc_code = return $! lA l (IEGroup unused (fromIntegral n) (mkLHsDoc l doc)) | otherwise = setLastToken form >> failB "Invalid group documentation" {-# INLINABLE b_ieGroup #-} b_ieDoc :: Code -> Builder HIE b_ieDoc (LForm (L l form)) = case form of Atom (AString _ str) -> return $! lA l (IEDoc unused (mkLHsDoc l str)) _ -> builderError {-# INLINABLE b_ieDoc #-} b_ieDocNamed :: Code -> Builder HIE b_ieDocNamed (LForm (L l form)) | List [_,name_code] <- form , Atom (ASymbol name) <- unCode name_code = return $! lA l (IEDocNamed unused (unpackFS name)) | otherwise = builderError {-# INLINABLE b_ieDocNamed #-} b_ieAbs :: Code -> Builder HIE b_ieAbs form@(LForm (L l _)) = iEThingAbs l <$> getConId form {-# INLINABLE b_ieAbs #-} b_ieAll :: Code -> Builder HIE b_ieAll form@(LForm (L l _)) = do name <- getConId form #if MIN_VERSION_ghc(9,10,0) -- XXX: Does not support ExportDoc. let iEThingAll ie_name = IEThingAll (Nothing, unused) ie_name Nothing #elif MIN_VERSION_ghc(9,8,0) let iEThingAll = IEThingAll (Nothing, unused) #else let iEThingAll = IEThingAll unused #endif return $ lA l (iEThingAll (lA l (ieName l (mkUnqual tcClsName name)))) {-# INLINABLE b_ieAll #-} b_ieWith :: Code -> [Code] -> Builder HIE b_ieWith (LForm (L l form)) names = case form of Atom (ASymbol name) -> return (thing name) _ -> builderError where #if MIN_VERSION_ghc(9,10,0) -- XXX: Does not support ExportDoc. thing name = lA l (iEThingWith (wrapped name) wc ns Nothing) #elif MIN_VERSION_ghc(9,2,0) -- XXX: Does not support DuplicateRecordFields. thing name = lA l (iEThingWith (wrapped name) wc ns) #else thing name = L l (iEThingWith (wrapped name) wc ns _fs) #endif wrapped name = lA l (ieName l (qn name)) qn name = maybe (mkUnqual tcClsName name) (mkQual tcClsName) (splitQualName name) (ns, _fs) = foldr f ([],[]) names f (LForm (L l0 (Atom (ASymbol n0)))) (ns0, fs0) = (lA l0 (ieName l (mkRdrName n0)) : ns0, fs0) f _ acc = acc #if MIN_VERSION_ghc(9,8,0) iEThingWith = IEThingWith (Nothing, unused) #else iEThingWith = IEThingWith unused #endif wc = NoIEWildcard {-# INLINABLE b_ieWith #-} b_ieMdl :: [Code] -> Builder HIE b_ieMdl xs = case xs of [LForm (L l (Atom (ASymbol name)))] -> return (thing l name) _ -> builderError where thing l n = lA l (iEModuleContents (lA l (mkModuleNameFS n))) #if MIN_VERSION_ghc(9,8,0) iEModuleContents = IEModuleContents (Nothing, unused) #else iEModuleContents = IEModuleContents unused #endif {-# INLINABLE b_ieMdl #-} b_importD :: (Code, Bool, Maybe Code) -> (Bool, Maybe [HIE]) -> Builder HImportDecl b_importD (name, qualified, mb_as) (hiding, mb_entities) = case name of LForm (L l (Atom (ASymbol m))) -> let decl = simpleImportDecl mname decl' = decl { ideclQualified = qualified' , ideclAs = fmap asModName mb_as , ideclName = lA l mname #if MIN_VERSION_ghc(9,6,0) , ideclImportList = hiding' #else , ideclHiding = hiding' #endif } mname = mkModuleNameFS m qualified' | qualified = QualifiedPre | otherwise = NotQualified asModName (LForm (L l' (Atom (ASymbol x)))) = lA l' (mkModuleNameFS x) asModName _ = error "b_importD.asModName" hiding' = case mb_entities of Nothing -> Nothing Just es -> Just (interp, lL l es) where #if MIN_VERSION_ghc(9,6,0) interp = if hiding then EverythingBut else Exactly #else interp = hiding #endif in return (lA l decl') _ -> builderError {-# INLINABLE b_importD #-} -- ------------------------------------------------------------------------ -- -- Auxiliary -- -- ------------------------------------------------------------------------ iEThingAbs :: SrcSpan -> FastString -> HIE iEThingAbs l name = #if MIN_VERSION_ghc(9,10,0) -- XXX: Does not support ExportDoc. lA l (IEThingAbs (Nothing, unused) (lA l (ieName l (mkUnqual tcClsName name))) Nothing) #elif MIN_VERSION_ghc(9,8,0) lA l (IEThingAbs (Nothing, unused) (lA l (ieName l (mkUnqual tcClsName name)))) #else lA l (IEThingAbs unused (lA l (ieName l (mkUnqual tcClsName name)))) #endif {-# INLINABLE iEThingAbs #-} #if MIN_VERSION_ghc(9,6,0) ieName :: SrcSpan -> RdrName -> IEWrappedName PARSED #else ieName :: SrcSpan -> RdrName -> IEWrappedName RdrName #endif #if MIN_VERSION_ghc(9,6,0) ieName l x = IEName unused (lN l x) #else ieName l x = IEName (lN l x) #endif ================================================ FILE: finkel-kernel/src/Language/Finkel/Syntax/HPat.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | Syntax for patterns. module Language.Finkel.Syntax.HPat where #include "ghc_modules.h" -- base import Data.Either (partitionEithers) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif -- ghc import GHC_Hs_Lit (HsLit (..), HsOverLit) import GHC_Hs_Pat (HsConPatDetails, HsRecFields (..), Pat (..), parenthesizePat) import GHC_Hs_Type (HsConDetails (..)) import GHC_Hs_Utils (mkHsIntegral, mkHsIsString, mkNPat, nlWildPat) import GHC_Types_Basic (Boxity (..), appPrec, opPrec) import GHC_Types_SrcLoc (GenLocated (..), Located) import GHC_Utils_Lexeme (isLexCon, isLexConId, isLexConSym, isLexSym) #if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0) import GHC.Hs.Extension (noHsTok) #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Hs.Pat (RecFieldsDotDot (..)) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Hs.Pat (gParPat) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Hs_Pat (ConLikeP) #else import GHC_Hs_Extension (IdP) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Hs_Type (mkHsPatSigType) #else import GHC_Hs_Utils (mkLHsSigWcType) #endif -- Internal import Language.Finkel.Builder import Language.Finkel.Data.FastString (nullFS, unconsFS) import Language.Finkel.Form import Language.Finkel.Syntax.Utils -- ------------------------------------------------------------------------ -- -- Pattern -- -- ------------------------------------------------------------------------ -- Note: [Pattern from expression] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- Until ghc-8.8.x, parser in GHC had intermediate constructors in HsExpr data -- type, to make HsPat values from HsExpr. In ghc-8.10.1, the intermediate -- constructors were removed and RdrHsSyn.{PatBuilder,ECP,DisambECP} and related -- functions were introduced. Those modules were renamed to -- GHC.Parser.PostProcess in ghc 9.0.1. -- -- At the moment, Finkel parser does not use the ECP, since the prefix notation -- does not introduce ambiguous syntax so much. Also, due to the ubiquitous use -- of the parentheses, parsing without adding redundant parentheses in the AST -- seemed difficult with the ECP approach. b_intP :: Code -> Builder HPat b_intP (LForm (L l form)) = case form of Atom (AInteger n) -> return $! lA l (npat n) _ -> builderError where npat n = mkNPat' (L l (mkHsIntegral n)) {-# INLINABLE b_intP #-} b_stringP :: Code -> Builder HPat b_stringP (LForm (L l form)) = case form of Atom (AString stxt str) -> return $! lA l (npat stxt str) _ -> builderError where npat stxt str = mkNPat' (L l (mkHsIsString stxt str)) {-# INLINABLE b_stringP #-} b_charP :: Code -> Builder HPat b_charP (LForm (L l form)) = case form of Atom (AChar stxt c) -> return $! lA l (LitPat unused (HsChar stxt c)) _ -> builderError {-# INLINABLE b_charP #-} b_unitP :: Code -> Builder HPat b_unitP (LForm (L l form)) = case form of Atom AUnit -> return $! lA l (mkTuplePat []) _ -> builderError {-# INLINABLE b_unitP #-} b_wildP :: Code -> HPat b_wildP (LForm (L l _)) = lA l wildPat where wildPat | L _ pat <- dL nlWildPat = pat {-# INLINABLE b_wildP #-} b_symP :: Code -> Builder HPat b_symP orig@(LForm (L l form)) | (Atom (ASymbol name)) <- form , Just (hdchr,tlchrs) <- unconsFS name = case () of _ | isLexCon name -- Constructor. -> return (lA l (mkConPat (lN l (mkVarRdrName name)) (mkPrefixCon []))) | hdchr == '~' -- Lazy pattern or operator function. -> if nullFS tlchrs then failB "Invalid use of `~'" else if isLexSym tlchrs -- Operator function. then do checkVarId orig name let name' = lN l (mkRdrName name) return (lA l (VarPat unused name')) -- Lazy pattern. else do checkVarId orig tlchrs let name' = lN l (mkRdrName tlchrs) pat = lA l (VarPat unused name') return (lA l (LazyPat unused pat)) | hdchr == '!' , not (nullFS tlchrs) , not (isLexSym tlchrs) -- Bang pattern. -> do let pat = lA l (VarPat unused (lN l (mkRdrName tlchrs))) checkVarId orig tlchrs return (lA l (BangPat unused pat)) | otherwise -- Varid. -> do checkVarId orig name return (lA l (VarPat unused (lN l (mkRdrName name)))) | otherwise = builderError {-# INLINABLE b_symP #-} b_hsListP :: [HPat] -> HPat b_hsListP pats = p where p = case dL (mkLocatedListA pats) of L l _ -> L l (listPat pats) listPat = ListPat unused {-# INLINABLE b_hsListP #-} b_labeledP :: Code -> [PreRecField HPat] -> Builder HPat b_labeledP (LForm (L l form)) ps | Atom (ASymbol name) <- form , isLexCon name = do let mkcfld' (lab, mb_p) = case mb_p of Just p -> mkcfld False (lab, p) Nothing -> mkcfld True (lab, punned) punned = lA l (VarPat unused (lN l punRDR)) (wilds, non_wilds) = partitionEithers ps mb_dotdot = case wilds of [] -> Nothing #if MIN_VERSION_ghc(9,10,0) (LForm (L wl _): _) -> Just (la2la (L wl (RecFieldsDotDot (length non_wilds)))) #elif MIN_VERSION_ghc(9,6,0) (LForm (L wl _): _) -> Just (L wl (RecFieldsDotDot (length non_wilds))) #else (LForm (L wl _): _) -> Just (L wl (length non_wilds)) #endif flds = map mkcfld' non_wilds rc = HsRecFields { rec_flds = flds , rec_dotdot = mb_dotdot } cid = lN l (mkVarRdrName name) cpd = RecCon rc return (lA l (mkConPat cid cpd)) | otherwise = builderError {-# INLINABLE b_labeledP #-} b_tupP :: Code -> [HPat] -> HPat b_tupP (LForm (L l _)) ps = lA l (mkTuplePat ps) {-# INLINABLE b_tupP #-} b_asP :: Code -> HPat -> Builder HPat b_asP (LForm (dL->L l form)) pat = case form of Atom (ASymbol name) -> return $! lA l (asPat (lN l (mkRdrName name)) (mkParPat' pat)) _ -> builderError where #if MIN_VERSION_ghc(9,10,0) asPat lid p = AsPat unused lid p #elif MIN_VERSION_ghc(9,6,0) asPat lid p = AsPat unused lid noHsTok p #else asPat = AsPat unused #endif {-# INLINABLE b_asP #-} b_lazyP :: HPat -> HPat b_lazyP (dL-> L l pat0) = cL l (LazyPat unused pat1) where pat1 = parenthesizePat appPrec (cL l pat0) {-# INLINABLE b_lazyP #-} b_bangP :: HPat -> HPat b_bangP (dL->L l pat) = cL l (BangPat unused (cL l pat)) {-# INLINABLE b_bangP #-} b_conP :: [Code] -> Bool -> [HPat] -> Builder HPat b_conP forms is_paren rest = case forms of [LForm (L l (Atom (ASymbol name)))] | is_paren, isLexConSym name -> prefixPat | isLexConId name -> prefixPat | isLexConSym name -> infixPat where rname = mkVarRdrName name lrname = lN l rname prefixPat = return (lA l (mkConPat lrname (mkPrefixCon prest))) prest = map (parenthesizePat appPrec) rest infixPat = case rest of (hd:rest') -> let f lh rh = lA l (mkConPat lrname (InfixCon lh (paren rh))) paren = parenthesizePat opPrec in return (foldl' f (parenthesizePat opPrec hd) rest') _ -> builderError _ -> builderError {-# INLINABLE b_conP #-} b_sigP :: Code -> HPat -> HType -> HPat b_sigP (LForm (L l _)) pat ty = #if MIN_VERSION_ghc(9,2,0) lA l (SigPat unused pat (mkHsPatSigType unused ty)) #elif MIN_VERSION_ghc(9,0,0) lA l (SigPat unused pat (mkHsPatSigType ty)) #else cL l (SigPat unused pat (mkLHsSigWcType ty)) #endif {-# INLINABLE b_sigP #-} mkTuplePat :: [HPat] -> Pat PARSED mkTuplePat ps = TuplePat unused ps Boxed {-# INLINABLE mkTuplePat #-} -- XXX: Consider using GHC.Hs.Utils.mkParPat mkParPat' :: HPat -> HPat #if MIN_VERSION_ghc(9,4,0) mkParPat' pat@(L l _) = cL l (gParPat pat) #else mkParPat' (dL->L l p) = -- This newline is mandatory to support 'unused' CPP macro. Seems like, the C -- preprocessor is not working well with view pattern. cL l (ParPat unused (cL l p)) #endif {-# INLINABLE mkParPat' #-} #if MIN_VERSION_ghc(9,0,0) mkConPat :: LocatedN (ConLikeP PARSED) -> HsConPatDetails PARSED -> Pat PARSED mkConPat = ConPat unused #else mkConPat :: Located (IdP PARSED) -> HsConPatDetails PARSED -> Pat PARSED mkConPat = ConPatIn #endif mkNPat' :: Located (HsOverLit PARSED) -> Pat PARSED #if MIN_VERSION_ghc(9,4,0) mkNPat' li = mkNPat (reLocA li) Nothing unused #elif MIN_VERSION_ghc(9,2,0) mkNPat' li = mkNPat li Nothing unused #else mkNPat' li = mkNPat li Nothing #endif {-# INLINABLE mkNPat' #-} #if MIN_VERSION_ghc(9,2,0) mkPrefixCon :: [a] -> HsConDetails ta a r mkPrefixCon = PrefixCon [] #else mkPrefixCon :: [a] -> HsConDetails a r mkPrefixCon = PrefixCon #endif {-# INLINABLE mkPrefixCon #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Syntax/HType.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | Syntax for type. module Language.Finkel.Syntax.HType where #include "ghc_modules.h" -- base #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif -- ghc import GHC_Builtin_Types (consDataCon, eqTyCon_RDR, listTyCon_RDR, tupleTyCon) import GHC_Hs_Doc (LHsDocString) import GHC_Hs_Type (HsSrcBang (..), HsTupleSort (..), HsTyLit (..), HsType (..), SrcStrictness (..), SrcUnpackedness (..), mkAnonWildCardTy, mkHsAppTy, mkHsOpTy, parenthesizeHsType) import GHC_Types_Basic (Boxity (..), PprPrec (..), PromotionFlag (..), appPrec, funPrec, opPrec) import GHC_Types_Name_Occurrence (dataName, tcName, tvName) import GHC_Types_Name_Reader (getRdrName, mkQual, mkUnqual) import GHC_Types_SrcLoc (GenLocated (..), getLoc) import GHC_Utils_Lexeme (isLexCon, isLexConSym, isLexVarSym) #if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,2,0) import GHC_Parser_Annotation (Anchor (..), AnchorOperation (..), EpAnn (..)) import GHC_Types_SrcLoc (srcSpanToRealSrcSpan) #endif #if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,4,0) import GHC.Hs.Extension (noHsUniTok) import GHC.Parser.Annotation (NoEpAnns (..)) #elif !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,2,0) import GHC_Parser_Annotation (EpaLocation (..), TrailingAnn (..)) #endif #if !MIN_VERSION_ghc(9,4,0) && MIN_VERSION_ghc(9,0,0) import GHC_Parser_Annotation (IsUnicodeSyntax (..)) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Builtin_Types (unrestrictedFunTyCon) #else import GHC_Builtin_Types_Prim (funTyCon) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Hs_Type (HsArrow (..), mkHsForAllInvisTele) #else import GHC_Types_Var (ForallVisFlag (..)) #endif -- Internal import Language.Finkel.Builder import Language.Finkel.Data.FastString (lengthFS, nullFS, unconsFS) import Language.Finkel.Form import Language.Finkel.Syntax.Utils -- --------------------------------------------------------------------- -- -- Promotion -- -- --------------------------------------------------------------------- unPromoteTyVar :: HType -> HType unPromoteTyVar ty = case ty of (dL->L l (HsTyVar _EXT _ (L ln name))) -> L l (hsTyVar NotPromoted (L ln name)) _ -> ty {-# INLINABLE unPromoteTyVar #-} -- --------------------------------------------------------------------- -- -- Types -- -- --------------------------------------------------------------------- b_anonWildT :: Code -> HType b_anonWildT (LForm (L l _)) = lA l mkAnonWildCardTy {-# INLINABLE b_anonWildT #-} b_symT :: Code -> Builder HType b_symT whole@(LForm (L l form)) = case form of Atom (ASymbol name) -> return $! ty name _ -> builderError where ty name = case splitQualName name of Just qual -> tv (mkQual (namespace name) qual) Nothing -> case unconsFS name of -- XXX: Handle "StarIsType" language extension. Name of the type kind -- could be obtained from "TysWiredIn.liftedTypeKindTyCon". Just (x, xs) | ',' == x -> tv (getRdrName (tupleTyCon Boxed arity)) | '!' == x -> bang (tv (mkUnqual (namespace xs) xs)) | '*' == x, nullFS xs -> lA l (HsStarTy unused False) _ -> tv (mkUnqual (namespace name) name) where arity = 1 + lengthFS name namespace ns -- Using "isLexVarSym" for "TypeOperator" extension. | isLexCon ns || isLexVarSym ns = tcName | otherwise = tvName tv rname = lA l (hsTyVar NotPromoted (lN l rname)) bang = b_bangT whole {-# INLINABLE b_symT #-} b_unitT :: Code -> HType b_unitT (LForm (L l _)) = lA l (hsTupleTy hsBoxedTuple []) {-# INLINABLE b_unitT #-} b_tildeT :: Code -> HType b_tildeT (LForm (L l _)) = lA l (hsTyVar NotPromoted (lN l eqTyCon_RDR)) {-# INLINABLE b_tildeT #-} b_funT :: Code -> [HType] -> Builder HType b_funT (LForm (L l _)) ts = -- For single argument, making HsAppTy with '(->)' instead of HsFunTy. case ts of [] -> return funty [t] -> return (mkHsAppTy funty t) _ -> return (foldr1 f ts) where f a b = addCLocAA a b (hsFunTy (parenthesizeHsType' funPrec a) b) -- XXX: Does not support linear type and unicode syntax. #if MIN_VERSION_ghc(9,2,0) -- XXX: As of ghc 9.2.1, the 'GHC.Hs.Type.splitHsFunType' function in the -- ghc package is ignoring "EpAnnNotUsed" constructor in the pattern match -- during recursion. Using "EpAnn" to make a dummy EpAnn typed value with -- "mkDummyAnn". Without the dummy value, GADT constructors will show -- compilation errors. # if MIN_VERSION_ghc(9,10,0) hsFunTy = HsFunTy ann (HsUnrestrictedArrow unused) # elif MIN_VERSION_ghc(9,4,0) hsFunTy = HsFunTy ann (HsUnrestrictedArrow noHsUniTok) # else hsFunTy = HsFunTy ann (HsUnrestrictedArrow NormalSyntax) # endif # if MIN_VERSION_ghc(9,10,0) ann = unused # else ann = maybe unused mkDummyAnn (srcSpanToRealSrcSpan l) mkDummyAnn real_span = let dummy_anchor = Anchor real_span UnchangedAnchor # if MIN_VERSION_ghc(9,4,0) dummy_anns = NoEpAnns # else dummy_anns = AddRarrowAnn (EpaSpan real_span) # endif dummy_comments = unused in EpAnn dummy_anchor dummy_anns dummy_comments # endif #elif MIN_VERSION_ghc(9,0,0) hsFunTy = HsFunTy unused (HsUnrestrictedArrow NormalSyntax) #else hsFunTy = HsFunTy unused #endif #if MIN_VERSION_ghc(9,0,0) funty = lA l (hsTyVar NotPromoted (lN l (getRdrName unrestrictedFunTyCon))) #else funty = lA l (hsTyVar NotPromoted (lN l (getRdrName funTyCon))) #endif {-# INLINABLE b_funT #-} b_tyLitT :: Code -> Builder HType b_tyLitT (LForm (L l form)) | Atom (AString stxt str) <- form = return (mkLit l (HsStrTy stxt str)) | Atom (AInteger IL {il_value=n, il_text=stxt}) <- form = return (mkLit l (HsNumTy stxt n)) | otherwise = builderError where mkLit loc lit = lA loc (HsTyLit unused lit) {-# INLINABLE b_tyLitT #-} b_opOrAppT :: Code -> [HType] -> Builder HType b_opOrAppT form@(LForm (L l ty)) typs -- Perhaps empty list | null typs = b_symT form -- Constructor application (not promoted) | Atom (ASymbol name) <- ty , isLexConSym name = let lrname = lN l (mkUnqual tcName name) #if MIN_VERSION_ghc(9,4,0) f lhs rhs = lA l (mkHsOpTy NotPromoted lhs lrname rhs) #else f lhs rhs = lA l (mkHsOpTy lhs lrname rhs) #endif in return (foldr1 f (map (parenthesizeHsType' opPrec) typs)) -- Var type application | otherwise = do op <- b_symT form b_appT (op:typs) {-# INLINABLE b_opOrAppT #-} b_prmConT :: Code -> Builder HType b_prmConT (LForm (L l form)) = case form of Atom (ASymbol name) -> return $! ty name _ -> builderError where ty name = lA l (hsTyVar IsPromoted (lN l (rname name))) rname name = case name of ":" -> getRdrName consDataCon _ -> maybe (mkUnqual (namespace name) name) (mkQual tcName) (splitQualName name) namespace n | isLexCon n = dataName | isLexVarSym n = tcName | otherwise = tvName {-# INLINABLE b_prmConT #-} b_appT :: [HType] -> Builder HType b_appT [] = builderError b_appT (x:xs) = case xs of [] -> return x _ -> let f t1 t2 = addCLocAA t1 t2 (HsAppTy unused t1 (parTyApp t2)) in pure (foldl' f x xs) {-# INLINABLE b_appT #-} b_listT :: HType -> HType b_listT ty@(L l _) = L l (HsListTy unused ty) {-# INLINABLE b_listT #-} b_nilT :: Code -> HType b_nilT (LForm (L l _)) = lA l (hsTyVar NotPromoted (lN l listTyCon_RDR)) {-# INLINABLE b_nilT #-} b_tupT :: Code -> [HType] -> HType b_tupT (LForm (L l _)) ts = case ts of [] -> lA l (hsTyVar NotPromoted (lN l tup)) where tup = getRdrName (tupleTyCon Boxed 2) _ -> lA l (hsTupleTy hsBoxedTuple ts) {-# INLINABLE b_tupT #-} b_bangT :: Code -> HType -> HType b_bangT (LForm (L l _)) t = lA l (hsBangTy srcBang (parTyApp t)) where srcBang = HsSrcBang (SourceText "b_bangT") NoSrcUnpack SrcStrict {-# INLINABLE b_bangT #-} b_forallT :: Code -> ([HTyVarBndrSpecific], ([HType], HType)) -> HType b_forallT (LForm (L l0 _)) (bndrs, (ctxts, body)) = let ty0 = lA l0 (mkHsQualTy' ctxts' body) #if MIN_VERSION_ghc(9,10,0) ctxts' = mkLocatedListA ctxts #else ctxts' = la2la (mkLocatedListA ctxts) #endif ty1 = hsParTy (lA l0 (forAllTy bndrs ty0)) in lA l0 ty1 {-# INLINABLE b_forallT #-} b_qualT :: Code -> ([HType], HType) -> HType b_qualT (LForm (L l _)) (ctxts, body) = #if MIN_VERSION_ghc(9,10,0) lA l (mkHsQualTy' (mkLocatedListA ctxts) body) #else lA l (mkHsQualTy' (la2la (mkLocatedListA ctxts)) body) #endif {-# INLINABLE b_qualT #-} b_kindedType :: Code -> HType -> HType -> HType b_kindedType (LForm (L l _)) ty kind = lA l (hsParTy (lA l (HsKindSig unused ty kind))) {-# INLINABLE b_kindedType #-} b_docT :: HType -> LHsDocString -> HType b_docT ty doc = let l = getLocA ty in lA l (HsDocTy unused ty doc') where doc' = lHsDocString2LHsDoc doc {-# INLINABLE b_docT #-} b_unpackT :: Code -> HType -> HType b_unpackT (LForm (L l _)) t = lA l (hsBangTy bang t') where bang = HsSrcBang (SourceText "b_unpackT") SrcUnpack strictness (strictness, t') = case t of L _ (HsBangTy _EXT (HsSrcBang _ _ st) t0) -> (st, t0) _ -> (NoSrcStrict, t) {-# INLINABLE b_unpackT #-} b_prmListT :: ([Code] -> Builder [HType]) -> Code -> Builder HType b_prmListT prsr typs = case typs of LForm (L l (HsList xs)) | null xs -> return (lA l (hsExplicitListTy [])) | otherwise -> do tys <- prsr xs return $! lA l (hsExplicitListTy tys) _ -> builderError {-# INLINABLE b_prmListT #-} b_prmTupT :: ([Code] -> Builder [HType]) -> [Code] -> Builder HType b_prmTupT prsr typs = case typs of hd:tl | isCommaSymbol hd -> do tys <- prsr tl let tys' = map unPromoteTyVar tys l = getLoc (mkLocatedList (map unLForm typs)) return (lA l (HsExplicitTupleTy unused tys')) _ -> builderError {-# INLINABLE b_prmTupT #-} isCommaSymbol :: Code -> Bool isCommaSymbol (LForm (L _ form)) = case form of Atom (ASymbol ",") -> True _ -> False {-# INLINABLE isCommaSymbol #-} hsTupleTy :: HsTupleSort -> [HType] -> HsType PARSED hsTupleTy = HsTupleTy unused {-# INLINABLE hsTupleTy #-} hsBangTy :: HsSrcBang -> HType -> HsType PARSED hsBangTy = HsBangTy unused {-# INLINABLE hsBangTy #-} forAllTy :: [HTyVarBndrSpecific] -> HType -> HsType PARSED forAllTy bndrs body = HsForAllTy { hst_body = body #if MIN_VERSION_ghc(9,2,0) , hst_tele = mkHsForAllInvisTele unused bndrs #elif MIN_VERSION_ghc(9,0,0) , hst_tele = mkHsForAllInvisTele bndrs #else , hst_bndrs = bndrs , hst_fvf = ForallInvis #endif , hst_xforall = unused } {-# INLINABLE forAllTy #-} hsParTy :: HType -> HsType PARSED hsParTy = HsParTy unused {-# INLINABLE hsParTy #-} hsTyVar :: PromotionFlag -> LIdP PARSED -> HsType PARSED hsTyVar = HsTyVar unused {-# INLINABLE hsTyVar #-} hsExplicitListTy :: [HType] -> HsType PARSED hsExplicitListTy = HsExplicitListTy unused IsPromoted {-# INLINABLE hsExplicitListTy #-} hsBoxedTuple :: HsTupleSort #if MIN_VERSION_ghc(9,2,0) hsBoxedTuple = HsBoxedOrConstraintTuple #else hsBoxedTuple = HsBoxedTuple #endif -- --------------------------------------------------------------------- -- -- Parenthesizing -- -- --------------------------------------------------------------------- -- Unlike "HsTypes.parenthesizeHsType" in ghc 8.6.x, does not -- parenthesize "HsBangTy" constructor, because -- "HsTypes.parenthesizeHsType" is used for parenthesizing argument in -- HsFunTy. -- | Parenthesize given 'HType' with 'appPrec'. parTyApp :: HType -> HType parTyApp = parenthesizeHsType' appPrec {-# INLINABLE parTyApp #-} parenthesizeHsType' :: PprPrec -> HType -> HType parenthesizeHsType' p lty@(L _ ty) | HsBangTy {} <- ty = lty | otherwise = parenthesizeHsType p lty ================================================ FILE: finkel-kernel/src/Language/Finkel/Syntax/Location.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -- For HasLoc (GenLocated l e) {-# LANGUAGE MonoLocalBinds #-} -- | Module for location in Haskell AST module Language.Finkel.Syntax.Location ( -- * Auxiliary function lN, lA, lL , mkLocatedList, mkLocatedListA , mkLocatedListA' -- * Re-export or aliase , LocatedN, LIdP , getLocA, la2la, reLoc, reLocA, addCLocA, addCLocAA , cL, dL ) where #include "ghc_modules.h" -- ghc import GHC_Types_SrcLoc (GenLocated (..), Located, SrcSpan, combineLocs, noLoc) #if MIN_VERSION_ghc(9,10,0) import qualified GHC.Hs.Utils (mkLocatedList) import GHC.Parser.Annotation (HasAnnotation (..), HasLoc (..), LocatedAn, NoAnn (..)) #elif MIN_VERSION_ghc(9,2,0) import GHC.Parser.Annotation (SrcAnn, SrcSpanAnn' (..), addCLocAA, combineLocsA, noAnn, noAnnSrcSpan, reLocA) import GHC.Types.SrcLoc (noSrcSpan) #endif #if MIN_VERSION_ghc(9,2,0) import Language.Haskell.Syntax.Extension (LIdP) #else import GHC.Hs.Extension (LIdP) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Parser.Annotation (LocatedA, LocatedL, LocatedN, addCLocA, getLocA, la2la, reLoc) #else import GHC_Types_SrcLoc (addCLoc, getLoc) #endif #if MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(9,0,0) import SrcLoc (HasSrcSpan, SrcSpanLess) import qualified SrcLoc #endif -- Note [Location helper functions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- From 9.2.x, ghc has shifted to use EPA (Exact Print Annotation), and quite a -- lot of data types with location information has changed to use dedicated type -- synonyms for located elements, such as 'LocatedA', 'LocatedN', 'LocatedL', -- etc. Those new type synonyms are defined in 'GHC.Parser.Annotation' module in -- ghc 9.2.x source. #if !MIN_VERSION_ghc(9,2,0) type LocatedN a = Located a #endif #if MIN_VERSION_ghc(9,2,0) lN :: SrcSpan -> a -> LocatedN a lN l = L (noAnnSrcSpan l) lA :: SrcSpan -> a -> LocatedA a lA l = L (noAnnSrcSpan l) lL :: SrcSpan -> a -> LocatedL a lL l = L (noAnnSrcSpan l) #elif MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(9,0,0) lN :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a lN = cL lA :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a lA = cL lL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a lL = cL #else lN :: SrcSpan -> a -> Located a lN = L lA :: SrcSpan -> a -> Located a lA = L lL :: SrcSpan -> a -> Located a lL = L #endif {-# INLINABLE lN #-} {-# INLINABLE lA #-} {-# INLINABLE lL #-} #if MIN_VERSION_ghc(9,10,0) reLocA :: (HasLoc (GenLocated a e), HasAnnotation b) => GenLocated a e -> GenLocated b e reLocA = reLoc {-# INLINE reLocA #-} addCLocAA :: (HasLoc a, HasLoc b, HasAnnotation l) => a -> b -> c -> GenLocated l c addCLocAA = addCLocA {-# INLINE addCLocAA #-} #endif #if !MIN_VERSION_ghc(9,2,0) getLocA :: Located a -> SrcSpan getLocA = getLoc {-# INLINE getLocA #-} reLoc :: a -> a reLoc = id {-# INLINE reLoc #-} reLocA :: a -> a reLocA = id {-# INLINE reLocA #-} addCLocA :: Located a -> Located b -> c -> Located c addCLocA = addCLoc {-# INLINE addCLocA #-} addCLocAA :: Located a -> Located b -> c -> Located c addCLocAA = addCLoc {-# INLINE addCLocAA #-} la2la :: a -> a la2la = id {-# INLINE la2la #-} #endif -- For 8.8.x and 8.10.x compatibility in source code location management #if MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(9,0,0) dL :: HasSrcSpan a => a -> Located (SrcSpanLess a) dL = SrcLoc.dL cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a cL = SrcLoc.cL #else dL :: a -> a dL = id cL :: s -> a -> GenLocated s a cL = L #endif {-# INLINABLE cL #-} {-# INLINABLE dL #-} -- For concrete 'Located' input and output. mkLocatedList :: [Located a] -> Located [Located a] mkLocatedList [] = noLoc [] mkLocatedList ms@(hd:_) = L (combineLocs hd (last ms)) ms {-# INLINABLE mkLocatedList #-} #if MIN_VERSION_ghc(9,10,0) mkLocatedListA :: (Semigroup a, NoAnn an) => [LocatedAn a e] -> LocatedAn an [LocatedAn a e] mkLocatedListA = GHC.Hs.Utils.mkLocatedList -- The expression is same as 'mkLocatedListA', but the type signature of the -- resulting value has the same annotation as the element of given list. mkLocatedListA' :: (Semigroup a, NoAnn a) => [LocatedAn a e] -> LocatedAn a [LocatedAn a e] mkLocatedListA' = mkLocatedListA #elif MIN_VERSION_ghc(9,2,0) mkLocatedListA :: Semigroup a => [GenLocated (SrcAnn a) e] -> GenLocated (SrcAnn a) [GenLocated (SrcAnn a) e] mkLocatedListA [] = L (SrcSpanAnn noAnn noSrcSpan) [] mkLocatedListA ms@(hd:_) = L (combineLocsA hd (last ms)) ms mkLocatedListA' :: Semigroup a => [GenLocated (SrcAnn a) e] -> GenLocated (SrcAnn a) [GenLocated (SrcAnn a) e] mkLocatedListA' = mkLocatedListA #else mkLocatedListA :: [Located a] -> Located [Located a] mkLocatedListA = mkLocatedList mkLocatedListA' :: [Located a] -> Located [Located a] mkLocatedListA' = mkLocatedList #endif {-# INLINABLE mkLocatedListA #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Syntax/Utils.hs ================================================ {-# LANGUAGE CPP #-} -- | Utility codes for syntax. module Language.Finkel.Syntax.Utils ( -- * This module module Language.Finkel.Syntax.Utils -- * Extension module , module Language.Finkel.Syntax.Extension -- * Location module , module Language.Finkel.Syntax.Location ) where #include "ghc_modules.h" -- base #if MIN_VERSION_ghc(9,0,0) import Control.Applicative (Alternative (..)) #endif import Data.Char (isUpper) -- ghc import GHC_Builtin_Types (consDataConName) import GHC_Data_FastString (appendFS, bytesFS, consFS) import GHC_Data_OrdList (OrdList) import GHC_Hs_Decls (DerivStrategy (..), LConDecl, LDataFamInstDecl, LDocDecl, LFamilyDecl, LTyFamInstDecl) import GHC_Hs_Doc (LHsDocString) import GHC_Hs_Pat (LHsRecField, LHsRecUpdField) import GHC_Hs_Type (AmbiguousFieldOcc (..), FieldOcc (..), HsTyVarBndr (..), HsType (..), LHsContext, mkFieldOcc) import GHC_Parser_Lexer (P (..), ParseResult (..)) import qualified GHC_Parser_PostProcess as PostProcess import GHC_Types_Name_Occurrence (NameSpace, srcDataName, tcName, tvName, varName) import GHC_Types_Name_Reader (RdrName, mkQual, mkUnqual, mkVarUnqual, nameRdrName) import GHC_Types_SrcLoc (GenLocated (..), Located, unLoc) import GHC_Utils_Lexeme (isLexCon, isLexConSym, isLexVar, isLexVarSym) #if MIN_VERSION_ghc(9,10,0) import GHC.Parser.Annotation (noAnnSrcSpan) #elif MIN_VERSION_ghc(9,4,0) import GHC.Parser.Annotation (SrcSpanAnn' (..), noComments) #endif #if MIN_VERSION_ghc(9,8,0) import Language.Haskell.Syntax.Type (HsBndrVis (..)) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Hs.Doc (LHsDoc) import GHC.Hs.DocString (HsDocStringDecorator (..)) import GHC.Hs.Pat (HsFieldBind (..)) import GHC.Parser (parseIdentifier) import GHC.Parser.HaddockLex (lexHsDoc) import GHC.Types.SrcLoc (SrcSpan) #else import GHC_Hs_Pat (HsRecField' (..)) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Hs.Extension (GhcPass (..)) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Hs_Decls (ConDecl (..)) import GHC_Hs_Type (LHsTyVarBndr) import GHC_Types_Var (Specificity (..)) #else import HaddockUtils (addConDoc) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Hs.Doc (HsDocString (..), mkHsDocStringChunkUtf8ByteString) #else import GHC_Hs_Doc (HsDocString, mkHsDocStringUtf8ByteString) #endif -- Internal import Language.Finkel.Builder import Language.Finkel.Data.FastString (FastString, fsLit, unconsFS, unpackFS) import Language.Finkel.Form import Language.Finkel.Syntax.Extension import Language.Finkel.Syntax.Location -- ------------------------------------------------------------------------ -- -- Types -- -- ------------------------------------------------------------------------ -- | An alias for record field to suuport named field puns and record wild -- cards. -- -- @Left form@ represent a record wild pattern with @form@ being the @..@ -- code form, @Right (fld, Nothing)@ means named field pun with @fld@ being the -- punned field name, and @Right (fld, Just x)@ is a traditional @field = x@ -- style form. type PreRecField a = Either Code (Located FastString, Maybe a) -- ------------------------------------------------------------------------ -- -- Functions -- -- ------------------------------------------------------------------------ mkRdrName :: FastString -> RdrName mkRdrName = mkRdrName' tcName {-# INLINABLE mkRdrName #-} mkVarRdrName :: FastString -> RdrName mkVarRdrName = mkRdrName' srcDataName {-# INLINABLE mkVarRdrName #-} mkRdrName' :: NameSpace -> FastString -> RdrName mkRdrName' upperCaseNameSpace name -- ':' is special syntax. It is defined in module "GHC.Types" in -- package "ghc-prim", but not exported. | name == fsLit ":" = nameRdrName consDataConName -- Names starting with ':' are data constructor. | nameStartsWith (== ':') = mkUnqual srcDataName name -- Names starting with capital letters might be qualified var names or -- data constructor names. | nameStartsWith isUpper = case splitQualName name of Nothing -> mkUnqual upperCaseNameSpace name Just q@(_, name') -> if isLexCon name' then mkQual upperCaseNameSpace q else mkQual varName q -- Variable. | otherwise = mkVarUnqual name where nameStartsWith test = case unconsFS name of Just (x,_) -> test x _ -> False {-# INLINABLE mkRdrName' #-} -- See also "compiler/parser/Lexer.x.source" in ghc source code. It has -- private function named "splitQualName". splitQualName :: FastString -> Maybe (FastString, FastString) splitQualName fstr = -- e.g. ":.+.", ":+:". Symbol may contain ".". if isLexConSym fstr then Nothing else go (unpackFS fstr) "" [] where go [] tmp acc = case concat acc of [] -> Nothing _:tl -> let mdl = reverse tl var = reverse tmp in Just (fsLit mdl, fsLit var) go "." tmp acc = go [] ('.':tmp) acc go ('.':cs) tmp acc = go cs [] (('.':tmp) : acc) go (c:cs) tmp acc = go cs (c:tmp) acc {-# INLINABLE splitQualName #-} checkVarId :: Code -> FastString -> Builder () checkVarId orig name = if isLexVar name then return () else setLastToken orig >> failB "Invalid variable identifier" {-# INLINABLE checkVarId #-} getConId :: Code -> Builder FastString getConId orig@(LForm (L _ form)) = case form of Atom (ASymbol sym) -- `isLexVarSym' is for "TypeOperators" extension. | isLexCon sym -> return sym | isLexVarSym sym -> return sym _ -> setLastToken orig >> failB "Invalid constructor identifier" {-# INLINABLE getConId #-} getLConId :: Code -> Builder (Located FastString) getLConId orig@(LForm (L l _)) = fmap (L l) (getConId orig) {-# INLINABLE getLConId #-} getVarOrConId :: Code -> Builder FastString getVarOrConId orig@(LForm (L _ form)) = case form of Atom (ASymbol sym) | isLexCon sym -> return sym | isLexVar sym -> return sym _ -> setLastToken orig >> failB "Invalid identifier" {-# INLINABLE getVarOrConId #-} -- | Convert record field constructor expression to record field update -- expression. cfld2ufld :: LHsRecField PARSED HExpr #if MIN_VERSION_ghc(9,8,0) -> LHsRecUpdField PARSED PARSED #else -> LHsRecUpdField PARSED #endif -- Almost same as 'mk_rec_upd_field' in 'RdrHsSyn' #if MIN_VERSION_ghc(9,4,0) cfld2ufld (L l0 (HsFieldBind _ann (L l1 (FieldOcc _ rdr)) rhs pun)) = L l0 (HsFieldBind unused (L l1 (Unambiguous unused rdr)) rhs pun) #elif MIN_VERSION_ghc(9,2,0) cfld2ufld (L l0 (HsRecField _ (L l1 (FieldOcc _ rdr)) arg pun)) = L l0 (HsRecField unused (L l1 (Unambiguous unused rdr)) arg pun) #else cfld2ufld (L l0 (HsRecField (L l1 (FieldOcc _ rdr)) arg pun)) = L l0 (HsRecField (L l1 unambiguous) arg pun) where unambiguous = Unambiguous unused rdr # if !MIN_VERSION_ghc(9,0,0) cfld2ufld _ = error "Language.Finkel.Syntax.Utils:cfld2ufld" # endif #endif {-# INLINABLE cfld2ufld #-} -- | Make 'HsRecField' with given name and located data. mkcfld :: Bool -> (Located FastString, a) -> LHsRecField PARSED a mkcfld is_pun (L nl name, e) = #if MIN_VERSION_ghc(9,10,0) lA nl HsFieldBind { hfbAnn = unused , hfbLHS = L (noAnnSrcSpan nl) (mkFieldOcc (lN nl (mkRdrName name))) , hfbRHS = e , hfbPun = is_pun } #elif MIN_VERSION_ghc(9,4,0) lA nl HsFieldBind { hfbAnn = unused -- XXX: Not much sure below location is appropriate , hfbLHS = L (SrcSpanAnn noComments nl) (mkFieldOcc (lN nl (mkRdrName name))) , hfbRHS = e , hfbPun = is_pun } #elif MIN_VERSION_ghc(9,2,0) lA nl HsRecField { hsRecFieldLbl = L nl (mkFieldOcc (lN nl (mkRdrName name))) , hsRecFieldAnn = unused , hsRecFieldArg = e , hsRecPun = is_pun } #else lA nl HsRecField { hsRecFieldLbl = L nl (mkFieldOcc (lN nl (mkRdrName name))) , hsRecFieldArg = e , hsRecPun = is_pun } #endif {-# INLINABLE mkcfld #-} -- | Dummy name for named field puns. See: @GHC.Parser.PostProcess.pun_RDR@. punRDR :: RdrName punRDR = mkUnqual varName (fsLit "pun-right-hand-side") {-# INLINABLE punRDR #-} -- Following `cvBindsAndSigs`, `getMonoBind`, `has_args`, and -- `makeFunBind` functions are based on resembling functions defined in -- `RdrHsSyn` module in ghc package. -- -- Unlike the original version, `cvBindsAndSigs` has pattern matches -- for 'ValD' and 'SigD' only, and `getMonoBind` ignores 'DocD' -- declarations. #if MIN_VERSION_ghc(9,2,0) type LDocDecl' a = LDocDecl a #else type LDocDecl' a = LDocDecl #endif data CategorizedDecls = CategorizedDecls { cd_binds :: HBinds , cd_sigs :: [HSig] , cd_fds :: [LFamilyDecl PARSED] , cd_tfis :: [LTyFamInstDecl PARSED] , cd_dfis :: [LDataFamInstDecl PARSED] , cd_docs :: [LDocDecl' PARSED] } toCategorizedDecls :: ( HBinds , [HSig] , [LFamilyDecl PARSED] , [LTyFamInstDecl PARSED] , [LDataFamInstDecl PARSED] , [LDocDecl' PARSED] ) -> CategorizedDecls toCategorizedDecls (binds, sigs, fds, tfis, dfis, docs) = CategorizedDecls { cd_binds = binds , cd_sigs = sigs , cd_fds = fds , cd_tfis = tfis , cd_dfis = dfis , cd_docs = docs } cvBindsAndSigs :: OrdList HDecl -> Builder CategorizedDecls cvBindsAndSigs fb = do ps <- fmap ghcPState getBState case unP (fmap toCategorizedDecls (PostProcess.cvBindsAndSigs fb)) ps of POk _ cd -> return cd _ -> builderError kindedTyVar :: Code -> Code -> HType -> Builder HTyVarBndrVis kindedTyVar (LForm (L l _dc)) name kind = case name of LForm (L ln (Atom (ASymbol name'))) -> do let name'' = lN ln (mkUnqual tvName name') #if MIN_VERSION_ghc(9,10,0) return $! lA l (KindedTyVar unused (HsBndrRequired unused) name'' kind) #elif MIN_VERSION_ghc(9,8,0) return $! lA l (KindedTyVar unused HsBndrRequired name'' kind) #elif MIN_VERSION_ghc(9,0,0) return $! lA l (KindedTyVar unused () name'' kind) #else return $! L l (KindedTyVar unused name'' kind) #endif _ -> builderError {-# INLINABLE kindedTyVar #-} kindedTyVarSpecific :: Code -> Code -> HType -> Builder HTyVarBndrSpecific #if MIN_VERSION_ghc(9,0,0) kindedTyVarSpecific (LForm (L l _dc)) name kind = case name of LForm (L ln (Atom (ASymbol name'))) -> do let name'' = lN ln (mkUnqual tvName name') return $! lA l (KindedTyVar unused SpecifiedSpec name'' kind) _ -> builderError #else kindedTyVarSpecific = kindedTyVar #endif {-# INLINABLE kindedTyVarSpecific #-} #if MIN_VERSION_ghc(9,10,0) codeToUserTyVar :: Code -> HTyVarBndrVis codeToUserTyVar code = -- XXX: Always using HsBndrRequired. case code of LForm (L l (Atom (ASymbol name))) -> let bvis = HsBndrRequired unused in lA l (UserTyVar unused bvis (lN l (mkUnqual tvName name))) _ -> error "Language.Finkel.Syntax.Utils:codeToUserTyVar" codeToUserTyVarSpecific :: Code -> LHsTyVarBndr Specificity PARSED codeToUserTyVarSpecific code = case code of LForm (L l (Atom (ASymbol name))) -> lA l (UserTyVar unused SpecifiedSpec (lN l (mkUnqual tvName name))) -- XXX: Does not support 'InferredSpec' yet. _ -> error "Language.Finkel.Syntax.Utils:codeToUserTyVarSpecific" #elif MIN_VERSION_ghc(9,8,0) codeToUserTyVar :: Code -> HTyVarBndrVis codeToUserTyVar code = case code of LForm (L l (Atom (ASymbol name))) -> lA l (UserTyVar unused HsBndrRequired (lN l (mkUnqual tvName name))) _ -> error "Language.Finkel.Syntax.Utils:codeToUserTyVar" codeToUserTyVarSpecific :: Code -> LHsTyVarBndr Specificity PARSED codeToUserTyVarSpecific code = -- XXX: Does not support 'InferredSpec' yet. case code of LForm (L l (Atom (ASymbol name))) -> lA l (UserTyVar unused SpecifiedSpec (lN l (mkUnqual tvName name))) _ -> error "Language.Finkel.Syntax.Utils:codeToUserTyVarSpecific" #elif MIN_VERSION_ghc(9,0,0) codeToUserTyVar :: Code -> LHsTyVarBndr () PARSED codeToUserTyVar code = case code of LForm (L l (Atom (ASymbol name))) -> lA l (UserTyVar unused () (lN l (mkUnqual tvName name))) _ -> error "Language.Finkel.Syntax.Utils:codeToUserTyVar" codeToUserTyVarSpecific :: Code -> LHsTyVarBndr Specificity PARSED codeToUserTyVarSpecific code = case code of LForm (L l (Atom (ASymbol name))) -> lA l (UserTyVar unused SpecifiedSpec (lN l (mkUnqual tvName name))) -- XXX: Does not support 'InferredSpec' yet. _ -> error "Language.Finkel.Syntax.Utils:codeToUserTyVarSpecific" #else codeToUserTyVar :: Code -> HTyVarBndr codeToUserTyVar code = case code of LForm (L l (Atom (ASymbol name))) -> L l (UserTyVar unused (L l (mkUnqual tvName name))) _ -> error "Language.Finkel.Syntax.Utils:codeToUserTyVar" codeToUserTyVarSpecific :: Code -> HTyVarBndrSpecific codeToUserTyVarSpecific = codeToUserTyVar #endif {-# INLINABLE codeToUserTyVar #-} {-# INLINABLE codeToUserTyVarSpecific #-} -- XXX: Move HsDocString related functions to separate module? #if !MIN_VERSION_ghc(9,4,0) -- These two types did not exist in ghc < 9.4, setting up simple aliases. type LHsDoc pass = HsDocString type HsDocStringDecorator = () -- dummy, not in use. #endif -- | Auxiliary function to make 'HsDocString'. mkHsDocString :: FastString -> HsDocString #if MIN_VERSION_ghc(9,4,0) mkHsDocString = GeneratedDocString . mkHsDocStringChunkUtf8ByteString . bytesFS #else mkHsDocString = mkHsDocStringUtf8ByteString . bytesFS #endif {-# INLINABLE mkHsDocString #-} #if MIN_VERSION_ghc(9,4,0) lHsDocString2LHsDoc :: LHsDocString -> LHsDoc PARSED lHsDocString2LHsDoc = fmap (lexHsDoc parseIdentifier) mkLHsDoc :: SrcSpan -> FastString -> LHsDoc PARSED mkLHsDoc l = lHsDocString2LHsDoc . L l . mkHsDocString mkLHsDocWithDecorator :: HsDocStringDecorator -> SrcSpan -> FastString -> LHsDoc PARSED mkLHsDocWithDecorator deco l fs = lHsDocString2LHsDoc (L l (mkHsDocStringWithDecorator deco l fs)) mkHsDocStringWithDecorator :: HsDocStringDecorator -> SrcSpan -> FastString -> HsDocString mkHsDocStringWithDecorator decorator loc fs = let chunk = mkHsDocStringChunkUtf8ByteString (bytesFS fs) in NestedDocString decorator (L loc chunk) #else lHsDocString2LHsDoc :: a -> a lHsDocString2LHsDoc = id mkLHsDoc :: a -> FastString -> HsDocString mkLHsDoc _ = mkHsDocString mkLHsDocWithDecorator :: a -> b -> FastString -> LHsDoc PARSED mkLHsDocWithDecorator _ _ = mkHsDocString mkHsDocStringWithDecorator :: a -> b -> FastString -> HsDocString mkHsDocStringWithDecorator _ _ = mkHsDocString #endif {-# INLINABLE lHsDocString2LHsDoc #-} {-# INLINABLE mkLHsDoc #-} {-# INLINABLE mkLHsDocWithDecorator #-} {-# INLINABLE mkHsDocStringWithDecorator #-} hsDocStringNext, hsDocStringPrevious :: HsDocStringDecorator #if MIN_VERSION_ghc(9,4,0) hsDocStringNext = HsDocStringNext hsDocStringPrevious = HsDocStringPrevious #else hsDocStringNext = () hsDocStringPrevious = () #endif {-# INLINABLE hsDocStringNext #-} {-# INLINABLE hsDocStringPrevious #-} mkHsQualTy' :: LHsContext PARSED -> HType -> HsType PARSED mkHsQualTy' ctxt body | nullLHsContext ctxt = unLoc body | otherwise = HsQualTy { hst_ctxt = real_ctxt , hst_xqual = unused , hst_body = body } where #if MIN_VERSION_ghc(9,4,0) real_ctxt = ctxt #elif MIN_VERSION_ghc(9,2,0) real_ctxt = Just ctxt #else real_ctxt = ctxt #endif {-# INLINABLE mkHsQualTy' #-} nullLHsContext :: LHsContext PARSED -> Bool nullLHsContext (L _ cs) = null cs {-# INLINABLE nullLHsContext #-} #if MIN_VERSION_ghc(9,4,0) addConDoc' :: Maybe LHsDocString -> LConDecl PARSED -> LConDecl PARSED #else addConDoc' :: Maybe LHsDocString -> LConDecl' a -> LConDecl' a #endif addConDoc' = flip addConDoc {-# INLINABLE addConDoc' #-} #if MIN_VERSION_ghc(9,4,0) addConDoc'' :: LHsDocString -> LConDecl PARSED -> LConDecl PARSED #else addConDoc'' :: LHsDocString -> LConDecl' a -> LConDecl' a #endif addConDoc'' = flip addConDoc . Just {-# INLINABLE addConDoc'' #-} #if MIN_VERSION_ghc(9,2,0) type LConDecl' a = LConDecl (GhcPass a) #else type LConDecl' a = LConDecl a #endif #if MIN_VERSION_ghc(9,4,0) addConDoc :: LConDecl PARSED -> Maybe LHsDocString -> LConDecl PARSED addConDoc decl Nothing = decl addConDoc (L p c) (Just ld) = L p (c {con_doc = con_doc c <|> doc'}) where doc' = case ld of L l d -> Just (L l (lexHsDoc parseIdentifier d)) {-# INLINABLE addConDoc #-} #elif MIN_VERSION_ghc(9,0,0) addConDoc :: LConDecl' a -> Maybe LHsDocString -> LConDecl' a addConDoc decl Nothing = decl addConDoc (L p c) doc = L p (c {con_doc = con_doc c <|> doc}) {-# INLINABLE addConDoc #-} #endif consListWith :: [Code] -> String -> Code consListWith rest sym = LForm (genSrc (List (LForm (genSrc (Atom (aSymbol sym))) : rest))) {-# INLINABLE consListWith #-} fsSymbol :: Code -> Builder (Located FastString) fsSymbol (LForm (L l x)) = case x of Atom (ASymbol sym) -> pure (L l sym) _ -> builderError {-# INLINABLE fsSymbol #-} stockStrategy, anyclassStrategy, newtypeStrategy :: DerivStrategy PARSED #if MIN_VERSION_ghc(9,2,0) stockStrategy = StockStrategy unused anyclassStrategy = AnyclassStrategy unused newtypeStrategy = NewtypeStrategy unused #else stockStrategy = StockStrategy anyclassStrategy = AnyclassStrategy newtypeStrategy = NewtypeStrategy #endif {-# INLINABLE stockStrategy #-} {-# INLINABLE anyclassStrategy #-} {-# INLINABLE newtypeStrategy #-} wrapWithSpaces :: FastString -> FastString wrapWithSpaces fs = consFS ' ' (appendFS fs (fsLit " ")) {-# INLINABLE wrapWithSpaces #-} ================================================ FILE: finkel-kernel/src/Language/Finkel/Syntax.y ================================================ -- -*- mode: haskell; -*- { {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | Module for parsing form data. -- -- This module contains Happy parser for S-expression forms. Unlike the lexer -- for reading source code, parser defined in this module takes a list of 'Code' -- data as input, and converts to internal abstract syntax tree data defined in -- GHC. -- module Language.Finkel.Syntax ( -- * Forms for documentation comment -- $docforms -- * Haskell AST parsers parseModule , parseModuleNoHeader , parseHeader , parseImports , parseLImport , parseStmt , parseDecls , parseTopDecls , parseExpr , parseType ) where #include "ghc_modules.h" -- ghc import GHC_Data_FastString (FastString) import GHC_Hs_Doc (LHsDocString) import GHC_Hs_Expr (GRHS(..)) import GHC_Types_Basic ( Activation(..), InlineSpec(..), OverlapMode(..) ) import GHC_Types_Fixity (FixityDirection (..)) import GHC_Types_ForeignCall (Safety) import GHC_Types_SrcLoc (GenLocated(..), Located, getLoc, noLoc) import GHC_Types_SourceText (SourceText (..)) import GHC_Hs_Decls (DerivStrategy(..)) #if MIN_VERSION_ghc(9,10,0) import GHC.Parser.Annotation (NoAnn(..)) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Parser.Annotation (LocatedA, LocatedAn, la2la) #endif -- Internal import Language.Finkel.Builder import Language.Finkel.Form import Language.Finkel.Syntax.HDecl import Language.Finkel.Syntax.HExpr import Language.Finkel.Syntax.HImpExp import Language.Finkel.Syntax.HPat import Language.Finkel.Syntax.HType import Language.Finkel.Syntax.Utils } %name parse_module module %name parse_module_no_header module_no_header %partial parse_header header %name p_mod_header mod_header %name p_entity entity %name p_entities entities %name p_imports imports %name p_limport limport %name p_top_decls top_decls %name p_top_decl top_decl %name p_decl decl %name p_decls decls %name p_decl_tsig decl_tsig %name p_lcdecl lcdecl %name p_lidecl lidecl %name p_field_detail field_detail %name p_lqtycl lqtycl %name p_sfsig sfsig %name p_lsimpletype lsimpletype %name p_ldinsthd ldinsthd %name p_famconhd famconhd %name p_lfinsthd lfinsthd %name p_lfameq lfameq %name p_phase phase %name p_type type %name p_types types %name p_types0 types0 %name p_lconstr lconstr %name p_lqtycon lqtycon %name p_lkindtv lkindtv %name p_lkindtv_specific lkindtv_specific %name p_lh98constr lh98constr %name p_deriving_clause deriving_clause %name p_standalone_deriv standalone_deriv %name p_pat pat %name p_pats pats %name p_pats0 pats0 %name p_pats1 pats1 %name p_label1p label1p %name p_expr expr %name p_exprs exprs %name p_hlist hlist %name p_match match %name p_guards0 guards0 %name p_guards1 guards1 %name p_guard guard %name p_where where %name p_lbinds0 lbinds0 %name p_rfbind rfbind %name p_app app %name p_stmt stmt %name p_stmt1 stmt1 %tokentype { Code } %monad { Builder } %lexer { formLexer } { LForm (L _ TEnd) } %token -- Haskell 2010 reserved ids 'case' { LForm (L _ (Atom (ASymbol "case"))) } 'class' { LForm (L _ (Atom (ASymbol "class"))) } 'data' { LForm (L _ (Atom (ASymbol "data"))) } 'default' { LForm (L _ (Atom (ASymbol "default"))) } 'deriving' { LForm (L _ (List (LForm (L _ (Atom (ASymbol "deriving"))):$$))) } 'do' { LForm (L _ (Atom (ASymbol "do"))) } 'foreign' { LForm (L _ (Atom (ASymbol "foreign"))) } 'if' { LForm (L _ (Atom (ASymbol "if"))) } 'import' { LForm (L _ (List ((LForm (L _ (Atom (ASymbol "import")))):$$))) } 'infix' { LForm (L _ (Atom (ASymbol "infix"))) } 'infixl' { LForm (L _ (Atom (ASymbol "infixl"))) } 'infixr' { LForm (L _ (Atom (ASymbol "infixr"))) } 'instance' { LForm (L _ (Atom (ASymbol "instance"))) } 'let' { LForm (L _ (Atom (ASymbol "let"))) } 'module' { LForm (L _ (List ((LForm (L _ (Atom (ASymbol "module")))):$$))) } 'newtype' { LForm (L _ (Atom (ASymbol "newtype"))) } 'type' { LForm (L _ (Atom (ASymbol "type"))) } 'where' { LForm (L _ (List ((LForm (L _ (Atom (ASymbol "where")))):$$))) } '!' { LForm (L _ (Atom (ASymbol "!"))) } ',' { LForm (L _ (Atom (ASymbol ","))) } '->' { LForm (L _ (Atom (ASymbol "->"))) } '..' { LForm (L _ (Atom (ASymbol ".."))) } '::' { LForm (L _ (Atom (ASymbol "::"))) } '<-' { LForm (L _ (Atom (ASymbol "<-"))) } '=' { LForm (L _ (Atom (ASymbol "="))) } '=>' { LForm (L _ (Atom (ASymbol "=>"))) } '@' { LForm (L _ (Atom (ASymbol "@"))) } '\\' { LForm (L _ (Atom (ASymbol "\\"))) } '{' { LForm (L _ (Atom (ASymbol "{"))) } '|' { LForm (L _ (Atom (ASymbol "|"))) } '}' { LForm (L _ (Atom (ASymbol "}"))) } '~' { LForm (L _ (Atom (ASymbol "~"))) } '_' { LForm (L _ (Atom (ASymbol "_"))) } -- Non Haskell 2010 reserved id, but treated specially 'as' { LForm (L _ (Atom (ASymbol "as"))) } 'hiding' { LForm (L _ (Atom (ASymbol "hiding"))) } 'qualified' { LForm (L _ (Atom (ASymbol "qualified"))) } -- GHC Extensions 'anyclass' { LForm (L _ (Atom (ASymbol "anyclass"))) } 'family' { LForm (L _ (Atom (ASymbol "family"))) } 'forall' { LForm (L _ (Atom (ASymbol "forall"))) } 'stock' { LForm (L _ (Atom (ASymbol "stock"))) } 'via' { LForm (L _ (Atom (ASymbol "via"))) } -- Pragmas 'inlinable' { LForm (L _ (Atom (ASymbol "INLINABLE"))) } 'inline' { LForm (L _ (Atom (ASymbol "INLINE"))) } 'noinline' { LForm (L _ (Atom (ASymbol "NOINLINE"))) } 'specialize' { LForm (L _ (Atom (ASymbol "SPECIALIZE"))) } 'unpack' { LForm (L _ (List [LForm (L _ (Atom (ASymbol "UNPACK")))])) } 'overlappable' { LForm (L _ (List [LForm (L _ (Atom (ASymbol "OVERLAPPABLE")))])) } 'overlapping' { LForm (L _ (List [LForm (L _ (Atom (ASymbol "OVERLAPPING")))])) } 'overlaps' { LForm (L _ (List [LForm (L _ (Atom (ASymbol "OVERLAPS")))])) } 'incoherent' { LForm (L _ (List [LForm (L _ (Atom (ASymbol "INCOHERENT")))])) } -- Documentation forms 'doc' { LForm (L _ (List [LForm (L _ (Atom (ASymbol ":doc"))), $$])) } 'doc^' { LForm (L _ (List [LForm (L _ (Atom (ASymbol ":doc^"))), $$])) } 'doc$' { LForm (L _ (List (LForm (L _ (Atom (ASymbol ":doc$"))) : _))) } 'dh1' { LForm (L _ (List (LForm (L _ (Atom (ASymbol ":dh1"))) : _))) } 'dh2' { LForm (L _ (List (LForm (L _ (Atom (ASymbol ":dh2"))) : _))) } 'dh3' { LForm (L _ (List (LForm (L _ (Atom (ASymbol ":dh3"))) : _))) } 'dh4' { LForm (L _ (List (LForm (L _ (Atom (ASymbol ":dh4"))) : _))) } -- Finkel specific quote primitive ':quote' { LForm (L _ (Atom (ASymbol ":quote"))) } -- Plain constructors 'symbol' { LForm (L _ (Atom (ASymbol _))) } 'char' { LForm (L _ (Atom (AChar _ _))) } 'string' { LForm (L _ (Atom (AString _ _))) } 'integer' { LForm (L _ (Atom (AInteger _))) } 'frac' { LForm (L _ (Atom (AFractional _))) } 'unit' { LForm (L _ (Atom AUnit)) } 'list' { LForm (L _ (List _)) } 'hslist' { LForm (L _ (HsList _)) } %% -- --------------------------------------------------------------------- -- -- For getting elements from list form -- -- --------------------------------------------------------------------- list_es :: { [Code] } : 'list' {% case unCode $1 of List xs -> pure xs; _ -> builderError } -- --------------------------------------------------------------------- -- -- Documentation -- -- --------------------------------------------------------------------- docnext :: { LHsDocString } : 'doc' {% b_docStringNext $1} docprev :: { LHsDocString } : 'doc^' {% b_docStringPrev $1 } mbdocprev :: { Maybe LHsDocString } : docprev { Just $1 } | {- empty -} { Nothing } -- --------------------------------------------------------------------- -- -- Module -- -- --------------------------------------------------------------------- -- Note: [module_no_header parser] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- The top level "module_no_header" parser is used by ":eval-when-compile" -- special form, which does not contain module header in its body form. Since -- the ":eval-when-compile" allows to parse body forms consists of module -- imports only, using dedicated parser to support such situations. module :: { HModule } : mhead imports top_decls {% $1 `fmap` pure $2 <*> pure $3 } | imports top_decls {% b_implicitMainModule <*> pure $1 <*> pure $2 } | mhead imports {% $1 `fmap` pure $2 <*> pure [] } | mhead top_decls {% $1 `fmap` pure [] <*> pure $2 } | top_decls {% b_implicitMainModule <*> pure [] <*> pure $1 } module_no_header :: { HModule } : imports {% b_implicitMainModule <*> pure $1 <*> pure [] } | imports top_decls {% b_implicitMainModule <*> pure $1 <*> pure $2 } | top_decls {% b_implicitMainModule <*> pure [] <*> pure $1 } mhead :: { [HImportDecl] -> [HDecl] -> HModule } : 'module' {% parse p_mod_header $1 <*> pure Nothing } | docnext 'module' {% parse p_mod_header $2 <*> pure (Just $1) } mod_header :: { Maybe LHsDocString -> [HImportDecl] -> [HDecl] -> HModule } : 'symbol' exports {% b_module (Just $1) $2 } exports :: { [HIE] } : rexports { reverse $1 } rexports :: { [HIE] } : {- empty -} { [] } | rexports export { $2 : $1 } export :: { HIE } : idsym {% b_ieSym $1 } | 'module' {% b_ieMdl $1 } | 'dh1' {% b_ieGroup 1 $1 } | 'dh2' {% b_ieGroup 2 $1 } | 'dh3' {% b_ieGroup 3 $1 } | 'dh4' {% b_ieGroup 4 $1 } | 'doc' {% b_ieDoc $1 } | 'doc$' {% b_ieDocNamed $1 } | list_es {% parse p_entity $1 } entity :: { HIE } : conid {- empty -} {% b_ieAbs $1 } | conid '..' {% b_ieAll $1 } | conid idsyms1 {% b_ieWith $1 $2 } entities :: { [HIE] } : rentities { reverse $1 } rentities :: { [HIE] } : {- empty -} { [] } | rentities idsym {% b_ieSym $2 >>= \es -> return (es:$1) } | rentities list_es {% fmap (:$1) (parse p_entity $2) } imports :: { [HImportDecl] } : rimports { reverse $1 } rimports :: { [HImportDecl] } : import { [$1] } | rimports import { $2 : $1 } import :: { HImportDecl } : 'import' {% parse p_limport $1 } limport :: { HImportDecl } : 'qualified' 'symbol' 'as' 'symbol' impspec {% b_importD ($2, True, Just $4) $5 } | 'qualified' 'symbol' impspec {% b_importD ($2, True, Nothing) $3 } | 'symbol' 'as' 'symbol' impspec {% b_importD ($1, False, Just $3) $4 } | 'symbol' impspec {% b_importD ($1, False, Nothing) $2 } impspec :: { (Bool, Maybe [HIE]) } : 'hiding' list_es {% do { es <- parse p_entities $2 ; return (True, Just es) } } | list_es {% do { es <- parse p_entities $1 ; return (False, Just es) } } | 'unit' { (False, Just []) } | {- empty -} { (False, Nothing) } -- Module declaration & imports only header :: { HModule } : mhead imports {% $1 `fmap` pure $2 <*> pure [] } | mhead {% $1 `fmap` pure [] <*> pure [] } | imports {% b_implicitMainModule <*> pure $1 <*> pure [] } | {- empty -} {% b_implicitMainModule <*> pure [] <*> pure [] } -- --------------------------------------------------------------------- -- -- Declarations -- -- --------------------------------------------------------------------- top_decls :: { [HDecl] } : rtop_decls { reverse $1 } rtop_decls :: { [HDecl] } : top_decl_with_doc { [$1] } | rtop_decls top_decl_with_doc { $2 : $1 } top_decl_with_doc :: { HDecl } : list_es {% parse p_top_decl $1 } | 'deriving' {% parse p_standalone_deriv $1 } | 'doc' {% b_docnextD $1 } | 'doc^' {% b_docprevD $1 } | 'dh1' {% b_docGroupD 1 $1 } | 'dh2' {% b_docGroupD 2 $1 } | 'dh3' {% b_docGroupD 3 $1 } | 'dh4' {% b_docGroupD 4 $1 } | 'doc$' {% b_docNamed $1 } top_decl :: { HDecl } : 'data' simpletype constrs { b_dataD $1 $2 $3 } | 'data' 'family' dconhead { b_datafamD $1 $3 } | 'data' 'instance' dinsthd constrs { b_datainstD $1 $3 $4 } | 'type' simpletype type { b_typeD $1 $2 $3 } | 'type' simpletype {% b_standaloneKindSigD $1 $2 } | 'type' 'family' dconhead fameqs { b_tyfamD $4 $1 $3 } | 'type' 'instance' finsthd type { b_tyinstD $1 $3 $4 } | 'newtype' simpletype constrs { b_newtypeD $1 $2 $3 } | 'newtype' 'instance' dinsthd constrs { b_newtypeinstD $1 $3 $4 } | 'class' qtycl cdecls {% b_classD $2 $3 } | 'instance' overlap qtycl idecls {% b_instD $2 $3 $4 } | 'default' zero_or_more_types { b_defaultD $2 } | fixity 'integer' idsyms1 {% b_fixityD $1 $2 $3 } | foreign { $1 } | decl { $1 } dinsthd :: { (Located FastString, [HType], Maybe HType) } : conid {% getLConId $1 >>= \ln -> pure (ln, [], Nothing) } | list_es {% parse p_ldinsthd $1 } ldinsthd :: { (Located FastString, [HType], Maybe HType) } : '::' finsthd type { case $2 of (n,ts) -> (n, ts, Just $3) } | conid types {% getLConId $1 >>= \ln -> pure (ln, $2, Nothing) } overlap :: { Maybe (Located OverlapMode) } : {- empty -} { Nothing } | 'overlappable' {% b_overlapP $1 } | 'overlapping' {% b_overlapP $1 } | 'overlaps' {% b_overlapP $1 } | 'incoherent' {% b_overlapP $1 } sfsig :: { (Code, HType) } : '::' idsym type { ($2, $3) } simpletype :: { (FastString, [HTyVarBndrVis], Maybe HKind)} : conid {% getConId $1 >>= \n -> return (n, [], Nothing) } | list_es {% parse p_lsimpletype $1 } lsimpletype :: { (FastString, [HTyVarBndrVis], Maybe HKind) } : '::' conid type {% getConId $2 >>= \n -> return (n, [], Just $3) } | '::' list_es type {% do { (n,tv) <- parse p_famconhd $2 ; return (n,tv,Just $3)} } | famconhd { case $1 of (n,tv) -> (n,tv,Nothing) } famconhd :: { (FastString, [HTyVarBndrVis]) } : conid tvbndrs {% getConId $1 >>= \n -> return (n,$2) } constrs :: { (HDeriving, [HConDecl]) } : rconstrs deriving { ($2,reverse $1) } rconstrs :: { [HConDecl] } : {- empty -} { [] } | rconstrs constr { $2 : $1 } constr :: { HConDecl } : conid mbdocprev {% addConDoc' $2 `fmap` b_conOnlyD $1 } | list_es mbdocprev {% addConDoc' $2 `fmap` parse p_lconstr $1 } | docnext conid {% addConDoc'' $1 `fmap` b_conOnlyD $2 } | docnext list_es {% addConDoc'' $1 `fmap` parse p_lconstr $2 } deriving :: { HDeriving } : {- empty -} { b_emptyDeriving } | 'deriving' deriving {% do { ds1 <- parse p_deriving_clause $1 ; return (b_derivsD ds1 $2) } } deriving_clause :: { HDeriving } : 'anyclass' types { b_derivD (Just (uLA $1 anyclassStrategy)) $2 } | 'newtype' types { b_derivD (Just (uLA $1 newtypeStrategy)) $2 } | 'stock' types { b_derivD (Just (uLA $1 stockStrategy)) $2 } | types mb_via { b_derivD $2 $1 } mb_via :: { Maybe HDerivStrategy } : {- empty -} { Nothing } | 'via' type {% b_viaD $2 } standalone_deriv :: { HDecl } : 'anyclass' 'instance' overlap type { b_standaloneD (Just (uLA $1 anyclassStrategy)) $3 $4 } | 'newtype' 'instance' overlap type { b_standaloneD (Just (uLA $1 newtypeStrategy)) $3 $4 } | 'stock' 'instance' overlap type { b_standaloneD (Just (uLA $1 stockStrategy)) $3 $4} | mb_via 'instance' overlap type { b_standaloneD $1 $3 $4 } lconstr :: { HConDecl } : '::' conid dtype {% b_gadtD $2 $3 } | 'forall' forallcon {% b_forallD (fst $2) (snd $2) } | lqtycon { b_qtyconD $1 } forallcon :: { ([HTyVarBndrSpecific], (HConDecl, [HType])) } : qtycon { ([], $1) } | tvbndr_specific forallcon { case $2 of (vs,con) -> ($1:vs,con) } lkindtv :: { HTyVarBndrVis } : '::' idsym type {% kindedTyVar $1 $2 $3 } tvbndr_specific :: { HTyVarBndrSpecific } : idsym { codeToUserTyVarSpecific $1 } | list_es {% parse p_lkindtv_specific $1 } lkindtv_specific :: { HTyVarBndrSpecific } : '::' idsym type {% kindedTyVarSpecific $1 $2 $3 } qtycon :: { (HConDecl, [HType]) } : list_es {% parse p_lqtycon $1 } lqtycon :: { (HConDecl, [HType]) } : '=>' type tys_h98constr { let (c,ts) = $3 in (c, $2:reverse ts) } | lh98constr { ($1, []) } tys_h98constr :: { (HConDecl, [HType]) } : h98constr { ($1, []) } | type tys_h98constr { let (c,ts) = $2 in (c,$1:ts) } h98constr :: { HConDecl } : conid {% b_conOnlyD $1 } | list_es {% parse p_lh98constr $1 } lh98constr :: { HConDecl } : conid condetails {% b_conD $1 $2 } | conid '{' fielddecls '}' {% b_conD $1 $3 } condetails :: { HConDeclH98Details } : type_args { b_conDeclDetails $1 } fielddecls :: { HConDeclH98Details } : fielddecls1 { b_recFieldsD $1 } fielddecls1 :: { [HConDeclField] } : rfielddecls { reverse $1 } rfielddecls :: { [HConDeclField] } : fielddecl { [$1] } | rfielddecls fielddecl { $2:$1 } fielddecl :: { HConDeclField } : list_es mbdocprev {% parse p_field_detail $1 >>= b_recFieldD $2 } | docnext list_es {% parse p_field_detail $2 >>= b_recFieldD (Just $1) } field_detail :: { ([Code], HType) } : '::' fields_and_type { $2 } fields_and_type :: { ([Code], HType) } : type_without_doc { ([], $1) } | idsym_no_bang fields_and_type { case $2 of (ns,t) -> ($1:ns,t) } qtycl :: { ([HType], HType) } : list_es {% parse p_lqtycl $1 } lqtycl :: { ([HType], HType) } : '=>' 'unit' type { ([], $3) } | '=>' list_es types {% parse p_types0 $2 >>= b_qtyclC . (:$3) } | types0_no_qtype { ([], $1) } cdecls :: { [HDecl] } : rcdecls { reverse $1 } rcdecls :: { [HDecl] } : {- empty -} { [] } | rcdecls cdecl { $2:$1 } cdecl :: { HDecl } : 'doc^' {% b_docprevD $1 } | 'doc' {% b_docnextD $1 } | list_es {% parse p_lcdecl $1 } lcdecl :: { HDecl } : 'type' dconhead { b_tyfamD [] $1 $2 } | 'type' 'instance' finsthd type { b_tyinstD $1 $3 $4 } | 'data' dconhead { b_datafamD $1 $2 } | 'default' list_es {% parse p_decl_tsig $2 >>= b_dfltSigD } | decl { $1 } idecls :: { [HDecl] } : ridecls { reverse $1 } ridecls :: { [HDecl] } : {- empty -} { [] } | ridecls idecl { $2:$1 } idecl :: { HDecl } : list_es {% parse p_lidecl $1 } lidecl :: { HDecl } : 'type' finsthd type { b_tyinstD $1 $2 $3 } | 'data' dinsthd constrs { b_datainstD $1 $2 $3 } | decl { $1 } dconhead :: { (FastString, [HTyVarBndrVis], Maybe HType) } : simpletype { $1 } tvbndrs :: { [HTyVarBndrVis] } : rtvbndrs { reverse $1 } rtvbndrs :: { [HTyVarBndrVis] } : {- empty -} { [] } | rtvbndrs tvbndr { $2:$1 } tvbndr :: { HTyVarBndrVis } : idsym { codeToUserTyVar $1 } | list_es {% parse p_lkindtv $1 } finsthd :: { (Located FastString, [HType]) } : list_es {% parse p_lfinsthd $1 } | conid {% getLConId $1 >>= \ln -> pure (ln, []) } lfinsthd :: { (Located FastString, [HType]) } : conid types {% getLConId $1 >>= \ln -> pure (ln, map parTyApp $2) } fameqs :: { [(Located FastString, [HType], HType)] } : rfameqs { reverse $1 } rfameqs :: { [(Located FastString, [HType], HType)] } : {- empty -} { [] } | rfameqs fameq { $2:$1 } fameq :: { (Located FastString, [HType], HType) } : list_es {% parse p_lfameq $1 } lfameq :: { (Located FastString, [HType], HType) } : '=' finsthd type { case $2 of (c,ts) -> (c,ts,$3) } fixity :: { FixityDirection } : 'infixl' { InfixL } | 'infixr' { InfixR } | 'infix' { InfixN } foreign :: { HDecl } : 'foreign' 'symbol' ccnv {- safety -} {- "" -} list_es {% do { (name, ty) <- parse p_sfsig $4 ; let entity = LForm (noLoc (Atom (AString NoSourceText ""))) ; b_ffiD $1 $2 $3 Nothing entity (name, ty) } } | 'foreign' 'symbol' ccnv {- safety -} fentity list_es {% parse p_sfsig $5 >>= b_ffiD $1 $2 $3 Nothing $4 } | 'foreign' 'symbol' ccnv safety fentity list_es {% parse p_sfsig $6 >>= b_ffiD $1 $2 $3 (Just $4) $5 } ccnv :: { HCCallConv } : 'symbol' {% b_callConv $1 } safety :: { Located Safety } : 'symbol' {% b_safety $1 } fentity :: { Code } : 'string' { $1 } decl :: { HDecl } : '=' pats_and_guards {% case $2 of (g,p) -> b_funOrPatD $1 p g } | decl_tsig { $1 } | 'inline' actv idsym {% b_inlineD Inline $2 $3 } | 'noinline' actv idsym {% b_inlineD NoInline $2 $3 } | 'inlinable' actv idsym {% b_inlineD Inlinable $2 $3 } | 'specialize' actv list_es {% do { sig <- parse p_sfsig $3 ; b_specializeD $1 $2 sig }} | 'specialize' 'inline' actv list_es {% do { sig <- parse p_sfsig $4 ; b_specializeInlineD $1 $3 sig }} pats_and_guards :: { (([HGRHS],[HDecl]), [HPat]) } : guards { ($1, []) } | pat pats_and_guards { ($1:) `fmap` $2 } decl_tsig :: { HDecl } : '::' idsyms_dtype {% case $2 of (ns,t) -> b_tsigD ns t } dtype :: { ([HType], HType) } : 'symbol' {% (\t -> ([], t)) `fmap` b_symT $1} | 'unit' { ([], b_unitT $1) } | 'hslist' {% do { t <- parse p_type [toListL $1] ; return ([], b_listT t) }} | qtycl { $1 } idsyms_dtype :: { ([Code], ([HType], HType)) } : dtype { ([],$1) } | idsym idsyms_dtype { case $2 of (ns,t) -> ($1:ns,t) } actv :: { Maybe Activation } : {- empty -} { Nothing } | 'hslist' {% fmap Just (parse p_phase (unListL $1)) } phase :: { Activation } : 'integer' {% b_activation ActiveAfter $1 } | '~' 'integer' {% b_activation ActiveBefore $2 } | idsym {% b_activation ActiveBefore $1 } decls :: { [HDecl] } : rdecls { reverse $1 } rdecls :: { [HDecl] } : {- empty -} { [] } | rdecls list_es {% (:$1) `fmap` parse p_decl $2 } -- --------------------------------------------------------------------- -- -- Type -- -- --------------------------------------------------------------------- type :: { HType } : type_without_doc mbdocprev { maybe $1 (b_docT $1) $2 } type_without_doc :: { HType } : 'symbol' {% b_symT $1 } | type_no_symbol { $1 } type_no_symbol :: { HType } : 'unpack' type { b_unpackT $1 $2 } | '!' type { b_bangT $1 $2 } | '_' { b_anonWildT $1 } | 'unit' { b_unitT $1 } | '~' { b_tildeT $1 } | 'string' {% b_tyLitT $1 } | 'integer' {% b_tyLitT $1 } | 'hslist' {% case toListL $1 of LForm (L _ (List [])) -> return (b_nilT $1) xs -> fmap b_listT (parse p_type [xs]) } | list_es {% parse p_types0 $1 } types0 :: { HType } : '=>' qtypes { b_qualT $1 $2 } | types0_no_qtype { $1 } types0_no_qtype :: { HType } : '->' type_args {% b_funT $1 $2 } | ',' type_args { b_tupT $1 $2 } | 'forall' forallty { b_forallT $1 $2 } | '::' type type { b_kindedType $1 $2 $3 } | ':quote' conid {% b_prmConT $2 } | ':quote' 'hslist' {% b_prmListT (parse p_types) $2 } | ':quote' list_es {% b_prmTupT (parse p_types) $2 } | 'symbol' type_args {% b_opOrAppT $1 $2 } | type_no_symbol type_args {% b_appT ($1:$2) } forallty :: { ([HTyVarBndrSpecific], ([HType], HType)) } : qtycl { ([], $1) } | tvbndr_specific forallty { case $2 of (vs,ty) -> ($1:vs,ty) } qtypes :: { ([HType], HType) } : type { ([], $1) } | type qtypes { case $2 of (ctxts,ty) -> ($1:ctxts,ty) } type_args :: { [HType] } : {- empty -} { [] } | rtype_args { reverse $1 } rtype_args :: { [HType] } : type_arg { [$1] } | rtype_args type_arg { $2 : $1 } type_arg :: { HType } : special_id_no_bang_no_at {% b_symT $1 } | type { $1 } types :: { [HType] } : rtypes { reverse $1 } rtypes :: { [HType] } : type { [$1] } | rtypes type { $2 : $1 } zero_or_more_types :: { [HType] } : {- empty -} { [] } | types { $1 } -- --------------------------------------------------------------------- -- -- Patterns -- -- --------------------------------------------------------------------- pats :: { [HPat] } : 'unit' { [] } | list_es {% parse p_pats0 $1 } pats0 :: { [HPat] } : rpats0 { reverse $1 } rpats0 :: { [HPat] } : {- empty -} { [] } | rpats0 pat { $2 : $1 } pat :: { HPat } : '~' pat_ { b_lazyP $2 } | '!' pat_ { b_bangP $2 } | pat_ { $1 } pat_ :: { HPat } : 'integer' {% b_intP $1 } | 'string' {% b_stringP $1 } | 'char' {% b_charP $1 } | 'unit' {% b_unitP $1 } | '_' { b_wildP $1 } | idsym_no_bang {% b_symP $1 } | 'hslist' {% b_hsListP `fmap` parse p_pats0 (unListL $1) } | list_es {% parse p_pats1 $1 } pats1 :: { HPat } : ',' pats0 { b_tupP $1 $2 } | '@' idsym_no_at pat {% b_asP $2 $3 } | conid '{' labelp '}' {% b_labeledP $1 $3 } | conid pats0 {% b_conP [$1] False $2 } | list_es pats0 {% b_conP $1 True $2 } | '::' pat type { b_sigP $1 $2 $3 } labelp :: { [PreRecField HPat] } : rlabelp { reverse $1 } rlabelp :: { [PreRecField HPat] } : {- empty -} { [] } | rlabelp '..' { Left $2:$1 } | rlabelp idsym {% fsSymbol $2 >>= \s -> pure (Right (s, Nothing):$1) } | rlabelp list_es {% (:$1) `fmap` parse p_label1p $2 } label1p :: { PreRecField HPat } : '=' idsym pat {% fsSymbol $2 >>= \s -> pure (Right (s, Just $3)) } -- --------------------------------------------------------------------- -- -- Expressions -- -- --------------------------------------------------------------------- expr :: { HExpr } : atom { $1 } | list_es {% parse p_exprs $1 } expr_no_idsym :: { HExpr } : atom_no_idsym { $1 } | list_es {% parse p_exprs $1 } atom :: { HExpr } : idsym {% b_varE $1 } | atom_no_idsym { $1 } atom_no_idsym :: { HExpr } : 'char' {% b_charE $1 } | 'string' {% b_stringE $1 } | 'integer' {% b_integerE $1 } | 'frac' {% b_fracE $1 } | 'unit' { b_unitE $1 } | 'hslist' {% b_hsListE `fmap` parse p_hlist (unListL $1) } exprs :: { HExpr } : '\\' lambda { b_lamE $2 } | ',' app { b_tupE $1 (fst $2) } | ',' { b_tupConE $1 } | 'let' lbinds expr {% b_letE $1 $2 $3 } | 'if' expr expr expr { b_ifE $1 $2 $3 $4 } | 'case' expr matches { b_caseE $1 $2 $3 } | 'do' stmts { b_doE $1 $2 } | '::' expr dtype { b_tsigE $1 $2 $3 } | idsym '{' fbinds '}' {% b_recConOrUpdE $1 $3 } | list_es '{' fbinds '}' {% b_recUpdE (parse p_exprs $1) $3 } | ':quote' form {% b_quoteE $2 } | idsym app {% b_opOrAppE $1 $2 } | expr_no_idsym app { case $2 of (es,ts) -> b_appE ($1:es,ts) } | expr { $1 } lambda :: { (HExpr,[HPat]) } : expr { ($1,[]) } | pat lambda { fmap ($1:) $2 } lbinds :: { [HDecl] } : 'unit' { [] } | list_es {% parse p_lbinds0 $1 } lbinds0 :: { [HDecl] } : rlbinds0 { reverse $1 } rlbinds0 :: { [HDecl] } : {- empty -} { [] } | rlbinds0 list_es {% fmap (:$1) (parse p_decl $2) } fbinds :: { [PreRecField HExpr] } : rfbinds { reverse $1 } rfbinds :: { [PreRecField HExpr] } : {- empty -} { [] } | rfbinds '..' { Left $2:$1 } | rfbinds idsym {% fsSymbol $2 >>= \s -> pure (Right (s, Nothing):$1) } | rfbinds list_es {% (:$1) `fmap` parse p_rfbind $2 } rfbind :: { PreRecField HExpr } : '=' 'symbol' expr {% (\s -> (Right (s, Just $3))) `fmap` fsSymbol $2 } app :: { ([HExpr], [HType]) } : rapp { case $1 of (es,ts) -> (reverse es, reverse ts) } rapp :: { ([HExpr], [HType]) } : et_arg { b_rapp $1 ([], []) } | '@' type { b_rapp (Right (parTyApp $2)) ([], []) } | rapp et_arg { b_rapp $2 $1 } | rapp '@' type { b_rapp (Right (parTyApp $3)) $1 } et_arg :: { Either HExpr HType } : idsym_no_at {% b_exprOrTyArg $1 } | expr_no_idsym { Left $1 } matches :: { [HMatch] } : rmatches { reverse $1 } rmatches :: { [HMatch] } : {- empty -} { [] } | rmatches match { $2 : $1 } match :: { HMatch } : pat guards { b_match $1 $2 } hlist :: { Either HExpr [HExpr] } : expr expr '..' expr { Left (b_arithSeqE $1 (Just $2) (Just $4)) } | expr expr '..' { Left (b_arithSeqE $1 (Just $2) Nothing) } | expr '..' expr { Left (b_arithSeqE $1 Nothing (Just $3)) } | expr '..' { Left (b_arithSeqE $1 Nothing Nothing) } | expr '|' stmts { Left (b_lcompE $1 $3) } | hlist0 { Right $1 } hlist0 :: { [HExpr] } : {- empty -} { [] } | expr hlist0 { $1:$2 } -- Parsing form for guards -- ~~~~~~~~~~~~~~~~~~~~~~~ -- -- Separating the rule for 'where', list_es and atom, so that the 'guards0' rule -- can try matching the symbol '|' before 'expr' rule, to differentiate the -- entire form from function application of reserved symbol '|'. guards :: { ([HGRHS],[HDecl]) } : 'where' {% parse p_where $1 } | list_es {% parse p_guards0 $1 >>= \gs -> return (gs,[]) } | atom { (b_hgrhs [] ($1, []), []) } guards0 :: { [HGRHS] } : '|' guards1 { $2 } | exprs { b_hgrhs [] ($1, []) } guards1 :: { [HGRHS] } : list_es {% b_hgrhs [] `fmap` parse p_guard $1 } | list_es guards1 {% b_hgrhs $2 `fmap` parse p_guard $1 } guard :: { (HExpr, [HGuardLStmt]) } : expr { ($1, []) } | stmt guard { fmap ($1:) $2 } where :: { ([HGRHS],[HDecl]) } : list_es lbinds0 {% parse p_guards0 $1 >>= \gs -> return (gs,$2) } | atom lbinds0 { (b_hgrhs [] ($1, []), $2) } -- Quoted form form :: { Code } : 'symbol' { $1 } | all_syms { $1 } | 'char' { $1 } | 'string' { $1 } | 'integer' { $1 } | 'frac' { $1 } | 'unit' { $1 } | 'list' { $1 } | all_lists { $1 } | 'hslist' { $1 } all_syms :: { Code } : 'case' { $1 } | 'class' { $1 } | 'data' { $1 } | 'default' { $1 } | 'do' { $1 } | 'foreign' { $1 } | 'if' { $1 } | 'infix' { $1 } | 'infixl' { $1 } | 'infixr' { $1 } | 'instance' { $1 } | 'let' { $1 } | 'newtype' { $1 } | 'type' { $1 } | '!' { $1 } | ',' { $1 } | '->' { $1 } | '..' { $1 } | '::' { $1 } | '<-' { $1 } | '=' { $1 } | '=>' { $1 } | '@' { $1 } | '\\' { $1 } | '{' { $1 } | '|' { $1 } | '}' { $1 } | '~' { $1 } | '_' { $1 } | special_id_no_bang_no_at { $1 } | 'inlinable' { $1 } | 'inline' { $1 } | 'noinline' { $1 } | 'specialize' { $1 } | ':quote' { $1 } all_lists :: { Code } : 'deriving' { consListWith $1 "deriving" } | 'import' { consListWith $1 "import" } | 'module' { consListWith $1 "module" } | 'where' { consListWith $1 "where" } | 'unpack' { $1 } | 'overlappable' { $1 } | 'overlapping' { $1 } | 'overlaps' { $1 } | 'incoherent' { $1 } | 'doc' { consListWith [$1] ":doc" } | 'doc^' { consListWith [$1] ":doc^" } | 'doc$' { $1 } | 'dh1' { $1 } | 'dh2' { $1 } | 'dh3' { $1 } | 'dh4' { $1 } -- --------------------------------------------------------------------- -- -- Do statement -- -- --------------------------------------------------------------------- stmts :: { [HStmt] } : rstmts { reverse $1 } rstmts :: { [HStmt] } : stmt { [$1] } | rstmts stmt { $2 : $1 } stmt :: { HStmt } : atom { b_bodyS $1 } | list_es {% parse p_stmt1 $1 } stmt1 :: { HStmt } : '<-' pat expr { b_bindS $1 $2 $3 } | 'let' lbinds {% b_letS $1 $2 } | exprs { b_bodyS $1 } -- --------------------------------------------------------------------- -- -- Identifier -- -- --------------------------------------------------------------------- idsym :: { Code } : 'symbol' { $1 } | special_id { $1 } idsym_no_bang :: { Code } : 'symbol' { $1 } | '@' { $1 } | special_id_no_bang_no_at { $1 } idsym_no_at :: { Code } : 'symbol' { $1 } | '!' { $1 } | special_id_no_bang_no_at { $1 } special_id :: { Code } : '!' { $1 } | '@' { $1 } | special_id_no_bang_no_at { $1 } special_id_no_bang_no_at :: { Code } : 'forall' { $1 } | special_id_no_bg_at_fa { $1 } -- special id, no bang, no forall special_id_no_bg_at_fa :: { Code } : 'anyclass' { $1 } | 'as' { $1 } | 'family' { $1 } | 'hiding' { $1 } | 'stock' { $1 } | 'via' { $1 } | 'qualified' { $1 } idsyms1 :: { [Code] } : ridsyms { reverse $1 } ridsyms :: { [Code] } : idsym { [$1] } | ridsyms idsym { $2 : $1 } conid :: { Code } : 'symbol' { $1 } { happyError :: Builder a happyError = builderError -- | Parser for Haskell module. parseModule :: Builder HModule parseModule = parse_module -- | Parser for Haskell module with out module header. parseModuleNoHeader :: Builder HModule parseModuleNoHeader = parse_module_no_header -- | Parse module declaration and imports only. parseHeader :: Builder HModule parseHeader = parse_header -- | Parser for import declarations. parseImports :: Builder [HImportDecl] parseImports = p_imports -- | Parser for single import declaration. parseLImport :: Builder HImportDecl parseLImport = p_limport -- | Parser for statement. parseStmt :: Builder HStmt parseStmt = p_stmt -- | Parser for declarations. parseDecls :: Builder [HDecl] parseDecls = p_decls -- | Parser for top level declarations. parseTopDecls :: Builder [HDecl] parseTopDecls = p_top_decls -- | Parser for Haskell expression. parseExpr :: Builder HExpr parseExpr = p_expr -- | Parser for Haskell type. parseType :: Builder HType parseType = p_type -- | Unwrap the element of 'List' and 'HsList', otherwise returns '[]'. unListL :: Code -> [Code] unListL (LForm (L _ form)) = case form of List xs -> xs HsList xs -> xs _ -> [] uL :: Code -> a -> Located a uL (LForm (L l _)) a = L l a {-# INLINE uL #-} #if MIN_VERSION_ghc(9,10,0) uLA :: NoAnn ann => Code -> a -> LocatedAn ann a uLA (LForm (L l _)) a = reLocA (L l a) #elif MIN_VERSION_ghc(9,4,0) uLA :: Code -> a -> LocatedAn ann a uLA (LForm (L l _)) a = la2la (reLocA (L l a)) #else uLA :: Code -> a -> Located a uLA = uL #endif {-# INLINE uLA #-} -- $docforms -- -- There are four kinds of forms for documentation comments. -- -- [@:doc@]: The @(:doc "comment")@ form is for writing documentation with -- @comment@ for the next element. It can appear in export entities list, or in -- top level declarations. It is analogous to Haskell comments starting with -- @|@. -- -- [@:doc^@]: The @(:doc^ "comment")@ form is like /:doc/, but for previous -- form. Unlike /:doc/, it cannot appear in export entities list. It is -- analogous to Haskell comments starting with @^@. -- -- [@:doc$@]: The @(:doc$ name)@ and @(:doc$ name "comment")@ form is for -- referencing documentation. @(:doc$ name)@ is used in export entities list to -- refer other documentation comment, and @(:doc$ name "comment")@ is for top -- level to contain the documentation contents. It is analogous to Haskell -- comment starting with @$name@. -- -- [@:dh1, :dh2, :dh3, and :dh4@]: The @(:dh1 "comment")@ is for level 1 -- documentation section header. There are four levels of section headers: -- @:dh1@, @:dh2@, @:dh3@, and @:dh4@. It could be used in export entities list, -- or in top level declaration when the module does not contain explicit export -- entities. It is analogous to Haskell comments starting with @*@s. } ================================================ FILE: finkel-kernel/src/Language/Finkel.hs ================================================ {-# LANGUAGE CPP #-} -- | Module re-exporting runtime dependency for Finkel kernel programs. -- -- This module exports types and functions for writing Finkel kernel -- programs, with quotes, quasi-quotes, unquotes, unquote-splicings, and -- macros. -- module Language.Finkel ( -- * Form Atom(..) , Form(..) , LForm(..) , Code , unCode , Homoiconic(..) , fromCode , QuoteFn , qSymbol , qChar , qString , qInteger , qFractional , qUnit , qList , qHsList , nil , asLocOf -- * Fnk , Fnk , runFnk , defaultFnkEnv -- * Macro , Macro(Macro) , isMacro , expand , expands , expand1 , gensym , gensym' , unquoteSplice , macroFunction -- * Exceptions , FinkelException(..) , finkelSrcError -- * Re-export from ghc , Located , GenLocated(..) , SrcSpan ) where #include "ghc_modules.h" -- ghc import GHC_Types_SrcLoc (GenLocated (..), Located, SrcSpan) -- Internal import Language.Finkel.Exception import Language.Finkel.Expand import Language.Finkel.Fnk import Language.Finkel.Form import Language.Finkel.Homoiconic import Language.Finkel.SpecialForms ================================================ FILE: finkel-kernel/test/EmitTest.hs ================================================ {-# LANGUAGE CPP #-} module EmitTest where #include "ghc_modules.h" -- ghc import GHC_Data_FastString (fsLit) import GHC_Types_Name_Reader (mkVarUnqual) import GHC_Types_SrcLoc (GenLocated (..), noSrcSpan) -- hspec import Test.Hspec -- finkel-kernel import Language.Finkel.Emit import Language.Finkel.Fnk import Language.Finkel.Lexer -- Internal import TestAux emitTests :: Spec emitTests = do let fooVar = mkVarUnqual (fsLit "foo") describe "emit RdrName" $ do it "should show \"foo\"" $ do foo <- emitSimple fooVar foo `shouldBe` "foo" describe "emit located thing" $ do it "should show located contents" $ do x <- emitSimple (L noSrcSpan fooVar) x `shouldBe` "foo" emitSimple :: HsSrc a => a -> IO String emitSimple h = runFnk (genHsSrc sp h) fnkTestEnv where sp = initialSPState (fsLit "") 0 0 ================================================ FILE: finkel-kernel/test/EvalTest.hs ================================================ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} module EvalTest (evalFnkTests) where #include "ghc_modules.h" -- base import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO (..)) import GHC.Exts (unsafeCoerce#) import System.Info (os) -- filepath import System.FilePath (takeBaseName) -- ghc import GHC_Data_StringBuffer (StringBuffer, hGetStringBuffer, stringToStringBuffer) import GHC_Driver_Monad (printException) import GHC_Driver_Ppr (showSDocForUser) import GHC_Driver_Session (HasDynFlags (..)) import GHC_Settings_Config (cProjectVersionInt) import GHC_Types_SourceError (handleSourceError) import GHC_Utils_Outputable (SDoc) #if MIN_VERSION_ghc(9,6,0) import GHC (getNamePprCtx) #else import GHC (getPrintUnqual) #endif #if MIN_VERSION_ghc(9,4,0) import GHC.Core.TyCo.Ppr (pprSigmaType) #else import GHC (Type) import GHC_Types_TyThing_Ppr (pprTypeForUser) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env (hsc_units) import GHC.Driver.Monad (getSession) #endif -- hspec import Test.Hspec -- finkel-kernel import Language.Finkel.Builder (Builder) import Language.Finkel.Eval (evalExpr, evalExprType, evalTypeKind) import Language.Finkel.Fnk (Fnk, FnkEnv (..), runFnk) import Language.Finkel.Syntax (parseExpr, parseType) -- Test internal import TestAux evalFnkTests :: FnkSpec evalFnkTests = do files <- runIO (getTestFiles "eval") mapM_ exprTest files exprTypeTest typeKindTest exprTest :: FilePath -> FnkSpec exprTest file = describe file $ it "should evaluate to True" work where work ftr | cProjectVersionInt == "810" , os == "mingw32" , takeBaseName file `elem` skipped = pendingWith "Not yet supported" | otherwise = do contents <- hGetStringBuffer file ret <- runEvalExpr ftr contents ret `shouldBe` True skipped = [ "0002-shadowing-macro" , "0004-unquote-unquote-splice" ] runEvalExpr ftr !buf = runFnk (handleSourceError (\se -> printException se >> liftIO (throwIO se)) (doEval ftr "" parseExpr act buf)) evalFnkEnv act = fmap unsafeCoerce# . evalExpr exprTypeTest :: FnkSpec exprTypeTest = describe "type of True" $ it "should be Bool" $ \ftr -> do ret <- runEvalType ftr "True" ret `shouldBe` "Bool" where runEvalType ftr str = let buf = stringToStringBuffer str in runFnk (doEval ftr "" parseExpr act buf) evalFnkEnv act expr = do ty <- evalExprType expr pprDocForUser (pprSigmaType ty) typeKindTest :: FnkSpec typeKindTest = do describe "kind of Maybe" $ it "should be * -> *" $ \ftr -> do ret <- runTypeKind ftr "Maybe" ret `shouldBe` "* -> *" where runTypeKind ftr str = let buf = stringToStringBuffer str in runFnk (doEval ftr "" parseType act buf) evalFnkEnv act expr = do (_, kind) <- evalTypeKind expr pprDocForUser (pprSigmaType kind) doEval :: FnkTestResource -> String -> Builder a -> (a -> Fnk b) -> StringBuffer -> Fnk b doEval !ftr !label !parser !act !input = do ftr_init ftr evalWith label parser act input evalFnkEnv :: FnkEnv evalFnkEnv = fnkTestEnv {envContextModules = modules} where modules = ["Prelude", "Language.Finkel"] pprDocForUser :: SDoc -> Fnk String pprDocForUser sdoc = do dflags <- getDynFlags #if MIN_VERSION_ghc(9,6,0) unqual <- getNamePprCtx #else unqual <- getPrintUnqual #endif #if MIN_VERSION_ghc(9,2,0) unit_state <- hsc_units <$> getSession pure (showSDocForUser dflags unit_state unqual sdoc) #else pure (showSDocForUser dflags unqual sdoc) #endif -- Auxiliary #if !MIN_VERSION_ghc(9,4,0) pprSigmaType :: Type -> SDoc pprSigmaType = pprTypeForUser #endif ================================================ FILE: finkel-kernel/test/ExceptionTest.hs ================================================ module ExceptionTest ( exceptionTests , exceptionFnkTests ) where -- base import Control.Exception (bracket) import System.Environment (lookupEnv, setEnv) import System.Exit (ExitCode (..)) -- hspec import Test.Hspec -- -- finkel-kernel import Language.Finkel.Fnk (initializeLibDirFromGhc) -- Internal import TestAux exceptionTests :: Spec exceptionTests = beforeAll getFnkTestResource exceptionFnkTests exceptionFnkTests :: FnkSpec exceptionFnkTests = do noGhcTest compileErrorTests noGhcTest :: FnkSpec noGhcTest = describe "No ghc found in current PATH" $ it "should fail with non-0 exit code" $ \_ -> do let act = withEmptyPATH initializeLibDirFromGhc act `shouldThrow` exitFailureSelector compileErrorTests :: FnkSpec compileErrorTests = runIO (getTestFiles "exception") >>= mapM_ mkTest mkTest :: FilePath -> FnkSpec mkTest path = describe path $ it "should not compile successfully" $ \ftr -> let go = ftr_main ftr ["-fno-code", path] in go `shouldThrow` exitFailureSelector exitFailureSelector :: ExitCode -> Bool exitFailureSelector (ExitFailure _) = True exitFailureSelector _ = False withEmptyPATH :: IO a -> IO a withEmptyPATH = bracket acquire restore . const where acquire = do mb_path <- lookupEnv "PATH" case mb_path of Nothing -> return "" Just path -> setEnv "PATH" "/" >> return path restore = setEnv "PATH" ================================================ FILE: finkel-kernel/test/FnkTest.hs ================================================ {-# LANGUAGE CPP #-} module FnkTest where #include "ghc_modules.h" -- base import Control.Exception (throwIO) import qualified Control.Monad.Fail as MonadFail import Control.Monad.IO.Class import Data.Maybe (fromMaybe, isNothing) -- ghc import GHC_Data_FastString (fsLit) import GHC_Data_StringBuffer (stringToStringBuffer) import GHC_Types_SrcLoc (GenLocated (..)) import GHC_Unit_Module (moduleNameString) import GHC_Unit_Module_ModSummary (ms_mod_name) -- exceptions import Control.Monad.Catch (bracket) -- hspec import Test.Hspec import Test.QuickCheck -- Internal import Language.Finkel.Builder import Language.Finkel.Exception import Language.Finkel.Expand import Language.Finkel.Fnk import Language.Finkel.Form import Language.Finkel.Homoiconic import Language.Finkel.Make import Language.Finkel.Reader import Language.Finkel.SpecialForms import Language.Finkel.Syntax import TestAux fnkTests :: Spec fnkTests = do exceptionTest fromGhcTest gensymTest expandTest envTest exceptionTest :: Spec exceptionTest = do let e_foo :: FinkelException e_foo = FinkelException "foo" test_e_foo :: FinkelException -> Bool test_e_foo e = case e of FinkelException msg -> msg == "foo" _ -> False fnkSrcErrorSelector :: FinkelException -> Bool fnkSrcErrorSelector (FinkelSrcError {}) = True fnkSrcErrorSelector _ = False run :: Fnk a -> IO a run = flip runFnk fnkTestEnv describe "Eq and Show instance of FinkelException" $ do it "should return True when comparing with itself" $ property (\str -> let e1 = FinkelException str e2 = FinkelException str in e1 == e2 && show e1 == show e2) it "should return False when message is different" $ FinkelException "foo" /= FinkelException "bar" `shouldBe` True describe "Eq and Show instance of SyntaxError" $ do it "should return True when cmparing with itself" $ property (\str -> let e1 = SyntaxError nil str e2 = SyntaxError nil str in e1 == e2 && show e1 == show e2) it "should return False when message is different" $ let e1 = SyntaxError nil "foo" e2 = SyntaxError nil "bar" in e1 `shouldNotBe` e2 describe "Code and message in SyntaxError" $ do let se = SyntaxError nil "message" it "should have given code" $ syntaxErrCode se `shouldBe` nil it "should have given message" $ syntaxErrMsg se `shouldBe` "message" describe "Applicative instance of Fnk" $ it "should return 42" $ do let act = (*) <$> pure 6 <*> pure 7 run act `shouldReturn` (42 :: Int) describe "ExceptionMonad instance of Fnk" $ do it "should return 42 with action in bracket" $ do let act = bracket (return 21) return (\x -> return (x * 2)) run act `shouldReturn` (42 :: Int) it "should catch exception from throwM" $ do let act = throwM e `catch` handler e = FinkelException "" handler :: FinkelException -> Fnk Int handler _ = return 42 run act `shouldReturn` 42 it "masks an exception" $ do let act = mask (\restore -> restore (throwM e_foo)) run act `shouldThrow` test_e_foo it "masks an exception (uninterruptible)" $ do let act = uninterruptibleMask (\restore -> restore (throwM e_foo)) run act `shouldThrow` test_e_foo describe "Handling FinkelException" $ it "should return 42" $ do let act = handleFinkelException (\_ -> return (42 :: Int)) (liftIO (throwIO (FinkelException ""))) run act `shouldReturn` 42 describe "running Fnk action containing `failFnk'" $ it "should throw FinkelException" $ do let act = failFnk "foo" run act `shouldThrow` test_e_foo describe "running Fnk action containing `fail'" $ it "should throw FinkelException" $ do let act = MonadFail.fail "foo" run act `shouldThrow` test_e_foo describe "running Fnk action containing FinkelSrcError" $ it "should throw SourceError" $ do let act = finkelSrcError nil "foo" run act `shouldThrow` fnkSrcErrorSelector describe "applying macroNames to specialForms" $ it "should not return name of special forms" $ do let ns = macroNames specialForms ns `shouldBe` [] describe "running buildHsSyn action" $ it "should throw FinkelSrcError" $ do let form = "(:: foo ->) (= foo 100)" form' = stringToStringBuffer form build = do (form'', _) <- parseSexprs Nothing form' buildHsSyn parseDecls form'' run build `shouldThrow` fnkSrcErrorSelector fromGhcTest :: Spec fromGhcTest = describe "converting Ghc to Fnk" $ it "should return the returned value in Ghc" $ do let v :: Int v = 42 x <- runFnk (fromGhc (return v)) fnkTestEnv x `shouldBe` v gensymTest :: Spec gensymTest = describe "generating two gensyms" $ it "should not be equal" $ do let gen _ = do g1 <- gensym g2 <- gensym return $ toCode [g1, g2] f = macroFunction (Macro gen) env = cleanFnkEnv ret <- runFnk (f nil) env case ret of LForm (L _ (HsList [g1, g2])) -> g1 `shouldNotBe` g2 _ -> expectationFailure "macro expansion failed" expandTest :: Spec expandTest = do let expand1_fn code = runFnk (macroFunction (Macro expand1) code) env env = cleanFnkEnv describe "expand-1 of nil" $ it "should return nil" $ do ret <- expand1_fn nil ret `shouldBe` nil describe "expand-1 of (:quote 42.0)" $ it "should return non-empty form" $ do let form = toCode (List [toCode $ aSymbol ":quote" ,toCode $ aFractional (42.0 :: Double)]) ret <- expand1_fn form length ret `shouldSatisfy` (>= 1) describe "expand-1 of non-macro" $ it "should return the original form" $ do let form = toCode (List [toCode $ aSymbol "show" ,toCode $ aFractional (42 :: Double)]) ret <- expand1_fn form ret `shouldBe` form describe "expanding with macroFunction" $ it "should return empty form" $ do let mb_qt = lookupMacro (fsLit ":quasiquote") env qt = fromMaybe (error "macro not found") mb_qt s x = LForm (genSrc (Atom (ASymbol (fsLit x)))) li xs = LForm (genSrc (List xs)) form0 = li [s ":quasiquote", s "a"] form1 = li [s ":quote", s "a"] ret <- runFnk (macroFunction qt form0) env ret `shouldBe` form1 envTest :: Spec envTest = do describe "deleting macro from specialForms" $ it "should delete macro with matching name" $ do let m0 = specialForms m1 = deleteMacro (fsLit ":with-macro") m0 e1 = emptyFnkEnv {envMacros = m1} mb_let_macro = lookupMacro (fsLit ":with-macro") e1 isNothing mb_let_macro `shouldBe` True describe "deleting macro from emptyMacros" $ it "should delete nothing" $ do let m0 = emptyEnvMacros m1 = deleteMacro (fsLit ":no-such-macro") m0 n0 = macroNames m0 n1 = macroNames m1 n0 `shouldBe` n1 describe "merging macros with itself" $ it "should not change" $ do let m0 = specialForms m1 = mergeMacros specialForms specialForms n0 = macroNames m0 n1 = macroNames m1 n0 `shouldBe` n1 describe "showing special forms" $ it "should be " $ do let e1 = emptyFnkEnv {envMacros = specialForms} mb_let_macro = lookupMacro (fsLit ":eval-when-compile") e1 let_macro = fromMaybe (error "not found") mb_let_macro show let_macro `shouldBe` "" describe "empty finkel env" $ do it "should have empty envMacros" $ macroNames (envMacros emptyFnkEnv) `shouldBe` [] it "should have empty envDefaultMacros" $ macroNames (envDefaultMacros emptyFnkEnv) `shouldBe` [] it "should set verbosity to 1" $ envVerbosity emptyFnkEnv `shouldBe` 1 it "should not have required module names" $ map (moduleNameString . ms_mod_name) (envRequiredHomeModules emptyFnkEnv) `shouldBe` [] emptyForm :: Code emptyForm = let bgn = LForm (genSrc (Atom (ASymbol (fsLit ":begin")))) in LForm (genSrc (List [bgn])) cleanFnkEnv :: FnkEnv cleanFnkEnv = fnkTestEnv {envDefaultMacros = emptyEnvMacros} ================================================ FILE: finkel-kernel/test/FormTest.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | Tests for forms. module FormTest where #include "ghc_modules.h" -- base import Control.Applicative (Alternative (..)) import Data.Char (toUpper) import Data.Complex import Data.Data import qualified Data.Fixed as Fixed import Data.Functor.Compose import Data.Functor.Const import Data.Functor.Identity import qualified Data.Functor.Product as Product import qualified Data.Functor.Sum as Sum import Data.Int import Data.List (isPrefixOf, isSubsequenceOf) import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid import Data.Ratio import qualified Data.Semigroup as Semigroup import Data.Version import Data.Word import GHC.Generics (Generic (..)) import Numeric.Natural import Text.Show.Functions () #if !MIN_VERSION_ghc(8,4,0) import Data.Monoid ((<>)) #endif -- binary import Data.Binary (decode, encode) -- deepseq import Control.DeepSeq -- ghc import GHC_Data_FastString (fsLit, unpackFS) import GHC_Data_StringBuffer (stringToStringBuffer) import GHC_Driver_Session (HasDynFlags (..)) import GHC_Types_SrcLoc (GenLocated (..), SrcSpan (..), noSrcSpan) import GHC_Driver_Ppr (showPpr) #if MIN_VERSION_ghc(9,0,0) import GHC_Types_SrcLoc (UnhelpfulSpanReason (..)) #endif -- transformers import Control.Monad.Trans.State -- hspec import Test.Hspec -- QuickCheck import Test.QuickCheck -- finkel-kernel import Language.Finkel.Fnk import Language.Finkel.Form import Language.Finkel.Homoiconic import qualified Language.Finkel.Homoiconic as Homoiconic import Language.Finkel.Lexer import Language.Finkel.Reader import Language.Finkel.SpecialForms -- Internal import Orphan () formTests :: Spec formTests = do mapM_ readShow [ "foo", "#'a", "12345", "6.789", "0.001" , "(foo bar buzz)" , "(#'a #'\\SP #'\\ \"bcd\")" , "[#'\\BEL #'\\BS #'\\FF #'\\LF #'\\CR #'\\HT #'\\VT]" , "[()]" , "(1 -2 345 6.789 0.001)" ] readUnicodeStringProp readShowFormProp dataInstanceTests qFunctionTests fracTest 1.23 fracTest (-1.23) fracTest 0 fracTest 1e-9 showTest pprTest functorTest "(a \"foo\" \\x [True False])" applicativeTest monadTest foldableTest traversableTest binaryTest eqTest "(a \"bcd\" \\e [f g] (h i))" eqPropTest locationTest Nothing "foo" locationTest (Just "locationTest") "foo" asLocOfTest lengthTest 3 "(a b c)" lengthTest 5 "(a (b (c)) d e)" lengthTest 1 "()" lengthTest 8 "[a (b (c d e) [f g]) h]" lengthTest 1 "foo" homoiconicTests rnfTest listTest numTest fractionalTest monoidTest alternativeTest fromCodeTest fromCodeErrorTest dataToCodeTest genericHomoiconicTest unquoteSpliceTest readShow :: String -> Spec readShow str = describe ("read and show `" ++ str ++ "'") $ it "should match the input" $ show (parseE str) `shouldBe` str readUnicodeStringProp :: Spec readUnicodeStringProp = describe "read and show unicode string" $ it "should return itself" $ property (\uni -> let str = getUnicodeString uni in parseE (show str) == toCode (aString NoSourceText str)) readShowFormProp :: Spec readShowFormProp = describe "read and show form property" $ it "should match the input" $ property (\form -> form == form && parseE (show form) `eqForm` form) dataInstanceTests :: Spec dataInstanceTests = do let gfoldl_self atom = gfoldl (\mb_f x -> case mb_f of Just f -> pure (f x) _ -> error "should not happen") return atom t_gfoldl_self x = gfoldl_self x `shouldBe` Just x t_show_constr x y = show (toConstr x) `shouldBe` y describe "Data instance for Atom" $ do let aunit = AUnit asym = ASymbol (fsLit "foo") achar = AChar NoSourceText 'a' astr = AString NoSourceText (fsLit "string") aint = AInteger (mkIntegralLit (42 :: Int)) afrac = aFractional (1.23 :: Double) it "should return Just self with simple gfoldl" $ do t_gfoldl_self aunit t_gfoldl_self asym t_gfoldl_self achar t_gfoldl_self astr t_gfoldl_self aint t_gfoldl_self afrac it "should show itself with toConstr" $ do t_show_constr aunit "AUnit" t_show_constr asym "ASymbol" t_show_constr achar "AChar" t_show_constr astr "AString" t_show_constr aint "AInteger" t_show_constr afrac "AFractional" it "should return AUnit with simple gunfold" $ do gunfold (const Nothing) Just (toConstr AUnit) `shouldBe` Just AUnit it "should return AUnit constr" $ do let dtype = dataTypeOf AUnit cnstr = toConstr AUnit readConstr dtype "AUnit" `shouldBe` Just cnstr describe "Data instance for Form" $ do let fatom = Atom AUnit qc c = qChar c "" 0 0 0 0 flist = List [qc 'a', qc 'b'] fhslist = HsList [qc 'a', qc 'b'] ftend :: Form Atom ftend = TEnd it "should return Just self with simple gfoldl" $ do t_gfoldl_self fatom t_gfoldl_self flist t_gfoldl_self fhslist t_gfoldl_self ftend it "should show itself with toConstr" $ do t_show_constr fatom "Atom" t_show_constr flist "List" t_show_constr fhslist "HsList" t_show_constr ftend "TEnd" it "should return TEnd with simple gunfold" $ gunfold (const Nothing) Just (toConstr ftend) `shouldBe` Just ftend it "should return Atom constr" $ do let dtype = dataTypeOf fatom cnstr = toConstr fatom readConstr dtype "Atom" `shouldBe` Just cnstr it "should return same result from dataCast1 and gcast1" $ do (dataCast1 [TEnd] :: Maybe [Form Atom]) `shouldBe` Just [TEnd] describe "Data instance for LForm" $ do let qc = qChar 'x' "" 0 0 0 0 d1, d2, d3 :: Data a => a d1 = fromConstr (toConstr noSrcSpan) d2 = fromConstrB (fromConstr (toConstr AUnit)) (toConstr (Atom AUnit)) d3 = evalState m 0 where m = fromConstrM act (toConstr (L noSrcSpan (Atom AUnit))) act :: Data d => State Int d act = do i <- get modify succ case i of 0 -> return d1 1 -> return d2 _ -> error ("index " ++ show i ++ " for LForm") d4 = fromConstrB d3 (toConstr qu) gc1 :: Data a => Maybe [LForm a] gc1 = let a :: Data a => a a = fromConstr (toConstr AUnit) in dataCast1 [LForm (L noSrcSpan (Atom a))] qu = qUnit "" 0 0 0 0 it "should return Just self with simple gfoldl" $ do t_gfoldl_self qc it "should show itself with toConstr" $ do t_show_constr qc "LForm" it "should return LForm constr" $ do let dtype = dataTypeOf qc cnstr = toConstr qc readConstr dtype "LForm" `shouldBe` Just cnstr it "should construct qUnit from constructors" $ do d4 `shouldBe` qu it "should return qUnit from dataCast1" $ gc1 `shouldBe` Just [qu] qFunctionTests :: Spec qFunctionTests = do describe "qSymbol function" $ it "should equal to quoted symbol" $ qSymbol "foo" "" 0 0 0 0 `shouldBe` toCode (ASymbol (fsLit "foo")) describe "qChar function" $ it "should equal to quoted char" $ qChar 'x' "" 0 0 0 0 `shouldBe` toCode 'x' describe "qString function" $ it "should equal to quoted string" $ qString "foo" "" 0 0 0 0 `shouldBe` toCode "foo" describe "qInteger function" $ it "should equal to quoted integer" $ qInteger 42 "" 0 0 0 0 `shouldBe` toCode (42 :: Integer) describe "qFractional function" $ it "should equal to quoted fractional" $ qFractional (1.23 :: Double) "" 0 0 0 0 `shouldBe` toCode (1.23 :: Double) describe "qUnit function" $ it "should equal to quoted unit" $ qUnit "" 0 0 0 0 `shouldBe` toCode () let qc x = qChar x "" 0 0 0 0 describe "qList function" $ it "should equal to quoted codes" $ let xs = [qc 'a', qc 'b'] in qList xs "" 0 0 0 0 `shouldBe` toCode (List xs) describe "qHsList function" $ it "should equal to quoted haskell list" $ let xs = [qc 'a', qc 'b'] in qHsList xs "" 0 0 0 0 `shouldBe` toCode (HsList xs) fracTest :: Double -> Spec fracTest x = describe ("read and show a fractional number `" ++ show x ++ "'") $ it "should match the input" $ show (aFractional x) `shouldBe` show x showTest :: Spec showTest = describe "showing TEnd" $ it "should be \"TEnd\"" $ show (TEnd :: Form Atom) `shouldBe` "TEnd" functorTest :: String -> Spec functorTest str = do describe ("Functor instance of Code `" ++ str ++ "'") $ it "should obey the Functor law" $ let c = parseE str in fmap id c `shouldBe` c describe "fmap to TEnd" $ it "should be TEnd" $ do let te :: Form Atom te = TEnd f :: Atom -> Atom f _ = AUnit fmap f te `shouldBe` te applicativeTest :: Spec applicativeTest = do let atom_a = AChar NoSourceText 'a' char_a = toCode atom_a al2 = qList [char_a, char_a] "" 0 0 0 0 ahl2 = qHsList [char_a, char_a] "" 0 0 0 0 unit = toCode () f1 a b = (a,b) a_pair = lf (Atom (atom_a, atom_a)) a_pair_ls = mk_a_pairs List 2 -- lf (List [a_pair, a_pair]) a_pair_hls = mk_a_pairs HsList 2 -- lf (HsList [a_pair, a_pair]) mk_a_pairs f n = lf (f (replicate n a_pair)) lf = LForm . genSrc tend :: Form Atom tend = TEnd describe "pure" $ it "should result in atom" $ toCode (pure AUnit :: Form Atom) `shouldBe` unit describe "<*>" $ do it "should apply f1 to atom and atom" $ f1 <$> char_a <*> char_a `shouldBe` a_pair it "should apply f1 to atom and list" $ f1 <$> char_a <*> al2 `shouldBe` a_pair_ls it "should apply f1 to atom and hslist" $ f1 <$> char_a <*> ahl2 `shouldBe` a_pair_hls it "should aply f1 to list and atom" $ f1 <$> al2 <*> char_a `shouldBe` a_pair_ls it "should apply f1 to list and list" $ f1 <$> al2 <*> al2 `shouldBe` mk_a_pairs List 4 it "should apply f1 to list and hslist" $ f1 <$> al2 <*> ahl2 `shouldBe` mk_a_pairs List 4 it "should aply f1 to list and atom" $ f1 <$> ahl2 <*> char_a `shouldBe` a_pair_hls it "should apply f1 to list and list" $ f1 <$> ahl2 <*> al2 `shouldBe` mk_a_pairs HsList 4 it "should apply f1 to list and list" $ f1 <$> ahl2 <*> ahl2 `shouldBe` mk_a_pairs HsList 4 it "should result in TEnd" $ do f1 <$> char_a <*> lf tend `shouldBe` lf TEnd f1 <$> lf tend <*> char_a `shouldBe` lf TEnd monadTest :: Spec monadTest = do let f1 x = case x of AChar st c -> AChar st (toUpper c) _ -> x qh x = qHsList x "" 0 0 0 0 ql x = qList x "" 0 0 0 0 describe "bind" $ do it "should apply f1 to atom" $ do {x <- toCode 'x'; return (f1 x)} `shouldBe` toCode 'X' it "should apply f1 to list" $ do {x <- ql [toCode 'x', toCode 'x']; return (f1 x)} `shouldBe` ql [toCode 'X', toCode 'X'] it "should apply f1 to hslist" $ do {x <- qh [toCode 'x',toCode 'x']; return (f1 x)} `shouldBe` qh [toCode 'X', toCode 'X'] it "should apply f1 to TEnd" $ do {x <- toCode (TEnd :: Form Atom); return (f1 x)} `shouldBe` toCode (TEnd :: Form Atom) foldableTest :: Spec foldableTest = do let fsum = foldr (\x acc -> case x of AInteger il -> acc + il_value il _ -> acc) 0 describe "taking sum of 1 to 10 with foldr" $ do let str1 = "(1 2 3 4 5 6 7 8 9 10)" it ("should be 55 for " ++ str1) $ fsum (parseE str1) `shouldBe` 55 it "should be 0 for TEnd" $ do #if MIN_VERSION_ghc(9,0,0) let sp = UnhelpfulSpan (UnhelpfulOther (fsLit "")) #else let sp = UnhelpfulSpan (fsLit "") #endif fsum (LForm (L sp TEnd)) `shouldBe` 0 describe "length of nil" $ it "should be 0" $ length nil `shouldBe` 0 traversableTest :: Spec traversableTest = do let f atom = case atom of ASymbol sym | '$' : _ <- unpackFS sym -> return (aSymbol "_") _ -> return atom describe "replacing symbol with mapM" $ do let str1 = "(a $b c [$d e] [f g $h] ($i $j))" str2 = "(a _ c [ _ e] [f g _] ( _ _))" it "should replace $.* with _" $ do let form1 = parseE str1 form2 = parseE str2 mapM f form1 `shouldBe` Just form2 describe "traversing TEnd" $ it "should be Just TEnd" $ mapM f TEnd `shouldBe` Just TEnd binaryTest :: Spec binaryTest = do describe "Instances of Get and Put from binary" $ do it "should return the original value" $ do let to_from_bin :: Code -> Bool to_from_bin x = decode (encode x) == x property to_from_bin eqTest :: String -> Spec eqTest str = describe "parsing same string twice" $ it "should result in equal codes" $ let c1 = parseE str c2 = parseE str in c1 `shouldBe` c2 eqPropTest :: Spec eqPropTest = do describe "Eq instance for LForm" $ it "should ignore location information" $ do let g :: Code -> Bool g x@(LForm (L _ body)) = x == LForm (L sp body) #if MIN_VERSION_ghc(9,0,0) sp = UnhelpfulSpan (UnhelpfulOther (fsLit "")) #else sp = UnhelpfulSpan (fsLit "") #endif property g describe "comparing TEnd with TEnd" $ it "should be True" $ (TEnd :: Form Atom) `shouldBe` (TEnd :: Form Atom) locationTest :: Maybe FilePath -> String -> Spec locationTest mb_path str = describe ("location of `" ++ str ++ "'") $ it (case mb_path of Just path -> "should contain `" ++ path ++ "'" Nothing -> "should be unhelpful") $ do let c = parseE' mb_path str l = showLoc c case mb_path of Just path -> (path `isPrefixOf` l) `shouldBe` True Nothing -> ("anon" `isSubsequenceOf` l) `shouldBe` True asLocOfTest :: Spec asLocOfTest = describe ("apply asLocOf to code") $ do it "should return the value of first arg" $ property (\ a b -> asLocOf a b == a) it "should use the location of second arg" $ property (\ a b -> case (asLocOf a b, b) of (LForm (L l1 _), LForm (L l2 _)) -> l1 == l2) lengthTest :: Int -> String -> Spec lengthTest n str = describe ("length of " ++ str) $ it ("should be " ++ show n) $ length (parseE str) `shouldBe` n homoiconicTests :: Spec homoiconicTests = do let t x = describe ("to/from code " ++ show x) $ it "shoult match the input" $ case fromCode (toCode x) of Just y -> y `shouldBe` x Nothing -> error ("got Nothing with " ++ show x) t (aIntegral (42 :: Int)) t () t 'x' t "string" t (42 :: Int) t (42 :: Int8) t (42 :: Int16) t (42 :: Int32) t (42 :: Int64) t (42 :: Integer) t (42 :: Word) t (42 :: Word8) t (42 :: Word16) t (42 :: Word32) t (42 :: Word64) t (0.123456789 :: Double) t (1.234 :: Float) t ([1,2,3] :: [Int]) t (Fixed.MkFixed 2 :: Fixed.Pico) t (Identity 'a') t (1 :+ 2 :: Complex Int) t (Compose (Just (Just 'a'))) t (Const True :: Const Bool Char) t (Product.Pair (Just 'a') (Just 'b')) t [Sum.InL (Just 'a'), Sum.InR (Right 'b'), Sum.InR (Left "foo")] t ('a' :| ['b', 'c', 'd']) t (All False) t (Alt (Just True)) t (Any False) t (Dual 'x') t (First (Just 'a')) t (Last (Just 'a')) t (Product (42 :: Int)) t (Sum (42 :: Int)) t (Proxy :: Proxy ()) t (Version [1,2,3] ["foo", "bar"]) t (1 % 3 :: Rational) t (Semigroup.Arg 'x' False) t (Semigroup.First 'a') t (Semigroup.Last 'z') t (Semigroup.Max (42 :: Int)) t (Semigroup.Min (42 :: Int)) #if !MIN_VERSION_ghc(9,0,0) t (Semigroup.Option (Just "foo")) #endif t (Semigroup.WrapMonoid True) t (42 :: Natural) t (Atom (aIntegral (42 :: Int))) t (LForm (genSrc (Atom (aIntegral (42 :: Int))))) t [True, False] t [EQ, LT, GT] t (Just (42 :: Int)) t [Right True, Left "foo"] t (Just 'x', [Right False, Left "foo"]) t (Just 'x', [Right False, Left "foo"], EQ) t (Just 'x', [Right False, Left "foo"], EQ, 42::Int) t (Just 'x', [Right False, Left "foo"], EQ, 42::Int ,False) t (Just 'x', [Right False, Left "foo"], EQ, 42::Int ,False, Just [Right (Just EQ), Left (3.1 :: Double)]) rnfTest :: Spec rnfTest = do describe "rnf of arbitrary form" $ it "should return ()" $ property (rnf :: Code -> ()) describe "rnf of TEnd" $ it "should return ()" $ rnf (TEnd :: Form Atom) `shouldBe` () listTest :: Spec listTest = describe "list from arbitrary form applied to arbitrary function" $ it "should be a list" $ do let f :: (Code -> Code) -> Code -> Bool f g form = isListL (toListL (g form)) property f cInt :: Int -> Code cInt = toCode cDouble :: Double -> Code cDouble = toCode numTest :: Spec numTest = describe "Num instance for Code" $ do it "should evaluate +" $ do cInt 2 + cInt 40 `shouldBe` 42 cInt 2 + cDouble 40 `shouldBe` 42.0 cDouble 2 + cInt 40 `shouldBe` 42.0 cDouble 2.0 + cDouble 40.0 `shouldBe` 42.0 it "should evaluate * for AInteger" $ do cInt 6 * cInt 7 `shouldBe` 42 cDouble 6 * cDouble 7 `shouldBe` 42.0 it "should evalue - for AInteger" $ do cInt 50 - cInt 8 `shouldBe` 42 cDouble 50 - cDouble 8 `shouldBe` 42.0 it "should evaluate abs" $ do abs (cInt (-42)) `shouldBe` 42 abs (cDouble (-42)) `shouldBe` 42.0 it "should evaluate signum" $ do signum (cInt (-42)) `shouldBe` -1 signum (cDouble (-42)) `shouldBe` -1.0 it "should evaluate fromInteger" $ fromInteger 42 `shouldBe` cInt 42 it "should result to nil with invalid values" $ do 3 + toCode 'a' `shouldBe` nil signum (toCode 'a') `shouldBe` nil fractionalTest :: Spec fractionalTest = describe "Fractional instance for Code" $ do it "should evaluate /" $ do cInt 84 / cInt 2 `shouldBe` 42.0 cDouble 84.0 / cDouble 2.0 `shouldBe` 42.0 it "should evaluate recip" $ do recip (cInt 4) `shouldBe` 0.25 recip (cDouble 4.0) `shouldBe` 0.25 monoidTest :: Spec monoidTest = do let a = toCode 'a' b = toCode 'b' lst = toCode (List [a,b]) hslst = toCode (HsList [a,b]) describe "Atom <> XXX" $ do it "should result in '(a b)" $ a <> b `shouldBe` lst it "should result in '(a a b)" $ a <> lst `shouldBe` toCode (List [a,a,b]) it "should result in '(a a b)" $ a <> hslst `shouldBe` toCode (List [a,a,b]) describe "List <> XXX" $ do it "should result in '(a b a)" $ lst <> a `shouldBe` toCode (List [a,b,a]) it "should result in '(a b a b)" $ lst <> lst `shouldBe` toCode (List [a,b,a,b]) it "should result in '(a b a b)" $ lst <> hslst `shouldBe` toCode (List [a,b,a,b]) describe "HsList <> XXX" $ do it "should result in '(a b a)" $ hslst <> a `shouldBe` toCode (List [a,b,a]) it "should result in '(a b a b)" $ hslst <> lst `shouldBe` toCode (List [a,b,a,b]) it "should result in '(a b a b)" $ hslst <> hslst `shouldBe` toCode (List [a,b,a,b]) describe "TEnd" $ do it "should result in non-TEnd" $ do let at = Atom True at <> TEnd `shouldBe` at TEnd <> at `shouldBe` at describe "mempty" $ do it "should be empty list" $ mempty `shouldBe` (List [] :: Form Atom) it "should be nil" $ mempty `shouldBe` nil alternativeTest :: Spec alternativeTest = describe "Alternative" $ do describe "empty" $ do it "should be nil for Code" $ empty `shouldBe` nil it "should be empty form for Form" $ empty `shouldBe` (mempty :: Form Atom) describe "<|>" $ do let a = toCode 'a' b = toCode 'b' c = toCode 'c' it "should append elements for Code" $ let ab = toCode (List [a,b]) cb = toCode (List [c,b]) in ab <|> cb `shouldBe` toCode (List [a,b,c,b]) it "should append elements for Form Atom" $ let ab = List [a,b] cb = List [c,b] in ab <|> cb `shouldBe` List [a,b,c,b] data Foo = Foo deriving (Eq, Show) instance Homoiconic Foo where toCode foo = toCode (aSymbol (show foo)) parseCode _ = Homoiconic.Failure "Foo" fromCodeTest :: Spec fromCodeTest = do describe "default toCode implementation" $ it "should return Nothing" $ (fromCode nil :: Maybe Foo) `shouldBe` Nothing describe "getting Nothing from fromCode" $ do let ng title x = it title $ x `shouldBe` Nothing q x = qSymbol x "" 0 0 0 0 foo = q "foo" foo1 = qList [q "Foo", q "a"] "" 0 0 0 0 foo2 = qList [q "Foo", q "a", q "b"] "" 0 0 0 0 it "should result to Nothing with explicit Nothing" $ do fromCode (q "Nothing") `shouldBe` (Just Nothing :: Maybe (Maybe ())) toCode (Nothing :: Maybe ()) `shouldBe` q "Nothing" ng "()" (fromCode foo :: Maybe ()) ng "Int" (fromCode foo :: Maybe Int) ng "Char" (fromCode nil :: Maybe Char) ng "[Int]" (fromCode nil :: Maybe [Int]) ng "[Char]" (fromCode foo :: Maybe [Char]) ng "Bool" (fromCode foo :: Maybe Bool) ng "Ordering" (fromCode foo :: Maybe Ordering) ng "Maybe ()" (fromCode foo1 :: Maybe (Maybe ())) ng "Either String ()" (fromCode foo1 :: Maybe (Either String ())) ng "(,)" (fromCode foo :: Maybe ((), ())) ng "(,,)" (fromCode foo :: Maybe ((), (), ())) ng "(,,,)" (fromCode foo :: Maybe ((), (), (), ())) ng "(,,,,)" (fromCode foo :: Maybe ((), (), (), (), ())) ng "(,,,,,)" (fromCode foo :: Maybe ((), (), (), (), (), ())) ng "Data.Functor.Sum.Sum Maybe (Either String) ()" (fromCode foo1 :: Maybe (Sum.Sum Maybe (Either String) ())) ng "Data.Functor.Product.Product Maybe (Either String) ()" (fromCode foo2 :: Maybe (Product.Product Maybe (Either String) ())) ng "Sum ()" (fromCode foo1 :: Maybe (Sum ())) ng "Proxy ()" (fromCode foo :: Maybe (Proxy ())) ng "Atom" (fromCode foo1 :: Maybe Atom) fromCodeErrorTest :: Spec fromCodeErrorTest = do let err :: Homoiconic a => a -> String -> Spec err a ty = it ("should show error message containing " ++ ty) $ do case parseCode x `asTypeOf` Homoiconic.Success a of Homoiconic.Failure e -> e `shouldSatisfy` isSubsequenceOf ty _ -> expectationFailure "parser unexpectedly succeeded" x = toCode (List [ toCode (aSymbol "foo") , toCode (aSymbol "x") ]) describe "Failing to parse Code" $ do err (1 :: Integer) "integral" err (1 :: Double) "fractional" err () "()" err 'a' "Char" err "string" "String" err False "Bool" err EQ "Ordering" err (Just False) "Maybe" err (Right True `asTypeOf` Left "foo") "Either" err ((),()) "," err ((),(),()) "(,,)" err ((),(),(),()) "(,,,)" err ((),(),(),(),()) "(,,,,)" err ((),(),(),(),(),()) "(,,,,,)" err (Sum.InL (Just True) `asTypeOf` Sum.InR (Just False)) "Sum" err (All True) "All" err (Proxy :: Proxy Int) "Proxy" err (aSymbol "foo") "Atom" data D1 = D1a | D1b | D1c deriving (Eq, Show, Data, Typeable, Generic) instance Homoiconic D1 instance Arbitrary D1 where arbitrary = oneof (map pure [D1a, D1b, D1c]) data D2 a = D2a a | D2b a a deriving (Eq, Show, Data, Typeable, Generic) instance Homoiconic a => Homoiconic (D2 a) instance Arbitrary a => Arbitrary (D2 a) where arbitrary = oneof [D2a <$> arbitrary, D2b <$> arbitrary <*> arbitrary] data D3 a b = D3a Int a b deriving (Eq, Show, Data, Typeable, Generic) instance (Homoiconic a, Homoiconic b) => Homoiconic (D3 a b) instance (Arbitrary a, Arbitrary b) => Arbitrary (D3 a b) where arbitrary = D3a <$> arbitrary <*> arbitrary <*> arbitrary data D4 a = D4a (a, a, a, a) deriving (Eq, Show, Data, Typeable, Generic) instance Homoiconic a => Homoiconic (D4 a) instance Arbitrary a => Arbitrary (D4 a) where arbitrary = D4a <$> ((,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) dataToCodeTest :: Spec dataToCodeTest = do let s = toCode . aSymbol describe "D1 to Code" $ it "should match D1 values" $ do let e1a = s "D1a" e1b = s "D1b" e1c = s "D1c" dataToCode D1a `shouldBe` e1a dataToCode D1b `shouldBe` e1b dataToCode D1c `shouldBe` e1c describe "D2 to Code" $ it "should match `D2 Char' values"$ do let e2a = toCode (List [s "D2a", toCode 'x']) e2b = toCode (List [s "D2b", toCode 'y', toCode 'z']) dataToCode (D2a 'x') `shouldBe` e2a dataToCode (D2b 'y' 'z') `shouldBe` e2b describe "D2 with D1 to Code" $ it "should match `D2 D1' values" $ do let e2b = toCode (List [s "D2b", s "D1a", s "D1b"]) dataToCode (D2b D1a D1b) `shouldBe` e2b describe "D2 with Double to Code" $ it "should match `D2 Double' values" $ do let e2c = toCode (List [s "D2a", toCode (1.23 :: Double)]) dataToCode (D2a (1.23 :: Double)) `shouldBe` e2c describe "D3 to Code" $ it "should match `D3' value" $ do let e3 = toCode (List [ s "D3a" , toCode (42 :: Int) , toCode False , toCode 'a' ]) dataToCode (D3a 42 False 'a') `shouldBe` e3 describe "D4 to Code" $ it "should match `D4' value" $ do let e4 = toCode (List [ s "D4a" , toCode (List [ s "," , toCode 'w' , toCode 'x' , toCode 'y' , toCode 'z'])]) dataToCode (D4a ('w', 'x', 'y', 'z')) `shouldBe` e4 genericHomoiconicTest :: Spec genericHomoiconicTest = do describe "Result data type for parsing" $ do let s1, s2, f1 :: Homoiconic.Result Bool s1 = Homoiconic.Success True s2 = Homoiconic.Success False f1 = Homoiconic.Failure "foo" it "should equal to itself" $ do s1 `shouldBe` s1 s1 `shouldNotBe` s2 f1 `shouldNotBe` s2 it "should show its conteints" $ do show s1 `shouldBe` "Success True" show f1 `shouldBe` "Failure \"foo\"" let isFailure (Homoiconic.Failure _) = True isFailure _ = False it "should fail on binding Failure" $ ((Homoiconic.Failure "X_X" >>= pure) :: Homoiconic.Result Bool) `shouldSatisfy` isFailure describe "parseCode failure" $ do let d2a_sym = toCode $ aSymbol "D2a" d3a_sym = toCode $ aSymbol "D3a" unit_sym = toCode () fail_with substring r = case r of Homoiconic.Failure msg -> substring `isSubsequenceOf` msg _ -> False it "should fail on non list Code" $ do let r = parseCode @(D2 ()) d2a_sym r `shouldSatisfy` fail_with "Not a list" it "should fail on unexpected field constructor" $ do let r = parseCode @(D3 (D2 Bool) Bool) x x = toCode (List [d3a_sym, unit_sym]) r `shouldSatisfy` fail_with "()" it "should fail on unexpected leftover values" $ do let r = parseCode @(D2 ()) x x = toCode (List [d2a_sym, unit_sym, unit_sym]) r `shouldSatisfy` fail_with "leftover" it "should fail on invalid constructor (no arg)" $ do let r = parseCode @FormTest.D1 (toCode (aSymbol "foo")) r `shouldSatisfy` fail_with "foo" it "should fail on invalid constructor (with args)" $ do let r = parseCode @(D2 Bool) (toCode (List [toCode (aSymbol "foo")])) r `shouldSatisfy` fail_with "foo" describe "genericFromCode" $ do it "should result in Code value" $ do let d2 :: D2 Int d2 = D2a 42 genericFromCode (toCode d2) `shouldBe` Just d2 it "should fail with invalid value" $ do genericFromCode (toCode ()) `shouldBe` (Nothing :: Maybe (D2 Int)) describe "To/from code via Generic" $ do it "should return itself" $ let g_to_from :: D4 (D3 (D2 Int) D1) -> Bool g_to_from x = Just x == fromCode (toCode x) in property g_to_from it "should return itself with nested Maybe data type" $ let g_to_from :: D3 (Maybe (Maybe (Maybe Int))) (Maybe (Maybe Bool)) -> Bool g_to_from x = Just x == fromCode (toCode x) in property g_to_from let s = toCode . aSymbol noParse :: (Eq a, Show a, Homoiconic a) => Maybe a -> IO () noParse = (`shouldBe` Nothing) describe "Malformed codes via Generic" $ do it "result to Nothing with invalid constructor" $ noParse (fromCode (s "Foo") :: Maybe D1) it "result to Nothing with arity mismatch" $ noParse (fromCode (toCode (List [s "D2a", toCode False, toCode False])) :: Maybe (D2 Bool)) it "result to Nothing with invalid field value" $ noParse (fromCode (toCode (List [s "D2a", s "FOO"])) :: Maybe (D2 Bool)) it "result to Nothing with non list" $ noParse (fromCode (toCode "FOO") :: Maybe (D2 Bool)) it "result to Nothing with invalid form" $ noParse (fromCode (toCode (List [s "D2a", toCode (List [s "Just", s "___"])])) :: Maybe (D2 (Maybe Bool))) unquoteSpliceTest :: Spec unquoteSpliceTest = describe "unquote splicing List" $ it "should return list contents" $ property (\form -> (isListL form || isHsListL form || isStringL form || isUnitL form) ==> (0 <= length (unquoteSplice form))) eqForm :: Code -> Code -> Bool eqForm a b = case (unCode a, unCode b) of -- Ignoring rounding error for fractional literals. (Atom (AFractional x), Atom (AFractional y)) -> abs (fl_value x - fl_value y) <= toRational epsilon -- Recursively compare with `eqForm' for 'List' and 'HsList'. (List [], List []) -> True (List (x:xs), List (y:ys)) -> let ql z = qList z "" 0 0 0 0 in eqForm x y && eqForm (ql xs) (ql ys) (HsList [], HsList []) -> True (HsList (x:xs), HsList (y:ys)) -> let qh z = qHsList z "" 0 0 0 0 in eqForm x y && eqForm (qh xs) (qh ys) -- Treating empty 'List' and Atom symbol 'nil' as same value. (Atom (ASymbol sym), List []) | sym == fsLit "nil" -> True (List [], Atom (ASymbol sym)) | sym == fsLit "nil" -> True -- Using '==' for other Atom values. (Atom x, Atom y) -> x == y _ -> False where epsilon :: Double epsilon = 1e-7 pprTest :: Spec pprTest = describe "ppr" $ it "should return expected String" $ do let str0 = "(1 2.34 () #'a \"foo\" [foo bar buzz])" str1 <- runPpr str0 str1 `shouldBe` str0 runPpr :: String -> IO String runPpr str = runFnk (do dflags <- getDynFlags return (showPpr dflags (parseE str))) defaultFnkEnv parseE :: String -> Code parseE = parseE' Nothing parseE' :: Maybe FilePath -> String -> Code parseE' mb_path str = let inp = stringToStringBuffer str in case runSP sexpr mb_path inp of Right (expr, _) -> expr Left err -> error (show err) isListL :: Code -> Bool isListL (LForm (L _ (List _))) = True isListL _ = False isHsListL :: Code -> Bool isHsListL (LForm (L _ (HsList _))) = True isHsListL _ = False isStringL :: Code -> Bool isStringL (LForm (L _ (Atom (AString _ _)))) = True isStringL _ = False isUnitL :: Code -> Bool isUnitL (LForm (L _ (Atom AUnit))) = True isUnitL _ = False ================================================ FILE: finkel-kernel/test/Main.hs ================================================ -- | Tests for Finkel. module Main where -- base import System.Environment (getArgs) -- hspec import Test.Hspec (beforeAll, beforeAll_, describe, hspec) -- finkel-kernel import Language.Finkel.Fnk (initUniqSupply') import Language.Finkel.Preprocess (defaultPreprocess) -- Internal import EmitTest import EvalTest import ExceptionTest import FnkTest import FormTest import MainTest import MakeTest import PluginTest import PreprocessTest import SyntaxTest import TestAux -- To support plugin tests, the test executable is acting as a preprocessor if -- specific three file paths were given. Otherwise, run the hspec tests. main :: IO () main = do args <- getArgs case args of (orig:isrc:_opath:_rest) | orig == isrc -> defaultPreprocess _ -> doHspec doHspec :: IO () doHspec = hspec (beforeAll_ -- Initializing UniqSupply before all tests, so that the tests not using -- 'Language.Finkel.Main.defaultMain' can use UniqSupply, and to avoid -- initializing the UniqSupply multiple times. (initUniqSupply' 0 1) (do describe "Form" formTests describe "Fnk" fnkTests describe "Emit" emitTests describe "Preprocess" preprocessTests beforeAll getFnkTestResource $ do describe "Eval" evalFnkTests describe "Main" mainFnkTests describe "Make" makeFnkTests describe "Plugin" pluginTests describe "Syntax" syntaxFnkTests describe "Exception" exceptionFnkTests)) ================================================ FILE: finkel-kernel/test/MainTest.hs ================================================ {-# LANGUAGE CPP #-} -- | Tests for "Language.Finkel.Main" module MainTest ( mainFnkTests ) where -- base import System.Exit (ExitCode (..)) -- filepath import System.FilePath (()) -- hspec import Test.Hspec -- Internal import TestAux mainFnkTests :: FnkSpec mainFnkTests = beforeAll_ (removeArtifacts odir) $ do let common_flags = ["-v0", "-fno-code"] compileFile common_flags "m001.hs" compileFile common_flags "m002.hs" compileFile ("-c" : common_flags) "m003.c" compileFile ("-main-is" : "MyMain.my-main" : common_flags) "MyMain.hs" rawGhcTest finkelHelpTest finkelVersionTest finkelSupportedLanguagesTest finkelInfoTest finkelUnknownFlagTest compileFile :: [String] -> FilePath -> FnkSpec compileFile args file = describe ("file " ++ file) $ it "should compile successfully" $ \ftr -> ftr_main ftr (args ++ pure (odir file)) rawGhcTest :: FnkSpec rawGhcTest = trivialTest "option --version" "should show project-version" ["--version"] finkelHelpTest :: FnkSpec finkelHelpTest = trivialTest "option --fnk-help" "should show Finkel help" ["--fnk-help"] finkelVersionTest :: FnkSpec finkelVersionTest = trivialTest "option --fnk-version" "should show finkel-kernel package version" ["--fnk-version"] finkelSupportedLanguagesTest :: FnkSpec finkelSupportedLanguagesTest = trivialTest "option --fnk-languages" "should show supported language extensions" ["--fnk-languages"] finkelInfoTest :: FnkSpec finkelInfoTest = trivialTest "option --info" "should show info of DynFlags" ["--info"] finkelUnknownFlagTest :: FnkSpec finkelUnknownFlagTest = describe "invalid flag" $ do it "should exit with failure with unknown flag" $ \ftr -> ftr_main ftr ["--fnk-foo"] `shouldThrow` (== ExitFailure 1) it "should exit with failure with invalid verbosity level" $ \ftr -> ftr_main ftr ["--fnk-verbose=foo"] `shouldThrow` (== ExitFailure 1) trivialTest :: String -> String -> [String] -> FnkSpec trivialTest desc label flags = describe desc $ it label (`ftr_main` flags) odir :: FilePath odir = "test" "data" "main" ================================================ FILE: finkel-kernel/test/MakeTest.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -- | Tests for 'make'. module MakeTest ( makeTests , makeFnkTests ) where #include "ghc_modules.h" -- base import Control.Exception (SomeException (..)) import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO (..)) import Data.List (isPrefixOf, tails) import Data.Maybe (isJust) import GHC.Exts (unsafeCoerce#) import System.Environment (getExecutablePath, lookupEnv) import System.Info (os) -- directory import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive) #if !MIN_VERSION_ghc(9,0,0) import System.Directory (getDirectoryContents) #endif -- filepath import System.FilePath ((<.>), ()) #if !MIN_VERSION_ghc(9,0,0) import System.FilePath (takeExtension) #endif -- ghc import GHC_Data_FastString (fsLit) import GHC_Driver_Monad (GhcMonad (..)) import GHC_Driver_Ppr (showPpr) import GHC_Driver_Session (HasDynFlags (..)) import GHC_Types_SrcLoc (noLoc) import GHC_Unit_Module (mkModuleName) import GHC_Unit_State (PackageName (..)) import GHC_Utils_Outputable (Outputable (..)) #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Env (hscInterp) import GHC.Linker.Loader (unload) #elif MIN_VERSION_ghc(9,2,0) import GHC.Linker.Loader (unload) import GHC.Runtime.Interpreter (hscInterp) #else import GHC_Runtime_Linker (unload) #endif #if !MIN_VERSION_ghc(9,0,0) import GHC_Driver_Session (DynFlags (..)) import GHC_Unit_State (lookupPackageName) import GHC_Utils_Outputable (showSDoc) #endif #if MIN_VERSION_ghc(9,0,0) import GHC_Platform_Ways (hostIsDynamic, hostIsProfiled) #else import DynFlags (Way (..), dynamicGhc, interpWays) import Module (componentIdToInstalledUnitId) import Packages (InstalledPackageInfo (..), PackageConfig, lookupInstalledPackage, pprPackageConfig) #endif -- process import System.Process (readProcess) -- hspec import Test.Hspec -- finkel-kernel import Language.Finkel.Eval import Language.Finkel.Fnk import Language.Finkel.Form import Language.Finkel.Make (TargetSource (..), asModuleName, buildHsSyn, setContextModules, simpleMake, withExpanderSettings) import Language.Finkel.Plugin (plugin, setFinkelPluginWithArgs) import Language.Finkel.Syntax -- Internal import TestAux makeTests :: Spec makeTests = beforeAll getFnkTestResource makeFnkTests makeFnkTests :: FnkSpec makeFnkTests = beforeAll_ (removeArtifacts odir) $ do targetSourceTests let in_odir file = odir file -- Build bytecode buildByteCode (in_odir "main1.hs") buildByteCode (in_odir "main2.hs") buildByteCode (in_odir "main3.hs") buildByteCodeWith ["--fnk-verbose=2", "-v2"] (in_odir "main4.hs") buildByteCode (in_odir "main5.hs") buildByteCodeWith [ "--fnk-dump-dflags" , "--fnk-dump-expand" , "--fnk-dump-hs" , "--fnk-trace-expand" , "--fnk-trace-make" , "--fnk-trace-spf" ] (in_odir "main9.hs") -- Build object codes buildC (odir "cbits1.c") buildObj ["-fforce-recomp", "-ddump-parsed", "-ddump-parsed-ast" ,"-dsource-stats"] [in_odir "main5.hs"] buildObj [] (map in_odir ["cbits1.c", "cbits2.c", "cbits3.c", "main6.hs"]) buildObj [] (map (odir ) ["cbits1.o","cbits2.o","cbits3.o"] ++ [in_odir "main6.hs"]) buildObj [] (map in_odir ["main6.hs", "cbits1.c", "cbits2.c", "cbits3.c"]) buildObj [] ["M4.A"] buildObj ["--fnk-dump-hs", "--fnk-hsdir=" ++ (in_odir "gen")] ["M5", "M4.A", "M4.B", "M4", in_odir "main7.hs"] buildObj ["-O2"] [in_odir "main8.hs"] let buildObj' flags inputs = before_ prepare_obj (buildObj flags inputs) buildObjAndExist' flags inputs = beforeAll_ prepare_obj (let outputs = map (<.> "o") inputs in buildObjAndExist flags inputs outputs) prepare_obj = do mapM_ removeArtifacts [odir, in_odir "M4", in_odir "M6"] -- Compile object codes with and without optimization option buildObjAndExist' [] ["P1", "P2"] buildObjAndExist' ["-O1"] ["P1", "P2"] -- Recompile P1 and P2 without deleting previous results buildObj [] ["P1","P2"] -- Compile object code with and without optimization, module reorderd buildObjAndExist' [] ["P2", "P1"] buildObjAndExist' ["-O1"] ["P2", "P1"] -- Compile object codes, P3 requires but does not import P1. buildObjAndExist' [] ["P1", "P3"] buildObjAndExist' ["-O1"] ["P1", "P3"] #if !defined(mingw32_HOST_OS) -- Compile object codes with dynamic-too and optimization option buildObj' ["-O0", "-dynamic-too"] ["P1", "P2"] buildObj' ["-O1", "-dynamic-too"] ["P1", "P2"] -- Compile object codes with dynamic-too and optimization option, reorderd buildObj' ["-O0", "-dynamic-too"] ["P2", "P1"] buildObj' ["-O1", "-dynamic-too"] ["P2", "P1"] #endif -- Compile object codes with profiling option has_profiling_obj <- runIO hasProfilingObj when has_profiling_obj $ do buildObj' ["-O","-prof", "-osuf", "p_o", "-hisuf", "p_hi"] ["P1", "P2"] buildObj' ["-O","-prof", "-osuf", "p_o", "-hisuf", "p_hi"] ["P1", "P2"] -- Reload tests let reload_simple t after_files after_output = buildReload t "foo" [("R01.hs.1", "R01.hs"), (t, t)] after_files "foo: before" after_output -- Reloading without modifications. reload_simple "R02.hs" [] "foo: before" #if MIN_VERSION_ghc(9,0,0) -- Reloading with modifications. Failing with ghc 8.10 when running with nix -- in CI test, disabling for now. reload_simple "R02.hs" [("R01.hs.2", "R01.hs")] "foo: after" #endif -- Reloading test for modules containing `:require' of home package modules -- not working well with ghc >= 8.10. -- XXX: Disabled at the moment. -- reload_simple "R03.fnk" -- Recompile tests let recompile_simple t extras = buildRecompile t ([("R01.hs.1", "R01.hs"), dot_hs t] ++ map dot_hs extras) [("R01.hs.2", "R01.hs")] "foo: before\n" "foo: after\n" dot_hs x = let y = x <.> "hs" in (y,y) recompile_simple "R04" [] recompile_simple "R05" ["R05a"] recompile_simple "R06" ["R06a"] -- XXX: R07 and R08 contains nested require of home modules. When compiling -- with plugin, recompilation is not working with modification of R01.hs. recompile_simple "R07" ["R07a", "R07b"] recompile_simple "R08" ["R08a", "R08b"] recompile_simple "R09" ["R09a", "R09b"] recompile_simple "R10" ["R10a", "R10b"] recompile_simple "R11" ["R11a", "R11b"] -- Errors buildFilesNG [] ["E01"] buildFilesNG [] ["E02"] -- Action to unload package libraries -- -- Until ghc 8.10, persistent linker state is stored in a global variable. The -- loaded package libraries are shared in "HscEnv.hsc_dynLinker" in every Fnk -- run, which may cause link time error with dynamic object on some platforms. -- To avoid such link time error, invoking "Linker.unload" before running the -- test containing macro expansion. -- -- Persistent linker state is isolated from ghc 8.10, does nothing. -- Action to decide whether profiling objects for the "finkel-kernel" package -- are available at runtime. hasProfilingObj :: IO Bool hasProfilingObj = runFnk (hasProfilingObj1 pkg_name) fnkTestEnv where pkg_name = PackageName (fsLit "finkel-kernel") hasProfilingObj1 :: PackageName -> Fnk Bool #if MIN_VERSION_ghc(9,0,0) hasProfilingObj1 _ = return False #else hasProfilingObj1 pkg_name = do initSessionForTest dflags <- getDynFlags case lookupPackageConfig dflags pkg_name of Nothing -> return False Just cfg -> liftIO (do putStrLn (showSDoc dflags (pprPackageConfig cfg)) lookupProfObjInDirectories (libraryDirs cfg)) lookupPackageConfig :: DynFlags -> PackageName -> Maybe PackageConfig lookupPackageConfig dflags pkg_name = do cmpid <- lookupPackageName dflags pkg_name lookupInstalledPackage dflags (componentIdToInstalledUnitId cmpid) lookupProfObjInDirectories :: [FilePath] -> IO Bool lookupProfObjInDirectories = let go (dir:dirs) = do files <- getDirectoryContents dir if any (\file -> ".p_o" == takeExtension file) files then return True else go dirs go [] = return False in go #endif fnksrc1, hssrc1, othersrc1 :: TargetSource fnksrc1 = FnkSource "path1" (mkModuleName "Foo") hssrc1 = HsSource "path2" (mkModuleName "Bar") othersrc1 = OtherSource "path3" subseq :: Eq a => [a] -> [a] -> Bool subseq xs ys = any (isPrefixOf xs) (tails ys) targetSourceTests :: FnkSpec targetSourceTests = describe "TargetSource" $ do showTargetTest pprTargetTest asModuleNameTest showTargetTest :: FnkSpec showTargetTest = do describe "show TargetSource" $ it "should contain filepath" $ \_ -> do show fnksrc1 `shouldSatisfy` subseq "path1" show hssrc1 `shouldSatisfy` subseq "path2" show othersrc1 `shouldSatisfy` subseq "path3" asModuleNameTest :: FnkSpec asModuleNameTest = describe "asModuleName" $ it "should replace path separators" $ \_ -> asModuleName ("Foo" "Bar" "Buzz.fnk") `shouldBe` "Foo.Bar.Buzz" runOutputable :: (MonadIO m, Outputable a) => a -> m String runOutputable obj = liftIO $ runFnk (flip showPpr obj <$> getDynFlags) fnkTestEnv pprTargetTest :: FnkSpec pprTargetTest = describe "ppr TargetSource" $ it "should contain filepath" $ \_ -> do let t target path = do str <- runOutputable target str `shouldSatisfy` subseq path t fnksrc1 "path1" t hssrc1 "path2" t othersrc1 "path3" buildByteCode :: FilePath -> FnkSpec buildByteCode = buildByteCodeWith [] buildByteCodeWith :: [String] -> FilePath -> FnkSpec buildByteCodeWith extra file = buildFiles (["-no-link", "-fbyte-code"] ++ extra) [file] buildC :: FilePath -> FnkSpec buildC file = buildFiles ["-no-link"] [file] buildObj :: [String] -> [FilePath] -> FnkSpec buildObj = buildFiles buildObjAndExist :: [String] -> [FilePath] -> [String] -> FnkSpec buildObjAndExist args inputs outputs = describe (labelWithOptionsAndFiles args inputs) $ it "should write to output" $ \ftr -> pendingInputsForWindowsOr inputs $ mapM_ (\f -> do buildWork ftr args inputs doesFileExist (odir f) `shouldReturn` True) outputs buildFiles :: [String] -> [FilePath] -> FnkSpec buildFiles pre inputs = describe (labelWithOptionsAndFiles pre inputs) $ it "should compile successfully" $ \ftr -> pendingInputsForWindowsOr inputs $ buildWork ftr pre inputs pendingInputsForWindowsOr :: [String] -> Expectation -> Expectation pendingInputsForWindowsOr inputs act = if os == "mingw32" && any (`elem` pendingInputsUnderWindows) inputs then pendingWith "pending under Windows" else act -- Compilation of modules containing macro expansion is not working well under -- Windows, pending for now. pendingInputsUnderWindows :: [String] pendingInputsUnderWindows = ["main4.fnk", "main8.fnk", "main9.fnk", "P1"] buildFilesNG :: [String] -> [FilePath] -> FnkSpec buildFilesNG pre inputs = describe (labelWithOptionsAndFiles pre inputs) $ it "should throw an exception" $ \ftr -> buildWork ftr pre inputs `shouldThrow` anyException labelWithOptionsAndFiles :: [String] -> [FilePath] -> String labelWithOptionsAndFiles pre inputs = "file " ++ show inputs ++ if null pre then "" else " with " ++ unwords pre buildWork :: FnkTestResource -> [String] -> [FilePath] -> Expectation buildWork ftr pre inputs = do_work where do_work | isProfWay = do_prof_work | otherwise = do_work_with [] -- Use dflags setttings for profile when running test executable with "+RTS -- -p" option. do_prof_work = do_work_with [ "-prof", "-fprof-auto", "-fprof-cafs" , "-hisuf", "p_hi", "-osuf", "p_o" ] do_work_with extra = ftr_main ftr (extra ++ common_args ++ pre) common_args = ["-i.", "-i" ++ odir, "-v1"] ++ inputs #if MIN_VERSION_ghc(9,0,0) isProfWay = hostIsProfiled #else isProfWay = WayProf `elem` interpWays #endif odir :: FilePath odir = "test" "data" "make" -- ------------------------------------------------------------------------ -- -- For reload and recompile tests -- -- ------------------------------------------------------------------------ buildReload :: String -- ^ Target module name. -> String -- ^ Function to return a 'String' value. -> [(String, String)] -- ^ List of (input file, output file), before. -> [(String, String)] -- ^ List of (input file, output file), after. -> String -- ^ Expected value of before. -> String -- ^ Expected value for after. -> FnkSpec buildReload the_file fname files1 files2 before_str after_str = beforeAllWith (\ftr -> do dir <- mk_tmp_dir ("reload_" ++ the_file) return (dir, ftr)) (afterAll (rmdir . fst) work) where work = do describe (unwords ["Reload test for", the_file , "with", fname]) $ do it "should get expected values (bytecode)" $ do_work False it "should get expected values (objcode)" $ do_work True do_work use_obj (tmpdir, ftr) = do if use_obj && not dynamicGhc -- XXX: Reloading with non-dynamic object code not yet working. It -- does work when the test executable was compiled with "-dynamic" -- option. then pendingWith "non-dynamic object code not yet supported" else do is_travis <- lookupEnv "TRAVIS" if isJust is_travis && os == "darwin" then pendingWith "not supported under Travis OSX" else do_work' use_obj tmpdir ftr do_work' use_obj tmpdir ftr = do let act = runFnk (fnk_work use_obj tmpdir ftr) reloadFnkEnv (ret1, ret2) <- quietly act (ret1, ret2) `shouldBe` (before_str, after_str) reloadFnkEnv = fnkTestEnv {envVerbosity = 3} fnk_work use_obj tmpdir ftr = do setup_reload_env use_obj tmpdir ftr copy_files tmpdir files1 str1 <- make_and_eval tmpdir reset_env copy_files tmpdir files2 str2 <- make_and_eval tmpdir return (str1, str2) setup_reload_env :: Bool -> FilePath -> FnkTestResource -> Fnk () setup_reload_env use_obj tmpdir ftr = do me <- liftIO getExecutablePath let args0 = ("-i" ++ tmpdir) : ["-fobject-code" | use_obj] args1 = ["-v0", "-F", "-pgmF", me, "-optF", "--no-warn-interp"] parseAndSetDynFlags (args0 <> args1) ftr_init ftr prepareInterpreter setFinkelPluginWithArgs plugin [] make_and_eval :: FilePath -> Fnk String make_and_eval tmpdir = do _ <- simpleMake [(noLoc (tmpdir the_file), Nothing)] False Nothing setContextModules [asModuleName the_file] hexpr <- buildHsSyn parseExpr [qSymbol fname fname 0 0 0 0] unsafeCoerce# <$> evalExpr hexpr reset_env = do hsc_env <- getSession #if MIN_VERSION_ghc(9,2,0) liftIO (unload (hscInterp hsc_env) hsc_env []) #else liftIO (unload hsc_env []) #endif #if MIN_VERSION_ghc(9,0,0) dynamicGhc = hostIsDynamic #endif -- | Make a test for recompilation. buildRecompile :: String -- ^ Module containing the @main@ function. -> [(String, String)] -- ^ List of @(SRC_FILE, DEST_FILE)@ for first run. -> [(String, String)] -- ^ List of @(SRC_FILE, DEST_FILE)@ for second run. -> String -- ^ Expected output from the first run. -> String -- ^ Expected output from the second run. -> FnkSpec buildRecompile main_mod files1 files2 before_str after_str = beforeAllWith (\ftr -> do dir <- mk_tmp_dir ("recompile_" ++ main_mod) return (dir, ftr)) (afterAll (rmdir . fst) work) where work = describe ("Recompile " ++ main_mod) $ it "should return expected result" $ \(tmpdir, ftr) -> do is_travis <- lookupEnv "TRAVIS" if isJust is_travis && os == "darwin" then pendingWith "not supported under Travis OSX" else if os == "mingw32" -- XXX: Recompile tests not working well under Windows, pending -- for now. then pendingWith "recompile tests pending under Windows" else do_work (tmpdir, ftr) do_work (tmpdir, ftr) = do -- Running with files1 twice to see compilation avoidance. compile_and_run tmpdir ftr False files1 before_str compile_and_run tmpdir ftr True files1 before_str -- When compiling with plugin, need to unload home unit modules from the -- global HscEnv used during macro expansion. Otherwise the required R01 -- module won't recompiled. clearGlobalSession compile_and_run tmpdir ftr False files2 after_str compile_and_run tmpdir ftr skip_copy files expected_str = do let a_dot_out = tmpdir "a.out" unless skip_copy $ copy_files tmpdir files buildWork ftr [] [ "-i" ++ tmpdir , "-outputdir", tmpdir , "-main-is", main_mod , "-o", a_dot_out , "--fnk-trace-make" , main_mod ] output1 <- readProcess a_dot_out [] "" output1 `shouldBe` expected_str clearGlobalSession :: IO () clearGlobalSession = runFnk clear (fnkTestEnv {envVerbosity = 1 ,envInvokedMode = GhcPluginMode}) where clear = withExpanderSettings $ do -- See also 'clearHPTs' in "ghc/GHCi/UI.hs". _ <- simpleMake [] False Nothing pure () copy_files :: MonadIO m => FilePath -> [(FilePath, FilePath)] -> m () copy_files dir fs = liftIO (mapM_ copy fs) where copy (i,o) = let src = odir i dst = dir o in copyFile src dst -- | Create temporary directory with given name. mk_tmp_dir :: String -> IO FilePath mk_tmp_dir name = do tmp <- getTemporaryDirectory let my_tmpdir = tmp name catch (removeDirectoryRecursive my_tmpdir) (\(SomeException _e) -> return ()) createDirectoryIfMissing True my_tmpdir return my_tmpdir -- | Remove given directory. rmdir :: FilePath -> IO () rmdir = removeDirectoryRecursive ================================================ FILE: finkel-kernel/test/Orphan.hs ================================================ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Orphan instance definitions for Form, for QuickCheck. module Orphan where #include "ghc_modules.h" -- ghc import GHC_Data_FastString (fsLit, unpackFS) import GHC_Types_SrcLoc (GenLocated (..), interactiveSrcSpan, mkSrcLoc, mkSrcSpan, noSrcSpan, wiredInSrcSpan) -- QuickCheck import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, arbitraryUnicodeChar, elements, getUnicodeString, listOf, oneof, scale, variant) -- Internal import Language.Finkel.Form instance Arbitrary Atom where -- XXX: Unicode symbols are not generated. arbitrary = oneof [ return AUnit , aSymbol <$> symbolG , AChar NoSourceText <$> arbitraryUnicodeChar , aString NoSourceText <$> stringG , aIntegral <$> (arbitrary :: Gen Integer) , aFractional <$> (arbitrary :: Gen Double) ] where headChars = ['A' .. 'Z'] ++ ['a' .. 'z'] ++ "_!$&*+./<=>?@^~:" tailChars = headChars ++ "0123456789'_" symbolG = (:) <$> elements headChars <*> listOf (elements tailChars) stringG = getUnicodeString <$> arbitrary instance CoArbitrary Atom where coarbitrary x = case x of AUnit -> var 0 ASymbol s -> var 1 . coarbitrary (unpackFS s) AChar _ c -> var 2 . coarbitrary c AString _ s -> var 3 . coarbitrary (unpackFS s) AInteger i -> var 4 . coarbitrary (il_value i) AFractional d -> var 5 . coarbitrary (fl_value d) where var :: Int -> Gen a -> Gen a var = variant instance Arbitrary a => Arbitrary (Form a) where arbitrary = oneof [Atom <$> arbitrary ,List <$> listOf (scale (`div` 3) arbitrary) ,HsList <$> listOf (scale (`div` 3) arbitrary)] shrink x = case x of Atom _ -> [] List xs -> map unCode xs ++ [List xs'|xs' <- shrink xs] HsList xs -> map unCode xs ++ [HsList xs'|xs' <- shrink xs] TEnd -> [] instance CoArbitrary a => CoArbitrary (Form a) where coarbitrary x = case x of Atom y -> var 0 . coarbitrary y List ys -> var 1 . coarbitrary ys HsList ys -> var 2 . coarbitrary ys TEnd -> var 3 where var :: Int -> Gen a -> Gen a var = variant instance Arbitrary a => Arbitrary (LForm a) where arbitrary = LForm <$> (L <$> aloc <*> arbitrary) where aloc = oneof [real, unhelpful] real = do file <- fsLit <$> arbitrary sl <- arbitrary sc <- arbitrary ec <- arbitrary let sloc = mkSrcLoc file sl sc eloc = mkSrcLoc file (sl + 1) ec pure (mkSrcSpan sloc eloc) unhelpful = oneof (map pure [noSrcSpan, wiredInSrcSpan, interactiveSrcSpan]) instance CoArbitrary a => CoArbitrary (LForm a) where coarbitrary (LForm (L _ form)) = coarbitrary form ================================================ FILE: finkel-kernel/test/PluginTest.hs ================================================ {-# LANGUAGE CPP #-} -- Module for testing the finkel plugin. module PluginTest (pluginTests) where #include "ghc_modules.h" -- base import Control.Monad (void) import System.Info (os) #if MIN_VERSION_ghc(9,6,0) || !MIN_VERSION_ghc(9,4,0) import Control.Exception (SomeException (..)) #endif -- filepath import System.Environment (getExecutablePath) import System.FilePath (()) -- ghc import GHC import GHC_Driver_Env (HscEnv (..)) -- hspec import Test.Hspec -- finkel-kernel import Language.Finkel.Fnk (getLibDirFromGhc) import Language.Finkel.Make (clearGlobalSession) import Language.Finkel.Plugin (plugin, setFinkelPluginWithArgs) -- Internal import TestAux -- ------------------------------------------------------------------------ -- -- Plugin tests -- -- ------------------------------------------------------------------------ pluginTests :: FnkSpec pluginTests = -- Clearing global session for macro expansion with `clearGlobalSession'. If -- not cleared, when this Plugin tests were ran after Make tests, nested -- required home modules (the test with p11.hs) will show a compilation error. beforeAll_ (removeArtifacts pdir >> clearGlobalSession) $ describe "run compiler as ghc plugin" $ do compile [] ["--verbose=3"] "p01.hs" compile [] [] "p02.hs" compile ["-optF", "--warn-interp=False"] ["--verbose=3"] "p03.hs" #if !MIN_VERSION_ghc(9,4,0) compile ["-optF", "--ignore"] ["--ignore"] "p04.hs" #endif compile ["-ddump-parsed-ast"] [] "p05.hs" compile ["-optF", "--warn-interp=False"] [] "p06.hs" compile [] [] "p08.hs" compile ["-v", "-optF", "--warn-interp=False"] ["--verbose=0"] "p09.hs" compile ["-v", "-optF", "--warn-interp=False"] ["--verbose=3"] "p09.hs" compile ["-v", "-optF", "--warn-interp=False"] ["--verbose=3"] "p10.hs" compile ["-v", "-optF", "--warn-interp=False"] ["--verbose=3"] "p11.hs" -- Failures compileWithFailedFlag [] [] "p07.hs" compileAndFail [] ["--help"] "p01.hs" compileAndFail [] ["--pragma"] "p01.hs" compile :: [String] -> [String] -> String -> FnkSpec compile ghc_args plugin_args basename = do let act io = do success_flag <- io succeeded success_flag `shouldBe` True pending_in_win = ["p03.hs", "p06.hs", "p09.hs", "p10.hs", "p11.hs"] if os == "mingw32" && basename `elem` pending_in_win then it ("should compile " ++ basename) $ \_ -> pendingWith "Windows not supported yet" else compile' "successfully" act ghc_args plugin_args basename compileWithFailedFlag :: [String] -> [String] -> String -> FnkSpec compileWithFailedFlag = compile' "fail to" (\io -> do success_flag <- io succeeded success_flag `shouldBe` False) compileAndFail :: [String] -> [String] -> String -> FnkSpec compileAndFail = #if MIN_VERSION_ghc(9,6,0) || !MIN_VERSION_ghc(9,4,0) compile' "fail to" (\io -> io `shouldThrow` \(SomeException _) -> True) #else compileWithFailedFlag #endif -- Compile source code file. The test executable can act as preprocessor, used -- to compile Finkel source codes. compile' :: String -> (IO SuccessFlag -> IO ()) -> [String] -> [String] -> String -> FnkSpec compile' msg wrap ghc_args plugin_args basename = let title = "compile " ++ basename ++ ", ghc args: " ++ show ghc_args ++ ", plugin args: " ++ show plugin_args in describe title $ do it ("should " ++ msg ++ " compile " ++ basename) $ \ftr -> do libdir <- getLibDirFromGhc _me <- getExecutablePath let act = quietly $ runGhc (Just libdir) $ do hsc_env1 <- getSession let dflags0 = hsc_dflags hsc_env1 fnk_args = ["-F", "-pgmF", _me, "-i" ++ pdir] args = map noLoc (ftr_pkg_args ftr ++ fnk_args ++ ghc_args) #if MIN_VERSION_ghc(9,2,0) logger <- getLogger (dflags1, _, _) <- parseDynamicFlags logger dflags0 args #else (dflags1, _, _) <- parseDynamicFlags dflags0 args #endif void (setSessionDynFlags dflags1) setFinkelPluginWithArgs plugin plugin_args #if MIN_VERSION_ghc(9,4,0) t <- guessTarget (pdir basename) Nothing Nothing #else t <- guessTarget (pdir basename) Nothing #endif setTargets [t] load LoadAllTargets wrap act pdir :: FilePath pdir = "test" "data" "plugin" ================================================ FILE: finkel-kernel/test/PreprocessTest.hs ================================================ module PreprocessTest where -- base import Control.Exception (SomeException (..), bracket) import Data.List (intercalate) import System.Environment (withArgs) import System.Exit (ExitCode (..)) -- directory import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, removeDirectoryRecursive) -- filepath import System.FilePath (takeDirectory, ()) -- hspec import Test.Hspec -- finkel-kernel import Language.Finkel.Preprocess (defaultPreprocess) -- Internal import TestAux -- ------------------------------------------------------------------------ -- -- Preprocessor tests -- -- ------------------------------------------------------------------------ preprocessTests :: Spec preprocessTests = around withTemporaryFile $ describe "preprocess" $ do let ul = intercalate "\n" pp args = quietly (withArgs args defaultPreprocess) anyExitFailure e = case e of ExitFailure _ -> True _ -> False it "should show help message" $ const (pp ["--help"]) it "should show result to stdout" $ const (pp ["--verbose=3", pdir "fnk01.hs"]) it "should write out to file" $ \opath -> pp [pdir "fnk01.hs", opath] it "should fail when no files were specified" $ const (pp [] `shouldThrow` anyExitFailure) it "should fail when no arg were passed to pragma option" $ const (pp ["fnk01.hs", "--pragma"] `shouldThrow` anyExitFailure) -- Finkel source code -- Parsing plugin01.hs, header only. doPreprocess ["--verbose=3"] "fnk01.hs" "module Main where\n\n" -- Parsing plugin01.hs, full module. doPreprocess ["--full", "--warn-interp"] "fnk01.hs" (ul [ "module Main where" , "main :: IO ()" , "main = putStrLn \"preprocess/fnk01.hs\"" , "\n" ]) doPreprocess ["--warn-interp=False"] "fnk02.hs" "module Main where\n\n" doPreprocess [] "fnk03.hs" "\n" -- empty contents doPreprocess [] "fnk04.hs" (ul [ "module Main (" , " foo, main" , " ) where" , "import Data.Maybe ( fromMaybe )" , "import qualified Control.Monad as M" , "\n" ]) doPreprocess ["--pragma=DEADBEEF"] "fnk05.hs" (ul [ "module Main where" , "import Control.Monad" , "\n" ]) doPreprocess ["--warn-interp=False"] "fnk06.hs" "module Main where\n\n" -- Haskell source code doPreprocess ["--verbose=3"] "hs01.hs" (ul [ "module Main where" , "" , "main :: IO ()" , "main = putStrLn \"preprocess/hs01.hs\"\n" ]) doPreprocess ["--ignore"] "hs02.hs" (ul [ "-- Haskell code containing \";;;\" in the first line." , "" , "module Main where" , "" , "main :: IO ()" , "main = putStrLn \"preprocess/hs02.hs\"\n" ]) -- Finkel source code containing `defmodule' doPreprocess [] "fnk11.hs" "module Main where\n\n" doPreprocess [] "fnk12.hs" (ul [ "module Main where" , "import Control.Monad ( forM_, when )" , "import qualified Data.ByteString as BS" , "import Data.Maybe hiding ( fromJust )" , "import Control.Applicative ( liftA3 )" , "\n" ]) doPreprocess [] "fnk13.hs" "module Main where\n\n" -- Failures doPreprocessAndFail ["--verbose=max"] "fnk01.hs" doPreprocessAndFail ["--warn-interp=3"] "fnk01.hs" doPreprocessAndFail [] "fnk14.hs" doPreprocessAndFail [] "fnk15.hs" doPreprocess :: [String] -> String -> String -> SpecWith FilePath doPreprocess extra_args basename expected = it ("should parse module header of " ++ basename) $ \opath -> do let ipath = pdir basename path_args = [ipath, ipath, opath] args = path_args ++ extra_args withArgs args (quietly defaultPreprocess) contents <- readFile opath contents `shouldBe` expected doPreprocessAndFail :: [String] -> String -> SpecWith FilePath doPreprocessAndFail extra_args basename = it ("should preprocess and fail with " ++ basename) $ \opath -> do let ipath = pdir basename path_args = [ipath, ipath, opath] args = path_args ++ extra_args withArgs args (quietly defaultPreprocess) `shouldThrow` (\(SomeException _) -> True) withTemporaryFile :: (FilePath -> IO a) -> IO a withTemporaryFile = bracket acquire cleanup where acquire = do tmp_dir <- getTemporaryDirectory let dir = tmp_dir "preprocess" file = dir "tmp.hs" createDirectoryIfMissing True dir pure file cleanup = removeDirectoryRecursive . takeDirectory pdir :: FilePath pdir = "test" "data" "preprocess" ================================================ FILE: finkel-kernel/test/SyntaxTest.hs ================================================ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} -- | Tests for syntax. -- -- All files under "test/data" directory with '.fnk' extension (i.e.: -- "test/data/*.fnk") are read and compiled, then type checked. -- module SyntaxTest ( syntaxTests , syntaxFnkTests ) where #include "ghc_modules.h" -- base import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO (..)) import Data.IORef (atomicWriteIORef, newIORef, readIORef) import Data.Maybe (fromMaybe) import GHC.Exts (unsafeCoerce#) import System.Environment (getExecutablePath) import System.Info (os) import System.IO (BufferMode (..), hSetBuffering, stdout) -- directory import System.Directory (createDirectoryIfMissing, doesFileExist, getTemporaryDirectory, removeFile) -- filepath import System.FilePath (takeBaseName, (<.>), ()) -- ghc import GHC (setContext, setTargets) import GHC_Data_StringBuffer (stringToStringBuffer) import GHC_Driver_Monad (GhcMonad (..)) import GHC_Settings_Config (cProjectVersionInt) import GHC_Types_Basic (SuccessFlag (..)) import GHC_Types_Target (Target (..), TargetId (..)) #if MIN_VERSION_ghc(9,4,0) import GHC.Driver.Env (hscActiveUnitId) #endif -- hspec import Test.Hspec -- silently import System.IO.Silently (capture_) -- finkel-kernel import Language.Finkel.Eval (evalExpr) import Language.Finkel.Fnk (Fnk, prepareInterpreter, runFnk) import Language.Finkel.Plugin (plugin, setFinkelPluginWithArgs) import Language.Finkel.Syntax (parseExpr) -- Internal import TestAux syntaxTests :: Spec syntaxTests = beforeAll getFnkTestResource syntaxFnkTests syntaxFnkTests :: FnkSpec syntaxFnkTests = runIO (getTestHsFiles "syntax") >>= mapM_ mkTest mkTest :: FilePath -> FnkSpec mkTest path | os == "mingw32" , base_name `elem` ["0002-lexical", "0004-decls", "1001-quote"] = describe path (it "is pending under Windows" (const (pendingWith "Unicode not supported yet"))) | cProjectVersionInt == "810" , os == "mingw32" , base_name `elem` ["1002-macro", "1003-eval-when-compile"] = describe path (it "is pending with ghc-8.10.1 under Windows" (const (pendingWith "Macro expansion not yet supported"))) | base_name == "0003-expressions-2" , ghcVersion < 900 = describe path (it "is pending under ghc < 9.0" (const (pendingWith "Generated Haskell code not working"))) | base_name `elem` ["1004-doccomment-03", "2005-gadts-02"] , ghcVersion >= 904 = describe path (it "is pending under ghc >= 9.4" (const (pendingWith "Warns with unusable UNPACK"))) | base_name == "0003-expressions-3" , ghcVersion >= 910 = describe path (it "is not supported in ghc >= 9.10" (const (pendingWith "`forall' is keyword by default"))) | base_name == "2028-standalonekind" , ghcVersion < 810 = describe path (it "is not supported in ghc < 8.10.1" (const (pendingWith "Not supported"))) | base_name == "2029-impredicative" , ghcVersion < 902 = describe path (it "is not reliable in ghc < 9.2" (const (pendingWith "Not supported"))) | otherwise = mkTest' path where base_name = takeBaseName path ghcVersion :: Int ghcVersion = __GLASGOW_HASKELL__ optsToSuppressWarnings :: [(String, [String])] optsToSuppressWarnings = let flag test opt = if test then [opt] else [] no_forall_identifier = flag (ghcVersion >= 904) "-Wno-forall-identifier" no_star_is_type = flag (ghcVersion >= 906) "-Wno-star-is-type" no_deprecated = flag (ghcVersion >= 906) "-Wno-deprecated-flags" in [ ("0003-expressions-3", no_forall_identifier) , ("2010-kindsig", no_star_is_type) , ("2015-typefam", no_star_is_type) -- TypeInType is deprecated in ghc >= 9.6 , ("2017-polykinds", no_deprecated) ] mkTest' :: FilePath -> FnkSpec mkTest' path = do let mkRef = runIO . newIORef . error removeWhenExist file = do exist <- doesFileExist file when exist (removeFile file) tmpdir <- runIO getTemporaryDirectory fnkORef <- mkRef "fnkORef" hsORef <- mkRef "hsORef" let odir = tmpdir "fnk_mk_test" aDotOut = odir "a.out" dotHs = odir takeBaseName path <.> "hs" dotTix = "a.out.tix" syndir = "test" "data" "syntax" prepare = do removeArtifacts syndir mapM_ removeWhenExist [dotTix, aDotOut, dotHs] toNativeCompile = takeBaseName path == "0008-ffi" extra_opts = fromMaybe [] (lookup (takeBaseName path) optsToSuppressWarnings) compile = if toNativeCompile then nativeCompile extra_opts else byteCompile extra_opts runIO (do createDirectoryIfMissing True odir hSetBuffering stdout NoBuffering) beforeAll_ prepare $ describe path $ do it "should compile Finkel code" $ \ftr -> do io <- runFnk (compile ftr path (Just odir)) fnkTestEnv unless toNativeCompile $ do capture_ io >>= atomicWriteIORef fnkORef it "should dump Haskell source" $ \_ -> do exist <- doesFileExist dotHs exist `shouldBe` True it "should compile dumped Haskell code" $ \ftr -> do io <- runFnk (compile ftr dotHs Nothing) fnkTestEnv unless toNativeCompile $ capture_ io >>= atomicWriteIORef hsORef it "should have same output" $ \_ -> do unless toNativeCompile $ do fnk <- readIORef fnkORef hs <- readIORef hsORef fnk `shouldBe` hs nativeCompile :: [String] -> FnkTestResource -> FilePath -> Maybe FilePath -> Fnk (IO ()) nativeCompile = compileWith False byteCompile :: [String] -> FnkTestResource -> FilePath -> Maybe FilePath -> Fnk (IO ()) byteCompile opts = compileWith True (["-no-link", "-fbyte-code"] ++ opts) compileWith :: Bool -> [String] -> FnkTestResource -> FilePath -> Maybe FilePath -> Fnk (IO ()) compileWith is_interpreting ini_args ftr file mb_dir = do parseAndSetDynFlags ini_args ftr_init ftr when is_interpreting prepareInterpreter let plugin_opts = maybe [] (\d -> ["--hsdir=" <> d]) mb_dir me <- liftIO getExecutablePath parseAndSetDynFlags ["-v0", "-F", "-pgmF", me, "-optF", "--no-warn-interp"] setFinkelPluginWithArgs plugin plugin_opts _hsc_env <- getSession let target = Target { targetId = TargetFile file Nothing , targetAllowObjCode = not is_interpreting #if MIN_VERSION_ghc(9,4,0) , targetUnitId = hscActiveUnitId _hsc_env #endif , targetContents = Nothing } setTargets [target] success_flag <- ftr_load ftr [file] case success_flag of Failed -> error $ "Failed to compile: " ++ file Succeeded -> if is_interpreting then do -- Flush the stdout used by the compiled expression to get the string -- output, which is captured later. setContext [mkIIDecl "Main", mkIIDecl "System.IO"] let act = fmap unsafeCoerce# . evalExpr buf = stringToStringBuffer "(>> main (hFlush stdout))" evalWith (file ++ ":main") parseExpr act buf else return (return ()) ================================================ FILE: finkel-kernel/test/TestAux.hs ================================================ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} -- | Miscellaneous auxiliary codes for tests. module TestAux ( FnkSpec , FnkTestResource(..) , getFnkTestResource , initSessionForTest , evalWith , mkIIDecl , parseAndSetDynFlags , removeArtifacts , fnkTestEnv , getTestFiles , getTestHsFiles , beforeAllWith , quietly ) where #include "ghc_modules.h" -- base import Control.Exception (catch, fromException, throw, throwIO) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (..)) import Data.List (isSubsequenceOf, sort) import Data.Maybe (fromMaybe) import Data.Version (showVersion) import System.Environment (getExecutablePath, lookupEnv, withArgs) import System.Exit (ExitCode (..)) import System.IO (stderr, stdout) #if !MIN_VERSION_hspec(2,7,6) import Control.Concurrent (MVar, modifyMVar, newMVar) import Control.Exception (SomeException, try) #endif -- directory import System.Directory (doesFileExist, getDirectoryContents, removeFile) -- filepath import System.FilePath (joinPath, takeExtension, (<.>), ()) -- ghc import GHC (setContext) import GHC_Data_FastString (fsLit) import GHC_Data_StringBuffer (StringBuffer) import GHC_Driver_Session (DynFlags (..), HasDynFlags (..), parseDynamicFlagsCmdLine) import GHC_Hs_ImpExp (simpleImportDecl) import GHC_Runtime_Context (InteractiveImport (..)) import GHC_Runtime_Eval (getContext) import GHC_Types_Basic (SuccessFlag) import GHC_Types_SrcLoc (noLoc) import GHC_Unit_Module (mkModuleNameFS) -- hspec import Test.Hspec (SpecWith) #if MIN_VERSION_hspec(2,7,6) import Test.Hspec (beforeAllWith) #else import Test.Hspec (beforeWith, runIO) #endif -- process import System.Process (readProcess) -- silently import System.IO.Silently (hSilence) -- fnk-kernel import Language.Finkel (defaultFnkEnv) import Language.Finkel.Builder (Builder) import Language.Finkel.Expand (expands) import Language.Finkel.Fnk (Fnk, FnkEnv (..), setDynFlags) import Language.Finkel.Lexer (evalSP) import Language.Finkel.Main (defaultMain) import Language.Finkel.Make (buildHsSyn, initSessionForMake, simpleMake, withExpanderSettings) import Language.Finkel.Reader (sexprs) import qualified Paths_finkel_kernel -- ----------------------------------------------------------------------- -- -- Configured values from setup script -- -- ----------------------------------------------------------------------- #include "finkel_kernel_config.h" distpref :: FilePath #ifdef FINKEL_KERNEL_CONFIG_DISTPREF distpref = FINKEL_KERNEL_CONFIG_DISTPREF #else distpref = error "FINKEL_KERNEL_CONFIG_DISTPREF not defined" #endif -- ----------------------------------------------------------------------- -- -- Auxiliary functions -- -- ----------------------------------------------------------------------- -- | Type synonym for hspec test taking 'FnkTestResource'. type FnkSpec = SpecWith FnkTestResource -- | Test resource for finkel-kernel package tests. data FnkTestResource = FnkTestResource { ftr_main :: [String] -> IO () -- ^ Function to run 'defaultMain'. , ftr_init :: Fnk () -- ^ Initialization action inside 'Fnk'. , ftr_load :: [FilePath] -> Fnk SuccessFlag -- ^ Function to load a module. -- , ftr_eval :: forall a b. String -> Builder a -> (a -> Fnk b) -- -> StringBuffer -> Fnk b -- -- ^ Function to evaluate an expression string, returns a string -- -- representation of evaluated result. , ftr_pkg_args :: [String] -- ^ Arguments for package. } getFnkTestResource :: IO FnkTestResource getFnkTestResource = do pkg_args <- getPackageArgs return (FnkTestResource { ftr_main = makeMain pkg_args , ftr_init = makeInit pkg_args , ftr_load = makeLoad , ftr_pkg_args = pkg_args }) makeMain :: [String] -> [String] -> IO () makeMain pkg_args other_args = catch (withArgs (pkg_args ++ other_args) (quietly defaultMain)) (\e -> case fromException e of Just ExitSuccess -> return () _ -> throw e) -- XXX: Ignoring all messages, including messages for reporting error. -- Might be better to implement an option to redirect log outputs. quietly :: IO a -> IO a quietly = hSilence [stderr, stdout] makeInit :: [String] -> Fnk () makeInit pkg_args = resetPackageEnv pkg_args >> initSessionForMake getPackageArgs :: IO [String] getPackageArgs = -- To support running the test without building the package, using the package -- db found in "package.conf.inplace" directory for inplace package db. -- -- There is a "dist-newstyle/packagedb" directory for holding package data of -- project local packages, but the package db file will be written only after -- running the "cabal v2-build" command once, which means that running "cabal -- v2-test" will fail if "v2-build" were not invoked in advance. -- -- The "inpkacepkgconf" is to support cabal-install v2-build, which uses -- "PKGNAME-X.Y.Z-inplace" format for inplace package. do let inplacedb = joinPath [distpref, "package.conf.inplace"] fkv = showVersion Paths_finkel_kernel.version inplacepkg = "finkel-kernel-" ++ fkv ++ "-inplace" inplacepkgconf = inplacedb inplacepkg <.> "conf" has_inplacepkgconf <- doesFileExist inplacepkgconf snapshotdb <- getSnapshotDb let inplacedbs = if has_inplacepkgconf then [ "-package-db", inplacedb , "-package-id", inplacepkg ] else [ "-package-db", inplacedb ] args = [ "-clear-package-db" , "-global-package-db" -- For overloaded label test which imports `GHC.Types' module. , "-package", "ghc-prim" ] ++ inplacedbs ++ snapshotdb return args -- Note: [Snapthos package database for stack] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- In ghc 9.0.1, the "exceptions" package has been added to the bundled packages -- shipped with ghc, to make "Ghc" monad as an instance of the type classes -- defined in "Control.Monad.Catch". Finkel followed this change and made "Fnk" -- as an instance of the type classes defined in "Control.Monad.Catch", and back -- ported the change. When running the stack with ghc version prior to 9.0.1, -- the "exceptions" package is installed in non-bundled package database. Thus, -- getting the snapshot package database with "stack path -- --snapshot-pkg-db". getSnapshotDb :: IO [String] getSnapshotDb = do me <- getExecutablePath let is_stack = ".stack" `isSubsequenceOf` me if is_stack then do mb_resolver <- lookupEnv "RESOLVER" let resolver = fromMaybe "lts-16" mb_resolver ret <- readProcess "stack" ["--resolver=" ++ resolver ,"path", "--snapshot-pkg-db"] "" let snapshot_db = filter (not . null) (lines ret) return ("-package-db" : snapshot_db) else return [] -- | Reset package environment to support running the test with cabal-install. resetPackageEnv :: [String] -> Fnk () resetPackageEnv pkg_args = do dflags0 <- getDynFlags let largs = map noLoc pkg_args dflags1 = clearPackageEnv dflags0 (dflags2, _, _) <- parseDynamicFlagsCmdLine dflags1 largs setDynFlags dflags2 -- | Clear 'packageEnv' field in 'DynFlags'. clearPackageEnv :: DynFlags -> DynFlags -- Use of "-" to reset package env is NOT supported until 8.4.4. clearPackageEnv dflags = dflags {packageEnv = Just "-"} parseAndSetDynFlags :: [String] -> Fnk () parseAndSetDynFlags args = do dflags0 <- getDynFlags (dflags1,_,_) <- parseDynamicFlagsCmdLine dflags0 (map noLoc args) setDynFlags dflags1 makeLoad :: [FilePath] -> Fnk SuccessFlag makeLoad files = simpleMake (map (\p -> (noLoc p, Nothing)) files) False Nothing evalWith :: String -> Builder a -> (a -> Fnk b) -> StringBuffer -> Fnk b evalWith !label !parser !act !input = do case evalSP sexprs (Just label) input of Right form0 -> do !form1 <- withExpanderSettings (prepare >> expands form0) !hthing <- buildHsSyn parser form1 act hthing Left err -> liftIO (throwIO err) where -- Adding 'Prelude' and 'Language.Finkel' to interactive context, since the -- codes in the file does not contain ':require' forms. prepare = do ctxt <- getContext setContext (mkIIDecl "Prelude" : mkIIDecl "Language.Finkel" : ctxt) -- mkII = IIDecl . simpleImportDecl . mkModuleNameFS . fsLit mkIIDecl :: String -> InteractiveImport mkIIDecl = IIDecl . simpleImportDecl . mkModuleNameFS . fsLit -- | Reset package env and initialize session with 'initSessionForMake'. initSessionForTest :: Fnk () initSessionForTest = liftIO getPackageArgs >>= makeInit -- | Remove compiled artifacts, such as @.o@ and @.hi@ files. removeArtifacts :: FilePath -> IO () removeArtifacts dir = do contents <- getDirectoryContents dir mapM_ removeObjAndHi contents where removeObjAndHi file = when (takeExtension file `elem` [ ".o", ".hi" , ".p_o", ".p_hi" , ".dyn_o", ".dyn_hi" , ".hscpp" ]) (removeFile (dir file)) -- | The 'FnkEnv' used for test. Has 'envLibDir' field from CPP header file. fnkTestEnv :: FnkEnv fnkTestEnv = defaultFnkEnv {envLibDir = Just FINKEL_KERNEL_LIBDIR} -- | Get files with @.fnk@ extension under test data directory. getTestFiles :: String -- ^ Name of the sub directory under test data directory. -> IO [FilePath] getTestFiles = getTestFilesBy ".fnk" -- | Get files with @.hs@ extension under test data directory. getTestHsFiles :: String -> IO [FilePath] getTestHsFiles = getTestFilesBy ".hs" getTestFilesBy :: String -- ^ File extension of interest. -> String -- ^ Name of the sub directory under test data directory. -> IO [FilePath] getTestFilesBy ext name = let dir = "test" "data" name f x acc = if takeExtension x == ext then (dir x) : acc else acc files = getDirectoryContents dir in sort . foldr f [] <$> files #if !MIN_VERSION_hspec(2,7,6) -- "Test.Hspec.Core.Hooks.beforeAllWith" did not exist. beforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b beforeAllWith action spec = do mvar <- runIO (newMVar Nothing) beforeWith (memoize mvar . action) spec memoize :: MVar (Maybe a) -> IO a -> IO a memoize mvar action = do et_result <- modifyMVar mvar $ \mb_val -> do case mb_val of Nothing -> do et_val <- try @ SomeException action case et_val of Left err -> return (Nothing, Left err) Right val -> return (Just val, Right val) Just val -> return (Just val, Right val) either throwIO return et_result #endif ================================================ FILE: finkel-kernel/test/data/eval/0001-simple.fnk ================================================ ;;;; -*- mode: finkel -*- (let ((:: x y Code) (= x '(a b c)) (= y '(foo a b c)) (:: cdr (-> Code Code)) (= cdr (LForm (L l (List (: _ rest)))) (LForm (L l (List rest)))) (:: fib (-> Int Int)) (= fib n (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))) (all id [(== 'foo 'foo) (== x (cdr y)) (== (fib 10) 55)])) ================================================ FILE: finkel-kernel/test/data/eval/0002-shadowing-macro.fnk ================================================ ;;;; -*- mode: finkel -*- ;;; Expression to test name shadowing with conflictinging names bounded ;;; to macro with `with-macro' and locally declared function with `let'. (:with-macro ((= foo (Macro (\form (case form (LForm (L _ (List [_ body]))) (return `(++ "with-macro: " ,body)) _ (error (++ "foo: got `" (show form) "'"))))))) (all id [(== (foo "bar") "with-macro: bar") ;; Bind `foo' to locally declared function. (== (let ((= foo body (++ "let: " body))) (foo "bar")) "let: bar") ;; The macro `foo' is still in current scope. (== (foo "bar") "with-macro: bar") ;; Bind `foo' with pattern matching. (== (let ((= (: foo _) ["local let" "local bar" "local buzz"])) foo) "local let") (== (let ((= (@ bar (Just foo)) (return "let: bar"))) foo) "let: bar") (== (let ((= (@ foo (Just bar)) (return "let: bar"))) foo) (Just "let: bar")) (== (let ((= [foo _ _] ["let: bar" "" ""])) foo) "let: bar") ;; Bind `foo' to function binding argument. (== (let ((= f1 foo (foo "bar"))) (f1 (++ "let: "))) "let: bar") ;; Bind `foo' to lambda argument. (== (let ((= f2 (\foo (foo "bar")))) (f2 (++ "let: "))) "let: bar") ;; Bind `foo' in do-notation. (== (do (<- foo (return (\x (Just (++ "do: " x))))) (foo "bar")) (Just "do: bar")) ;; Bind `foo' in do-notation after using `foo'. The first use ;; of `foo' is from `with-macro', and the second use is ;; locally bounded function. (== (do (<- x (return (foo "bar"))) (<- foo (return (\x (++ "do: " x)))) (return (, x (foo "buzz")))) (Just (, "with-macro: bar" "do: buzz"))) ;; Pattern match in `case' expression (== (case (Just (++ "let: ")) (Just foo) (foo "bar")) "let: bar") (== (case (Just (++ "let: ")) (Just foo) (where bar (= bar (foo "bar")))) "let: bar") ;; Shadowing with `where' (== (case () _ (where (foo "bar") (= foo (++ "let: ")))) "let: bar") (== (case () _ (where (bar "bar") (= bar foo (++ "let: " foo)))) "let: bar")])) ================================================ FILE: finkel-kernel/test/data/eval/0003-expand1.fnk ================================================ (:with-macro ((= foo (Macro (\ (LForm (L _ (List [_ x]))) (return `(do (print ,x) (print ,x)))))) (= mex1 (Macro (\ (LForm (L _ (List [_ x]))) (do (<- expanded (expand1 x)) (return `',expanded)))))) (== (mex1 (foo "bar")) '(do (print "bar") (print "bar")))) ================================================ FILE: finkel-kernel/test/data/eval/0004-unquote-unquote-splice.fnk ================================================ ;;;; -*- mode: finkel -*- ;;; Expression containing ",,@(...)". (:with-macro ((= m1 (Macro (const (return `(let ((= foo #'a) (= bar 'v1) (= buzz 'v2)) `(let (,,@(map (\n ``(= ,,n #'b)) ['bar 'buzz])) [,foo ,bar ,buzz]))))))) (== (m1) '(let ((= v1 #'b) (= v2 #'b)) [#'a v1 v2]))) ================================================ FILE: finkel-kernel/test/data/exception/0001-invalid-unquote-splice.hs ================================================ (:eval-when-compile (import Prelude) (import Language.Finkel) (import Control.Monad.IO.Class (liftIO)) (:: m Macro) (= m (Macro (\ (LForm (L _ (List [_ arg1]))) (return `(:a 1 :b ,@arg1)))))) (:: main (IO ())) (= main (print (m foo))) ================================================ FILE: finkel-kernel/test/data/exception/0002-invalid-string-literal.hs ================================================ (= main (print "foo)) ================================================ FILE: finkel-kernel/test/data/exception/0003-malformed-qq.hs ================================================ (:: main (IO ())) (= main (print (:quasiquote foo bar buzz))) ================================================ FILE: finkel-kernel/test/data/main/MyMain.hs ================================================ ;;; -*- mode: finkel -*- (module MyMain) (:: my-main (IO ())) (= my-main (putStrLn "From MyMain.my-main")) ================================================ FILE: finkel-kernel/test/data/main/m001.hs ================================================ ;;; -*- mode: finkel -*- (= main (putStrLn "Hello, world!")) ================================================ FILE: finkel-kernel/test/data/main/m002.hs ================================================ main = putStrLn "Hello, world!" ================================================ FILE: finkel-kernel/test/data/main/m003.c ================================================ #include void hello() { printf("Hello, world!\n"); } ================================================ FILE: finkel-kernel/test/data/make/E01.hs ================================================ (module ModuleNameMismatch foo bar buzz) (:: foo bar buzz Int) (= foo 1) (= bar 2) (= buzz 3) ================================================ FILE: finkel-kernel/test/data/make/E02.hs ================================================ (module Main) (import NoSuchModule) (:: foo Int) (= foo 42) ================================================ FILE: finkel-kernel/test/data/make/M1.hs ================================================ ;;; -*- mode: finkel -*- (module M1) (:: main (IO ())) (= main (putStrLn "From M1.main")) ================================================ FILE: finkel-kernel/test/data/make/M2.hs ================================================ module M2 where import Data.List import qualified M1 main :: IO () main = do M1.main putStrLn (concat (intersperse " " ["From", "M2.main"])) ================================================ FILE: finkel-kernel/test/data/make/M3.hs ================================================ ;;; -*- mode: finkel -*- (module M3 greet (Greet ..) (Greetable ..)) (import Language.Finkel) (newtype (Greet a) (Greet a)) (class (Greetable a) (:: gg (-> a String))) (:: greet Macro) (= greet (Macro (\form (case (unCode form) (List [_ body]) (return `(putStrLn ,body)) _ (finkelSrcError form "greet: malformed body"))))) ================================================ FILE: finkel-kernel/test/data/make/M4/A.hs ================================================ ;;; -*- mode: finkel -*- (module M4.A m4a) (:: m4a Int) (= m4a 4) ================================================ FILE: finkel-kernel/test/data/make/M4/B.hs ================================================ ;;; -*- mode: finkel -*- (module M4.B) (:: m4b String) (= m4b "m4b") ================================================ FILE: finkel-kernel/test/data/make/M4.hs ================================================ ;;; -*- mode: finkel -*- (module M4 m4 m4a m4b) (import M4.A) (import M4.B) (:: m4 (IO ())) (= m4 (putStrLn (++ "M4.m4: m4a=" (show m4a) ", m4b=" (show m4b)))) ================================================ FILE: finkel-kernel/test/data/make/M5.hs ================================================ ;;; -*- mode: finkel -*- (module M5 m5) (import M4) (:: m5 (IO ())) (= m5 (putStrLn (++ "From M5.m5: m4b=" m4b))) ================================================ FILE: finkel-kernel/test/data/make/M6/A.hs ================================================ ;;; -*- mode: finkel -*- (module M6.A m6a1 m6a2) (import Language.Finkel) (:: m6a1 Macro) (= m6a1 (Macro (\form (case (unCode form) (List [_]) (return `(putStrLn "From M6.A.m6a1")) _ (error "m6a1"))))) (:: m6a2 Macro) (= m6a2 (Macro (\form (case (unCode form) (List [_]) (return `(putStrLn "From M6.A.m6a2")) _ (error "m6a2"))))) ================================================ FILE: finkel-kernel/test/data/make/M6/B.hs ================================================ ;;; -*- mode: finkel -*- (module M6.B m6b1 m6b2) (import Language.Finkel) (:: m6b1 Macro) (= m6b1 (Macro (\form (case (unCode form) (List [_]) (return `(putStrLn "From M6.B.m6b1")) _ (error "m6b1"))))) (:: m6b2 Macro) (= m6b2 (Macro (\form (case (unCode form) (List [_]) (return `(putStrLn "From M6.B.m6b2")) _ (error "m6b2"))))) ================================================ FILE: finkel-kernel/test/data/make/P1.hs ================================================ ;;; -*- mode: finkel -*- %p(LANGUAGE DeriveDataTypeable DeriveGeneric OverloadedStrings) (module P1 (D ..) define-macro) (import Language.Finkel) (import Data.Data) (import GHC.Generics ((Generic ..))) (data D D1 D2 D3 (deriving Bounded Enum Eq Ord Show Read Data Typeable Generic)) (instance (Homoiconic D)) (:: dmac (-> Code (Fnk Code))) (= dmac form (let ((:: make-tsig (-> Code Code)) (= make-tsig name `(:: ,name Macro)) (:: macro-decl (-> Code Code Code (Fnk Code))) (= macro-decl name arg body (do (<- tmp (gensym' (show name))) (return `(= ,name (let ((:: ,tmp (-> Code (Fnk Code))) (= ,tmp ,arg ,body)) (Macro ,tmp))))))) (case (unCode form) (List [_ name arg body]) (do (<- decl (macro-decl name arg body)) (return `(:begin ,(make-tsig name) ,decl))) (List [_ name (@ doc (LForm (L _ (Atom (AString {}))))) arg body]) (do (<- decl (macro-decl name arg body)) (return `(:begin ,(make-tsig name) (:doc^ ,doc) ,decl))) _ (finkelSrcError form (++ "dmac: malformed macro: " (show form)))))) %p(INLINABLE dmac) (:: define-macro Macro) (= define-macro (Macro dmac)) ================================================ FILE: finkel-kernel/test/data/make/P2.hs ================================================ ;;; -*- mode: finkel -*- (:require P1) (module P2) (:eval-when-compile (import Prelude) (import Language.Finkel)) (import Language.Finkel) (import P1) (:eval-when-compile (define-macro define-foo form (case (unCode form) (List [_ name]) (return `(define-macro ,name _args (return '(putStrLn "foo")))) _ (finkelSrcError form "define-foo: error"))) (:: show-d-fn (-> D Code)) (= show-d-fn d `(show ,d)) (define-macro show-d form (case (unCode form) (List [_ o]) (| ((<- (Just d) (fromCode o)) (return `(,(show-d-fn d)))) (otherwise (finkelSrcError form (++ "say-d: cannot get D from `" (show o) "'")))) _ (finkelSrcError form "say-d: error")))) (define-foo foo) (:: print-d (-> D (IO ()))) (= print-d d (putStrLn (show-d D2))) ================================================ FILE: finkel-kernel/test/data/make/P3.hs ================================================ ;;; -*- mode: finkel -*- (:require P1) (module P3) (:eval-when-compile (import Prelude) (import Language.Finkel)) (import Language.Finkel) (:eval-when-compile (define-macro define-bar form (case (unCode form) (List [_ name]) (return `(define-macro ,name _ (return '(return "bar from define-bar"))))))) (define-bar bar) ================================================ FILE: finkel-kernel/test/data/make/R01.hs.1 ================================================ ;;;; -*- mode: finkel -*- (module R01) (import Language.Finkel) (:: foo-function String) (= foo-function "foo: before") (:: foo-macro Macro) (= foo-macro (Macro (const (return (toCode foo-function))))) ================================================ FILE: finkel-kernel/test/data/make/R01.hs.2 ================================================ ;;;; -*- mode: finkel -*- (module R01) (import Language.Finkel) (:: foo-function String) (= foo-function "foo: after") (:: foo-macro Macro) (= foo-macro (Macro (const (return (toCode foo-function))))) ================================================ FILE: finkel-kernel/test/data/make/R02.hs ================================================ ;;; -*- mode: finkel -*- (module R02) (import R01) (:: foo String) (= foo foo-function) ================================================ FILE: finkel-kernel/test/data/make/R03.hs ================================================ ;;; -*- mode: finkel -*- (:require R01) (module R03) (:: foo String) (= foo (foo-macro)) ================================================ FILE: finkel-kernel/test/data/make/R04.hs ================================================ ;;; -*- mode: finkel -*- (:require R01) (module R04) (:: foo String) (= foo (foo-macro)) (:: main (IO ())) (= main (putStrLn (foo-macro))) ================================================ FILE: finkel-kernel/test/data/make/R05.hs ================================================ ;;; -*- mode: finkel -*- (:require R05a) (module R05) (:: main (IO ())) (= main (putStrLn (r05a))) ================================================ FILE: finkel-kernel/test/data/make/R05a.hs ================================================ ;;; -*- mode: finkel -*- (module R05a) (import Language.Finkel) (import R01) (:: r05a Macro) (= r05a (Macro (const (return (toCode foo-function))))) ================================================ FILE: finkel-kernel/test/data/make/R06.hs ================================================ ;;; -*- mode: finkel -*- (:require R06a) (module R06) (:: main (IO ())) (= main (putStrLn (r06a))) ================================================ FILE: finkel-kernel/test/data/make/R06a.hs ================================================ ;;; -*- mode: finkel -*- (:require R01) (module R06a) (import Language.Finkel) (:: r06a Macro) (= r06a (Macro (const (do (let ((= x (foo-macro)))) (return (toCode x)))))) ================================================ FILE: finkel-kernel/test/data/make/R07.hs ================================================ ;;; -*- mode: finkel -*- ;;; R07 --require-> R07a --require-> R07b --require-> R01 (:require R07a) (module R07) (:: main (IO ())) (= main (putStrLn (r07a))) ================================================ FILE: finkel-kernel/test/data/make/R07a.hs ================================================ ;;; -*- mode: finkel -*- (:require R07b) (module R07a) (import Language.Finkel) (:: r07a Macro) (= r07a (Macro (const (return (toCode (r07b)))))) ================================================ FILE: finkel-kernel/test/data/make/R07b.hs ================================================ ;;; -*- mode: finkel -*- (:require R01) (module R07b) (import Language.Finkel) (:: r07b Macro) (= r07b (Macro (const (return (toCode (foo-macro)))))) ================================================ FILE: finkel-kernel/test/data/make/R08.hs ================================================ ;;; -*- mode: finkel -*- ;;; R08 --require-> R08a --require-> R08b --import-> R01 (:require R08a) (module R08) (:: main (IO ())) (= main (putStrLn (r08a))) ================================================ FILE: finkel-kernel/test/data/make/R08a.hs ================================================ ;;; -*- mode: finkel -*- (:require R08b) (module R08a) (import Language.Finkel) (:: r08a Macro) (= r08a (Macro (const (return (toCode (r08b)))))) ================================================ FILE: finkel-kernel/test/data/make/R08b.hs ================================================ ;;; -*- mode: finkel -*- (module R08b) (import R01) (import Language.Finkel) (:: r08b Macro) (= r08b (Macro (const (return (toCode foo-function))))) ================================================ FILE: finkel-kernel/test/data/make/R09.hs ================================================ ;;; -*- mode: finkel -*- ;;; R09 --require-> R09a --import-> R09b --require-> R01 (:require R09a) (module R09) (:: main (IO ())) (= main (putStrLn (r09a))) ================================================ FILE: finkel-kernel/test/data/make/R09a.hs ================================================ ;;; -*- mode: finkel -*- (module R09a) (import Language.Finkel) (import R09b) (:: r09a Macro) (= r09a (Macro (const (return (toCode r09b))))) ================================================ FILE: finkel-kernel/test/data/make/R09b.hs ================================================ ;;; -*- mode: finkel -*- (:require R01) (module R09b) (:: r09b String) (= r09b (foo-macro)) ================================================ FILE: finkel-kernel/test/data/make/R10.hs ================================================ ;;; -*- mode: finkel -*- ;;; R10 --require-> R10a --import-> R10b --import-> R01 (:require R10a) (module R10) (:: main (IO ())) (= main (putStrLn (r10a))) ================================================ FILE: finkel-kernel/test/data/make/R10a.hs ================================================ ;;; -*- mode: finkel -*- (module R10a) (import Language.Finkel) (import R10b) (:: r10a Macro) (= r10a (Macro (const (return (toCode r10b))))) ================================================ FILE: finkel-kernel/test/data/make/R10b.hs ================================================ ;;; -*- mode: finkel -*- (module R10b) (import R01) (:: r10b String) (= r10b foo-function) ================================================ FILE: finkel-kernel/test/data/make/R11.hs ================================================ ;;; -*- mode: finkel -*- ;;; R11 --import-> {R11a, R11b} --import-> R01 (module R11) (import R11a) (import R11b) (:: main (IO ())) (= main (r11a r11b)) ================================================ FILE: finkel-kernel/test/data/make/R11a.hs ================================================ ;;; -*- mode: finkel -*- (module R11a) (import R01) (:: r11a (-> String (IO ()))) (= r11a putStrLn) (:: r11a-run (IO ())) (= r11a-run (r11a foo-function)) ================================================ FILE: finkel-kernel/test/data/make/R11b.hs ================================================ ;;; -*- mode: finkel -*- (module R11b) (import R01) (:: r11b String) (= r11b foo-function) ================================================ FILE: finkel-kernel/test/data/make/cbits1.c ================================================ #include int f1(int x); int f1(int x) { return x + 1; } ================================================ FILE: finkel-kernel/test/data/make/cbits2.c ================================================ #include int f2(int x); int f2(int x) { return x + 2; } ================================================ FILE: finkel-kernel/test/data/make/cbits3.c ================================================ #include int f3(int x); int f3(int x) { return x + 3; } ================================================ FILE: finkel-kernel/test/data/make/main1.hs ================================================ ;;;; -*- mode: finkel -*- (module Main) (:: main (IO ())) (= main (putStrLn "From main1.hs")) ================================================ FILE: finkel-kernel/test/data/make/main2.hs ================================================ ;;;; -*- mode: finkel -*- (module Main) (import qualified M1) (:: main (IO ())) (= main M1.main) ================================================ FILE: finkel-kernel/test/data/make/main3.hs ================================================ ;;;; -*- mode: finkel -*- ;;; Main module importing Haskell module. (import qualified M2) (:: main (IO ())) (= main (M2.main)) ================================================ FILE: finkel-kernel/test/data/make/main4.hs ================================================ ;;; -*- mode: finkel -*- (:require M3 (greet)) (:require Control.Monad) (module Main) (:: main (IO ())) (= main (greet "From main4.main")) ================================================ FILE: finkel-kernel/test/data/make/main5.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (import qualified M1) (import qualified M2) (:: main (IO ())) (= main (do (putStrLn "From main5.hs") M1.main M2.main)) ================================================ FILE: finkel-kernel/test/data/make/main6.hs ================================================ ;;; -*- mode: finkel -*- (:: main (IO ())) (= main (do (print (f1 41)) (print (f2 40)) (print (f3 39)))) (foreign import ccall safe "f1" (:: f1 (-> Int Int))) (foreign import ccall safe "f2" (:: f2 (-> Int Int))) (foreign import ccall safe "f3" (:: f3 (-> Int Int))) ================================================ FILE: finkel-kernel/test/data/make/main7.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (import M5) (import M4) (:: main (IO ())) (= main (>> m4 m5)) ================================================ FILE: finkel-kernel/test/data/make/main8.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (:eval-when-compile (import Prelude) (import Language.Finkel)) (:eval-when-compile (:: m1 Macro) (= m1 (Macro (\_ (return `(putStrLn "From m1")))))) (:: main (IO ())) (= main (m1)) ================================================ FILE: finkel-kernel/test/data/make/main9.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (:require M6.A hiding (m6a2)) (:require M6.B (m6b1)) (:: m6a2 (-> Int (IO ()))) (= m6a2 x (putStrLn (++ "From main9.m6a2: " (show x)))) (:: m6b2 (-> Int (IO ()))) (= m6b2 x (putStrLn (++ "From main9.m6b2: " (show x)))) (:: main (IO ())) (= main (do (m6a1) (m6a2 42) (m6b1) (m6b2 42))) ================================================ FILE: finkel-kernel/test/data/plugin/M01.hs ================================================ ;;; -*- mode: finkel -*- (module M01) (import Language.Finkel) (:: m01 Macro) (= m01 (Macro (const (pure '(putStrLn "plugin/M01.hs"))) )) ================================================ FILE: finkel-kernel/test/data/plugin/M02.hs ================================================ ;;; -*- mode: finkel -*- (module M02) (:require M01) (:: m02 (IO ())) (= m02 (do (m01) (putStrLn "plugin/M02.hs"))) ================================================ FILE: finkel-kernel/test/data/plugin/M03.hs ================================================ ;;; -*- mode: finkel -*- (module M03) (:require M01) (:: m03 (IO ())) (= m03 (do (m01) (putStrLn "plugin/M03.hs"))) ================================================ FILE: finkel-kernel/test/data/plugin/M04.hs ================================================ ;;; -*- mode: finkel -*- (module M04) (import Control.Monad.IO.Class) (import Language.Finkel) (:require M04b) (defmac m04 [] '(putStrLn "M04.m04")) ================================================ FILE: finkel-kernel/test/data/plugin/M04b.hs ================================================ ;;; -*- mode: finkel -*- (module M04b) (import Language.Finkel) (:: defmac Macro) (= defmac (Macro (\ (LForm (L _ (List (: _ forms)))) (case forms [name args body] (pure `(:begin (:: ,name Macro) (= ,name (Macro (\ (LForm (L _ (List (: _ _forms)))) (case _forms ,args (pure ,body) _ (error "defmac: yikes!"))))))) _ (error "defmac: ahh!"))))) ================================================ FILE: finkel-kernel/test/data/plugin/p01.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (:: main (IO ())) (= main (putStrLn "plugin/p01.hs")) ================================================ FILE: finkel-kernel/test/data/plugin/p02.hs ================================================ module Main where main :: IO () main = putStrLn "plugin/p02.hs" ================================================ FILE: finkel-kernel/test/data/plugin/p03.hs ================================================ ;;; -*- mode: finkel -*- (:eval-when-compile (import Prelude) (import Language.Finkel) (:: m1 Macro) (= m1 (Macro (const (pure '(putStrLn "plugin/p03.hs")))))) (:: main (IO ())) (= main (m1)) ================================================ FILE: finkel-kernel/test/data/plugin/p04.hs ================================================ -- Haskell source code containing ;;; in the first line module Main where main :: IO () main = putStrLn "plugin/p04.hs" ================================================ FILE: finkel-kernel/test/data/plugin/p05.hs ================================================ -- File containing the magic finkel pragma in the first line. {-# OPTIONS_GHC -optF --ignore #-} {-# OPTIONS_GHC -fplugin-opt=Language.Finkel.Plugin:--ignore #-} module Main where main :: IO () main = putStrLn "plugin/p05.hs" ================================================ FILE: finkel-kernel/test/data/plugin/p06.hs ================================================ ;;; -*- mode: finkel -*- (:eval-when-compile (import Prelude) (import Language.Finkel) (:: m1 Macro) (= m1 (Macro (\_ (do (<- tmp gensym) (pure `(let ((= ,tmp (not True))) (print ,tmp)))))))) (module Main) (:: main (IO ())) (= main (m1)) ================================================ FILE: finkel-kernel/test/data/plugin/p07.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (:: main (IO ())) (== main (putStrLn "foo")) ================================================ FILE: finkel-kernel/test/data/plugin/p08.hs ================================================ main = putStrLn "plugin/p08.hs" ================================================ FILE: finkel-kernel/test/data/plugin/p09.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (:require M01) (:: main (IO ())) (= main (m01)) ================================================ FILE: finkel-kernel/test/data/plugin/p10.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (import M02) (import M03) (:: main (IO ())) (= main (do m02 m03)) ================================================ FILE: finkel-kernel/test/data/plugin/p11.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (:require M04) (:: main (IO ())) (= main (m04)) ================================================ FILE: finkel-kernel/test/data/preprocess/fnk01.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (:: main (IO ())) (= main (putStrLn "preprocess/fnk01.hs")) ================================================ FILE: finkel-kernel/test/data/preprocess/fnk02.hs ================================================ ;;; -*- mode: finkel -*- (:eval-when-compile (import Prelude) (import Language.Finkel) (:: m1 Macro) (= m1 (Macro (const (pure '(putStrLn "preprocess/fnk02.hs")))))) (module Main) (:: main (IO ())) (= main (m1)) ================================================ FILE: finkel-kernel/test/data/preprocess/fnk03.hs ================================================ ;;; -*- mode: finkel -*- (:: main (IO ())) (= main (putStrLn "preprocess/fnk03.hs")) ================================================ FILE: finkel-kernel/test/data/preprocess/fnk04.hs ================================================ ;;; -*- mode: finkel -*- (module Main foo main) (import Data.Maybe (fromMaybe)) (import qualified Control.Monad as M) (:: main (IO ())) (= main (M.forM- print (Just foo))) (:: foo Bool) (= foo (fromMaybe True Nothing)) ================================================ FILE: finkel-kernel/test/data/preprocess/fnk05.hs ================================================ ; Using DEADBEEF as pragma string (module Main) (import Control.Monad) (:: main (IO ())) (= main (forM- (Just "From fnk05.hs") putStrLn)) ;;; Local variables: ;;; mode: finkel ;;; fill-columns: 72 ;;; comment-column: 0 ;;; End: ================================================ FILE: finkel-kernel/test/data/preprocess/fnk06.hs ================================================ ;;; -*- mode: finkel -*- ;;; Macro codes (:eval-when-compile (import Prelude) (import Language.Finkel) (:: m1 Macro) (= m1 (Macro (const (pure '(putStr (unlines ["=====================" "From dummy02/exe01.hs" "====================="]))))))) ;;; Module sources code (module Main) (:: main (IO ())) (= main (print True)) ================================================ FILE: finkel-kernel/test/data/preprocess/fnk11.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Main) (:: main (IO ())) (= main (putStrLn "preprocess/fnk11.hs")) ================================================ FILE: finkel-kernel/test/data/preprocess/fnk12.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Main (require (Required.Modules.Are.Ignored.In.Downsweep)) (import (Control.Monad [forM- when]) (qualified Data.ByteString as BS) (Data.Maybe hiding [fromJust])) (import-when [:compile] (Compile.Time.Only.Import)) (import-when [:compile :load] (Control.Applicative [liftA3]))) (:: main (IO ())) (= main (putStrLn "preprocess/fnk12.hs")) ================================================ FILE: finkel-kernel/test/data/preprocess/fnk13.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Main (invalid-form) (import Symbol_is_expanded_to_empty_form) (import-when invalid_phase (Control.Monad))) (:: main (IO ())) (= main (putStrLn "preprocess/fnk13.hs")) ================================================ FILE: finkel-kernel/test/data/preprocess/fnk14.hs ================================================ ;;; -*- mode: finkel -*- (module)(Main) ================================================ FILE: finkel-kernel/test/data/preprocess/fnk15.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (:: main (IO ())) (= main (print (:quasiquote foo bar buzz))) ================================================ FILE: finkel-kernel/test/data/preprocess/hs01.hs ================================================ module Main where main :: IO () main = putStrLn "preprocess/hs01.hs" ================================================ FILE: finkel-kernel/test/data/preprocess/hs02.hs ================================================ -- Haskell code containing ";;;" in the first line. module Main where main :: IO () main = putStrLn "preprocess/hs02.hs" ================================================ FILE: finkel-kernel/test/data/syntax/0001-hello.hs ================================================ ;;; -*- mode: finkel -*- ;;; ;;; Simple source containing definition for module named 'Main', with ;;; single function definition 'main'. Contains comments. ;;; (module Main) (= main (putStrLn "Hello, world!")) ================================================ FILE: finkel-kernel/test/data/syntax/0002-lexical.hs ================================================ ;;; -*- mode: finkel -*- ;;; ;;; Tests for tokens and literal values. Unlike Haskell, lines starting ;;; with `;' are comments. This file intentionally contain spaces and ;;; tabs. (module Main) (= main (do ;; 2.5 Numeric Literals ;; Literal integers. (print 42) (print -24) (print 0x123abcdef) (print -0xdeadbeaf) (print 0o7654321) (print -0o7777) ;; Fractional number. (print 1.234567) (print -8.9) ;; 2.6 Character and String Literals. (print #'a) (print #'0) (print #'+) (print #'') (print #')) (print #'[) (print #';) (print #'\) (print #'犬) (print #'Я) (print #'λ) (print #'👺) (print #'\29356) (print #'\1071) (print #'\955) (print #'\128122) (print #'\o71254) (print #'\o2057) (print #'\o1673) (print #'\o372172) (print #'\x72ac) (print #'\x42f) (print #'\x3bb) (print #'\x1f47a) (putChar #'\a) ; alert (putChar #'\SP) ; space (putChar #'\b) ; backspace (putChar #'\HT) ; horizontal tab (putChar #'\n) ; new line (putChar #'\NUL) ; \NUL (putChar #'\LF) ; line feed (putChar #'\FF) ; form feed (putChar #'\^L) ; form feed with control char ;; Single element String with escaped character. (putStrLn [#'\35]) (putStrLn "string literal") ; Simple string ;; String containing escaped `"'. (putStrLn "string with \"double quotes\".") ;; String containing escaped newlines and tabs. (putStrLn "string with newlines: \n\n\nand tabs: \t\t\t.") ;; Strings with non-ASCII characters. (putStrLn "᚛᚛ᚉᚑᚅᚔᚉᚉᚔᚋ ᚔᚈᚔ ᚍᚂᚐᚅᚑ ᚅᚔᚋᚌᚓᚅᚐ᚜") (putStrLn "ᛁᚳ᛫ᛗᚨᚷ᛫ᚷᛚᚨᛋ᛫ᛖᚩᛏᚪᚾ᛫ᚩᚾᛞ᛫ᚻᛁᛏ᛫ᚾᛖ᛫ᚻᛖᚪᚱᛗᛁᚪᚧ᛫ᛗᛖ᛬") (putStrLn "私はガラスを食べられます。それは私を傷つけません。") ;; String gap (putStrLn "Here is a backslant \\ as well as \137, \ \a numeric escape character, and \^X, a control character.") ;; Empty string. (putStrLn "") ;; Unit. (print ()) ;; List literals. (print [1 2 3 4 5]) (print (: True (: False []))) ;; List containing expressions. (print [(if (> 2 3) (do (<- x (return 100)) (<- y (return 23)) (return (+ x y))) (return 123)) (Left "foo")]) ;; Value names not starting with but containing `quote'. (let ((:: x x' x'' Int) (= x 100) (= x' 200) (= x'' 300))) (print x) (print x') (print x'') ;; Some tabs ;; Function names starting with `#'. (let ((:: # #. ## (-> Int Int)) (= # a (+ a 1)) (= #. a (+ a 2)) (= ## a (+ a 3)))) (print ((#) 41)) (print ((#.) 40)) (print ((##) 39)) ;; Function names starting with `%'. (let ((:: %. %% (-> Int Int)) (= %. a (+ a 4)) (= %% a (+ a 5)))) (print ((%.) 38)) (print ((%%) 37)))) ================================================ FILE: finkel-kernel/test/data/syntax/0003-expressions-1.hs ================================================ ;;; -*- mode: finkel -*- (module Main) (import Control.Monad (ap)) ;;; Simple expressions (= simple1 a b (+ (* a (simple2 (+ a b) (+ a b) a)) (* (simple2 (* b b) (* a a) (* a b)) b))) (= simple2 x y z (* (+ x (* y z)) (+ y (* x z)))) (= factorial n (if (== n 1) 1 (* n (factorial (- n 1))))) (= simples (>> (print (simple1 3 4)) (print (factorial 10)))) ;;; 3.3 Curried Applications and Lambda Abstractions ;;; This function takes single argument which is a function, and applies ;;; 3 and 11 to it. (= lam1 f (f 3 11)) ;;; Calls `lam1' defined above. (= lam2 (>> ;; Lambda WITH spaces between '\' and the first argument. (print (lam1 (\ a b (* a (+ a b))))) ;; Lambda WITHOUT spaces between '\' and the first argument. (print (lam1 (\a b (* a (+ a b))))))) (= lamexprs lam2) ;;; 3.4 Operator Applications ;;; Operator are expanded when it takes more than two literal arguments. ;;; Partial application is supported for left hand side argument only. (= op1 (do (print (+ 1 2 3 4 5)) (print (Prelude.* 1 2 3 4 5)) (let ((= f (. putStrLn show (+ 3) (* 13))))) (f (:: 3 Int)) ($ putStrLn show not False))) ;; The ':' operator expansion in pattern match. (= op2 xs (case xs (: a b c _) (print (+ a b c)) _ (return ()))) (= opexprs (do op1 (op2 [1 2 3 4]))) ;;; 3.7 Lists (= lie0 (print (:: [] [Int]))) (= lie1 (print [1])) (= lie2 (print [1 2])) (= lie3 (print [1 2 3])) (= lie4 (print [1 2 3 4])) (= lie5 (print (: 1 (: 2 (: 3 [4 5]))))) (= listexprs (do lie0 lie1 lie2 lie3 lie4 lie5)) ;;; 3.8 Tuples (:: tup1 (-> a (-> b (-> c (, a b c))))) (= tup1 a b c (, a b c)) (:: tup2 (-> a b (Maybe (, a b)))) (= tup2 a b (ap (ap (return (,)) (return a)) (return b))) (:: tup3 (-> a b c d (Maybe (, a b c d)))) (= tup3 a b c d (ap (ap (ap (ap (return (,,,)) (return a)) (return b)) (return c)) (return d))) (= tupexprs (do (print (tup1 #'x 1.23 "4567")) (print (tup2 True #'y)) (print (tup3 True #'a False #'b)))) ;;; 3.9 Unit Expressions and Parenthesized Expressions (= upe1 (print ())) (= upe2 (print ((((((((((True)))))))))))) (= uparenexprs (do upe1 upe2)) ;;; 3.10 Arithmetic Sequences (= ase1 (print (take 10 [1 ..]))) (= ase2 (print (take 10 [1 3 ..]))) (= ase3 (print [2 .. 20])) (= ase4 (print [2 4 .. 20])) (= aseqexprs (do ase1 ase2 ase3 ase4)) ;;; 3.11 List Comprehensions (= lcmp1 [x | (<- x [1 2 3])]) (= lcmp2 [x | (<- x [1 2 3]) (even x)]) (= lcmp3 [y | (<- x [1 2 3]) (even x) (let ((= y (+ x 1))))]) (= lcmp4 [(, x y) | (<- x [1 2 3]) (even x) (let ((= y (+ x 1))))]) (= lcmpexprs (do (print lcmp1) (print lcmp2) (print lcmp3) (print lcmp4))) ;;; 3.12 Let Expressions ;;; Expression with empty 'let'. (= let1 n (let () (+ n 35))) ;;; Expression with 'let'. In bindings of `let', 'a' is a integer value ;;; 14, and `f' is a function taking two arguments. (= let2 n (let ((:: a Int) (= a 14) (:: f (-> Int Int Int)) (= f x y (+ x y)) (:: g (-> Int Int)) (= g (\x (* x 2)))) (g (f n a)))) ;;; Using non-reserved special value names (e.g. `as', `hiding' ...). (= let3 n (let ((= as n) (= ccall n) (= hiding n) (= qualified n) (= ! a b (+ a b)) (= ~~ a b (* a b))) [as ccall hiding qualified (! 19 23) (~~ 6 7)])) ;;; `let' with pattern match (= let4 n (let ((:: f (-> Int Int)) (= f 1 1) (= f 2 1) (= f k (+ (f (- k 1)) (f (- k 2)))) (:: g (-> Int Int)) (= g 0 0) (= g n n)) (g (f n)))) (= letexprs (do (print (let1 7)) (print (let2 7)) (print (let3 7)) (print (let4 7)))) ;;; 3.13 Case Expressions (= case1 x (case x (Just n) (+ n 1) _ 0)) (= case2 x (case x (Right (Just _)) 1 (Right Nothing) 2 (Left (Just _)) 3 (Left Nothing) 4)) (:: mbeven (-> Int (Maybe Int))) (= mbeven n (if (even n) (Just n) Nothing)) (:: case3 (-> (Maybe Int) Int String)) (= case3 x y (case x (Just n) (| ((odd n) (> n 100) "small odd number") ((odd n) "big odd number") ((<- (Just m) (mbeven n)) (let ((:: k Int) (= k (+ m 1)))) (< k 101) "small even number") (otherwise "big even number")) Nothing (| ((even y) "y is even") (otherwise "y is odd")))) (:: case4 (-> (Maybe Int) Int String)) (= case4 x y (where (case x (Just n) (where (| ((even n) (show (f n y))) ((odd n) (++ (h n) (show (f n 1))))) (= f a b (+ a b))) Nothing "nothing") (= h i (replicate (+ i y) #'@)))) ;;; Using non-reserved special value names (e.g. `as', `hiding' ...), in ;;; pattern. (:: case5 (-> (, Int Int Int Int) Int)) (= case5 (, as ccall qualified hiding) (sum [as ccall qualified hiding])) (= caseexprs (do (print (case1 (Just 41))) (print (case1 Nothing)) (print (case2 (Right (Just ())))) (print (case3 (Just 42) 12)) (print (case4 (Just 41) 1)) (print (case5 (, 1 1 1 1))))) ;;; 3.14 Do Expressions (= showBar x (do (putStrLn "String `bar' from showBar.") (return x))) (= listdo (do (<- x [1 2 3]) (<- y [4 5 6]) [x y])) (= letdo (do (let ((= f 1 1) (= f 2 1) (= f n (+ (f (- n 1)) (f (- n 2)))))) (print (f 10)))) (= doexpres (do (putStrLn "foo") (<- buzz (showBar "buzz")) (let ((:: buzz3 buzz4 String) (= buzz3 (concat [buzz buzz buzz])) (= buzz4 "buzz4"))) (putStrLn buzz3) (putStrLn buzz4) (print listdo) letdo)) ;;; 3.15 Datatypes with Field Labels (data R1 (Con1 {(:: field1 Int) (:: field2 Bool)}) (deriving Eq Show)) (:: mkR1 (-> Int (-> Bool R1))) (= mkR1 a b (Con1 {(= field1 a) (= field2 b)})) (:: fe_01 (IO ())) (= fe_01 (do (let ((:: r1 r2 R1) (= r1 (Con1 {(= field2 False) (= field1 42)})) (= r2 (r1 {(= field1 (* (field1 r1) 2))})) (= r3 ((mkR1 21 True) {(= field1 12)})) (= as (r1 {(= field1 (* (field1 r1) 2))})) (= bs (as {(= field1 (* (field1 as) 2))})))) (print r1) (print r2) (print r3) (print as) (print bs))) (:: fe_02 (IO ())) (= fe_02 (do (let ((:: as bs R1) (= as (Con1 {(= field2 True) (= field1 3)})) (= bs (as {(= field1 (* (field1 as) 2))})))) (print as) (print bs))) (= fieldexprs (do fe_01 fe_02)) ;;; 3.16 Expression Type-Signatures (= t316a n (if (< n (:: 2 Int)) n (+ (t316a (- n 1)) (t316a (- n 2))))) (= t316b xs (print (map (:: (\x (+ x 1)) (=> (Num a) (-> a a))) xs))) (= tsigexprs (do (print (t316a 10)) (t316b [1 2 3]) (t316b [1.0 2.0 3.0]))) ;;; 3.17 Pattern Matching ;;; Top level functions with pattern matches. (= fib 0 0) (= fib 1 1) (= fib n (+ (fib (- n 1)) (fib (- n 2)))) (= bar Nothing "bar got nothing") (= bar _ "bar got something") (= buzz (Just n) (putStrLn (++ "buzz: " (show n)))) (= buzz _ (putStrLn "buzz got nothing")) (= addMaybes Nothing Nothing 0) (= addMaybes (Just a) Nothing a) (= addMaybes Nothing (Just b) b) (= addMaybes (Just a) (Just b) (+ a b)) (= nest1 Nothing 0) (= nest1 (Just (Right n)) n) (= nest1 (Just (Left True)) 9999) (= nest1 (Just (Left False)) 42) (= lp1 [] 0) (= lp1 [a] 1) (= lp1 [(Just x) (Just y)] (+ x y)) (= lp1 [a b] 2) (= lp1 _ 999) (= patexprs1 (do (print (fib 10)) (putStrLn (bar Nothing)) (putStrLn (bar (Just undefined))) (buzz (Just 3)) (print (addMaybes Nothing Nothing)) (print (addMaybes (Just 2) Nothing)) (print (addMaybes Nothing (Just 3))) (print (addMaybes (Just 2) (Just 3))) (print (nest1 Nothing)) (print (nest1 (Just (Right 3)))) (print (nest1 (Just (Left True)))) (print (lp1 [])) (print (lp1 [Nothing])) (print (lp1 [Nothing Nothing])) (print (lp1 [(Just 28) (Just 14)])) (print (lp1 [Nothing (Just 1) Nothing])))) (:: tupp1 (-> (, a b) a)) (= tupp1 (, a _) a) (:: tupp2 (-> (, Char Char Char) Char)) (= tupp2 x (case x (, _ _ c) c)) (:: intpat (-> Int String)) (= intpat x (case x 1 "one" 2 "two" _ "unknown")) (:: strpat (-> String String)) (= strpat x (case x "foo" "GOT FOO" "bar" "GOT BAR" _ "UNKNOWN")) (:: charpat (-> Char String)) (= charpat x (case x #'a "GOT A" #'b "GOT B" _ "UNKNOWN")) (= patexprs2 (do (print (tupp1 (, True False))) (print (tupp2 (, #'a #'b #'c))) (print (intpat 1)) (print (intpat 2)) (print (intpat 3)) (print (strpat "foo")) (print (strpat "bar")) (print (strpat "buzz")) (print (charpat #'a)) (print (charpat #'X)))) (:: aspat1 (-> (Maybe Char) String)) (= aspat1 mbc (case mbc (@ x (Just y)) (unwords [(show x) (show y)]) Nothing "Nothing")) (:: ap2a ap2b ap2c Int) (:: aspat2 [Int]) (= (@ aspat2 [ap2a ap2b ap2c]) [123 456 789]) (:: ap3 [String]) (= ap3 (let ((:: p (Either String Int)) (= (@ p (Right q)) (Right 42))) [(show p) (show q)])) (:: ap4 [String]) (= ap4 (let ((= (@ as (, a b)) (, #'a #'b)) (= (@ ccall (, c d)) (, #'c #'d)) (= (@ hiding (, e f)) (, #'e #'f)) (= (@ qualified (, g h)) (, #'g #'h))) [(show as) (show ccall) (show hiding) (show qualified)])) (= patexprs3 (do (print (aspat1 (Just #'p))) (print ap2a) (print ap2b) (print ap2c) (print aspat2) (print ap3) (print ap4))) (:: lzp1 (-> (Maybe Int) String)) (= lzp1 (@ _mbi ~(Just _i)) "matched") (:: lzp2 (-> (, Int [Char] (, Char [Int])) Char)) (= lzp2 (, x ~(: y ys) ~(, z (: w ws))) (| ((even x) y) ((odd x) z))) (:: lzp3 (-> (, a (, b c)) String)) (= lzp3 x (case x ~(, _a ~(, _b _c)) "lzp3")) (:: lzp4 (-> (, a (, b c)) (IO ()))) (= lzp4 x (do (<- ~(, _a ~(, _b _c)) (return x)) (putStrLn "lzp4"))) (:: lzp5 (-> (, a (, b c)) (IO ()))) (= lzp5 (\ ~(, _a ~(, _b _c)) (putStrLn "lzp5"))) (:: lzp6 (-> (, a (, b c)) (IO ()))) (= lzp6 x (let ((= ~(, _a ~(, _b _c)) x)) (putStrLn "lzp6"))) (:: lzp7 (-> (, Int (, Char Bool)) (IO ()))) (= lzp7 ~x (print x)) (= patexprs4 (do (print (lzp1 (Just undefined))) (print (lzp2 (, 3 undefined (, #'x [1 2 3])))) (print (lzp2 (, 4 [#'a #'b] (, undefined [])))) (print (lzp3 undefined)) (lzp4 undefined) (lzp5 undefined) (lzp6 undefined) (lzp7 (, 42 (, #'g True))))) (= lfp1 mb (case mb (Just {}) "just" _ "nothing")) (= lfp2 r1 (case r1 (Con1 {(= field1 i) (= field2 b)}) (if b (* i 7) i))) (= patexprs5 (do (print (lfp1 Nothing)) (print (lfp1 (Just undefined))) (print (lfp2 (Con1 42 False))) (print (lfp2 (Con1 6 True))))) (= unitp1 a (case a () (putStrLn "unitp1: `()' pattern matched."))) (= unitp2 () (putStrLn "unitp2: `()' pattern matched.")) (= patexprs6 (do (unitp1 ()) (unitp2 ()))) (= patexprs (do patexprs1 patexprs2 patexprs3 patexprs4 patexprs5 patexprs6)) ;;; Main (= main (do simples lamexprs opexprs listexprs tupexprs uparenexprs aseqexprs lcmpexprs letexprs caseexprs doexpres fieldexprs tsigexprs patexprs)) ================================================ FILE: finkel-kernel/test/data/syntax/0003-expressions-2.hs ================================================ ;;;; Module containing operator function "@" (= @ a b (* (+ a b) 2)) (= main (print (@ 10 11))) ================================================ FILE: finkel-kernel/test/data/syntax/0003-expressions-3.hs ================================================ ;;; -*- mode: finkel -*- ;;; ;;; This module contains expressions using `forall' as variable idntifier, which ;;; will show an error from ghc 9.10 in default flag settings. (module Main) (:: let1 (-> Int [Int])) (= let1 n (let ((= forall n)) [forall])) (:: case1 (-> (, Int Int) Int)) (= case1 (, as forall) (+ as forall)) (:: main (IO ())) (= main (do (print (let1 42)) (print (case1 (, 19 23))))) ================================================ FILE: finkel-kernel/test/data/syntax/0004-decls.hs ================================================ ;;;; Forms containing type declarations. (module Main) ;;; 4.2 User-Defined Datatypes ;;; 4.2.1 Algebraic Datatype Declarations (data MyData1 (MyD1Con1 Int Bool ()) (MyD1Con2 [(, Int Int)] Double Char) (deriving Eq Show)) (data (MyData2 a b) (MyD2Con1 a b) (MyD2Con2 a a Bool) (deriving Eq Show)) (data (MyData3 a) (MyD3Con1 {(:: d3f1 a) (:: d3f2 (Maybe FilePath))}) (MyD3Con2 Int Int Int) ;; (MyD3Con3 {(:: (d3f1 d3f1b d3f1c) a) ;; (:: d3f4 (Either Bool Char))}) (MyD3Con3 {(:: d3f1 d3f1b d3f1c a) (:: d3f4 (Either Bool Char))}) (deriving Eq Show)) (data MyData4 M4A M4B M4C M4D (deriving Eq Show Enum)) ;;; Empty data declaration. (data MyData5) (instance (Show MyData5) (= show _ "MyData5")) ;;; Strictness Flags (data MyData6 (M6L Int) (M6S1 !Int) (M6S2 !(Maybe Int)) (deriving Eq Show)) (data MyData7 (M7a {(:: m7aF1 !Int) (:: m7aF2 !(Maybe String))}) (deriving Eq Show)) ;; Using non-reserved special names in type variable. ;; ;; GHC 8.8.1 introduced "More explicit foralls", and using "forall" in ;; type variable will show a parse error. (data (MyData8 as ccall forAll hiding qualified) (M8a as ccall forAll hiding qualified) (deriving Eq Show)) (:: s4_2_1 (IO ())) (= s4_2_1 (do (print (MyD1Con1 123 True ())) (print (MyD1Con2 [(, 1 2) (, 3 4)] 1.23 #'z)) (print [(MyD2Con1 (:: 123 Int) #'z) (MyD2Con2 (:: 789 Int) 0 False)]) (print (MyD3Con1 #'x (Just "/foo/bar"))) (print (:: (MyD3Con2 1 2 3) (MyData3 Double))) (print (MyD3Con3 #'a #'b #'c (Right #'z))) (print [M4A M4B M4C]) (print (:: undefined MyData5)) (print [(M6L 42) (M6S1 42) (M6S2 Nothing)]) (print (M7a {(= m7aF1 100) (= m7aF2 (Just "strict Maybe field"))})) (print (M8a True True True True True)))) ;;; 4.2.2 Type Synonym Declarations (type (Synonym1 a) (Maybe (Either String a))) (type Synonym2 (Synonym1 Int)) (:: syn1a (Synonym1 Bool)) (= syn1a (Just (Left "syn1a"))) (:: syn2a Synonym2) (= syn2a Nothing) (:: s4_2_2 (IO ())) (= s4_2_2 (do (print syn1a) (print syn2a))) ;;; 4.2.3 Datatype Renamings (newtype (N1 a) (N1 a)) (instance (=> (Show a) (Show (N1 a))) (= show (N1 a) (++ "N1 " (show a)))) (newtype (N2 a) (N2 a) (deriving Eq Show)) (newtype (N3 a) (N3 {(:: unN3 a)})) (instance (=> (Show a) (Show (N3 a))) (= show (N3 a) (++ "N3 " (show a)))) (newtype (N4 a) (N4 {(:: unN4 a)}) (deriving Eq Show)) (:: s4_2_3 (IO ())) (= s4_2_3 (do (print (N1 1)) (print (N2 2)) (print (N3 3)) (print (N4 4)))) (:: s4_2 (IO ())) (= s4_2 (do s4_2_1 s4_2_2 s4_2_3)) ;;; 4.3 Type Classes and Overloading ;;; 4.3.1 Class Declarations ;;; Simple type class. (class (MyShow a) (:: myShow (-> a String))) ;;; Instance declaration of `MyShow' for `Bool'. (instance (MyShow Bool) (= myShow b (case b True "t" False "f"))) (instance (MyShow Char) (= myShow #'d "dddddddddddddddddddd") (= myShow c (++ "myShow: " (show c)))) ;;; Typeclass with context and default method. (class (=> (Show a) (MyShow2 a)) (:: myShow2 (-> a String)) (= myShow2 show)) (instance (MyShow2 Bool)) (class (Tup2 k) (:: tup2 (-> (k a b) String))) (instance (Tup2 (,)) (= tup2 _ "tup2 for (,)")) (class (Tup3 k) (:: tup3 (-> (k a b c) String))) (instance (Tup3 (,,)) (= tup3 _ "tup3 for (,,)")) (class (Tup4 k) (:: tup4 (-> (k a b c d) String))) (instance (Tup4 (,,,)) (= tup4 _ "tup4 for (,,,)")) (:: s4_3_1 (IO ())) (= s4_3_1 (do (print (map myShow [True False])) (print (map myShow [#'a #'b #'c #'d #'e])) (print (map myShow2 [True False])) (putStrLn (tup2 (, undefined undefined))) (putStrLn (tup3 (, undefined undefined undefined))) (putStrLn (tup4 (, undefined undefined undefined undefined))))) ;;; 4.3.2 Instance Declarations (data (MyF a) (MyF {(:: unMyF a)}) (deriving Eq Show)) (instance (Functor MyF) (= fmap f (MyF a) (MyF (f a)))) (data (EmptyContext a) (EmptyContext Int)) (instance (=> () (Show (EmptyContext a))) (= show (EmptyContext n) (++ "EmptyContext " (show n)))) (data (MCs a b) (MCs a b)) (instance (=> (Show a) (Show b) (Show (MCs a b))) (= show (MCs a b) (concat ["MCs " (show a) " " (show b)]))) (class (C1 c) (:: c1m1 (-> (c a) String))) (instance (C1 []) (= c1m1 li (case li [] "null" _ "list"))) (class (MyFunctor f) (:: myFmap (-> (-> a b) (f a) (f b)))) (instance (MyFunctor (-> a)) (= myFmap f g (\x (f (g x))))) (class (MyProfunctor pf) (:: myDimap (-> (-> a b) (-> c d) (pf b c) (pf a d)))) (instance (MyProfunctor (->)) (= myDimap ab cd bc (. cd (. bc ab)))) (:: s4_3_2 (IO ())) (= s4_3_2 (do (print (fmap (* 2) (MyF 21))) (print (EmptyContext 42)) (print (MCs True #'a)) (putStrLn (c1m1 [])) (putStrLn (c1m1 [() () ()])) (myFmap putStrLn show (:: 42 Int)))) ;;; 4.3.4 Ambiguous Types, and Defaults for Overloaded Numeric Options (default Integer Double) (:: s4_3 (IO ())) (= s4_3 (do s4_3_1 s4_3_2)) ;;; 4.4 Nested Declarations ;;; 4.4.1 Type signatures ;; Unit type. (:: ts1 ()) (= ts1 ()) ;;; Simple function type. (:: ts2 (-> String (IO ()))) (= ts2 str (putStrLn (++ "From ts2: " str))) ;;; Another function type, taking multiple arguments. (:: ts3 (-> Int (-> Bool (-> String (IO ()))))) (= ts3 i b s (do (putStrLn (++ "Int: " (show i))) (putStrLn (++ "Bool: " (show b))) (putStrLn (++ "String: " (show s))))) ;;; Function type operator '->' takes variable arguments, explicit ;;; parentheses are optional. (:: ts3b (-> Int Bool String (IO ()))) (= ts3b i b s (do (putStrLn (++ "Int: " (show i))) (putStrLn (++ "Bool: " (show b))) (putStrLn (++ "String: " (show s))))) ;;; Function taking higher order function. (:: ts4 (-> (-> Int Int) Int)) (= ts4 f (f 6)) ;;; Function taking list. (:: ts5 (-> [Int] (IO ()))) (= ts5 xs (mapM_ print xs)) ;;; Function with type variables. (:: ts6 (-> a [b] Int)) (= ts6 x ys (length ys)) ;;; Type signature with context. (:: ts7 (=> (Show a) (-> a String))) (= ts7 x (++ (show x) (++ ", " (show x)))) ;;; Another type signature with context. (:: ts8 (=> (Functor f) (Show a) (-> (f a) (f String)))) (= ts8 m (fmap ts7 m)) (:: s4_4_1 (IO ())) (= s4_4_1 (do (print ts1) (ts2 "BAR") (ts3 1 True "buzz") (ts3b 2 False "buzzz") (print (ts4 (\n (* (+ n 1) n)))) (ts5 [1 2 3]) (print (ts6 True [1 2 3])) (putStrLn (ts7 False)) (print (ts8 (Just True))))) ;;; 4.4.2 Fixity Declarations (= $^+^$ a b (+ a b)) (= $^-^$ a b (- a b)) (= $^*^$ a b (* a b)) (= $^/^$ a b (/ a b)) (infixl 6 $^+^$) (infixl 6 $^-^$) (infixl 7 $^*^$ $^/^$) ;; Fixity resolution with expanded operator. Without `infixr 4', ;; expanded form "a >*< b >*< c" will not pass the type checker. (:: >*< (=> (Applicative f) (-> (f a) (f (-> a b)) (f b)))) (= >*< (flip <*>)) (infixr 4 >*<) ;; Unicode operators (= •••• a b (* a (+ b 2))) (= ‣ a b (* b (+ a 2))) (= •-•-• a b (* a (+ b 2))) (:: s4_4_2 (IO ())) (= s4_4_2 (do (print ($^*^$ ($^+^$ 3 4) ($^/^$ 48 8))) (print (>*< (Just []) (Just True) (Just :))) (print (•••• 1 2 3 4 5)) (print (‣ 1 2 3 4 5)) (print (•-•-• 1 2 3 4 5)))) ;;; 4.4.3 Function and Pattern Bindinds ;;; 4.4.3.1 Function bindings ;;; Function without guards. (:: fpb0 (-> Int String)) (= fpb0 n (++ "f0 got " (show n))) ;;; Function with guards. (:: fpb1 (-> Int String)) (= fpb1 n (| ((even n) "even") (otherwise "odd"))) ;;; Function with pattern guards. (:: fpb2 (-> (Maybe Int) (Maybe Int) String)) (= fpb2 a b (| ((<- (Just n) a) (<- (Just m) b) (even n) (even m) "f2: got two even numbers.") ((<- (Just n) a) (<- (Just m) b) (++ "f2: got two numbers, sum = " (show (+ n m)))) ((<- (Just n) a) "f2: b was nothing.") ((<- (Just n) b) "f2: a was nothing") (otherwise "f2: no numbers."))) (:: fpb3 [String]) (= fpb3 ["string" "expression" "without" "guards"]) ;;; Function with `where' (:: fpb4 (-> Char Int String)) (= fpb4 c n (where (f n) (= f x (replicate x c)))) ;;; Functions with `where', with identical name. (:: fpb5 (-> Int Int)) (= fpb5 k (where (f 0 k) (= f acc 0 acc) (= f acc n (f (+ acc n) (- n 1))))) ;;; Another function with `where', with pattern match. (:: fpb6 (-> Int String)) (= fpb6 n (where (f (lookup n names)) (= f Nothing "none") (= f (Just n) n) (= names [(, 1 "one") (, 2 "two") (, 3 "three")]))) ;;; 4.4.3.2 Pattern Bindings (:: xs ys [Int]) (= (, xs ys) (break (> 5) (enumFromTo 1 10))) (:: addJust (-> Int Int (Maybe Int))) (= addJust a b (Just (+ a b))) (:: tpb1 Int) (= (Just tpb1) (addJust 16 27)) (:: tpb2 Int) (= [_ _ tpb2 _] (enumFromTo 40 43)) (:: tpb3 Int) (= (: tpb3 _) (enumFrom 42)) ;;; Ignored top level bindings (= _ (:: 1 Int)) (= _ (:: 2 Integer)) (= _ (:: 3 Double)) (:: s4_4_3 (IO ())) (= s4_4_3 (do (putStrLn (fpb0 42)) (putStrLn (fpb1 10)) (putStrLn (fpb1 11)) (putStrLn (fpb2 (Just 2) (Just 4))) (putStrLn (fpb2 (Just 2) (Just 5))) (putStrLn (fpb2 (Just 100) Nothing)) (putStrLn (fpb2 (Nothing) (Just 8))) (putStrLn (fpb2 Nothing Nothing)) (print fpb3) (putStrLn (fpb4 #'= 30)) (print (fpb5 10)) (print (fpb6 2)) (putStrLn (++ "xs: " (show xs))) (putStrLn (++ "ys: " (show ys))) (putStrLn (++ "tpb1: " (show tpb1))) (putStrLn (++ "tpb2: " (show tpb2))) (putStrLn (++ "tpb3: " (show tpb3))))) (:: s4_4 (IO ())) (= s4_4 (do s4_4_1 s4_4_2 s4_4_3)) ;;; Main. (:: main (IO ())) (= main (do s4_2 s4_3 s4_4)) ================================================ FILE: finkel-kernel/test/data/syntax/0005-modules-01.hs ================================================ ;;; -*- mode: finkel -*- ;;; ;;; Simple example for `import'. (module Main) (import Data.Maybe) (= main (putStrLn (foo (Just "bar")))) (= foo x (fromMaybe "foo" x)) ================================================ FILE: finkel-kernel/test/data/syntax/0005-modules-02.hs ================================================ ;;; -*- mode: finkel -*- ;;; ;;; File without module name. (:: main (IO ())) (= main (putStrLn "Module without module header.")) ================================================ FILE: finkel-kernel/test/data/syntax/0005-modules-03.hs ================================================ ;;; -*- mode: finkel -*- ;;; ;;; 5.2 Export Lists (module Main ;; Value entities f1 f3 ;; Data constructor only ... is impossible. From section 5.2 of ;; Haskell 2010 report: ;; ;; ... Data cnstructros cannot be named in export lists except as ;; subordinate names, because they cannot otherwise be distinguished ;; from type constructors. ;; ;; D1A ;; Typeclass method only. c1a ;; Type constructor only. (D2) C2 ;; Type constructor and all data constructors. (D3 ..) (C3 ..) ;; Type constructor and specified data constructors. (D4 D4a D4c) (D5 d5f1 d5f3) (C4 c4a c4c) ;; Module re-export (module Data.Char) ;; Re-export with qualified renamed module (Mb.Maybe Just Nothing) main) (import Data.Char) (import qualified Data.Maybe as Mb) ;; Function values (:: f1 (-> Int Int)) (= f1 (+ 1)) (:: f2 (-> Int Int)) (= f2 (* 2)) (:: f3 (-> Int Int)) (= f3 (. f1 f2)) ;;; Data types (data D1 (D1A Int Int)) (data (D2 a) (D2A a) (D2B a a)) (data (D3 a) (D3a a) (D3b a a) (D3c a a a)) (data (D4 a b c) (D4a a) (D4b b) (D4c c)) (data (D5 a) (D5a {(:: d5f1 a) (:: d5f2 a) (:: d5f3 Int)}) (D5b {(:: d5f1 a)}) (D5c {(:: d5f2 a)})) ;;; Typeclasses (class (C1 a) (:: c1a (-> a String))) (class (C2 a) (:: c2a (-> a String)) (:: c2b (-> a Int))) (class (C3 a) (:: c3a (-> a String)) (:: c3b (-> a Int)) (:: c3c (-> a Bool))) (class (C4 a) (:: c4a (-> a String)) (:: c4b (-> a Int)) (:: c4c (-> a Bool))) (:: main (IO ())) (= main (putStrLn "Module containing various exports")) ================================================ FILE: finkel-kernel/test/data/syntax/0005-modules-04.hs ================================================ ;;; -*- mode: finkel -*- ;;; ;;; 5.3 Import Declarations (module Main) (import Data.Char) (import System.IO ()) (import Control.Monad as M) (import Data.Array (! array)) (import Data.Complex ((Complex ..) realPart imagPart mkPolar)) (import Data.Monoid ((All All) (Any) (Alt getAlt))) (import Data.Ratio hiding (Ratio Rational numerator %)) (import qualified Data.List) (import qualified Data.Functor.Identity as Id) (import qualified Data.Map as Map) (import qualified Data.Maybe as Mb) (import qualified Data.Bits as Bt (shiftL shiftR)) (import qualified System.Environment as Env hiding (getArgs getEnv)) (:: f1 (Map.Map String Int)) (= f1 (Map.fromList [(, "k1" 1) (, "k2" 2)])) (:: f2 (-> (Id.Identity a) (IO ()))) (= f2 i (case i (Id.Identity {}) (putStrLn "Id.Identity pattern match with {}"))) (:: main (IO ())) (= main (do (putStrLn (map toUpper "import declarations")) (print (Data.List.nub [1 2 3 2 1 2 3 2 1])) (print (Mb.fromMaybe 123 Nothing)) (print (Mb.Just 42)) (print (:: (return 42) (Id.Identity Int))) (case (return 42) (Id.Identity n) (print n)) (print (case EQ Prelude.EQ True)) (print (case (Id.Identity 42) (Id.Identity n) n)) (let ((= i1 (Id.Identity 100)) (= i2 (Id.Identity {(= Id.runIdentity 101)})) (= i3 (i2 {(= Id.runIdentity 102)})))) (mapM_ print [i1 i2 i3]) (f2 i1) (M.when (< 3 5) (putStrLn "Control Monad imported as `M'")) (let ((= arr (array (, 0 15) (zip [0 .. 15] [#'a ..]))))) (print (! arr 3)) (let ((= c (mkPolar 1.2 3.4)))) (print (realPart c)) (print (imagPart c)) (print (Bt.shiftL (:: 8 Int) 8)) (>>= Env.getProgName putStrLn) (print f1))) ================================================ FILE: finkel-kernel/test/data/syntax/0005-modules-05.hs ================================================ ;;; Module without header, with imports. (import Control.Monad (foldM)) (:: main (IO ())) (= main (where go (= go (do (<- n (foldM f 0 [#'a .. #'z])) (print n))) (= f n a (do (print a) (return (+ n 1)))))) ================================================ FILE: finkel-kernel/test/data/syntax/0008-ffi.hs ================================================ ;;;; Forms containing FFI. (module Main) (import Foreign.C.String ((CString) peekCAString)) ;;; 8.4 Foreign Declarations ;;; 8.4.3 Import Declarations (foreign import ccall (:: rand (IO Int))) (foreign import ccall "sin" (:: csin (-> Double Double))) (foreign import ccall safe "cos" (:: ccos (-> Double Double))) (foreign import ccall unsafe "math.h tan" (:: ctan (-> Double Double))) (:: s8_4_3 (IO ())) (= s8_4_3 (do (print (csin (* pi 0.5))) (print (ccos (* pi 2))) (print (ctan pi)))) ;;; 8.4.4 Export Declarations (:: printSomeThing (-> CString (IO ()))) (= printSomeThing something (do (putStrLn "From printSomething") (<- str (peekCAString something)) (putStrLn str))) (foreign export ccall "printSomeThing" (:: printSomeThing (-> CString ( IO ())))) ;; XXX: Not working. This code compiles with fnkc, but fails to ;; compile the generated Haskell code. 'Outputable.ppr' for operator ;; function in FFI export does not use parenthesis in ghc. This also ;; happens when running ghc with "-ddump-parsed" option. ;; ;; (foreign export ccall "addInt" ;; (:: + (-> Int Int Int))) ;;; Main (:: main (IO ())) (= main s8_4_3) ================================================ FILE: finkel-kernel/test/data/syntax/0012-pragmas.hs ================================================ ;;; Forms containing INLINE, INLINABLE ... etc. (module Main) ;;; 12.1 Inlining (:: inlineMe Int) (= inlineMe 42) %p(INLINE inlineMe) (:: inlineMe0 Int) (= inlineMe0 42) %p(INLINE [0] inlineMe0) (:: inlineMe1 Int) (= inlineMe1 42) %p(INLINE [1] inlineMe1) (:: inlineMe2 Int) (= inlineMe2 42) %p(INLINE [2] inlineMe2) (:: inlineMeT0 Int) (= inlineMeT0 42) %p(INLINE [~ 0] inlineMeT0) (:: inlineMeT0' Int) (= inlineMeT0' 42) %p(INLINE [~0] inlineMeT0') (:: dontInlineMe Int) (= dontInlineMe 43) %p(NOINLINE dontInlineMe) (:: dontInlineMe1 Int) (= dontInlineMe1 43) %p(NOINLINE [1] dontInlineMe1) (:: dontInlineMeT2 Int) (= dontInlineMeT2 43) %p(NOINLINE [~2] dontInlineMeT2) (:: iAmInlinable Int) (= iAmInlinable 44) %p(INLINABLE iAmInlinable) (:: iAmInlinable0 Int) (= iAmInlinable0 44) %p(INLINABLE [0] iAmInlinable0) (:: iAmInlinableT2 Int) (= iAmInlinableT2 44) %p(INLINABLE [~2] iAmInlinableT2) (data (I1 a) (I1 a)) (instance (=> (Show a) (Show (I1 a))) (= showsPrec _ (I1 a) (showString (++ "I1 " (show a)))) %p(INLINE showsPrec)) (:: inlineprgm (IO ())) (= inlineprgm (do (print inlineMe) (print dontInlineMe) (print iAmInlinable) (print (show (I1 True))))) ;;; 12.2 Specialization (:: specializeMe1 (=> (Num a) (Show a) (-> a String))) (= specializeMe1 x (show (+ x 1))) %p(SPECIALIZE (:: specializeMe1 (-> Int String))) %p(SPECIALIZE [0] (:: specializeMe1 (-> Integer String))) %p(SPECIALIZE [~1] (:: specializeMe1 (-> Float String))) %p(SPECIALIZE [2] (:: specializeMe1 (-> Double String))) (:: specprgm (IO ())) (= specprgm (do (putStrLn (specializeMe1 (:: 41 Int))) (putStrLn (specializeMe1 (:: 41 Integer))) (putStrLn (specializeMe1 (:: 41 Double))) (putStrLn (specializeMe1 (:: 41 Float))))) (:: main (IO ())) (= main (do inlineprgm specprgm)) ================================================ FILE: finkel-kernel/test/data/syntax/1000-comment.hs ================================================ ;;; -*- mode: finkel -*- ;;;; | File with documentation header comments. ;;;; ;;;; Some more documentation strings in consequent lines. Some more ;;;; documentation strings in consequent lines. Some more documentation ;;;; strings in consequent lines. ;;;; ;;;; Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do ;;;; eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ;;;; ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut ;;;; aliquip ex ea commodo consequat. Duis aute irure dolor in ;;;; reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla ;;;; pariatur. Excepteur sint occaecat cupidatat non proident, sunt in ;;;; culpa qui officia deserunt mollit anim id est laborum. (module Main) {- Sample block comment. All literals between character sequence `#' `|', and `|' `#' are block comment. Block comments understand UNICODE characters: - 我能吞下玻璃而不伤身体。 - ฉันกินกระจกได้ แต่มันไม่ทำให้ฉันเจ็บ - მინას ვჭამ და არა მტკივა. -} ;;; * The main function ;;; $foo ;;; ;;; Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do ;;; eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ;;; ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut ;;; aliquip ex ea commodo consequat. Duis aute irure dolor in ;;; reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla ;;; pariatur. Excepteur sint occaecat cupidatat non proident, sunt in ;;; culpa qui officia deserunt mollit anim id est laborum. ;;; | Main entry function. (= main ;; This is not a documentation comment. (foo "Module with doc comments.")) ;;; * Other functions ;;; ** The foo function (= foo str (>> (foo-aux str) (bar 15 27))) ;;; ^ Comment for function foo. ;;; *** Auxiliary function for foo (= foo-aux putStrLn) {-onelineblockcommentwithoutspaces-} ;;; ** The bar function ;;; | Comment for function bar. ;;; ;;; This comment spans multiple lines. Bar bar bar bar bar bar bar bar ;;; bar bar bar bar bar bar bar bar bar bar. ;;; ;;; Bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar ;;; bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar ;;; bar bar bar. ;;; ;;; Some unicode strings: ;;; ;;; - 我能吞下玻璃而不伤身体。 ;;; - ฉันกินกระจกได้ แต่มันไม่ทำให้ฉันเจ็บ ;;; - მინას ვჭამ და არა მტკივა. (:: bar (-> Int ; ^ Arg 1. Int ; ^ Arg 2. (IO ()))) (= bar a b (putStrLn {-more-} (++ {-block-} "From bar: " {-comments-} (show (+ a b))))) ;;; ** The buzz function ;;; | Comment for function buzz. ;;; ;;; This comment is written on the line above type signature of buzz. ;;; (:: buzz (-> Int Int)) (= buzz %_(codes inside this list is ignored) n %_this_symbol_is_ignored (+ n %_"ignored string literal" n)) ================================================ FILE: finkel-kernel/test/data/syntax/1001-quote.hs ================================================ ;;; Tests for quote, quasiquote, unquote, and unquote-splice. (module Main) (import Language.Finkel) (= f1 arg (print ['a 'b arg 'd])) (= f2 arg (print `(a b ,arg d))) (= f3 arg (print `(a b ,@arg d))) (= f4 arg (print `(கிழக்கு බටහිර ,arg Βόρειος))) (:: main (IO ())) (= main (do ;; "'foo" is same as "(:quote foo)". (print 'foo) (print (:quote foo)) ;; Quotes can nest. (print ''foo) (print '''foo) ;; Quoting literals (print '"string") (print '42) (print '1.23) (print '#'c) (print '[1 2 3]) (print '()) ;; Quoting reserved symbols (print 'case) (print 'class) (print 'data) (print 'default) (print 'do) (print 'foreign) (print 'infix) (print 'infixl) (print 'infixr) (print 'instance) (print 'let) (print 'newtype) (print 'type) (print '!) (print '->) (print '..) (print '::) (print '<-) (print '=) (print '=>) (print '@) (print '{) (print '}) (print '|) (print '~) (print '_) (print 'forall) (print 'anyclass) (print 'as) (print 'family) (print 'hiding) (print 'stock) (print 'via) (print 'qualified) (print ':quote) (print '(deriving)) (print '(import)) (print '(module)) (print '(where)) ;; Quoting pragmas (print '(UNPACK)) (print '(OVERLAPPABLE)) (print '(OVERLAPPING)) (print '(OVERLAPS)) (print '(INCOHERENT)) ;; Quoting doc comments (print '(:doc "xxxx")) (print '(:doc^ "xxxx")) (print '(:doc$ key "xxxx")) (print '(:dh1 "xxxx")) (print '(:dh2 "xxxx")) (print '(:dh3 "xxxx")) (print '(:dh4 "xxxx")) ;; Quasiquote. (print `foo) (print (:quasiquote foo)) (f1 'foo) (f2 'foo) (f3 '(foo bar buzz)) (f3 '[\x \y \z]) (f3 ['foo 'bar 'buzz]) (f4 'みなみ))) ================================================ FILE: finkel-kernel/test/data/syntax/1002-macro.hs ================================================ ;;; Tests for macros. (module Main) (:eval-when-compile (import Prelude) (import Language.Finkel)) (import Language.Finkel) (:eval-when-compile (:: define-macro Macro) (= define-macro (Macro (\form (case (unCode form) (List (: _ (: name rest))) (let ((= __name (toCode (qSymbol (++ "__" (show name)) "1002-macro.fnk" 0 0 0 0)))) (return `(:begin (:: ,name Macro) (= ,name (let ((:: ,__name (-> Code (Fnk Code))) (= ,__name ,@rest)) (Macro ,__name)))))) _ (finkelSrcError form "define-macro: invalid args"))))) (:: let-macro Macro) (= let-macro (let ((= f form (case (unCode form) (List [name arg body]) (let ((= __name (toCode (qSymbol (++ "__" (show name)) "1002-macro.fnk" 0 0 0 0)))) (return `(= ,name (let ((:: ,__name (-> Code (Fnk Code))) (= ,__name ,arg ,body)) (Macro ,__name))))) _ (finkelSrcError form "let-macro: malformed macro")))) (Macro (\form (case (unCode form) (List (: _self (: (LForm (L _l (List ms))) rest))) (do (<- ms' (mapM f ms)) (return `(:with-macro (,@ms') ,@rest))) _ (finkelSrcError form "let-macro: malformed args"))))))) (:eval-when-compile (define-macro define-macro' form (case (unCode form) (List (: _ rest)) (return `(:begin (:eval-when-compile (define-macro ,@rest)) (define-macro ,@rest))) _ (finkelSrcError form "error")))) ;; Simple version of `defmacro' defined with `define-macro'' (define-macro' defmacro form (case form (LForm (L _ (List [_self name args body]))) (case args (LForm (L _ (List _))) (return `(define-macro' ,name form (case form (LForm (L l1 (List [_ ,@args]))) (return ,body) _ (finkelSrcError ',name "error")))) _ (return `(define-macro ,name ,args (return ,body)))) _ (finkelSrcError form "error"))) ;;; Using `defmacro' defined above. (defmacro m1 (x y) `(putStrLn (concat [,x ", " ,y]))) (define-macro' m2 form (where (case form (LForm (L _ (List [_self arg1 arg2]))) (return (mkbody arg1 arg2))) (= mkbody x y `(print (+ (:: ,x Int) (:: ,y Int)))))) ;; Simple `let-macro'. (let-macro ((m2a form (case form (LForm (L _ (List [_ a b c]))) (return `(,a (+ ,b ,c))) _ (finkelSrcError form "m2a: error"))) (m2b form (case form (LForm (L _ (List [_ x y]))) (return `(+ ,x ,y)) _ (finkelSrcError form "m2b: error")))) (:: f1 (-> Int Int (IO ()))) (= f1 x y (m2a print x (m2b x y)))) ;;; Macro taking fractional value as argument. (let-macro ((m1 form (case form (LForm (L l (List [_ x]))) (case (fromCode x) (Just d) (if (<= 1.0 (:: d Double)) (return '"more or eq to one") (return '"less than one")) Nothing (return '"not a double")) _ (finkelSrcError form "m1: invalid args")))) (:: fracmac (IO ())) (= fracmac (do (putStrLn (m1 1.1)) (putStrLn (m1 0.9)) (putStrLn (m1 #'x))))) ;;; Macro returning haskell list. (let-macro ((m2 form (case form (LForm (L l (List [_ a b c]))) (let ((:: mbints (Maybe (, Int Int Int))) (= mbints (do (<- x (fromCode a)) (<- y (fromCode b)) (<- z (fromCode c)) (return (, x y z))))) (case mbints (Just (, x y z)) (return `[,(* x 100) ,(* y 100) ,(* z 100)]) _ (finkelSrcError form "m2: invalid args"))) _ (finkelSrcError form "m2: invalid form")))) (:: hslistmac (IO ())) (= hslistmac (print (m2 1 2 3)))) (let-macro ((identity-form form (case (unCode form) (List [_ body]) (return body)))) (identity-form (define-macro' m4 _ (return `(putStrLn "m4"))))) (:: m4run (IO ())) (= m4run (m4)) (define-macro' m5 form (case (unCode form) (List [_ arg1 body]) (do (<- tmp gensym) (return `(let ((= ,tmp (* ,arg1 2))) (sequence_ (replicate ,tmp ,body))))) _ (finkelSrcError form "m5-ok"))) (:: m5run (IO ())) (= m5run (let ((= x 123)) (m5 2 (print x)))) ;;; XXX: Haskell source code generated from below expression does not ;;; compile, since the line containing `let ... in ...' get long with ;;; temporary name generated by gensym. The `do' block cannot understand ;;; the line starting with `in', because the line does not have ;;; indentation clue. ;; (:: m5run-v2 (IO ())) ;; (= m5run-v2 ;; (do (let ((= x 123))) ;; (m5 2 (print x)))) (:: main (IO ())) (= main (do (m1 "Hello" "macro") (m2 11 31) (f1 11 20) fracmac hslistmac m4run m5run)) ================================================ FILE: finkel-kernel/test/data/syntax/1003-eval-when-compile.hs ================================================ ;;;; -*- mode: finkel -*- ;;;; ;;;; Code containing `eval-when-compile'. (module Main) ;;; Function declaration and macro definition done during compilation ;;; phase. Codes inside `eval-when-compile' do won't appear in resulting ;;; Haskell code. (:eval-when-compile (import Prelude) (import Language.Finkel) ;; Function called later from macro `m1'. (:: f1 (-> Int Int Int)) (= f1 a b (+ a b)) ;; Macro defined in compiler's interactive context. (:: macro-ct Macro) (= macro-ct (Macro (const (return '(putStrLn "From `macro-ct'.")))))) ;;; Macro `m1' is calling `f1' declared above. (:with-macro ((= m1 (Macro (\_form (let ((= ret (* (f1 4 2) 7))) (return (toCode ret))))))) (:: main (IO ())) (= main (do (macro-ct) (print (m1))))) ================================================ FILE: finkel-kernel/test/data/syntax/1004-doccomment-01.hs ================================================ ;;; -*- mode: finkel -*- %p(LANGUAGE RankNTypes TypeFamilies) (:doc " Module : Main Description : Module for documentation comment Copyright : (c) someone, someyear License : GPL-3 Maintainer : foo@bar.com Stability : experimental Portability : POSIX Module header documentation. This comment is written inside `:doc' form.") (module Main (:dh1 "The main function") (:doc "Main entry point function. This function is performed from compiled executable.") main (:dh1 "Types and classes") (:doc$ auxdt) (D1 ..) (D2 ..) (D3 ..) (D4 ..) (T1) (C1 ..) (C2 ..) (TF1) (DF1) (:dh1 "Functions") (:doc$ auxfn) f1 f2 f3 f4 f5 f6) ;;; Functions (:doc$ auxfn "Section documentation for auxiliary functions.") (:doc "Documentation of 'f1'") (:: f1 (-> String (IO ()))) (= f1 str (putStrLn (++ "From f1: " str))) (:doc "Documentation of 'f2'") (:: f2 (-> String (IO ()))) (= f2 (. putStrLn (++ "From f2: "))) (:doc "Documentation of 'f3'") (:: f3 (-> Int (:doc^ "Single line comment") String (:doc^ "Multiple lines comment for the second argument. Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.") (IO ()) (:doc^ "Action to print given message for given times"))) (= f3 n msg (sequence_ (replicate n (putStrLn msg))) ) (:: f4 (forall a (-> a (:doc^ "Documentation for first argument.") a (:doc^ "Documentation for result.")))) (:doc^ "Documentation for 'f4'. This function contains unnecessary explicit @forall@ keyword.") (= f4 x x) (:: f5 (-> (forall a (-> a a)) (:doc^ "Documentation for first arg.") (, Char Bool) (:doc^ "Documentation for result."))) (:doc^ "Documentation for 'f5'. This function contains rank-n type function argument.") (= f5 f (, (f #'a) (f True))) (:: f6 (=> (Show a) (Show b) (-> a (:doc^ "Documentation for first arg.") b (:doc^ "Documentation for second arg.") String (:doc^ "Documentation for result.")))) (:doc^ "Documentation for 'f6'. Example for writing documentation for argument, with a function containing type class constraints. This documentation comment includes @since@ metadata. @since 1.2.3.4.5.6.7") (= f6 a b (++ "f6: a=" (show a) ", b=" (show b))) ;;; Types and classes (:doc$ auxdt "Section documentation for auxiliary data and types.") ;;; Unlike haddock comment in Haskell source code, constructor ;;; documentation comments are allowed for ':doc^' forms only. (:doc "Documentation for data type 'D1'.") (data (D1 a b) (D1a a) (:doc^ "Documentation for 'D1a'. This comment contains empty lines. To add a line break in generated HTML document, need to add an empty line. Otherwise, line breaks in source codes will disappear.") (D1ab a (:doc^ "The first argument of `D1ab'.") b (:doc^ "The 2nd.") Int (:doc^ "Documentation for the 3rd argument of `D1ab'. Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.") Int (:doc^ "The 4th.")) (:doc^ "Documentation for constructor 'D1ab'.") (deriving Eq Show)) (newtype (D2 a) (D2 a) (:doc^ "Documentation for constructor `D2'.")) (:doc^ "Documentation for top level newtype declaration.") (data (D3 a) (:doc "Documentation for 'D3a'.") (D3a {(:: d3_f1 Int) (:doc^ "Documentation for 'd3_f1' field.") (:: d3_f2 a) (:doc^ "Documentation for 'd3_f2' field. Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.") (:: d3_f3 d3_f4 a) (:doc^ "Documentation for 'd3_f3' and 'd3_f4' fields.")}) (:doc "Documentation for 'D3b'.") (D3b a a) (deriving Eq Show)) (:doc^ "Documentation for top level 'D3' data type declaration.") (:doc "Documentation for top level `D4' data type declaration.") (data (D4 a) (:doc "Documentation for `D4a'.") (D4a {(:doc "Documentation for `d4_f1'.") (:: d4-f1 Int) (:doc "Documentation for `d4_f2' and `d4_f3'.") (:: d4-f2 d4-f3 a)}) (:doc "Documentation for `D4b'") D4b (deriving Eq Show)) (type (T1 a) (Maybe (, a a)) (:doc^ "T1 is a synonym of optional pair of __@a@__ values.")) (:doc^ "Documentation for top level 'T1' type synonym.") (class (C1 a) (type (C1T1 a)) (:doc^ "Documentation for 'C1T1'.") (type (C1T2 a)) (:doc^ "Documentation for 'C1T2'. Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.") (:: c1_m1 (-> a String)) (:doc^ "Documentation for `c1_m1' method in 'C1'.") (:: c1_m2 (-> a (:doc^ "1st arg.") a (:doc^ "2nd arg.") String)) (:doc^ "documentation for `c1_m2' method in 'C1'. This method takes two __@a@__ arguments. ")) (:doc^ "Documentation for top level 'C1' type class.") (:doc "Documentation for top level `C2' type class.") (class (C2 a) (:doc "Documentation for `C2T1'.") (type (C2T1 a)) (:doc "Documentation for `c2_m1'.") (:: c2-m1 (-> a String)) (:doc "Documentation for `c2_m2'.") (:: c2-m2 (-> (C2T1 a) (:doc^ "1st arg.") a (:doc^ "2nd arg.") String))) (:doc "Documentation for instance declaration of `C2' for `Int'.") (instance (C2 Int) (type (C2T1 Int) Int) (= c2_m1 show) (= c2_m2 a1 a2 (++ "arg1=" (show a1) ", arg2=" (show a2)))) (type family (TF1 a)) (:doc^ "Documentation for top level 'TF1' type family.") (type instance (TF1 Bool) Int) (:doc^ "Documentation for top level `TF1' instance for `Bool'.") (data family (DF1 a)) (:doc^ "Documentation for top level data family `DF1'.") (data instance (DF1 Bool) (DF1B Int) (deriving Eq Show)) (:doc^ "Documentation for top level `DF1' instance for `Bool'.") (data instance (DF1 Double) (DF1D1 Double) (DF1D2 Int) (deriving Eq Show)) (:doc^ "Documentation for top level `DF1' instance for `Double'.") (newtype instance (DF1 Char) (DF1C Bool)) (:doc^ "Documentation for top level `DF1' instance for `Char'.") ;;; Main function (:: main (IO ())) (:doc^ "Documentation of 'main'.") (= main (do (putStrLn "documentation comment tests.") (f1 "foo") (f2 "bar") (f3 3 "buzz"))) ================================================ FILE: finkel-kernel/test/data/syntax/1004-doccomment-02.hs ================================================ ;;; -*- mode: finkel -*- (:doc "Module without explicit export entities.") (module Main) (:dh1 "Level 1") (:dh2 "Level 2") (:dh3 "Level 3") (:doc "Docmentation for 'foo'.") (:: foo (-> Int Int)) (= foo succ) (:dh1 "Level 1") (:doc$ main "Named comment.") (:doc "Documentation for 'main'.") (:: main (IO ())) (= main (print (foo 41))) ================================================ FILE: finkel-kernel/test/data/syntax/1004-doccomment-03.hs ================================================ ;;; Doccomment with unusable UNPACK pragma (module Main) (:doc "Documentation for data type 'D1'.") (data (D1 a b) (D1a a) (:doc^ "Documentation for 'D1a'.") (D1b %p(UNPACK) !b) (:doc^ "Documentation for 'D1b', has unusable UNPACK pragma. This comment contains empty lines. A line containing some foo: Foo foo foo foo, foo foo, and foo.") (D1ab a (:doc^ "The first argument 'D1ab.") b (:doc^ "The 2nd.") Int (:doc^ "The 3rd.")) (deriving Show)) (:: main (IO ())) (= main (print [(D1a True) (D1b False)])) ================================================ FILE: finkel-kernel/test/data/syntax/1005-begin.hs ================================================ ;;; Tests for begin. (:begin (module Main) (:begin (:: bgn01 (IO ())) (= bgn01 (do (putStrLn "=== start bgn01 ===") (putStrLn ":begin") (putStrLn "in") (putStrLn "do") (putStrLn "=== end bgn01 ==="))))) (:begin (:: bgn02 (IO ()))) (:begin (= bgn02 (let ((= f str (putStrLn str)) (= g str (concat ["=== " str " ==="]))) (f (g "bgn02"))))) (:begin (:begin (:: bgn03 (IO ()))) (:begin (:begin (= bgn03 (let ((= f str (++ "f:" str)) (= g str (++ "g:" str))) (putStrLn (f (g "bgn03")))))))) (:: main (IO ())) (= main (do bgn01 bgn02 bgn03)) ================================================ FILE: finkel-kernel/test/data/syntax/2001-unpack.hs ================================================ ;;;; "UNPACK" and "SPECIALIZE INLINE" pragma %p(LANGUAGE GADTs) (module Main) ;;; UNPACK (data D1 (C1 %p(UNPACK) (! Int) %p(UNPACK) !Char) (deriving Eq Show)) (data D2 (C2 {(:: c2field1 %p(UNPACK) !Int) (:: c2field2 %p(UNPACK) (! Char))}) (deriving Eq Show)) (:: unpackprgm (IO ())) (= unpackprgm (do (print (C1 42 #'x)) (print (C2 42 #'x)))) ;; SPECIALIZE INLNE (data (Lst e) (:: LstInt (-> !Int [Int] (Lst Int))) (:: LstPair (-> !Int (Lst e1) (Lst e2) (Lst (, e1 e2))))) (:: !: (-> (Lst e) Int e)) (= !: (LstInt _ xs) i (!! xs i)) (= !: (LstPair _ l1 l2) i (, (!: l1 i) (!: l2 i))) %p(SPECIALIZE INLINE (:: !: (-> (Lst Int) Int Int))) %p(SPECIALIZE INLINE (:: !: (-> (Lst (, a b)) Int (, a b)))) (:: main (IO ())) (= main unpackprgm) ================================================ FILE: finkel-kernel/test/data/syntax/2002-bang.hs ================================================ ;;;; Bang patterns %p(LANGUAGE BangPatterns) (:: bp01 (-> Int Int Int)) (= bp01 !a !b (+ a b)) (:: bp02 (-> (, Int Int) (IO ()))) (= bp02 (, !a b) (print (if (even a) b a))) (:: bp03 (-> Int (IO ()))) (= bp03 n (let ((= !x (* n 2)) (= f i (, () (replicate i ()))) (= (, !y _) (f n))) (>> (print x) (print y)))) (:: bp04 (-> Int (IO ()))) (= bp04 n (let ((:: f (-> a [a])) (= f x [x x x])) (case (f n) !ys (print (length ys))))) (:: bp05 (-> Int (IO ()))) (= bp05 n (let ((= ![x y] (replicate 2 n)) (= !(, a b) (, n n))) (do (print (+ x y)) (print (+ a b))))) (:: bp06 (-> Int (IO ()))) (= bp06 !name-with-hyphens (print name-with-hyphens)) (:: non-bp01 (-> Int (IO ()))) (= non-bp01 n (let ((= ! a b (+ a b))) (print (! n (+ n 2))))) (:: main (IO ())) (= main (do (print (bp01 10 32)) (bp02 (, 21 42)) (bp03 21) (bp04 21) (bp05 21) (non-bp01 20))) ================================================ FILE: finkel-kernel/test/data/syntax/2003-derive.hs ================================================ ;;;; DeriveXXX language extensions %p(LANGUAGE DeriveDataTypeable DeriveFoldable DeriveGeneric DeriveTraversable GeneralizedNewtypeDeriving) (module Main) (import Data.Data) (import GHC.Generics) ;;; DeriveDataTypeable (data (D1 a) (D1 a a) (deriving Eq Show Data Typeable)) ;;; DeriveFunctor (data (D2 a) (D2 a) (deriving Eq Show Functor)) ;;; DeriveGeneric (data (D3 a) (D3 a) (deriving Eq Show Generic)) ;;; DeriveFoldable, DeriveTraversable (data (Lst a) Nil (Cons a (Lst a)) (deriving Eq Show Functor Foldable Traversable)) ;;; GeneralizedNewtypeDeriving (newtype (N a) (N a) (deriving Eq Show Num)) (:: main (IO ())) (= main (do (print (typeOf (D1 True False))) (print (dataTypeOf (D1 #'a #'b))) (print (fmap succ (D2 (:: 41 Int)))) (print (from (D3 False))) (let ((:: l1 (Lst Int)) (= l1 (Cons 1 (Cons 2 (Cons 3 Nil)))))) (print (foldr + 0 l1)) (sequence_ (fmap print l1)) (let ((:: l1 (Lst Int)) (= l1 (Cons 1 (Cons 2 (Cons 3 Nil)))))) (print (foldr + 0 l1)) (sequence_ (fmap print l1)) (print (+ (N (:: 20 Int)) (N 22))))) ================================================ FILE: finkel-kernel/test/data/syntax/2004-overloaded.hs ================================================ ;;;; OverloadedXXX language extensions %p(LANGUAGE OverloadedLists OverloadedStrings) (module Main) (import Data.ByteString ((ByteString))) (import Data.Set ((Set))) ;;; OverloadedString (:: f1 ByteString) (= f1 "foo") ;;; OverloadedLists (:: f2 (Set Char)) (= f2 [#'a #'e #'i #'o #'u]) ;;; Main (:: main (IO ())) (= main (do (print f1) (print f2))) ================================================ FILE: finkel-kernel/test/data/syntax/2005-gadts-01.hs ================================================ ;;; GADTs %p(LANGUAGE GADTs KindSignatures RankNTypes) (module Main) (import Data.Kind) (data (Expr a) (:: I (-> Int (Expr Int))) (:: B (-> Bool (Expr Bool))) (:: Add (-> (Expr Int) (Expr Int) (Expr Int))) (:: Mul (-> (Expr Int) (Expr Int) (Expr Int))) (:: Eq (=> (Eq a) (-> (Expr a) (Expr a) (Expr Bool))))) (:: eval (-> (Expr a) a)) (= eval e (case e (I n) n (B b) b (Add x y) (+ (eval x) (eval y)) (Mul x y) (* (eval x) (eval y)) (Eq x y) (== (eval x) (eval y)))) (:: gadt1 (IO ())) (= gadt1 (print (eval (Eq (Mul (Add (I 10) (I 11)) (I 2)) (I 42))))) ;; GADTs with UNPACK pragmas. (data (G2 a) (:: G2a (-> !(Maybe a) (G2 a))) (:: G2b (-> %p(UNPACK) !Int (G2 Int))) (:: G2c (-> !a %p(UNPACK) !Int (G2 a)))) (instance (=> (Show a) (Show (G2 a))) (= show (G2a a) (concat ["G2a (" (show a) ")"])) (= show (G2b a) (concat ["G2b (" (show a) ")"])) (= show (G2c a b) (concat ["G2c (" (show a) " " (show b) ")"]))) (:: gadt2 (-> Int (IO ()))) (= gadt2 n (do (print (G2a (Just #'x))) (print (G2b n)) (print (G2c n 43)))) ;; GADTs with documentation comments. (:doc "Documentation for top level `G3' data type declaration.") (data (G3 a) (:doc "Documentation for `G3a'.") (:: G3a (-> a (G3 a))) (:doc "Documentation for `G3Int'") (:: G3Int (-> Int (:doc^ "An integer number.") (G3 Int)))) (:doc "Documentation for `Show' instance of `G3'.") (instance (=> (Show a) (Show (G3 a))) (= show g3 (case g3 (G3a a) (++ "G3a" (show a)) (G3Int n) (++ "G3Int " (show n))))) (:: gadt3 (-> Int (IO ()))) (= gadt3 n (do (print (G3a True)) (print (G3Int n)))) ;;; GADTs with `deriving' (data (Maybe1 a) (:: Nothing1 (Maybe1 a)) (:: Just1 (-> a (Maybe1 a))) (deriving Eq Show)) (:: gadt4 (-> Int (IO ()))) (= gadt4 n (print [Nothing1 (Just1 n)])) ;;; XXX: GADTs with multiple constructors with single signature ;; (data Multi ;; (:: (MA MB) Multi) ;; (:: MC (-> Int Multi))) ;;; XXX: GADTs with record syntax ;; (data Person ;; (:: Adult (-> {name String children [Person]} Person)) ;; (:: Child (=> (Show a) (-> {name !String funny a} Person)))) ;; (:: gadt5 (-> Int (IO ()))) ;; (= gadt5 n ;; (do (let ((= adult (Adult {name "foo" children [child]})) ;; (= child (Chilc [name "bar" funny n])))) ;; (putStrLn (name adult)) ;; (putStrLn (name child)) ;; (mapM_ (. print funny) (children adult)))) ;;; GADTs with kind signature (data Ze) (data (Su n)) (data (:: Vec (-> Type Type Type)) (:: Nil (Vec a Ze)) (:: Cons (-> a (Vec a n) (Vec a (Su n))))) ;;; GADT and RankNTypes (data (Equal a b) (:: Refl (Equal a a))) (:: subst (-> (Equal a b) (=> (~ a b) r) r)) (= subst Refl r r) ;;; Main function (:: main (IO ())) (= main (do gadt1 (gadt2 42) (gadt3 42) (gadt4 42))) ================================================ FILE: finkel-kernel/test/data/syntax/2005-gadts-02.hs ================================================ ;;; GADTs with unusable UNPACK pragmas. %p(LANGUAGE GADTs) (module Main) (data (G2 a) (:: G2a (-> %p(UNPACK) !(Maybe a) (G2 a))) (:: G2b (-> %p(UNPACK) !Int (G2 Int))) (:: G2c (-> %p(UNPACK) !a %p(UNPACK) !Int (G2 a)))) (instance (=> (Show a) (Show (G2 a))) (= show (G2a a) (concat ["G2a (" (show a) ")"])) (= show (G2b a) (concat ["G2b (" (show a) ")"])) (= show (G2c a b) (concat ["G2c (" (show a) " " (show b) ")"]))) (:: gadt2 (-> Int (IO ()))) (= gadt2 n (do (print (G2a (Just #'x))) (print (G2b n)) (print (G2c n 43)))) (:: main (IO ())) (= main (gadt2 42)) ================================================ FILE: finkel-kernel/test/data/syntax/2006-existential.hs ================================================ ;;;; Existential Quantification language extension %p(LANGUAGE ExistentialQuantification) (module Main) (data AnyShow1 (forall a (=> (Show a) (AnyShow1 a)))) (instance (Show AnyShow1) (= show (AnyShow1 a) (concat ["(AnyShow " (show a) ")"]))) (data AnyShow2 (forall a b (=> (Show a) (Show b) (AnyShow2 {(:: as2a a) (:: as2b b)})))) (instance (Show AnyShow2) (= show (AnyShow2 {(= as2a a) (= as2b b)}) (concat ["(AnyShow2 " (show a) " " (show b) ")"]))) (data (AnyShow3 a) (=> (Show a) AnyShow3)) (:: show3 (-> (AnyShow3 a) a String)) (= show3 AnyShow3 a (show a)) (:: main (IO ())) (= main (do (print [(AnyShow1 (:: 42 Int)) (AnyShow1 False) (AnyShow1 #'x)]) (print [(AnyShow2 (:: 42 Int) (:: 43 Integer)) (AnyShow2 False (Just #'x)) (AnyShow2 #'x "bar")]) (print (show3 AnyShow3 True)))) ================================================ FILE: finkel-kernel/test/data/syntax/2007-rankn.hs ================================================ ;;;; RankNTypes %p(LANGUAGE RankNTypes) (module Main) (:: f3 (-> (forall a (-> a a)) (, Char Bool))) (= f3 f (, (f #'a) (f True))) (:: main (IO ())) (= main (print (f3 id))) ================================================ FILE: finkel-kernel/test/data/syntax/2008-options.hs ================================================ ;;;; OPTIONS_GHC and OPTIONS_HADDOCK pragma. %p(LANGUAGE DeriveFoldable) %p(OPTIONS_GHC -Wall) %p(LANGUAGE DeriveFunctor) %p(OPTIONS_HADDOCK prune) %p(OPTIONS_GHC -fspec-constr-keen) %p(LANGUAGE GeneralizedNewtypeDeriving) (module Main) (:: main (IO ())) (= main (putStrLn "File with OPTIONS_GHC")) ================================================ FILE: finkel-kernel/test/data/syntax/2009-flexible.hs ================================================ ;;;; Flexible instance related language extension and overlap pragmas %p(LANGUAGE FlexibleContexts FlexibleInstances MultiParamTypeClasses NoMonomorphismRestriction TypeSynonymInstances) (module Main) ;;; Multi param type classes (class (C1 m a b) (:: c1 (-> (m a) (m b) (IO ())))) (instance (C1 IO Bool Char) (= c1 a b (do (<- a' a) (<- b' b) (putStrLn (concat ["c1: " (show a') ", " (show b')]))))) ;;; Flexible instances ;; Use of `Either String' requires `FlexibleInstances'. (instance (C1 (Either String) Bool Char) (= c1 a b (where (f a b) (= f (Right b1) (Right b2) (pr (show b1) (show b2))) (= f (Right b1) (Left s2) (pr (show b1) s2)) (= f (Left s1) (Right b2) (pr s1 (show b2))) (= f (Left s1) (Left s2) (pr s1 s2)) (= pr x y (putStrLn (concat ["c1: " x ", " y])))))) ;;; Flexible contexts (class (C2 a b) (:: c2 (-> a b))) (instance (C2 Bool String) (= c2 bool (++ "bool: " (show bool)))) (:: c2str (=> (C2 a String) (-> a String))) (= c2str c2) ;;; GHC Extension: overlap mode (instance %p(OVERLAPS) (=> (Show a) (C2 a String)) (= c2 show)) (class (C2b a b) (:: c2b (-> a b))) (instance (C2b Bool String) (= c2b bool (++ "[c2b] bool:" (show bool)))) (instance %p(OVERLAPPABLE) (=> (Show a) (C2b a String)) (= c2b (. (++ "[c2b] ") show))) (class (C2c a b) (:: c2c (-> a b))) (instance %p(OVERLAPPING) (C2c Bool String) (= c2c bool (++ "[c2c] bool:" (show bool)))) (instance (=> (Show a) (C2c a String)) (= c2c (. (++ "[c2c] ") show))) (class (C2d a b) (:: c2d (-> a b))) (instance (C2d Bool String) (= c2d bool (++ "[c2d] bool:" (show bool)))) (instance %p(INCOHERENT) (=> (Show a) (C2d a String)) (= c2d (. (++ "[c2d] ") show))) ;;;; NoMonomorphismRestriction and TypeSynonymInstances (class (C3 a) (:: int (-> Int a)) (:: add (-> a a a))) (instance (C3 String) (= int show) (= add a b (concat ["(" a " + " b ")"]))) (= c3-f1 (add (int 1) (add (int 2) (int 3)))) ;;; Main (:: main (IO ())) (= main (do (c1 (:: (return False) (IO Bool)) (return #'x)) (c1 (:: (return True) (Either String Bool)) (return #'y)) (let ((:: n Int) (= n 42))) (putStrLn (c2str True)) (putStrLn (c2str n)) (putStrLn (c2b True)) (putStrLn (c2b n)) (putStrLn (c2c True)) (putStrLn (c2c n)) (putStrLn (c2d True)) (putStrLn (c2d n)) (putStrLn c3-f1) (putStrLn (add (add (int 1) (int 2)) (add (int 3) (int 4)))))) ================================================ FILE: finkel-kernel/test/data/syntax/2010-kindsig.hs ================================================ ;;;; Kind signatues %p(LANGUAGE ExplicitForAll KindSignatures MultiParamTypeClasses) (module Main) (import Data.Kind ((Type))) (data (KS1 (:: m (-> Type Type)) a) (KS1 [a])) (data (KS2 (:: m (-> * *)) a) (KS2 [a])) (newtype (KS3 (:: m (-> Type Type)) a) (KS3 [a]) (deriving Show)) (type (KS4 (:: f (-> Type Type))) (f Int)) (class (KS5 (:: f (-> Type Type)) a) (:: ks5 (-> (f Int) a))) (:: f_ks1 (-> (:: Int Type) Int)) (= f_ks1 (+ 1)) (:: f_ks2 (forall (:: a *) (-> a a))) (= f_ks2 x x) (:: f_ks3 (forall a (-> a (:: a Type)))) (= f_ks3 x x) (:: f_ks4 (forall (:: a *) (:: b *) (-> a b a))) (= f_ks4 x _ x) (:: main (IO ())) (= main (do (case (KS1 [(:: 1 Int) 2 3]) (KS1 xs) (print xs)) (case (KS2 [(:: 4 Int) 5 6]) (KS2 xs) (print xs)) (print (KS3 [(:: 7 Int) 8 9])) (print (:: (Just 42) (KS4 Maybe))) (print (f_ks1 41)) (print (f_ks2 "f_ks2")) (print (f_ks3 "f_ks3")) (print (f_ks4 "f_ks4" undefined)))) ================================================ FILE: finkel-kernel/test/data/syntax/2011-scoped.hs ================================================ ;;;; Scoped Type Variable %p(LANGUAGE ScopedTypeVariables) (data Zero) (data (Succ n)) (type One (Succ Zero)) (type Two (Succ One)) (type Four (Succ (Succ Two))) (type Six (Succ (Succ Four))) (type Eight (Succ (Succ Six))) (class (Nat n) (:: toInt (-> n Int))) (instance (Nat Zero) (= toInt _ 0)) (instance (=> (Nat n) (Nat (Succ n))) (= toInt _ (+ 1 (toInt (:: undefined n))))) (:: f_stv01 (IO ())) (= f_stv01 (print (map (\ (:: x Int) (+ x 1)) [1 2 3]))) (:: f_stv02 (forall a (-> [a] [a]))) (= f_stv02 xs (where ys (:: ys [a]) (= ys (reverse xs)))) (class (STVC a) (:: stv_op (-> [a] (Maybe a))) (= stv_op xs (case (reverse xs) (: x _) (Just x) [] Nothing))) (instance (=> (STVC b) (STVC [b])) (= stv_op xs (case (:: xs [[b]]) (: ys _) (Just (reverse ys)) [] Nothing))) (instance (STVC Bool)) (:: main (IO ())) (= main (do (print (toInt (:: undefined Four))) (print (toInt (:: undefined Eight))) f_stv01 (print (f_stv02 "abc")) (print (stv_op [True False False])))) ================================================ FILE: finkel-kernel/test/data/syntax/2012-typeop.hs ================================================ ;;;; Type operatos %p(LANGUAGE TypeOperators) ;;; Type operators, with and without operator expansions (data (:.+ a b) (:.+ a b) (deriving Eq Show)) (infixl 6 :.+) (:: to01a (-> (:.+ (:.+ Int Int) Int) (IO ()))) (= to01a (:.+ a b c) (print (+ a b c))) (:: to01b (-> (:.+ Int Int Int) (IO ()))) (= to01b (:.+ a b c) (print (+ a b c))) (:: to01c (-> (:.+ Int (:.+ Int Int)) (IO ()))) (= to01c (:.+ a (:.+ b c)) (print (+ a b c))) (data (:+. a b) (:+. a b) (deriving Eq Show)) (infixr 6 :+.) (:: to02a (-> (:+. Int (:+. Int Int)) (IO ()))) (= to02a (:+. a b c) (print (+ a b c))) (:: to02b (-> (:+. Int Int Int) (IO ()))) (= to02b (:+. a b c) (print (+ a b c))) (:: to02c (-> (:+. (:+. Int Int) Int) (IO ()))) (= to02c (:+. (:+. a b) c) (print (+ a b c))) (data (:++ a b c) (:++ a b c) (deriving Eq Show)) ;; `:++' constructor takes three arguments, so surrounding with ;; parenthesis to avoid operator expansion. If no parenthesis, ;; below line would be expanded to: True :++ 'x' :++ "foo" (:: to03 (-> ((:++) Int Int Int) (IO ()))) (= to03 ((:++) a b c) (print (+ a b c))) (:: main (IO ())) (= main (do (to01a (:.+ 1 2 3)) (to01b (:.+ 1 2 3)) (to01c (:.+ 1 (:.+ 2 3))) (to02a (:+. 1 2 3)) (to02b (:+. 1 2 3)) (to02c (:+. (:+. 1 2) 3)) (to03 ((:++) 1 2 3)))) ================================================ FILE: finkel-kernel/test/data/syntax/2013-undecidable.hs ================================================ ;;;; UndecidableInstances, and some others. %p(LANGUAGE FlexibleInstances MonoLocalBinds UndecidableInstances) (module Main) (class (=> (Show a) (Monoid a) (ShowMonoid a))) (instance (=> (Show a) (Monoid a) (ShowMonoid a))) (:: showMonoid (=> (ShowMonoid a) (-> a String))) (= showMonoid x (concat [(show x) "(mempty=" (show (asTypeOf mempty x)) ")"])) (:: main (IO ())) (= main (do (putStrLn (showMonoid [(:: 1 Int) 2 3])) (putStrLn (showMonoid GT)))) ================================================ FILE: finkel-kernel/test/data/syntax/2014-noprelude.hs ================================================ ;;;; File containing NoImplicitPrelude. %p(LANGUAGE NoImplicitPrelude) %p(OPTIONS_GHC -Wall) (module Main) (import Prelude hiding (^ read)) (:: read (-> String Bool)) (= read "true" True) (= read _ False) (:: ^ (-> [a] [a] [a])) (= ^ ++) (:: main (IO ())) (= main (putStrLn (^ "(read true) ==> " (show (read "true"))))) ================================================ FILE: finkel-kernel/test/data/syntax/2015-typefam.hs ================================================ ;;;; File containing codes using `TypeFamiles' language extension %p(LANGUAGE TypeFamilies) (module Main) (import Data.Kind ((Type))) ;;; Data families (data family (:: (Gmap k) (-> * *))) (data family (T1 a)) (data instance (T1 Int) A1 (deriving Eq Show)) (newtype instance (T1 Char) (B1 Bool)) (data instance (T1 Double) (C1 Double) (C2 Int) (deriving Eq Show)) (class (T1C a) (:: t1c (-> (T1 a) Int))) (instance (T1C Int) (= t1c A1 1)) (instance (T1C Char) (= t1c (B1 _) 2)) (instance (T1C Double) (= t1c (C1 _) 3) (= t1c (C2 _) 4)) (:: t1c-insts (IO ())) (= t1c-insts (do (print (t1c A1)) (print (t1c (B1 False))) (print (t1c (C1 1))) (print (t1c (C2 1))))) ;;; Synonym families (type family (Elem c)) (type instance (Elem [e]) e) (type family (:: (TF1 a b) (-> Type Type))) ;; Closed type synonym family. (type family (TF3 a) (= (TF3 Int) Double) (= (TF3 Bool) Char) (= (TF3 a) String)) (:: ctfs1 (IO ())) (= ctfs1 (do (print (:: 3 (TF3 Int))) (print (:: #'x (TF3 Bool))) (print (:: "foo" (TF3 Char))))) ;;; Wildcards on the LHS of data and type family instances (data family (:: (DF1 a b) *)) (data instance (DF1 Int _) Int) (type family (:: (TF4 a) *)) (type instance (TF4 (, a _)) a) (type instance (TF4 (, a _ _)) a) (:: wc1 (IO ())) (= wc1 (do (print (:: 8 (TF4 (, Int Bool Char)))) (print (:: 9 (TF4 (, Double String)))))) ;;; Associated data and type familes (class (Collects1 ce) (type (:: (Entry1 ce) *))) (instance (=> (Eq e) (Collects1 [e])) (type (Entry1 [e]) e)) (class (Collects2 ce) (data (:: (Entry2 ce) *))) (instance (=> (Eq e) (Collects2 [e])) (data (Entry2 [e]) (E2 e))) (class (IsBoolMap v) (type (Key v)) (type instance (Key v) Int) (:: lookupKey (-> (Key v) v (Maybe Bool)))) (newtype IBAL (IBAL {(:: unIBAL [(, Int Bool)])})) (instance (IsBoolMap IBAL) (= lookupKey k (. (lookup k) unIBAL))) (:: at1 (IO ())) (= at1 (do (let ((= im (IBAL [(, 0 False) (, 1 True) (, 2 True)])))) (print (lookupKey 0 im)) (print (lookupKey 2 im)) (print (lookupKey 4 im)))) ;;; Equality constraint (:: ec1 (=> (IsBoolMap v1) (~ k1 (Key v1)) (IsBoolMap v2) (~ k2 (Key v2)) (-> k1 v1 k2 v2 (Maybe Bool)))) (= ec1 k1 v1 k2 v2 (| ((<- (Just b1) (lookupKey k1 v1)) (<- (Just b2) (lookupKey k2 v2)) (Just (&& b1 b2))) (otherwise Nothing))) ;;; Main function (:: main (IO ())) (= main (do t1c-insts ctfs1 wc1 at1)) ================================================ FILE: finkel-kernel/test/data/syntax/2016-datakinds.hs ================================================ ;;;; File containing codes using `DataKinds' language extension %p(LANGUAGE DataKinds GADTs KindSignatures MultiParamTypeClasses RankNTypes TypeFamilies TypeOperators) ;;; Ghc <= 8.4 need `FlexibleInstances' language extension for instance ;;; declarations of `Has' type class. %p(LANGUAGE FlexibleInstances) (module Main) ;; base (import Data.Proxy ((Proxy ..))) (import Data.Kind ((Type))) ;;; XXX: Need "ExplicitNamespace" extension. ;; (import GHC.TypeLits ((Symbol) natVal (type +)) (import GHC.TypeLits) ;; finkel-kernel (import Language.Finkel) ;;; Value-level quoted symbols (:: quoted-1 (IO ())) (= quoted-1 (do (print 'foo) (print 'bar))) (:: quoted-2 (IO ())) (= quoted-2 (do (print '[]) (print '(, a b c)))) ;;; Overview (data Na Ze (Su Na)) (data (Vec (:: a Type) (:: n Na)) (:: Nil (Vec a 'Ze)) (:: Cons (-> a (Vec a n) (Vec a ('Su n))))) ;;; Alternative syntax (data (:: Vec2 (-> Type Na Type)) (:: Nil2 (Vec2 a 'Ze)) (:: Cons2 (-> a (Vec2 a n) (Vec2 a ('Su n))))) ;;; Another alternative syntax (data (:: (Vec3 (:: a Type)) (-> Na Type)) (:: Nil3 (Vec3 a 'Ze)) (:: Cons3 (-> a (Vec3 a n) (Vec3 a ('Su n))))) ;;; Promoted list and tuple types ;; HList (data (:: HList (-> [Type] Type)) (:: HNil (HList '[])) (:: HCons (-> a (HList as) (HList (': a as))))) (:: foo0 (HList '[])) (= foo0 HNil) (:: foo1 (HList '[Int])) (= foo1 (HCons (:: 3 Int) foo0)) ;; Explicit quote is required for promoted list. (:: foo2 (HList '[Bool Int])) (= foo2 (HCons True foo1)) (:: print-foo2 (IO ())) (= print-foo2 (case foo2 (HCons a (HCons b HNil)) (putStrLn (++ "foo2: [" (show a) " " (show b) "]")))) ;; Tuple (data (:: Tuple (-> (, Type Type) Type)) (:: Tuple (-> a b (Tuple '(, a b))))) ;;; Promoting existential data constructors (data (:: Ex Type) (:: MkEx (forall a (-> a Ex)))) (type family (UnEx (:: ex Ex))) (type instance (UnEx ('MkEx ex)) ex) (:: print-ex (IO ())) (= print-ex (let ((:: ex (UnEx ('MkEx Bool))) (= ex True)) (print ex))) ;;; Type-Level literals (data (Label (:: l Symbol)) Get) (class (Has a l) (type (Res a l)) (:: from (-> a (Label l) (Res a l)))) (data Point (Point Int Int) (deriving (Show))) (instance (Has Point "x") (type (Res Point "x") Int) (= from (Point x _) _ x)) (instance (Has Point "y") (type (Res Point "y") Int) (= from (Point _ y) _ y)) (:: tylit-syms (IO ())) (= tylit-syms (do (let ((= p (Point 12 34)))) (print (from p (:: Get (Label "x")))) (print (from p (:: Get (Label "y")))))) (:: tylit-nats-simple (IO ())) (= tylit-nats-simple (do (print (natVal (:: Proxy (Proxy 1)))) (print (natVal (:: Proxy (Proxy 2)))))) (:: tylit-nats-with-op (IO ())) (= tylit-nats-with-op (do (print (natVal (:: Proxy (Proxy (+ 1 2))))) (print (natVal (:: Proxy (Proxy (+ 3 4))))))) ;;; Using same names in type constructor and data constructor (data Bar Bar) (type family (:: (Buzz (:: a Bool)) Bar) (= (Buzz 'True) 'Bar)) ;;; The main function (:: main (IO ())) (= main (do (putStrLn ";;; datakinds ;;;") quoted-1 quoted-2 print-foo2 print-ex tylit-syms tylit-nats-simple)) ================================================ FILE: finkel-kernel/test/data/syntax/2017-polykinds.hs ================================================ ;;;; File containing codes using `PolyKinds' language extension %p(LANGUAGE DataKinds GADTs PolyKinds RankNTypes TypeFamilies TypeOperators) ;; ghc-8.2.x and 8.4.x requires `TypeInType' extension. %p(LANGUAGE TypeInType) (module Main) (import Data.Kind ((Type))) (data (App f a) (MkApp (f a))) (:: a1 (App Maybe Int)) (= a1 (MkApp (Just 42))) (data (T a) (MkT (a Int))) (:: a2 (App T Maybe)) (= a2 (MkApp (MkT (Just 42)))) (:: print-a2 (IO ())) (= print-a2 (case a2 (MkApp (MkT ji)) (print ji))) (type family (F1 a) (= (F1 'True) 'False) (= (F1 'False) 'True) (= (F1 x) x)) (type family (:: (F3 (:: a Bool)) Bool) (= (F3 'True) 'False) (= (F3 'False) 'True)) (data (Proxy a) Proxy (deriving Eq Show)) (:: print-f3 (IO ())) (= print-f3 (let ((:: x (Proxy (F3 'True))) (= x Proxy)) (print x))) (class (HTestEquality (:: t (forall k (-> k Type)))) (:: hTestEquality (forall k1 k2 (:: a k1) (:: b k2) (-> (t a) (t b) (Maybe (:~~: a b)))))) (data (:: :~~: (forall k1 (-> k1 (forall k2 (-> k2 Type))))) (:: HRefl (:~~: a a))) (instance (HTestEquality ((:~~:) a)) (= hTestEquality HRefl HRefl (Just HRefl))) ;;; Requires `PolyKinds' language extension. (type family (:: (TF2 a) k)) (type family (:: TF3 (-> k Type))) (:: main (IO ())) (= main (do (print-a2) (print-f3))) ================================================ FILE: finkel-kernel/test/data/syntax/2018-typeapp.hs ================================================ ;;;; File containing codes using `TypeApplications' language extension %p(LANGUAGE TypeApplications) (module Main) (:: main (IO ())) (= main (do (print (read @ Int "42")) (print (read @Double "1.23")) ; Without space after '@' (print (read @ (Maybe Bool) "Just True")) (print (foldr @ Maybe @ Int @ Int + 1 (Just 41))))) ================================================ FILE: finkel-kernel/test/data/syntax/2019-overlabel.hs ================================================ ;;;; File containing codes using `OverloadedLabels' language extension %p(LANGUAGE OverloadedLabels) ;;; ... and many other extensions too. %p(LANGUAGE DataKinds FlexibleContexts FlexibleInstances GADTs MultiParamTypeClasses PolyKinds ScopedTypeVariables TypeApplications UndecidableInstances) (module Main) (import Data.Proxy ((Proxy ..))) (import GHC.OverloadedLabels ((IsLabel ..))) (import GHC.Records ((HasField ..))) (import GHC.Types ((Type))) (data Person (Person {(:: person-name String)})) (instance %p(OVERLAPPABLE) (IsLabel "name" (-> Person String)) (= fromLabel person-name)) (data Item (Item {(:: item-name String)})) (instance %p(OVERLAPPABLE) (IsLabel "name" (-> Item String)) (= fromLabel item-name)) (:: ol01 (IO ())) (= ol01 (do (putStrLn (#name (Person "Alice"))) (putStrLn (#name (Item "Banana"))))) (data (Record (:: xs [(, k Type)])) (:: Nil (Record '[])) (:: Cons (-> (Proxy x) a (Record xs) (Record (': '(, x a) xs))))) (instance %p(OVERLAPPABLE) (HasField x (Record (': '(, x a) xs)) a) (= getField (Cons _ v _) v)) (instance %p(OVERLAPPABLE) (=> (HasField x (Record xs) a) (HasField x (Record (': '(, y b) xs)) a)) (= getField (Cons _ _ r) (getField @ x r))) (instance %p(OVERLAPPABLE) (=> (HasField x r a) (IsLabel x (-> r a))) (= fromLabel (getField @ x))) (:: r1 (Record '[ '(, "personId" Int) '(, "name" String)])) (= r1 (Cons Proxy 42 (Cons Proxy "R" Nil))) (:: i1 Int) (= i1 (getField @ "personId" r1)) (:: i2 Int) (= i2 (#personId r1)) (:: r2 (Record '[ '(, True Char) '(, False Char)])) (= r2 (Cons Proxy #'a (Cons Proxy #'b Nil))) (:: j1 Char) (= j1 (getField @ True r2)) (:: j2 Char) (= j2 (getField @ False r2)) (:: ol02 (IO ())) (= ol02 (putStrLn (++ "i1=" (show i1) ", i2=" (show i2) "\n" "j1=" (show j1) ", j2=" (show j1)))) (:: main (IO ())) (= main (do ol01 ol02)) ================================================ FILE: finkel-kernel/test/data/syntax/2020-emptyderiv.hs ================================================ ;;;; `EmptyDataDeriving' language extension %p(LANGUAGE EmptyDataDeriving) (module Main) (data Empty (deriving Eq Ord Show Read)) (:: main (IO ())) (= main (return ())) ================================================ FILE: finkel-kernel/test/data/syntax/2021-dfltsig.hs ================================================ ;;;; File containing codes using `DefaultSignatures' language extension %p(LANGUAGE DefaultSignatures) (module Main) (class (SPretty a) (:: sPpr (-> a String)) (default (:: sPpr (=> (Show a) (-> a String)))) (= sPpr show)) (instance (SPretty Bool)) (:: main (IO ())) (= main (putStrLn (sPpr False))) ================================================ FILE: finkel-kernel/test/data/syntax/2022-drvstrat.hs ================================================ ;;;; File containing codes using `DerivingStrategies' language extension %p(LANGUAGE DeriveAnyClass DerivingStrategies GeneralizedNewtypeDeriving) (module Main) (class (C a)) (newtype Buzz (Buzz Double) (deriving Eq Ord) (deriving stock Read Show) (deriving newtype Num Fractional Floating) (deriving anyclass C)) (:: main (IO ())) (= main (print (:: 42 Buzz))) ================================================ FILE: finkel-kernel/test/data/syntax/2023-standalone.hs ================================================ ;;;; File containing codes using `StandaloneDeriving' language extension %p(LANGUAGE DeriveAnyClass DerivingStrategies GeneralizedNewtypeDeriving StandaloneDeriving) (module Main) (class (C a)) (newtype (Foo a) (MkFoo Int)) (deriving instance (Eq (Foo a))) (deriving instance %p(OVERLAPPING) (Ord (Foo a))) (deriving stock instance (Show (Foo a))) (deriving stock instance %p(OVERLAPPABLE) (Read (Foo a))) (deriving newtype instance (Enum (Foo a))) (deriving newtype instance (Real (Foo a))) (deriving newtype instance %p(OVERLAPS) (Integral (Foo a))) (deriving newtype instance %p(INCOHERENT) (Num (Foo a))) (deriving anyclass instance (C (Foo a))) (:: main (IO ())) (= main (print (== (succ (:: 3 (Foo Char))) 4))) ================================================ FILE: finkel-kernel/test/data/syntax/2024-derivingvia.hs ================================================ ;;;; File containing codes using `DerivingVia' language extension %p(LANGUAGE DerivingVia DeriveFunctor GeneralizedNewtypeDeriving StandaloneDeriving) (module Main) (import Control.Applicative (liftA2)) (import Numeric (showHex)) (newtype (Hex a) (Hex a)) (instance (=> (Integral a) (Show a) (Show (Hex a))) (= show (Hex a) (++ "0x" (showHex a "")))) (newtype Unicode (U Int) (deriving Num via Int) (deriving Show via (Hex Int))) (:: euroSign Unicode) (= euroSign 0x20ac) (newtype (App f a) (App (f a)) (deriving newtype Functor Applicative)) (instance (=> (Applicative f) (Semigroup a) (Semigroup (App f a))) (= <> (liftA2 <>))) (instance (=> (Applicative f) (Monoid a) (Monoid (App f a))) (= mempty (pure mempty))) (data (Pair a) (MkPair a a) (deriving stock Functor) (deriving Semigroup Monoid via (App Pair a))) (instance (Applicative Pair) (= pure a (MkPair a a)) (= <*> (MkPair f g) (MkPair a b) (MkPair (f a) (g b)))) ;;; XXX: Following `Kleisli1' and `Kleisli2' examples are taken from ghc user ;;; guide documentation. It is shown in ghc 9.2.1 version of the documentation, ;;; but getting errors, not only in Finkel codes but in Haskell codes too. ;; (newtype (Kleisli m a b) (Kleisli (-> a (m b))) ;; (deriving Semigroup Monoid via (-> a (App m b)))) ;; ;; (newtype (Kleisli2 m a b) (Klsisli2 (-> a (m b)))) ;; ;; (deriving via (-> a (App m b)) instance ;; (=> (Applicative m) (Semigroup b) ;; (Semigroup (Kleisli2 m a b)))) ;; ;; (deriving via (-> a (App m b)) instance ;; (=> (Applicative m) (Monoid b) ;; (Monoid (Kleisli2 m a b)))) (:: main (IO ())) (= main (print euroSign)) ================================================ FILE: finkel-kernel/test/data/syntax/2025-namedfieldpuns.hs ================================================ ;;;; File containing code using `NamedFieldPuns' language extension %p(LANGUAGE NamedFieldPuns) (import Data.Monoid ((All All))) (import qualified Data.Monoid as M) (data C1 (C1 {(:: a Int)})) (data C2 (C2 {(:: b Int) (:: c Int) (:: d Int)})) (:: f1 (-> C1 (IO ()))) (= f1 (C1 {a}) (print a)) (:: f2 C1) (= f2 (let ((= a 100)) (C1 {a}))) (:: f3 (-> C2 Int)) (= f3 (C2 {b (= c 4)}) b) (= f3 _ 0) (:: f4 (-> All Bool)) (= f4 (All {M.getAll}) getAll) (:: main (IO ())) (= main (do (f1 f2))) ================================================ FILE: finkel-kernel/test/data/syntax/2026-recordwildcards.hs ================================================ ;;;; File containing code using `RecordWildCards' language extension %p(LANGUAGE RecordWildCards NamedFieldPuns) (import Data.Monoid ((All getAll))) (data C (C {(:: a b c d Int)}) (deriving Eq Show)) (= f1 (C {(= a 1) ..}) (+ b c d)) (= f1 _ 0) (= f2 (C {(= a 1) b ..}) (+ b c d)) (= f2 _ 1) (= e (C {(= a 111) (= b 222) (= c 333) (= d 444)})) (= f3 (let ((= (C {(= a 111) ..}) e)) [b c d])) (= f4 (let ((= a 12) (= b 34) (= c 56) (= d 78)) (C {..}))) (:: main (IO ())) (= main (do (let ((= c1 (C 1 2 3 4)))) (print (f1 c1)) (print (f2 c1)) (print f3) (print f4))) ================================================ FILE: finkel-kernel/test/data/syntax/2027-emptycase-1.hs ================================================ ;;;; File containing code using `EmptyCase' language extension %p(LANGUAGE EmptyCase) (data Void) (:: absurd (-> Void a)) (= absurd a (case a)) (:: main (IO ())) (= main (putStrLn "EmptyCase language extension")) ================================================ FILE: finkel-kernel/test/data/syntax/2027-emptycase-2.hs ================================================ ;;; -*- mode: finkel -*- %p(LANGUAGE EmptyCase DataKinds KindSignatures GADTs) %p(OPTIONS_GHC -Werror=incomplete-patterns) (import Data.Kind (Type)) ;; Types (data D O C L) (data (:: SD (-> D Type)) (:: SO (SD 'O)) (:: SC (SD 'C)) (:: SL (SD 'L))) (data (:: K (-> D Type)) (:: KC (K 'C)) (:: KL (K 'L))) (data Void) (data (Decision a) (Proved a) (Disproved (-> a Void))) ;; Function (:: isA (-> (SD s) (Decision (K s)))) (= isA s (case s SO (Disproved (\x (case x))) SC (Proved KC) SL (Proved KL))) (:: main (IO ())) (= main (let ((= f s (putStrLn (case (isA s) (Proved _) "Proved" (Disproved _) "Disproved")))) (do (f SO) (f SC) (f SL)))) ================================================ FILE: finkel-kernel/test/data/syntax/2028-standalonekind.hs ================================================ ;;;; File containing codes using `Standalonekindsignatures' language extension %p(LANGUAGE StandaloneKindSignatures) (module Main) (import Data.Kind) (type (:: MyMaybe (-> Type Type))) (data (MyMaybe a) MyNothing (MyJust a) (deriving Eq Show)) (:: main (IO ())) (= main (do (print (MyJust False)) (print (:: MyNothing (MyMaybe Int))))) ================================================ FILE: finkel-kernel/test/data/syntax/2029-impredicative.hs ================================================ ;;; -*- mode: finkel -*- ;;; File containing codes using `ImpredicativeTypes' language extension. ;;; According to the ghc documentation, the `ImpredicativeTypes' extension did ;;; exist since ghc 6.10, but was unreliable until ghc 9.2. %p(LANGUAGE ImpredicativeTypes) (module Main) (:: f (-> (Maybe (forall a (-> [a] [a]))) (Maybe (, [Int] [Char])))) (= f (Just g) (Just (, (g [1 2 3]) (g "hello")))) (= f Nothing Nothing) (= main (print (f (Just reverse)))) ================================================ FILE: finkel-setup/LICENSE ================================================ Copyright (c) 2017-2022, 8c6794b6 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: finkel-setup/README.md ================================================ # finkel-setup Auxiliary package containing `Setup.hs` related functions for building cabal packages with Finkel. See the [documentation][doc] for more details. [doc]: https://finkel.readthedocs.io/en/latest/ ================================================ FILE: finkel-setup/Setup.hs ================================================ import Distribution.Simple main = defaultMain ================================================ FILE: finkel-setup/finkel-setup.cabal ================================================ cabal-version: 2.0 name: finkel-setup version: 0.0.0 synopsis: Cabal setup script helper for Finkel description: Cabal setup script helper for Finkel . See the for more info. homepage: https://github.com/finkel-lang/finkel#readme license: BSD3 license-file: LICENSE author: 8c6794b6 maintainer: 8c6794b6@gmail.com copyright: 2017-2022 8c6794b6 category: Language build-type: Simple extra-source-files: README.md -- test/data/p01/LICENSE test/data/p01/p01.cabal test/data/p01/Setup.hs test/data/p01/exec/p01.hs test/data/p01/src/P01/*.fnk test/data/p01/src/P01/*.hs test/data/p01/test/*.fnk test/data/p01/test/*.hs -- test/data/p02/LICENSE test/data/p02/CHANGELOG.md test/data/p02/p02.cabal test/data/p02/Setup.hs test/data/p02/app/Main.hs test/data/p02/src/MyLib.hs test/data/p02/test/Main.hs tested-with: GHC == 8.10.7 , GHC == 9.0.1 , GHC == 9.2.8 , GHC == 9.4.6 , GHC == 9.6.5 , GHC == 9.8.2 , GHC == 9.10.1 library hs-source-dirs: src exposed-modules: Distribution.Simple.Finkel build-depends: Cabal >= 3.2 && < 3.13 , base >= 4.14 && < 5 , directory >= 1.3.0 && < 1.4 , filepath >= 1.4.1 && < 1.6 default-language: Haskell2010 ghc-options: -Wall test-suite finkel-setup-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs build-depends: base , directory , filepath , finkel-kernel , finkel-setup -- , ghc >= 8.10.0 && < 9.11 , hspec >= 2.4.8 && < 2.12 build-tool-depends: fkc:fkc , fnkpp:fnkpp ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 -- Skipping this test under Windows, since it's too slow. if os(windows) buildable: False source-repository head type: git location: https://github.com/finkel-lang/finkel.git subdir: finkel-setup ================================================ FILE: finkel-setup/src/Distribution/Simple/Finkel.hs ================================================ -- | Module exporting utilities to work with cabal's @Setup.hs@ script. {-# LANGUAGE CPP #-} module Distribution.Simple.Finkel ( -- * Main functions fnkMain , finkelMakeMain , fnkMainWith -- * Haddock for plugin , fnkPluginMainForHaddock -- * UserHooks , fnkHooksWith -- * Suffix handler , finkelPPHandler -- * Reexport from Cabal , UserHooks , defaultMainWithHooks ) where -- base import Control.Exception (bracket_) import Control.Monad (foldM, mapAndUnzipM, when) import Data.Foldable (toList) import Data.Function (on) import Data.List (unionBy) -- filepath import System.FilePath ((<.>), ()) -- Cabal import Distribution.ModuleName (toFilePath) import Distribution.PackageDescription import Distribution.Simple import Distribution.Simple.BuildPaths (autogenComponentModulesDir) import Distribution.Simple.Configure (configure, findDistPrefOrDefault) import Distribution.Simple.Haddock (haddock) import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess import Distribution.Simple.Program import Distribution.Simple.Program.GHC import Distribution.Simple.Program.Types import Distribution.Simple.Register (internalPackageDBPath) import Distribution.Simple.Setup import Distribution.Simple.Utils (installDirectoryContents) import Distribution.Utils.NubList #if MIN_VERSION_Cabal(3,5,0) import Distribution.Utils.Path (getSymbolicPath) #endif #if MIN_VERSION_Cabal(2,4,0) import Distribution.Types.ExposedModule #else import Distribution.InstalledPackageInfo #endif import qualified Distribution.Simple.Setup as Setup import qualified Distribution.Verbosity as Verbosity -- directory import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, findFile, getTemporaryDirectory, removeDirectoryRecursive, removeFile) -- -------------------------------------------------------------------- -- -- Main functions -- -- ------------------------------------------------------------------------ -- | Main function using /fkc/ executable. -- -- This acton uses the /fkc/ executable found on system when building -- a package. fnkMain :: IO () fnkMain = rawFnkMain "fkc" [] False -- | Main function using /finkel/ executable with /make/ subcommand. -- -- This action uses the /finkel/ executable found on system when -- building a package. finkelMakeMain :: IO () finkelMakeMain = rawFnkMain "finkel" ["make"] False -- | Main function with given executable name and arguments passed to -- the executable. fnkMainWith :: String -- ^ Executable name. -> [String] -- ^ Args passed to the executable. -> IO () fnkMainWith exe args = rawFnkMain exe args False -- | Run main using 'fnkHooksWith' and given executable. rawFnkMain :: String -- ^ Executable -> [String] -- ^ Argument passed to the executable. -> Bool -- ^ Debug flag -> IO () rawFnkMain exec args debug = defaultMainWithHooks (fnkHooksWith exec args debug) -- | Main function for generating haddock when building with finkel plugin. fnkPluginMainForHaddock :: IO () fnkPluginMainForHaddock = defaultMainWithHooks my_hooks where my_hooks = simpleUserHooks {haddockHook = my_haddock_hook} my_haddock_hook pd lbi _user_hooks flags = do let search_path = getProgramSearchPath (withPrograms lbi) mb_fnkpp <- findProgramOnSearchPath Verbosity.verbose search_path "fnkpp" let fnkpp_path = maybe "fnkpp" fst mb_fnkpp flags' = append_args fnkpp_path flags haddock pd lbi knownSuffixHandlers flags' append_args fnkpp flags = let orig_args = filter ((== "ghc") . fst) $ haddockProgramArgs flags my_args = ["-F", "-pgmF", fnkpp, "-optF", "--no-warn-interp"] merged_args = case orig_args of (_, args):_ -> args <> my_args [] -> my_args in flags {haddockProgramArgs = [("ghc", merged_args)]} -- --------------------------------------------------------------------- -- -- UserHooks -- ----------------------------------------------------------------------- -- | Make user hooks from compiler executable and extra arguments to the -- executable. fnkHooksWith :: FilePath -- ^ Compiler executable. -> [String] -- ^ Extra arguments to the executable. -> Bool -- ^ Debug flag. -> UserHooks fnkHooksWith exec args debug = simpleUserHooks { hookedPreProcessors = finkelPPHandler : knownSuffixHandlers , confHook = fnkConfHookWith exec args debug , haddockHook = fnkHaddockHooks } -- --------------------------------------------------------------------- -- -- Auxiliary -- -- --------------------------------------------------------------------- -- | Preprocessor suffix handler to merely register files with @"*.fnk"@ -- files. finkelPPHandler :: PPSuffixHandler finkelPPHandler = (suffix, doNothingPP) where #if MIN_VERSION_Cabal(3,12,0) suffix = Suffix "fnk" #else suffix = "fnk" #endif doNothingPP _ _ _ = PreProcessor { platformIndependent = True #if MIN_VERSION_Cabal(3,8,0) , ppOrdering = unsorted #endif , runPreProcessor = mkSimplePreProcessor (\_ _ _ -> return ()) } fnkConfHookWith :: FilePath -- ^ Path to Finkel compiler. -> [String] -- ^ Extra default args to the Finkel -- compiler. -> Bool -- ^ Flag for debug. -> (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo fnkConfHookWith fnk extra_args debug (pkg_descr, hbi) cflags = do lbi <- configure (pkg_descr, hbi) cflags return (overrideGhcAsFnk fnk extra_args debug lbi) -- | Update @ghc@ program in 'LocalBuildInfo'. overrideGhcAsFnk :: FilePath -- ^ Path to Finkel compiler. -> [String] -- ^ Extra default args. -> Bool -- ^ Debug flag. -> LocalBuildInfo -> LocalBuildInfo overrideGhcAsFnk fnk extra_args debug lbi = lbi' where lbi' = lbi {withPrograms = updateProgram ghc (withPrograms lbi)} ghc = case lookupProgram (simpleProgram "ghc") (withPrograms lbi) of Just ghc_orig -> ghc_orig { programLocation = FoundOnSystem fnk, programDefaultArgs = extra_args ++ programDefaultArgs ghc_orig, programOverrideArgs = programOverrideArgs ghc_orig ++ finkelflags } Nothing -> (simpleConfiguredProgram "ghc" (FoundOnSystem fnk)) { programDefaultArgs = extra_args, programOverrideArgs = finkelflags } finkelflags = debugs debugs = ["--fnk-debug"|debug] -- | Haddock hooks for Finkel. Generates and cleans up Haskell source -- codes from Finkel files during documentation generation. fnkHaddockHooks :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO () fnkHaddockHooks pd lbi hooks flags = do (acquires, cleanups) <- mapAndUnzipM gen_hs_sources clbis bracket_ (sequence_ acquires) (sequence_ cleanups) (haddock pd lbi pps flags) where pps = allSuffixHandlers hooks clbis = toList (componentGraph lbi) gen_hs_sources clbi = do let name = componentLocalName clbi comp = getComponent pd name bi = componentBuildInfo comp cflags = configFlags lbi verbosity = case configVerbosity cflags of Setup.Flag v -> v NoFlag -> Verbosity.normal autogen_dir = autogenComponentModulesDir lbi clbi pkg_dbs = withPackageDB lbi pkgs = componentIncludes clbi hs_src_dirs = hsSourceDirs bi other_mods = otherModules bi distPref <- findDistPrefOrDefault (configDistPref cflags) let internal_pkg_db = SpecificPackageDB (internalPackageDBPath lbi distPref) (hs_mods, hs_insts, hs_files) <- case comp of CLib {} -> do let ms = componentExposedModules clbi is = componentInstantiatedWith clbi ms' = foldr f [] ms where f em acc = case exposedReexport em of Nothing -> exposedName em : acc Just _ -> acc return (ms' ++ other_mods, is, []) CExe exe -> do let path = modulePath exe return (other_mods, [], [path]) _ -> return (other_mods, [], []) let opts dir = mempty { ghcOptMode = flag GhcModeMake , ghcOptExtra = optExtras dir , ghcOptInputFiles = toNubListR hs_files , ghcOptInputModules = toNubListR hs_mods , ghcOptSourcePathClear = flag True , ghcOptSourcePath = toNubListR hs_src_dirs' , ghcOptInstantiatedWith = hs_insts , ghcOptPackageDBs = pkg_dbs ++ [internal_pkg_db] , ghcOptPackages = toNubListR pkgs , ghcOptHideAllPackages = flag True , ghcOptNoLink = flag True } hs_src_dirs' = map getSymbolicPath hs_src_dirs ++ [autogen_dir] flag = Setup.Flag cmpl = compiler lbi platform = hostPlatform lbi accumulateGeneratedFile acc m = do let p = toFilePath m hs_src_dir_paths = map getSymbolicPath hs_src_dirs mb_found <- findFile hs_src_dir_paths (p <.> "fnk") case mb_found of Just _found -> do let dest = autogen_dir p <.> "hs" return (dest:acc) Nothing -> return acc -- Using package name as prefix of temporary directory, to support -- concurrent build of packages. makeTemporaryDirectory = do tmpdir <- getTemporaryDirectory let dir = tmpdir pre cmp_name cmp_name = remove_quotes $ replace_spaces (showComponentName name) replace_spaces = map space_to_underscore space_to_underscore c = case c of ' ' -> '_' _ -> c remove_quotes = filter (/= '\'') pre = "fnk_haddock_hooks" pkg_name pkg_name = unPackageName (pkgName (package pd)) createDirectoryIfMissing True dir return dir gen_files <- foldM accumulateGeneratedFile [] hs_mods tmpdir <- makeTemporaryDirectory let ghc = simpleProgram "ghc" acquire = case lookupProgram ghc (withPrograms lbi) of Just prog | not (null gen_files) -> do runGHC verbosity prog cmpl platform (opts tmpdir) installDirectoryContents verbosity tmpdir autogen_dir _ -> return () clean path = do exist <- doesFileExist path when exist (do when (Verbosity.normal < verbosity) (putStrLn ("Removing: " ++ path)) removeFile path) exist_dir <- doesDirectoryExist tmpdir when exist_dir $ removeDirectoryRecursive tmpdir cleanup = mapM_ clean gen_files return (acquire, cleanup) -- | Optional arguments passed to ghc, for writing Haskell source code -- files from Finkel source code files. #if MIN_VERSION_Cabal(2,4,0) optExtras :: FilePath -> [String] optExtras = optExtras' #else optExtras :: FilePath -> NubListR String optExtras = toNubListR . optExtras' #endif where optExtras' :: FilePath -> [String] #if MIN_TOOL_VERSION_ghc(9,2,0) -- In ghc >= 9.2, "-fbyte-code" creates '*.o' object files. Using -- "-fno-code" instead of bytecode. optExtras' odir = ["-v0", "-fno-code", "--fnk-hsdir=" ++ odir] #else optExtras' odir = ["-v0", "-fbyte-code", "--fnk-hsdir=" ++ odir] #endif -- | Same as the one used in "Distribution.Simple". allSuffixHandlers :: UserHooks -> [PPSuffixHandler] allSuffixHandlers hooks = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers where overridesPP = unionBy ((==) `on` fst) #if !MIN_VERSION_Cabal(3,5,0) getSymbolicPath :: a -> a getSymbolicPath = id #endif ================================================ FILE: finkel-setup/test/Main.hs ================================================ {-# LANGUAGE CPP #-} module Main where -- base import Control.Exception (catch, throw) import Data.List (isSubsequenceOf) import System.Environment (getExecutablePath, lookupEnv, setEnv, unsetEnv, withArgs) -- ghc #if MIN_VERSION_ghc(9,0,0) import GHC.Settings.Config (cProjectVersion) #else import Config (cProjectVersion) #endif -- directory import System.Directory (doesDirectoryExist, getCurrentDirectory, removeDirectoryRecursive, setCurrentDirectory) import System.Directory.Internal.Prelude (isDoesNotExistError) -- filepath import System.FilePath (isSearchPathSeparator, joinPath, splitDirectories, takeDirectory, ()) -- hspec import Test.Hspec -- Internal import Distribution.Simple.Finkel main :: IO () main = do executable <- getExecutablePath pkgdbs <- getPackageDbs executable cwd <- getCurrentDirectory putChar '\n' putStrLn ("executable: " ++ executable) putStrLn (unlines ("pkgdbs:" : map (" - " ++) pkgdbs)) putStrLn ("cwd: " ++ cwd) -- Required to unset "GHC_PACKAGE_PATH" environment variable before -- invoking setup script, otherwise the setup script will complain. unsetEnv "GHC_PACKAGE_PATH" -- Setting the `null' package environment for ghc >= 8.4.0, to support -- building executable in test packages. In ghc 8.2.x, the use of "-" -- in GHC_ENVIRONMENT will show "No such package environment" error, -- so "executable" and "test" stanzas in ".cabal" file are disabled. setEnv "GHC_ENVIRONMENT" "-" hspec (afterAll_ (setCurrentDirectory cwd) (beforeAll_ (removeDistIfExist cwd) (do buildPackage cwd pkgdbs "p01" buildPluginPackage cwd pkgdbs "p02"))) buildPackage :: String -> [String] -> String -> Spec buildPackage = buildPackageWith setup where setup args = do putStrLn (unwords ("running:" : args)) withArgs args fnkMain buildPluginPackage :: String -> [String] -> String -> Spec buildPluginPackage = buildPackageWith plugin_setup where plugin_setup args = do putStrLn (unwords ("running:" : args)) withArgs args fnkPluginMainForHaddock buildPackageWith :: ([String] -> IO ()) -> String -> [String] -> String -> Spec buildPackageWith my_main cwd pkgdbs name = describe ("package " ++ name) $ it "should compile and pass the tests" $ do let pkgdir = joinPath [cwd, "test", "data", name] pkgdb_flags = [ "--package-db=clear" , "--package-db=global" ] ++ fmap ("--package-db=" ++) pkgdbs configure_args = "configure" : pkgdb_flags ++ ["--enable-tests", "-v2"] run act = act `shouldReturn` () mapM_ run [ setCurrentDirectory pkgdir , my_main configure_args , my_main ["build"] , my_main ["test"] , my_main ["haddock"] ] getPackageDbs :: String -> IO [String] getPackageDbs executable_path | ".stack-work" `isSubsequenceOf` executable_path = getStackPackageDbs | "dist-newstyle" `isSubsequenceOf` executable_path = getCabalPackageDbs executable_path | otherwise = getPackageConfD executable_path getStackPackageDbs :: IO [String] getStackPackageDbs = do -- Getting package database paths from "GHC_PACKAGE_PATH" environment -- variable, so that we can get the package database paths without -- knowing which "stack.yaml" file were used. mb_paths <- lookupEnv "GHC_PACKAGE_PATH" case mb_paths of Just paths -> return (reverse (sepBySearchPathSeparator paths)) Nothing -> return [] sepBySearchPathSeparator :: String -> [String] sepBySearchPathSeparator xs = case dropWhile isSearchPathSeparator xs of "" -> [] ys -> case break isSearchPathSeparator ys of (w, ys') -> w : sepBySearchPathSeparator ys' getCabalPackageDbs :: String -> IO [String] getCabalPackageDbs executable_path = do let dirs = splitDirectories executable_path distdir = takeWhile (/= "dist-newstyle") dirs ghc_ver = "ghc-" ++ cProjectVersion localdb = joinPath distdir joinPath ["dist-newstyle", "packagedb", ghc_ver] return [localdb] getPackageConfD :: FilePath -> IO [FilePath] getPackageConfD path = go path (takeDirectory path) where go prev current = if prev == current then return [] else do let pkg_conf_d = current "package.conf.d" found <- doesDirectoryExist pkg_conf_d if found then return [pkg_conf_d] else go current (takeDirectory current) removeDistIfExist :: FilePath -> IO () removeDistIfExist cwd = mapM_ remove_dir ["p01", "p02"] where remove_dir pkg = catch (let dir = cwd "test" "data" pkg "dist" in removeDirectoryRecursive dir) (\e -> if isDoesNotExistError e then return () else throw e) ================================================ FILE: finkel-setup/test/data/p01/LICENSE ================================================ Copyright Author name here (c) 2017 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Author name here nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: finkel-setup/test/data/p01/Setup.hs ================================================ import Distribution.Simple.Finkel main = fnkMain ================================================ FILE: finkel-setup/test/data/p01/exec/p01.hs ================================================ module Main where import P01.A main :: IO () main = print p01a ================================================ FILE: finkel-setup/test/data/p01/p01.cabal ================================================ cabal-version: 2.0 name: p01 version: 0.1.0.0 synopsis: Test package description: Test package homepage: https://github.com/githubuser/p01#readme license: BSD3 license-file: LICENSE author: Author name here maintainer: example@example.com copyright: 2022 Author name here category: Test build-type: Custom extra-source-files: src/P01/*.fnk custom-setup setup-depends: base >= 4.7 && < 5 , Cabal >= 2.0 , finkel-setup library hs-source-dirs: src exposed-modules: P01.A P01.B P01.C P01.D P01.E P01.F P01.G1 P01.G2 P01.H P01.I P01.J Paths_p01 autogen-modules: Paths_p01 build-depends: base >= 4.7 && < 5 , finkel-kernel build-tool-depends: fkc:fkc >= 0.1 && < 1 default-language: Haskell2010 executable p01 if impl(ghc >= 8.4.0) buildable: True else buildable: False hs-source-dirs: exec main-is: p01.hs ghc-options: -Wall -threaded -rtsopts build-depends: base , p01 default-language: Haskell2010 test-suite p01-test if impl(ghc >= 8.4.0) buildable: True else buildable: False type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs other-modules: TestAll build-depends: base , finkel-kernel , p01 ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 source-repository head type: git location: https://github.com/githubuser/p01 ================================================ FILE: finkel-setup/test/data/p01/src/P01/A.fnk ================================================ (module P01.A) (import P01.B) (import P01.C) (import P01.D) (import P01.H) (import P01.J) (:: p01a [String]) (= p01a (concat [["p01a" p01b p01c] p01d p01h [p01j]])) ================================================ FILE: finkel-setup/test/data/p01/src/P01/B.fnk ================================================ (module P01.B) (:: p01b String) (= p01b "p01b") ================================================ FILE: finkel-setup/test/data/p01/src/P01/C.fnk ================================================ (:require P01.G2) (module P01.C) (m1 p01c "p01c") ================================================ FILE: finkel-setup/test/data/p01/src/P01/D.hs ================================================ module P01.D where import P01.E import P01.F p01d :: [String] p01d = "p01d": p01e ================================================ FILE: finkel-setup/test/data/p01/src/P01/E.hs ================================================ {-# LANGUAGE CPP #-} module P01.E where import P01.F p01e :: [String] #ifdef DEBUG p01e = ["debug is defined"] #else p01e = "p01e" : p01f #endif ================================================ FILE: finkel-setup/test/data/p01/src/P01/F.fnk ================================================ (module P01.F) (:: p01f [String]) (= p01f ["p01f"]) ================================================ FILE: finkel-setup/test/data/p01/src/P01/G1.fnk ================================================ (module P01.G1) (import Language.Finkel) ;; Simple definition of `define-macro' used in `p01' package. (:: define-macro Macro) (= define-macro (Macro (\ form (case (unCode form) (List [_ name arg body]) (let ((= __name (toCode (qSymbol (++ "__" (show name)) "G1.fnk" 0 0 0 0)))) (return `(:begin (:: ,name Macro) (= ,name (let ((:: ,__name (-> Code (Fnk Code))) (= ,__name ,arg ,body)) (Macro ,__name)))))) _ (finkelSrcError form "define-macro: invalid args"))))) ;;; Simple definition of `defmacro' used in `p01' package. (:: defmacro Macro) (= defmacro (Macro (\ form (case (unLForm form) (L _ (List [_ name args body])) (case (unLForm args) (L l1 (List _)) (let ((= body' `(define-macro ,name form (case (unLForm form) (L l2 (List [_ ,@args])) (return ,body) _ (finkelSrcError ',name ": error"))))) (return body')) (L l1 (Atom _)) (let ((= body' `(define-macro ,name ,args (return ,body)))) (return body'))) _ (finkelSrcError form "defmacro: error"))))) ================================================ FILE: finkel-setup/test/data/p01/src/P01/G2.fnk ================================================ (:require P01.G1) (module P01.G2) (import Language.Finkel) (defmacro m1 (name str) `(:begin (:: ,name String) (= ,name ,str))) (defmacro define-p01-module (name imp) `(:begin (module ,name) (import ,imp))) (defmacro define-p01-function (name typ val) `(:begin (:: ,name ,typ) (= ,name ,val))) ================================================ FILE: finkel-setup/test/data/p01/src/P01/H.fnk ================================================ ;;;; Module using macros defined in `P01.G2'. ;;; [Requiring Home Package Module] ;;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;;; ;;; This module contains `require' special form which adds `P01.G2' ;;; module to the context during macro expansion phase in skc. (:require P01.G2) (define-p01-module P01.H P01.I) (define-p01-function p01h [String] ["p01h" p01i]) ================================================ FILE: finkel-setup/test/data/p01/src/P01/I.fnk ================================================ (module P01.I) (:: p01i String) (= p01i "p01i") ================================================ FILE: finkel-setup/test/data/p01/src/P01/J.fnk ================================================ ;;;; This module test refershing context modules and macros modified by ;;;; `require' keyword. (module P01.J) ;;; Exported entities in P01.C is not used, the `import' declaration is ;;; fore controlling the dependency analysis of `make' function. (import P01.C) (:: p01j String) (= p01j (m1 blah "j")) ;;; In module P01.C, there is a top-level `require' of P01.G2. In ;;; P01.G2, there is a macro named `m1'. Desired behaviour is that the ;;; indirectly required macros should not affect the code in this ;;; module. (:: m1 (-> String String String)) (= m1 ++) (:: blah String) (= blah "p01") ================================================ FILE: finkel-setup/test/data/p01/test/Spec.hs ================================================ module Main where import System.Exit import P01.A (p01a) import TestAll (expected) main :: IO () main = if p01a == expected then exitSuccess else exitFailure ================================================ FILE: finkel-setup/test/data/p01/test/TestAll.fnk ================================================ (:require P01.G1) (module TestAll) (:: expected [String]) (= expected ["p01a" "p01b" "p01c" "p01d" "p01e" "p01f" "p01h" "p01i" "p01j"]) ================================================ FILE: finkel-setup/test/data/p02/CHANGELOG.md ================================================ # Revision history for p02 ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. ================================================ FILE: finkel-setup/test/data/p02/LICENSE ================================================ Copyright (c) 2024 8c6794b6 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: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 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. ================================================ FILE: finkel-setup/test/data/p02/Setup.hs ================================================ {-# LANGUAGE CPP #-} #if 906 <= __GLASGOW_HASKELL__ import Distribution.Simple.Finkel main = fnkPluginMainForHaddock #else import Distribution.Simple (defaultMain) main = defaultMain #endif ================================================ FILE: finkel-setup/test/data/p02/app/Main.hs ================================================ module Main where import qualified MyLib (someFunc) main :: IO () main = do putStrLn "Hello, Haskell!" MyLib.someFunc ================================================ FILE: finkel-setup/test/data/p02/p02.cabal ================================================ cabal-version: 3.0 name: p02 version: 0.1.0.0 license: MIT license-file: LICENSE author: Author name here maintainer: example@example.com category: Development build-type: Custom extra-doc-files: CHANGELOG.md custom-setup setup-depends: base >= 4.14 && < 5 , Cabal >= 3.2 , finkel-setup common warnings ghc-options: -Wall common finkel build-depends: finkel-kernel build-tool-depends: fnkpp:fnkpp ghc-options: -fplugin Language.Finkel.Plugin -F -pgmF fnkpp -optF --no-warn-interp if impl (ghc >= 9.6.0) ghc-options: -keep-hscpp-files library import: warnings, finkel exposed-modules: MyLib build-depends: base >= 4.14 && < 5 hs-source-dirs: src default-language: Haskell2010 executable p02 import: warnings main-is: Main.hs build-depends: base >= 4.14 && < 5 , p02 hs-source-dirs: app default-language: Haskell2010 test-suite p02-test import: warnings default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs build-depends: base >= 4.14 && < 5 , p02 ================================================ FILE: finkel-setup/test/data/p02/src/MyLib.hs ================================================ ;;; -*- mode: finkel -*- (:doc "Header documentation for MyLib") (module MyLib someFunc) (:doc "Documentation for 'someFunc'.") (:: someFunc (IO ())) (= someFunc (putStrLn "someFunc")) ================================================ FILE: finkel-setup/test/data/p02/test/Main.hs ================================================ module Main (main) where main :: IO () main = putStrLn "Test suite not yet implemented." ================================================ FILE: finkel-tool/LICENSE ================================================ Copyright (c) 2017-2022, 8c6794b6 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: finkel-tool/README.md ================================================ # finkel-tool Package containing a command line executable tool and library functions for building Finkel package. See the [documentation][doc] for more details. [doc]: https://finkel.readthedocs.io/en/latest/ ================================================ FILE: finkel-tool/Setup.hs ================================================ import Distribution.Simple (defaultMain) main = defaultMain ================================================ FILE: finkel-tool/finkel-tool.cabal ================================================ cabal-version: 2.0 name: finkel-tool version: 0.0.0 synopsis: Finkel tool description: Finkel tool . See the for more info. homepage: https://github.com/finkel-lang/finkel#readme license: BSD3 license-file: LICENSE author: 8c6794b6 maintainer: 8c6794b6@gmail.com copyright: 2017-2022 8c6794b6 category: Language build-type: Simple extra-source-files: README.md finkel.hsfiles test/data/*.fnk test/data/input01.txt test/data/p02/LICENSE test/data/p02/Setup.hs test/data/p02/p02.cabal test/data/p02/README.md test/data/p02/stack.yaml test/data/p02/app/Main.hs test/data/p02/src/Lib.fnk test/data/p02/test/Spec.hs tested-with: GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.7 , GHC == 9.6.5 , GHC == 9.8.2 , GHC == 9.10.1 flag dynamic description: Dynamically link executables (except Windows) default: True manual: True library hs-source-dirs: src exposed-modules: Finkel.Tool.Command Finkel.Tool.Command.Eval Finkel.Tool.Command.Help Finkel.Tool.Command.Make Finkel.Tool.Command.Repl Finkel.Tool.Command.Run Finkel.Tool.Command.Sdist Finkel.Tool.Command.Version Finkel.Tool.Internal.CLI Finkel.Tool.Internal.Commit Finkel.Tool.Internal.Compat Finkel.Tool.Internal.Eval Finkel.Tool.Internal.Exception Finkel.Tool.Internal.IO Finkel.Tool.Internal.Listen Finkel.Tool.Internal.Loop Finkel.Tool.Internal.Macro.Ghc Finkel.Tool.Internal.Macro.Repl Finkel.Tool.Internal.Types Finkel.Tool.Main Paths_finkel_tool autogen-modules: Paths_finkel_tool build-depends: base >= 4.14 && < 5 , bytestring >= 0.10 && < 0.13 , Cabal >= 3.2 && < 3.13 , deepseq >= 1.4 && < 1.6 , directory >= 1.3 && < 1.4 , exceptions >= 0.10 && < 0.11 , filepath >= 1.4.1 && < 1.6 , haskeline >= 0.8 && < 0.9 , ghc >= 8.10.0 && < 9.11.0 , ghc-boot >= 8.10.0 && < 9.11.0 , ghci >= 8.10.0 && < 9.11.0 , network >= 2.6.3 && < 3.3 , process >= 1.6 && < 1.7 , transformers >= 0.5 && < 0.7 -- , finkel-kernel == 0.0.0 , finkel-core == 0.0.0 default-language: Haskell2010 build-tool-depends: fnkpp:fnkpp == 0.0.0 ghc-options: -Wall -F -pgmF fnkpp -optF --no-warn-interp -fplugin Finkel.Core.Plugin if impl (ghc >= 9.6.0) ghc-options: -keep-hscpp-files test-suite finkel-tool-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs build-depends: base , directory , exceptions , filepath , ghc , haskeline , network , process , finkel-core , finkel-kernel , finkel-tool -- , hspec >= 2.4.8 && < 2.12 , silently >= 1.2 && < 1.3 , QuickCheck >= 2.10.1 && < 2.16 other-modules: CLITest GhcTest MainTest ReplTest ReplMacroTest TestAux default-language: Haskell2010 build-tool-depends: fnkpp:fnkpp == 0.0.0 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -F -pgmF fnkpp -optF --no-warn-interp -fplugin Finkel.Core.Plugin if !os(windows) && flag(dynamic) ghc-options: -dynamic if impl (ghc >= 9.6.0) ghc-options: -keep-hscpp-files source-repository head type: git location: https://github.com/finkel-lang/finkel.git subdir: finkel-tool ================================================ FILE: finkel-tool/finkel.hsfiles ================================================ {-# START_FILE {{name}}.cabal #-} cabal-version: 3.0 name: {{name}} version: 0.1.0.0 -- synopsis: -- description: homepage: http://www.example.org license: BSD-3-Clause license-file: LICENSE author: {{author-name}}{{^author-name}}Author name here{{/author-name}} maintainer: {{author-email}}{{^author-email}}example@example.com{{/author-email}} copyright: {{copyright}}{{^copyright}}{{year}}{{^year}}2022{{/year}} {{author-name}}{{^author-name}}Author name here{{/author-name}}{{/copyright}} category: Data build-type: Simple extra-source-files: README.md common finkel build-depends: finkel-core build-tool-depends: fnkpp:fnkpp ghc-options: -F -pgmF fnkpp -optF --no-warn-interp -fplugin Finkel.Core.Plugin library import: finkel hs-source-dirs: src exposed-modules: Lib build-depends: base >= 4.7 && < 5 default-language: Haskell2010 executable {{name}} hs-source-dirs: app main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base , {{name}} default-language: Haskell2010 test-suite {{name}}-test import: finkel type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs build-depends: base , {{name}} ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 -- source-repository head -- type: git -- location: https://github.com/{{github-username}}{{^github-username}}githubuser{{/github-username}}/{{name}} {-# START_FILE Setup.hs #-} import Distribution.Simple (defaultMain) main = defaultMain {-# START_FILE test/Spec.hs #-} main :: IO () main = putStrLn "Test suite not yet implemented" {-# START_FILE src/Lib.hs #-} ;;; -*- mode: finkel -*- (defmodule Lib (export someFunc)) (defn (:: someFunc (IO ())) (putStrLn "Hello from {{name}}")) {-# START_FILE app/Main.hs #-} module Main where import Lib main :: IO () main = someFunc {-# START_FILE README.md #-} # {{name}} {-# START_FILE LICENSE #-} Copyright {{author-name}}{{^author-name}}Author name here{{/author-name}} (c) {{year}}{{^year}}2022{{/year}} All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: finkel-tool/src/Finkel/Tool/Command/Eval.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Eval sub command (defmodule Finkel.Tool.Command.Eval (export evalMain eval-and-exit eval-and-exit-with-args) (require ;; finkel-core (Finkel.Tool.Internal.Macro.Ghc)) (import ;; base (Control.Concurrent [MVar newEmptyMVar newMVar takeMVar]) (Control.Exception [displayException throwIO]) (Control.Monad.IO.Class [(MonadIO ..)]) (System.Console.GetOpt [(ArgDescr ..) (ArgOrder ..) (OptDescr ..) getOpt usageInfo]) (System.Environment [getProgName]) ;; finkel-kernel (Language.Finkel.Fnk [(Fnk) FnkEnv runFnk]) (Language.Finkel.Form [Code]) (Language.Finkel.Lexer [evalSP]) (Language.Finkel.Options [fromFnkEnvOptions fnkEnvOptionsUsage]) (Language.Finkel.Reader [sexpr]) ;; Internal (Finkel.Tool.Command.Repl [repl-env]) (Finkel.Tool.Internal.CLI) (Finkel.Tool.Internal.Eval) (Finkel.Tool.Internal.Exception) (Finkel.Tool.Internal.Types))) (imports-from-ghc (GHC.Data.StringBuffer [stringToStringBuffer])) ;;; Exported (defn (:: evalMain (=> (CLI m) (-> [String] (m ())))) [args] (lept [all-opts (++ eval-opts eval-fnk-env-opts) (, os gs) (partition-descrs all-opts args) mk-opt (foldl (flip id) initial-eval-option) (, o _ es) (getOpt Permute all-opts os)] (case es [] (do-eval (mk-opt o) gs) _ (liftIO (throwIO (ArgumentErrors "eval" es)))))) ;;; Internal (data EvalOption (EvalOption {(:: eo-help Bool) (:: eo-fnk-env FnkEnv)})) (defn (:: initial-eval-option EvalOption) (EvalOption {(= eo-help False) (= eo-fnk-env repl-env)})) (defn (:: eval-opts [(OptDescr (-> EvalOption EvalOption))]) [(Option [] ["help"] (NoArg (\o (o {(= eo-help True)}))) "Show this help and exit")]) (defn (:: eval-fnk-env-opts [(OptDescr (-> EvalOption EvalOption))]) (fromFnkEnvOptions (\f o (o {(= eo-fnk-env (f (eo-fnk-env o)))})))) (defn (:: print-eval-help (=> (CLI m) (m ()))) (do (<- me (liftIO getProgName)) (putString (unlines [(concat ["USAGE: " me " eval [OPTIONS] FORM"]) "" "Evaluate given FORM expression." "" (usageInfo "OPTIONS:\n" eval-opts) (fnkEnvOptionsUsage "DEBUG OPTIONS:\n") others-passed-to-ghc])))) (defn (:: do-eval (=> (CLI m) (-> EvalOption [String] (m ())))) [eo args] (if (eo-help eo) print-eval-help (lept [(, ghc-args mb-str) (separate-args args) parse (. (evalSP sexpr (Just "")) stringToStringBuffer)] (liftIO (case (fmap parse mb-str) (Just (Right form)) (eval-and-exit ghc-args (eo-fnk-env eo) form) (Just (Left err)) ($ throwIO FinkelToolException displayException err) Nothing (throwIO NoEvalInput)))))) (defn (:: separate-args (-> [String] (, [String] (Maybe String)))) [args] (case args [] (, [] Nothing) [x] (, [] (Just x)) (: x xs) (lept [(, ghc-opts mb-form) (separate-args xs)] (, (: x ghc-opts) mb-form)))) (defn (:: eval-and-exit (-> [String] FnkEnv Code (IO ()))) (eval-and-exit-with-args [])) (defn (:: eval-and-exit-with-args (-> [String] [String] FnkEnv Code (IO ()))) [wrapper-args ghc-args-0 fnk-env form] ;; Adding "-v0" to front of ghc arguments, to suppress module compilation ;; messages. (lept [hdl (error "eval-and-exit: uninitialized handle") ghc-args-1 (: "-v0" ghc-args-0)] (runFnk (do (<- (, in-mv out-mv) (make-in-and-out form)) (eval-once wrapper-args ghc-args-1 hdl in-mv) (liftIO (case-do (takeMVar out-mv) (Right msg) (putStr msg) (Left errs) ($ throwIO FinkelToolException errs)))) fnk-env))) (defn (:: make-in-and-out (-> Code (Fnk (, (MVar Input) (MVar Result))))) [form] (liftIO (do (<- out-mv newEmptyMVar) (<- in-mv (newMVar (Input Prompt form out-mv))) (return (, in-mv out-mv))))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Command/Help.hs ================================================ ;;; -*- mode: finkel -*- ;;; Help utility for Finkel tool. (defmodule Finkel.Tool.Command.Help (export ;; Help command helpMain show-usage) (import ;; base (Control.Monad.IO.Class [(MonadIO ..)]) (Data.Foldable [maximumBy]) (Data.Function [on]) (System.Environment [getProgName]) ;; Internal (Finkel.Tool.Internal.CLI))) (defn (:: helpMain (=> (CLI m) (-> [Command] [String] (m ())))) "Main function for help command." [cmds args] (case args (: name _ ) (| ((<- (Just cmd) (find-command cmds name)) (liftIO (cmd-act cmd ["--help"])))) _ (show-usage cmds))) (defn (:: show-usage (=> (CLI m) (-> [Command] (m ())))) "Show usage message generated from given commands." [cmds] (lefn [(max-len (length (maximumBy (on compare length) (fmap cmd-name cmds)))) (pad [n str] (++ str (replicate (- n (length str)) #'\SP))) (descr [n cmd] (concat [" " (pad n (cmd-name cmd)) " " (cmd-descr cmd)]))] (do (<- name (liftIO getProgName)) (putString (unlines (++ [(concat ["USAGE:\n\n " name " [arguments]"]) "" (concat ["Run \"" name " help \"" " for more information."]) "" "COMMANDS:" ""] (fmap (descr max-len) cmds))))))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Command/Make.hs ================================================ ;;; -*- mode: finkel -*- ;;; Module for make sub command. (defmodule Finkel.Tool.Command.Make (export makeMain) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (System.Console.GetOpt [(OptDescr ..) (ArgDescr ..) (ArgOrder ..) getOpt]) (System.Environment [getProgName withArgs withProgName]) ;; finkel-kernel (Language.Finkel.Main [defaultMainWith]) ;; finkel-core (Finkel.Core))) (data MakeOption (MakeOption {(:: mo-help Bool)})) (defn (:: initial-make-option MakeOption) (MakeOption {(= mo-help False)})) (defn (:: make-options [(OptDescr (-> MakeOption MakeOption))]) [(Option [] ["help"] (NoArg (\o (o {(= mo-help True)}))) "Show this help and exit")]) (defn (:: runMain (-> [String] (IO ()))) "Main function for compiler with macros from `Finkel.Prelude'." [args] (macrolet ((preloaded () `[,@(map (\mac (, mac (make-symbol mac))) (exported-macros Finkel.Core))])) (do (<- me (fmap (flip ++ " make") getProgName)) (withArgs args (withProgName me (defaultMainWith (preloaded))))))) (defn (:: makeMain (-> [String] (IO ()))) [args] (lept [(, o _ _) (getOpt Permute make-options args) mo (foldl (flip id) initial-make-option o)] (if (mo-help mo) (runMain ["--fnk-help"]) (runMain args)))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Command/Repl.hs ================================================ ;;; -*- mode: finkel -*- ;;;; | Simple Finkel REPL. ;;;; ;;;; This implementation uses two threads: one for reading and printing, ;;;; and another for evaluating and modifying the FnkEnv. Using `MVar' ;;;; containing `Code' to communicate between the threads. This design ;;;; shall be easier to support reading forms from other sources than ;;;; line oriented user input, e.g. network sockets. (defmodule Finkel.Tool.Command.Repl (export replMain repl-env) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Exception [throwIO]) (Control.Monad [mplus]) (Control.Monad.IO.Class [(MonadIO ..)]) (System.Console.GetOpt [(ArgDescr ..) (ArgOrder ..) (OptDescr ..) getOpt usageInfo]) (System.Environment [getProgName]) ;; finkel-kernel (Language.Finkel) (Language.Finkel.Fnk [(FnkEnv ..) EnvMacros makeEnvMacros mergeMacros]) (Language.Finkel.Options [fromFnkEnvOptions fnkEnvOptionsUsage]) (Language.Finkel.SpecialForms [specialForms]) ;; finkel-core (Finkel.Core) ;; Internal (Finkel.Tool.Internal.CLI) (Finkel.Tool.Internal.Exception) (Finkel.Tool.Internal.Loop) (Finkel.Tool.Internal.Macro.Repl) (Finkel.Tool.Internal.Types))) ;;; Exported (defn (:: replMain (=> (CLI m) (-> [String] (m ())))) "Main entry point function for REPL." [args] (lept [all-descrs (++ repl-options repl-fnk-env-options) (, repl-opts ghc-opts) (partition-descrs all-descrs args) initial-option (make-initial-option ghc-opts)] (case (getOpt Permute all-descrs repl-opts) (, o _other []) (do-repl (foldl (flip id) initial-option o)) (, _ _ es) (liftIO (throwIO (ArgumentErrors "repl" es)))))) (defn (:: repl-env FnkEnv) "Environment value used by the Finkel REPL." (lept [macros (mergeMacros specialForms replMacros)] (defaultFnkEnv {(= envContextModules ["Prelude"]) (= envMacros macros) (= envDefaultMacros macros) (= envQualifyQuotePrimitives True)}))) ;;; Internal (data ReplMode Help Run) (data ReplOption (ReplOption {(:: repl-mode ReplMode) (:: repl-listen-port (Maybe Int)) (:: repl-input-path (Maybe FilePath)) (:: repl-prompt (Maybe String)) (:: repl-quiet Bool) (:: repl-init-form Code) (:: repl-ghc-options [String]) (:: repl-fnk-env FnkEnv)})) (defn (:: make-initial-option (-> [String] ReplOption)) [ghc-options] (ReplOption {(= repl-mode Run) (= repl-listen-port Nothing) (= repl-input-path Nothing) (= repl-prompt Nothing) (= repl-quiet False) (= repl-init-form greet) (= repl-ghc-options ghc-options) (= repl-fnk-env repl-env)})) (defn (:: repl-options [OptDescr (-> ReplOption ReplOption)]) [(Option [] ["help"] (NoArg (\o (o {(= repl-mode Help)}))) "Show this help and exit") (Option [] ["listen"] (OptArg (\mb-port o (lept [port (mplus (fmap read mb-port) (Just 50321))] (o {(= repl-mode Run) (= repl-listen-port port)}))) "PORT") "Listen to port (default: 50321)") (Option [] ["file"] (ReqArg (\file o (o {(= repl-input-path (Just file))})) "FILE") "File to get input from") (Option [] ["prompt"] (ReqArg (\str o (o {(= repl-prompt (Just str))})) "TEXT") "Prompt for input (default: '> ')") (Option [] ["quiet"] (NoArg (\o (o {(= repl-quiet True) (= repl-prompt (Just "")) (= repl-init-form '(:begin))}))) "Suppress message from REPL")]) (defn (:: repl-fnk-env-options [(OptDescr (-> ReplOption ReplOption))]) (fromFnkEnvOptions (\f o (o {(= repl-fnk-env (f (repl-fnk-env o)))})))) (defn (:: do-repl (=> (CLI m) (-> ReplOption (m ())))) [ro] (case (repl-mode ro) Help print-usage Run (liftIO (start-repl (repl-ghc-options ro) (repl-input-path ro) (repl-listen-port ro) (repl-fnk-env ro) (maybe mempty (\p (mempty {(= prompt-string p)})) (repl-prompt ro)) (repl-init-form ro))))) (defn (:: greet Code) "Form containing initial message for the REPL." '(System.IO.putStrLn "Hit `Ctrl-d' or type ,q to quit, type ,? for help.")) (defn (:: print-usage (=> (CLI m) (m ()))) (do (<- name (liftIO getProgName)) (putString (unlines [(concat ["USAGE: " name " repl [OPTIONS]"]) "" "Start interactive REPL." "" (usageInfo "OPTIONS:\n" repl-options) (fnkEnvOptionsUsage "DEBUG OPTIONS:\n") " Other options are passed to ghc."])))) (defn (:: replMacros EnvMacros) "Default macros imported in REPL. These macros always get imported after loading compiled modules." (macrolet [(the-macros () `[,@(map (\mac `(, ,mac ,(make-symbol mac))) (: "repl_macro" (exported-macros Finkel.Core)))])] (makeEnvMacros (the-macros)))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Command/Run.hs ================================================ ;;; -*- mode: finkel -*- ;;; Module for run sub command (defmodule Finkel.Tool.Command.Run (export runMain) (import ;; base (Control.Exception [throwIO]) (Control.Monad.IO.Class [(MonadIO ..)]) (System.Console.GetOpt [(ArgDescr ..) (ArgOrder ..) (OptDescr ..) getOpt usageInfo]) (System.Environment [getProgName]) ;; finkel-kernel (Language.Finkel.Fnk [FnkEnv]) (Language.Finkel.Options [fromFnkEnvOptions fnkEnvOptionsUsage]) ;; finkel-core (Finkel.Core.Functions [make-symbol]) ;; Internal (Finkel.Tool.Command.Eval [eval-and-exit-with-args]) (Finkel.Tool.Command.Repl [repl-env]) (Finkel.Tool.Internal.CLI) (Finkel.Tool.Internal.Exception))) (defn (:: runMain (=> (CLI m) (-> [String] (m ())))) [args0] (lept [(, args1 prog-args) (split-program-args args0) all-opts (++ run-opts run-fnk-env-opts) (, rargs ghc-args) (partition-descrs all-opts args1) (, o _ es) (getOpt Permute all-opts rargs) ro (foldl (flip id) initial-run-option o) main-fn (make-symbol (mangle-name (ro-main ro)))] (if (ro-help ro) print-run-help (liftIO (case es [] (eval-and-exit-with-args prog-args ghc-args (ro-fnk-env ro) main-fn) _ (throwIO (ArgumentErrors "run" es))))))) (data RunOption (RunOption {(:: ro-help Bool) (:: ro-main String) (:: ro-fnk-env FnkEnv)})) (defn (:: initial-run-option RunOption) (RunOption {(= ro-help False) (= ro-main "main") (= ro-fnk-env repl-env)})) (defn (:: run-opts [(OptDescr (-> RunOption RunOption))]) [(Option [] ["help"] (NoArg (\o (o {(= ro-help True)}))) "Show this help and exit") (Option [] ["main"] (ReqArg (\name o (o {(= ro-main name)})) "NAME") "Name of the function to run (default: main)")]) (defn (:: run-fnk-env-opts [(OptDescr (-> RunOption RunOption))]) (fromFnkEnvOptions (\f o (o {(= ro-fnk-env (f (ro-fnk-env o)))})))) (defn (:: print-run-help (=> (CLI m) (m ()))) (do (<- me (liftIO getProgName)) (putString (unlines [(concat ["USAGE: " me " run [OPTIONS] FILE [-- ARGS]"]) "" "Compile and run given FILE." "" "Arguments after `--' are passed to the given FILE." "" (usageInfo "OPTIONS:\n" run-opts) (fnkEnvOptionsUsage "DEBUG OPTIONS:\n") others-passed-to-ghc])))) (defn (:: split-program-args (-> [String] (, [String] [String]))) [xs] (case (break (== "--") xs) (, pre (: "--" post)) (, pre post) (, pre _) (, pre []))) (defn (:: mangle-name (-> String String)) (lefn [(replace [c] (if (== c #'-) #'_ c))] (map replace))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Command/Sdist.hs ================================================ ;;; -*- mode: finkel -*- ;;; Finkel sdist command, to create tar.gz of cabal package ;;; ;;; XXX: Consider removing this command when the support for "*.fnk" file ;;; extension is dropped. (defmodule Finkel.Tool.Command.Sdist (export sdistMain) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Exception [throwIO]) (Control.Monad [>=>]) (Control.Monad.IO.Class [liftIO]) (System.Environment [getProgName]) ;; Cabal (Distribution.PackageDescription.Configuration [flattenPackageDescription]) (Distribution.Simple.BuildPaths [srcPref]) (Distribution.Simple.Command [(CommandParse ..) (CommandUI ..) commandParseArgs]) (Distribution.Simple.PreProcess [knownSuffixHandlers]) (Distribution.Simple.Setup [(SDistFlags ..) defaultSDistFlags sdistCommand]) (Distribution.Simple.SrcDist [sdist]) (Distribution.Simple.Utils [findPackageDesc]) (Distribution.Simple.PreProcess [PPSuffixHandler (PreProcessor ..) mkSimplePreProcessor]) ;; directory (System.Directory [withCurrentDirectory]) ;; Internal (Finkel.Tool.Internal.CLI) (Finkel.Tool.Internal.Exception))) ;;; Extra imports for version compatibility (cond-expand [(:min-version "Cabal" 3 12 0) (:begin (import Distribution.Simple.Errors (exceptionMessage)) (import Distribution.Simple.PreProcess ((Suffix ..))))] [otherwise (:begin)]) (cond-expand [(:min-version "Cabal" 3 8 0) (import Distribution.Simple.PreProcess (unsorted))] [otherwise (:begin)]) (cond-expand [(:min-version "Cabal" 3 0 1) (:begin)] [otherwise (import Distribution.Simple.Configure (findDistPrefOrDefault))]) (cond-expand [(:min-version "Cabal" 3 0 1) (import Distribution.Simple.Flag (fromFlag))] [(:min-version "Cabal" 2 4 0) (import Distribution.Simple.Flag (fromFlag toFlag))] [otherwise (import Distribution.Simple.Setup (fromFlag toFlag))]) (cond-expand [(:min-version "Cabal" 3 8 0) (import Distribution.Simple.PackageDescription (readGenericPackageDescription))] [(:min-version "Cabal" 2 2 0) (import Distribution.PackageDescription.Parsec (readGenericPackageDescription))] [otherwise (import Distribution.PackageDescription.Parse (readGenericPackageDescription))]) ;;; Main action (defn (:: sdistMain (=> (CLI m) (-> [String] (m ())))) [args] (lefn [(write-tgzs [parsed] (do (lept [(, update-flags non-opts) parsed flags1 (update-flags defaultSDistFlags)]) (<- flags2 (update-dist-pref flags1)) (lept [verbosity (fromFlag (sDistVerbosity flags2)) write (write-tgz verbosity flags2)]) (if (null non-opts) (write ".") (mapM- write non-opts)))) (write-tgz [verbosity flags dir] (>>= (findPackageDesc dir) (either (cond-expand [(:min-version "Cabal" 3 12 0) (. throwIO FinkelToolException exceptionMessage)] [otherwise (. throwIO FinkelToolException)]) (>=> (readGenericPackageDescription verbosity) (write-tgz-2 flags dir))))) (write-tgz-2 [flags dir descr] (lept [sd (run-sdist (flattenPackageDescription descr) flags)] (if (== dir ".") sd (withCurrentDirectory dir sd)))) (update-dist-pref [flags] (cond-expand [(:min-version "Cabal" 3 0 0) (pure flags)] [otherwise ;; Until Cabal 3.x, seems like the "sDistDistPref" field was set ;; by "configure" command, setting it manually. (do (<- pref (findDistPrefOrDefault (sDistDistPref flags))) (pure (flags {(= sDistDistPref (toFlag pref))})))])) (run-sdist [pd flags] (lept [sufs (: finkelPPHandler knownSuffixHandlers)] (cond-expand [(:min-version "Cabal" 3 4 0) (sdist pd flags srcPref sufs)] [otherwise (sdist pd Nothing flags srcPref sufs)]))) (my-sdist-cmd (sdistCommand {(= commandUsage (\pname (++ "Usage: " pname " sdist [FLAGS] [DIRS]\n")))}))] (liftIO (case (commandParseArgs my-sdist-cmd False args) (CommandHelp f) (>>= getProgName (. putStrLn f)) (CommandList os) ($ putStr unlines os) (CommandReadyToGo parsed) (write-tgzs parsed) (CommandErrors es) (throwIO (ArgumentErrors "sdist" es)))))) ;;; Preprocessor suffix handler to merely register files with @"*.fnk"@ files. (defn (:: finkelPPHandler PPSuffixHandler) (where (, suffix do_nothing_pp) (defn suffix (cond-expand [(:min-version "Cabal" 3 12 0) (Suffix "fnk")] [otherwise "fnk"])) (defn do_nothing_pp [_ _ _] (cond-expand [(:min-version "Cabal" 3 8 0) (PreProcessor {(= platformIndependent True) (= ppOrdering unsorted) (= runPreProcessor (mkSimplePreProcessor (\ _ _ _ (pure ()))))})] [otherwise (PreProcessor {(= platformIndependent True) (= runPreProcessor (mkSimplePreProcessor (\ _ _ _ (pure ()))))})])))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Command/Version.hs ================================================ ;;; -*- mode: finkel -*- ;;; Module for showing versions. (defmodule Finkel.Tool.Command.Version (export versionMain) (require ;; finkel-core (Finkel.Tool.Internal.Macro.Ghc)) (import-when [:compile :load] ;; base (Control.Monad.IO.Class [(MonadIO ..)])) (import-when [:compile] ;; finkel-core (Finkel.Prelude) ;; Internal (Finkel.Tool.Internal.Commit)) (import ;; base (Data.Version [showVersion]) (System.Console.GetOpt [(ArgDescr ..) (ArgOrder ..) (OptDescr ..) getOpt usageInfo]) (System.Environment [getProgName]) (System.Info [arch os]) ;; finkel-core (qualified Paths_finkel_core) ;; Internal (Finkel.Tool.Internal.CLI))) (imports-from-ghc (GHC.Settings.Config [cProjectVersion])) ;;; Exported (defn (:: versionMain (=> (CLI m) (-> [String] (m ())))) "Main function for version sub command." [args] (case (getOpt Permute version-descrs args) (, opts _ []) (show-version (foldr const VersionMessage opts)) (, _ _ es) (do (putString (concat es)) print-version-help))) ;;; Internal (data VersionMode VersionMessage VersionNumeric VersionHelp) (defn (:: version-descrs [OptDescr VersionMode]) [(Option [#'n] ["numeric"] (NoArg VersionNumeric) "show numeric version") (Option [#'h] ["help"] (NoArg VersionHelp) "show this help and exit")]) (defn (:: show-version (=> (CLI m) (-> VersionMode (m ())))) [mode] (case mode VersionMessage print-version-message VersionNumeric print-version-numeric VersionHelp print-version-help)) (defn (:: print-version-message (=> (CLI m) (m ()))) (macroletM ((get-commit-id _ (case-do (liftIO get-git-commit) (Just str) (return (toCode (: #'- str))) Nothing (return '"")))) (do (<- name (liftIO getProgName)) (putString (++ name " " finkel-version (get-commit-id) " " arch "-" os "\n" "compiled with ghc " cProjectVersion))))) (defn (:: print-version-numeric (=> (CLI m) (m ()))) (putString finkel-version)) (defn (:: print-version-help (=> (CLI m) (m ()))) (do (<- name (liftIO getProgName)) (putString (unlines [(concat ["USAGE: " name " version [OPTIONS]"]) "" "Show version information." "" (usageInfo "OPTIONS:\n" version-descrs)])))) (defn (:: finkel-version String) (showVersion Paths_finkel_core.version)) ================================================ FILE: finkel-tool/src/Finkel/Tool/Command.hs ================================================ ;;; -*- mode: finkel -*- ;;; Commands (defmodule Finkel.Tool.Command (export commands) (import (Finkel.Tool.Command.Eval) (Finkel.Tool.Command.Help) (Finkel.Tool.Command.Make) (Finkel.Tool.Command.Repl) (Finkel.Tool.Command.Run) (Finkel.Tool.Command.Sdist) (Finkel.Tool.Command.Version) (Finkel.Tool.Internal.CLI))) (defn (:: commands [Command]) "Available commands in the `finkel' executable." [(Command "eval" "evaluate given form" evalMain) (Command "help" "show help information" (helpMain commands)) (Command "make" "compile source codes" makeMain) (Command "repl" "start interactive REPL" replMain) (Command "run" "run function in module" runMain) (Command "sdist" "create source tarballs" sdistMain) (Command "version" "show version" versionMain)]) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/CLI.hs ================================================ ;;; -*- mode: finkel -*- ;;; Command line interface utilities. (defmodule Finkel.Tool.Internal.CLI (export (CLI ..) (Command ..) (ExitCode ..) find-command partition-descrs others-passed-to-ghc) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Exception [throwIO]) (Control.Monad.IO.Class [(MonadIO ..)]) (Data.Foldable [find]) (Data.List [isPrefixOf]) (System.Console.GetOpt [(ArgDescr ..) (OptDescr ..)]) (System.Exit [(ExitCode ..)]) (System.IO.Error [isEOFError]) (qualified Control.Exception) (qualified System.Exit as Exit) ;; haskeline (System.Console.Haskeline [InputT]) (qualified System.Console.Haskeline as Haskeline))) (import Control.Monad.Catch ((MonadThrow ..) (MonadCatch ..) (MonadMask ..))) ;;; Type class for command line interface, ... actually, for 'InputT' from the ;;; haskeline package. (class (=> (MonadIO cl) (CLI cl)) ;; Show prompt string, and get input line. Return Nothing for EOF ;; input. (:: getString (-> String (cl (Maybe String)))) ;; Put output line. (:: putString (-> String (cl ()))) ;; Interrupt signal handler. (:: handleInterrupt (-> (cl a) (cl a) (cl a))) ;; Perform computation with interrupt handler. (:: withInterrupt (-> (cl a) (cl a))) ;; Exit with given 'ExitCode'. (:: exitWith (-> ExitCode (cl ())))) (instance (CLI IO) (= getString prompt (Control.Exception.catch (>> (putStr prompt) (fmap Just getLine)) (\e (if (isEOFError e) (return Nothing) (throwIO e))))) (= putString putStrLn) (= handleInterrupt _handler act act) (= withInterrupt act act) (= exitWith Exit.exitWith)) (instance (=> (MonadIO m) (MonadCatch m) (MonadMask m) (MonadThrow m) (CLI (InputT m))) (= getString Haskeline.getInputLine) %p(INLINE getString) (= putString Haskeline.outputStrLn) %p(INLINE putString) (= handleInterrupt Haskeline.handleInterrupt) %p(INLINE handleInterrupt) (= withInterrupt Haskeline.withInterrupt) %p(INLINE withInterrupt) (= exitWith (. liftIO Exit.exitWith)) %p(INLINE exitWith)) ;;; Command data type ;;; Data type to wrap an IO action taking string arguments with name and ;;; description. (data Command (Command {(:: cmd-name String) (:: cmd-descr String) (:: cmd-act (-> [String] (IO ())))})) (defn (:: find-command (-> [Command] String (Maybe Command))) "Find the command by command name." [cmds name] (find (. (== name) cmd-name) cmds)) ;;; Command line option helper ;;; Note: [Finkel options, ghc options, and RTS options] ;;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;;; ;;; The finkel executable sub commands support options specific to itself, and ;;; some of the sub commands support options to update `DynFlags' in GhcMonad, ;;; and the executable itself support options for RTS. To support these three ;;; kind of options, the command line argument handling work starts with ;;; filtering out the finkel sub command specific options with manually ;;; separating the options defined with `OptDescr' from `System.Console.GetOpts' ;;; module. Then, the rest of the arguments are treated as ghc options and RTS ;;; options. ;;; ;;; Note that, in the C source code of the `rts' package, command line arguments ;;; after `--' are passed to the callee program (see: "rts/RtsFlags.c" in the ;;; ghc source code for detail). Once the command line parser for REPL options ;;; tried to separate ghc options from REPL specific options with `--', however ;;; this approach did not work well when considering RTS options. (defn (:: others-passed-to-ghc String) " Other options are passed to ghc.") (defn (:: partition-descrs (-> [(OptDescr a)] [String] (, [String] [String]))) [descrs] (lefn [(go [xs0] (cond [(<- (: x0 x1 rest) xs0) (req-arg x0) (case (go rest) (, as bs) (, (: x0 x1 as) bs))] [(<- (: x0 rest) xs0) (case (go rest) (, as bs) (if (|| (req-arg x0) (no-arg x0) (opt-arg x0) (req-arg-short-no-space x0)) (, (: x0 as) bs) (, as (: x0 bs))))] [(<- [] xs0) (, [] [])])) (no-arg [(: #'- #'- cs)] (elem cs long-nos) [(: #'- [c])] (elem c short-nos) [_] False) (req-arg [(: #'- #'- cs)] (elem cs long-reqs) [(: #'- [c])] (elem c short-reqs) [_] False) (req-arg-short-no-space [(: #'- c _)] (elem c short-reqs) [_] False) (opt-arg [(: #'- #'- cs)] (any (flip isPrefixOf cs) long-eqs) [_] False) ((, short-nos long-nos short-reqs long-reqs long-eqs) (group-descrs descrs))] go)) (defn (:: group-descrs (-> [(OptDescr a)] (, String [String] String [String] [String]))) [descrs] (lefn [(long-eq [cs] (++ cs "=")) (oflags [cs acc] (++ (map long-eq cs) acc)) (f [(Option ss ls adescr _) (, sns lns srs lrs les)] (case adescr (NoArg {}) (, (++ ss sns) (++ ls lns) srs lrs les) (ReqArg {}) (lefn [(srs' (++ ss srs)) (lrs' (++ ls lrs)) (les' (oflags ls les))] (, sns lns srs' lrs' les')) (OptArg {}) (, sns lns srs lrs (oflags ls les))))] (foldr f (, [] [] [] [] []) descrs))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/Commit.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Module containing function to get git commit ID (defmodule Finkel.Tool.Internal.Commit (export get-git-commit) (import ;; base (Control.Exception [(SomeException ..) catch]) (System.Exit [(ExitCode ..)]) ;; process (System.Process [readProcess readProcessWithExitCode]))) (defn (:: is-dirty (IO Bool)) (case-do (readProcessWithExitCode "git" ["diff" "--quiet"] []) (, ExitSuccess _ _) (return False) _ (return True))) (defn (:: get-git-commit (IO (Maybe String))) (catch (case-do (fmap lines (readProcess "git" ["rev-parse" "--short=7" "HEAD"] [])) (: hash _) (do (<- dirty is-dirty) (return (Just (++ hash (if dirty "-dirty" ""))))) _ (return Nothing)) (\ (SomeException _) (return Nothing)))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/Compat.hs ================================================ ;;; -*- mode: finkel -*- %p(LANGUAGE TypeApplications TypeFamilies) ;;;; Some commonly used version compatibility type and functions (defmodule Finkel.Tool.Internal.Compat (export WARNINGs NamePprCtx print-or-throw-diagnostics ppr-wrapped-msg-bag-with-loc get-name-ppr-ctx) (require (Finkel.Tool.Internal.Macro.Ghc)) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; finkel-kernel (Language.Finkel.Error [WARNINGs printOrThrowDiagnostics']))) ;;; ghc (imports-from-ghc (GHC.Driver.Env [(HscEnv ..)]) (GHC.Driver.Monad [(GhcMonad ..)]) (GHC.Driver.Session [(DynFlags ..)]) (GHC.Utils.Outputable [SDoc])) (cond-expand [(<= 906 :ghc) (import GHC (NamePprCtx getNamePprCtx))] [otherwise (import GHC (PrintUnqualified getPrintUnqual))]) (cond-expand [(<= 906 :ghc) (:begin (import GHC.Driver.Errors.Types ((GhcMessage ..) GhcMessageOpts)) (import GHC.Types.Error ((Messages ..) (Diagnostic ..) defaultDiagnosticOpts)))] [(<= 904 :ghc) (import GHC.Types.Error (Diagnostic Messages getMessages))] [otherwise (:begin (import Language.Finkel.Error (WrappedMsg)) (imports-from-ghc (GHC.Data.Bag [Bag])))]) (cond-expand [(<= 902 :ghc) (import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc))] [otherwise (imports-from-ghc (GHC.Utils.Error [pprErrMsgBagWithLoc]))]) ;;; Functions (:: get-name-ppr-ctx (=> (GhcMonad m) (m NamePprCtx))) (cond-expand [(<= 906 :ghc) (defn get-name-ppr-ctx getNamePprCtx)] [otherwise (:begin (type NamePprCtx PrintUnqualified) (defn get-name-ppr-ctx getPrintUnqual))]) (defn (:: print-or-throw-diagnostics (-> HscEnv DynFlags WARNINGs (IO ()))) [_hsc-env dflags warns] (cond-expand [(<= 902 :ghc) (printOrThrowDiagnostics' (hsc-logger _hsc-env) dflags warns)] [otherwise (printOrThrowDiagnostics' (error "no logger") dflags warns)])) (cond-expand [(<= 906 :ghc) (defn (:: ppr-wrapped-msg-bag-with-loc (=> (Diagnostic e) (~ (DiagnosticOpts e) GhcMessageOpts) (-> (Messages e) [SDoc]))) [msg] (pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @GhcMessage) (getMessages msg)))] [(<= 904 :ghc) (defn (:: ppr-wrapped-msg-bag-with-loc (=> (Diagnostic e) (-> (Messages e) [SDoc]))) (. pprMsgEnvelopeBagWithLoc getMessages))] [otherwise (defn (:: ppr-wrapped-msg-bag-with-loc (-> (Bag WrappedMsg) [SDoc])) (cond-expand [(<= 902 :ghc) pprMsgEnvelopeBagWithLoc] [otherwise pprErrMsgBagWithLoc]))]) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/Eval.hs ================================================ ;;; -*- mode: finkel -*- ;;; Eval loop in REPL. (defmodule Finkel.Tool.Internal.Eval (export eval-loop eval-once fork-eval-loop) (require ;; Internal (Finkel.Tool.Internal.Macro.Ghc)) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Concurrent [MVar ThreadId forkIOWithUnmask putMVar takeMVar]) (Control.Exception [(AsyncException ..) (Exception ..) SomeException fromException throwIO throwTo]) (Control.Monad (unless)) (Control.Monad.IO.Class [(MonadIO ..)]) (Data.Foldable [toList]) (Data.List [intercalate]) (GHC.Conc [myThreadId]) (System.IO [Handle]) ;; exceptions (Control.Monad.Catch [catch]) ;; ghc-boot (GHC.LanguageExtensions [(Extension ..)]) ;; ghci (GHCi.Message [(EvalExpr ..)]) (GHCi.RemoteTypes (ForeignHValue)) ;; finkel-kernel (Language.Finkel) (Language.Finkel.Builder [HDecl HImportDecl HStmt syntaxErrCode syntaxErrMsg evalBuilder]) (Language.Finkel.Error [mkWrappedMsg]) (Language.Finkel.Eval [evalDecls]) (Language.Finkel.Exception [finkelExceptionLoc]) (Language.Finkel.Make [initSessionForMake isFnkFile isHsFile]) (Language.Finkel.Fnk [(FnkEnv ..) failFnk modifyFnkEnv prepareInterpreter setDynFlags useInterpreter withTmpDynFlags]) (Language.Finkel.Syntax [parseExpr parseImports parseStmt parseTopDecls]) (Language.Finkel.Plugin [setFinkelPluginWithArgs]) (Finkel.Core.Plugin [plugin]) ;; internal (Finkel.Tool.Internal.Compat) (Finkel.Tool.Internal.Exception) (Finkel.Tool.Internal.IO) (Finkel.Tool.Internal.Macro.Repl) (Finkel.Tool.Internal.Types))) (imports-from-ghc (GHC [(Target ..) (TargetId ..) parseDynamicFlags setTargets]) (GHC.Data.Bag [unitBag]) (GHC.Data.OrdList [toOL]) (GHC.Driver.Env [(HscEnv ..)]) (GHC.Driver.Monad [(GhcMonad ..) modifySession withTempSession]) (GHC.Driver.Ppr [showSDoc showPpr]) (GHC.Driver.Session [(DynFlags ..) (GeneralFlag ..) (HasDynFlags ..) (Option ..) gopt-set xopt-unset]) (GHC.Parser.PostProcess [cvTopDecls]) (GHC.Runtime.Context [(InteractiveImport ..) setInteractivePrintName]) (GHC.Runtime.Eval [(ExecOptions ..) (ExecResult ..) compileParsedExprRemote getContext parseName setContext execStmt' execOptions]) (GHC.Types.Basic [(SuccessFlag ..)]) (GHC.Types.Name [(Name) getName nameOccName occNameString]) (GHC.Types.SourceError [SourceError srcErrorMessages]) (GHC.Types.SrcLoc [mkGeneralLocated unLoc]) (GHC.Types.TyThing [(TyThing ..)]) (GHC.Types.Var [Var varType]) (GHC.Unit.Module [mkModuleName]) (GHC.Utils.Misc [looksLikeModuleName]) (GHC.Utils.Outputable [SDoc ppr mkErrStyle setStyleColoured text vcat])) ;;; Extra imports (import GHC.Hs.ImpExp ((ImportDecl ..) isImportDeclQualified)) (cond-expand [(<= 906 :ghc) (import Language.Haskell.Syntax.ImpExp ((ImportListInterpretation ..)))] [otherwise (:begin)]) (cond-expand [(<= 904 :ghc) (:begin (import GHC.Driver.Env (hscActiveUnitId)) (import GHC.Types.Error (mkMessages)))] [otherwise (:begin)]) (cond-expand [(<= 902 :ghc) (import GHC.Utils.Outputable (renderWithContext))] [otherwise (imports-from-ghc (GHC.Utils.Outputable [renderWithStyle]))]) (cond-expand [(<= 902 :ghc) (import GHC.Driver.Session (initSDocContext))] [(<= 900 :ghc) (import GHC.Utils.Outputable (initSDocContext))] [otherwise (:begin)]) ;;; Version compatibility function (defn (:: optional-dynflags [GeneralFlag]) "Optional 'GeneralFlag' set for REPL. See \"GHCi.UI\", \"GHCi.UI.Monad\", and \"ghc/Main.hs\"." (cond-expand [(<= 906 :ghc) [Opt-ImplicitImportQualified Opt-IgnoreOptimChanges Opt-IgnoreHpcChanges Opt-UseBytecodeRatherThanObjects]] [otherwise [Opt-ImplicitImportQualified Opt-IgnoreOptimChanges Opt-IgnoreHpcChanges]])) (defn (:: parse-dynamic-flags (=> (MonadIO m) (-> HscEnv [Located String] (m (, DynFlags [Located String] WARNINGs))))) [hsc-env] (cond-expand [(<= 902 :ghc) (parseDynamicFlags (hsc-logger hsc-env) (hsc-dflags hsc-env))] [otherwise (parseDynamicFlags (hsc-dflags hsc-env))])) (defn (:: render-with-err-style (-> DynFlags NamePprCtx SDoc String)) [dflags unqual sdoc] (lept [style0 (cond-expand [(<= 900 :ghc) (mkErrStyle unqual)] [otherwise (mkErrStyle dflags unqual)]) style1 (setStyleColoured True style0)] (cond-expand [(<= 902 :ghc) (renderWithContext (initSDocContext dflags style1) sdoc)] [(<= 900 :ghc) (renderWithStyle (initSDocContext dflags style1) sdoc)] [otherwise (renderWithStyle dflags sdoc style1)]))) ;;; Eval loop (defn (:: fork-eval-loop (-> [String] Handle (MVar Input) FnkEnv (IO ThreadId))) [ghc-args hdl in-mv fnk-env] (do (<- me myThreadId) (forkIOWithUnmask (\unmask (catch (unmask (runFnk (eval-loop ghc-args hdl in-mv) fnk-env)) (\e (throwTo me (:: e SomeException)))))))) (defn (:: init-eval-loop (-> [String] [String] (Fnk ForeignHValue))) "Initialization works for evaluation loop." [eval-wrapper-opts ghc-opts] (do prepareInterpreter ;; Parse the ghc options from argument, assuming that the arguments are ;; passed from the command line. (<- hsc-env0 getSession) (lept [on-the-commandline (mkGeneralLocated "on the commandline") ghc-opts2 (<> ["-F" "-pgmF" "fnkpp" "-optF" "--no-warn-interp"] ghc-opts) ;; XXX: Get plugin options from command line plugin-args [] lghc-opts (map on-the-commandline ghc-opts2)]) (<- (, dflags0 fileish warns) (parse-dynamic-flags hsc-env0 lghc-opts)) (liftIO (print-or-throw-diagnostics hsc-env0 dflags0 warns)) ;; As done in the Main.hs in "ghc-bin" package, updating the `ldInputs' ;; field o the `DynFlags' with `FileOption', to support linking object ;; files. (lept [dflags1 (foldl gopt-set dflags0 optional-dynflags) (, srcs objs) (partition-args fileish) dflags2 (dflags1 {(= ldInputs (++ (map (. (FileOption "") unLoc) objs) (ldInputs dflags1)))})]) ;; Initializing plugins with dflags from updated session. (setDynFlags dflags2) initSessionForMake ;; Registring the finkel plugin. ;; ;; XXX: It is possible to pass "-fplugin" option and dynamically load the ;; plugin module. Reconsider after rewriting other commands with ;; plugin. If so, modify the `ghc-opts' to take the options for plugin. (setFinkelPluginWithArgs plugin plugin-args) ;; Setting the default `DynFlags' for macro expansion. (<- dflags3 getDynFlags) (modifyFnkEnv (\e (e {(= envDefaultDynFlags (Just dflags3))}))) ;; Load modules specified from command line, when given. (lept [err (=<< (. liftIO throwIO FinkelToolException))]) (unless (null srcs) (catch (do (setTargets (map (guessFnkTarget hsc-env0) srcs)) (<- sflag (compile-and-import srcs)) (case sflag Failed ($ err pure (++ "Failed loading: ") (intercalate ", ") (map unLoc) fileish) Succeeded (pure ()))) (\e (cond [(<- (Just se) (fromException e)) ($ err make-src-err-message se)] [(<- (Just fe) (fromException e)) ($ err make-finkel-exception-message fe)] [otherwise ($ err pure displayException e)])))) ;; XXX: Currently the printer function and the arguments returned from ;; "System.Environment.getArgs" are defined here and cannot be changed. (set-print-name "System.IO.print") ;; Pass the argument to evaluation wrapper, to set the value of `argv' ;; returned from `System.Environment.getArgs'. (make-eval-wrapper eval-wrapper-opts))) (defn (:: eval-loop (-> [String] Handle (MVar Input) (Fnk ()))) "Loop to evaluate expressions." (eval-loop-or-once False [])) (defn (:: eval-once (-> [String] [String] Handle (MVar Input) (Fnk ()))) "Evalute the form once and return." (eval-loop-or-once True)) (defn (:: eval-loop-or-once (-> Bool [String] [String] Handle (MVar Input) (Fnk ()))) "Evaluate expressions, and loop or return." [once-only wrapper-args ghc-opts hdl in-mvar] (lefn [(with-async-handler [wrapper act] (catch act (\e (case (fromException e) (Just UserInterrupt) (loop wrapper) (Just ThreadKilled) (return ()) _ (liftIO (throwIO e)))))) (:: throw-async-io (-> AsyncException (Fnk a))) (throw-async-io (. liftIO throwIO)) (withErrorHandler [act] (catch act (\e (cond [(<- (Just se) (fromException e)) (fmap Left (make-src-err-message se))] [(<- (Just ae) (fromException e)) (throw-async-io ae)] [(<- (Just fe) (fromException e)) (fmap Left (make-finkel-exception-message fe))] [otherwise ($ pure Left show e)])))) (eval-one [wrapper] (do (<- (Input itype form out-mv) (liftIO (takeMVar in-mvar))) (<- ret (withErrorHandler (do (<- expanded (expands [form])) (<- dflags getDynFlags) (eval-form hdl dflags wrapper itype expanded)))) (liftIO (putMVar out-mv ret)))) (loop [wrapper] (with-async-handler wrapper (>> (eval-one wrapper) (loop wrapper))))] (>>= (init-eval-loop wrapper-args ghc-opts) (if once-only eval-one loop)))) (defn (:: set-print-name (-> String (Fnk ()))) "Set the name of function used for printing values in interactive context." [name] (case-do (fmap toList (parseName name)) (: f _) (modifySession (\he (he {(= hsc-IC (setInteractivePrintName (hsc-IC he) f))}))) _ (failFnk "set-print-name: parse error"))) (defn (:: eval-form (-> Handle DynFlags ForeignHValue InSource [Code] (Fnk Result))) [hdl dflags wrapper itype forms] (| ((null forms) (return (Right ""))) ((<- (Right stmt) (evalBuilder dflags True parseStmt forms)) (eval-statement hdl wrapper itype stmt)) ((<- (Right decls) (evalBuilder dflags True parseTopDecls forms)) (eval-decls decls)) (otherwise (case (evalBuilder dflags True parseImports forms) (Right idecl) (eval-imports dflags idecl) (Left se) (finkelSrcError (syntaxErrCode se) (syntaxErrMsg se)))))) (defn (:: eval-statement (-> Handle ForeignHValue InSource HStmt (Fnk Result))) [hdl wrapper itype stmt] (lept [wrap (case itype Prompt (fmap (\r (, r ""))) Connection (with-io-redirect hdl)) err (. pure Left (++ "*** Exception: ") show) ok (. pure Right) opts (execOptions {(= execWrap (\fhv (EvalApp (EvalThis wrapper) (EvalThis fhv))))})] (case-do (wrap (execStmt' stmt "stmt-text" opts)) (, (ExecComplete (Right _ns) _) r) (ok r) (, (ExecComplete (Left e) _) _r) (err e) (, (ExecBreak {}) r) (pure (Left (++ "break: " r)))))) (defn (:: eval-imports (-> DynFlags [HImportDecl] (Fnk Result))) [dflags imports] (lefn [(mkIIDecl [(L _ idecl)] (IIDecl idecl)) (imps (map (. (showSDoc dflags) ppr) imports)) (mdls (++ "; " (intercalate ", " imps))) (add-imports [ctx] (foldr (\mdl (add-gt-ii (mkIIDecl mdl))) ctx imports))] (do (<- ctx0 getContext) (setContext (add-imports ctx0)) (return (Right mdls))))) (defn (:: eval-decls (-> [HDecl] (Fnk Result))) [decls] (do (<- hsc-env getSession) (lefn [(decls' (cvTopDecls (toOL decls))) (dflags (hsc-dflags hsc-env)) (pr [tt] (case tt (AnId var) (var-name-and-type dflags (getName var) var) _ (++ "; " (showSDoc dflags (ppr tt))))) (show-tything [tt acc] (lefn [(nstr (showSDoc dflags (ppr (getName tt))))] (if (== "$trModule" nstr) acc (: (pr tt) acc)))) (tystr [tt] (intercalate "\n" (foldr show-tything [] tt)))]) ;; In "ghc/GHCi/UI.hs", the `runStmt' function is wrapping declarations ;; with `let' expression and passing to `execStmt'' as a work around for ;; supporting top level declaration. However, this approach seems like ;; not working well when multiple declarations were entered at once. ;; ;; In finkel REPL, instead of wrapping with `let', always using ;; `HscInterpreted' as target when evaluating declarations, to support ;; declaring functions and values when the REPL is using `-fobject-code'. (<- (, tythings ic) (withTmpDynFlags (useInterpreter dflags) (evalDecls decls'))) (setSession (hsc-env {(= hsc-IC ic)})) (return (Right (tystr tythings))))) ;;; Auxiliary (defn (:: guessFnkTarget (-> HscEnv (Located String) Target)) "Simple function to do similar work done in `GHC.guessTarget', to support source code file paths with @.fnk@ extension." [_hsc_env lsrc] (lept [src (unLoc lsrc) tid (if (looksLikeModuleName src) (TargetModule (mkModuleName src)) (TargetFile src Nothing))] (cond-expand [(<= 904 :ghc) (Target tid True (hscActiveUnitId _hsc_env) Nothing)] [otherwise (Target tid True Nothing)]))) (defn (:: partition-args (-> [(Located String)] (, [(Located String)] [(Located String)]))) "Simplified version of the function with same name defined in @ghc/Main.hs@, to separate object files from source code files." (lefn [(f [(L l arg) (, srcs objs)] (if (|| (isFnkFile arg) (isHsFile arg) (looksLikeModuleName arg)) (, (: (L l arg) srcs) objs) (, srcs (: (L l arg) objs))))] (foldr f (, [] [])))) (defn (:: make-src-err-message (-> SourceError (Fnk String))) [src-err] (lept [emsgs (srcErrorMessages src-err) sdoc (vcat (ppr-wrapped-msg-bag-with-loc emsgs))] (do (<- dflags getDynFlags) (<- unqual get-name-ppr-ctx) (return (render-with-err-style dflags unqual sdoc))))) (defn (:: make-finkel-exception-message (-> FinkelException (Fnk String))) [fe] (lept [msg (displayException fe)] (do (<- dflags getDynFlags) (<- unqual get-name-ppr-ctx) (lefn [(lmsg [l] (lept [wmsg (mkWrappedMsg dflags l unqual (text msg)) emsgs (cond-expand [(<= 904 :ghc) (mkMessages (unitBag wmsg))] [otherwise (unitBag wmsg)]) sdoc (vcat (ppr-wrapped-msg-bag-with-loc emsgs))] (render-with-err-style dflags unqual sdoc)))]) (case (finkelExceptionLoc fe) (Just l) ($ pure lmsg l) _ (pure msg))))) (defn (:: make-eval-wrapper (-> [String] (Fnk ForeignHValue))) [args] (lept [form `(\m (do (<- r (System.Environment.withArgs ,args m)) (System.IO.hFlush System.IO.stdout) (System.IO.hFlush System.IO.stderr) (Control.Monad.return r))) no-rb-hsc (\hsc-env (hsc-env {(= hsc-dflags (xopt-unset (hsc-dflags hsc-env) RebindableSyntax))}))] (do (<- dflags getDynFlags) (case (evalBuilder dflags True parseExpr [form]) (Right expr) (withTempSession no-rb-hsc (compileParsedExprRemote expr)) (Left err) (finkelSrcError (syntaxErrCode err) (syntaxErrMsg err)))))) (defn (:: var-name-and-type (-> DynFlags Name Var String)) [dflags name var] (lept [nstr (occNameString (nameOccName name)) typ (showPpr dflags (varType var))] (if (== nstr "it") "" (intercalate "\n" (map (++ "; ") (lines (++ nstr (++ " :: " typ)))))))) (defn (:: add-gt-ii (-> InteractiveImport [InteractiveImport] [InteractiveImport])) [mdl acc] (if (any (subsume-ii mdl) acc) acc (: mdl acc))) (defn (:: subsume-ii (-> InteractiveImport InteractiveImport Bool)) ;; See `GHCi.UI.iiSubsumes'. [(IIModule x) (IIModule y)] (== x y) [(IIDecl x) (IIDecl y)] (where (&& (== (unLoc (ideclName x)) (unLoc (ideclName y))) (== (ideclAs x) (ideclAs y)) (|| (not (isImportDeclQualified (ideclQualified x))) (isImportDeclQualified (ideclQualified y))) (cond-expand [(<= 906 :ghc) (hiding-subsumes (ideclImportList x) (ideclImportList y))] [otherwise (hiding-subsumes (ideclHiding x) (ideclHiding y))])) (cond-expand [(<= 906 :ghc) (defn hiding-subsumes [_ (Just (, Exactly (L _ [])))] True [(Just (, Exactly (L _ xs))) (Just (, Exactly (L _ ys)))] (all (flip elem xs) ys) [a b] (== a b))] [otherwise (defn hiding-subsumes [_ (Just (, False (L _ [])))] True [(Just (, False (L _ xs))) (Just (, False (L _ ys)))] (all (flip elem xs) ys) [a b] (== a b))])) [_ _] False) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/Exception.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Finkel.Tool.Internal.Exception (export (FinkelToolException ..) finkel-tool-exception-handler) (import ;; base (Control.Exception [(Exception ..) handle]) (System.Environment [getProgName]) (System.Exit [exitFailure]) (System.IO [hPutStrLn stderr]) (System.IO.Unsafe [unsafePerformIO]))) (data FinkelToolException (:doc "Error with command line arguments.") (ArgumentErrors String ; Name of the command. [String] ; Error messages. %_end) (:doc "No input given for eval command.") NoEvalInput (:doc "Generic exception for finkel-tool package.") (FinkelToolException String) (deriving Eq Show)) (instance (Exception FinkelToolException) (defn displayException [(ArgumentErrors cmd msgs)] (++ (unlines msgs) (brief-usage cmd)) [NoEvalInput] (++ "eval: No input given.\n" (brief-usage "eval")) [(FinkelToolException msg)] msg)) (defn (:: brief-usage (-> String String)) [cmd] (++ "Try `" (unsafePerformIO getProgName) " help " cmd "' for usage.")) (defn (:: finkel-tool-exception-handler (-> (IO a) (IO a))) (lefn [(:: handler (-> FinkelToolException (IO a))) (handler [e] (do ($ (hPutStrLn stderr) displayException e) exitFailure))] (handle handler))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/IO.hs ================================================ ;;; -*- mode: finkel -*- ;;;; IO related function for REPL (defmodule Finkel.Tool.Internal.IO (export read-form read-print-loop with-io-redirect) (require ;; finkel-core (Finkel.Tool.Internal.Macro.Ghc)) (import ;; base (Control.Concurrent [MVar ThreadId killThread newEmptyMVar putMVar takeMVar throwTo]) (Control.Exception [(AsyncException ..) catch throwIO]) (Control.Monad.Catch [(MonadMask ..) bracket]) (Control.Monad [when]) (Control.Monad.IO.Class [(MonadIO ..)]) (Data.List [intercalate isPrefixOf isSubsequenceOf]) (GHC.IO.Handle [hDuplicate hDuplicateTo]) (System.IO [Handle (SeekMode ..) hClose hFlush hGetLine hSeek hSetFileSize stdout]) (System.IO.Error [isEOFError]) ;; deepseq (Control.DeepSeq) ;; finkel-kernel (Language.Finkel) (Language.Finkel.Lexer [evalSP]) (Language.Finkel.Reader [sexpr]) ;; finkel-core (Finkel.Core.Functions [make-symbol]) ;; Internal (Finkel.Tool.Internal.CLI) (Finkel.Tool.Internal.Types))) (imports-from-ghc (GHC.Data.StringBuffer [appendStringBuffers stringToStringBuffer])) ;;; Read and print loop (defn (:: read-print-loop (=> (MonadIO cl) (CLI cl) (HasReplState cl) (-> Code (MVar Input) ThreadId (cl ())))) "Loop for reading input and printing the output. Tracks the state of intermediate S-expression from input, and continue reading the input until successful parse result." [init-form to-mvar eval-tid] (lefn [(go [result-mv] (do (<- st0 getReplState) (lefn [(prompt (if (null (pending-input st0)) (prompt-string st0) "")) (reset-pending [st] (st {(= pending-input Nothing)}))]) (<- mb-input ;; Handle interrupt signals thrown while waiting for input, to ;; handle `Ctrl-C' key presses without valid evaluation form, ;; and to refresh intermediate user inputs in Repl state. (handleInterrupt (do (putReplState (reset-pending st0)) (return (Just []))) (withInterrupt (getString prompt)))) (maybe quit (go1 st0 result-mv) mb-input))) (go1 [st0 result-mv line] (case line (: h tl) (| ((== line "(quit)") quit) ((null (pending-input st0)) (== #', h) (if (isSubsequenceOf tl "quit") quit (go-command result-mv tl))) (otherwise (go-line result-mv line))) [] (go result-mv))) (go-command [result-mv lin] ;; Using raw symbol for non-mangled REPL commands, to skip replacing ;; hyphens to underscores. Otherwise, command arguments like ;; "ghc-boot" will be replaced to "ghc_boot" by the parser. (if (mangled-command lin) (go-line result-mv (concat ["(repl-macro " lin ")"])) (go-form result-mv (as-repl-macro lin)))) (go-line [result-mv line] (do (<- mb-form (read-form line)) (maybe (go result-mv) (go-form result-mv) mb-form))) (go-form [result-mv form] ;; Handle interrupt signals thrown while evaluation thread is ;; working. Give a chance to interrupt here, after parsing input and ;; before printing outputs. (do (handleInterrupt (do (liftIO (throwTo eval-tid UserInterrupt)) (print-io result-mv)) (withInterrupt (do (liftIO (putMVar to-mvar (Input Prompt form result-mv))) (print-io result-mv)))) (go result-mv))) (quit ($ liftIO killThread eval-tid))] ;; Print the result from boot expression, then start the loop. (do (<- result-mv (liftIO newEmptyMVar)) (liftIO (putMVar to-mvar (Input Prompt init-form result-mv))) (print-io result-mv) (go result-mv)))) (defn (:: print-io (=> (MonadIO m) (CLI m) (-> (MVar Result) (m ())))) [result-mv] (lefn [(pr [str] (when (not (null str)) (>> (putString str) (liftIO (hFlush stdout)))))] (case-do (liftIO (takeMVar result-mv)) (Right str) (pr str) (Left str) (pr str)))) (defn (:: read-form (=> (HasReplState repl) (MonadIO repl) (-> String (repl (Maybe Code))))) "Read single S-expression form." [input0] (do (<- st getReplState) (lefn [(input1 (stringToStringBuffer (: #'\n input0))) (put-and-return [pending ret] (do (putReplState (st {(= pending-input pending)})) (return ret)))]) (<- input2 (liftIO (maybe (pure input1) (flip appendStringBuffers input1) (pending-input st)))) (case (evalSP sexpr (Just "") input2) (Right forms) (put-and-return Nothing (Just forms)) (Left _err) (put-and-return (Just input2) Nothing)))) ;;; IO redirect (defn (:: with-io-redirect (=> (MonadIO m) (MonadMask m) (-> Handle (m a) (m (, a String))))) "Execute given action with redirecting stdout to given 'Handle'." [hdl action] (bracket (liftIO (do (<- stdout2 (hDuplicate stdout)) (hSetFileSize hdl 0) (hSeek hdl AbsoluteSeek 0) (hDuplicateTo hdl stdout) (return stdout2))) (\stdout2 (liftIO (do (hDuplicateTo stdout2 stdout) (hClose stdout2)))) (\_stdout2 (do (<- x action) (liftIO (do (hFlush stdout) (hSeek hdl AbsoluteSeek 0) (<- ls (get-lines hdl)) (lept [contents (intercalate "\n" ls)]) (deepseq contents (return (, x contents))))))))) (defn (:: get-lines (-> Handle (IO [String]))) (lefn [(go [acc hdl] (catch (do (<- l (hGetLine hdl)) (go (: l acc) hdl)) (\e (if (isEOFError e) (return (reverse acc)) (throwIO e)))))] (go []))) ;;; Auxiliary (defn (:: mangled-command (-> String Bool)) [lin] (lept [commands ["expand" "expand!" "info" "kind" "load" "type"]] (case (words lin) (: w _) (any (isPrefixOf w) commands) _ False))) (defn (:: as-repl-macro (-> String Code)) [str] `(repl-macro ,@(map make-symbol (words str)))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/Listen.hs ================================================ ;;; -*- mode: finkel -*- ;;; Loop for network connection. (defmodule Finkel.Tool.Internal.Listen (export listener accept-loop run-conn) (require ;; finkel-core (Finkel.Tool.Internal.Macro.Ghc)) (import ;; base (Control.Concurrent [(MVar) forkIO newEmptyMVar putMVar takeMVar]) (Control.Exception [(Exception ..) (SomeException ..) handle]) (Control.Monad [void unless when]) (Data.Char [isSpace]) (System.IO [(BufferMode ..) (IOMode ..) hClose hFlush hPutStr hSetBuffering hSetEncoding utf8]) ;; bytestring (Data.ByteString.Internal [toForeignPtr]) (qualified Data.ByteString.Char8 as BS) ;; network (Network.Socket [(AddrInfo ..) (AddrInfoFlag ..) PortNumber Socket (SocketOption ..) (SocketType ..) accept bind defaultHints getAddrInfo listen socket socketToHandle setSocketOption withSocketsDo]) ;; finkel-kernel (Language.Finkel.Lexer [evalSP]) (Language.Finkel.Reader [sexpr]) ;; internal (Finkel.Tool.Internal.Types))) (imports-from-ghc (GHC.Data.StringBuffer [(StringBuffer ..)])) (defn (:: listener (-> PortNumber (MVar Input) (IO ()))) [pnum mvar] (withSocketsDo (lefn [(hints (defaultHints {(= addrFlags [AI_PASSIVE]) (= addrSocketType Stream)})) (start-loop [addr] (do (<- sock (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))) (setSocketOption sock ReuseAddr 1) (bind sock (addrAddress addr)) (listen sock 2) (accept-loop sock mvar)))] (case-do (getAddrInfo (Just hints) Nothing (Just (show pnum))) (: addr _) (start-loop addr) _ (putStrLn "listener: unable to open address."))))) (defn (:: accept-loop (-> Socket (MVar Input) (IO ()))) [sock mvar] (do (<- (, conn _) (accept sock)) (<- _ (forkIO (run-conn conn mvar))) (accept-loop sock mvar))) (defn (:: run-conn (-> Socket (MVar Input) (IO ()))) [sock mvar] (do (<- hdl (socketToHandle sock ReadWriteMode)) (hSetBuffering hdl (BlockBuffering Nothing)) (hSetEncoding hdl utf8) (hPutStr hdl "Connected to Finkel REPL.") (hFlush hdl) (<- my-mvar newEmptyMVar) (lefn [(handler [(SomeException e)] (do (putStrLn (++ "run-conn: " (show e))) (hClose hdl))) (put-input [form] (putMVar mvar (Input Connection form my-mvar))) (read-loop ;; `BS.hGetSome' returns empty contents when the handle is closed. ;; Also, empty lines could be sent as input, evaluating the form ;; only when it contained non-space characters. (do (<- bs (BS.hGetSome hdl 65535)) (unless (BS.null bs) (do (when (BS.any (. not isSpace) bs) (lept [(, fp o l) (toForeignPtr bs) sbuf (StringBuffer fp l o)] (case (evalSP sexpr (Just "") sbuf) (Right form) (put-input form) (Left err) (putStrLn (displayException err))))) read-loop)))) (print-loop (do (<- result (takeMVar my-mvar)) (case result (Right r) (hPutStr hdl r) (Left err) (hPutStr hdl err)) (hFlush hdl) print-loop))]) (void (forkIO print-loop)) (handle handler read-loop))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/Loop.hs ================================================ ;;; -*- mode: finkel -*- ;;; Starting REPL (defmodule Finkel.Tool.Internal.Loop (export start-repl acquire-repl cleanup-repl) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Concurrent [ThreadId forkIO]) (Control.Concurrent.MVar [MVar newEmptyMVar]) (Control.Exception [bracket catch throwIO]) (System.IO [Handle hClose openTempFile]) (System.IO.Error [isDoesNotExistError]) ;; directory (System.Directory [getTemporaryDirectory removeFile]) ;; haskeline (System.Console.Haskeline [defaultBehavior defaultSettings useFile runInputTBehavior]) ;; finkel-kernel (Language.Finkel.Form [Code]) (Language.Finkel.Fnk [(FnkEnv ..)]) ;; internal (Finkel.Tool.Internal.Eval) (Finkel.Tool.Internal.Listen) (Finkel.Tool.Internal.IO) (Finkel.Tool.Internal.Types))) ;;; Extra imports (cond-expand [(== :os "mingw32") (import System.IO (hSetEncoding stdin utf8))] [otherwise (:begin)]) ;;; Starting the REPL (defn (:: start-repl (-> [String] (Maybe FilePath) (Maybe Int) FnkEnv ReplState Code (IO ()))) "Start REPL, maybe listen to given port number when given." [ghc-opts mb-path mb-port fnk-env repl-st init-form] (bracket acquire-repl cleanup-repl (use-repl ghc-opts mb-path mb-port fnk-env repl-st init-form))) (defn (:: acquire-repl (IO (, FilePath Handle (MVar Input)))) "Return a file path and handle for temporary use." (do (<- dir getTemporaryDirectory) (<- (, path hdl) (openTempFile dir "finkel-repl-.out")) (<- mvar newEmptyMVar) (return (, path hdl mvar)))) (defn (:: cleanup-repl (-> (, FilePath Handle a) (IO ()))) "Clean up temporary file." [(, path hdl _)] (catch (do (hClose hdl) (removeFile path)) (\e (if (isDoesNotExistError e) (return ()) (throwIO e))))) (defn (:: use-repl (-> [String] (Maybe FilePath) (Maybe Int) FnkEnv ReplState Code (, a Handle (MVar Input)) (IO ()))) "Inner work for `start-repl'." [ghc-opts mb-path mb-port fnk-env repl-st init-form (, _ hdl in-mv)] (do (mapM- (start-listener in-mv) mb-port) (<- tid (fork-eval-loop ghc-opts hdl in-mv fnk-env)) (lept [rpl (read-print-loop init-form in-mv tid) behavior (maybe defaultBehavior useFile mb-path) run (runInputTBehavior behavior defaultSettings)]) ;; Using UTF-8 for Windows. See "GHCi.UI.interactiveUI" (cond-expand [(== :os "mingw32") (hSetEncoding stdin utf8)] [otherwise (return ())]) (run-repl (run rpl) repl-st))) (defn (:: start-listener (-> (MVar Input) Int (IO ThreadId))) "Start listner in separate thread, and return temporary file for getting String output from statement." [in-mv port] (do (putStrLn (++ "Listening on port " (show port))) (forkIO (listener (fromIntegral port) in-mv)))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/Macro/Ghc.hs ================================================ ;;; -*- mode: finkel -*- ;;; Module containing ghc version compatibililty macro. (defmodule Finkel.Tool.Internal.Macro.Ghc (export imports-from-ghc) (import ;; base (Control.Exception [throw]) ;; finkel-core (Finkel.Prelude) (Finkel.Core.Internal [__glasgow_haskell__]))) ;;; Module name aliases (data GhcModuleName (Pre902 Code Code) (Pre900 Code)) (defn (:: hscTypes GhcModuleName) (Pre902 'GHC.Driver.Types 'HscTypes)) (defn (:: basicTypes GhcModuleName) (Pre902 'GHC.Types.Basic 'BasicTypes)) (defn (:: ghc-module-name-aliases [(, Code GhcModuleName)]) "List of `Code' and `GhcModuleName' pairs, to relate module names in latest ghc with module names in older versions." [(, 'GHC (Pre900 'GHC)) (, 'GHC.Core.FamInstEnv (Pre900 'FamInstEnv)) (, 'GHC.Core.InstEnv (Pre900 'InstEnv)) (, 'GHC.Core.TyCo.Rep (Pre900 'TyCoRep)) (, 'GHC.Data.Bag (Pre900 'Bag)) (, 'GHC.Data.FastString (Pre900 'FastString)) (, 'GHC.Data.OrdList (Pre900 'OrdList)) (, 'GHC.Data.StringBuffer (Pre900 'StringBuffer)) (, 'GHC.Driver.CmdLine (Pre900 'CmdLineParser)) (, 'GHC.Driver.Main (Pre900 'HscMain)) (, 'GHC.Driver.Make (Pre900 'GhcMake)) (, 'GHC.Driver.Monad (Pre900 'GhcMonad)) (, 'GHC.Driver.Ppr (Pre902 'GHC.Utils.Outputable 'Outputable)) (, 'GHC.Driver.Session (Pre900 'DynFlags)) (, 'GHC.Driver.Env hscTypes) (, 'GHC.Driver.Errors hscTypes) (, 'GHC.Iface.Syntax (Pre900 'IfaceSyn)) (, 'GHC.Parser (Pre900 'Parser)) (, 'GHC.Parser.Lexer (Pre900 'Lexer)) (, 'GHC.Parser.PostProcess (Pre900 'RdrHsSyn)) (, 'GHC.Runtime.Context hscTypes) (, 'GHC.Runtime.Debugger (Pre900 'Debugger)) (, 'GHC.Runtime.Eval (Pre900 'InteractiveEval)) (, 'GHC.Runtime.Interpreter (Pre900 'GHCi)) (, 'GHC.Runtime.Linker (Pre900 'Linker)) (, 'GHC.Settings.Config (Pre900 'Config)) (, 'GHC.Types.Basic (Pre900 'BasicTypes)) (, 'GHC.Types.Fixity basicTypes) (, 'GHC.Types.Fixity.Env hscTypes) (, 'GHC.Types.Name (Pre900 'Name)) (, 'GHC.Types.Name.Set (Pre900 'NameSet)) (, 'GHC.Types.SrcLoc (Pre900 'SrcLoc)) (, 'GHC.Types.SourceError hscTypes) (, 'GHC.Types.SourceText basicTypes) (, 'GHC.Types.Target hscTypes) (, 'GHC.Types.TyThing hscTypes) (, 'GHC.Types.TyThing.Ppr (Pre902 'GHC.Core.Ppr.TyThing 'PprTyThing)) (, 'GHC.Types.Var (Pre900 'Var)) (, 'GHC.Unit.Finder (Pre902 'GHC.Driver.Finder 'Finder)) (, 'GHC.Unit.Module (Pre900 'Module)) (, 'GHC.Unit.Module.Graph hscTypes) (, 'GHC.Unit.Module.ModSummary hscTypes) (, 'GHC.Unit.Home.ModInfo hscTypes) (, 'GHC.Utils.Error (Pre900 'ErrUtils)) (, 'GHC.Utils.IO.Unsafe (Pre900 'FastFunctions)) (, 'GHC.Utils.Lexeme (Pre900 'Lexeme)) (, 'GHC.Utils.Misc (Pre900 'Util)) (, 'GHC.Utils.Outputable (Pre900 'Outputable))]) ;;; Auxiliary functions (defn (:: rename-ghc-module (-> Code Code)) [name] (lefn [(legacy [m1 m2] (if (<= 900 __glasgow_haskell__) m1 m2)) (reloc (flip asLocOf name)) (msg (++ "Could not find module ‘" (show name) "’"))] (case (lookup name ghc-module-name-aliases) _ (| ((<= 902 __glasgow_haskell__) name)) (Just (Pre902 m900 m8xx)) (legacy (reloc m900) (reloc m8xx)) (Just (Pre900 m8xx)) (legacy name (reloc m8xx)) _ (throw (FinkelSrcError name msg))))) (defn (:: make-import (-> Code Code)) [form] `(import ,(rename-ghc-module (car form)) ,(curve (cadr form)))) ;;; Exported macro (defmacro imports-from-ghc "Macro for version compatible import declaration for @ghc@. Expects module names in latest released @ghc@, returns old module name as necessary. Takes multiple modules in single form. This macro is for internal use. The covered modules are used by @finkel-core@ and @finkel-tool@ packages." form `(:begin ,@(map1 make-import form))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/Macro/Repl.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Macros used in REPL. ;;; This module contains macros accessible only from REPL. Main purpose ;;; of using macros for REPL is to access runtime value of ;;; `FnkEnv'. Macro body can contain codes accessing `FnkEnv', and then ;;; the code could be invoked from REPL via evaluating the typed in ;;; forms. (defmodule Finkel.Tool.Internal.Macro.Repl (export repl-macro compile-and-import) (require ;; Internal (Finkel.Tool.Internal.Macro.Ghc)) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Prelude hiding [<>]) (Control.Exception [(Exception ..) (SomeException ..) try]) (Control.Monad [filterM unless void when]) (Control.Monad.IO.Class [(MonadIO ..)]) (Data.Foldable [toList]) (Data.Function [on]) (Data.List [find intercalate intersperse isPrefixOf partition sortBy]) (Data.Maybe [catMaybes]) (System.Console.GetOpt [(ArgOrder ..) getOpt]) (Text.Printf [printf]) (Text.Read [readMaybe]) ;; directory (System.Directory [getCurrentDirectory getHomeDirectory setCurrentDirectory]) ;; filepath (System.FilePath [normalise]) ;; exceptions (Control.Monad.Catch [catch bracket]) ;; process (System.Process [callProcess]) ;; finkel-kernel (Language.Finkel) (Language.Finkel.Eval [evalExprType evalTypeKind]) (Language.Finkel.Form [mkLocatedForm]) (Language.Finkel.Make [buildHsSyn discardInteractiveContext simpleMake clearExpandedCodeCache]) (Language.Finkel.Fnk [(FnkEnv ..) getFnkEnv macroNames modifyFnkEnv putFnkEnv setDynFlags setFnkVerbosity updateDynFlags]) (Language.Finkel.Options [fnkEnvOptions partitionFnkEnvOptions]) (Language.Finkel.Syntax [parseExpr parseType]) (Language.Finkel.Make [asModuleName]) ;; finkel-core (Finkel.Core.Functions) ;; Internal (Finkel.Tool.Internal.Compat))) ;;; ghc (imports-from-ghc (GHC [(ModuleInfo) findModule getBindings getModSummary getModuleGraph getModuleInfo getTargets isLoaded lookupName lookupModule modInfoExports setSessionDynFlags setTargets workingDirectoryChanged]) (GHC.Core.FamInstEnv [FamInst pprFamInst]) (GHC.Core.InstEnv [ClsInst pprInstance]) (GHC.Data.FastString [FastString fsLit unpackFS]) (GHC.Driver.Env [(HscEnv ..)]) (GHC.Driver.Make [(LoadHowMuch ..)]) (GHC.Driver.Monad [(GhcMonad ..) getSessionDynFlags withTempSession]) (GHC.Driver.Ppr [showSDoc showSDocForUser showPpr]) (GHC.Driver.Session [(DynFlags ..) (GhcMode ..) (HasDynFlags ..) (Language ..) (PackageFlag ..) (GeneralFlag ..) defaultDynFlags fFlags flagSpecFlag flagSpecName gopt lang_set parseDynamicFlagsCmdLine settings xFlags xopt wopt wWarningFlags]) (GHC.Iface.Syntax [showToHeader]) (GHC.Runtime.Context [(InteractiveImport ..)]) (GHC.Runtime.Debugger [pprTypeAndContents]) (GHC.Runtime.Eval [abandonAll getContext getInfo moduleIsInterpreted parseName setContext showModule]) (GHC.Types.Basic [(SuccessFlag ..)]) (GHC.Types.Fixity [Fixity defaultFixity]) (GHC.Types.Name [Name getName nameModule nameOccName nameSrcSpan pprInfixName]) (GHC.Types.Name.Set [elemNameSet mkNameSet]) (GHC.Types.SourceError [srcErrorMessages]) (GHC.Types.SrcLoc [getLoc isGoodSrcSpan mkGeneralLocated unLoc]) (GHC.Types.Target [(Target ..) (TargetId ..) pprTarget]) (GHC.Types.TyThing [(TyThing ..) tyThingParent_maybe]) (GHC.Types.TyThing.Ppr [pprTyThing pprTyThingInContextLoc]) (GHC.Unit.Finder (flushFinderCaches uncacheModule)) (GHC.Unit.Home.ModInfo [pprHPT]) (GHC.Unit.Module [ModuleName mkModuleName mkModuleNameFS moduleNameString]) (GHC.Unit.Module.Graph [mgModSummaries]) (GHC.Unit.Module.ModSummary [(ModSummary ..) ms-mod-name]) (GHC.Utils.Misc [looksLikeModuleName]) (GHC.Utils.Outputable [SDoc $$ <+> <> empty dcolon hsep nest ppr sep text vcat])) ;;; Extra imports (import GHC.Hs.ImpExp ((ImportDecl ..) simpleImportDecl)) (cond-expand [(<= 904 :ghc) (:begin (import qualified GHC) (import GHC.Core.TyCo.Ppr (pprSigmaType)) (import GHC.Driver.Env (hsc-HPT hsc-home-unit hscActiveUnitId)) (import GHC.Driver.Make ((ModIfaceCache ..))))] [otherwise (imports-from-ghc (GHC (Type)) (GHC.Types.SourceText [(StringLiteral ..)]) (GHC.Types.TyThing.Ppr [pprTypeForUser]))]) (cond-expand [(<= 906 :ghc) (import GHC.Driver.Backend (backendCanReuseLoadedCode))] [(<= 902 :ghc) (import GHC.Driver.Backend (backendProducesObject))] [otherwise (imports-from-ghc (GHC.Driver.Session [isObjectTarget]))]) (cond-expand [(<= 902 :ghc) (:begin (import GHC.Driver.Env (hsc-units)) (import GHC.Linker.Loader (initLoaderState showLoaderState)))] [otherwise (imports-from-ghc (GHC.Runtime.Linker [initDynLinker showLinkerState]))]) (cond-expand [(<= 902 :ghc) (import GHC.Runtime.Interpreter ((Message ..) interpCmd))] [otherwise (imports-from-ghc (GHC.Runtime.Interpreter [(Message ..) iservCmd]))]) (cond-expand [(<= 900 :ghc) (:begin (import GHC.Types.SrcLoc (leftmost-smallest)) (import GHC.Unit.Module ((Module) moduleName)) (import qualified GHC.Driver.Make as GhcMake))] [otherwise (:begin (imports-from-ghc (GHC.Unit.Module [(Module ..)])) (import qualified GhcMake))]) ;;; Types (type ReplAction (-> [Code] (Fnk Code))) (data ReplCmd (ReplCmd {(:: rc-name String) (:: rc-args [String]) (:: rc-action ReplAction) (:: rc-help String)})) ;;; Auxiliary functions (cond-expand [(<= 904 :ghc) (:begin)] [otherwise (defn (:: pprSigmaType (-> Type SDoc)) pprTypeForUser)]) (defn (:: showUnitId (-> DynFlags String)) [dflags] (cond-expand [(<= 902 :ghc) (showPpr dflags (homeUnitId_ dflags))] [(<= 900 :ghc) (showPpr dflags (homeUnitId dflags))] [otherwise (showPpr dflags (thisInstalledUnitId dflags))])) (defn (:: gen-default-dflags (-> DynFlags DynFlags)) [flg] (cond-expand [(<= 906 :ghc) (defaultDynFlags (settings flg))] [otherwise (defaultDynFlags (settings flg) (llvmConfig flg))])) (defn (:: show-linker-state (-> HscEnv (IO ()))) [hsc-env] (cond-expand [(<= 902 :ghc) (case (hsc-interp hsc-env) (Just interp) (do (<- sdoc (showLoaderState interp)) (putStrLn (showPpr (hsc-dflags hsc-env) sdoc))) _ (pure ()))] [(<= 900 :ghc) (do (<- sdoc (showLinkerState (hsc-dynLinker hsc-env))) (putStrLn (showPpr (hsc-dflags hsc-env) sdoc)))] [otherwise (showLinkerState (hsc-dynLinker hsc-env) (hsc-dflags hsc-env))])) (defn (:: rts-revert-cafs (Fnk ())) (cond-expand [(<= 902 :ghc) (case-do (fmap hsc-interp getSession) (Just interp) (liftIO (interpCmd interp RtsRevertCAFs)) _ (pure ()))] [otherwise (do (<- hsc-env getSession) (liftIO (iservCmd hsc-env RtsRevertCAFs)))])) (defn (:: is-interpreting (-> DynFlags Bool)) (cond-expand [(<= 906 :ghc) (. backendCanReuseLoadedCode backend)] [(<= 902 :ghc) (. not backendProducesObject backend)] [otherwise (. not isObjectTarget hscTarget)])) (defn (:: mk-ii (-> ModuleName InteractiveImport)) (. IIDecl simpleImportDecl)) (defn (:: mk-ii-fs (-> FastString InteractiveImport)) (. mk-ii mkModuleNameFS)) (defn (:: mk-ii-str (-> String InteractiveImport)) (. mk-ii-fs fsLit)) (defn (:: code-to-mb-string (-> Code (Maybe String))) (. (fmap unpackFS) code-to-mb-fs)) (defn (:: code-to-mb-fs (-> Code (Maybe FastString))) [code] (case (unCode code) (Atom (ASymbol s)) (Just s) (Atom (AString _ s)) (Just s) _ Nothing)) (defn (:: located-list (-> [Code] Code)) [xs] (case xs [] nil _ (LForm (L (getLoc (mkLocatedForm xs)) (List xs))))) (defn (:: show-sdoc-for-user-m (-> SDoc (Fnk String))) [sdoc] (do (<- hsc-env getSession) (<- unqual get-name-ppr-ctx) (lept [dflags (hsc-dflags hsc-env) str (cond-expand [(<= 902 :ghc) (showSDocForUser dflags (hsc-units hsc-env) unqual sdoc)] [otherwise (showSDocForUser dflags unqual sdoc)])]) (pure str))) (defn (:: invalid-form (-> String [Code] (Fnk a))) [label forms] (lept [form (car (located-list forms)) msg (concat [label ": invalid form `" (show form) "'"])] (finkelSrcError form msg))) (defn (:: onTheREPL (-> a (Located a))) (mkGeneralLocated "on the REPL")) (defn (:: compile-module (-> [(Located String)] (Fnk SuccessFlag))) [lstrs] (where (bracket acquire cleanup work) (defn acquire (do (<- dflags getDynFlags) (<- fnk-env getFnkEnv) (return (, dflags fnk-env)))) (defn cleanup [(, dflags fnk-env)] (do (setDynFlags dflags) (modifyFnkEnv (\e (e {(= envQualifyQuotePrimitives (envQualifyQuotePrimitives fnk-env))}))))) (defn work [(, dflags fnk-env)] (do (putFnkEnv (fnk-env {(= envQualifyQuotePrimitives False)})) (lept [force-recomp (gopt Opt-ForceRecomp dflags)]) (<- success-flag (simpleMake (zip lstrs (repeat Nothing)) force-recomp Nothing)) ;; As done in `GHCi.UI', reverting CAFs on load. rts-revert-cafs (return success-flag))))) (defn (:: compile-and-import (-> [(Located FilePath)] (Fnk SuccessFlag))) [lpaths] (do (<- fnk-env getFnkEnv) clearExpandedCodeCache (lefn [(imps0 (map mk-ii-str (envContextModules fnk-env))) (:: adjust-module (-> (Located String) (Fnk InteractiveImport))) (adjust-module [lpath] (lept [name1 (asModuleName (unLoc lpath)) name2 (if (null name1) "Main" name1) name3 (mkModuleNameFS (fsLit name2))] (do (<- mdl (getModSummary name3)) (<- is-interp (moduleIsInterpreted (ms-mod mdl))) (return (if is-interp (IIModule name3) (mk-ii name3))))))]) ;; As done in ghci, adding `IIModule' if the module is interpreted as ;; bytecode, adding `IIDecl' otherwise. Safe Haskell setting in DynFlags ;; is ignored at the moment. (<- success-flag (compile-module lpaths)) (case success-flag Succeeded (do (<- mdls (mapM adjust-module lpaths)) (setContext (++ mdls imps0))) Failed (setContext imps0)) (return success-flag))) (defn (:: adjust-current-target (-> FilePath [InteractiveImport] (Fnk [InteractiveImport]))) "Adjust current IIModule target to IIDecl if current HscTarget is object code." [path imports] (do (<- dflags getDynFlags) (lefn [(current-module-name (mkModuleName (asModuleName path))) (iimodule-to-iidecl [ii] (case ii (IIModule mname) (| ((== mname current-module-name) (mk-ii mname))) _ ii)) (iidecl-to-iimodule [ii] (case ii (IIDecl idecl) (| ((== (unLoc (ideclName idecl)) current-module-name) (IIModule current-module-name))) _ ii)) (ii-fn (if (not (is-interpreting dflags)) iimodule-to-iidecl iidecl-to-iimodule))]) (return (map ii-fn imports)))) (defn (:: env-context-on-exception (-> (Fnk Code) (Fnk Code))) [action] (catch action (\e (do (lefn [(print-se [se] (do (<- dflags getSessionDynFlags) (liftIO (putStr (unlines (map (showSDoc dflags) (msgs se))))))) (msgs [se] (ppr-wrapped-msg-bag-with-loc (srcErrorMessages se)))]) (maybe (liftIO (print e)) print-se (fromException e)) (<- mods (fmap envContextModules getFnkEnv)) (setContext (map mk-ii-str mods)) (return '(:begin)))))) (defn (:: sort-by-name-src-span (-> [Name] [Name])) (cond-expand [(<= 900 :ghc) (sortBy (on leftmost-smallest nameSrcSpan))] [otherwise (sortBy (on compare nameSrcSpan))])) (defn (:: browse-module (-> Module ModuleInfo (Fnk Code))) "Simplified version of `GHCi.UI.browseModule'." [mdl mod-info] (lefn [(loc-sort [ns] (| ((<- (: n _) ns) (isGoodSrcSpan (nameSrcSpan n)) (sort-by-name-src-span ns)) (otherwise (occ-sort ns)))) (occ-sort (sortBy (on compare nameOccName)))] (lept [names (modInfoExports mod-info) (, local external) (partition (. (== mdl) nameModule) names) sorted-names (++ (loc-sort local) (occ-sort external)) pretty (pprTyThing showToHeader)] (do (<- mb-things (mapM lookupName sorted-names)) (lept [things (catMaybes mb-things) prettyThings (map pretty things)]) (<- str (show-sdoc-for-user-m (vcat prettyThings))) (return `(System.IO.putStrLn ,str)))))) (defn (:: expand-with (-> String (-> Code (Fnk Code)) ReplAction)) [label f forms] (case forms [] (return '(:begin)) [expr] (>>= (f expr) (\x (return `(System.IO.print ',x)))) _ (invalid-form label forms))) ;;; Mostly translated from `GHCi.UI.infoThing'. (defn (:: info-name (-> Code (Fnk Code))) [thing] (do (<- sdoc (info-thing True (show thing))) (<- str (show-sdoc-for-user-m sdoc)) (return `(System.IO.putStrLn ,str)))) (defn (:: info-thing (-> Bool String (Fnk SDoc))) [all-info str] (where (do (<- names (parseName str)) (<- mb_stuffs (mapM (getInfo all-info) names)) (lept [filtered (filter-out-children child-filter (catMaybes (toList mb_stuffs)))]) (return (vcat (intersperse (text "") (map ppr-info filtered))))) (defn child-filter [(, a _ _ _ _)] a) (defn ppr-info [(, thing fixity cls fam _)] (__ppr-info thing fixity cls fam)))) (defn (:: __ppr-info (-> TyThing Fixity [ClsInst] [FamInst] SDoc)) [thing fixity cls fam] (lept [show-fixity (if (== fixity defaultFixity) empty (<+> (ppr fixity) (pprInfixName (getName thing))))] ($$ (pprTyThingInContextLoc thing) show-fixity (vcat (map pprInstance cls)) (vcat (map pprFamInst fam))))) (defn (:: filter-out-children (-> (-> a TyThing) [a] [a])) [get-thing xs] (lefn [(all-names (mkNameSet (map (. getName get-thing) xs))) (has-parent [x] (case (tyThingParent-maybe (get-thing x)) (Just p) (elemNameSet (getName p) all-names) _ False))] (filter (. not has-parent) xs))) (defn (:: clear-all-targets (=> (GhcMonad m) (m ()))) (do (setTargets []) (void (GhcMake.load LoadAllTargets)))) (defn (:: clear-caches (Fnk ())) (cond-expand [(<= 904 :ghc) (do (<- fnk-env getFnkEnv) (lept [clear (. void liftIO iface-clearCache)]) (mapM- clear (envInterpModIfaceCache fnk-env)))] [otherwise (pure ())])) ;;; Functions for show command (defn (:: show-bindings (Fnk Code)) (where (do (<- bs getBindings) (<- docs (mapM make-doc (reverse bs))) (<- str (show-sdoc-for-user-m (vcat docs))) (return `(System.IO.putStrLn ,str))) (defn (:: make-doc (-> TyThing (Fnk SDoc))) [tt] (case tt (AnId i) (pprTypeAndContents i) _ (do (<- mb-stuff (getInfo False (getName tt))) (return (maybe (text "") ppr-tt mb-stuff))))) (defn ppr-tt [(, thing _ _ _ _)] (pprTyThing showToHeader thing)))) (defn (:: show-context (Fnk Code)) (where (do (<- context getContext) (<- dflags getSessionDynFlags) (return `(System.IO.putStr ,(result dflags context)))) (defn result [dflags context] (unlines (: "; context" (map (context-string dflags) context)))) (defn context-string [dflags ctx] (case ctx (IIDecl d) (++ "; IIDecl: " (showSDoc dflags (ppr d))) (IIModule m) (++ "; IIModule: " (moduleNameString m)))))) (defn (:: show-backend (-> DynFlags String)) (cond-expand [(<= 902 :ghc) (. show backend)] [otherwise (. show hscTarget)])) (defn (:: show-dflags (Fnk Code)) (lefn [(ss [dflags] ["; dflags:" (++ "; ghcLink: " (show (ghcLink dflags))) (++ "; ghcMode: " (showGhcMode (ghcMode dflags))) (++ "; backend: " (show-backend dflags)) (++ "; objectDir: " (show (objectDir dflags))) (++ "; homeUnitId: " (showUnitId dflags)) (++ "; forceRecomp: " (show (gopt Opt-ForceRecomp dflags)))]) (showGhcMode [m] (case m CompManager "CompManager" OneShot "OneShot" MkDepend "MkDepend"))] (do (<- dflags getDynFlags) (return `(System.IO.putStr ,($ unlines ss dflags)))))) (defn (:: show-hpt (Fnk Code)) "Show home package table." (do (<- hsc-env getSession) (<- str0 (show-sdoc-for-user-m (pprHPT (hsc-HPT hsc-env)))) (lept [str1 (if (null str0) "show: no home package table found" str0)]) (return `(System.IO.putStrLn ,str1)))) ;;; Mostly taken from `GHCi.UI.showLanguages''. (defn (:: show-language (-> Bool (Fnk Code))) [show-all] (do (<- dflags getDynFlags) (lefn [(setting [test flag] (where (| (quiet empty) (is-on (<> (text "-X") (text name))) (otherwise (<> (text "-XNo") (text name)))) (= name (flagSpecName flag)) (= f (flagSpecFlag flag)) (= is-on (test f dflags)) (= quiet (&& (not show-all) (== (test f default-dflags) is-on))))) (default-lang (cond-expand [(<= 902 :ghc) GHC2021] [otherwise Haskell2010])) (default-dflags (lang-set (gen-default-dflags dflags) (case (language dflags) Nothing (Just default-lang) other other)))]) (<- str (show-sdoc-for-user-m (vcat [(<> (text "base language is: ") (case (language dflags) Nothing (text (show default-lang)) (Just lang) (ppr lang))) ($$ (if show-all (text "all active language options:") (text "with the following modifiers:")) (nest 2 (vcat (map (setting xopt) xFlags))))]))) (return `(System.IO.putStrLn ,str)))) (defn (:: show-loader-state (-> HscEnv (IO ()))) [hsc-env] (cond-expand [(<= 902 :ghc) (case (hsc-interp hsc-env) (Just interp) (do (initLoaderState interp hsc-env) (show-linker-state hsc-env)) _ (pure ()))] [otherwise ;; XXX: `Linker.showLinkerState' reads from `v_PersistentLinkerState', ;; which is not exposed from the module its defined ... not sure how ;; to get resulting output as `String' other than redirecting output ;; to stdout. (>> (initDynLinker hsc-env) (show-linker-state hsc-env))])) (defn (:: show-linker (Fnk Code)) (do (<- hsc-env getSession) (liftIO (show-loader-state hsc-env)) (return '(:begin)))) (defn (:: show-macros (Fnk Code)) (do (<- macros (fmap envMacros getFnkEnv)) (lept [macro-strings (unlines (: "; macros: " (map (++ "; ") (macroNames macros))))]) (return `(System.IO.putStr ,macro-strings)))) (defn (:: show-modules (Fnk Code)) (do (<- graph0 getModuleGraph) (lept [graph1 (mgModSummaries graph0)]) (<- graph2 (filterM (. isLoaded ms_mod_name) graph1)) (<- mods (mapM showModule graph2)) (return `(System.IO.putStr ,(unlines mods))))) (defn (:: show-options (-> Bool (Fnk Code))) [show-all] (do (<- dflags getDynFlags) (lefn [(setting [prefix no-prefix test flag] (where (| (quiet empty) (is-on (<> (text prefix) (text name))) (otherwise (<> (text no-prefix) (text name)))) (= name (flagSpecName flag)) (= f (flagSpecFlag flag)) (= is-on (test f dflags)) (= quiet (&& (not show-all) (== (test f default-dflags) is-on))))) (default-dflags (gen-default-dflags dflags)) ((, ghciFlags others) (partition (\f (elem (flagSpecFlag f) flgs)) fFlags)) (flgs [Opt_PrintExplicitForalls Opt_PrintExplicitKinds Opt_PrintBindResult Opt_BreakOnException Opt_BreakOnError Opt_PrintEvldWithShow]) (sdocs [($$ (text "REPL specific dynamic flag settings:") (nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags)))) ($$ (text "other dynamic, non-language, flag settings:") (nest 2 (vcat (map (setting "-f" "-fno-" gopt) others)))) ($$ (text "warning settings:") (nest 2 (vcat (map (setting "-W" "-Wno-" wopt) wWarningFlags))))]) (printOthers `(Data.Foldable.mapM_ System.IO.putStrLn ,(map (showSDoc dflags) sdocs)))]) (<- printLang (show-language show-all)) (return `(>> ,printLang ,printOthers)))) (defn (:: show-packages (Fnk Code)) (do (<- dflags getDynFlags) (lefn [(pr (++ "; ")) (pr-flag [flag] (case flag (ExposePackage n _ _) (pr n) (HidePackage n) (pr (++ "hiding " n)))) (pkgs (: "; packages" (map pr-flag (packageFlags dflags))))]) (return `(System.IO.putStr ,(unlines pkgs))))) (defn (:: show-paths (Fnk Code)) (do (<- dflags getDynFlags) (<- cwd (liftIO getCurrentDirectory)) (lept [ipaths (importPaths dflags) result (unlines (concat [["; current working directory:" (++ "; " cwd) "; module import search paths:"] (if (null ipaths) ["; none"] (map (++ "; ") ipaths))]))]) (return `(System.IO.putStr ,result)))) (defn (:: show-targets (Fnk Code)) (do (<- hsc-env getSession) (<- strs (mapM (. show-sdoc-for-user-m pprTarget) (hsc-targets hsc-env))) (return `(System.IO.putStrLn (++ "; targets: " ,(if (null strs) "none" (unwords strs))))))) ;;; REPL commands (defn (:: help-cmd ReplAction) [_form] (return `(System.IO.putStrLn ,(++ "DESCRIPTION: \n\ \\n\ \ REPL meta macro, ARGS varies per COMMAND.\n\ \\n\ \COMMANDS:\n\ \\n" (unlines (map (\rc (lept [pre (unwords (: (rc-name rc) (rc-args rc)))] (concat [" ," (printf "%-14s" pre) " - " (rc-help rc)]))) commands)))))) (defn (:: system-cmd ReplAction) "Invoke system command." [forms] ;; Using `callProces' which uses `System.Process.RawCommand' instead of ;; `System.Process.Shell', to support invoking commands without shell. (do (case (map show forms) [] (return ()) (: cmd rest) (liftIO (callProcess cmd rest))) (return '(:begin)))) ;;; Mostly taken from `GHCi.UI.guessCurrentModule'. (defn (:: guess-current-module (-> Code (Fnk Module))) [form] (case-do getContext (: (IIModule m) _) (findModule m Nothing) (: (IIDecl d) _) (cond-expand [(<= 904 :ghc) (do (<- pq (GHC.renameRawPkgQualM (unLoc (ideclName d)) (ideclPkgQual d))) (GHC.findQualifiedModule pq (unLoc (ideclName d))))] [otherwise (findModule (unLoc (ideclName d)) (fmap sl-fs (ideclPkgQual d)))]) _ (finkelSrcError form "browse: no current module"))) ;;; Mostly taken from `GHCi.UI.browseCmd'. (defn (:: browse-cmd ReplAction) [forms] (lefn [(go [mb-name] (case mb-name (Just name) (| ((looksLikeModuleName name) (>>= (lookupModule (mkModuleName name) Nothing) go'))) _ (>>= (guess-current-module (located-list forms)) go'))) (go' [mdl] (case-do (getModuleInfo mdl) (Just mod-info) (browse-module mdl mod-info) Nothing (lept [mname (moduleName mdl) str (moduleNameString mname) msg (++ "unknown module: " str)] (return `(System.IO.putStrLn ,msg)))))] (case (map unCode forms) [(Atom (ASymbol sym))] (go (Just (unpackFS sym))) [] (go Nothing) _ (invalid-form "browse" forms)))) (defn (:: expand-path (=> (MonadIO m) (-> FilePath (m FilePath)))) (lefn [(:: try-getHomeDirectory (IO (Either SomeException FilePath))) (try-getHomeDirectory (try getHomeDirectory)) (go [path] (case path (: #'~ rest) (case-do try-getHomeDirectory (Right home) (pure (normalise (++ home (: #'/ rest)))) (Left _) (pure path)) _ (return path)))] (. liftIO go))) ;;; From `GHCi.UI.changeDirectory'. (defn (:: cd-cmd ReplAction) "Function to change current directory." [forms] (lefn [(work [dir0] (do (<- graph getModuleGraph) (<- mods (fmap envContextModules getFnkEnv)) (when ($ not null mgModSummaries graph) (liftIO (putStrLn warn-unloading))) clear-all-targets clear-caches (setContext (map mk-ii-str mods)) workingDirectoryChanged (liftIO (do (<- dir1 (expand-path dir0)) (setCurrentDirectory dir1))) (return '(:begin)))) (warn-unloading (++ "Warning: " "changing directory causes all loaded modules to be unloaded\n" "because the search path has changed."))] (case forms [] (>>= (expand-path "~") work) [arg1] (| ((<- (Just path) (code-to-mb-string arg1)) (work path))) _ (invalid-form "cd" forms)))) (defn (:: expand-cmd ReplAction) "Expand given form for one layer." (expand-with "expand" expand1)) (defn (:: expand-full-cmd ReplAction) "Fully expand given form." (expand-with "expand!" expand)) (defn (:: info-cmd ReplAction) [forms] (case (map unCode forms) [(@ form (Atom (ASymbol _)))] (info-name (toCode form)) [(Atom AUnit)] (info-name (make-symbol "()")) [(HsList [])] (info-name (make-symbol "[]")) _ (invalid-form "info" forms))) ;; From `GHCi.UI.kindOfType' (defn (:: kind-cmd ReplAction) [forms] (case forms [form] (do (<- ty0 (buildHsSyn parseType forms)) (<- (, _ kind) (evalTypeKind ty0)) (lept [sdoc (hsep [(text (show form)) dcolon (pprSigmaType kind)])]) (<- str (show-sdoc-for-user-m sdoc)) (return `(System.IO.putStrLn ,str))) _ (invalid-form "kind" forms))) (defn (:: load-cmd ReplAction) "Load a module source code file. Handles absolute paths and relative paths from import directories." [forms] (lefn [(clear-all ;; Clear the main session, then clear the macro expander session. (do do-clear-all (case-do (fmap envSessionForExpand getFnkEnv) (Just mex-env-1) (do-clear-mex mex-env-1) _ (pure ())))) (do-clear-mex [hsc-env-1] (withTempSession (const hsc-env-1) (do do-clear-all (<- hsc-env-2 getSession) (modifyFnkEnv (\e (e {(= envSessionForExpand (Just hsc-env-2))})))))) (do-clear-all [] ;; See `loadModule'' in "ghc/GHCi/UI.hs". Clearing various states: ;; finder cache, targets, interactive context ... etc. (do (<- graph0 getModuleGraph) (<- _ abandonAll) clear-all-targets clear-caches (<- hsc-env getSession) (lept [graph1 (mgModSummaries graph0) uncache (cond-expand [(<= 904 :ghc) (\ ms (uncacheModule (hsc-FC hsc-env) (hsc-home-unit hsc-env) (ms-mod-name ms)))] [otherwise (. (uncacheModule hsc-env) ms_mod_name)])]) (liftIO (do (mapM_ uncache graph1) (cond-expand [(<= 904 :ghc) (flushFinderCaches (hsc-FC hsc-env) (hsc-unit-env hsc-env))] [otherwise (flushFinderCaches hsc-env)]))) (setSession (discardInteractiveContext hsc-env)))) (make-target [path] (do (<- hsc-env getSession) (lept [allow-obj (cond-expand [(<= 904 :ghc) ;; Deciding from target name, since the ;; "-fforce-recomp" option is always turned ;; ON when object code was not allowed. (not (isPrefixOf "*" path))] [otherwise ($ not is-interpreting hsc-dflags hsc-env)]) tfile (TargetFile path Nothing)]) (pure (cond-expand [(<= 904 :ghc) (Target tfile allow-obj (hscActiveUnitId hsc-env) Nothing)] [otherwise (Target tfile allow-obj Nothing)]))))] (case forms [form] (maybe (finkelSrcError form (++ "load: not a FilePath: " (show form))) (\path ;; Clear current state first. Then find the source file ;; path and compile, load, and link. (env-context-on-exception (do clear-all (<- target (make-target path)) (<- _ (setTargets [target])) (<- success-flag (compile-and-import [(onTheREPL path)])) (case success-flag Succeeded (liftIO (putStrLn (++ "; loaded " path))) _ (return ())) (return '(:begin))))) (code-to-mb-string form)) _ (invalid-form "load" forms)))) (defn (:: pwd-cmd ReplAction) "Function to show current directory." [_forms] (do (<- dir (liftIO getCurrentDirectory)) (return `,dir))) (defn (:: reload-cmd ReplAction) "Function to reload previously loaded module." [_forms] (case-do getTargets (cond-expand [(<= 904 :ghc) (: (Target target-id _ _ _) _)] [otherwise (: (Target target-id _ _) _)]) (env-context-on-exception (lept [tstr (case target-id (TargetFile path _) path (TargetModule mdl) (moduleNameString mdl))] (case-do (compile-and-import [(onTheREPL tstr)]) Succeeded (do (<- ctx0 getContext) (<- ctx1 (adjust-current-target tstr ctx0)) (setContext ctx1) (return `(System.IO.putStrLn ,(++ "; reloaded " tstr)))) Failed (return '(:begin))))) _ (return '(System.IO.putStrLn "; reload: invalid target")))) (defn (:: set-cmd ReplAction) "Set command line flags, see `GHCi.UI.newDynFlags'." [forms] (case forms (: _ _) ;; Always using `setSessionDynFlags' for `set' REPL command to support ;; `-package' flag. (do (lefn [(all-flags (foldr (\form acc (case (mb-symbol-name form) (Just name) (: name acc) _ acc)) [] forms)) ((, fnk-flags hs-flags) (partitionFnkEnvOptions all-flags)) (update-fnk-opts [opts fnk-env] (foldl (flip id) fnk-env opts))]) (when (not (null fnk-flags)) (case (getOpt Permute fnkEnvOptions fnk-flags) (, o _ []) (modifyFnkEnv (update-fnk-opts o)) (, _ _ es) (liftIO (print es)))) (<- hsc-env getSession) (lept [dflags0 (hsc-dflags hsc-env)]) (<- (, dflags1 leftovers warns) (parseDynamicFlagsCmdLine dflags0 (map onTheREPL hs-flags))) (liftIO (do (print-or-throw-diagnostics hsc-env dflags1 warns) (unless (null leftovers) (putStrLn (++ "Some flags have not been recognized: " (intercalate ", " (map unLoc leftovers))))))) (<- _ (setSessionDynFlags dflags1)) (<- dflags2 getDynFlags) (setDynFlags dflags2) ;; Updating two more `DynFlags', one is the default `DynFlags' used to ;; import modules during macro expansion, and another is the `DynFlags' ;; in the `HscEnv' used by the macro expander. (modifyFnkEnv (\e (e {(= envDefaultDynFlags (Just dflags2)) (= envSessionForExpand (fmap (updateDynFlags dflags2) (envSessionForExpand e)))}))) (return '(:begin))) _ (finkelSrcError nil "set: empty form"))) (defn (:: show-cmd ReplAction) [forms] (where go (defn go (case forms [form] (| ((<- (Just name) (mb-symbol-name form)) (<- (Just act) (lookup name things)) act)) _ (finkelSrcError nil (++ "show: expecting one of:\n" (intercalate ", " (map fst things)))))) (defn things [(, "bindings" show-bindings) (, "context" show-context) (, "dflags" show-dflags) (, "hpt" show-hpt) (, "language" (show-language False)) (, "linker" show-linker) (, "macros" show-macros) (, "modules" show-modules) (, "options" (show-options False)) (, "options!" (show-options True)) (, "packages" show-packages) (, "paths" show-paths) (, "targets" show-targets)]))) ;; From `GHCi.UI.typeOfExpr'. (defn (:: type-cmd ReplAction) [forms] (case forms [form] (do (<- expanded (expand form)) (<- expr (buildHsSyn parseExpr [expanded])) (<- ty (evalExprType expr)) (lept [sdoc (sep [(text (show form)) (nest 2 (<+> dcolon (pprSigmaType ty)))])]) (<- str (show-sdoc-for-user-m sdoc)) (return `(System.IO.putStrLn ,str))) _ (invalid-form "type" forms))) (defn (:: verbose-cmd ReplAction) "Modify verbosity settings in REPL." [forms] (case forms [] (do (<- lvl (fmap envVerbosity getFnkEnv)) (return `(System.IO.putStrLn ,(++ "Verbosity level is " (show lvl))))) [form] (| ((<- (Just n) (readMaybe (show form))) (do (modifyFnkEnv (setFnkVerbosity n)) (lept [msg (++ "Verbosity level set to " (show n))]) (return `(System.IO.putStrLn ,msg))))) _ (invalid-form "verbose" forms))) ;;; REPL command macro (defn (:: commands [ReplCmd]) (lept [c ReplCmd] [(c "!" ["CMD" "ARGS" "..."] system-cmd "run system CMD with ARGS") (c "?" [] help-cmd "show this help") (c "browse" ["MODULE"] browse-cmd "browse contents of MODULE") (c "cd" ["DIR"] cd-cmd "change working directory to DIR") (c "expand" ["FORM"] expand-cmd "show expanded result of FORM") (c "expand!" ["FORM"] expand-full-cmd "show fully expanded result of FORM") (c "info" ["NAME"] info-cmd "show info of NAME") (c "kind" ["TYPE"] kind-cmd "show kind of TYPE") (c "load" ["FILE"] load-cmd "compile and load FILE") (c "pwd" [] pwd-cmd "show working directory") (c "reload" [] reload-cmd "reload previous module") (c "set" ["FLAGS" "..."] set-cmd "parse and set FLAGS") (c "show" ["ARG"] show-cmd "show information of ARG") (c "type" ["EXPR"] type-cmd "show type of EXPR") (c "verbose" ["INT"] verbose-cmd "set finkel verbosity to INT")])) (defmacroM repl-macro form (case (unCode form) (List (: name args)) (case (do (<- name' (code-to-mb-string name)) (find (. (isPrefixOf name') rc-name) commands)) (Just rc) (rc-action rc args) _ (help-cmd [])) _ (finkelSrcError form (++ "invalid args: " (show form))))) ================================================ FILE: finkel-tool/src/Finkel/Tool/Internal/Types.hs ================================================ ;;; -*- mode: finkel -*- %p(LANGUAGE FlexibleInstances GeneralizedNewtypeDeriving) ;;;; Types for REPL. (defmodule Finkel.Tool.Internal.Types (export ;; repl (Repl ..) run-repl put-repl-state get-repl-state ;; repl state (ReplState ..) (HasReplState ..) initial-repl-state ;; input and result (Input ..) (InSource ..) Result ;; re-export (MonadTrans ..)) (require ;; finkel-core (Finkel.Tool.Internal.Macro.Ghc)) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Concurrent [MVar]) (Control.Monad.IO.Class [(MonadIO ..)]) (Data.Function [on]) (Data.IORef [IORef atomicWriteIORef newIORef readIORef]) ;; transformers (Control.Monad.Trans.Class [(MonadTrans ..)]) ;; finkel-kernel (Language.Finkel [Code]))) (imports-from-ghc (GHC.Data.StringBuffer [StringBuffer appendStringBuffers]) (GHC.Utils.IO.Unsafe [inlinePerformIO])) (cond-expand [(:min-version "haskeline" 0 8 0) ;; exceptions (import Control.Monad.Catch ((MonadThrow ..) (MonadCatch ..) (MonadMask ..)))] [otherwise ;; haskeline (import System.Console.Haskeline ((MonadException ..) (RunIO ..)))]) ;;; REPL, REPL state, input, and result types ;;; Repl state type to hold intermediate line-wise inputs. (data ReplState (ReplState {(:: pending-input (Maybe StringBuffer)) (:: prompt-string String)}) (deriving Show)) (defn (:: append-repl-state (-> ReplState ReplState ReplState)) [r1 r2] (where (ReplState {(= pending-input (on unsafeAppendStringBuffers pending-input r1 r2)) (= prompt-string (prompt-string r2))}) ;; Note the use of `inlinePerformIO'. (= unsafeAppendStringBuffers mb-s1 mb-s2 (| ((<- (Just s1) mb-s1) (<- (Just s2) mb-s2) (Just (inlinePerformIO (appendStringBuffers s1 s2)))) ((<- (Just _) mb-s1) mb-s1) ((<- (Just _) mb-s2) mb-s2) (otherwise Nothing))))) (instance (Eq ReplState) (defn == (where (on eqStringBuffer pending-input) (= eqStringBuffer (on == show))))) (instance (Monoid ReplState) (defn mempty initial-repl-state) (cond-expand [(not (:min-version "base" 4 11 0)) (defn mappend append-repl-state)] [otherwise (:begin)])) (cond-expand [(:min-version "base" 4 11 0) (instance (Semigroup ReplState) (= <> append-repl-state))] [otherwise (:begin)]) (defn (:: initial-repl-state ReplState) (ReplState {(= pending-input Nothing) (= prompt-string "> ")})) ;;; Newtype wrapper for REPL prompt. (newtype (Repl a) (Repl {(:: unRepl (-> (IORef ReplState) (IO a)))})) (instance (Functor Repl) (defn fmap [f (Repl repl)] (Repl (. (fmap f) repl))) %p(INLINE fmap)) (instance (Applicative Repl) (defn pure [x] (Repl (\_ (pure x)))) %p(INLINE pure) (defn <*> [(Repl mf) (Repl mx)] (Repl (\ref (<*> (mf ref) (mx ref))))) %p(INLINE <*>)) (instance (Monad Repl) (defn >>= [(Repl repl) k] (Repl (\ref (>>= (repl ref) (. (flip unRepl ref) k))))) %p(INLINE >>=)) (instance (MonadIO Repl) (defn liftIO [io] (Repl (\_ io))) %p(INLINE liftIO)) ;;; In ghc-8.10.1, `haskeline' switched to use `MonadThrow', `MonadCatch', and ;;; `MonadMask' type classes from the `exceptions' package instead of the ;;; internally defined `MonadException' type class. Since the `Repl' data type ;;; is used with codes for the `InputT' from `haskeline' package, defining ;;; instances of type classes from `exceptions'. (cond-expand [(:min-version "haskeline" 0 8 0) (:begin (instance (MonadThrow Repl) (defn throwM (. liftIO throwM)) %p(INLINE throwM)) (instance (MonadCatch Repl) (defn catch [(Repl repl) f] (Repl (\ref (catch (repl ref) (\e (unRepl (f e) ref)))))) %p(INLINE catch)) (instance (MonadMask Repl) (defn mask [a] (lefn [(:: q (-> (-> (IO a) (IO a)) (Repl a) (Repl a))) (q [unmask (Repl repl)] (Repl (. unmask repl)))] (Repl (\ref (mask (\unmask (unRepl (a (q unmask)) ref))))))) %p(INLINE mask) (defn uninterruptibleMask [a] (lefn [(:: q (-> (-> (IO a) (IO a)) (Repl a) (Repl a))) (q [unmask (Repl repl)] (Repl (. unmask repl)))] (Repl (\ref (uninterruptibleMask (\unmask (unRepl (a (q unmask)) ref))))))) %p(INLINE uninterruptibleMask) (defn generalBracket [acquire release use] (Repl (\ref (generalBracket (unRepl acquire ref) (\resource exit-case (unRepl (release resource exit-case) ref)) (\resource (unRepl (use resource) ref)))))) %p(INLINE generalBracket)))] [otherwise (instance (MonadException Repl) (defn controlIO [f] (Repl (\ref (controlIO (\ (RunIO run) (lept [run' (RunIO (. (fmap (. Repl const)) (. run (flip unRepl ref))))] (fmap (flip unRepl ref) (f run')))))))) %p(INLINE controlIO))]) (defn (:: run-repl (-> (Repl a) ReplState (IO a))) [(Repl repl) st] (>>= (newIORef st) repl)) (defn (:: get-repl-state (Repl ReplState)) (Repl readIORef)) (defn (:: put-repl-state (-> ReplState (Repl ()))) [st] (Repl (flip atomicWriteIORef st))) ;;; Type class for getting and putting 'ReplState'. (class (HasReplState r) (:: getReplState (r ReplState)) (:: putReplState (-> ReplState (r ())))) (instance (HasReplState Repl) (= getReplState get-repl-state) %p(INLINE getReplState) (= putReplState put-repl-state) %p(INLINE putReplState)) (instance (=> (MonadTrans t) (Monad m) (HasReplState m) (HasReplState (t m))) (= getReplState (lift getReplState)) %p(INLINE getReplState) (= putReplState (. lift putReplState)) %p(INLINE putReplState)) ;;; Input data type to hold form to evaluate, and MVar to receive ;;; result from evaluation thread. (data Input (Input InSource Code (MVar Result))) ;;; Type for input, to distinguish prompt from network connections to ;;; REPL server. (data InSource Prompt Connection) ;;; Synonym for evaluation result. (type Result (Either String String)) ================================================ FILE: finkel-tool/src/Finkel/Tool/Main.hs ================================================ ;;; -*- mode: finkel -*- ;;; Main entry point (defmodule Finkel.Tool.Main (export defaultMain) (import ;; base (System.Environment [getArgs]) ;; Internal (Finkel.Tool.Command) (Finkel.Tool.Command.Help) (Finkel.Tool.Internal.CLI) (Finkel.Tool.Internal.Exception))) (defn (:: defaultMain (IO ())) "Main entry point function for the executable." (finkel-tool-exception-handler (lefn [(go [name rest] (maybe (show-usage commands) (flip cmd-act rest) (find-command commands name)))] (case-do getArgs [] (go "repl" []) (: name rest) (go name rest))))) ================================================ FILE: finkel-tool/test/CLITest.hs ================================================ ;;; -*- mode: finkel -*- ;;; Tests for CLI type class and its instances %p(language RankNTypes) (defmodule CLITest (export cliTests) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Exception [bracket]) (Control.Monad [replicateM]) (GHC.IO.Handle [hDuplicate hDuplicateTo]) (System.IO [(IOMode ..) hClose hSetNewlineMode noNewlineTranslation openFile stdin]) ;; filepath (System.FilePath []) ;; haskeline (System.Console.Haskeline [defaultSettings runInputT]) ;; hspec (Test.Hspec) ;; Internal (Finkel.Tool.Internal.CLI) (TestAux))) (defn (:: cliTests Spec) (do (describe "IO instance" io-tests) (describe "InputT instance" inputT-tests))) (defn (:: io-tests Spec) (make-cli-tests id)) (defn (:: inputT-tests Spec) (make-cli-tests (runInputT defaultSettings))) (defn (:: make-cli-tests (=> (CLI m) (-> (forall a (-> (m a) (IO a))) Spec))) [toIO] (do (describe "getString" (lept [expected (cond-expand [(== :os "mingw32") [(Just "First line\r") (Just "Second line\r") Nothing]] [otherwise [(Just "First line") (Just "Second line") Nothing]])] (it "should end with Nothing" (shouldReturn (with-test-stdin "input01.txt" (toIO (replicateM 3 (getString "")))) expected)))) (describe "putString" (it "should run successfully" (quietly (toIO (putString "foo"))))) (describe "handleInterrupt" (it "should run the given action" (toIO (handleInterrupt (return ()) (return ()))))) (describe "withInterrupt" (it "should run the given action" (toIO (withInterrupt (return ()))))) (describe "exitWith" (it "should throw exit failure" (shouldThrow (toIO (exitWith (ExitFailure 1))) (== (ExitFailure 1))))))) (defn (:: with-test-stdin (-> String (IO a) (IO a))) [path act] (bracket (do (<- stdin2 (hDuplicate stdin)) (<- hdl (openFile (datafile path) ReadMode)) (hSetNewlineMode hdl noNewlineTranslation) (hDuplicateTo hdl stdin) (return (, hdl stdin2))) (\ (, hdl stdin2) (do (hDuplicateTo stdin2 stdin) (hClose hdl) (hClose stdin2))) (const act))) (defn (:: datafile (-> String FilePath)) [name] ( "test" ( "data" name))) ================================================ FILE: finkel-tool/test/GhcTest.hs ================================================ ;;; -*- mode: finkel -*- %p(LANGUAGE TypeApplications) (defmodule GhcTest (export ghcTests) (import-when [:compile] ;; Internal (Finkel.Prelude)) (import ;; base (Control.Exception [(SomeException ..) try]) ;; hspec (Test.Hspec) ;; finkel-kernel (Language.Finkel) (Language.Finkel.Fnk [FnkEnv]) ;; finkel-tool (Finkel.Tool.Internal.Macro.Ghc))) (defn (:: ghcTests Spec) imports-from-ghc-test) (defn (:: expand-form (-> Macro Code Code Expectation)) (expand-form-with-env defaultFnkEnv shouldBe)) (defn (:: expand-form-with-env (-> FnkEnv (-> Code Code Expectation) Macro Code Code Expectation)) [fnk-env test macro in-form out-form] (>>= (try (runFnk (macroFunction macro in-form) fnk-env)) (either (. expectationFailure (show @ SomeException)) (flip test out-form)))) (defn (:: imports-from-ghc-test Spec) (describe "imports-from-ghc-test" (it "should return import declarations" (expand-form imports-from-ghc '(imports-from-ghc (GHC.Driver.Env [(HscEnv ..)]) (GHC.Types.SourceText [(SourceText ..)]) (GHC.Utils.Outputable [SDoc])) (cond-expand [(<= 902 :ghc) '(:begin (import GHC.Driver.Env ((HscEnv ..))) (import GHC.Types.SourceText ((SourceText ..))) (import GHC.Utils.Outputable (SDoc)))] [(<= 900 :ghc) '(:begin (import GHC.Driver.Types ((HscEnv ..))) (import GHC.Types.Basic ((SourceText ..))) (import GHC.Utils.Outputable (SDoc)))] [otherwise '(:begin (import HscTypes ((HscEnv ..))) (import BasicTypes ((SourceText ..))) (import Outputable (SDoc)))]))))) ================================================ FILE: finkel-tool/test/MainTest.hs ================================================ ;;; -*- mode: finkel -*- ;;; Tests for main function (defmodule MainTest (export mainTests) (import-when [:compile] (Finkel.Prelude)) (import ;; base (Control.Concurrent [forkIO killThread threadDelay]) (Control.Exception [bracket]) (Control.Monad.IO.Class [(MonadIO ..)]) (Data.Version [showVersion]) (System.Environment [getEnvironment setEnv withArgs]) ;; directory (System.Directory [makeAbsolute withCurrentDirectory]) ;; filepath (System.FilePath []) ;; finkel-core (qualified Paths_finkel_core) ;; hspec (Test.Hspec) ;; Internal (Finkel.Tool.Command) (Finkel.Tool.Command.Help) (Finkel.Tool.Command.Version) (Finkel.Tool.Internal.CLI) (Finkel.Tool.Internal.Commit) (Finkel.Tool.Main) (TestAux))) ;;; Tests (defn (:: mainTests Spec) (do cliTests helpTests evalTests replTests runTests sdistTests versionTests)) (defn (:: cliTests Spec) (do (describe "main with no argument" (it "should start repl" (do (<- tid (forkIO (main' []))) (threadDelay 20000) (killThread tid)))) (describe "main with invalid command" (it "should show usage" (main' ["no-such-command"]))) (describe "main with help command" (do (it "should show usage" (main' ["help"])) (it "should show help of repl command" (main' ["help" "repl"])) (it "should show help of make command" (main' ["help" "make"])))) (describe "main with make command" (it "should show help on --fnk-help" (main' ["make" "--fnk-help"]))) (describe "main with version command" (it "should show version message by default" (main' ["version"]))))) (defn (:: helpTests Spec) (describe "help command" (it "should contain command names in usage message" (do (<- (, _ lns) (runTestIO (show-usage commands) [])) (lept [messageShouldContain (shouldContain (unlines (tst-outputs lns)))]) (messageShouldContain "eval") (messageShouldContain "repl") (messageShouldContain "make") (messageShouldContain "version"))))) (defn (:: evalTests Spec) (describe "eval command" (do (lefn [(failure [args] (shouldThrow (main' args) anyExitFailure))]) (it "should show help with --help" (main' ["eval" "--help"])) (it "should understand debug option" (main' ["eval" "--fnk-verbosity=3" "(not False)"])) (it "should evaluate '(+ 1 2 3 4 5)'" (main' ["eval" "(+ 1 2 3 4 5)"])) (it "should load module and evaluate given form" (main' ["eval" (++ "-i" test-data-dir) "LoadMe" "(from-load-me \"LOADED\")"])) (it "should show error message when invoked without form" (failure ["eval"])) (it "should exit with non-zero on compile error" (failure ["eval" "(+ 1 True)"])) (it "should exit with non-zero on parse error" (failure ["eval" "(+ 1 True)))"]))))) (defn (:: replTests Spec) (lept [print-int (test-data "print-int.hs") print-load-me (test-data "print-load-me.hs") err001 (test-data "Err001.fnk")] (describe "repl command" (do (it "should show help on --help" (main' ["repl" "--help"])) (it "should show warning messages" (main' ["repl" (++ "--file=" print-int) "-v2" "-O"])) (it "should evaluate file contents after loading module" (main' ["repl" "--quiet" (++ "--file=" print-load-me) (test-data "LoadMe.hs")])) (it "should show compilation error when loading invalid module" (shouldThrow (main' ["repl" "--quiet" (++ "--file=" print-int) print-int]) anyExitFailure)) (it "should show load failure with type error on load" (shouldThrow (main' ["repl" "--quiet" (++ "--file=" print-int) err001]) anyExitFailure)) (it "should compilain missing argument" (shouldThrow (main' ["repl" (++ "--file=" print-int) "--prompt"]) anyExitFailure)))))) (defn (:: runTests Spec) (lefn [(run [args] (main' (: "run" args))) (failure [args] (shouldThrow (run args) anyExitFailure))] (describe "run command" (do (it "should show help on --help" (run ["--help"])) (it "should run run-me.hs" (run ["-v0" (test-data "run-me.hs")])) (it "should search directory with ghc option" (pendingWith "needs full path")) (it "should run given function" (run ["-v0" "--main" "main-two" (test-data "RunMeToo.hs")])) (it "should pass arguments after `--'" (run ["-v0" "--main" "main-three" (test-data "RunMeToo.hs") "--" "dog"])) (it "should complain with malformed argument" (failure ["-v0" "--main"])) (it "should fail when input file does not exist" (failure ["-v0" "no-such-file.fnk"])) (it "should exit with status from given script" (failure ["-v0" "--main" "main-three" (test-data "RunMeToo.hs") "--" "elephant"])))))) (defn (:: sdistTests Spec) (describe "sdist command" (do (lept [sdist (. main' (: "sdist")) failure (. (flip shouldThrow anyExitFailure) sdist)]) (it "should show help message" (sdist ["--help"])) (it "should list options" (sdist ["--list-options"])) (it "should list sources" (sdist ["--list-sources=sources" (test-data "p02")])) (it "should make tarball with .cabal in current directory" (sdist [])) (it "should make tarball with .cabal in given directory" (do (<- builddir (makeAbsolute (test-data "sdist"))) (sdist ["--verbose=2" (++ "--builddir=" builddir) (test-data "p02")]))) (it "should fail without .cabal file in current directory" (withCurrentDirectory ".." (failure []))) (it "should show error on invalid argument" (failure ["--foo"]))))) (defn (:: versionTests Spec) (describe "version command" (do (lefn [(version [args] (fmap (. unlines (. tst-outputs snd)) (liftIO (runTestIO (versionMain args) []))))]) (it "should not throw exceptions with git command" (do (<- commit-id (liftIO get-git-commit)) (quietly (print commit-id)))) (it "should not throw exception when git command is not found" (cond-expand ;; The use of `setEnv' may have problem under Windows ... [(/= :os "mingw32") (do (<- mb-commit-id (liftIO (with-tmp-env [(, "PATH" ".")] get-git-commit))) (shouldBe mb-commit-id Nothing))] [otherwise (pendingWith "problem with `setEnv'")])) (it "should show ghc version in default message" (do (<- msg (version [])) (shouldContain msg "ghc"))) (it "should show \"--help\" in help message" (do (<- msg (version ["--help"])) (shouldContain msg "--help"))) (it "should show numeric version with \"--numeric\" option" (do (<- msg (version ["--numeric"])) (shouldContain msg (showVersion Paths_finkel_core.version)))) (it "should complain unrecognized option" (do (<- msg (version ["--no-such-option"])) (shouldContain msg "--no-such-option")))))) ;;; Auxiliary (defn (:: with-tmp-env (-> [(, String String)] (IO a) (IO a))) [envvars act] (bracket getEnvironment (mapM_ (uncurry setEnv)) (const (>> (mapM_ (uncurry setEnv) envvars) act)))) (defn (:: main' (-> [String] (IO ()))) (. quietly (flip withArgs defaultMain))) (defn (:: anyExitFailure (Selector ExitCode)) [(ExitFailure _)] True [_] False) (defn (:: test-data-dir FilePath) ( "test" "data")) (defn (:: test-data (-> FilePath FilePath)) ( test-data-dir)) ================================================ FILE: finkel-tool/test/ReplMacroTest.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Tests for REPL macros (defmodule ReplMacroTest (export replMacroTests) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Exception [catch throw]) (Data.List [intercalate isSubsequenceOf]) (System.IO.Error [isDoesNotExistError]) ;; filepath (System.FilePath []) ;; directory (System.Directory [getCurrentDirectory getTemporaryDirectory removeFile]) ;; hspec (Test.Hspec) ;; finkel-core (Finkel.Prelude) ;; Internal (TestAux))) (defn (:: replMacroTests (-> EvalTestFns Spec)) [etf] (cond-expand [(== :os "mingw32") (it "should skip under Windows" (pendingWith "Windows not yet supported"))] [otherwise (replMacroTests-1 etf)])) (defn (:: replMacroTests-1 (-> EvalTestFns Spec)) [(EvalTestFns {(= etf-ok ok) (= etf-ng ng) (= etf-satisfy satisfy)})] (do (<- current-dir (runIO getCurrentDirectory)) (<- tmp-dir (runIO getTemporaryDirectory)) (lefn [(testdata [name] ( "test" "data" name)) (delines (intercalate "\n")) (m02-dot-hs ( tmp-dir "m02.hs")) (m02-dot-hi ( tmp-dir "m02.hi")) (main-dot-o ( tmp-dir "Main.o")) (clear-m02-files (mapM_ remove-if-exist [m02-dot-hs m02-dot-hi main-dot-o])) (with-right [form test] (satisfy form (either (const False) test))) (with-left [form test] (satisfy form (either test (const False)))) (with-left-subseq [form str0] (satisfy form (either (isSubsequenceOf str0) (const False))))]) (beforeAll_ clear-m02-files (afterAll_ clear-m02-files (do ;; ! (ok '(repl-macro ! echo foo) "") ;; ?, help (with-right '(repl-macro ?) (isSubsequenceOf ",type EXPR")) (with-right '(repl-macro help) (isSubsequenceOf "show this help")) ;; browse (with-right '(repl-macro browse Unsafe.Coerce) (isSubsequenceOf "Unsafe.Coerce.unsafeCoerce :: a -> b")) (with-left-subseq '(repl-macro browse foo bar) "browse: invalid form `foo'") ;; cd (ok `(repl-macro cd ,current-dir) "") (ok `(repl-macro cd ,(testdata "")) "") (ok '(repl-macro cd ../../) "") (with-left `(repl-macro cd (foo bar) buzz) (isSubsequenceOf "invalid form")) ;; expand (ok '(repl-macro expand (defn f (where g (defn g [x] (print (++ "g: " x)))))) "(= f (where g (defn g [x] (print (++ \"g: \" x)))))") (ok '(repl-macro expand) "") (with-left-subseq '(repl-macro expand foo bar) "expand: invalid form `foo'") ;; expand! (ok '(repl-macro expand! (defn f (where g (defn g [x] (print (++ "g: " x)))))) "(= f (where g (= g x (print (++ \"g: \" x)))))") ;; info (ok '(repl-macro info putStr) (cond-expand [(<= 910 :ghc) "putStr :: String -> IO () \t-- Defined in ‘GHC.Internal.System.IO’"] [otherwise "putStr :: String -> IO () \t-- Defined in ‘System.IO’"])) (ok '(repl-macro info ++) (cond-expand [(<= 910 :ghc) "(++) :: [a] -> [a] -> [a] \t-- Defined in ‘GHC.Internal.Base’\n\ \infixr 5 ++"] [otherwise "(++) :: [a] -> [a] -> [a] \t-- Defined in ‘GHC.Base’\n\ \infixr 5 ++"])) (with-right '(repl-macro info ()) (isSubsequenceOf "instance Show ()")) (with-right '(repl-macro info []) (isSubsequenceOf (cond-expand [(<= 906 :ghc) "data List a = [] | a : [a]"] [otherwise "data [] a = [] | a : [a]"]))) ;; kind (ok '(repl-macro kind Maybe) "Maybe :: * -> *") (with-left-subseq '(repl-macro kind (foo bar) buzz) "kind: invalid form `(foo bar)'") ;; pwd (ok '(repl-macro pwd) (show current-dir)) ;; set (ok '(repl-macro set -foo -bar -buzz) "") (ok '(repl-macro set --fnk-verbose=3) "") (ok '(repl-macro set --fnk-verbose=1) "") (ng '(repl-macro set) ": error: set: empty form") ;; show (ok '(defn (:: f1 (-> Int Int)) [n] (+ n 1)) "; f1 :: Int -> Int") (with-right '(repl-macro show bindings) (. (elem "f1 :: Int -> Int = _") lines)) (with-right '(class (C a) (:: cm1 (-> a Int))) (. (elem "; Class ‘C’") lines)) (with-right '(repl-macro show bindings) (. (elem "class C a") lines)) (lept [interpreter-backend-line (cond-expand [(<= 906 :ghc) "; backend: byte-code interpreter"] [(<= 902 :ghc) "; backend: Interpreter"] [otherwise "; backend: HscInterpreted"])]) (ok '(repl-macro show context) (delines ["; context" "; IIDecl: import Prelude"])) (ok '(repl-macro show dflags) (delines ["; dflags:" "; ghcLink: LinkInMemory" "; ghcMode: CompManager" interpreter-backend-line "; objectDir: Nothing" "; homeUnitId: main" "; forceRecomp: False"])) (ok '(:begin (repl-macro set -odir /tmp) (repl-macro show dflags)) (delines ["; dflags:" "; ghcLink: LinkInMemory" "; ghcMode: CompManager" interpreter-backend-line "; objectDir: Just \"/tmp\"" "; homeUnitId: main" "; forceRecomp: False"])) (ok '(repl-macro show hpt) "show: no home package table found") (ok '(repl-macro show language) (delines (cond-expand [(<= 902 :ghc) ["base language is: GHC2021" "with the following modifiers:"]] [otherwise ["base language is: Haskell2010" "with the following modifiers:" " -XNoDatatypeContexts" " -XNondecreasingIndentation"]]))) ;; show linker command uses 'showLinkerState' from ghc package, ;; which does printing action, so not returning 'String' value. (ok '(repl-macro show linker) "") (with-right '(repl-macro show macros) (. (elem "; defmacroM'") lines)) (ok '(repl-macro show modules) "") (with-right '(repl-macro show options) (isSubsequenceOf "-fimplicit-import-qualified")) (with-right '(repl-macro show options!) (isSubsequenceOf "-Wno-orphans")) (with-right '(repl-macro show packages) (isSubsequenceOf "; packages")) (with-right '(:begin (repl-macro set -hide-package bytestring) (repl-macro show packages)) (isSubsequenceOf "hiding")) (ok '(repl-macro show paths) (concat ["; current working directory:\n" "; " current-dir "\n" "; module import search paths:\n" "; ."])) (ok '(repl-macro show targets) "; targets: none") (with-left '(repl-macro show (foo bar) buzz) (isSubsequenceOf "targets")) ;; type (ok '(repl-macro type putStrLn) "putStrLn :: String -> IO ()") (ok '(repl-macro type (foldr + (:: 0 Int))) "(foldr + (:: 0 Int)) :: Foldable t => t Int -> Int") (ok '(repl-macro type 'x) "(:quote x) :: Language.Finkel.Form.Code") (with-left-subseq '(repl-macro type (foo bar) buzz) "type: invalid form `(foo bar)'") ;; verbose (ok '(repl-macro verbose) "Verbosity level is 1") (ok '(repl-macro verbose 2) "Verbosity level set to 2") (ok '(repl-macro verbose 1) "Verbosity level set to 1") ;; load and reload (lept [m01-dot-hs (testdata "m01.hs")]) (ok `(:begin (repl-macro load ,(make-symbol m01-dot-hs)) main) "=== m01.fnk ===") (ok '(repl-macro reload) "; reloaded test/data/m01.hs") (ok '(repl-macro browse) (delines ["main :: IO ()" "foo :: String" "bar :: Int -> Int"])) (ok '(repl-macro show targets) (cond-expand [(<= 904 :ghc) "; targets: main:test/data/m01.hs"] [(<= 902 :ghc) "; targets: test/data/m01.hs"] [otherwise "; targets: *test/data/m01.hs"])) (with-right '(repl-macro show context) (isSubsequenceOf "IIModule: Main")) (ok `(writeFile ,m02-dot-hs ";;; m02.hs\n(defn main (print True))") "") (cond-expand [(== :os "darwin") (describe "evaluate (repl-macro load m02.fnk)" (it "should skip under darwin" (pendingWith "OSX not supported yet")))] [otherwise (ok `(:begin (repl-macro load ,(make-symbol m02-dot-hs)) main) "True")]) (ok `(writeFile ,m02-dot-hs ";;; m02.hs\n(defn main (print False))") "") (cond-expand [(== :os "darwin") (describe "evaluate (repl-macro reload)" (it "should skip under darwin" (pendingWith "OSX not supported yet")))] [otherwise (ok '(repl-macro reload) (++ "; reloaded " m02-dot-hs))]) (cond-expand [(== :os "darwin") (describe "evaluate main" (it "should skip under darwin" (pendingWith "OSX not supported yet")))] [otherwise (ok 'main "False")]) ;; Compiling object code (cond-expand [(== :os "darwin") (describe "Compiling object code" (it "should be skipped under darwin" (pendingWith "OSX not supported yet")))] [otherwise (do (ok `(writeFile ,m02-dot-hs ";;; m02.hs\n(defn main (print True))") "") (ok `(:begin (repl-macro set -fobject-code) (repl-macro load ,m02-dot-hs) main) "True") (ok '(repl-macro reload) (++ "; reloaded " m02-dot-hs)))]) ;; Errors (with-left-subseq '(repl-macro load (foo bar)) "load: not a FilePath: (foo bar)") (with-left-subseq '(repl-macro load (foo bar) buzz) "load: invalid form `(foo bar)'") ;; Calling functions from Prelude after load error: (ok '(:begin (repl-macro load /no/such/file.fnk) (print (not False))) "True") ;; Errors (with-left-subseq '(repl-macro info (foo bar)) "info: invalid form `(foo bar)'") (with-left-subseq '(repl-macro) "invalid args: nil")))))) (defn (:: remove-if-exist (-> FilePath (IO ()))) [path] (catch (removeFile path) (\e (if (isDoesNotExistError e) (return ()) (throw e))))) ================================================ FILE: finkel-tool/test/ReplTest.hs ================================================ ;;; -*- mode: finkel -*- ;;; Tests for REPL. %p(LANGUAGE OverloadedStrings) %p(OPTIONS_GHC -Wno-orphans) (defmodule ReplTest (export replTests listenTests) (require ;; finkel-tool (Finkel.Tool.Internal.Macro.Ghc)) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Concurrent [forkIO newEmptyMVar killThread putMVar takeMVar threadDelay yield]) (Control.Exception [IOException finally throwIO]) (qualified Control.Exception as ControlException) (Control.Monad [forever replicateM_ when]) (Data.List [isSubsequenceOf]) (Data.String [(IsString ..)]) (GHC.Conc [(ThreadStatus ..) threadStatus]) (GHC.IO.Exception [(AsyncException ..)]) ;; filepath (System.FilePath []) ;; haskeline (System.Console.Haskeline [defaultSettings runInputT]) ;; hspec (Test.Hspec) ;; network (Network.Socket [(AddrInfo ..) (SocketType ..) close connect defaultHints getAddrInfo socket]) (Network.Socket.ByteString [sendAll recv]) ;; finkel-kernel (Language.Finkel) ;; Internal (Finkel.Tool.Command.Repl) (Finkel.Tool.Internal.IO) (Finkel.Tool.Internal.Types) (TestAux))) (imports-from-ghc (GHC.Data.StringBuffer (StringBuffer stringToStringBuffer))) ;;; Extra imports (cond-expand [(<= 810 :ghc) (import Control.Monad.Catch ((MonadThrow ..) (MonadCatch ..) (MonadMask ..)))] [otherwise (:begin)]) (cond-expand [(:min-version "base" 4 11 0) (:begin)] [otherwise (import Data.Monoid (<>))]) ;;; Exported test (defn (:: replTests (-> EvalTestFns Spec)) [etf] (do (describe "ReplState" replStateTests) (describe "Exception" exceptionTests) (describe "Read" readTests) (describe "ReadPrint" readPrintTests) (describe "Eval" (cond-expand [(== :os "mingw32") (it "should be skipped under Windows" (pendingWith "Windows not supported yet"))] [otherwise (evalTests etf)])))) (defn (:: listenTests (-> EvalTestFns Spec)) [etf] (describe "Listen" (cond-expand [(== :os "mingw32") (it "should be skipped under Windows" (pendingWith "Windows not supported yet"))] [otherwise (listenTests1 etf)]))) ;;; Orphan (instance (IsString StringBuffer) (= fromString stringToStringBuffer)) ;;; Internal (defn (:: replStateTests Spec) (do (lept [rs1 (mempty {(= pending-input (Just "(foo"))}) rs2 (mempty {(= pending-input (Just " bar)"))})]) (describe "Show instance" (it "should show pending inputs" (shouldBe (show rs1) "ReplState {pending_input = Just , \ \prompt_string = \"> \"}"))) (describe "Eq instance" (do (it "should be itself" (shouldBe rs1 rs1)) (it "should not be different pending input" (shouldNotBe rs1 rs2)))) (describe "Monoid laws for ReplState" (do (it "should have an identity element" (shouldBe (<> mempty rs1) rs1)) (it "should satisfy associativity law" (shouldBe (<> (<> rs1 mempty) rs2) (<> rs1 (<> mempty rs2)))))) (describe "get and put ReplState for InputT" (do (lept [act (run-repl (runInputT defaultSettings work) mempty) work (>> (putReplState mempty) getReplState)]) (it "should return the given ReplState" (shouldReturn act mempty)))) (lept [run-repl' (flip run-repl mempty) repl1 (pure True)]) (describe "Functor instance of Repl" (do (it "should satisfy identity law" (shouldReturn (run-repl' (fmap id repl1)) True)) (it "should satisfy composition law" (shouldReturn (run-repl' (fmap show (fmap not repl1))) (show (not True)))) (it "should return second arg with <$" (shouldReturn (run-repl' (<$ True (pure False))) True)))) (describe "Applicative instance of Repl" (it "should satisfy applicative law" (shouldReturn (run-repl' (<*> (pure not) repl1)) False))))) (defn (:: do-repl (-> (Repl a) (IO a))) (flip run-repl initial-repl-state)) (defn (:: exceptionTests Spec) (describe "exceptions instances for REPL" (cond-expand [(<= 810 :ghc) (do (lept [throw-sof-on-no-input (>>= getReplState (. (maybe (throwM StackOverflow) (const (return 42))) pending-input))]) (it "should throw exception" (shouldThrow (do-repl (throwM StackOverflow)) anyException)) (it "should catch exception" (lefn [(act (catch throw-sof-on-no-input handler)) (:: handler (-> AsyncException (Repl Int))) (handler [ae] (do (<- st getReplState) (case (, ae (pending-input st)) (, StackOverflow Nothing) (return 42) _ (throwM ae))))] (shouldReturn (do-repl act) 42))) (it "should throw exception from mask when unmasked" (lept [act (mask (\unmask (unmask throw-sof-on-no-input)))] (shouldThrow (do-repl act) anyException))) (it "should throw exception from uninterruptibleMask when unmasked" (lept [act (uninterruptibleMask (\unmask (unmask throw-sof-on-no-input)))] (shouldThrow (do-repl act) anyException))))] [otherwise (it "should throw, catch, and mask exceptions as necessary" (pendingWith "... on newer versions of ghc"))]))) (defn (:: readTests Spec) (do (describe "reading single line form" (it "returns '(foo bar buzz)" (do (<- form (do-repl (read-form "(foo bar buzz)"))) (shouldBe form (Just '(foo bar buzz)))))) (describe "reading multi line form" (it "returns '(a b c)" (do (<- form (do-repl (do (<- _ (read-form "(a ")) (<- _ (read-form "b ")) (read-form "c)")))) (shouldBe form (Just '(a b c)))))))) (defn (:: readPrintTests Spec) (describe "read and print loop" (do (rptest "multi line form" ["(print" "(+" "10" "32" "))"]) (rptest "quitting with \"(quit)\"" ["(quit)"]) (rptest "\",t\" command" [",t False"]) (rptest "\",!\" command" [",! echo foo bar"]) (rptest "\",q\" command" [",q"])))) (defn (:: rptest (-> String [String] Spec)) [label inputs] (lept [run (do (<- in-mv newEmptyMVar) (<- tid (forkIO (forever (do (<- (Input _ _ out-mv) (takeMVar in-mv)) (putMVar out-mv (Right "")))))) (return (, in-mv tid)))] (describe label (it "should have no pending inputs" (do (<- (, in-mv tid) run) (<- (, _ tst) (runTestIO (read-print-loop nil in-mv tid) inputs)) (finally (shouldSatisfy (pending-input (tst-replstate tst)) null) (killThread tid))))))) (defn (:: evalTests (-> EvalTestFns Spec)) [(EvalTestFns {(= etf-ok ok) (= etf-satisfy satisfy)})] (do ;; Statements and declarations (ok '(+ 10 32) "42") (ok '(defn (:: f1 (-> Int Int)) [n] (+ n 1)) "; f1 :: Int -> Int") (ok '(f1 41) "42") (ok '(:begin (:: x y Int) (= x 1) (= y 2)) "; x :: Int\n; y :: Int") (ok '(<- z (return True)) "") (ok '(defn (:: f2 (-> (Maybe Int) Int)) [(Just n)] (* n 2) [Nothing] 0) "; f2 :: Maybe Int -> Int") (ok '(f2 (Just 21)) "42") (ok '(data Foo (Foo Int)) (concat ["; $tcFoo :: TyCon\n" "; $tc'Foo :: TyCon\n" "; Type constructor ‘Foo’"])) ;; Import (ok '(import Control.Monad) "; import Control.Monad") (ok '(import qualified Data.Functor as DF) "; import qualified Data.Functor as DF") (ok '(import Control.Monad (liftM ap)) "; import Control.Monad ( liftM, ap )") ;; Eval wrapper (ok 'System.Environment.getArgs "[]") ;; Expansion quoted codes in REPL (ok '(macroexpand ''foo) "(:quote foo)") ;; Exported macros (satisfy '(exported-macros Finkel.Core) (lcase (Right str) (isSubsequenceOf "defmacro" str) _ False)) ;; Errors (satisfy 'buzz (lcase (Left str) (isSubsequenceOf "Variable not in scope: buzz" str) _ False)) (satisfy '(= f a (+ a 1) (+ a 2)) (lcase (Left str) (isSubsequenceOf "syntax error on input" str) _ False)) (satisfy '(head []) (lcase (Left str) (isSubsequenceOf "*** Exception: Prelude.head: empty list" str) _ False)))) (defn (:: listenTests1 (-> EvalTestFns Spec)) [(EvalTestFns {(= etf-tid etid)})] (lefn [(short-pause (threadDelay 50000)) (wait-until-killed [tid] (do (<- st (threadStatus tid)) (putStrLn (++ "listenTests1: " (show st))) (when (notElem st [ThreadFinished ThreadDied]) (do short-pause (wait-until-killed tid))))) (acquire (do (wait-until-killed etid) (<- tid (forkIO ;; Passing a file to work for, so that the REPL thread ;; will not terminate before the testing client connect. (replMain [(++ "--listen=" port) (++ "--file=" input-file) "--prompt=" "--quiet"]))) ;; Pause for a bit after forking the server action. (replicateM_ 5 short-pause) (<- addr (resolve "127.0.0.1" port)) (<- conn (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))) (with-retry (:: 20 Int) (connect conn (addrAddress addr))) (return (, conn tid)))) (with-retry [n act] (ControlException.catch act (\e (if (< 0 n) (do yield short-pause (with-retry (- n 1) act)) (throwIO (:: e IOException)))))) (release [(, conn tid)] (do (sendAll conn ",quit") (<- _msg (recv conn 1024)) (close conn) (killThread tid))) (port "50322") (input-file ( "test" "data" "sleep-for-while.fnk")) (resolve [host portnum] (lefn [(hints (defaultHints {(= addrSocketType Stream)}))] (case-do (getAddrInfo (Just hints) (Just host) (Just portnum)) (: addr _) (return addr) _ (error "REPL client: address error")))) (work [(, conn _)] (do (<- _msg1 (recv conn 1024)) (sendAll conn "(* 7 (+ 4 2))") (recv conn 1024))) (listener-test (describe "listener" (it "evaluates a form sent from connected client" (\args (shouldReturn (work args) "42")))))] (before acquire (after release listener-test)))) ================================================ FILE: finkel-tool/test/Spec.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Main (import ;; hspec (Test.Hspec) ;; Internal (CLITest) (GhcTest) (MainTest) (ReplMacroTest) (ReplTest) (TestAux))) (defn (:: main (IO ())) (do (<- etf makeEvalTestFns) (hspec (do (afterAll- (etf-cleanup etf) (do (describe "CLITest" cliTests) (describe "GhcTest" ghcTests) (describe "MainTest" mainTests) (describe "ReplTest" (replTests etf)) (describe "ReplMacroTest" (replMacroTests etf)))) (listenTests etf))))) ================================================ FILE: finkel-tool/test/TestAux.hs ================================================ ;;; -*- mode: finkel -*- ;;;; Auxiliary codes for tests (defmodule TestAux (export (TestIO ..) (TestIOState ..) runTestIO (EvalTestFns ..) makeEvalTestFns quietly) (require ;; finkel-core (Finkel.Tool.Internal.Macro.Ghc)) (import-when [:compile] ;; finkel-core (Finkel.Prelude)) (import ;; base (Control.Concurrent [ThreadId newEmptyMVar killThread putMVar takeMVar]) (Control.Monad [mplus]) (Control.Monad.IO.Class [(MonadIO ..)]) (Data.Function [on]) (System.Environment [lookupEnv]) (System.IO [stderr stdout]) ;; filepath (System.FilePath []) ;; hspec (Test.Hspec) ;; silently (System.IO.Silently [hSilence]) ;; finkel-kernel (Language.Finkel) ;; Internal (Finkel.Tool.Command.Repl) (Finkel.Tool.Internal.CLI) (Finkel.Tool.Internal.Eval) (Finkel.Tool.Internal.Loop) (Finkel.Tool.Internal.Types))) (imports-from-ghc (GHC.Settings.Config (cProjectVersion))) ;;; Extra imports (cond-expand [(:min-version "base" 4 11 0) (:begin)] [otherwise (import Data.Monoid (<>))]) ;;; Test IO (data TestIOState (TestIOState {(:: tst-inputs [String]) (:: tst-outputs [String]) (:: tst-exitcode (Maybe ExitCode)) (:: tst-replstate ReplState)})) (instance (Monoid TestIOState) (= mempty emptyTestIOState) (cond-expand [(:min-version "base" 4 16 0) (:begin)] [otherwise (= mappend appendTestIOState)])) (cond-expand [(:min-version "base" 4 11 0) (instance (Semigroup TestIOState) (= <> appendTestIOState))] [otherwise (:begin)]) (defn (:: appendTestIOState (-> TestIOState TestIOState TestIOState)) [s1 s2] (TestIOState {(= tst-inputs (on mappend tst-inputs s1 s2)) (= tst-outputs (on mappend tst-outputs s1 s2)) (= tst-exitcode (mplus (tst-exitcode s2) (tst-exitcode s1))) (= tst-replstate (on mappend tst-replstate s1 s2))})) (defn (:: emptyTestIOState TestIOState) (TestIOState {(= tst-inputs []) (= tst-outputs []) (= tst-exitcode Nothing) (= tst-replstate initial-repl-state)})) ;;; Newtype wrapper to test IO actions, combination of TestIOState state ;;; monad and IO. (newtype (TestIO a) (TestIO {(:: unTestIO (-> TestIOState (IO (, a TestIOState))))})) (defn (:: runTestIO (-> (TestIO a) [String] (IO (, a TestIOState)))) [test-io inputs] (unTestIO test-io (mempty {(= tst-inputs inputs)}))) (instance (Functor TestIO) (= fmap f (TestIO m) (TestIO (\st0 (fmap (\ (, a st) (, (f a) st)) (m st0)))))) (instance (Applicative TestIO) (= pure x (TestIO (\st (pure (, x st))))) (= <*> (TestIO ft) (TestIO xt) (TestIO (\st0 (do (<- (, f st1) (ft st0)) (<- (, x st2) (xt st1)) (return (, (f x) st2))))))) (instance (Monad TestIO) (= return pure) (= >>= (TestIO m) k (TestIO (\st0 (do (<- (, a st1) (m st0)) (unTestIO (k a) st1)))))) (instance (MonadIO TestIO) (= liftIO io (TestIO (\st (fmap (\x (, x st)) io))))) (instance (CLI TestIO) (= getString _prompt (TestIO (\tst (case (tst-inputs tst) (: s rest) (lept [tst' (tst {(= tst-inputs rest)})] (pure (, (Just s) tst'))) [] (pure (, Nothing tst)))))) (= putString str (TestIO (\st (lept [tst-outputs' (<> (tst-outputs st) [str])] (pure (, () (st {(= tst-outputs tst-outputs')}))))))) ;;; XXX: Does nothing. (= handleInterrupt _handler act act) ;;; XXX: Does nothing. (= withInterrupt act act) (= exitWith ec (TestIO (\st (pure (, () (st {(= tst-exitcode (Just ec))}))))))) (instance (HasReplState TestIO) (= putReplState rst (TestIO (\st (pure (, () (st {(= tst-replstate rst)})))))) (= getReplState (TestIO (\st (pure (, (tst-replstate st) st)))))) ;;; Repl test environment (data EvalTestFns (EvalTestFns {(:: etf-ok (-> Code String Spec)) (:: etf-ng (-> Code String Spec)) (:: etf-satisfy (-> Code (-> Result Bool) Spec)) (:: etf-cleanup (IO ())) (:: etf-tid ThreadId)})) (defn (:: if-ghc-package-path-is-set (=> (MonadIO m) (-> (m a) (m a) (m a)))) "Perform the first action if @GHC_PACKAGE_PATH@ is set in environment variable, otherwise perform the second." [set-act not-set-act] (case-do (liftIO (lookupEnv "GHC_PACKAGE_PATH")) (Just _) set-act Nothing not-set-act)) (defn (:: init-etf-args-for-cabal (IO [String])) "Initialization arguments for running eval tests with `cabal-install'." (lept [ghc-ver (++ "ghc-" cProjectVersion) inplacedb ( ".." "dist-newstyle" "packagedb" ghc-ver) args ["-package-db" inplacedb]] (pure args))) (defn (:: init-etf-args (IO [String])) "Initialization arguments for `EvalTestFns'." (if-ghc-package-path-is-set (return []) init-etf-args-for-cabal)) (defn (:: makeEvalTestFns (IO EvalTestFns)) (do (<- out-mv newEmptyMVar) (<- (@ resources (, _tmpfile hdl in-mv)) acquire-repl) (<- ghc-args init-etf-args) (<- etid (fork-eval-loop ghc-args hdl in-mv repl-env)) (lefn [(eval-form [right-or-left form expect] (describe (++ "evaluate " (show form)) (it "evaluates to expected result" (quietly (do (putMVar in-mv (Input Connection form out-mv)) (<- ret (takeMVar out-mv)) (shouldBe ret (right-or-left expect))))))) (ok (eval-form Right)) (ng (eval-form Left)) (satisfy [form test] (describe (++ "evaluate " (show form)) (it "satisfies predicate" (quietly (do (putMVar in-mv (Input Connection form out-mv)) (<- ret (takeMVar out-mv)) (shouldSatisfy ret test)))))) (cleanup (do (killThread etid) (cleanup-repl resources)))]) (putMVar in-mv (Input Connection '(:begin) out-mv)) (<- _ (takeMVar out-mv)) (return (EvalTestFns {(= etf-ok ok) (= etf-ng ng) (= etf-satisfy satisfy) (= etf-cleanup cleanup) (= etf-tid etid)})))) (defn (:: quietly (-> (IO a) (IO a))) (hSilence [stderr stdout])) ================================================ FILE: finkel-tool/test/data/Err001.fnk ================================================ (defmodule Err001) (defn (:: foo (-> Int Int)) [n] (+ (* n 2) 2)) (defn (:: err01 (IO ())) (print (foo "type error"))) ================================================ FILE: finkel-tool/test/data/LoadMe.hs ================================================ ;;; -*- mode: finkel -*- (defmodule LoadMe (export from-load-me)) (defn (:: from-load-me (-> String (IO ()))) (. putStrLn (++ "LoadMe.from-load-me: "))) ================================================ FILE: finkel-tool/test/data/RunMeToo.hs ================================================ ;;; -*- mode: finkel -*- (defmodule RunMeToo (import (System.Environment (getArgs)) (System.Exit (exitFailure)))) (defn (:: main-one (IO ())) (putStrLn "From RunMeToo.main-one")) (defn (:: main-two (IO ())) (putStrLn "From RunMeToo.main-two")) (defn (:: main-three (IO ())) (do (<- args getArgs) (case args ["dog"] (putStrLn "WUFF WUFF WUFF!") ["cat"] (putStrLn "MEOW MEOW MEOW!") _ (>> (putStrLn "I don't know what to do") exitFailure)))) (defn (:: main (IO ())) main-one) ================================================ FILE: finkel-tool/test/data/input01.txt ================================================ First line Second line ================================================ FILE: finkel-tool/test/data/m01.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Main (export main foo bar)) (defn (:: main (IO ())) "Main function of m01" (putStrLn "=== m01.fnk ===")) (defn (:: foo String) "A string value named foo." "foo") (defn (:: bar (-> Int Int)) "A function named bar" [x] (* x (+ x 2))) ================================================ FILE: finkel-tool/test/data/p02/LICENSE ================================================ Copyright Author name here (c) 2022 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: finkel-tool/test/data/p02/README.md ================================================ # p02 ================================================ FILE: finkel-tool/test/data/p02/Setup.hs ================================================ module Main where import Distribution.Simple.Finkel main :: IO () main = finkelMakeMain ================================================ FILE: finkel-tool/test/data/p02/app/Main.hs ================================================ module Main where import Lib main :: IO () main = someFunc ================================================ FILE: finkel-tool/test/data/p02/p02.cabal ================================================ name: p02 version: 0.1.0.0 -- synopsis: -- description: homepage: http://www.example.org license: BSD3 license-file: LICENSE author: Author name here maintainer: example@example.com copyright: 2022 Author name here category: Data build-type: Custom extra-source-files: README.md src/*.fnk cabal-version: >=2.0 custom-setup setup-depends: base >= 4.7 && < 5 , Cabal >= 2.0 , finkel-setup library hs-source-dirs: src exposed-modules: Lib build-depends: base >= 4.7 && < 5 build-tool-depends: finkel:finkel default-language: Haskell2010 executable p02 hs-source-dirs: app main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base , p02 default-language: Haskell2010 test-suite p02-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs build-depends: base , p02 build-tool-depends: finkel:finkel ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 -- source-repository head -- type: git -- location: https://github.com/githubuser/p02 ================================================ FILE: finkel-tool/test/data/p02/src/Lib.fnk ================================================ (defmodule Lib (export someFunc)) (defn (:: someFunc (IO ())) (putStrLn "Hello from p02")) ================================================ FILE: finkel-tool/test/data/p02/stack.yaml ================================================ # This file was automatically generated by 'stack init' # # Some commonly used options have been documented as comments in this file. # For advanced use and comprehensive documentation of the format, please see: # https://docs.haskellstack.org/en/stable/yaml_configuration/ # A warning or info to be displayed to the user on config load. user-message: | Warning (added by new or init): Some packages were found to be incompatible with the resolver and have been left commented out in the packages section. You can omit this message by removing it from stack.yaml # Resolver to choose a 'specific' stackage snapshot or a compiler version. # A snapshot resolver dictates the compiler version and the set of packages # to be used for project dependencies. For example: # # resolver: lts-3.5 # resolver: nightly-2015-09-21 # resolver: ghc-7.10.2 # # The location of a snapshot can be provided as a file or url. Stack assumes # a snapshot provided as a file might change, whereas a url resource does not. # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml resolver: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/13.yaml # User packages to be built. # Various formats can be used as shown in the example below. # # packages: # - some-directory # - https://example.com/foo/bar/baz-0.0.2.tar.gz # subdirs: # - auto-update # - wai packages: [] # The following packages have been ignored due to incompatibility with the # resolver compiler, dependency conflicts with other packages # or unsatisfied dependencies. #- . # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: # # extra-deps: # - acme-missiles-0.3 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # # extra-deps: [] # Override default flag values for local packages and extra-deps # flags: {} # Extra package databases containing global packages # extra-package-dbs: [] # Control whether we use the GHC we find on the path # system-ghc: true # # Require a specific version of stack, using version ranges # require-stack-version: -any # Default # require-stack-version: ">=2.7" # # Override the architecture used by stack, especially useful on Windows # arch: i386 # arch: x86_64 # # Extra directories used by stack for building # extra-include-dirs: [/path/to/dir] # extra-lib-dirs: [/path/to/dir] # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor ================================================ FILE: finkel-tool/test/data/p02/test/Spec.hs ================================================ main :: IO () main = putStrLn "Test suite not yet implemented" ================================================ FILE: finkel-tool/test/data/print-int.hs ================================================ ;;; -*- mode: finkel -*- (print (:: 42 Int)) ================================================ FILE: finkel-tool/test/data/print-load-me.hs ================================================ ;;; -*- mode: finkel -*- (from-load-me "LOADED") ================================================ FILE: finkel-tool/test/data/run-me.hs ================================================ ;;; -*- mode: finkel -*- (defmodule Main) (defn (:: main (IO ())) (putStrLn "From run-me.fnk")) ================================================ FILE: finkel-tool/test/data/sleep-for-while.fnk ================================================ (Control.Concurrent.threadDelay 1000000) (Control.Concurrent.threadDelay 1000000) (putStrLn "sleep-for-while.fnk: done") ================================================ FILE: fkc/LICENSE ================================================ Copyright (c) 2020-2022, 8c6794b6 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: fkc/Main.hs ================================================ module Main where import Language.Finkel.Main main :: IO () main = defaultMain ================================================ FILE: fkc/README.md ================================================ # fnkc Package for @fkc@, the Finkel Kernel Compiler executable. See the [documentation](https://finkel.readthedocs.org) for more info. ================================================ FILE: fkc/Setup.hs ================================================ import Distribution.Simple main = defaultMain ================================================ FILE: fkc/fkc.cabal ================================================ cabal-version: 2.0 name: fkc version: 0.0.0 synopsis: Finkel kernel compiler description: Finkel kernel compiler . This package contains an executable @fkc@, which is internally used for compiling Finkel related packages. . See the for more info. homepage: https://github.com/finkel-lang/finkel#readme license: BSD3 license-file: LICENSE author: 8c6794b6 maintainer: 8c6794b6@gmail.com copyright: 2017-2022 8c6794b6 category: Language build-type: Simple extra-source-files: README.md executable fkc main-is: Main.hs build-depends: base > 4.10 && < 5 , finkel-kernel default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts=all "-with-rtsopts=-K512M -H -I5 -T" source-repository head type: git location: https://github.com/finkel-lang/finkel.git subdir: fkc ================================================ FILE: fnkpp/LICENSE ================================================ Copyright (c) 2022, 8c6794b6 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: fnkpp/Main.hs ================================================ import Language.Finkel.Preprocess main :: IO () main = defaultPreprocess ================================================ FILE: fnkpp/README.md ================================================ # fnkpp ================================================ FILE: fnkpp/fnkpp.cabal ================================================ cabal-version: 2.0 name: fnkpp version: 0.0.0 synopsis: Finkel preprocessor description: Finkel preprocessor. . This package contains an executable @fnkpp@, which is used for preprocessing Finkel source code. . See the for more info. homepage: https://github.com/finkel-lang/finkel#readme license: BSD3 license-file: LICENSE author: 8c6794b6 maintainer: 8c6794b6@gmail.com copyright: 2022 8c6794b6 category: Language build-type: Simple extra-source-files: README.md executable fnkpp main-is: Main.hs ghc-options: -Wall -threaded build-depends: base > 4.10 && < 5 , finkel-kernel default-language: Haskell2010 source-repository head type: git location: https://github.com/finkel-lang/finkel.git subdir: fnkpp ================================================ FILE: nix/docker.nix ================================================ { nixpkgs ? , compiler ? "ghc8104", tag ? "latest", created ? "now", stream ? true }: let myPkgs = import ./finkel-packages.nix { inherit nixpkgs compiler; }; myHaskellPackages = myPkgs.haskellPackages; myGhc = myHaskellPackages.ghcWithPackages (p: [ p.finkel-kernel p.finkel-setup p.finkel-core p.finkel-tool ]); buildImage = if stream then myPkgs.dockerTools.streamLayeredImage else myPkgs.dockerTools.buildLayeredImage; in buildImage { name = "finkel"; tag = "${tag}"; created = "${created}"; contents = [ myPkgs.busybox myHaskellPackages.cabal-install # Compilation of stack is failing, commented out for now. # myPkgs.stack myGhc myHaskellPackages.fkc myHaskellPackages.fnkpp myHaskellPackages.finkel ]; config = { # Cmd = [ "/bin/finkel" "repl" "-B${myGhc}/lib/ghc-${myGhc.version}" ]; Cmd = [ "/bin/sh" ]; Volumes = { "/tmp" = { }; }; }; } ================================================ FILE: nix/finkel-packages.nix ================================================ # Main configuration settings for finkel packages { nixpkgs, compiler } : let # Separating the "cabal2nix" from host nixpkgs to target nixpkgs with using # "pkgs.haskellPackages.haskellSrc2nix" and # "pkgs.haskellPackages.callPackage". The resulting ".nix" file generated from # cabal2nix is a plain nix script taking "mkDerivation" from its argument. hostNixPkgs = import {}; haskellSrc2nix = hostNixPkgs.haskellPackages.haskellSrc2nix; filtPattern = pkgs.nix-gitignore.gitignoreFilterPure (_:_: true) ../.gitignore ../.; targets = pkgs.lib.mapAttrs (name: src0: let src = builtins.filterSource filtPattern src0; in haskellSrc2nix { inherit name src; } ) { finkel-kernel = ../finkel-kernel; fkc = ../fkc; fnkpp = ../fnkpp; finkel-setup = ../finkel-setup; finkel-core = ../finkel-core; finkel-tool= ../finkel-tool; finkel = ../finkel; }; # To compile finkel-core and finkel-tool with ghc 8.10.3. At the moment, # running fkc with multiple cores not working well. # moreCabalOptions = # if compiler == "ghc8103" then # { maxBuildCores = 1; } # else # { }; # ATM, Constantly using single build cores .... moreCabalOptions = { maxBuildCores = 1; }; # Main configuration for finkel related packages. overlay = self: super: { haskellPackages = super.haskell.packages.${compiler}.override { overrides = hself: hsuper: ( builtins.mapAttrs (name: drv: let reified = hsuper.callPackage drv {}; in super.haskell.lib.overrideCabal reified (old: { # To descrease the size of executables, as done in ghc. enableSharedExecutables = true; }) // moreCabalOptions ) targets ) // { doc = # The 'doc' package contains test codes only, overwriting the # installPhase to skip the works done for library and executable # packages. let drv = haskellSrc2nix { name = "doc"; src = ../doc; }; reified = hsuper.callPackage drv {}; in super.haskell.lib.overrideCabal reified (old: { doHaddock = false; installPhase = '' runHook preInstallPhase mkdir -p $out runHook postInstallPhase ''; } ); }; }; }; pkgs = import "${nixpkgs}" { overlays = [overlay]; }; finkelPackages = with pkgs.haskellPackages; { inherit finkel-kernel fkc fnkpp finkel-setup finkel-core finkel-tool finkel doc; }; in pkgs // { inherit finkelPackages; } ================================================ FILE: scripts/travis.sh ================================================ #!/bin/sh # Functions for Travis CI # ------------------------ # # This file is sourced in "before_install" section of ".travis.yml". Environment # variable set by Travis (e.g.; $TRAVIS_OS_NAME) could be referred from this # script. # # The functions with OS name suffix are specific to each OS. # Auxiliary # --------- travis_init () { case "$TRAVIS_OS_NAME" in linux | osx) case "$EXEC" in stack) export PATH="$HOME/.local/bin:$PATH" export STACK="stack --no-terminal --resolver=$RESOLVER" ;; cabal) export PATH=$"HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH" ;; esac ;; windows) export LOCALBIN=$HOME/AppData/Roaming/stack/local/bin export PATH="$PATH:$LOCALBIN" export STACK="stack.exe --no-terminal --resolver=$RESOLVER" ;; esac } # Linux # ----- travis_install_linux () { case "$EXEC" in stack) mkdir -p ~/.local/bin url=https://get.haskellstack.org/stable/linux-x86_64.tar.gz travis_retry curl -L $url | \ tar xz --wildcards --strip-components=1 \ -C ~/.local/bin "*/stack" ;; cabal) mkdir -p ~/.ghcup/bin url='https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup' travis_retry curl -L $url > ~/.ghcup/bin/ghcup chmod +x ~/.ghcup/bin/ghcup ghcup -c install-cabal ghcup -c install $GHC ghcup -c set $GHC which cabal which ghc cabal --version ghc --version travis_retry cabal v2-update ;; esac } travis_script_linux () { case "$EXEC" in stack) $STACK --install-ghc test --only-dependencies $STACK build --fast --test --coverage --no-run-tests $STACK -j 1 build --fast --test --coverage ;; cabal) cabal v2-configure $FLAGS cabal v2-build all cabal v2-test all cabal v2-haddock all ;; esac } travis_after_success_linux () { case "$EXEC" in stack) $STACK install hpc-codecov HPCROOT=$($STACK path --local-hpc-root) DISTDIR=$($STACK path --dist-dir) DOCPKG=doc/include/building-package TIX=$(find $HPCROOT -name 'all.tix') hpc-codecov \ --src=finkel-kernel --mix=kernel/$DISTDIR/hpc \ --src=finkel-setup --mix=setup/$DISTDIR/hpc \ --src=finkel-core --mix=core/$DISTDIR/hpc \ --src=finkel-tool --mix=tool/$DISTDIR/hpc \ --src=$DOCPKG/my-second-package \ --mix=$DOCPKG/my-second-package/$DISTDIR/hpc \ --src=$DOCPKG/my-new-package \ --mix=$DOCPKG/my-new-package/$DISTDIR/hpc \ --out=codecov.json --verbose $TIX curl -s https://codecov.io/bash | bash -s ;; cabal) echo Not taking codecov for cabal-install yet ;; esac } # OSX # --- travis_install_osx () { mkdir -p ~/.local/bin url=https://get.haskellstack.org/stable/osx-x86_64.tar.gz travis_retry curl -L $url | \ tar xz -f- --strip-components=1 -C ~/.local/bin which stack stack --version } travis_script_osx () { $STACK --install-ghc test --only-dependencies $STACK build --fast --test --no-run-tests $STACK -j 1 build --fast --test } travis_after_success_osx () { echo "OSX after success not yet written" } # Windows # ------- # See: https://docs.travis-ci.com/user/reference/windows/ travis_install_windows () { url=https://get.haskellstack.org/stable/windows-x86_64.zip travis_retry curl --silent --output stack.zip --location $url 7z x stack.zip stack.exe mkdir -p $LOCALBIN mv stack.exe $LOCALBIN echo STACK=$STACK $STACK --version || echo "no stack" } travis_script_windows () { travis_script_osx } travis_after_success_windows () { echo "Windows after success not yet written" } # Entry points for ".travis.yml" # ------------------------------ travis_install () { travis_install_${TRAVIS_OS_NAME} } travis_script () { travis_script_${TRAVIS_OS_NAME} } travis_after_success () { travis_after_success_${TRAVIS_OS_NAME} } set -e travis_init ================================================ FILE: shell.nix ================================================ { nixpkgs ? , compiler ? "ghc8104", withHoogle ? false }: let hostPkgs = import {}; pkgs = import ./nix/finkel-packages.nix { inherit compiler nixpkgs; }; shell = pkgs.haskellPackages.shellFor { packages = _ : builtins.attrValues pkgs.finkelPackages; withHoogle = withHoogle; buildInputs= [ hostPkgs.cabal-install hostPkgs.wget ]; }; in shell ================================================ FILE: stack.yaml ================================================ # This file was automatically generated by 'stack init' # # For advanced use and comprehensive documentation of the format, please see: # http://docs.haskellstack.org/en/stable/yaml_configuration/ resolver: lts-22.31 packages: # Main components - finkel-kernel/ - fkc/ - fnkpp/ - finkel-setup/ - finkel-core/ - finkel-tool/ - finkel/ # For test - doc - doc/include/building-package/my-first-package - doc/include/building-package/my-second-package - doc/include/building-package/my-new-package flags: finkel-kernel: dev: true custom-preprocessor-extensions: - fnk require-stack-version: ">= 2.6.0"