[ { "path": ".appveyor.yml", "content": "branches:\n only:\n - /appveyor-*/\n\nenvironment:\n global:\n CABOPTS: \"--store-dir=C:\\\\SR --http-transport=plain-http\"\n GHCVER: 8.10.2\n CABALVER: 3.2.0.0\n\nclone_folder: \"C:\\\\WORK\"\nclone_depth: 5\n\ncache:\n - C:\\SR\n\ninstall:\n - choco install -y cabal --version %CABALVER%\n - choco install -y ghc --version %GHCVER%\n - refreshenv\n\nbefore_build:\n - cabal --version\n - ghc --version\n - cabal %CABOPTS% v2-update\n\nbuild_script:\n - cabal %CABOPTS% v2-configure --disable-optimization --disable-library-profiling\n - cabal %CABOPTS% v2-build all -j --only-dependencies\n - cabal %CABOPTS% v2-build all\n - cabal %CABOPTS% v2-test all\n" }, { "path": ".circleci/config.yml", "content": "# Use the latest 2.1 version of CircleCI pipeline process engine. See:\n# https://circleci.com/docs/2.0/configuration-reference\nversion: 2.1\n\njobs:\n build-linux:\n docker:\n - image: fpco/stack-build:lts-15.4\n steps:\n - checkout\n - restore_cache:\n name: Restore Cached Dependencies\n keys:\n - stack-{{ checksum \"stack.yaml\" }}\n - kernel-{{ checksum \"finkel-kernel/finkel-kernel.cabal\" }}\n - kernel-{{ checksum \"fkc/fkc.cabal\" }}\n - setup-{{ checksum \"finkel-setup/finkel-setup.cabal\" }}\n - lang-{{ checksum \"finkel-core/finkel-core.cabal\" }}\n - tool-{{ checksum \"finkel-tool/finkel-tool.cabal\" }}\n - finkel-{{ checksum \"finkel/finkel.cabal\" }}\n - run:\n name: Resolve/Update Dependencies\n command: stack --no-terminal setup\n - run:\n name: Build Packages\n command: stack --no-terminal build --test --no-run-tests\n - run:\n name: Run tests\n command: RESOLVER=lts-15.4 stack --no-terminal build --test\n - save_cache:\n name: Cache dependencies\n key: stack-{{ checksum \"stack.yaml\" }}\n paths:\n - ~/.stack\n - ~/.stack-work\n\nworkflows:\n build:\n jobs:\n - build-linux:\n filters:\n branches:\n only:\n - /circleci-.*/\n" }, { "path": ".codecov.yml", "content": "coverage:\n status:\n project:\n default:\n threshold: 5%\n" }, { "path": ".dir-locals.el", "content": ";;; Directory Local Variables\n;;; For more information see (info \"(emacs) Directory Variables\")\n\n((nil\n (fill-column . 80)\n (indent-tabs-mode . nil))\n\n (finkel-mode\n (eval finkel-put-indent-method 'define-macro 'finkel-indent-multiargs)\n (eval finkel-put-doc-string-elt 'define-macro 2)\n\n (eval finkel-put-indent-method 'define-macro\\' 'finkel-indent-multiargs)\n (eval finkel-put-doc-string-elt 'define-macro\\' 2)\n\n (eval finkel-put-indent-method 'describe 1)\n (eval finkel-put-indent-method 'it 1)))\n" }, { "path": ".gitattributes", "content": "* text=auto\n" }, { "path": ".github/ISSUE_TEMPLATE/bug_report.md", "content": "---\nname: Bug Report\nabout: Report a bug in Finkel\n---\n\nPlease follow the steps below for reporting a bug:\n\nMake sure that you are using the latest source (currently git HEAD in\nthe master branch).\n\nPlease use the following schema for your bug report:\n\n### General summary/comments (optional)\n\n### Steps to reproduce\n\nFor example:\n\n1. Remove directory *foo*.\n2. Run command `finkel bar`.\n3. Edit file buzz.\n4. Run command `finkel quux`.\n\n### Expected\n\nWhat you expected to see and happen.\n\n### Actual\n\nWhat actually happened.\n\nIf you suspect that a finkel command misbehaved, please include the\noutput of that command in `debug` mode. If the output is larger than\na page please paste the output in a [Gist](https://gist.github.com/).\n\n```\n$ FNK_DEBUG=1 finkel \n\n```\n\n### Finkel version and environment information\n\nFinkel version could be obtained with below command.\n\n```\n$ finkel version\n\n```\n\n* OS name and version\n* ... etc\n\n### Method of installation\n\n* Via cabal-install\n* Via stack\n* Other (please specify)\n" }, { "path": ".github/dependabot.yml", "content": "version: 2\n\nupdates:\n - package-ecosystem: \"github-actions\"\n directory: \"/\"\n schedule:\n interval: \"weekly\"\n" }, { "path": ".github/workflows/cabal-install.yml", "content": "name: cabal-install\n\non:\n workflow_call:\n inputs:\n cache-version:\n description: cache key version\n required: true\n type: string\n\ndefaults:\n run:\n shell: bash\n\njobs:\n cabal-install:\n name: ghc ${{ matrix.plan.ghc }} with ${{ matrix.plan.flags }}\n strategy:\n matrix:\n os:\n - ubuntu-latest\n # - macos-latest\n # - windows-latest\n plan:\n - ghc: \"9.0.2\"\n cabal: \"3.10.3.0\"\n flags: \"-O0\"\n\n - ghc: \"9.2.8\"\n cabal: \"latest\"\n flags: \"-O0\"\n\n # Running tests in ghc 9.4.8 was approximately 2x slower than 9.4.7\n - ghc: \"9.4.7\"\n cabal: \"latest\"\n flags: \"-O0\"\n\n - ghc: \"9.6.5\"\n cabal: \"latest\"\n flags: \"-O0\"\n\n - ghc: \"9.8.2\"\n cabal: \"latest\"\n flags: \"-O0\"\n\n - ghc: \"9.10.1\"\n cabal: \"latest\"\n flags: \"-O0\"\n\n - ghc: \"9.10.1\"\n cabal: \"latest\"\n flags: \"-O2\"\n\n runs-on:\n - ${{ matrix.os }}\n\n steps:\n - name: Checkout project repository\n uses: actions/checkout@v4\n\n - name: Cache cabal package database\n uses: actions/cache@v4\n with:\n path: ~/.cabal\n key: home-dot-cabal-${{ matrix.plan.ghc }}-${{ inputs.cache-version }}\n\n - name: Setup ghc and cabal-install\n uses: haskell-actions/setup@v2\n with:\n ghc-version: ${{ matrix.plan.ghc }}\n cabal-version: ${{ matrix.plan.cabal }}\n\n - name: Show version and paths\n run: |\n ghc --version\n cabal --version\n\n # # XXX: In Windows, use of profiling libraries are not yet supported.\n # - name: Write cabal.project.local with v2-configure (windows)\n # if: matrix.os == 'windows-latest'\n # run: cabal v2-configure --disable-library-profiling ${{ matrix.plan.flags }}\n\n - name: Write cabal.project.local with v2-configure\n run: cabal v2-configure ${{ matrix.plan.flags }} --test-show-details=streaming\n\n - name: Build dependency packages\n run: cabal v2-build all -j --only-dependencies\n\n - name: Build packages\n run: cabal v2-build all\n\n - name: Run tests\n run: cabal v2-test all\n\n - name: Run haddock\n run: cabal v2-haddock all\n" }, { "path": ".github/workflows/ci.yml", "content": "name: ci\n\non:\n pull_request:\n push:\n paths-ignore:\n - '**.md'\n\ndefaults:\n run:\n shell: bash\n\njobs:\n pre-job:\n uses: ./.github/workflows/pre-job.yml\n\n stack:\n needs: pre-job\n if: ${{ needs.pre-job.outputs.run == 'true' }}\n uses: ./.github/workflows/stack.yml\n secrets: inherit\n with:\n cache-version: v16\n\n cabal-install:\n needs: pre-job\n if: ${{ needs.pre-job.outputs.run == 'true' }}\n uses: ./.github/workflows/cabal-install.yml\n with:\n cache-version: v18\n\n nix-build:\n needs: pre-job\n if: ${{ needs.pre-job.outputs.run == 'true' }}\n uses: ./.github/workflows/nix-build.yml\n secrets: inherit\n\n make-sdist-with-stack:\n needs: pre-job\n if: ${{ needs.pre-job.outputs.run == 'true' }}\n uses: ./.github/workflows/sdist.yml\n" }, { "path": ".github/workflows/nix-build.yml", "content": "name: nix-build\n\non:\n workflow_call:\n\njobs:\n nix-build:\n name: Build with nix\n strategy:\n matrix:\n include:\n # - nixpkgs: \"channel:nixos-20.03\"\n # compiler: \"ghc865\"\n # - nixpkgs: \"channel:nixos-20.09\"\n # compiler: \"ghc884\"\n - nixpkgs: \"channel:nixos-22.05\"\n compiler: \"ghc8107\"\n # - nixpkgs: \"channel:nixos-23.05\"\n # compiler: \"ghc92\"\n # - nixpkgs: \"channel:nixos-unstable\"\n # compiler: \"ghc8107\"\n # - nixpkgs: \"channel:nixos-unstable\"\n # compiler: \"ghc901\"\n\n runs-on:\n - ubuntu-latest\n\n steps:\n - name: Checkout git repository\n uses: actions/checkout@v4\n\n - name: Install nix\n uses: cachix/install-nix-action@v29\n with:\n nix_path: nixpkgs=${{ matrix.nixpkgs }}\n\n - name: Build with nix-build\n run: nix-build --argstr compiler ${{ matrix.compiler }}\n\n - name: Build container image stream\n # if: matrix.compiler == 'ghc8107' && github.ref == 'refs/heads/master'\n if: github.ref == 'refs/heads/master'\n run: |\n nix-build --argstr compiler ${{ matrix.compiler }} ./nix/docker.nix\n echo \"image_stream=$(readlink result)\" >> $GITHUB_ENV\n\n - name: Push image to ghcr.io\n # if: matrix.compiler == 'ghc8107' && github.ref == 'refs/heads/master'\n if: github.ref == 'refs/heads/master'\n env:\n # Below `CRED' was used for credentials for ghcr.io, but not any more\n # since logging in with GITHUB_TOKEN is working. May be the\n # `GHCR_USER' and `GHCR_PAT' variables could be removed from the\n # secrets.\n #\n # CRED: ${{ secrets.GHCR_USER }}:${{ secrets.GHCR_PAT }}\n FROM: docker-archive:/dev/stdin\n TO: docker://ghcr.io/${{ github.repository }}:latest\n run: |\n echo ${{ secrets.GITHUB_TOKEN }} | skopeo login -u $ --password-stdin ghcr.io\n ${{ env.image_stream }} | gzip | skopeo --debug copy ${FROM} ${TO}\n" }, { "path": ".github/workflows/pre-job.yml", "content": "name: pre-job\n\non:\n workflow_call:\n outputs:\n run:\n description: \\\"true\\\" if running other jobs\n value: ${{ jobs.pre-job.outputs.run }}\n\njobs:\n pre-job:\n name: Decide whether to run other jobs\n runs-on: ubuntu-latest\n outputs:\n run: >-\n ${{\n steps.skip-check.outputs.should_skip != 'true' ||\n github.ref_name == github.event.repository.default_branch\n }}\n steps:\n - id: skip-check\n uses: fkirc/skip-duplicate-actions@v5\n with:\n concurrent_skipping: same_content_newer\n" }, { "path": ".github/workflows/sdist.yml", "content": "name: sdist\n\non:\n workflow_call:\n\njobs:\n make-sdist-with-stack:\n name: Build *.tar.gz made via sdist\n\n runs-on: ubuntu-latest\n\n env:\n STACK: stack --resolver=lts-20\n\n steps:\n - name: Checkout git repository\n uses: actions/checkout@v4\n\n - name: Show versions\n run: |\n stack --version\n ghc --version\n cabal --version\n\n - name: Build finkel-setup\n # The \"finkel-setup\" is used by other packages in custom-setup stanza of\n # cabal configuration, building before running sdist command.\n run: $STACK build --fast finkel-setup\n\n - name: Run stack sdist\n run: |\n $STACK sdist \\\n finkel-kernel \\\n fkc \\\n fnkpp \\\n finkel-setup \\\n finkel-core \\\n finkel-tool \\\n finkel \\\n --tar-dir sdist\n\n - name: Emit temporary stack.yaml\n run: |\n cd sdist\n echo 'resolver: lts-0.0' > stack.yaml\n echo 'packages:' >> stack.yaml\n ls *.tar.gz | sed -e 's/\\(.*\\)\\.tar.gz/ - \\1/' >> stack.yaml\n cat stack.yaml\n\n - name: Build from tarballs with stack\n run: |\n cd sdist\n for t in `ls *.tar.gz`; do tar zxvf $t; done\n $STACK build --fast\n\n - name: Emit temporary cabal.project\n run: |\n cd sdist\n echo 'packages:' >> cabal.project\n ls *.tar.gz | sed -e 's/\\(.*\\)\\.tar.gz/ \\1/' >> cabal.project\n cat cabal.project\n\n - name: Install and set ghc 9.2.8 via ghcup\n run: |\n ghcup install ghc 9.2.8\n ghcup set ghc 9.2.8\n\n - name: Build from tarballs with cabal-install\n run: |\n cd sdist\n cabal v2-update\n cabal v2-build all\n\n - name: Upload package tarballs\n uses: actions/upload-artifact@v4\n with:\n name: finkel-srcs\n path: |\n sdist/*.tar.gz\n sdist/stack.yaml\n sdist/cabal.project\n" }, { "path": ".github/workflows/stack.yml", "content": "name: stack\n\non:\n workflow_call:\n inputs:\n cache-version:\n description: cache key version\n required: true\n type: string\n\ndefaults:\n run:\n shell: bash\n\njobs:\n stack:\n name: ${{ matrix.resolver }} under ${{ matrix.os }}\n strategy:\n matrix:\n include:\n # - os: ubuntu-latest\n # resolver: lts-11\n # - os: ubuntu-latest\n # resolver: lts-12\n\n # - os: ubuntu-latest\n # resolver: lts-14\n # - os: ubuntu-latest\n # resolver: lts-16\n # - os: ubuntu-latest\n # resolver: lts-18\n\n - os: ubuntu-latest\n resolver: lts-22\n - os: macos-latest\n resolver: lts-22\n - os: windows-latest\n resolver: lts-22\n\n env:\n STACK: stack --resolver=${{ matrix.resolver }}\n\n runs-on:\n - ${{ matrix.os }}\n\n steps:\n - name: Checkout git repository\n uses: actions/checkout@v4\n\n - name: Cache stack related directories\n uses: 8c6794b6/playing-with-github/.github/actions/setup-stack-cache@main\n with:\n cache-key:\n ${{ matrix.os }}-${{ matrix.resolver }}-${{ inputs.cache-version }}\n\n - name: Setup haskell\n uses: haskell-actions/setup@v2.7.3\n with:\n enable-stack: true\n stack-no-global: true\n\n - name: Setup stack\n run: $STACK setup\n\n - name: Show versions\n run: |\n $STACK --version\n $STACK exec -- ghc --version\n\n - name: Install dependency packages\n run: $STACK build -j 2 --test --only-dependencies\n\n - name: Build packages\n run: $STACK build --fast --test --coverage --no-run-tests\n\n - name: Run tests\n run: |\n RESOLVER=${{ matrix.resolver }} $STACK --jobs 1 build \\\n --fast --test --coverage\n\n - name: Generate coverage report\n uses: 8c6794b6/hpc-codecov-action@v4\n with:\n target: stack:all\n\n - name: Send coverage report\n uses: codecov/codecov-action@v4\n with:\n name: stack-${{ matrix.os }}-${{ matrix.resolver }}\n token: ${{ secrets.CODECOV_TOKEN }}\n" }, { "path": ".gitignore", "content": "*~\n*.hi\n*.hie\n*.hscpp\n*.o\n*.dyn_o\n*.dyn_hi\n*.p_o\n*.p_hi\n*.info\n*.prof\n*.html\n*.hp\n*.tix\n*.yaml.lock\n.ghc.environment.*\nresult*\n\nTAGS\na.out\ncabal.project.local\n\nfinkel-kernel/include/finkel_kernel_config.h\nfinkel-kernel/test/data/main/m00?\nfinkel-kernel/test/data/make/main?\nfinkel-kernel/test/data/make/gen\nfinkel-kernel/test/data/plugin/p??\nfinkel-kernel/test/data/syntax/*.h\n\n.stack-work/\ndist/\ndist-newstyle/\n\ndoc/_build\ndoc/_static\ndoc/_templates\n\ndoc/include/finkel-executable/hello\ndoc/include/macros/quasiquote\ndoc/include/macros/require\n" }, { "path": ".hlint.yaml", "content": "# HLint configuration file\n# https://github.com/ndmitchell/hlint\n##########################\n\n# This file contains a template configuration file, which is typically\n# placed as .hlint.yaml in the root of your project\n\n\n# Specify additional command line arguments\n#\n# - arguments: [--color, --cpp-simple, -XQuasiQuotes]\n\n\n# Control which extensions/flags/modules/functions can be used\n#\n# - extensions:\n# - default: false # all extension are banned by default\n# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used\n# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module\n#\n# - flags:\n# - {name: -w, within: []} # -w is allowed nowhere\n#\n# - modules:\n# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'\n# - {name: Control.Arrow, within: []} # Certain modules are banned entirely\n#\n# - functions:\n# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules\n\n\n# Add custom hints for this project\n#\n# Will suggest replacing \"wibbleMany [myvar]\" with \"wibbleOne myvar\"\n# - error: {lhs: \"wibbleMany [x]\", rhs: wibbleOne x}\n\n\n# Turn on hints that are off by default\n#\n# Ban \"module X(module X) where\", to require a real export list\n# - warn: {name: Use explicit module export list}\n#\n# Replace a $ b $ c with a . b $ c\n# - group: {name: dollar, enabled: true}\n#\n# Generalise map to fmap, ++ to <>\n# - group: {name: generalise, enabled: true}\n\n\n# Ignore some builtin hints\n# - ignore: {name: Use let}\n# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules\n- ignore: {name: Use fewer imports}\n- ignore: {\n name: Use camelCase,\n within: [\n Language.Finkel.Emit,\n Language.Finkel.Syntax.HBind,\n Language.Finkel.Syntax.HDecl,\n Language.Finkel.Syntax.HExpr,\n Language.Finkel.Syntax.HImpExp,\n Language.Finkel.Syntax.HPat,\n Language.Finkel.Syntax.HType,\n Language.Finkel.SpecialForms\n ]\n }\n\n\n# Define some custom infix operators\n# - fixity: infixr 3 ~^#^~\n\n\n# To generate a suitable file for HLint do:\n# $ hlint --default > .hlint.yaml\n" }, { "path": ".readthedocs.yaml", "content": "version: 2\n\nsphinx:\n configuration: doc/conf.py\n\npython:\n version: 3.8\n install:\n - requirements: doc/requirements.txt\n" }, { "path": ".stylish-haskell.yaml", "content": "# stylish-haskell configuration file\n# ==================================\n\n# The stylish-haskell tool is mainly configured by specifying steps. These steps\n# are a list, so they have an order, and one specific step may appear more than\n# once (if needed). Each file is processed by these steps in the given order.\nsteps:\n # Convert some ASCII sequences to their Unicode equivalents. This is disabled\n # by default.\n # - unicode_syntax:\n # # In order to make this work, we also need to insert the UnicodeSyntax\n # # language pragma. If this flag is set to true, we insert it when it's\n # # not already present. You may want to disable it if you configure\n # # language extensions using some other method than pragmas. Default:\n # # true.\n # add_language_pragma: true\n\n # Align the right hand side of some elements. This is quite conservative\n # and only applies to statements where each element occupies a single\n # line. All default to true.\n - simple_align:\n cases: true\n top_level_patterns: true\n records: true\n\n # Import cleanup\n - imports:\n # There are different ways we can align names and lists.\n #\n # - global: Align the import names and import list throughout the entire\n # file.\n #\n # - file: Like global, but don't add padding when there are no qualified\n # imports in the file.\n #\n # - group: Only align the imports per group (a group is formed by adjacent\n # import lines).\n #\n # - none: Do not perform any alignment.\n #\n # Default: global.\n align: file\n\n # The following options affect only import list alignment.\n #\n # List align has following options:\n #\n # - after_alias: Import list is aligned with end of import including\n # 'as' and 'hiding' keywords.\n #\n # > import qualified Data.List as List (concat, foldl, foldr, head,\n # > init, last, length)\n #\n # - with_alias: Import list is aligned with start of alias or hiding.\n #\n # > import qualified Data.List as List (concat, foldl, foldr, head,\n # > init, last, length)\n #\n # - with_module_name: Import list is aligned `list_padding` spaces after\n # the module name.\n #\n # > import qualified Data.List as List (concat, foldl, foldr, head,\n # init, last, length)\n #\n # This is mainly intended for use with `pad_module_names: false`.\n #\n # > import qualified Data.List as List (concat, foldl, foldr, head,\n # init, last, length, scanl, scanr, take, drop,\n # sort, nub)\n #\n # - new_line: Import list starts always on new line.\n #\n # > import qualified Data.List as List\n # > (concat, foldl, foldr, head, init, last, length)\n #\n # Default: after_alias\n list_align: after_alias\n\n # Right-pad the module names to align imports in a group:\n #\n # - true: a little more readable\n #\n # > import qualified Data.List as List (concat, foldl, foldr,\n # > init, last, length)\n # > import qualified Data.List.Extra as List (concat, foldl, foldr,\n # > init, last, length)\n #\n # - false: diff-safe\n #\n # > import qualified Data.List as List (concat, foldl, foldr, init,\n # > last, length)\n # > import qualified Data.List.Extra as List (concat, foldl, foldr,\n # > init, last, length)\n #\n # Default: true\n pad_module_names: true\n\n # Long list align style takes effect when import is too long. This is\n # determined by 'columns' setting.\n #\n # - inline: This option will put as much specs on same line as possible.\n #\n # - new_line: Import list will start on new line.\n #\n # - new_line_multiline: Import list will start on new line when it's\n # short enough to fit to single line. Otherwise it'll be multiline.\n #\n # - multiline: One line per import list entry.\n # Type with constructor list acts like single import.\n #\n # > import qualified Data.Map as M\n # > ( empty\n # > , singleton\n # > , ...\n # > , delete\n # > )\n #\n # Default: inline\n long_list_align: inline\n\n # Align empty list (importing instances)\n #\n # Empty list align has following options\n #\n # - inherit: inherit list_align setting\n #\n # - right_after: () is right after the module name:\n #\n # > import Vector.Instances ()\n #\n # Default: inherit\n empty_list_align: inherit\n\n # List padding determines indentation of import list on lines after import.\n # This option affects 'long_list_align'.\n #\n # - : constant value\n #\n # - module_name: align under start of module name.\n # Useful for 'file' and 'group' align settings.\n #\n # Default: 4\n list_padding: 4\n\n # Separate lists option affects formatting of import list for type\n # or class. The only difference is single space between type and list\n # of constructors, selectors and class functions.\n #\n # - true: There is single space between Foldable type and list of it's\n # functions.\n #\n # > import Data.Foldable (Foldable (fold, foldl, foldMap))\n #\n # - false: There is no space between Foldable type and list of it's\n # functions.\n #\n # > import Data.Foldable (Foldable(fold, foldl, foldMap))\n #\n # Default: true\n separate_lists: true\n\n # Space surround option affects formatting of import lists on a single\n # line. The only difference is single space after the initial\n # parenthesis and a single space before the terminal parenthesis.\n #\n # - true: There is single space associated with the enclosing\n # parenthesis.\n #\n # > import Data.Foo ( foo )\n #\n # - false: There is no space associated with the enclosing parenthesis\n #\n # > import Data.Foo (foo)\n #\n # Default: false\n space_surround: false\n\n # Language pragmas\n - language_pragmas:\n # We can generate different styles of language pragma lists.\n #\n # - vertical: Vertical-spaced language pragmas, one per line.\n #\n # - compact: A more compact style.\n #\n # - compact_line: Similar to compact, but wrap each line with\n # `{-#LANGUAGE #-}'.\n #\n # Default: vertical.\n style: vertical\n\n # Align affects alignment of closing pragma brackets.\n #\n # - true: Brackets are aligned in same column.\n #\n # - false: Brackets are not aligned together. There is only one space\n # between actual import and closing bracket.\n #\n # Default: true\n align: true\n\n # stylish-haskell can detect redundancy of some language pragmas. If this\n # is set to true, it will remove those redundant pragmas. Default: true.\n remove_redundant: true\n\n # Replace tabs by spaces. This is disabled by default.\n # - tabs:\n # # Number of spaces to use for each tab. Default: 8, as specified by the\n # # Haskell report.\n # spaces: 8\n\n # Remove trailing whitespace\n - trailing_whitespace: {}\n\n # Squash multiple spaces between the left and right hand sides of some\n # elements into single spaces. Basically, this undoes the effect of\n # simple_align but is a bit less conservative.\n # - squash: {}\n\n# A common setting is the number of columns (parts of) code will be wrapped\n# to. Different steps take this into account. Default: 80.\ncolumns: 80\n\n# By default, line endings are converted according to the OS. You can override\n# preferred format here.\n#\n# - native: Native newline format. CRLF on Windows, LF on other OSes.\n#\n# - lf: Convert to LF (\"\\n\").\n#\n# - crlf: Convert to CRLF (\"\\r\\n\").\n#\n# Default: native.\nnewline: native\n\n# Sometimes, language extensions are specified in a cabal file or from the\n# command line instead of using language pragmas in the file. stylish-haskell\n# needs to be aware of these, so it can parse the file correctly.\n#\n# No language extensions are enabled by default.\nlanguage_extensions:\n - TemplateHaskell\n # - QuasiQuotes\n\n# Attempt to find the cabal file in ancestors of the current directory, and\n# parse options (currently only language extensions) from that.\n#\n# Default: true\ncabal: true\n" }, { "path": ".travis.yml", "content": "language: c\n\nbranches:\n only:\n - /^travis-.*/\n\ngit:\n depth: 3\n\ncache:\n directories:\n - $HOME/.stack\n - $HOME/.cabal/packages\n - $HOME/.cabal/store\n - $HOME/.ghcup\n - $HOME/AppData/Local/Programs/stack\n - $HOME/AppData/Roaming/stack\n\naddons:\n apt:\n packages:\n - libgmp-dev\n homebrew:\n # Workaround for \"Unknown command: bundle\", see: https://bit.ly/32d3V2d\n update: true\n\njobs:\n include:\n - os: linux\n env: EXEC=stack RESOLVER=lts-11\n - os: linux\n env: EXEC=stack RESOLVER=lts-12\n - os: linux\n env: EXEC=stack RESOLVER=lts-14\n - os: linux\n env: EXEC=stack RESOLVER=lts-16\n - os: linux\n env: EXEC=cabal GHC=8.10.2 FLAGS=\"-O0\"\n - os: linux\n env: EXEC=cabal GHC=8.10.2 FLAGS=\"-O2\"\n - os: osx\n env: EXEC=stack RESOLVER=lts-16\n - os: windows\n env: EXEC=stack RESOLVER=lts-14\n allow_failures:\n - os: windows\n env: EXEC=stack RESOLVER=lts-16\n\nbefore_install:\n - . scripts/travis.sh\n\ninstall:\n - travis_install\n\nscript:\n - travis_script\n\nafter_success:\n - travis_after_success\n\nnotification:\n email: false\n" }, { "path": "CODE_OF_CONDUCT.md", "content": "# Contributor Covenant Code of Conduct\n\n## Our Pledge\n\nWe as members, contributors, and leaders pledge to make participation\nin our community a harassment-free experience for everyone, regardless\nof age, body size, visible or invisible disability, ethnicity, sex\ncharacteristics, gender identity and expression, level of experience,\neducation, socio-economic status, nationality, personal appearance,\nrace, religion, or sexual identity and orientation.\n\nWe pledge to act and interact in ways that contribute to an open,\nwelcoming, diverse, inclusive, and healthy community.\n\n## Our Standards\n\nExamples of behavior that contributes to a positive environment for\nour community include:\n\n* Demonstrating empathy and kindness toward other people\n* Being respectful of differing opinions, viewpoints, and experiences\n* Giving and gracefully accepting constructive feedback\n* Accepting responsibility and apologizing to those affected by our\n mistakes, and learning from the experience\n* Focusing on what is best not just for us as individuals, but for the\n overall community\n\nExamples of unacceptable behavior include:\n\n* The use of sexualized language or imagery, and sexual attention or\n advances of any kind\n* Trolling, insulting or derogatory comments, and personal or\n political attacks\n* Public or private harassment\n* Publishing others' private information, such as a physical or email\n address, without their explicit permission\n* Other conduct which could reasonably be considered inappropriate in a\n professional setting\n\n## Enforcement Responsibilities\n\nCommunity leaders are responsible for clarifying and enforcing our\nstandards of acceptable behavior and will take appropriate and fair\ncorrective action in response to any behavior that they deem\ninappropriate, threatening, offensive, or harmful.\n\nCommunity leaders have the right and responsibility to remove, edit,\nor reject comments, commits, code, wiki edits, issues, and other\ncontributions that are not aligned to this Code of Conduct, and will\ncommunicate reasons for moderation decisions when appropriate.\n\n## Scope\n\nThis Code of Conduct applies within all community spaces, and also\napplies when an individual is officially representing the community in\npublic spaces. Examples of representing our community include using an\nofficial e-mail address, posting via an official social media account,\nor acting as an appointed representative at an online or offline\nevent.\n\n## Enforcement\n\nInstances of abusive, harassing, or otherwise unacceptable behavior\nmay be reported to the community leaders responsible for enforcement\nat [INSERT CONTACT METHOD]. All complaints will be reviewed and\ninvestigated promptly and fairly.\n\nAll community leaders are obligated to respect the privacy and\nsecurity of the reporter of any incident.\n\n## Enforcement Guidelines\n\nCommunity leaders will follow these Community Impact Guidelines in\ndetermining the consequences for any action they deem in violation of\nthis Code of Conduct:\n\n### 1. Correction\n\n**Community Impact**: Use of inappropriate language or other behavior\ndeemed unprofessional or unwelcome in the community.\n\n**Consequence**: A private, written warning from community leaders,\nproviding clarity around the nature of the violation and an\nexplanation of why the behavior was inappropriate. A public apology\nmay be requested.\n\n### 2. Warning\n\n**Community Impact**: A violation through a single incident or series\nof actions.\n\n**Consequence**: A warning with consequences for continued\nbehavior. No interaction with the people involved, including\nunsolicited interaction with those enforcing the Code of Conduct, for\na specified period of time. This includes avoiding interactions in\ncommunity spaces as well as external channels like social\nmedia. Violating these terms may lead to a temporary or permanent ban.\n\n### 3. Temporary Ban\n\n**Community Impact**: A serious violation of community standards,\nincluding sustained inappropriate behavior.\n\n**Consequence**: A temporary ban from any sort of interaction or\npublic communication with the community for a specified period of\ntime. No public or private interaction with the people involved,\nincluding unsolicited interaction with those enforcing the Code of\nConduct, is allowed during this period. Violating these terms may lead\nto a permanent ban.\n\n### 4. Permanent Ban\n\n**Community Impact**: Demonstrating a pattern of violation of\ncommunity standards, including sustained inappropriate behavior,\nharassment of an individual, or aggression toward or disparagement of\nclasses of individuals.\n\n**Consequence**: A permanent ban from any sort of public interaction\nwithin the community.\n\n## Attribution\n\nThis Code of Conduct is adapted from the [Contributor\nCovenant][homepage], version 2.0, available at\nhttps://www.contributor-covenant.org/version/2/0/code_of_conduct.html.\n\nCommunity Impact Guidelines were inspired by [Mozilla's code of\nconduct enforcement ladder](https://github.com/mozilla/diversity).\n\n[homepage]: https://www.contributor-covenant.org\n\nFor answers to common questions about this code of conduct, see the\nFAQ at https://www.contributor-covenant.org/faq. Translations are\navailable at https://www.contributor-covenant.org/translations.\n" }, { "path": "CONTRIBUTING.md", "content": "# Contributing\n\nFirst of all, thanks for your interest in contributing to Finkel!\n\nWe want to make contributing to this project as easy and transparent\nas possible, whether it's:\n\n- Reporting a bug\n- Discussing the current state of the code\n- Submitting a fix\n- Proposing new features\n- Becoming a maintainer\n\nFinkel is an open source project. Following these guidelines helps to\ncommunicate that you respect the time of the developers managing and\ndeveloping this open source project. In return, they should\nreciprocate that respect in addressing your issue, assessing changes,\nand helping you finalize your pull requests.\n\n\n## Code of Conduct\n\nAll members of our community are expected to follow our [Code of\nConduct][coc]. Please make sure you are welcoming and friendly in all\nof our spaces.\n\n[coc]: https://github.com/finkel-lang/finkel/blob/master/CODE_OF_CONDUCT.md\n\n\n## Getting started with Finkel source\n\nPlease see the [Building And Installing][doc-install] section of the\ndocumentation for detailed instruction. In short:\n\n```\n$ git clone https://github.com/finkel-lang/finkel\n$ cd finkel\n$ stack build\n```\n\n[doc-install]: https://finkel.readthedocs.io/en/latest/contents/install.html\n\n\n## Issues\n\nWe use the [github issue tracker][ghissue] to manage issues. Please do\nsome searches in the existing issues before creating a new one. When\nsending a bug report, please make sure that you are using the latest\nversion of Finkel built from the source.\n\n[ghissue]: https://github.com/finkel-lang/finkel/issues\n\n\n## Pull Requests\n\n### Style guide / Coding conventions\n\nWe believe every one has its taste in coding style. However, the\nfollowing provides some suggestions:\n\n- By default, all source codes are written with max 80 characters per\n line, but there are some exceptions, e.g. use of long string\n constants in URL.\n\n- For Haskell source code, use 2 spaces for indentations. We use\n [hlint][hlint] and [stylish-haskell][stylish-haskell] with the\n configuration files in the repository root directory. It is totally\n fine to make changes to the configuration files, just please tell us\n why.\n\n- For Finkel source code, not much to say at the moment, since the\n language is still young. However, try to follow the style used in\n the file when you modify the existing file.\n\n- Please consider writing [a good Git commit message][gitcommit].\n\n[hlint]: https://github.com/ndmitchell/hlint\n[stylish-haskell]: https://github.com/jaspervdj/stylish-haskell\n[gitcommit]: https://chris.beams.io/posts/git-commit/#seven-rules\n\n### Running tests\n\nPlease make sure that the tests are passing with your modifications.\nFor example, to test with [stack][stack], run:\n\n```\n$ stack build --test\n```\n\n[stack]: https://docs.haskellstack.org/en/stable/README/\n\n### Trivial changes\n\nSmall contributions such as fixing spelling errors, can be also\nsubmitted by a contributor as a pull request.\n\nAs a rule of thumb, changes are obvious fixes if they do not introduce\nany new functionality or creative thinking. As long as the change does\nnot affect functionality, some likely examples include the following:\n\n- Spelling/grammar fixes\n- Typo correction, white space and formatting changes\n- Comment clean up\n- Changes to *metadata* files like ``.gitignore``, etc.\n\n### License\n\nIn short, when you submit code changes, your submissions are\nunderstood to be under the same [BSD 3-clause License][bsd3] that\ncovers the project.\n\n[bsd3]: https://choosealicense.com/licenses/bsd-3-clause/\n" }, { "path": "LICENSE", "content": "Copyright 8c6794b6 (c) 2017-2020\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "README.md", "content": "# Finkel\n\n[![CI status][ci-badge]][ci]\n[![Documentation][doc-badge]][doc]\n[![Codecov][codecov-badge]][codecov]\n\nFinkel is a statically typed, purely functional, and non-strict-by-default\n[LISP][lisp] flavored programming language.\n\nOr in other words, **[Haskell][haskell] in S-expression**.\n\n\n## Features\n\n- Integration with existing Haskell modules.\n- Building Haskell-compatible [Cabal][cabal] packages.\n- Documentation generation with [Haddock][haddock].\n- Lisp style macro system.\n- Tool executable, including interactive REPL.\n\n## Example\n\n### Sample code\n\n```clojure\n;;;; File: fib.hs\n\n(:doc \"Simple example module to show fibonacci number.\n\nThe compiled executable takes an integer argument from command line\ninput and print the fibonacci number of the argument.\")\n\n(defmodule Main\n (import\n (System.Environment [getArgs])))\n\n(defn (:: main (IO ()))\n \"The main entry point function.\"\n (>>= getArgs (. print fib read head)))\n\n(defn (:: fib (-> Int Int))\n \"Naive fibonacci function.\"\n [0] 0\n [1] 1\n [n] (+ (fib (- n 1))\n (fib (- n 2))))\n```\n\n### Compiling an executable\n\n```console\n$ finkel make -o fib fib.hs\n[1 of 1] Compiling Main ( fib.hs, fib.o )\nLinking fib\n$ ./fib 10\n55\n```\n\n### Running REPL\n\n```console\n$ finkel repl\nHit `Ctrl-d' or type ,q to quit, type ,? for help.\n> ,load fib.hs\n[1 of 1] Compiling Main ( fib.hs, interpreted )\n; loaded fib.hs\n> ,info fib\nfib :: Int -> Int -- Defined at fib.hs:16:11\n> (map fib [1 .. 10])\n[1,1,2,3,5,8,13,21,34,55]\n> (System.Environment.withArgs [\"10\"] main)\n55\n> ,q\n```\n\n## Further resources\n\nSee the [documentation][doc] for more details.\n\n\n## Contributing\n\nContributions are welcome. Please see the [CONTRIBUTING.md][contrib].\n\n[ci-badge]: https://img.shields.io/github/actions/workflow/status/finkel-lang/finkel/ci.yml?logo=github&label=ci\n[ci]: https://github.com/finkel-lang/finkel/actions/workflows/ci.yml\n[doc-badge]: http://readthedocs.org/projects/finkel/badge/?version=latest\n[doc]: https://finkel.readthedocs.io/en/latest/\n[codecov-badge]: https://codecov.io/gh/finkel-lang/finkel/branch/master/graph/badge.svg\n[codecov]: https://codecov.io/gh/finkel-lang/finkel\n\n[cabal]: https://www.haskell.org/cabal/\n[contrib]: https://github.com/finkel-lang/finkel/blob/master/CONTRIBUTING.md\n[haddock]: https://www.haskell.org/haddock/\n[haskell]: https://haskell.org\n[lisp]: https://en.wikipedia.org/wiki/Lisp_(programming_language)\n" }, { "path": "cabal.project", "content": "packages:\n -- Main components\n finkel-kernel/\n fkc/\n fnkpp/\n finkel-setup/\n finkel-core/\n finkel-tool/\n finkel/\n\n -- For test\n doc/\n doc/include/building-package/my-first-package\n doc/include/building-package/my-second-package\n doc/include/building-package/my-new-package\n\ntests: True\nbenchmarks: True\nlibrary-profiling: True\n\npackage finkel-kernel\n flags: +dev\n" }, { "path": "default.nix", "content": "{\n nixpkgs ? ,\n compiler ? \"ghc8106\"\n}:\n\nlet\n pkgs = import ./nix/finkel-packages.nix {\n inherit compiler nixpkgs;\n };\nin pkgs.finkelPackages\n" }, { "path": "doc/LICENSE", "content": "Copyright 8c6794b6 (c) 2020-2022\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "doc/Makefile", "content": "# Minimal makefile for Sphinx documentation\n#\n\n# You can set these variables from the command line.\nSPHINXOPTS =\nSPHINXBUILD = sphinx-build\nSOURCEDIR = .\nBUILDDIR = _build\n\n# Put it first so that \"make\" without argument is like \"make help\".\nhelp:\n\t@$(SPHINXBUILD) -M help \"$(SOURCEDIR)\" \"$(BUILDDIR)\" $(SPHINXOPTS) $(O)\n\n.PHONY: help Makefile\n\n# Catch-all target: route all unknown targets to Sphinx using the new\n# \"make mode\" option. $(O) is meant as a shortcut for $(SPHINXOPTS).\n%: Makefile\n\t@$(SPHINXBUILD) -M $@ \"$(SOURCEDIR)\" \"$(BUILDDIR)\" $(SPHINXOPTS) $(O)" }, { "path": "doc/Setup.hs", "content": "import Distribution.Simple (defaultMain)\nmain = defaultMain\n" }, { "path": "doc/conf.py", "content": "# -*- coding: utf-8 -*-\n#\n# Configuration file for the Sphinx documentation builder.\n#\n# This file does only contain a selection of the most common options. For a\n# full list see the documentation:\n# http://www.sphinx-doc.org/en/master/config\n\n# -- Path setup --------------------------------------------------------------\n\n# If extensions (or modules to document with autodoc) are in another directory,\n# add these directories to sys.path here. If the directory is relative to the\n# documentation root, use os.path.abspath to make it absolute, like shown here.\n#\n# import os\n# import sys\n# sys.path.insert(0, os.path.abspath('.'))\n\n\n# -- Project information -----------------------------------------------------\n\nproject = 'Finkel'\ncopyright = '2019-2022, 8c6794b6'\nauthor = '8c6794b6'\n\n# The short X.Y version\nversion = ''\n# The full version, including alpha/beta/rc tags\nrelease = ''\n\n\n# -- General configuration ---------------------------------------------------\n\n# If your documentation needs a minimal Sphinx version, state it here.\n#\n# needs_sphinx = '1.0'\n\n# Add any Sphinx extension module names here, as strings. They can be\n# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom\n# ones.\nextensions = [\n]\n\n# Add any paths that contain templates here, relative to this directory.\ntemplates_path = ['_templates']\n\n# The suffix(es) of source filenames.\n# You can specify multiple suffix as a list of string:\n#\n# source_suffix = ['.rst', '.md']\nsource_suffix = '.rst'\n\n# The master toctree document.\nmaster_doc = 'index'\n\n# The language for content autogenerated by Sphinx. Refer to documentation\n# for a list of supported languages.\n#\n# This is also used if you do content translation via gettext catalogs.\n# Usually you set \"language\" from the command line for these cases.\nlanguage = 'en'\n\n# List of patterns, relative to source directory, that match files and\n# directories to ignore when looking for source files.\n# This pattern also affects html_static_path and html_extra_path.\nexclude_patterns = ['_build', 'Thumbs.db', '.DS_Store']\n\n# The name of the Pygments (syntax highlighting) style to use.\n# pygments_style = None\n# pygments_style = 'colorful'\n# pygments_style = 'default'\n# pygments_style = 'emacs'\npygments_style = 'friendly'\n\n\n# -- Options for HTML output -------------------------------------------------\n\n# The theme to use for HTML and HTML Help pages. See the documentation for\n# a list of builtin themes.\n#\nhtml_theme = 'sphinx_rtd_theme'\n# html_theme = 'alabaster'\n# html_theme = 'furo'\n# html_theme = 'sphinx_material'\n# html_theme = 'pydata_sphinx_theme'\n# html_theme = 'sphinx_book_theme'\n# html_theme = 'sphinx_typlog_theme'\n# html_theme = 'insipid'\n\n# Theme options are theme-specific and customize the look and feel of a theme\n# further. For a list of options available for each theme, see the\n# documentation.\n#\nhtml_theme_options = {}\n\n# For 'alabaster' theme\n# html_theme_options = {\n# 'fixed_sidebar': True,\n# 'show_relbars': True,\n# }\n\n# For 'rtd' theme\n# html_theme_options = {\n# 'display_version': True,\n# 'prev_next_buttons_location': 'bottom',\n# 'style_nav_header_background': '#2980b9',\n# }\n\n# For 'sphinx_material' theme\n# html_theme_options = {\n# 'base_url': 'http://finkel.readthedocs.io/',\n# 'repo_url': 'https://github.com/finkel-lang/finkel/',\n# 'repo_name': 'Finkel',\n# # 'google_analytics_account': 'UA-XXXXX',\n# # 'html_minify': True,\n# # 'css_minify': True,\n# # 'nav_title': 'The Finkel Documentation',\n# # 'logo_icon': '',\n# # 'logo_icon': '',\n# 'logo_icon': '',\n# 'globaltoc_depth': 1,\n# 'globaltoc_collapse': True,\n# 'color_primary': 'teal',\n# }\n\n# For furo\n# html_theme_options = {\n# \"light_css_variables\": {\n# \"font-stack\": \"Arial, sans-serif\",\n# \"font-stack--monospace\": \"Courier, monospace\",\n# },\n# }\n\n# Add any paths that contain custom static files (such as style sheets) here,\n# relative to this directory. They are copied after the builtin static files,\n# so a file named \"default.css\" will overwrite the builtin \"default.css\".\nhtml_static_path = ['_static']\n\n# Custom sidebar templates, must be a dictionary that maps document names\n# to template names.\n#\n# The default sidebars (for documents that don't match any pattern) are\n# defined by theme itself. Builtin themes are using these templates by\n# default: ``['localtoc.html', 'relations.html', 'sourcelink.html',\n# 'searchbox.html']``.\n#\n# html_sidebars = {}\n\n# html_sidebars = {\n# \"**\": [\n# \"globaltoc.html\",\n# \"localtoc.html\",\n# \"searchbox.html\",\n# ]\n# }\n\n# For material\n# html_sidebars = {\n# \"**\": [\n# \"logo-text.html\",\n# \"globaltoc.html\",\n# \"localtoc.html\",\n# \"searchbox.html\",\n# ]\n# }\n\n\n\n# -- Options for HTMLHelp output ---------------------------------------------\n\n# Output file base name for HTML help builder.\nhtmlhelp_basename = 'Finkeldoc'\n\n\n# -- Options for LaTeX output ------------------------------------------------\n\nlatex_elements = {\n # The paper size ('letterpaper' or 'a4paper').\n #\n # 'papersize': 'letterpaper',\n\n # The font size ('10pt', '11pt' or '12pt').\n #\n # 'pointsize': '10pt',\n\n # Additional stuff for the LaTeX preamble.\n #\n # 'preamble': '',\n\n # Latex figure (float) alignment\n #\n # 'figure_align': 'htbp',\n}\n\n# Grouping the document tree into LaTeX files. List of tuples\n# (source start file, target name, title,\n# author, documentclass [howto, manual, or own class]).\nlatex_documents = [\n (master_doc, 'Finkel.tex', 'Finkel Documentation',\n '8c6794b6', 'manual'),\n]\n\n\n# -- Options for manual page output ------------------------------------------\n\n# One entry per manual page. List of tuples\n# (source start file, name, description, authors, manual section).\nman_pages = [\n (master_doc, 'finkel', 'Finkel Documentation',\n [author], 1)\n]\n\n\n# -- Options for Texinfo output ----------------------------------------------\n\n# Grouping the document tree into Texinfo files. List of tuples\n# (source start file, target name, title, author,\n# dir menu entry, description, category)\ntexinfo_documents = [\n (master_doc, 'Finkel', 'Finkel Documentation',\n author, 'Finkel', 'Lisp Flavored Haskell',\n 'Miscellaneous'),\n]\n\n\n# -- Options for Epub output -------------------------------------------------\n\n# Bibliographic Dublin Core info.\nepub_title = project\n\n# The unique identifier of the text. This can be a ISBN number\n# or the project homepage.\n#\n# epub_identifier = ''\n\n# A unique identification for the text.\n#\n# epub_uid = ''\n\n# A list of files that should not be packed into the epub file.\nepub_exclude_files = ['search.html']\n\n\n# -- Custom setup function\n\nfrom pygments.lexer import RegexLexer, bygroups\nfrom pygments import token\nfrom pygments.token import Text, Comment, Number, String, Keyword, \\\n Name, Operator, Punctuation\nfrom pygments import unistring as uni\nfrom sphinx.highlighting import lexers\n\nimport re\n\nclass FinkelLexer(RegexLexer):\n name = 'finkel'\n reserved = (\n # Haskell 2010\n 'case', 'class', 'data', 'default', 'deriving', 'do',\n 'family', 'if', 'infix', 'infixl', 'infixr', 'instance', 'let',\n 'newtype', 'type', 'where',\n '_', '=', '=>', '<-', '->', '::',\n\n # Finkel kernel special forms\n ':begin', ':eval-when-compile', ':quote', ':quasiquote',\n ':unquote', ':unquote-splice',\n\n # Finkel core\n 'eval-when', 'macrolet',\n )\n\n ascii = ('NUL', 'SOH', '[SE]TX', 'EOT', 'ENQ', 'ACK',\n 'BEL', 'BS', 'HT', 'LF', 'VT', 'FF', 'CR', 'S[OI]', 'DLE',\n 'DC[1-4]', 'NAK', 'SYN', 'ETB', 'CAN',\n 'EM', 'SUB', 'ESC', '[FGRU]S', 'SP', 'DEL')\n\n tokens = {\n 'root': [\n # Whitespace:\n (r'\\s+', Text),\n\n # Pragma:\n (r'%p\\(.*', token.Comment),\n\n # Comment:\n (r'{-', Comment.Multiline, 'multiline-comment'),\n (r';.*', Comment.Single),\n (r'%_', Comment.Single),\n\n # Numbers\n (r'-?\\d+\\.\\d+', Number.Float),\n (r'-?\\d(_*\\d)*_*[eE][+-]?\\d(_*\\d)*', Number.Float),\n (r'0[oO]_*[0-7](_*[0-7])*', Number.Oct),\n (r'0[xX]_*[\\da-fA-F](_*[\\da-fA-F])*', Number.Hex),\n (r'-?\\d+', Number.Integer),\n\n # Characters:\n (r\"#'\", String.Char, 'character'),\n\n # String literal\n (r'\"', String, 'string'),\n\n # Core macros\n (r\"(defn)(\\s+\\(?)(::)?(\\s+)?([^\\s]+)\",\n bygroups(Keyword.Reserved, Text, Keyword.Reserved,\n Text, Name.Function)),\n\n (r\"(defmacro)(\\s+)([^\\s]+)\",\n bygroups(Keyword.Reserved, Text, Name.Function)),\n\n (r\"(defmodule)(\\s+)([A-Z]\\w+)\",\n bygroups(Keyword.Reserved, Text, Name.Namespace),\n 'defmodule'),\n\n # Module header\n (r\"(module)(\\s+)([^\\s]+)\",\n bygroups(Keyword.Reserved, Text, Name.Namespace)),\n\n # Macro specific keywords\n (r':compile', String),\n (r':load', String),\n\n # Keywords\n ('(%s)' % '|'.join(re.escape(e) + ' ' for e in reserved),\n Keyword.Reserved),\n\n # Import\n (r'(import|:require)(\\s+)(qualified)?(\\s+)?([A-Z][\\w\\.]+)(\\s+)?(as|hiding)?',\n bygroups(Keyword.Reserved,\n Text,\n Keyword.Reserved,\n Text,\n Name.Namespace,\n Text,\n Keyword.Reserved),\n 'funclist'),\n\n # Types\n (r'([A-Z][0-9a-zA-Z\\-_]*)', Keyword.Type),\n\n # Operators\n (r'([!@$%^&*-=+?/<>\\|~]+)', Operator),\n (r'(,@|,)', Operator),\n\n # Variable identifier\n (r'[_a-z][\\w\\']*', Name),\n\n # Lambda\n (r'\\\\', Keyword.Reserved),\n\n # Puctuation\n (r'(\\(|\\))', Punctuation),\n (r'(\\[|\\])', Punctuation),\n (r'(\\{|\\})', Punctuation),\n (r'`', Punctuation),\n (r\"'\", Punctuation),\n ],\n\n 'character': [\n (r\"[^\\\\]\", String.Char, '#pop'),\n (r\"\\\\\", String.Escape, 'escape'),\n (r\" \", String.Char, '#pop'),\n ],\n\n 'string': [\n (r'[^\\\\\"]+', String),\n (r\"\\\\\", String.Escape, 'escape'),\n ('\"', String, '#pop'),\n ],\n\n 'escape': [\n (r'[abfnrtv\"\\'&\\\\]', String.Escape, '#pop'),\n (r'\\^[][' + uni.Lu + r'@^_]', String.Escape, '#pop'),\n ('|'.join(ascii), String.Escape, '#pop'),\n (r'o[0-7]+', String.Escape, '#pop'),\n (r'x[\\da-fA-F]+', String.Escape, '#pop'),\n (r'\\d+', String.Escape, '#pop'),\n (r'\\s+\\\\', String.Escape, '#pop'),\n (r'', String.Escape, '#pop'),\n ],\n\n 'defmodule': [\n (r'\\s+', Text),\n (r'export', Keyword.Reserved, 'funclist'),\n (r'(import-when)(\\s+)(\\[)(:compile|:load)+(\\])(\\s+)',\n bygroups(Keyword.Reserved, Text, Punctuation,\n String, Punctuation, Text),\n 'import-body'),\n (r'import', Keyword.Reserved, 'import-body'),\n (r'require', Keyword.Reserved, 'import-body'),\n (r'\\(', Punctuation, '#push'),\n (r'\\)', Punctuation, '#pop'),\n (r'', Text, '#pop'),\n ],\n\n 'import-body': [\n (r'\\s+', Text),\n (r'(as|hiding)', Keyword.Reserved),\n (r'[A-Za-z_.]+', Name.Namespace, 'funclist'),\n (r'\\(', Punctuation, '#push'),\n (r'\\)', Punctuation, '#pop'),\n (r'', Text, '#pop'),\n ],\n\n 'funclist': [\n (r'\\s+', Text),\n (r'(_[\\w\\']+|[' + uni.Ll + r'][\\w\\'-]*)', Name.Function),\n (r'\\(', Punctuation, '#push'),\n (r'\\)', Punctuation, '#pop'),\n (r'', Text, '#pop'),\n ],\n\n 'multiline-comment': [\n (r'{-', Comment.Multiline, '#push'),\n (r'-}', Comment.Multiline, '#pop'),\n (r'[^-}]+', Comment.Multiline),\n (r'[-}]', Comment.Multiline),\n ]\n }\n\ndef setup(sphinx):\n sphinx.add_lexer(\"finkel\", FinkelLexer)\n" }, { "path": "doc/contents/building-package.rst", "content": "Building Cabal Package\n======================\n\nTo build a cabal package with Finkel, make a cabal configuration file as in the\nHaskell cabal package, but with some build tool and package dependencies.\n\n.. note::\n\n This documentation assumes the readers are using the `stack\n `_ build tool for\n building cabal packages. Those who prefer other tools such as\n `cabal-install `_\n may translate the invoked commands and modify the file contents as\n necessary.\n\n\nBuilding My First Package\n-------------------------\n\nMake a directory named ``my-first-package``, and create a file named\n``package.yaml`` under the directory with following\ncontents:\n\n.. literalinclude:: ../include/building-package/my-first-package/package.yaml\n :language: yaml\n\nAnd a simple ``Setup.hs`` script:\n\n.. literalinclude:: ../include/building-package/my-first-package/Setup.hs\n :language: haskell\n\nAnd a Finkel source code ``src/MyFirstPackage.hs`` for exposed\nmodule:\n\n.. literalinclude:: ../include/building-package/my-first-package/src/MyFirstPackage.hs\n :language: finkel\n\nAnd a ``stack.yaml``:\n\n.. literalinclude:: ../include/building-package/my-first-package/stack.template.yaml\n :language: yaml\n\nAt this point the files under the ``my-first-project`` directory\nshould look like below:\n\n::\n\n my-first-package\n ├── package.yaml\n ├── Setup.hs\n ├── src\n │ └── MyFirstPackage.hs\n └── stack.yaml\n\nNow one can build the ``my-first-package`` package with ``stack``:\n\n.. code-block:: console\n\n $ stack build my-first-package\n ... Output messages omitted ...\n [1 of 2] Compiling Main\n [2 of 2] Compiling StacksetupShim\n ... More output messages ...\n [1 of 1] Compiling MyFirstPackage\n\n.. tip::\n\n To build a package containing Finkel source codes with the latest\n ``finkel`` built from source, one can specify the packages from\n `finkel git repository `_ as\n extra dependencies.\n\n For example, the following ``stack.yaml`` is set to build a package\n in the current directory with ``finkel`` from the git repository:\n\n .. literalinclude:: ../include/building-package/my-first-package/stack.git.yaml\n :language: yaml\n\n See the `stack documentation\n `_\n and the `Cabal User Guide\n `_\n for more information about using remote git repository for extra\n dependencies.\n\n\nMixing Finkel And Haskell Source Codes\n--------------------------------------\n\nOne can mix Finkel source codes and Haskell source codes in a package.\nThis time, making a package ``my-second-package`` with ``stack new``\ncommand using Finkel specific template:\n\n.. code-block:: console\n\n $ stack new my-second-package https://raw.githubusercontent.com/finkel-lang/finkel/master/finkel-tool/finkel.hsfiles\n\n.. warning::\n\n At the time of writing, one may encounter messages similar to the\n following when running ``stack new`` with the above template:\n\n .. code-block:: console\n\n Selecting the best among 17 snapshots...\n\n * Partially matches lts-15.7\n finkel-setup not found\n - my-second-pkg requires -any\n\n * Partially matches nightly-2020-03-04\n finkel-setup not found\n - my-second-pkg requires -any\n\n ...\n\n Selected resolver: lts-15.7\n Resolver 'lts-15.7' does not have all the packages to match your requirements.\n finkel-setup not found\n - my-second-pkg requires -any\n\n This may be resolved by:\n - Using '--omit-packages' to exclude mismatching package(s).\n - Using '--resolver' to specify a matching snapshot/resolver\n\n This is because the packages for ``finkel`` is not yet uploaded to\n `stackage `_.\n\n As the message indicates, one can pass ``--omit-packages`` option\n or ``--resolver`` option to ``stack new`` until the ``finkel``\n dependency packages are uploaded to the upstream, and add the git\n repository to ``stack.yaml``.\n\nThe above command will make a directory named ``my-second-package``\nwith a cabal configuration file, ``Setup.hs`` script, and a stub\nFinkel source code file. Directory contents of ``my-second-package``\nshould look like below:\n\n::\n\n my-second-package\n ├── app\n │ └── Main.hs\n ├── LICENSE\n ├── my-second-package.cabal\n ├── README.md\n ├── Setup.hs\n ├── src\n │ └── Lib.hs\n └── test\n └── Spec.hs\n\n\nAdd a new file named ``my-second-package/src/FnkCodes.hs``, with\nFinkel source codes:\n\n.. literalinclude:: ../include/building-package/my-second-package/src/FnkCodes.hs\n :language: finkel\n\nAnd another new file named ``my-second-package/src/HsCodes.hs``, with\nHaskell source codes:\n\n.. literalinclude:: ../include/building-package/my-second-package/src/HsCodes.hs\n :language: haskell\n\nModify the ``library`` stanza of the file ``my-second-package.cabal``\nand add ``HsCodes`` and ``FnkCodes`` modules as shown below:\n\n.. literalinclude:: ../include/building-package/my-second-package/my-second-package.cabal\n :lines: 22-29\n\nThe functions exported from ``HsCodes`` module could be used from\n``Lib`` module, as in compilation of cabal package without Finkel\ncodes. Modify the file ``my-second-package/src/Lib.hs`` to import\n``hsfactorial`` and ``fnkfactorial`` functions from ``HsCodes``:\n\n.. literalinclude:: ../include/building-package/my-second-package/src/Lib.hs\n :language: finkel\n\nOne can build the ``my-second-package`` with ``stack build`` command, as\nbefore:\n\n.. code-block:: console\n\n $ stack build my-second-package\n\n.. note::\n\n It is also possible to use a library package containing Finkel code\n from other Haskell packages as a build dependency since the\n resulting object codes are compiled by compatible ``ghc`` version.\n\n\nExecutable, Test, Coverage, And Haddock\n---------------------------------------\n\nThe ``my-second-package`` cabal package contains an executable named\n``my-second-package``. The executable simply invokes the\n``Lib.someFunc`` function. To compile and run the executable:\n\n.. code-block:: console\n\n $ stack run my-second-package:my-second-package\n From `Lib.someFunc':\n hsfactorial 10 : 3628800\n fnkfactorial 10 : 3628800\n\nTo run tests, invoke ``stack test`` or ``stack build --test``:\n\n.. code-block:: console\n\n $ stack build --test my-second-package\n\nTo generate code coverage report, add ``--coverage`` option when running\ntest:\n\n.. code-block:: console\n\n $ stack build --test --coverage my-second-package\n\nAnd, to generate haddock documentation of the package, add ``--haddock``\noption to ``stack build`` command:\n\n.. code-block:: console\n\n $ stack build --haddock my-second-package\n" }, { "path": "doc/contents/finkel-executable.rst", "content": "Using The Finkel Executable\n===========================\n\nThe ``finkel`` executable from the ``finkel`` package contains\nsub-commands to work with Finkel source codes.\n\n\nCompiling with Finkel Make\n--------------------------\n\nTo compile a Finkel source code file, one can use the ``make``\nsub-command. Open a file named ``hello.hs`` with your favorite editor\nand save the file with the following contents:\n\n.. literalinclude:: ../include/finkel-executable/hello.hs\n :language: finkel\n\nThen invoke ``finkel make`` to compile the file. The command shown in\nthe following line will compile the file as an executable named ``hello``:\n\n.. literalinclude:: ../include/finkel-executable/hello.console\n :language: console\n\nThe ``make`` sub-command understands most of the options for the\n``ghc`` executable ``--make`` mode:\n\n.. literalinclude:: ../include/finkel-executable/hello-prof.console\n :language: console\n\nThe compiled executable understands RTS options:\n\n.. code-block:: console\n\n $ ./hello +RTS -s -p\n Hello, World!\n 56,992 bytes allocated in the heap\n 4,864 bytes copied during GC\n 46,040 bytes maximum residency (1 sample(s))\n 23,592 bytes maximum slop\n 0 MB total memory in use (0 MB lost due to fragmentation)\n\n Tot time (elapsed) Avg pause Max pause\n Gen 0 0 colls, 0 par 0.000s 0.000s 0.0000s 0.0000s\n Gen 1 1 colls, 0 par 0.000s 0.000s 0.0001s 0.0001s\n\n INIT time 0.000s ( 0.000s elapsed)\n MUT time 0.000s ( 0.000s elapsed)\n GC time 0.000s ( 0.000s elapsed)\n RP time 0.000s ( 0.000s elapsed)\n PROF time 0.000s ( 0.000s elapsed)\n EXIT time 0.000s ( 0.000s elapsed)\n Total time 0.000s ( 0.001s elapsed)\n\n %GC time 0.0% (0.0% elapsed)\n\n Alloc rate 0 bytes per MUT second\n\n Productivity 100.0% of total user, 22.7% of total elapsed\n\n\nRunning REPL\n------------\n\nFrom shell\n^^^^^^^^^^\n\nThe ``finkel`` executable has ``repl`` sub-command to run an interactive\n*read-eval-print-loop* (a.k.a. REPL). To start a REPL from a shell,\ninvoke ``finkel repl``:\n\n.. code-block:: console\n\n $ finkel repl\n Hit `Ctrl-d' or type ,q to quit, type ,? for help.\n > (+ 41 1)\n 42\n > ,type foldr\n foldr :: Foldable t => (a -> b -> b) -> b -> t a -> b\n > ,info Rational\n type Rational = GHC.Real.Ratio Integer -- Defined in ‘GHC.Real’\n > ,load hello.hs\n [1 of 1] Compiling Main ( hello.hs, interpreted )\n ; loaded hello.hs\n > main\n Hello, World!\n > ,q\n\n\nFrom Emacs\n^^^^^^^^^^\n\nThere is a major mode named ``finkel-mode`` for the `Emacs\n`_ editor, with functionality to\nrun an interactive REPL session from Emacs. See the README file in\nthe `finkel-mode repository\n`_ for more\ndetails.\n\n\nGetting More Help\n-----------------\n\nThe ``finkel`` executable contains a ``help`` sub-command to show\nbrief usages of available commands:\n\n.. literalinclude:: ../include/finkel-executable/finkel-help-make.console\n :language: console\n" }, { "path": "doc/contents/install.rst", "content": "Building And Installing\n=======================\n\n.. note::\n\n At the time of writing, Finkel related packages are not yet uploaded to\n `hackage `_ and `stackage\n `_.\n\n\nContainer Image\n---------------\n\nThere is a container image with the ``finkel`` executable built from the latest\nsource code with accompanying Haskell libraries and some development tools. The\nmain use case of the container image is to play with ``finkel`` without setting\nup a working Haskell environment. For instance, one can run ``finkel`` with\n``docker`` by followings:\n\n.. code-block:: console\n\n $ docker pull ghcr.io/finkel-lang/finkel:latest\n $ docker run --rm -it ghcr.io/finkel-lang/finkel:latest\n / # finkel eval '(putStrLn \"Hello, Finkel!\")'\n Hello, Finkel!\n\nSee the `GitHub package page\n`_ for\nmore info.\n\n\nBuilding From Source\n--------------------\n\nGetting The Latest Source\n^^^^^^^^^^^^^^^^^^^^^^^^^\n\nClone the Finkel repository with ``git``:\n\n.. code-block:: console\n\n $ git clone https://github.com/finkel-lang/finkel.git\n\n\nBuilding With ``stack``\n^^^^^^^^^^^^^^^^^^^^^^^\n\nOne can use ``stack`` to build the packages. To build and test with\n``stack``:\n\n.. code-block:: console\n\n $ cd finkel\n $ stack build --test\n\nAnd to install the ``finkel`` executable:\n\n.. code-block:: console\n\n $ stack build --copy-bins finkel\n\n\nBuilding With ``cabal-install``\n^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n\n.. note::\n\n As of ``cabal-install`` version 3.4.0.0, installing with ``cabal\n v2-install`` does not work. This is `a known issue\n `_ related to the\n file extension used by Finkel. To install with ``cabal-install``,\n use the ``cabal v1-install`` command or the ``setup`` executable\n built under the ``dist-newstyle`` directory.\n\nTo build and test with ``cabal-install``:\n\n.. code-block:: console\n\n $ cd finkel\n $ cabal v2-build all\n $ cabal v2-test all\n\n\nBuilding With ``nix``\n^^^^^^^^^^^^^^^^^^^^^\n\nThe git repository contains ``default.nix`` file. Building and testing with `nix\n`_ could be done with:\n\n.. code-block:: console\n\n $ nix-build\n" }, { "path": "doc/contents/language-syntax.rst", "content": "Language Syntax\n===============\n\nThe Finkel language is made from Finkel kernel keywords and Finkel\ncore keywords.\n\nThe Finkel kernel keywords are designed to be compatible with `Haskell\n2010 `_, with few\nexceptions. The syntax for literal values and function applications\nare also defined in the Finkel kernel. The rest of this section will\ngo through the Finkel kernel language syntax with small example\ncodes. Each Finkel code is compared to an equivalent Haskell code.\n\nThe Finkel core keywords are implemented as macros. Details of the\nFinkel core keywords are described in the `haddock API documentation\n`_ of the ``finkel-core`` package.\n\n\nLiterals\n--------\n\nComments\n^^^^^^^^\n\nLine contents after ``;`` are treated as comments.\n\n.. literalinclude:: ../include/language-syntax/expr/line-comment.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/line-comment.hs\n :language: haskell\n\nBlock style comment is supported with ``{-`` and ``-}``.\n\n.. literalinclude:: ../include/language-syntax/expr/block-comment.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/block-comment.hs\n :language: haskell\n\nForm after ``%_`` is ignored:\n\n.. literalinclude:: ../include/language-syntax/expr/discard-prefix.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/discard-prefix.hs\n :language: haskell\n\n\nVariable identifier\n^^^^^^^^^^^^^^^^^^^\n\nFinkel accepts valid variable identifiers defined in Haskell 2010, and\nvariable identifiers containing hyphens which starting with a\nnon-operator character. Hyphens in variable identifiers are internally\nconverted to underscores. For instance, ``foo-bar-buzz`` will be\nconverted to ``foo_bar_buzz``:\n\n.. literalinclude:: ../include/language-syntax/expr/varid.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/varid.hs\n :language: haskell\n\nThe hyphen conversion will be triggered only when the first letter of a\nvariable identifier was a non-operator character. Operators like\n``-:-``, ``*+-``, ``$-$``, etc are kept as-is.\n\n\nNumeric\n^^^^^^^\n\nAs described in the `Numeric Literals\n`_\nsection of the Haskell 2010 report, decimal, octal, hexadecimal\nintegers and float with exponent are supported.\n\n.. literalinclude:: ../include/language-syntax/expr/numeric.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/numeric.hs\n :language: haskell\n\n\nCharacter And String\n^^^^^^^^^^^^^^^^^^^^\n\nA character literal in Finkel starts with ``#'`` instead of\nsurrounding with single quotes. Other than that, Finkel mostly follows\nthe `Characters and String Literals\n`_\nsection in the Haskell 2010 report.\n\nFollowing code prints single lower case character ``a``:\n\n.. literalinclude:: ../include/language-syntax/expr/char-a.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/char-a.hs\n :language: haskell\n\nFollowing code prints backslash and single quote:\n\n.. literalinclude:: ../include/language-syntax/expr/char-escape.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/char-escape.hs\n :language: haskell\n\nSome characters like newline, space, NUL, etc. are expressed with\nescape character and specific character sequences.\n\n.. literalinclude:: ../include/language-syntax/expr/char-special.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/char-special.hs\n :language: haskell\n\nCharacters could be expressed with their numeric code in decimal, octal,\nand hexadecimal:\n\n.. literalinclude:: ../include/language-syntax/expr/char-ncode.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/char-ncode.hs\n :language: haskell\n\nString literals are written between double-quotes. Special characters are\nescaped with ``\\``. Finkel also supports the **gap** feature, to ignore the\nstring contents between two backslashes.\n\n.. literalinclude:: ../include/language-syntax/expr/string.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/string.hs\n :language: haskell\n\n\nExpressions\n-----------\n\nFunction Applications\n^^^^^^^^^^^^^^^^^^^^^\n\nFunction application in Finkel is done with parentheses:\n\n.. literalinclude:: ../include/language-syntax/expr/funapp.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/funapp.hs\n :language: haskell\n\nUnlike some other lisps, extra parentheses are ignored. For instance:\n\n.. literalinclude:: ../include/language-syntax/expr/funapp-pars.fnk\n :language: finkel\n\nis simplified to:\n\n.. literalinclude:: ../include/language-syntax/expr/funapp-pars.hs\n :language: haskell\n\n\nOperator Applications\n^^^^^^^^^^^^^^^^^^^^^\n\nFinkel does not have native support for infix operator\napplications. However, a form applying operator function will be\nexpanded to a form taking all of its arguments, with two operands for\neach. For example, adding numbers from 1 to 5 could be written as:\n\n.. literalinclude:: ../include/language-syntax/expr/opexp-add.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/opexp-add.hs\n :language: haskell\n\nOperator expansion understands right and left associativity. Operator\nprecedence in Finkel is explicitly specified with parentheses.\n\n.. literalinclude:: ../include/language-syntax/expr/opexp-app.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/opexp-app.hs\n :language: haskell\n\nThe compiler treats the above expression as:\n\n.. code-block:: haskell\n\n ((pure foldr <*> Just (+)) <*> pure 1) <*> pure [2, 3] -- Haskell\n\nbecause the ``<*>`` operator is left-associative.\n\nWhen a single argument has been passed to operator function, the resulting\nexpression is partial application:\n\n.. literalinclude:: ../include/language-syntax/expr/map-mul2.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/map-mul2.hs\n :language: haskell\n\nTo apply more than two arguments to an operator function, one needs to\nexplicitly surround the operator with parenthesis. Suppose that there\nis an operator function ``*+`` which takes three arguments:\n\n.. literalinclude:: ../include/language-syntax/expr/muladd.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/muladd.hs\n :language: haskell\n\n\nUnary Operator Application\n^^^^^^^^^^^^^^^^^^^^^^^^^^\n\nThe operator ``-`` is always treated as a binary operator in\nFinkel. In below Finkel example, ``(- 1)`` is a partially applied\nfunction:\n\n.. literalinclude:: ../include/language-syntax/expr/map-unary.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/map-unary.hs\n :language: haskell\n\n\nLambda\n^^^^^^\n\nLambda expression starts with ``\\``. The last form in the lambda expression the\nbody expression of entire lambda abstraction, others forms are argument\npatterns:\n\n.. literalinclude:: ../include/language-syntax/expr/lambda.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/lambda.hs\n :language: haskell\n\n\nConditionals\n^^^^^^^^^^^^\n\nAn ``if`` expression does not take ``then`` and ``else``:\n\n.. literalinclude:: ../include/language-syntax/expr/if.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/if.hs\n :language: haskell\n\nA guard starts with ``|``, and supports pattern, local declaration,\nand boolean:\n\n.. literalinclude:: ../include/language-syntax/expr/guard.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/guard.hs\n :language: haskell\n\nSee also `cond `_ in ``finkel-core``.\n\n\nTuples\n^^^^^^\n\nTuple constructor expression uses single comma. At least one space\nafter the comma is required:\n\n.. literalinclude:: ../include/language-syntax/expr/tup2.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/tup2.hs\n :language: haskell\n\nSingle comma works for tuples with more than two elements:\n\n.. literalinclude:: ../include/language-syntax/expr/tup5.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/tup5.hs\n :language: haskell\n\nTo express tuple data and type constructor, use consecutive commas\nwithout spaces:\n\n.. literalinclude:: ../include/language-syntax/expr/tupfn.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/tupfn.hs\n :language: haskell\n\n\nUnit\n^^^^\n\nUnit is expressed with empty parentheses:\n\n.. literalinclude:: ../include/language-syntax/expr/unit.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/unit.hs\n :language: haskell\n\nSee also `nil `_ to express an empty form.\n\n\nLists\n^^^^^\n\nList expression does not take commas:\n\n.. literalinclude:: ../include/language-syntax/expr/list-const.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/list-const.hs\n :language: haskell\n\nArithmetic sequences use ``..``. Space on each side of ``..`` are\nrequired:\n\n.. literalinclude:: ../include/language-syntax/expr/list-range.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/list-range.hs\n :language: haskell\n\nList comprehensions use ``|`` to separate the resulting expression.\nSpace between ``|`` and the result is required.\n\n.. literalinclude:: ../include/language-syntax/expr/list-comp.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/list-comp.hs\n :language: haskell\n\n\nLet\n^^^\n\nA let expression is expressed with ``let`` without ``in``:\n\n.. literalinclude:: ../include/language-syntax/expr/let.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/let.hs\n :language: haskell\n\n\nCase\n^^^^\n\nA case expression is expressed with ``case`` without ``of`` and ``->``:\n\n.. literalinclude:: ../include/language-syntax/expr/case.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/case.hs\n :language: haskell\n\n\nDo\n^^^\n\nDo expression is expressed with ``do``, and bindings inside do-expressions are\nexpressed with ``<-``:\n\n.. literalinclude:: ../include/language-syntax/expr/do.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/do.hs\n :language: haskell\n\n\nDatatypes with field labels\n^^^^^^^^^^^^^^^^^^^^^^^^^^^\n\nField labels are enclosed with ``{`` and ``}``:\n\n.. literalinclude:: ../include/language-syntax/expr/fieldlabels.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/fieldlabels.hs\n :language: haskell\n\n\nExpression Type-Signatures\n^^^^^^^^^^^^^^^^^^^^^^^^^^\n\nType signature uses ``::``:\n\n.. literalinclude:: ../include/language-syntax/expr/sige.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/sige.hs\n :language: haskell\n\n\nPattern Matching\n^^^^^^^^^^^^^^^^\n\nA non-variable pattern requires parentheses, as in ``Just`` shown\nbelow:\n\n.. literalinclude:: ../include/language-syntax/expr/pat-maybe.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/pat-maybe.hs\n :language: haskell\n\n\nAs pattern\n\"\"\"\"\"\"\"\"\"\"\n\nAs pattern uses ``@``:\n\n.. literalinclude:: ../include/language-syntax/expr/pat-as.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/pat-as.hs\n :language: haskell\n\n\nIrrefutable pattern\n\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\n\nIrrefutable patterns are expressed with ``~``:\n\n.. literalinclude:: ../include/language-syntax/expr/pat-irf.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/pat-irf.hs\n :language: haskell\n\n\nOperator expansion\n\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\n\nThe Operator expansion rule applies to patterns. For instance, the\n``:`` constructor for a list is expanded with its pattern arguments:\n\n.. literalinclude:: ../include/language-syntax/expr/pat-opexp.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/expr/pat-opexp.hs\n :language: haskell\n\n\nDeclarations And Bindings\n-------------------------\n\nAlgebraic Datatype\n^^^^^^^^^^^^^^^^^^\n\nAlgebraic datatype declaration uses ``data``. It does not use ``=``\nand ``|``. Optional ``deriving`` form may appear at the last element\nof the ``data`` form:\n\n.. literalinclude:: ../include/language-syntax/decl/data-d1.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/data-d1.hs\n :language: haskell\n\nConstructor with labeled fields are supported with ``{`` and ``}``:\n\n.. literalinclude:: ../include/language-syntax/decl/data-d2.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/data-d2.hs\n :language: haskell\n\n\nType Synonym\n^^^^^^^^^^^^\n\nType synonym declaration uses ``type``. It does not use ``=``:\n\n.. literalinclude:: ../include/language-syntax/decl/tysym.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/tysym.hs\n :language: haskell\n\n\nDatatype Renamings\n^^^^^^^^^^^^^^^^^^\n\nNewtype declaration uses ``newtype``:\n\n.. literalinclude:: ../include/language-syntax/decl/newtype.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/newtype.hs\n :language: haskell\n\n\nClass\n^^^^^\n\nType class declaration uses ``class``:\n\n.. literalinclude:: ../include/language-syntax/decl/class.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/class.hs\n :language: haskell\n\nClass instance declaration uses ``instance``:\n\n.. literalinclude:: ../include/language-syntax/decl/instance.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/instance.hs\n :language: haskell\n\n\nDefaults for Overloaded Numeric Operations\n^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n\nDefault declaration is done with ``default``:\n\n.. literalinclude:: ../include/language-syntax/decl/default.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/default.hs\n :language: haskell\n\n\nType Signatures\n^^^^^^^^^^^^^^^\n\nType signature uses ``::``:\n\n.. literalinclude:: ../include/language-syntax/decl/tysig-one.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/tysig-one.hs\n :language: haskell\n\nSingle type signature could be used for multiple variables:\n\n.. literalinclude:: ../include/language-syntax/decl/tysig-many.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/tysig-many.hs\n :language: haskell\n\nConstraints in type signature are expressed with ``=>``. The last\nelement of the form ``=>`` should be a type:\n\n.. literalinclude:: ../include/language-syntax/decl/tysig-constraints.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/tysig-constraints.hs\n :language: haskell\n\n\nFixity\n^^^^^^\n\nIt is possible to declare fixity and precedence with ``infix``, ``infixl``, and\n``infixr``. Assuming ``$+$`` as a binary operator:\n\n.. literalinclude:: ../include/language-syntax/decl/fixity.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/fixity.hs\n :language: haskell\n\nNote that Finkel syntax is affected by the left and right\nassociativity of operators, but not by the precedence of operators.\n\n\nBindings\n^^^^^^^^\n\nFunction binding declaration uses ``=``. The form after ``=`` is the\nfunction name, the last form is the expression body. Rest of the forms\nare argument patterns:\n\n.. literalinclude:: ../include/language-syntax/decl/bind-simpl.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/bind-simpl.hs\n :language: haskell\n\nKeyword ``where`` can appear in the right-hand side:\n\n.. literalinclude:: ../include/language-syntax/decl/bind-where.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/bind-where.hs\n :language: haskell\n\nPattern bindings are similarly done with ``=``:\n\n.. literalinclude:: ../include/language-syntax/decl/bind-pat.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/decl/bind-pat.hs\n :language: haskell\n\n\nModules\n-------\n\nTop-level module definition does not use ``where``:\n\n.. literalinclude:: ../include/language-syntax/module/simpl.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/module/simpl.hs\n :language: haskell\n\nSee also `defmodule `_ in\n``finkel-core``.\n\n\nExport Lists\n^^^^^^^^^^^^\n\nModule definition can contain an explicit export list. Entities in the\nexport list can contain bindings, type and data constructors, type\nclasses, and modules:\n\n.. literalinclude:: ../include/language-syntax/module/export-list.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/module/export-list.hs\n :language: haskell\n\n\nImport Declarations\n^^^^^^^^^^^^^^^^^^^\n\nModule import declarations use ``import``:\n\n.. literalinclude:: ../include/language-syntax/import/simpl.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/import/simpl.hs\n :language: haskell\n\nQualified import declarations use ``qualified`` and optional ``as``:\n\n.. literalinclude:: ../include/language-syntax/import/qualified-as.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/import/qualified-as.hs\n :language: haskell\n\nEntity lists use list:\n\n.. literalinclude:: ../include/language-syntax/import/entity-list.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/import/entity-list.hs\n :language: haskell\n\nHiding specified entities with ``hiding``. Form after ``hiding`` is a\nlist of entity names to hide:\n\n.. literalinclude:: ../include/language-syntax/import/hiding.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/import/hiding.hs\n :language: haskell\n\nAltogether:\n\n.. literalinclude:: ../include/language-syntax/import/altogether.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/import/altogether.hs\n :language: haskell\n\n\nForeign Function Interfaces\n---------------------------\n\nForeign Import\n^^^^^^^^^^^^^^\n\nForeign import declarations start with ``foreign`` ``import``:\n\n.. literalinclude:: ../include/language-syntax/ffi/import.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/ffi/import.hs\n :language: haskell\n\n\nForeign Export\n^^^^^^^^^^^^^^\n\nForeign export declarations start with ``foreign`` ``export``:\n\n.. literalinclude:: ../include/language-syntax/ffi/export.fnk\n :language: finkel\n\n.. literalinclude:: ../include/language-syntax/ffi/export.hs\n :language: haskell\n\n\nCompiler Pragmas\n----------------\n\nAll pragmas use ``%p(..)`` form.\n\n\nInlining\n^^^^^^^^\n\nPragmas to control inlining of codes use ``INLINE`` and ``NOINLINE``:\n\n.. code-block:: finkel\n\n %p(INLINE foo) ; Finkel\n\n.. code-block:: haskell\n\n {-# INLINE foo #-} -- Haskell\n\nGHC specific phase controls are also supported:\n\n.. code-block:: finkel\n\n %p(INLINE [1] bar) ; Finkel\n %p(NOINLINE [~2] buzz)\n\n.. code-block:: haskell\n\n {-# INLINE [1] bar #-} -- Haskell\n {-# NOINLINE [~2] buzz #-}\n\n\nSpecialization\n^^^^^^^^^^^^^^\n\nPragmas to control specialization of overloaded function use\n``SPECIALIZE``:\n\n.. code-block:: finkel\n\n %p(SPECIALIZE (:: factorial (-> Int Int))) ; Finkel\n\n.. code-block:: haskell\n\n {-# SPECIALIZE factorial :: Int -> Int #-} -- Haskell\n\n\nLanguage extensions\n^^^^^^^^^^^^^^^^^^^\n\nPragma for language extensions use ``LANGUAGE``:\n\n.. code-block:: finkel\n\n %p(LANGUAGE GADTs OverloadedStrings) ; Finkel\n\n.. code-block:: haskell\n\n {-# LANGUAGE GADTs, OverloadedStrings #-} -- Haskell\n\n..\n Overlaps\n ^^^^^^^^\n\n This is GHC specific ...\n\n..\n .. rubric:: Footnotes\n\n .. [#f1] With few exceptions. Perhaps the most notable exception is the\n lack of native infix function support, but has operator\n expansion instead.\n" }, { "path": "doc/contents/macros.rst", "content": "Macros In Finkel\n================\n\nThis section shows how to write and use macros. Macros in Finkel are\nsimilar to macros in Common Lisp and Clojure. Macros in Finkel are\nimplemented as a function taking codes and returning a code.\n\n\nUnderstanding Compilation Phases\n--------------------------------\n\nDuring compilation, the compiler executable parses the contents of the\nsource code. If the parsed code was a list, and the first element of\nthe list was a symbol of known macro name, the rest of the elements in\nthe list will be passed to the macro. Resulting forms will be replaced\nwith the original list form of the macro. This replacement of the code\nwith macro function is often called *macro expansion*. The expanded\nresult will again get expanded until it cannot be expanded anymore.\nDuring macro expansion, the compiler can use predefined functions in\nthe executable. To add functions to use during macro expansion, one\nneeds to explicitly tell so.\n\n\nDefining Macro With ``eval-when`` And ``defmacro``\n--------------------------------------------------\n\nOne way to tell a new macro to the compiler is to define a macro\ninside ``eval-when (compile)``. The ``eval-when`` is a macro that\nspecifies the phase of declaration in its body form. The phase\n``compile`` will evaluate the contents while compiling the parsed\nsource code.\n\nOpen a new file and save following contents to a file named\n``eval-when.fnk``:\n\n.. literalinclude:: ../include/macros/eval-when.fnk\n :language: finkel\n\nIn the above example, ``(import-when [:compile] (Finkel.Prelude))`` is\nadded in the ``defmodule`` to import functions and data types for\nwriting while compiling the ``Main`` module.\n\nThe ``eval-when`` macro can take multiple forms. Two forms are passed\nto ``eval-when`` in the above example, one to define a macro named\n``say-hello`` , and another to define a macro named ``say-bye``.\n\nThe ``say-hello`` macro takes no argument, and the body of the macro\nsimply returns a quoted form with a single quote (i.e. ``'``).\nSimilarly, the ``say-bye`` macro takes no argument and returns a form\nto prints out a message.\n\nThe ``main`` function contains the ``say-hello`` and ``say-bye``\nmacros. Unlike functions, macros taking no arguments need to be\nsurrounded by parentheses.\n\nOne can run the compiler with the ``-ddump-parsed`` option to observe\nthe parsed Haskell representation:\n\n.. literalinclude:: ../include/macros/eval-when.console\n :language: console\n\n\nDefining Macro With ``macrolet``\n--------------------------------\n\nOne can add a temporary macro with the ``macrolet`` macro. Following\n``macrolet.fnk`` example do similar work done in the previous example,\nbut using ``macrolet`` instead of ``eval-when`` and ``defmacro``.\n\n.. literalinclude:: ../include/macros/macrolet.fnk\n :language: finkel\n\nNote that single ``macrolet`` form can define multiple temporary\nmacros.\n\n.. literalinclude:: ../include/macros/macrolet.console\n :language: console\n\n\nLoading Macros With ``require``\n-------------------------------\n\nAnother way to add macros to the current module is to ``require`` a\nmodule containing macros. Open a file named ``RequireMe.fnk`` and save\nthe following code:\n\n.. literalinclude:: ../include/macros/RequireMe.fnk\n :language: finkel\n\nNote that the ``RequireMe`` module has the ``import`` of\n``Finkel.Prelude`` inside ``defmodule``. This is because the macros\ndefined in ``RequireMe`` are not for itself, but other modules.\n\nNext, open and edit another file named ``require.fnk`` to require the\n``RequireMe`` module:\n\n.. literalinclude:: ../include/macros/require.fnk\n :language: finkel\n\nCompilation output:\n\n.. literalinclude:: ../include/macros/require.console\n :language: console\n\nUnlike the previous two examples, one needs to generate an object code\nof the ``RequireMe`` module so that the macro functions defined in\n``RequireMe`` could be used in the file ``require.fnk``.\n\n.. note::\n\n As of finkel version 0.1, one may need to add ``-dynamic-too`` option to the\n ``finkel`` executable when compiling a source code file containing\n ``require``.\n\n\nQuasiquote, Unquote, And Unquote-Splice\n---------------------------------------\n\nMacro can *unquote* and *unquote-splice* a form inside\n*quasiquote*.\n\nOpen a new file named ``unquote.fnk`` and save the following contents:\n\n.. literalinclude:: ../include/macros/unquote.fnk\n :language: finkel\n\nThe example defines two macros: ``uq1`` and ``uq2``. Both macros use\n````` (back-tick) instead of ``'`` (single quote) in body expression.\n\nIn ``uq1``, the macro argument ``arg`` is unquoted with ``,``, and the\nunquoted form is passed as the second argument of ``++`` function. In\n``uq2`` the expression ``(++ \"uq2: arg = \" (show arg))`` is unquoted\nwith ``,``.\n\nObserving parsed result with ``-ddump-parsed``:\n\n.. literalinclude:: ../include/macros/unquote.console\n :language: console\n\nParsed Haskell representation shows ``++`` in the expanded form of\n``uq1`` macro. Expanded result of ``uq2`` evaluates ``++`` at the time\nof macro expansion, so the resulting form of ``uq2`` is a literal\n``String``.\n\nInside the quasi-quoted form, ``,@`` is used to unquote-splice a list\nform. The ``,@`` can unquote-splice a quoted list and a Haskell list.\n\n.. literalinclude:: ../include/macros/unquote-splice.fnk\n :language: finkel\n\nObserving parsed Haskell code:\n\n.. literalinclude:: ../include/macros/unquote-splice.console\n :language: console\n\n\nGetting Macro Arguments As A List\n---------------------------------\n\nMacro can take its entire argument as a list form. Below example codes\nshow a macro which takes entire arguments passed to it as a list named\n``args``:\n\n.. literalinclude:: ../include/macros/arglist.fnk\n :language: finkel\n\nParsed Haskell code:\n\n.. literalinclude:: ../include/macros/arglist.console\n :language: console\n\n\nGetting Values From Macro Arguments\n-----------------------------------\n\nOne can obtain Haskell values from arguments passed to macro:\n\n.. literalinclude:: ../include/macros/fib-macro.fnk\n :language: finkel\n\nThe above example applies the ``fromCode`` function to the macro\nargument to get an ``Int`` value from the code object. To return the\ncode object, the ``fib-macro`` applies ``toCode`` to the ``Int`` value\nevaluated by the ``fib`` function. Note that the ``fib`` function\nneeds to be defined inside ``eval-when`` so that ``fib-macro`` can use\nthe function during macro expansion.\n\nSample compilation output:\n\n.. literalinclude:: ../include/macros/fib-macro.console\n :language: console\n\n\nSpecial forms\n-------------\n\nThe Finkel core keywords are implemented as macros made from Finkel\nkernel. Details of Finkel core keywords are described in the `haddock\nAPI documentation `_ of the\n``finkel-core`` package.\n\nThis section explains built-in macros in the Finkel kernel\nlanguage. These built-in macros are sometimes called *special\nforms*. All special forms start with ``:``, followed by lower case\nalphabetic character, to avoid name conflict with existing Haskell\nfunctions.\n\n\n:begin\n^^^^^^\n\nThe ``:begin`` special form is basically for writing a macro returning\nmultiple top-level declarations. Following code shows an example use\nof ``:begin``, to return type synonym declarations from the\n``nat-types`` macro:\n\n.. literalinclude:: ../include/macros/begin.fnk\n :language: finkel\n\nObserving parsed Haskell code:\n\n.. literalinclude:: ../include/macros/begin.console\n :language: console\n\n\n:eval-when-compile\n^^^^^^^^^^^^^^^^^^\n\nThe ``:eval-when-compile`` special form is used to implement\n``eval-when`` macro in the core language. Basically,\n``(:eval-when-compile BODY1 BODY2 ...)`` is the same as ``(eval-when\n(compile) BODY1 BODY2 ...)``.\n\nThe following code shows sample use of ``:eval-when-compile``. The\nfunction ``wrap-actions`` is defined inside ``:eval-when-compile``, so\nthat later the compiler can use the function in the ``doactions``\nmacro.\n\n.. literalinclude:: ../include/macros/eval-when-compile.fnk\n :language: finkel\n\nParsed Haskell code:\n\n.. literalinclude:: ../include/macros/eval-when-compile.console\n :language: console\n\n\n:quote\n^^^^^^\n\nThe ``:quote`` special form is used for quoting the given value as a\ncode object. The ``'`` is syntax sugar of this special\nform. Internally, quoted values are passed to functions exported from\nthe ``finkel-kernel`` package.\n\nFollowing code shows how underlying Finkel kernel functions are\napplied to literal values in source code:\n\n.. literalinclude:: ../include/macros/quote.fnk\n :language: finkel\n\nParsed Haskell source:\n\n.. literalinclude:: ../include/macros/quote.console\n :language: console\n\n\n:quasiquote\n^^^^^^^^^^^\n\nThe ``:quasiquote`` is the underlying special form for the `````\nsyntax sugar. Inside a quasi-quoted form, ``:unquote`` and\n``:unquote-splice`` could be used for getting the value from the\ncode. Indeed, ``,`` is a syntax sugar of ``:unquote``, and ``,@`` is a\nsyntax sugar of ``:unquote-splice``.\n\n.. literalinclude:: ../include/macros/quasiquote.fnk\n :language: finkel\n\nAbove example prints ``True``:\n\n.. literalinclude:: ../include/macros/quasiquote.console\n :language: console\n\n\n:require\n^^^^^^^^\n\nThe ``:require`` is for adding a module to the compiler during macro\nexpansion. It also adds macros defined in the required module to the\ncurrent compiler environment. This special form is used by the\n``defmodule`` macro.\n\n.. literalinclude:: ../include/macros/raw-require.fnk\n :language: finkel\n\nParsed Haskell code:\n\n.. literalinclude:: ../include/macros/raw-require.console\n :language: console\n\n\n:with-macro\n^^^^^^^^^^^\n\nThe ``:with-macro`` is the underlying special form for ``macrolet``\nmacro. This special form is perhaps not useful unless one wants to\nwrite an alternative implementation of the ``macrolet`` macro. See the\nsource code of ``Finkel.Core`` module for usage.\n" }, { "path": "doc/doc.cabal", "content": "cabal-version: 2.0\nname: doc\nversion: 0.0.0\nsynopsis: Internal test for Finkel documentation\nlicense: BSD3\nlicense-file: LICENSE\nauthor: 8c6794b6\nmaintainer: 8c6794b6@gmail.com\ncopyright: 2020-2022 8c6794b6\ncategory: Language\nbuild-type: Simple\n\ndescription:\n Internal package to test the codes in the Finkel documentation.\n\nflag dynamic\n description: Dynamically link executables (except Windows)\n default: True\n manual: True\n\ntest-suite test\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Spec.hs\n other-modules: Doc\n Doc.TestAux\n Doc.FinkelExecutable\n Doc.BuildingPackage\n Doc.Macros\n Doc.LanguageSyntax\n build-depends: base >= 4.14 && < 5\n , directory >= 1.3 && < 1.4\n , filepath >= 1.4 && < 1.6\n , ghc >= 8.10.0 && < 9.11\n , process >= 1.6 && < 1.7\n , hspec >= 2.4.8 && < 2.12\n , QuickCheck >= 2.10.1 && < 2.16\n --\n , finkel-core == 0.0.0\n , finkel-kernel == 0.0.0\n build-tool-depends: finkel:finkel == 0.0.0\n , fnkpp:fnkpp == 0.0.0\n default-language: Haskell2010\n\n ghc-options: -Wall -threaded -rtsopts\n\n -- Skipping the whole test under Windows, since it's too slow.\n if os(windows)\n buildable: False\n else\n if flag(dynamic)\n ghc-options: -dynamic\n\n build-tool-depends: fnkpp:fnkpp == 0.0.0\n ghc-options: -F -pgmF fnkpp -optF --no-warn-interp\n -fplugin Finkel.Core.Plugin\n if impl (ghc >= 9.6)\n ghc-options: -keep-hscpp-files\n\nsource-repository head\n type: git\n location: https://github.com/finkel-lang/doc.git\n subdir: doc\n" }, { "path": "doc/include/building-package/my-first-package/Setup.hs", "content": "-- File: my-first-package/Setup.hs\nimport Distribution.Simple (defaultMain)\nmain = defaultMain\n" }, { "path": "doc/include/building-package/my-first-package/my-first-package.cabal", "content": "cabal-version: 1.12\n\n-- This file has been generated from package.yaml by hpack version 0.36.0.\n--\n-- see: https://github.com/sol/hpack\n--\n-- hash: 5f8c819490edb2e9673637f8df651684d12bbc5294a98b1a63b820025e8792cd\n\nname: my-first-package\nversion: 0.1.0.0\nbuild-type: Simple\n\nlibrary\n exposed-modules:\n MyFirstPackage\n other-modules:\n Paths_my_first_package\n hs-source-dirs:\n src\n ghc-options: -F -pgmF fnkpp -optF --no-warn-interp -fplugin Finkel.Core.Plugin\n build-tool-depends:\n fnkpp:fnkpp\n build-depends:\n base\n , finkel-core\n default-language: Haskell2010\n" }, { "path": "doc/include/building-package/my-first-package/package.yaml", "content": "# File: my-first-package/package.yaml\n\nname: my-first-package\nversion: 0.1.0.0\n\nlibrary:\n source-dirs: src\n exposed-modules: MyFirstPackage\n ghc-options:\n - -F -pgmF fnkpp -optF --no-warn-interp\n - -fplugin Finkel.Core.Plugin\n build-tools:\n - fnkpp:fnkpp\n dependencies:\n - base\n - finkel-core\n" }, { "path": "doc/include/building-package/my-first-package/src/MyFirstPackage.hs", "content": ";;;; File: my-first-package/src/MyFirstPackage.hs\n\n(defmodule MyFirstPackage\n (export factorial))\n\n(defn (:: factorial (-> Integer Integer))\n \"Compute factorial of the given number.\n\nThis function does not support negative numbers. If the argument was\nnegative, constantly returns @-1@.\n\n==== __Example__\n\n>>> (factorial 10)\n3628800\n>>> (factorial -42)\n1\n\"\n [n]\n (if (<= n 1)\n 1\n (* n (factorial (- n 1)))))\n" }, { "path": "doc/include/building-package/my-first-package/stack.git.yaml", "content": "resolver: lts-22.31\npackages:\n - .\nextra-deps:\n - git: https://github.com/finkel-lang/finkel\n commit: f7913be75db03beec66b9a029c538c95cdbb05a8\n subdirs:\n - finkel-kernel\n - fkc\n - finkel-setup\n - finkel-core\n - finkel-tool\n - finkel\n" }, { "path": "doc/include/building-package/my-first-package/stack.template.yaml", "content": "resolver: lts-22.31\npackages:\n - .\n" }, { "path": "doc/include/building-package/my-new-package/LICENSE", "content": "Copyright Author name here (c) 2024\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "doc/include/building-package/my-new-package/README.md", "content": "# my-new-package\n" }, { "path": "doc/include/building-package/my-new-package/Setup.hs", "content": "import Distribution.Simple (defaultMain)\nmain = defaultMain\n" }, { "path": "doc/include/building-package/my-new-package/app/Main.hs", "content": "module Main where\n\nimport Lib\n\nmain :: IO ()\nmain = someFunc\n" }, { "path": "doc/include/building-package/my-new-package/my-new-package.cabal", "content": "cabal-version: 3.0\nname: my-new-package\nversion: 0.1.0.0\n-- synopsis:\n-- description:\nhomepage: http://www.example.org\nlicense: BSD-3-Clause\nlicense-file: LICENSE\nauthor: Author name here\nmaintainer: example@example.com\ncopyright: 2024 Author name here\ncategory: Data\nbuild-type: Simple\nextra-source-files: README.md\n\ncommon finkel\n build-depends: finkel-core\n build-tool-depends: fnkpp:fnkpp\n ghc-options: -F -pgmF fnkpp -optF --no-warn-interp\n -fplugin Finkel.Core.Plugin\n\nlibrary\n import: finkel\n hs-source-dirs: src\n exposed-modules: Lib\n build-depends: base >= 4.7 && < 5\n default-language: Haskell2010\n\nexecutable my-new-package\n hs-source-dirs: app\n main-is: Main.hs\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n build-depends: base\n , my-new-package\n default-language: Haskell2010\n\ntest-suite my-new-package-test\n import: finkel\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Spec.hs\n build-depends: base\n , my-new-package\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n default-language: Haskell2010\n\n-- source-repository head\n-- type: git\n-- location: https://github.com/githubuser/my-new-package\n" }, { "path": "doc/include/building-package/my-new-package/src/Lib.hs", "content": ";;; -*- mode: finkel -*-\n(defmodule Lib\n (export someFunc))\n\n(defn (:: someFunc (IO ()))\n (putStrLn \"Hello from my-new-package\"))\n" }, { "path": "doc/include/building-package/my-new-package/stack.yaml", "content": "# This file was automatically generated by 'stack init'\n#\n# Some commonly used options have been documented as comments in this file.\n# For advanced use and comprehensive documentation of the format, please see:\n# https://docs.haskellstack.org/en/stable/yaml_configuration/\n\n# A warning or info to be displayed to the user on config load.\nuser-message: |\n 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.\n You can omit this message by removing it from stack.yaml\n\n# Resolver to choose a 'specific' stackage snapshot or a compiler version.\n# A snapshot resolver dictates the compiler version and the set of packages\n# to be used for project dependencies. For example:\n#\n# resolver: lts-3.5\n# resolver: nightly-2015-09-21\n# resolver: ghc-7.10.2\n#\n# The location of a snapshot can be provided as a file or url. Stack assumes\n# a snapshot provided as a file might change, whereas a url resource does not.\n#\n# resolver: ./custom-snapshot.yaml\n# resolver: https://example.com/snapshots/2018-01-01.yaml\nresolver: lts-22.31\n\n# User packages to be built.\n# Various formats can be used as shown in the example below.\n#\n# packages:\n# - some-directory\n# - https://example.com/foo/bar/baz-0.0.2.tar.gz\n# subdirs:\n# - auto-update\n# - wai\npackages: []\n# The following packages have been ignored due to incompatibility with the\n# resolver compiler, dependency conflicts with other packages\n# or unsatisfied dependencies.\n#- .\n\n# Dependency packages to be pulled from upstream that are not in the resolver.\n# These entries can reference officially published versions as well as\n# forks / in-progress versions pinned to a git hash. For example:\n#\n# extra-deps:\n# - acme-missiles-0.3\n# - git: https://github.com/commercialhaskell/stack.git\n# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a\n#\n# extra-deps: []\n\n# Override default flag values for local packages and extra-deps\n# flags: {}\n\n# Extra package databases containing global packages\n# extra-package-dbs: []\n\n# Control whether we use the GHC we find on the path\n# system-ghc: true\n#\n# Require a specific version of stack, using version ranges\n# require-stack-version: -any # Default\n# require-stack-version: \">=2.3\"\n#\n# Override the architecture used by stack, especially useful on Windows\n# arch: i386\n# arch: x86_64\n#\n# Extra directories used by stack for building\n# extra-include-dirs: [/path/to/dir]\n# extra-lib-dirs: [/path/to/dir]\n#\n# Allow a newer minor version of GHC than the snapshot specifies\n# compiler-check: newer-minor\n" }, { "path": "doc/include/building-package/my-new-package/test/Spec.hs", "content": "main :: IO ()\nmain = putStrLn \"Test suite not yet implemented\"\n" }, { "path": "doc/include/building-package/my-second-package/LICENSE", "content": "Copyright Author name here (c) 2019\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of Author name here nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "doc/include/building-package/my-second-package/README.md", "content": "# my-second-package\n" }, { "path": "doc/include/building-package/my-second-package/Setup.hs", "content": "import Distribution.Simple (defaultMain)\nmain = defaultMain\n" }, { "path": "doc/include/building-package/my-second-package/app/Main.hs", "content": "module Main where\n\nimport Lib\n\nmain :: IO ()\nmain = someFunc\n" }, { "path": "doc/include/building-package/my-second-package/my-second-package.cabal", "content": "cabal-version: 3.0\nname: my-second-package\nversion: 0.1.0.0\n-- synopsis:\n-- description:\nhomepage: http://www.example.org\nlicense: BSD-3-Clause\nlicense-file: LICENSE\nauthor: Author name here\nmaintainer: example@example.com\ncopyright: 2019 Author name here\ncategory: Data\nbuild-type: Simple\nextra-source-files: README.md\n\ncommon finkel\n build-depends: finkel-core\n build-tool-depends: fnkpp:fnkpp\n ghc-options: -F -pgmF fnkpp -optF --no-warn-interp\n -fplugin Finkel.Core.Plugin\n\nlibrary\n import: finkel\n hs-source-dirs: src\n exposed-modules: Lib\n HsCodes\n FnkCodes\n build-depends: base >= 4.7 && < 5\n default-language: Haskell2010\n\nexecutable my-second-package\n hs-source-dirs: app\n main-is: Main.hs\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n build-depends: base\n , my-second-package\n default-language: Haskell2010\n\ntest-suite my-second-package-test\n import: finkel\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Spec.hs\n other-modules: FactorialTest\n build-depends: base\n , my-second-package\n build-tool-depends: fnkpp:fnkpp\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n default-language: Haskell2010\n\n-- source-repository head\n-- type: git\n-- location: https://github.com/githubuser/my-second-package\n" }, { "path": "doc/include/building-package/my-second-package/src/FnkCodes.hs", "content": ";;;; File: my-second-package/src/FnkCodes.hs\n\n(defmodule FnkCodes\n (export fnkfactorial))\n\n(defn (:: fnkfactorial (-> Int Int))\n [n]\n (if (<= n 1)\n n\n (* n (fnkfactorial (- n 1)))))\n" }, { "path": "doc/include/building-package/my-second-package/src/HsCodes.hs", "content": "-- File: my-second-package/src/HsCodes.hs\n\nmodule HsCodes\n ( hsfactorial\n , fnkfactorial\n ) where\n\nimport FnkCodes\n\nhsfactorial :: Int -> Int\nhsfactorial = fnkfactorial\n" }, { "path": "doc/include/building-package/my-second-package/src/Lib.hs", "content": ";;;; File: my-second-package/src/Lib.hs\n\n(defmodule Lib\n (export someFunc)\n (import (HsCodes [hsfactorial fnkfactorial])))\n\n(defn (:: someFunc (IO ()))\n (putStrLn\n (++ \"From `Lib.someFunc':\\n\"\n \" hsfactorial 10 : \" (show (hsfactorial 10)) \"\\n\"\n \" fnkfactorial 10 : \" (show (fnkfactorial 10)))))\n" }, { "path": "doc/include/building-package/my-second-package/test/FactorialTest.hs", "content": ";;;; File: FactorialTest.hs\n\n(defmodule FactorialTest\n (export test)\n (import\n (HsCodes)\n (System.Exit (exitFailure))))\n\n(defn (:: test (IO ()))\n (if (== (fnkfactorial 10) (hsfactorial 10))\n (return ())\n exitFailure))\n" }, { "path": "doc/include/building-package/my-second-package/test/Spec.hs", "content": "import FactorialTest\n\nmain :: IO ()\nmain = test\n" }, { "path": "doc/include/finkel-executable/finkel-help-make.console", "content": "$ finkel help make\nUSAGE: finkel make [command-line-options-and-files]\n\nHELP OPTIONS:\n\n --fnk-help Show this help and exit.\n --fnk-languages Show supported language extensions and exit.\n --fnk-version Show Finkel version and exit.\n\nDEBUG OPTIONS:\n\n --fnk-verbose=INT Set verbosity level to INT.\n --fnk-hsdir=DIR Set Haskell code output directory to DIR.\n --fnk-dump-dflags Dump DynFlags settings.\n --fnk-dump-expand Dump expanded code.\n --fnk-dump-hs Dump Haskell source code.\n --fnk-dump-session Dump session information.\n --fnk-trace-expand Trace macro expansion.\n --fnk-trace-session Trace session env.\n --fnk-trace-make Trace make function.\n --fnk-trace-spf Trace builtin special forms.\n\n Other options are passed to ghc.\n\n" }, { "path": "doc/include/finkel-executable/hello-prof.console", "content": "$ finkel make -o hello -fforce-recomp -prof -fprof-auto hello.fnk\n[1 of 1] Compiling Main ( hello.hs, hello.o )\nLinking hello ...\n" }, { "path": "doc/include/finkel-executable/hello.console", "content": "$ finkel make -o hello hello.hs\n[1 of 1] Compiling Main ( hello.hs, hello.o )\nLinking hello ...\n$ ./hello\nHello, World!\n" }, { "path": "doc/include/finkel-executable/hello.hs", "content": ";;;; File: hello.hs\n\n(defn main\n (putStrLn \"Hello, World!\"))\n" }, { "path": "doc/include/finkel-executable/hello904.console", "content": "$ finkel make -o hello hello.hs\n[1 of 2] Compiling Main ( hello.hs, hello.o )\n[2 of 2] Linking hello\n$ ./hello\nHello, World!\n" }, { "path": "doc/include/language-syntax/decl/bind-pat.fnk", "content": "(= (Just x) (lookup k vs)) ; Finkel\n" }, { "path": "doc/include/language-syntax/decl/bind-pat.hs", "content": "Just x = lookup k vs -- Haskell\n" }, { "path": "doc/include/language-syntax/decl/bind-simpl.fnk", "content": "(= f1 x y z (+ x (* y z))) ; Finkel\n" }, { "path": "doc/include/language-syntax/decl/bind-simpl.hs", "content": "f1 x y z = x + (y * z) -- Haskell\n" }, { "path": "doc/include/language-syntax/decl/bind-where.fnk", "content": "(= f2 n ; Finkel\n (where body\n (= body (+ n 1))))\n" }, { "path": "doc/include/language-syntax/decl/bind-where.hs", "content": "f2 n = body -- Haskell\n where\n body = n + 1\n" }, { "path": "doc/include/language-syntax/decl/class.fnk", "content": "(class (=> (Ord a) (C1 a)) ; Finkel\n (:: m1 (-> a Int))\n (= m1 _ 0))\n" }, { "path": "doc/include/language-syntax/decl/class.hs", "content": "class Ord a => C1 a where -- Haskell\n m1 :: a -> Int\n m1 _ = 0\n" }, { "path": "doc/include/language-syntax/decl/data-d1.fnk", "content": "(data (D1 a b) ; Finkel\n C1\n (C2 a)\n (C3 b)\n (deriving Eq Show))\n" }, { "path": "doc/include/language-syntax/decl/data-d1.hs", "content": "data D1 a b -- Haskell\n = C1\n | C2 a\n | C3 b\n deriving (Eq, Show)\n" }, { "path": "doc/include/language-syntax/decl/data-d2.fnk", "content": "(data (D2 a b) ; Finkel\n (D2 {(:: f1 a)\n (:: f2 b)\n (:: f3 Int)}))\n" }, { "path": "doc/include/language-syntax/decl/data-d2.hs", "content": "data D2 a b -- Haskell\n = D2 { f1 :: a\n , f2 :: b\n , f3 :: Int }\n" }, { "path": "doc/include/language-syntax/decl/default.fnk", "content": "(default Int Double) ; Finkel\n" }, { "path": "doc/include/language-syntax/decl/default.hs", "content": "default (Int, Double) -- Haskell\n" }, { "path": "doc/include/language-syntax/decl/fixity.fnk", "content": "(infixr 6 $+$)\n" }, { "path": "doc/include/language-syntax/decl/fixity.hs", "content": "infixr 6 $+$\n" }, { "path": "doc/include/language-syntax/decl/instance.fnk", "content": "(instance (C1 Int) ; Finkel\n (= m1 n (+ n 1)))\n" }, { "path": "doc/include/language-syntax/decl/instance.hs", "content": "instance C1 Int where -- Haskell\n m1 n = n + 1\n" }, { "path": "doc/include/language-syntax/decl/newtype.fnk", "content": "(newtype N (N {(:: unN Int)})) ; Finkel\n" }, { "path": "doc/include/language-syntax/decl/newtype.hs", "content": "newtype N = N {unN :: Int} -- Haskell\n" }, { "path": "doc/include/language-syntax/decl/tysig-constraints.fnk", "content": "(:: f (=> (Eq a) (Ord a) (Show a) (Num a) (-> a a))) ; Finkel\n" }, { "path": "doc/include/language-syntax/decl/tysig-constraints.hs", "content": "f :: (Eq a, Ord a, Show a, Num a) => a -> a -- Haskell\n" }, { "path": "doc/include/language-syntax/decl/tysig-many.fnk", "content": "(:: f g h (-> Int Int)) ; Finkel\n" }, { "path": "doc/include/language-syntax/decl/tysig-many.hs", "content": "f, g, h :: Int -> Int -- Haskell\n" }, { "path": "doc/include/language-syntax/decl/tysig-one.fnk", "content": "(:: f (-> Int Int Int)) ; Finkel\n" }, { "path": "doc/include/language-syntax/decl/tysig-one.hs", "content": "f :: Int -> Int -> Int -- Haskell\n" }, { "path": "doc/include/language-syntax/decl/tysym.fnk", "content": "(type (T1 a) (Maybe (, a Bool String))) ; Finkel\n" }, { "path": "doc/include/language-syntax/decl/tysym.hs", "content": "type T1 a = Maybe (a, Bool, String) -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/block-comment.fnk", "content": "(putStrLn {- Finkel block comment -} \"bar\")\n" }, { "path": "doc/include/language-syntax/expr/block-comment.hs", "content": "putStrLn {- Haskell block comment -} \"bar\"\n" }, { "path": "doc/include/language-syntax/expr/case.fnk", "content": "(case n ; Finkel\n 0 \"zero\"\n 1 \"one\"\n _ \"many\")\n" }, { "path": "doc/include/language-syntax/expr/case.hs", "content": "case n of -- Haskell\n 0 -> \"zero\"\n 1 -> \"one\"\n _ -> \"many\"\n" }, { "path": "doc/include/language-syntax/expr/char-a.fnk", "content": "(putChar #'a) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/char-a.hs", "content": "putChar 'a' -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/char-escape.fnk", "content": "(print [#'\\ #'']) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/char-escape.hs", "content": "print ['\\\\', '\\''] -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/char-ncode.fnk", "content": "(print [#'\\97 #'\\o141 #'\\x61]) ; Finkel, prints \"aaa\"\n" }, { "path": "doc/include/language-syntax/expr/char-ncode.hs", "content": "print ['\\97', '\\o141', '\\x61'] -- Haskell, prints \"aaa\"\n" }, { "path": "doc/include/language-syntax/expr/char-special.fnk", "content": "(print [#'\\n #' #'\\NUL #'\\^L]) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/char-special.hs", "content": "print ['\\n', ' ', '\\NUL', '\\^L'] -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/discard-prefix.fnk", "content": "(do (print True) ; Finkel\n %_(this list (is ignored))\n (print %_ignored False %_ \"ignored\"))\n" }, { "path": "doc/include/language-syntax/expr/discard-prefix.hs", "content": "do print True -- Haskell, ignored forms removed\n print False\n" }, { "path": "doc/include/language-syntax/expr/do.fnk", "content": "(do (putStr \"x: \") ; Finkel\n (<- l getLine)\n (return (words l)))\n" }, { "path": "doc/include/language-syntax/expr/do.hs", "content": "do putStr \"x: \" -- Haskell\n l <- getLine\n return (words l)\n" }, { "path": "doc/include/language-syntax/expr/fieldlabels.fnk", "content": "(Constr1 {(= field1 1) (= field2 True) (= field3 \"abc\")}) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/fieldlabels.hs", "content": "Constr1 {field1=1, field2=True, field3=\"abc\"} -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/funapp-pars.fnk", "content": "(((((putStrLn)) \"hello\"))) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/funapp-pars.hs", "content": "putStrLn \"hello\" -- Haskell, redundant parentheses removed\n" }, { "path": "doc/include/language-syntax/expr/funapp.fnk", "content": "(putStrLn \"hello\") ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/funapp.hs", "content": "putStrLn \"hello\" -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/guard.fnk", "content": "(case expr ; Finkel\n (Just y) (| ((even y) r1)\n ((odd y) (< y 10) r2)\n ((<- (Just z) (lookup y kvs))\n (let ((= z' (* z 2))))\n (r3 z'))\n (otherwise r4)))\n" }, { "path": "doc/include/language-syntax/expr/guard.hs", "content": "case expr of -- Haskell\n Just y | even y -> r1\n | odd y, y < 10 -> r2\n | Just z <- lookup y kvs\n , let z' = z * 2\n -> r3 z'\n | otherwise -> r4\n" }, { "path": "doc/include/language-syntax/expr/if.fnk", "content": "(if test true-expr false-expr) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/if.hs", "content": "if test then true_expr else false_expr -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/lambda.fnk", "content": "(zipWith (\\x y (* x (+ y 1))) [1 2 3] [4 5 6]) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/lambda.hs", "content": "zipWith (\\x y -> x * (y + 1)) [1, 2, 3] [4, 5, 6] -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/let.fnk", "content": "(let ((:: a Int) ; Finkel\n (:: b c Int)\n (= a 10)\n (= b 4)\n (= c 2))\n (print [a b c]))\n" }, { "path": "doc/include/language-syntax/expr/let.hs", "content": "let a :: Int -- Haskell\n b, c :: Int\n a = 10\n b = 4\n c = 2\nin print [a, b, c]\n" }, { "path": "doc/include/language-syntax/expr/line-comment.fnk", "content": "(putStrLn \"foo\") ; single-line comment in Finkel\n" }, { "path": "doc/include/language-syntax/expr/line-comment.hs", "content": "putStrLn \"foo\" -- single-line comment in Haskell\n" }, { "path": "doc/include/language-syntax/expr/list-comp.fnk", "content": "[x | (<- x [1 .. 10]) (even x)] ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/list-comp.hs", "content": "[x | x <- [1 .. 10], even x] -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/list-const.fnk", "content": "(print [1 2 3]) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/list-const.hs", "content": "print [1, 2, 3] -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/list-range.fnk", "content": "(print [1 3 .. 9]) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/list-range.hs", "content": "print [1, 3 .. 9] -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/map-mul2.fnk", "content": "(map (* 2) [1 2 3]) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/map-mul2.hs", "content": "map ((*) 2) [1, 2, 3] -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/map-unary.fnk", "content": "(map (- 1) [1 2 3]) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/map-unary.hs", "content": "map ((-) 1) [1, 2, 3] -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/muladd.fnk", "content": "((*+) 2 3 4) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/muladd.hs", "content": "(*+) 2 3 4 -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/numeric.fnk", "content": "(do (print 1) ; decimal integer in Finkel\n (print 0o77) ; octal integer\n (print 0xff) ; hexadecimal integer\n (print 2.34) ; float\n (print 1e-2)) ; float with exponent\n" }, { "path": "doc/include/language-syntax/expr/numeric.hs", "content": "do print 1 -- decimal integer in Haskell\n print 0o77 -- octal integer\n print 0xff -- hexadecimal integer\n print 2.34 -- float\n print 1e-2 -- float with exponent\n" }, { "path": "doc/include/language-syntax/expr/opexp-add.fnk", "content": "(+ 1 2 3 4 5) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/opexp-add.hs", "content": "1 + 2 + 3 + 4 + 5 -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/opexp-app.fnk", "content": "(<*> (pure foldr) (Just +) (pure 1) (pure [2 3])) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/opexp-app.hs", "content": "pure foldr <*> Just (+) <*> pure 1 <*> pure [2, 3] -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/pat-as.fnk", "content": "(let ((= (@ x (Just n)) expr)) ; Finkel\n (+ n 1))\n" }, { "path": "doc/include/language-syntax/expr/pat-as.hs", "content": "let x@(Just n) = expr -- Haskell\nin n + 1\n" }, { "path": "doc/include/language-syntax/expr/pat-irf.fnk", "content": "(let ((= ~(, a ~(, b c)) expr)) ; Finkel\n (+ a (* b c)))\n" }, { "path": "doc/include/language-syntax/expr/pat-irf.hs", "content": "let ~(a, ~(b, c)) = expr -- Haskell\nin a + (b * c)\n" }, { "path": "doc/include/language-syntax/expr/pat-maybe.fnk", "content": "(case expr ; Finkel\n (Just x) (+ x 1)\n Nothing 0)\n" }, { "path": "doc/include/language-syntax/expr/pat-maybe.hs", "content": "case expr of -- Haskell\n Just x -> x + 1\n Nothing -> 0\n" }, { "path": "doc/include/language-syntax/expr/pat-opexp.fnk", "content": "(case expr ; Finkel\n (: a1 a2 _) (+ a1 a2)\n _ 0)\n" }, { "path": "doc/include/language-syntax/expr/pat-opexp.hs", "content": "case expr of -- Haskell\n a1 : a2 : _ -> a1 + a2\n _ -> 0\n" }, { "path": "doc/include/language-syntax/expr/sige.fnk", "content": "(:: 42 Int) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/sige.hs", "content": "(42 :: Int) -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/string.fnk", "content": "\"Here is a backslant \\\\ as well as \\137, \\\n \\a numeric escape character, and \\^X, a control character.\" ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/string.hs", "content": "\"Here is a backslant \\\\ as well as \\137, \\\n \\a numeric escape character, and \\^X, a control character.\" -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/tup2.fnk", "content": "(print (, True #'x)) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/tup2.hs", "content": "print (True, 'x') -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/tup5.fnk", "content": "(print (, True #'x 42 1.23 \"foo\")) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/tup5.hs", "content": "print (True, 'x', 42, 1.23, \"foo\") -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/tupfn.fnk", "content": "(<*> (pure (,,,)) (Just 1) (Just 2) (Just 3) (Just 4)) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/tupfn.hs", "content": "pure (,,,) <*> Just 1 <*> Just 2 <*> Just 3 <*> Just 4 -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/unit.fnk", "content": "(return ()) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/unit.hs", "content": "return () -- Haskell\n" }, { "path": "doc/include/language-syntax/expr/varid.fnk", "content": "(foo-bar-buzz quux) ; Finkel\n" }, { "path": "doc/include/language-syntax/expr/varid.hs", "content": "foo_bar_buzz quux -- Haskell\n" }, { "path": "doc/include/language-syntax/ffi/export.fnk", "content": "(foreign export ccall \"addInt\"\n (:: + (-> Int Int Int)))\n" }, { "path": "doc/include/language-syntax/ffi/export.hs", "content": "foreign export ccall \"addInt\"\n (+) :: Int -> Int -> Int\n" }, { "path": "doc/include/language-syntax/ffi/import.fnk", "content": "(foreign import ccall safe \"string.h strlen\" ; Finkel\n (:: cstrlen (-> (Ptr CChar) (IO CSize))))\n" }, { "path": "doc/include/language-syntax/ffi/import.hs", "content": "foreign import ccall safe \"string.h strlen\" -- Haskell\n cstrlen :: Ptr CChar -> IO CSize\n" }, { "path": "doc/include/language-syntax/import/altogether.fnk", "content": "(import qualified Data.Maybe as Mb hiding (fromJust)) ; Finkel\n" }, { "path": "doc/include/language-syntax/import/altogether.hs", "content": "import qualified Data.Maybe as Mb hiding (fromJust) -- Haskell\n" }, { "path": "doc/include/language-syntax/import/entity-list.fnk", "content": "(import Data.Maybe (catMaybes fromMaybe)) ; Finkel\n" }, { "path": "doc/include/language-syntax/import/entity-list.hs", "content": "import Data.Maybe (catMaybes, fromMaybe) -- Haskell\n" }, { "path": "doc/include/language-syntax/import/hiding.fnk", "content": "(import Data.Maybe hiding (fromJust fromMaybe)) ; Finkel\n" }, { "path": "doc/include/language-syntax/import/hiding.hs", "content": "import Data.Maybe hiding (fromJust, fromMaybe) -- Haskell\n" }, { "path": "doc/include/language-syntax/import/qualified-as.fnk", "content": "(import qualified Data.Maybe as Mb) ; Finkel\n" }, { "path": "doc/include/language-syntax/import/qualified-as.hs", "content": "import qualified Data.Maybe as Mb -- Haskell\n" }, { "path": "doc/include/language-syntax/import/simpl.fnk", "content": "(import Data.Maybe) ; Finkel\n" }, { "path": "doc/include/language-syntax/import/simpl.hs", "content": "import Data.Maybe -- Haskell\n" }, { "path": "doc/include/language-syntax/module/export-list.fnk", "content": "(module M2 ; Finkel\n f1 ; Value, field name, or class method\n T1 ; Type constructor only\n (T2 ..) ; Type constructor and all of its data constructors\n (T3 T3a T3b) ; Type constructor and specified data constructors\n (T4 t4f1) ; Type constructor and field label\n\n (module Data.Char) ; Module reexport\n (Mb.Maybe Just Nothing) ; Reexport with a qualified name\n )\n\n(import Data.Maybe as Mb)\n\n;; ... more module contents ...\n" }, { "path": "doc/include/language-syntax/module/export-list.hs", "content": "module M2 -- Haskell\n ( f1 -- Value, field name, or class method\n , T1 -- Type constructor only\n , T2(..) -- Type constructor and all of its data constructors\n , T3(T3a, T3b) -- Type constructor and specified data constructors\n , T4(t4f1) -- Type constructor and field label\n\n , module Data.Char -- Module reexport\n , Mb.Maybe(Just, Nothing) -- Reexport with a qualified name\n ) where\n\nimport Data.Maybe as Mb\n\n-- ... more module contents ...\n" }, { "path": "doc/include/language-syntax/module/simpl.fnk", "content": "(module M1) ; Finkel\n(= x 1)\n(= y 2)\n" }, { "path": "doc/include/language-syntax/module/simpl.hs", "content": "module M1 where -- Haskell\nx = 1\ny = 2\n" }, { "path": "doc/include/macros/RequireMe.fnk", "content": ";;;; File: RequireMe.fnk\n\n(defmodule RequireMe\n (export say-hello say-bye)\n (import (Finkel.Prelude)))\n\n(defmacro say-hello []\n '(putStrLn \"Hello macro!\"))\n\n(defmacro say-bye []\n '(putStrLn \"Goodbye.\"))\n" }, { "path": "doc/include/macros/arglist.console", "content": "$ finkel make -fno-code -ddump-parsed arglist.fnk\n\n==================== Parser ====================\nmodule Main where\nmain :: IO ()\nmain = putStrLn (unwords [\"foo\", \"bar\", \"buzz\"])\n\n\n[1 of 1] Compiling Main ( arglist.fnk, nothing )\n" }, { "path": "doc/include/macros/arglist.fnk", "content": ";;;; File: arglist.fnk\n\n(defmodule Main\n (import-when [:compile]\n (Finkel.Prelude)))\n\n(eval-when [:compile]\n (defmacro puts args\n `(putStrLn (unwords [,@args]))))\n\n(defn (:: main (IO ()))\n (puts \"foo\" \"bar\" \"buzz\"))\n" }, { "path": "doc/include/macros/begin.console", "content": "$ finkel make -fno-code -ddump-parsed begin.fnk\n\n==================== Parser ====================\nmodule Main where\nimport Data.Proxy\ndata Nat = Zero | Succ Nat\ntype N0 = 'Zero\ntype N1 = 'Succ 'Zero\ntype N2 = 'Succ ('Succ 'Zero)\ntype N3 = 'Succ ('Succ ('Succ 'Zero))\ntype N4 = 'Succ ('Succ ('Succ ('Succ 'Zero)))\ntype N5 = 'Succ ('Succ ('Succ ('Succ ('Succ 'Zero))))\ntype N6 = 'Succ ('Succ ('Succ ('Succ ('Succ ('Succ 'Zero)))))\nmain :: IO ()\nmain = print (Proxy :: Proxy N6)\n\n\n[1 of 1] Compiling Main ( begin.fnk, nothing )\n" }, { "path": "doc/include/macros/begin.fnk", "content": ";;;; File: begin.fnk\n\n%p(LANGUAGE DataKinds)\n\n(defmodule Main\n (import-when [:compile]\n (Finkel.Prelude))\n (import (Data.Proxy)))\n\n(data Nat\n Zero\n (Succ Nat))\n\n(macrolet ((nat-types [n]\n (let ((:: go (-> Int Code Int [Code]))\n (= go stop body i\n (if (< stop i)\n []\n (let ((= name (make-symbol (++ \"N\" (show i))))\n (= next `('Succ ,body)))\n (: `(type ,name ,body)\n (go stop next (+ i 1)))))))\n (case (fromCode n)\n (Just m) `(:begin\n ,@(go m ''Zero 0))\n Nothing (error \"not an integer\")))))\n (nat-types 6))\n\n(defn (:: main (IO ()))\n (print (:: Proxy (Proxy N6))))\n" }, { "path": "doc/include/macros/eval-when-compile.console", "content": "$ finkel make -fno-code -ddump-parsed eval-when-compile.fnk\n\n==================== Parser ====================\nmodule Main where\nfoo :: Int -> IO ()\nfoo n\n = do putStrLn \"from foo\"\n print (n + 1)\nbar :: Int -> Int -> IO ()\nbar a b\n = do putStrLn \"from bar\"\n print (a + (b * 2))\nmain :: IO ()\nmain\n = do foo 41\n bar 10 16\n\n\n[1 of 1] Compiling Main ( eval-when-compile.fnk, nothing )\n" }, { "path": "doc/include/macros/eval-when-compile.fnk", "content": ";;;; File: eval-when-compile.fnk\n\n(defmodule Main\n (import-when [:compile]\n (Finkel.Prelude)))\n\n(:eval-when-compile\n (defn (:: wrap-actions (-> [Code] Code))\n [actions]\n `(do ,@actions)))\n\n(macrolet ((doactions [xs]\n (case (unCode xs)\n (HsList actions) (wrap-actions actions)\n _ (error \"doactions: expecting HsList\"))))\n (defn (:: foo (-> Int (IO ())))\n [n]\n (doactions [(putStrLn \"from foo\")\n (print (+ n 1))]))\n (defn (:: bar (-> Int Int (IO ())))\n [a b]\n (doactions [(putStrLn \"from bar\")\n (print (+ a (* b 2)))])))\n\n(defn (:: main (IO ()))\n (do (foo 41)\n (bar 10 16)))\n" }, { "path": "doc/include/macros/eval-when.console", "content": "$ finkel make -fno-code -ddump-parsed eval-when.fnk\n\n==================== Parser ====================\nmodule Main where\nmain :: IO ()\nmain\n = do putStrLn \";;; eval-when ;;;\"\n putStrLn \"Hello macro!\"\n putStrLn \"Goodbye.\"\n\n\n[1 of 1] Compiling Main ( eval-when.fnk, nothing )\n" }, { "path": "doc/include/macros/eval-when.fnk", "content": ";;; File: eval-when.fnk\n\n(defmodule Main\n (import-when [:compile]\n (Finkel.Prelude)))\n\n(eval-when [:compile]\n (defmacro say-hello []\n '(putStrLn \"Hello macro!\"))\n (defmacro say-bye []\n '(putStrLn \"Goodbye.\")))\n\n(defn (:: main (IO ()))\n (do (putStrLn \";;; eval-when ;;;\")\n (say-hello)\n (say-bye)))\n" }, { "path": "doc/include/macros/fib-macro.console", "content": "$ finkel make -fno-code -ddump-parsed fib-macro.fnk\n\n==================== Parser ====================\nmodule Main where\nmain :: IO ()\nmain = print 55\n\n\n[1 of 1] Compiling Main ( fib-macro.fnk, nothing )\n" }, { "path": "doc/include/macros/fib-macro.fnk", "content": ";;;; File: fib-macro.fnk\n\n(defmodule Main\n (import-when [:compile]\n (Finkel.Prelude)))\n\n(eval-when [:compile]\n (defn (:: fib (-> Int Int))\n [n]\n (if (< n 2)\n n\n (+ (fib (- n 1)) (fib (- n 2)))))\n\n (defmacro fib-macro [n]\n (case (fromCode n)\n (Just i) (toCode (fib i))\n Nothing (error \"fib-macro: not an integer literal\"))))\n\n(defn (:: main (IO ()))\n (print (fib-macro 10)))\n" }, { "path": "doc/include/macros/macrolet.console", "content": "$ finkel make -fno-code -ddump-parsed macrolet.fnk\n\n==================== Parser ====================\nmodule Main where\nmain :: IO ()\nmain\n = do putStrLn \";;; macrolet ;;;\"\n putStrLn \"Hello macro!\"\n putStrLn \"Goodbye.\"\n\n\n[1 of 1] Compiling Main ( macrolet.fnk, nothing )\n" }, { "path": "doc/include/macros/macrolet.fnk", "content": ";;;; File: macrolet.fnk\n\n(defmodule Main\n (import-when [:compile]\n (Finkel.Prelude)))\n\n(macrolet ((say-hello []\n '(putStrLn \"Hello macro!\"))\n (say-bye []\n '(putStrLn \"Goodbye.\")))\n (defn (:: main (IO ()))\n (do (putStrLn \";;; macrolet ;;;\")\n (say-hello)\n (say-bye))))\n" }, { "path": "doc/include/macros/quasiquote.console", "content": "$ finkel make -o quasiquote quasiquote.fnk\n[1 of 1] Compiling Main ( quasiquote.fnk, quasiquote.o )\nLinking quasiquote ...\n$ ./quasiquote\nTrue\n" }, { "path": "doc/include/macros/quasiquote.fnk", "content": ";;;; File: quasiquote.fnk\n\n(defmodule Main\n (import (Finkel.Prelude)))\n\n(defn (:: with-sugar [Code])\n [`(foo ,(length \"123\") bar)\n `(foo ,@[True False] bar)])\n\n(defn (:: without-sugar [Code])\n [(:quasiquote (foo (:unquote (length \"123\")) bar))\n (:quasiquote (foo (:unquote-splice [True False]) bar))])\n\n(defn (:: main (IO ()))\n (print (== with-sugar without-sugar)))\n" }, { "path": "doc/include/macros/quasiquote904.console", "content": "$ finkel make -o quasiquote quasiquote.fnk\n[1 of 2] Compiling Main ( quasiquote.fnk, quasiquote.o )\n[2 of 2] Linking quasiquote\n$ ./quasiquote\nTrue\n" }, { "path": "doc/include/macros/quote.console", "content": "$ finkel make -fno-code -ddump-parsed quote.fnk\n\n==================== Parser ====================\nmodule Main where\nimport Finkel.Prelude\nmain :: IO ()\nmain\n = do putStrLn \";;; quote ;;;\"\n print (qSymbol \"foo\" \"quote.fnk\" 8 15 8 18)\n print (qSymbol \"foo\" \"quote.fnk\" 9 22 9 25)\n print (qInteger 42 \"quote.fnk\" 10 15 10 17)\n print (qInteger 42 \"quote.fnk\" 11 22 11 24)\n print (qString \"string\" \"quote.fnk\" 12 15 12 23)\n print (qString \"string\" \"quote.fnk\" 13 22 13 30)\n\n\n[1 of 1] Compiling Main ( quote.fnk, nothing )\n" }, { "path": "doc/include/macros/quote.fnk", "content": ";;;; File: quote.fnk\n\n(defmodule Main\n (import (Finkel.Prelude)))\n\n(defn (:: main (IO ()))\n (do (putStrLn \";;; quote ;;;\")\n (print 'foo)\n (print (:quote foo))\n (print '42)\n (print (:quote 42))\n (print '\"string\")\n (print (:quote \"string\"))))\n" }, { "path": "doc/include/macros/raw-require.console", "content": "$ finkel make -fno-code -ddump-parsed raw-require.fnk\n\n==================== Parser ====================\nmodule Main where\nmain :: IO ()\nmain\n = do putStrLn \";;; raw-require.fnk ;;;\"\n putStrLn \"Hello macro!\"\n putStrLn \"Goodbye.\"\n\n\n[1 of 1] Compiling Main ( raw-require.fnk, nothing )\n" }, { "path": "doc/include/macros/raw-require.fnk", "content": ";;;; File: raw-require.fnk\n\n(:require Finkel.Prelude)\n\n(defmodule Main)\n\n(eval-when [:compile]\n (defmacro say-hello []\n '(putStrLn \"Hello macro!\"))\n (defmacro say-bye []\n '(putStrLn \"Goodbye.\")))\n\n(defn (:: main (IO ()))\n (do (putStrLn \";;; raw-require.fnk ;;;\")\n (say-hello)\n (say-bye)))\n" }, { "path": "doc/include/macros/require.console", "content": "$ finkel make -no-link -fno-code require.fnk\n(*) [1 of 1] Compiling RequireMe ( RequireMe.fnk, interpreted )\n\n==================== Parser ====================\nmodule Main where\nmain :: IO ()\nmain\n = do putStrLn \";;; require ;;;\"\n putStrLn \"Hello macro!\"\n putStrLn \"Goodbye.\"\n\n\n[1 of 1] Compiling Main ( require.fnk, nothing )\n" }, { "path": "doc/include/macros/require.fnk", "content": ";;;; File: require.fnk\n\n%p(OPTIONS_GHC -ddump-parsed)\n\n(defmodule Main\n (require\n (RequireMe (say-hello say-bye))))\n\n(defn (:: main (IO ()))\n (do (putStrLn \";;; require ;;;\")\n (say-hello)\n (say-bye)))\n" }, { "path": "doc/include/macros/unquote-splice.console", "content": "$ finkel make -fno-code -ddump-parsed unquote-splice.fnk\n\n==================== Parser ====================\nmodule Main where\nmain :: IO ()\nmain\n = do putStrLn (concat [\"foo\", \"bar\", \"buzz\"])\n putStrLn (concat [\"foo\", \"bar\", \"buzz\"])\n\n\n[1 of 1] Compiling Main ( unquote-splice.fnk, nothing )\n" }, { "path": "doc/include/macros/unquote-splice.fnk", "content": ";;;; File: unquote-splice.fnk\n\n(defmodule Main\n (import-when [:compile]\n (Finkel.Prelude)))\n\n(eval-when [:compile]\n (defmacro uqs [arg]\n `(putStrLn (concat [,@arg]))))\n\n(defn (:: main (IO ()))\n (do (uqs (\"foo\" \"bar\" \"buzz\"))\n (uqs [\"foo\" \"bar\" \"buzz\"])))\n" }, { "path": "doc/include/macros/unquote.console", "content": "$ finkel make -fno-code -ddump-parsed unquote.fnk\n\n==================== Parser ====================\nmodule Main where\nmain :: IO ()\nmain\n = do putStrLn (\"uq1: arg = \" ++ show \"foo\")\n putStrLn \"uq2: arg = \\\"bar\\\"\"\n\n\n[1 of 1] Compiling Main ( unquote.fnk, nothing )\n" }, { "path": "doc/include/macros/unquote.fnk", "content": ";;;; File: unquote.fnk\n\n(defmodule Main\n (import-when [:compile]\n (Finkel.Prelude)))\n\n(eval-when [:compile]\n (defmacro uq1 [arg]\n `(putStrLn (++ \"uq1: arg = \" (show ,arg))))\n\n (defmacro uq2 [arg]\n `(putStrLn ,(++ \"uq2: arg = \" (show arg)))))\n\n(defn (:: main (IO ()))\n (do (uq1 \"foo\")\n (uq2 \"bar\")))\n" }, { "path": "doc/index.rst", "content": "The Finkel Documentation\n========================\n\nIntroduction\n------------\n\nFinkel is a statically typed, purely functional,\nand non-strict-by-default `LISP\n`_\nflavored programming language. Or in other words, `Haskell\n`_ **in S-expression**. [#f1]_\n\nFinkel has the following features:\n\n* Integration with existing Haskell modules.\n\n* Building Haskell-compatible `Cabal\n `_ packages.\n\n* Documentation generation with `Haddock\n `_.\n\n* Lisp style macro system.\n\n* Tool executable, including interactive REPL.\n\n..\n And following anti-features:\n\n * CPP language extension\n\nThe capital lettered term Finkel is used to refer to the programming\nlanguage itself, and the quoted ``finkel`` is used to refer an\nexecutable program to work with the language. This documentation\nbriefly introduces the ``finkel`` executable and the language, just\nenough to get started. Readers of this documentation are assumed to\nhave some basic knowledge of the Unix-like environment and have some\nprogramming experiences with Haskell.\n\n\n.. toctree::\n :maxdepth: 2\n :caption: Contents:\n\n contents/install.rst\n contents/finkel-executable.rst\n contents/building-package.rst\n contents/macros.rst\n contents/language-syntax.rst\n\n.. ==================\n Indices and tables\n ==================\n * :ref:`genindex`\n * :ref:`search`\n\n\n.. rubric:: Footnotes\n\n.. [#f1] More precisely, `GHC `_ in\n S-expression.\n" }, { "path": "doc/make.bat", "content": "@ECHO OFF\r\n\r\npushd %~dp0\r\n\r\nREM Command file for Sphinx documentation\r\n\r\nif \"%SPHINXBUILD%\" == \"\" (\r\n\tset SPHINXBUILD=sphinx-build\r\n)\r\nset SOURCEDIR=.\r\nset BUILDDIR=_build\r\n\r\nif \"%1\" == \"\" goto help\r\n\r\n%SPHINXBUILD% >NUL 2>NUL\r\nif errorlevel 9009 (\r\n\techo.\r\n\techo.The 'sphinx-build' command was not found. Make sure you have Sphinx\r\n\techo.installed, then set the SPHINXBUILD environment variable to point\r\n\techo.to the full path of the 'sphinx-build' executable. Alternatively you\r\n\techo.may add the Sphinx directory to PATH.\r\n\techo.\r\n\techo.If you don't have Sphinx installed, grab it from\r\n\techo.http://sphinx-doc.org/\r\n\texit /b 1\r\n)\r\n\r\n%SPHINXBUILD% -M %1 %SOURCEDIR% %BUILDDIR% %SPHINXOPTS%\r\ngoto end\r\n\r\n:help\r\n%SPHINXBUILD% -M help %SOURCEDIR% %BUILDDIR% %SPHINXOPTS%\r\n\r\n:end\r\npopd\r\n" }, { "path": "doc/requirements.txt", "content": "sphinx==3.5.3\nsphinx_rtd_theme==0.5.2\n" }, { "path": "doc/test/Doc/BuildingPackage.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Test codes for \"building-package.rst\".\n\n(defmodule Doc.BuildingPackage\n (export spec)\n (import\n ;; base\n (Control.Exception [bracket])\n (Control.Monad [zipWithM_])\n (Data.Char (isSpace))\n (Data.Function [on])\n (Data.List [isPrefixOf sort])\n (System.Exit [(ExitCode ..)])\n (System.Process [(CreateProcess ..) createProcess proc waitForProcess])\n\n ;; directory\n (System.Directory\n [canonicalizePath doesDirectoryExist doesFileExist getTemporaryDirectory\n listDirectory removeDirectoryRecursive])\n\n ;; filepath\n (System.FilePath [ takeExtension takeFileName])\n\n ;; hspec\n (Test.Hspec [(Spec) describe expectationFailure it pendingWith shouldBe])\n\n ;; Internal\n (Doc.TestAux)))\n\n\n;;; Spec\n\n(defn (:: spec Spec)\n (describe \"building cabal package\"\n (it \"matches package made with hsfiles template\"\n (case-do get-build-tool\n Cabal (pendingWith \"not running with cabal-install\")\n Raw (pendingWith \"not running with raw build\")\n Stack compare-new-package))))\n\n\n;;; Auxiliary\n\n(defn (:: compare-new-package (IO ()))\n (bracket make-tmp-dir\n remove-tmp-dir\n compare-package-dirs))\n\n(defn (:: make-tmp-dir (IO (, FilePath String)))\n (fmap (flip (,) \"my-new-package\") getTemporaryDirectory))\n\n(defn (:: remove-tmp-dir (-> (, FilePath String) (IO ())))\n (. removeDirectoryRecursive (uncurry )))\n\n(defn (:: compare-package-dirs (-> (, FilePath String) (IO ())))\n [(, tmpdir pkgname)]\n (case-do (stack-new tmpdir pkgname)\n ;; Ignoring \"stack.yaml\", since the file contains version number of the\n ;; stack executable, which may change when the stack was upgraded.\n ;;\n ;; XXX: This approach will make the tests to pass. However, cannot detect\n ;; the validity of stack.yaml file, so consider taking different way to pass\n ;; the test.\n (Right ExitSuccess) (compare-directory-contents\n [\"stack.yaml\"]\n ( \"include\" \"building-package\" pkgname)\n ( tmpdir pkgname))\n (Right ec) (expectationFailure (++ \"stack new failed with \" (show ec)))\n (Left msg) (expectationFailure msg)))\n\n(defn (:: compare-directory-contents (-> [FilePath] FilePath FilePath (IO ())))\n \"Recursively compare directory contents.\"\n [ignored path1 path2]\n (if (elem (takeFileName path1) ignored)\n (return ())\n (do (<- path1-is-file (doesFileExist path1))\n (<- path2-is-file (doesFileExist path2))\n (if (&& path1-is-file path2-is-file\n (notElem (takeFileName path1) ignored))\n (do (<- contents1 (readFile path1))\n (<- contents2 (readFile path2))\n (on shouldBe trim contents1 contents2))\n (do (<- path1-is-dir (doesDirectoryExist path1))\n (<- path2-is-dir (doesDirectoryExist path2))\n (if (&& path1-is-dir path2-is-dir)\n (do (<- ls1 (list-directory path1))\n (<- ls2 (list-directory path2))\n (lept [add-dir (. map )\n ls1' (add-dir path1 ls1)\n ls2' (add-dir path2 ls2)])\n (zipWithM- (compare-directory-contents ignored)\n ls1' ls2'))\n (expectationFailure\n (++ \"differed: \" path1 \", \" path2))))))))\n\n(defn (:: trim (-> String String))\n \"Trim white spaces at the beginning and end.\"\n (. (dropWhile isSpace) reverse (dropWhile isSpace) reverse))\n\n(defn (:: list-directory (-> FilePath (IO [FilePath])))\n \"List directory contents, filter outs some ignored files.\"\n (lefn [(ignored [path]\n (&& (/= \".stack-work\" path)\n (/= \".tix\" (takeExtension path))))]\n (. (fmap (. sort (filter ignored))) listDirectory)))\n\n(defn (:: stack-new (-> FilePath String (IO (Either String ExitCode))))\n \"Run stack new command to generate new package.\"\n [dir pkgname]\n (do (<- template get-template-path)\n (<- mb-resolver (get-resolver-version pkgname))\n (case mb-resolver\n (Just resolver) (fmap Right\n (run (Just dir)\n \"stack\" [\"--resolver\" resolver \"--silent\"\n \"new\" pkgname\n \"--omit-packages\" template]))\n Nothing (return (Left \"Failed to get the resolver version\")))))\n\n(defn (:: get-template-path (IO FilePath))\n \"Get canonicalized template path.\"\n ;; XXX: May move template to separate repository to support\n ;; `github:finkel-lang/simple' style template argument.\n ;;\n ;; See: https://docs.haskellstack.org/en/stable/GUIDE/#templates\n ;;\n (canonicalizePath ( \"..\" \"finkel-tool\" \"finkel.hsfiles\")))\n\n(defn (:: get-resolver-version (-> String (IO (Maybe String))))\n \"Get stack resolver version from YAML file used in `my-new-package'.\"\n [pkgname]\n (lept [yaml-path ( \"include\" \"building-package\" pkgname \"stack.yaml\")\n resolver-line (. (concatMap words)\n (filter (isPrefixOf \"resolver:\"))\n lines)]\n (case-do (fmap resolver-line (readFile yaml-path))\n [_ version] (return (Just version))\n _ (return Nothing))))\n\n(defn (:: run (-> (Maybe String) String [String] (IO ExitCode)))\n \"Run command and wait.\"\n [mb-dir cmd args]\n (do (<- (, _mbin _mbout _mberr ph)\n (createProcess ((proc cmd args) {(= cwd mb-dir)})))\n (waitForProcess ph)))\n" }, { "path": "doc/test/Doc/FinkelExecutable.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Test codes for \"finkel-executable.rst\".\n\n(defmodule Doc.FinkelExecutable\n (export spec)\n (import\n ;; base\n (Data.Version [makeVersion])\n (System.Info [os])\n\n ;; filepath\n (System.FilePath [])\n\n ;; hspc\n (Test.Hspec [(Spec) before_ describe])\n\n ;; Internal\n (Doc.TestAux)))\n\n(defn (:: spec Spec)\n (lept [dir ( \"include\" \"finkel-executable\")\n const2 (\\ x _ _ x)\n is-osx (== os \"darwin\")\n is-win (== os \"mingw32\")\n ghc904 (makeVersion [9 4 0])\n skips\n [(, \"finkel-help-make.console\" (const2 is-win))\n (, \"hello.console\"\n (\\version _\n (|| is-osx is-win\n (< ghc904 version))))\n (, \"hello904.console\"\n (\\version _\n (|| is-osx is-win\n (< version ghc904))))\n (, \"hello-prof.console\"\n (\\ version _build-tool\n ;; XXX: Always skipping\n (|| is-win\n ;; Skipping in ghc >= 9.0 ...\n (<= (makeVersion [9 0]) version))))]]\n (before_\n (remove-compiled [( dir \"hello\")])\n (describe \"using the finkel executable\"\n (run-console-tests dir skips)))))\n" }, { "path": "doc/test/Doc/LanguageSyntax.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Test codes for \"language-syntax.rst\"\n\n;;; This module contains codes to tests the code snippets shown in the \"Language\n;;; Syntax\" chapter of the documentation. The tests parses expressions and\n;;; declarations from file, and parse the Haskell code and Finkel code, then\n;;; compare the parsed results with `showPpr'.\n\n(defmodule Doc.LanguageSyntax\n (export spec)\n (import-when [:compile]\n ;; finkel-lang\n (Finkel.Prelude))\n (import\n ;; base\n (Data.List [sort])\n\n ;; directory\n (System.Directory [listDirectory])\n\n ;; filepath\n (System.FilePath [ <.> dropExtension takeExtension])\n\n ;; finkel-kernel\n (Language.Finkel.Builder [(Builder) evalBuilder])\n (Language.Finkel.Reader [parseSexprs])\n (qualified Language.Finkel.Syntax as FnkParser)\n\n ;; hspec\n (Test.Hspec [(Spec) (SpecWith) beforeAll describe expectationFailure it runIO\n shouldBe])\n\n ;; Internal\n (Doc.TestAux)))\n\n;; ghc\n\n(import GHC (DynFlags getSessionDynFlags runGhc))\n\n(cond-expand\n [(<= 902 :ghc)\n (import GHC.Driver.Ppr (showPpr))]\n [(<= 900 :ghc)\n (import GHC.Utils.Outputable (showPpr))]\n [otherwise\n (import Outputable (showPpr))])\n\n(cond-expand\n [(<= 900 :ghc)\n (:begin\n (import GHC.Data.FastString (fsLit))\n (import GHC.Utils.Outputable ((Outputable ..)))\n (import GHC.Parser.Lexer ((P ..) (ParseResult ..)))\n (import GHC.Types.SrcLoc ((GenLocated ..) mkRealSrcLoc interactiveSrcSpan))\n (import GHC.Data.StringBuffer (hGetStringBuffer))\n (import qualified GHC.Parser as GhcParser)\n (import qualified GHC.Parser.Lexer as GhcLexer))]\n [otherwise\n (:begin\n (import FastString (fsLit))\n (import Outputable ((Outputable ..)))\n (import Lexer ((P ..) (ParseResult ..)))\n (import SrcLoc ((GenLocated ..) mkRealSrcLoc interactiveSrcSpan))\n (import StringBuffer (hGetStringBuffer))\n (import qualified Parser as GhcParser)\n (import qualified Lexer as GhcLexer))])\n\n(cond-expand\n [(<= 904 :ghc)\n (:begin\n (import GHC.Driver.Config.Parser (initParserOpts))\n (import GHC.Parser.PostProcess ((ECP ..) runPV)))]\n [(<= 902 :ghc)\n (:begin\n (import GHC.Driver.Config (initParserOpts))\n (import GHC.Parser.PostProcess ((ECP ..) runPV)))]\n [(<= 900 :ghc)\n (import GHC.Parser.PostProcess (runECP-P))]\n [otherwise\n (import RdrHsSyn (runECP-P))])\n\n\n;;; Functions\n\n(defn (:: spec Spec)\n (beforeAll\n ;; Running `runGhc' to set the `unsafeGlobalDynFlags' with `initGhcMonad'.\n (do (<- mb-ghc-lib get-ghc-lib)\n (runGhc mb-ghc-lib getSessionDynFlags))\n (describe \"language syntax\"\n (do (lept [expFromECP (cond-expand\n ;; The function `runECP_P' was added in ghc 8.10.x,\n ;; and removed in ghc 9.2.1. Using explicit lambda\n ;; for `runPV' and `unECP' to make the type\n ;; concrete.\n [(<= 902 :ghc) (\\p (runPV (unECP p)))]\n [otherwise runECP-P])])\n (describe \"expression\"\n (parser-tests \"expr\" (Parsers (>>= GhcParser.parseExpression\n expFromECP)\n FnkParser.parseExpr)))\n (describe \"declaration\"\n (parser-tests \"decl\" (Parsers (fmap pure GhcParser.parseDeclaration)\n FnkParser.parseTopDecls)))\n (describe \"module\"\n (parser-tests \"module\" (Parsers GhcParser.parseModule\n (fmap (L interactiveSrcSpan)\n FnkParser.parseModule))))\n (describe \"import\"\n (parser-tests \"import\" (Parsers (fmap pure GhcParser.parseImport)\n FnkParser.parseImports)))\n (describe \"ffi\"\n (parser-tests \"ffi\" (Parsers (fmap pure GhcParser.parseDeclaration)\n FnkParser.parseTopDecls)))))))\n\n(defn (:: parser-tests\n (=> (Outputable a) (-> FilePath (Parsers a) (SpecWith DynFlags))))\n [subdir parsers]\n (do (lefn [(run-it [name]\n (it (++ \"should parse tests in \" name)\n (\\dflags\n (parser-test dflags parsers ( (language-dir subdir) name)))))])\n (<- files (runIO (list-base-names (language-dir subdir))))\n (mapM_ run-it files)))\n\n(data (Parsers a)\n (Parsers {(:: hs-parser (P a))\n (:: fnk-parser (Builder a))}))\n\n(defn (:: parser-test\n (=> (Outputable a) (-> DynFlags (Parsers a) FilePath (IO ()))))\n [dflags parsers basename]\n (do (lept [fnk (<.> basename \"fnk\")\n hs (<.> basename \"hs\")])\n (<- buf (hGetStringBuffer hs))\n (lept [loc (mkRealSrcLoc (fsLit \"\") 1 1)\n ps (cond-expand\n [(<= 902 :ghc)\n (GhcLexer.initParserState (initParserOpts dflags) buf loc)]\n [otherwise\n (GhcLexer.mkPState dflags buf loc)]) ])\n (case (GhcLexer.unP (hs-parser parsers) ps)\n (POk _st hres) (do (<- fstr (parse-fnk dflags parsers fnk))\n (shouldBe fstr (showPpr dflags hres)))\n _ (expectationFailure \"failed to parse haskell code\"))))\n\n(defn (:: parse-fnk\n (=> (Outputable a)\n (-> DynFlags (Parsers a) FilePath (IO String))))\n [dflags parser path]\n (do (<- buf (hGetStringBuffer path))\n (<- (, forms _sp) (parseSexprs (Just path) buf))\n (case (evalBuilder dflags False (fnk-parser parser) forms)\n (Right fexp) (return (showPpr dflags fexp))\n (Left err) (return (show err)))))\n\n(defn (:: language-dir (-> String FilePath))\n [subdir]\n ( \"include\" \"language-syntax\" subdir))\n\n(defn (:: list-base-names (-> FilePath (IO [FilePath])))\n [dir]\n (do (<- files (listDirectory dir))\n (return\n (sort [(dropExtension file)\n | (<- file files) (== \".fnk\" (takeExtension file))]))))\n" }, { "path": "doc/test/Doc/Macros.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Test codes for \"macros.rst\"\n\n(defmodule Doc.Macros\n (export spec)\n (import\n ;; base\n (Data.Version [makeVersion])\n (System.Info [os])\n\n ;; filepath\n (System.FilePath [])\n\n ;; hspec\n (Test.Hspec [(Spec) beforeAll_ describe])\n\n ;; Internal\n (Doc.TestAux)))\n\n(defn (:: spec Spec)\n (lept [dir ( \"include\" \"macros\")\n is-osx-or-win (|| (== os \"darwin\") (== os \"mingw32\"))\n skips [(, \"begin.console\"\n (\\version _\n (> (makeVersion [8 8 0]) version)))\n (, \"quasiquote.console\"\n (\\version _\n (|| is-osx-or-win\n (<= (makeVersion [9 4 0]) version))))\n (, \"quasiquote904.console\"\n (\\version _\n (|| is-osx-or-win\n (< version (makeVersion [9 4 0])))))]]\n (beforeAll_\n (remove-compiled [( dir \"quasiquote\")\n ( dir \"require\")\n ( dir \"RequireMe\")])\n (describe \"macros in finkel\"\n (run-console-tests dir skips)))))\n" }, { "path": "doc/test/Doc/TestAux.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Auxiliary codes for tests.\n\n(defmodule Doc.TestAux\n (export (BuildTool ..)\n get-build-tool\n get-stack-resolver\n get-ghc-lib\n run-console-tests\n run-console-test\n remove-compiled)\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Exception [catch throw])\n (Control.Monad [unless when])\n (Data.List [isSubsequenceOf isPrefixOf sort])\n (Data.Maybe [fromMaybe])\n (Data.Version [(Version ..) parseVersion])\n (System.Environment [getExecutablePath lookupEnv])\n (System.Exit [(ExitCode ..)])\n (System.IO [hGetContents hGetLine])\n (Text.ParserCombinators.ReadP [readP-to-S])\n\n ;; directory\n (System.Directory [listDirectory removeFile])\n (System.Directory.Internal.Prelude [isDoesNotExistError])\n\n ;; filepath\n (System.FilePath [ <.> takeExtension])\n\n ;; hspc\n (Test.Hspec\n [(Expectation) (Spec) expectationFailure it pendingWith runIO shouldBe])\n\n ;; process\n (System.Process\n [(CreateProcess ..) (StdStream ..) createProcess proc waitForProcess])))\n\n(cond-expand\n [(<= 900 :ghc)\n (import GHC.Settings.Config (cProjectVersion))]\n [otherwise\n (import Config (cProjectVersion))])\n\n;;; Exported\n\n(defn (:: remove-compiled (-> [String] (IO ())))\n \"Remove given compiled files if exist.\nRemove the given file @FILE@, @FILE.o@, and @FILE.hi@.\"\n [name]\n (lefn [(go0 [exe]\n (mapM go1 [exe\n (<.> exe \"o\")\n (<.> exe \"hi\")\n (<.> exe \"dyn_o\")\n (<.> exe \"dyn_hi\")]))\n (go1 [file]\n (catch (removeFile file)\n (\\e\n (unless (isDoesNotExistError e)\n (throw e)))))]\n (mapM_ go0 name)))\n\n(defn (:: get-build-tool (IO BuildTool))\n \"Get the running `BuildTool'.\"\n (do (<- me getExecutablePath)\n (pure (cond\n [(isSubsequenceOf \".stack\" me) Stack]\n [(isSubsequenceOf \"dist-newstyle\" me) Cabal]\n [otherwise Raw]))))\n\n(defn (:: get-stack-resolver (IO String))\n \"Return @RESOLVER@ environment variable.\"\n (fmap (fromMaybe \"lts-16\") (lookupEnv \"RESOLVER\")))\n\n(defn (:: get-ghc-lib (IO (Maybe FilePath)))\n (do (<- build-tool get-build-tool)\n (<- p0\n (case build-tool\n Cabal (return (proc \"cabal\" [\"v2-exec\" \"--\" \"ghc\" \"--print-libdir\"]))\n Stack (do (<- resolver get-stack-resolver)\n (return (proc \"stack\" [\"--resolver\" resolver \"exec\" \"--\"\n \"ghc\" \"--print-libdir\"])))\n Raw (return (proc \"ghc\" [\"--print-libdir\"]))))\n (lept [p1 (p0 {(= std-out CreatePipe)})])\n (<- (, _mb-in mb-out _mb-err ph) (createProcess p1))\n (<- _ec (waitForProcess ph))\n (case mb-out\n (Just out) (fmap pure (hGetLine out))\n Nothing (return Nothing))))\n\n(:doc \"List of pair of name and condition for skipping console test.\n\nPair of cosole filename (without the directory, with extension) and a function\ntaking GHC version. If the function evaluates to `True', the console test will\nbe skipped.\")\n(type ConsoleSkip [(, String (-> Version BuildTool Bool))])\n\n(defn (:: get-console-files (-> FilePath (IO [FilePath])))\n (lept [is-console-file (. (== \".console\") takeExtension)]\n (. (fmap (. sort (filter is-console-file))) listDirectory)))\n\n(defn (:: run-console-tests (-> FilePath ConsoleSkip Spec))\n \"Run test for @*.console@ files in given directory.\"\n [dir skips]\n (do (lefn [(test [build-tool file]\n (it (++ \"runs \" file \" successfully\")\n (case (do (<- f (lookup file skips))\n (<- v mb-ghc-version)\n (return (f v build-tool)))\n (Just True) (pendingWith \"skipped\")\n _ (run-console-test dir file))))\n (mb-ghc-version\n (case (filter (. null snd)\n (readP-to-S parseVersion cProjectVersion))\n (: (, v _) _) (Just v)\n _ Nothing))])\n (<- console-files (runIO (get-console-files dir)))\n (<- build-tool (runIO get-build-tool))\n (mapM_ (test build-tool) console-files)))\n\n(data BuildTool\n ;; | This package is build with `cabal-install'.\n Cabal\n\n ;; | This package is build with `stack'.\n Stack\n\n ;; | This package is build with raw invokation of available commands.\n Raw\n (deriving Eq))\n\n(defn (:: run-console-test (-> FilePath ; ^ Directory to run the command.\n FilePath ; ^ Console file.\n Expectation))\n [dir file]\n (do (<- contents (readFile ( dir file)))\n (<- build-tool get-build-tool)\n (<- finkel\n (case build-tool\n Cabal (return (, \"cabal\" [\"v2-exec\" \"-v0\" \"--\" \"finkel\"]))\n Stack (do (<- resolver get-stack-resolver)\n (return (, \"stack\" [\"--resolver\" resolver \"--silent\"\n \"exec\" \"--\" \"finkel\"])))\n Raw (return (, \"finkel\" []))))\n (lept [tests (parse-console contents)\n aliases [(, \"finkel\" finkel)]])\n (mapM_ (run-console dir aliases) tests)))\n\n(data ConsoleTest\n (ConsoleTest String ; ^ The command.\n [String] ; ^ Arguments passed to the command.\n [String]) ; ^ Expected output lines.\n (deriving Eq Show))\n\n(defn (:: run-console\n (-> String ; ^ Directory to run the test\n [(, String (, String [String]))] ; ^ Alias for command.\n ConsoleTest ; ^ The test.\n (IO ())))\n [dir aliases (ConsoleTest cmd args expected)]\n (do (lept [(, cmd' args') (case (lookup cmd aliases)\n (Just (, rc ra)) (, rc (++ ra args))\n Nothing (, cmd args))])\n (<- (, _mbin mbout mberr ph)\n (createProcess ((proc cmd' args') {(= cwd (Just dir))\n (= std-out CreatePipe)})))\n (<- ec (waitForProcess ph))\n (<- errs (case mberr\n (Just hdl) (hGetContents hdl)\n Nothing (return \"\")))\n (when (not (null errs))\n (putStrLn (++ \"stderr: \" errs)))\n (<- outs0 (case mbout\n (Just out) (fmap lines (hGetContents out))\n Nothing (return [])))\n (lept [outs1 (remove-loaded-package-env outs0)])\n (case ec\n ExitSuccess (shouldBe (unlines outs1) (unlines expected))\n _ (expectationFailure (++ \"Got exit code \" (show ec))))))\n\n(defn (:: remove-loaded-package-env (-> [String] [String]))\n \"In ghc-8.10.1, the `Loaded package environment from ...' message has changd\n its output from stderr to stdout. Removing the message line from command\n outputs.\"\n (filter (. not (isPrefixOf \"Loaded package environment from\"))))\n\n(defn (:: parse-console (-> String [ConsoleTest]))\n \"Parse the contents of console file.\"\n (lefn [(go [ls]\n (case (span is-cmd-line ls)\n (, (: cl _) r0) (case (words (drop 1 cl))\n (: cmd args) (case (break is-cmd-line r0)\n (, os r1) (: (ct cmd args os)\n (go r1)))\n _ (go r0))\n _ []))\n (ct ConsoleTest)]\n (. go lines)))\n\n(defn (:: is-cmd-line (-> String Bool))\n \"True if the line starts with @$@.\"\n [(: #'$ _)] True\n [_] False)\n" }, { "path": "doc/test/Doc.hs", "content": ";;; -*- mode: finkel -*-\n(defmodule Doc\n (export main)\n (import\n ;; hspec\n (Test.Hspec (hspec))\n\n ;; Internal\n (qualified Doc.FinkelExecutable)\n (qualified Doc.BuildingPackage)\n (qualified Doc.Macros)\n (qualified Doc.LanguageSyntax)))\n\n(defn (:: main (IO ()))\n (hspec (do Doc.FinkelExecutable.spec\n Doc.BuildingPackage.spec\n Doc.Macros.spec\n Doc.LanguageSyntax.spec)))\n" }, { "path": "doc/test/Spec.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule Main\n (import\n (qualified Doc)))\n\n(defn (:: main (IO ()))\n Doc.main)\n" }, { "path": "finkel/CHANGELOG.md", "content": "# Revision history for finkel\n\n## 0.1.0.0 -- YYYY-mm-dd\n\n* First version. Released on an unsuspecting world.\n" }, { "path": "finkel/LICENSE", "content": "Copyright (c) 2020-2022, 8c6794b6\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "finkel/Main.hs", "content": "import Finkel.Tool.Main (defaultMain)\n\nmain :: IO ()\nmain = defaultMain\n" }, { "path": "finkel/README.md", "content": "# finkel\n\nPackage for the @finkel@ executable.\n\nSee the [documentation](https://finkel.readthedocs.org) for more info\n" }, { "path": "finkel/Setup.hs", "content": "import Distribution.Simple\nmain = defaultMain\n" }, { "path": "finkel/finkel.cabal", "content": "cabal-version: 2.0\nname: finkel\nversion: 0.0.0\nsynopsis: Haskell in S-expression\nlicense: BSD3\nlicense-file: LICENSE\nauthor: 8c6794b6\nmaintainer: 8c6794b6@gmail.com\ncopyright: 2020-2022 8c6794b6\ncategory: Language\nbuild-type: Simple\nextra-source-files: CHANGELOG.md\n README.md\n\ndescription:\n Package for the @finkel@ executable.\n .\n See the for more info.\n\nexecutable finkel\n main-is: Main.hs\n build-depends: base >= 4.14 && < 5\n , finkel-tool == 0.0.0\n default-language: Haskell2010\n ghc-options: -Wall -threaded\n -rtsopts=all\n \"-with-rtsopts=-K512M -H -I5 -T\"\n\nsource-repository head\n type: git\n location: https://github.com/finkel-lang/finkel.git\n subdir: finkel\n" }, { "path": "finkel-core/LICENSE", "content": "Copyright (c) 2017-2022, 8c6794b6\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "finkel-core/README.md", "content": "# finkel-core\n\nCore language macro for Finkel.\n\nSee the [documentation][doc] for more details.\n\n[doc]: https://finkel.readthedocs.io/en/latest/\n" }, { "path": "finkel-core/Setup.hs", "content": "import Distribution.Simple (defaultMain)\nmain = defaultMain\n" }, { "path": "finkel-core/finkel-core.cabal", "content": "cabal-version: 2.0\nname: finkel-core\nversion: 0.0.0\nsynopsis: Finkel language core\ndescription:\n Finkel language core macros and functions\n .\n See the for more info.\n\nhomepage: https://github.com/finkel-core/finkel#readme\nlicense: BSD3\nlicense-file: LICENSE\nauthor: 8c6794b6\nmaintainer: 8c6794b6@gmail.com\ncopyright: 2017-2022 8c6794b6\ncategory: Language\nbuild-type: Simple\nextra-source-files: README.md\n --\n test/data/plugin/*.hs\n\ntested-with: GHC == 8.10.7\n , GHC == 9.0.1\n , GHC == 9.2.8\n , GHC == 9.4.7\n , GHC == 9.6.5\n , GHC == 9.8.2\n , GHC == 9.10.1\n\nlibrary\n hs-source-dirs: src\n exposed-modules: Finkel.Core\n Finkel.Core.Functions\n Finkel.Core.Internal\n Finkel.Core.Plugin\n Finkel.Prelude\n Paths_finkel_core\n other-modules: Finkel.Core.Internal.Stage0\n Finkel.Core.Internal.Stage1\n Finkel.Core.Internal.Stage2\n Finkel.Core.Internal.Ghc\n Finkel.Core.Internal.Ghc.Compat\n Finkel.Core.Internal.Ghc.Version\n autogen-modules: Paths_finkel_core\n\n build-depends: base >= 4.14 && < 5\n , ghc >= 8.10.0 && < 9.11\n , finkel-kernel == 0.0.0\n -- To import \"GHC.PackageDb.packageVersion\"\n if impl (ghc <= 9.0.0)\n build-depends: ghc-boot >= 8.2.0 && < 9\n\n default-language: Haskell2010\n\n build-tool-depends: fnkpp:fnkpp == 0.0.0\n ghc-options: -Wall\n -F -pgmF fnkpp -optF --no-warn-interp\n -fplugin Language.Finkel.Plugin\n if impl (ghc >= 9.6.0)\n ghc-options: -keep-hscpp-files\n\ntest-suite finkel-core-test\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Spec.hs\n other-modules: Orphan\n CoreTest\n FunctionTest\n PluginTest\n TestAux\n build-depends: base\n , ghc\n , finkel-core\n , finkel-kernel\n --\n , QuickCheck >= 2.10.1 && < 2.16\n , directory >= 1.3 && < 1.4\n , filepath >= 1.4 && < 1.6\n , hspec >= 2.4.8 && < 2.12\n\n default-language: Haskell2010\n\n -- Known not to work ..., disabling the test under Windows with ghc >= 9.4.\n -- The test requires object files of this package built with \"-dynamic\"\n -- option, which does not work well under Windows.\n if impl (ghc >= 9.4.0) && os(windows)\n buildable: False\n\n build-tool-depends: fnkpp:fnkpp == 0.0.0\n ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N\n -F -pgmF fnkpp -optF --warn-interp=False\n -fplugin Language.Finkel.Plugin\n if impl (ghc >= 9.6.0)\n ghc-options: -keep-hscpp-files\n\nsource-repository head\n type: git\n location: https://github.com/finkel-lang/finkel.git\n subdir: finkel-core\n" }, { "path": "finkel-core/src/Finkel/Core/Functions.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Exported functions defined in this package\n\n(:doc \"Module for exporting functions defined in the @finkel-core@ package.\n\nThis module does not export macros, but exports some of the functions to work\nwith code values when writing macros.\")\n\n(module Finkel.Core.Functions\n (:dh1 \"Predicates\")\n is-atom is-pair is-list is-hslist\n is-symbol is-string is-char is-integer is-fractional is-unit\n caris\n\n (:dh1 \"Atom constructors\")\n make-symbol\n\n (:dh1 \"Atom extractors\")\n mb-symbol-name mb-symbol-name-fs\n\n (:dh1 \"Code constructors\")\n cons list (Listable ..)\n\n (:dh1 \"CXrs\")\n (:dh2 \"Basic cXrs\")\n car cdr\n\n (:dh2 \"Composed cXrs\")\n (:doc$ cxr)\n\n caar cadr\n caaar caadr cadar caddr\n caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr\n\n cdar cddr\n cdaar cdadr cddar cdddr\n cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr\n\n (:dh1 \"Converting\")\n curve rev unsnoc\n\n (:dh1 \"Higher order functions\")\n reduce reduce1 map1 keep trav1 omni omniM\n\n (:dh1 \"Exceptions\")\n (FinkelListException ..) unsafeFinkelSrcError)\n\n;; Internal\n(import Finkel.Core.Internal.Stage0)\n(import Finkel.Core.Internal.Stage2)\n\n(:doc$ cxr \"The `car' and `cdr' are the basic of /cxr/ functions.\nRest of the /cxr/ functions are composed from `car' and `cdr'.\n\nE.g., definition of `cadr' is:\n\n> (cadr x) == (car (cdr x))\n\nand the definition of `cdadr' is:\n\n> (cdadr x) == (cdr (car (cdr x)))\")\n" }, { "path": "finkel-core/src/Finkel/Core/Internal/Ghc/Compat.hs", "content": "{-# LANGUAGE CPP #-}\n-- Module to re-export functions from ghc\n\nmodule Finkel.Core.Internal.Ghc.Compat\n (\n -- GHC\n getModuleInfo, lookupModule, lookupName, modInfoExports,\n\n -- GHC.Data.FastString\n FastString, fsLit, unpackFS, nullFS,\n\n -- GHC.Driver.Env\n HscEnv(..),\n\n -- GHC.Driver.Monad\n GhcMonad(..),\n\n -- GHC.Driver.Ppr\n showSDoc,\n\n -- GHC.Plugin\n Plugin(..),\n\n -- GHC.Types.SourceText\n SourceText(..),\n\n -- GHC.Types.TyThing\n TyThing(..),\n\n -- GHC.Types.Var\n varName,\n\n -- GHC.Unit.Module\n mkModuleName,\n\n -- GHC.Utils.Lexeme\n isLexCon,\n\n -- GHC.Utils.Outputable\n ppr\n ) where\n\nimport GHC (getModuleInfo, lookupModule, lookupName,\n modInfoExports)\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Env\nimport GHC.Driver.Ppr\nimport GHC.Types.SourceText\nimport GHC.Types.TyThing\n#elif MIN_VERSION_ghc(9,0,0)\nimport GHC.Driver.Types\nimport GHC.Types.Basic\nimport GHC.Types.Var\nimport GHC.Unit.Module\nimport GHC.Utils.Outputable\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC.Data.FastString\nimport GHC.Driver.Monad\nimport GHC.Plugins\nimport GHC.Utils.Lexeme\n#else\nimport BasicTypes\nimport FastString\nimport GhcMonad\nimport HscTypes\nimport Lexeme\nimport Module\nimport Outputable\nimport Plugins\nimport Var\n#endif\n\n" }, { "path": "finkel-core/src/Finkel/Core/Internal/Ghc/Version.hs", "content": "{-# LANGUAGE CPP #-}\n-- | Wrapper module to export version related functions.\nmodule Finkel.Core.Internal.Ghc.Version\n ( __glasgow_haskell__\n , getPackageVersion\n ) where\n\n-- base\nimport Data.Version (Version)\n\n-- finkel-kernel\nimport Language.Finkel (Code, Fnk, finkelSrcError, fromCode)\n\n-- ghc\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Env (hsc_units)\n#elif MIN_VERSION_ghc(9,0,0)\nimport GHC.Driver.Session (unitState)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,4,0)\nimport GHC.Unit.Types (indefUnit)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC.Unit.State (PackageName (..), lookupPackageName,\n lookupUnitId, unitPackageVersion)\n#else\nimport Module (componentIdToInstalledUnitId)\nimport Packages (PackageName (..),\n lookupInstalledPackage,\n lookupPackageName)\n\n-- ghc-boot\nimport GHC.PackageDb (packageVersion)\n#endif\n\n-- Internal\nimport Finkel.Core.Internal.Ghc.Compat\n\n-- | Function version of @__GLASGOW_HASKELL__@ C preprocessor macro.\n__glasgow_haskell__ :: Int\n__glasgow_haskell__ = __GLASGOW_HASKELL__\n\ngetPackageVersion :: HscEnv -> Code -> Fnk Version\ngetPackageVersion hsc_env form =\n let err = finkelSrcError form\n in case fromCode form of\n Nothing -> err (\"want package name `String' value but got: \" ++ show form)\n Just name -> case lookupPackageVersion hsc_env name of\n Nothing -> err (\"cannot find package: \" ++ name)\n Just v -> pure v\n\nlookupPackageVersion :: HscEnv -> String -> Maybe Version\n#if MIN_VERSION_ghc(9,4,0)\nlookupPackageVersion hsc_env name =\n -- XXX: Is GHC.Driver.Env.hscActiveUnitId related?\n do let pname = PackageName (fsLit name)\n us = hsc_units hsc_env\n uid <- lookupPackageName us pname\n uinfo <- lookupUnitId us uid\n pure $ unitPackageVersion uinfo\n#elif MIN_VERSION_ghc(9,2,0)\nlookupPackageVersion hsc_env name =\n do let pname = PackageName (fsLit name)\n us = hsc_units hsc_env\n indef_uid <- lookupPackageName us pname\n uid <- lookupUnitId us (indefUnit indef_uid)\n pure $ unitPackageVersion uid\n#elif MIN_VERSION_ghc(9,0,0)\nlookupPackageVersion hsc_env name =\n do let pname = PackageName (fsLit name)\n ust = unitState (hsc_dflags hsc_env)\n indef_uid <- lookupPackageName ust pname\n uid <- lookupUnitId ust (indefUnit indef_uid)\n pure $ unitPackageVersion uid\n#else\nlookupPackageVersion hsc_env name =\n do let pname = PackageName (fsLit name)\n component_id <- lookupPackageName (hsc_dflags hsc_env) pname\n let iuid = componentIdToInstalledUnitId component_id\n conf <- lookupInstalledPackage (hsc_dflags hsc_env) iuid\n pure $ packageVersion conf\n#endif\n" }, { "path": "finkel-core/src/Finkel/Core/Internal/Ghc.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Module for ghc related functions\n\n(:doc \"Internal module for @ghc@ related functions.\")\n\n(module Finkel.Core.Internal.Ghc\n __glasgow_haskell__\n (module Finkel.Core.Internal.Ghc.Compat))\n\n(import Finkel.Core.Internal.Ghc.Compat)\n(import Finkel.Core.Internal.Ghc.Version)\n" }, { "path": "finkel-core/src/Finkel/Core/Internal/Stage0.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Stage0 - functions used in stage 1.\n\n;;; This module contains few functions and type to work with `Code', just enough\n;;; to define some macros in the next `Finkel.Core.Internal.Stage1' module.\n\n(module Finkel.Core.Internal.Stage0\n ;; Exported from other modules.\n (FinkelListException ..) car cdr cons\n\n ;; Internal, used in this package only.\n non-list the-macro-arg)\n\n;; base\n(import Control.Exception ((Exception ..) throw))\n\n;; finkel-kernel\n(import Language.Finkel)\n(import Language.Finkel.Form (mkLocatedForm))\n\n\n;;; Exception\n\n(:doc \"List related exception.\")\n(data FinkelListException\n (NonListValue Code String))\n\n(instance (Show FinkelListException)\n (= show (NonListValue _ str) str))\n\n(instance (Exception FinkelListException))\n\n(:doc \"Throw a `NonListValue' with label and cause.\")\n(:: non-list (-> String Code a))\n(= non-list fname what\n (let ((= msg (++ fname \": non-list value `\" (show what) \"'\")))\n (throw (NonListValue what msg))))\n%p(INLINE non-list)\n\n\n;;; CONS, CAR, CDR\n\n(:doc \"Extend the second argument with the first argument by appending\nto the tip.\n\nConsing to 'HsList' will result in 'List', and consing to non-list value\nwill create a new 'List' instead of a /dotted-pair/.\n\n==== __Examples__\n\n>>> (cons 'a '(b c))\n(a b c)\n>>> (cons 'a '[b c])\n(a b c)\n>>> (cons '(a b) '(c d))\n((a b) c d)\n>>> (cons '[a b] '[c d])\n([a b] c d)\n>>> (cons 'a 'b)\n(a b)\")\n(:: cons (=> (Homoiconic a) (Homoiconic b) (-> a b Code)))\n(= cons a b\n (let ((= (@ hd (LForm (L l0 _))) (toCode a))\n (= (@ whole (LForm (L _ xs))) (toCode b)))\n (LForm (L l0 (case xs\n (List xs') (List (: hd xs'))\n (HsList xs') (List (: hd xs'))\n _ (List [hd whole]))))))\n%p(INLINABLE cons)\n\n(:doc \"Get the first element of given 'Code'.\n\nThe function 'car' returns the first element of 'List' and 'HsList' constructor,\nor 'nil' value when the 'List' or 'HsList' were empty. Throws a 'NonListValue'\nwhen the given argument was non-list value.\n\n==== __Examples__\n\n>>> (car '(a b c))\na\n>>> (car '[a b c])\na\n>>> (car nil)\nnil\n>>> (car 'foo)\n*** Exception: car: non-list value `foo'\")\n(:: car (-> Code Code))\n(= car (@ lform (LForm (L l form)))\n (case form\n (List (: x _)) x\n (List []) lform\n (HsList (: x _)) x\n (HsList []) (LForm (L l (List [])))\n _ (non-list \"car\" lform)))\n%p(INLINABLE car)\n\n(:doc \"Get a list without the first element.\n\nThe function 'cdr' returns list value without the first element of 'List' or\n'HsList' argument. When the argument is a 'HsList', returned value is converted\nto a 'List'. Like 'car', throws 'NonListValue' when the argument were non-list\nvalue.\n\n==== __Examples__\n\n>>> (cdr '(a b c))\n(b c)\n>>> (cdr '[a b c])\n(b c)\n>>> (cdr nil)\nnil\n>>> (cdr 'foo)\n*** Exception: cdr: non-list value `foo'\n\")\n(:: cdr (-> Code Code))\n(= cdr (@ lform (LForm (L l form)))\n (let ((= f xs\n (case (mkLocatedForm xs)\n (L l1 _) (LForm (L l1 (List xs))))))\n (case form\n (List (: _ xs)) (f xs)\n (List []) (LForm (L l (List [])))\n (HsList (: _ xs)) (f xs)\n (HsList []) (LForm (L l (List [])))\n _ (non-list \"cdr\" lform))))\n%p(INLINABLE cdr)\n\n\n;;; Special symbol\n\n(:doc \"The symbol used for entire argument in macro function.\")\n(:: the-macro-arg Code)\n(= the-macro-arg '__form__)\n%p(INLINE the-macro-arg)\n" }, { "path": "finkel-core/src/Finkel/Core/Internal/Stage1.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Stage1 - fundamental macros\n\n;;; This module contains codes of some fundamental macros, such as `defmacro',\n;;; `defmodule', `eval-when', `macrolet' ... etc, just enough to start writing\n;;; other macros and function in `Finkel.Core.Stage2'.\n\n(module Finkel.Core.Internal.Stage1\n defmacro defmacro' defmacro-\n defmacroM defmacroM' defmacroM-\n macrolet macroletM\n defn defn' defn-\n eval-when eval-and-compile)\n\n;;; Imports\n\n;; base\n(import Control.Monad (foldM))\n\n;; finkel-kernel\n(import Language.Finkel)\n\n;; Internal\n(import Finkel.Core.Internal.Stage0)\n(import Finkel.Core.Internal.Ghc.Compat)\n\n\f\n;;; [Internally used macros]\n;;; ~~~~~~~~~~~~~~~~~~~~~~~~\n;;;\n;;; First, defining `eval-when-compile-and-load' macro, to define functions and\n;;; macros in current compilation context and compiled result. Then this module\n;;; defines some auxiliary functions, and then a macro `define-macro'' to define\n;;; macros for this module itself and compiled result.\n\n(:eval-when-compile\n ;; base\n (import Prelude)\n\n ;; finkel-kernel\n (import Language.Finkel)\n\n (:: eval-when-compile-and-load Macro)\n (= eval-when-compile-and-load\n (Macro\n (\\form\n (case (unCode form)\n (List (: _ rest)) (return `(:begin\n (:eval-when-compile ,@rest)\n ,@rest))\n _ (finkelSrcError form \"eval-when-compile-and-load\"))))))\n\n(eval-when-compile-and-load\n (:doc \"Code transformer function for macro declaration.\")\n (:: macro-decl (-> Code Code Code (Fnk Code)))\n (= macro-decl name arg body\n (do (<- tmp (gensym' \"tmp\"))\n ;; XXX: Test the behaviour when the type signature in below is removed.\n (return `(= ,name\n (let ((:: ,tmp (-> Code (Fnk Code)))\n (= ,tmp ,arg ,body))\n (Macro ,tmp))))))\n %p(INLINABLE macro-decl)\n\n (:doc \"Body function of /macro-defining-macro/.\")\n (:: dmac (-> Code (Fnk Code)))\n (= dmac form\n (let ((:: make-tsig (-> Code Code))\n (= make-tsig name `(:: ,name Macro)))\n (case (unCode form)\n (List [_ name arg body])\n (do (<- decl (macro-decl name arg body))\n (return `(:begin\n ,(make-tsig name)\n ,decl)))\n\n (List [_ name (@ doc (LForm (L _ (Atom (AString {}))))) arg body])\n (do (<- decl (macro-decl name arg body))\n (return `(:begin\n ,(make-tsig name)\n (:doc^ ,doc)\n ,decl)))\n\n _ (finkelSrcError form \"dmac: malformed macro\"))))\n %p(INLINABLE dmac)\n\n (:doc \"Function for body of `macrolet'.\")\n (:: lmac (-> Code (Fnk Code)))\n (= lmac form\n (let ((= f x\n (case (unCode x)\n (List [name arg body]) (macro-decl name arg body)\n _ (finkelSrcError x \"lmac: malformed macro\"))))\n (case (unCode form)\n (List (: _ (LForm (L _l (List ms))) rest))\n (do (<- ms' (mapM f ms))\n (return `(:with-macro (,@ms') ,@rest)))\n _ (finkelSrcError form \"lmac: malformed args\"))))\n %p(INLINABLE lmac))\n\n(:eval-when-compile\n (:doc \"Simple macro for defining macro. This macro is used internally\nin \\\"Finkel.Core\\\" module to define other macros.\n\n==== __Syntax__\n\n> DEFINE-MACRO ::= 'define-macro' NAME [DOC] ARGS BODY\n> NAME ::= varid\n> DOC ::= '\\\"' comment '\\\"'\n> ARGS ::= varid | '[' varid* ']' | '(' varid* ')'\n> BODY ::= form\n\n==== __Examples__\n\nWithout documentation comment:\n\n@\n(define-macro m1a\n form\n (case (unCode form)\n (List [_ x]) (return `(print ,x))))\n@\n\nWith documentation comment:\n\n@\n(define-macro m1b\n \\\"Documentation comment\\\"\n form\n (case (unCode form)\n (List [_ x]) (return `(print ,x))))\n@\n\")\n (:: define-macro Macro)\n (= define-macro (Macro dmac)))\n\n\f\n;;; Exported codes\n\n(:doc \"Macro to specify the /PHASE/s of evaluation of /BODY/ codes. Valid phases\nare __@:compile@__ and __@:load@__. The @:compile@ phase evaluates the body\nforms at the time of compilation, so that the compilation context can refer to\nthe function and macros definied in the /BODY/ forms. The @:load@ phase simply\nemit the body forms to compiled result.\n\n==== __Syntax__\n\n> EVAL-WHEN ::= 'eval-when' PHASES BODY+\n> PHASES ::= '[' PHASE+ ']' | '(' PHASE+ ')'\n> PHASE ::= ':compile' | ':load'\n> BODY ::= form\n\n==== __Example__\n\nIn following module, the function @f@ is defined inside 'eval_when', so that the\nfunction could be called from the function @g@ at run-time, and temporally macro\n@m@ at compilation time.\n\n@\n(defmodule Main\n (import-when [:compile :load]\n (Finkel.Prelude)))\n\n(eval-when [:compile :load]\n (defn (:: f (-> Code Code))\n [x]\n `(print ,x)))\n\n(defn (:: g (-> Code (IO ())))\n [x]\n (print (f x)))\n\n(macrolet ((m [x]\n (f x)))\n (defn (:: main (IO ()))\n (do (g 'foo)\n (m 'bar))))\n@\n\")\n(define-macro eval-when form\n (let ((:: at-compile (-> [Code] Bool))\n (= at-compile (elem ':compile))\n (:: at-load (-> [Code] Bool))\n (= at-load (elem ':load))\n (:: emit (-> [Code] [Code] (Fnk Code)))\n (= emit phases body\n (| ((&& (at-compile phases) (at-load phases))\n (do (<- expanded (expands body))\n (return\n (cons ':begin\n (cons (cons ':eval-when-compile expanded)\n expanded)))))\n ((at-compile phases)\n (return `(:eval-when-compile ,@body)))\n ((at-load phases)\n (return `(:begin ,@body)))\n (otherwise\n (finkelSrcError form (++ \"eval-when: invalid phase: \"\n (show phases)))))))\n (case (unCode form)\n (List (: _ (LForm (L _ lst)) body))\n (| ((<- (List phases) lst) (emit phases body))\n ((<- (HsList phases) lst) (emit phases body)))\n _ (finkelSrcError form (++ \"eval-when: invalid form: \" (show form))))))\n\n(:doc \"Same as 'eval_when' macro with __@:compile@__ and __@:load@__ phases.\n\n==== __Syntax__\n\n> EVAL-AND-COMPILE ::= 'eval-and-compile' BODY*\n\n==== __Example__\n\nSee 'eval_when'.\")\n(define-macro eval-and-compile form\n (return `(eval-when [:compile :load]\n ,@(cdr form))))\n\n\f\n;;; Auxiliary functions for `defmacro'\n\n(:: subst-gensyms (-> [(, Atom Atom)] Code Code))\n(= subst-gensyms kvs\n (fmap (\\x (case (lookup x kvs)\n (Just y) y\n Nothing x))))\n%p(INLINE subst-gensyms)\n\n(:: replace-hyphens (-> String String))\n(= replace-hyphens\n (map (\\x (if (== x #'-) #'_ x))))\n%p(INLINE replace-hyphens)\n\n(:: acc-gensym-names (-> [(, Atom Atom)] Atom (Fnk [(, Atom Atom)])))\n(= acc-gensym-names acc form\n (case form\n (ASymbol sym) (| ((<- (: #'$ (@ cs (: c _))) (unpackFS sym))\n (elem c [#'a .. #'z])\n (<- Nothing (lookup form acc))\n (do (<- x (gensym' (replace-hyphens cs)))\n (return (case (unCode x)\n (Atom gsym) (: (, form gsym) acc)\n _ acc)))))\n _ (return acc)))\n%p(INLINE acc-gensym-names)\n\n(:: gensymfy (-> Code (Fnk Code)))\n(= gensymfy form\n (do (<- kvs (foldM acc-gensym-names [] form))\n (return (subst-gensyms kvs form))))\n%p(INLINE gensymfy)\n\n;; Function to make body of macro.\n;;\n;; XXX: Currently does not suuport lambda-list like pattern match in\n;; macro argument.\n(:: make-macro-body (-> String Code Code Code Code (Fnk Code)))\n(= make-macro-body label whole name0 arg0 body0\n (let ((:: err (-> Code Code Code))\n (= err form-name name\n `(finkelSrcError\n ,form-name\n (++ ,(++ \"in macro `\" (show name) \"'\\ninvalid form: `\")\n (show ,the-macro-arg) \"'\")))\n\n (:: atom-arg-body (-> Code Code Code Code Code))\n (= atom-arg-body name arg body form-name\n `(case ,form-name\n (LForm (L $loc (List (: _ __arg__))))\n (let ((= ,arg (LForm (L $loc (List __arg__))))\n (= $tmp ,body))\n $tmp)\n _ ,(err form-name name)))\n\n (:: list-arg-body (-> SrcSpan Code [Code] Code Code Code))\n (= list-arg-body l1 name args body form-name\n (let ((:: abind Code)\n (= abind\n `(LForm (L _loc\n (List [_ ,@(LForm (L l1 (List args)))])))))\n `(case ,form-name\n ,abind (let ((= $tmp ,body))\n $tmp)\n _ ,(err form-name name)))))\n\n (case (unLForm arg0)\n (L l1 (Atom AUnit))\n (gensymfy (list-arg-body l1 name0 [] body0 the-macro-arg))\n\n (L l1 (List args))\n (gensymfy (list-arg-body l1 name0 args body0 the-macro-arg))\n\n (L l1 (HsList args))\n (gensymfy (list-arg-body l1 name0 args body0 the-macro-arg))\n\n (L _ (Atom (ASymbol _)))\n (gensymfy (atom-arg-body name0 arg0 body0 the-macro-arg))\n\n _ (finkelSrcError whole (++ label \": invalid args\")))))\n%p(INLINE make-macro-body)\n\n;; Function to make body expression of `defmacroM' and `defmacro'.\n(:: make-defmacro-body (-> String Code (-> Code Code) (Fnk Code)))\n(= make-defmacro-body label whole f\n (let ((:: emit (-> Code (Maybe Code) Code Code (Fnk Code)))\n (= emit name mb-doc arg body0\n (do (let ((= body1 (f body0))\n (= docs (maybe [] pure mb-doc))))\n (<- body2 (make-macro-body label whole name arg body1))\n (dmac `(_ ,name ,@docs ,the-macro-arg ,body2)))))\n (case (unCode whole)\n (List [_ name (@ doc (LForm (L _ (Atom (AString {}))))) arg body])\n (emit name (Just doc) arg body)\n\n (List [_ name arg body])\n (emit name Nothing arg body)\n\n _ (finkelSrcError whole (++ label \": invalid form\")))))\n%p(INLINE make-defmacro-body)\n\n;; Function to make body expression of `macrolet-m' and `macrolet'.\n(:: make-macrolet-body (-> String Code (-> Code Code) (Fnk Code)))\n(= make-macrolet-body label whole f\n (let ((:: make-macro (-> Code (Fnk Code)))\n (= make-macro code\n (case code\n (LForm (L l (List [name arg body0])))\n (do (let ((= body1 (f body0))))\n (<- body2 (make-macro-body label code name arg body1))\n (return (LForm (L l (List [name the-macro-arg body2])))))\n\n _ (finkelSrcError code (++ label \": invalid form\"))))\n (:: emit (-> SrcSpan [Code] [Code] (Fnk Code)))\n (= emit l ms body\n (do (<- macros (mapM make-macro ms))\n (lmac `(:with-macro ,(LForm (L l (List macros)))\n ,@body)))))\n\n (case (unCode whole)\n (List (: _ (LForm (L l macs)) rest))\n (| ((<- (List forms) macs) (emit l forms rest))\n ((<- (HsList forms) macs) (emit l forms rest)))\n\n _ (finkelSrcError whole (++ label \": invalid form\")))))\n%p(INLINE make-macrolet-body)\n\n(:doc \"Variant of 'macrolet', the body of each macro need to be a 'Code' value\nwrapped in 'Fnk'. This macro has full access to 'Fnk' in compilation context.\n\n==== __Syntax__\n\nSee 'macrolet'.\n\n==== __Example__\n\nRewrite of the example shown in 'macrolet':\n\n@\n(macrolet-m ((m1 [x]\n (return `(+ ,x 1)))\n (m2 [a b]\n (return `[(m1 ,a) (m1 ,b)])))\n (m2 19 20))\n;;; ==> [20,21]\n@\n\")\n(define-macro macroletM form\n (make-macrolet-body \"macroletM\" form id))\n\n(:doc \"Define temporary macros named /NAME/. The defined macros could be\nreferred from /BODY/. Each macro takes /ARGS/ parameter, and results in\n/EXPR/. The parameter /ARGS/ works as in 'defmacro'.\n\n==== __Syntax__\n\n> MACROLET ::= 'macrolet' '(' MACRO* ')' BODY\n> MACRO ::= NAME ARGS EXPR\n> NAME ::= varid\n> ARGS ::= '(' varid* ')' | '[' varid* ']' | varid\n> EXPR ::= form\n> BODY ::= form\n\n==== __Examples__\n\nTemporary macros can refer other temporary macros:\n\n@\n(macrolet ((m1 [x]\n `(+ ,x 1))\n (m2 [a b]\n `[(m1 ,a) (m1 ,b)]))\n (m2 19 20))\n;;; ==> [20,21]\n@\n\")\n(define-macro macrolet form\n (make-macrolet-body \"macrolet\" form (\\body `(return ,body))))\n\n(:doc \"A macro similar to 'defmacro', but the body expression need to be a value\nof type 'Fnk' 'Code'. This macro has full access to the 'Fnk' environment in\ncompilation context.\n\n==== __Syntax__\n\nSee 'defmacro'.\n\n==== __Examples__\n\nA macro to read a file contents during compilation:\n\n@\n(defmacroM m1 [path]\n (| ((<- (Just path') (fromCode path))\n (do (<- contents (liftIO (readFile path')))\n (return `(putStrLn ,contents))))\n (otherwise\n (finkelSrcError path \\\"m1: not a file path.\\\"))))\n@\n\nSample expansion:\n\n>>> (macroexpand '(m1 \\\"/path/to/a/file.txt\\\")\n(putStrLn \\\"... contents of the file ...\\\") \")\n(define-macro defmacroM form\n (make-defmacro-body \"defmacroM\" form id))\n\n(:doc \"Variant of 'defmacroM', wrapped in 'eval_and_compile'.\n\n==== __Syntax__\n\nSee 'defmacro'.\n\n==== __Examples__\n\nSee 'defmacro' and 'defmacroM'.\")\n(define-macro defmacroM' form\n (return `(eval-and-compile\n (defmacroM ,@(cdr form)))))\n\n(:doc \"Variant of 'defmacroM', wrapped in @:eval_when_compile@.\n\n==== __Syntax__\n\nSee 'defmacro'.\n\n==== __Examples__\n\nSee 'defmacro' and 'defmacroM'. \")\n\n(define-macro defmacroM- form\n (return `(:eval-when-compile\n (defmacroM ,@(cdr form)))))\n\n(:doc \"Macro to define a macro named /NAME/, similar to the macro with same\nname found in other Lisps, such as Common Lisp, Clojure, LFE, Hy\n... etc. The 'defmacro' can take an optional /DOC/ comment string in\nsecond parameter. Next parameter is either a list of /ARGS/, or a single\nvarid to refer the entire parameter as a list of 'Code's. The last\nparameter is a /BODY/ expression, which need to be a value of 'Code'\ntype.\n\nNote that the 'defmacro' does not add the defined macro to REPL\nsession. To add macros in REPL session, use 'defmacro'' or write the\nmacro definition inside 'eval_when'.\n\n==== __Syntax__\n\n> DEFMACRO ::= 'defmacro' NAME [DOC] ARGS BODY\n> NAME ::= varid\n> DOC ::= '\\\"' comment '\\\"'\n> ARGS ::= '(' varid* ')' | '[' varid* ']' | varid\n> BODY ::= form\n\n==== __Examples__\n\nMacro taking single parameter named /x/, returns a form with 'print'\napplied to the given parameter:\n\n> (defmacro m1a [x]\n> `(print ,x))\n\nSample expansion:\n\n>>> (macroexpand '(m1a False))\n(print False)\n\nParameters could be enclosed in parentheses or brackets:\n\n> (defmacro m1b (x)\n> `(print ,x))\n\nMacro with documentation comment:\n\n> (defmacro m2\n> \\\"Documentation comment.\\\"\n> [a b]\n> `(do (print ,a)\n> (print ,b)))\n\nSample expansion:\n\n>>> (macroexpand '(m2 False #'x))\n(do (print False) (print #'x))\n\nMacro taking parameter as a list of 'Code':\n\n@\n(defmacro m3 args\n (case args\n (List [a]) `(print ,a)\n (List [a b]) `(>> (print ,a) (print ,b))\n (List xs) `(do ,@(map (\\\\\\\\ x `(print ,x)) xs))))\n@\n\nExpansions of /m3/:\n\n>>> (macroexpand '(m3 False))\n(print False)\n>>> (macroexpand '(m3 False #'x))\n(>> (print False) (print #'x))\n>>> (macroexpand '(m3 False #'x \\\"bar\\\"))\n(do (print False) (print #'x) (print \\\"bar\\\"))\n\")\n(define-macro defmacro form\n (make-defmacro-body \"defmacro\" form (\\x `(return ,x))))\n\n(define-macro defmacro'\n \"Variant of 'defmacro', wrapped in 'eval_and_compile'.\n\n==== __Syntax__\n\nSee 'defmacro'.\n\n==== __Examples__\n\nSee 'defmacro'.\n\"\n form\n (return `(eval-and-compile\n (defmacro ,@(cdr form)))))\n\n(define-macro defmacro-\n \"Variant of 'defmacro', wrapped in @:eval-when-compile@.\n\n==== __Syntax__\n\nSee 'defmacro'.\n\n==== __Examples__\n\nSee 'defmacro'.\"\n form\n (return `(:eval-when-compile\n (defmacro ,@(cdr form)))))\n\n(define-macro defn\n \"Macro for defining function. Supports optional function type\nsignature /SIG/, which could be a name symbol or a list of name symbol\nand type signature form. Parameter /ARGS/ could be enclosed in\nparantheses or brackets. When multiple pairs of /ARGS/ and /BODY/ were\ngiven, does expand to function definition with argument pattern\nmatchings.\n\n==== __Syntax__\n\n> DEFN ::= 'defn' SIG [DOC] [ARGS] BODY ARGBODY*\n> SIG ::= varid | '(' varid typesig ')' | '(' '::' varid typesig ')'\n> DOC ::= '\\\"' comment '\\\"'\n> ARGS ::= '(' varid* ')' | '[' varid* ']'\n> BODY ::= form\n> ARGBODY ::= ARGS BODY\n\n==== __Examples__\n\nFunction without arguments:\n\n> (defn v1 42)\n\nFunction without arguments, with type signature:\n\n> (defn (:: v2 Int) 43)\n\nFunction with arguments, type signature, and documentation comment:\n\n@\n(defn (:: fib1 (-> Int Int))\n \\\"Documentation comment\\\"\n [n]\n (case n\n 0 0\n 1 1\n _ (+ (fib1 (- n 1)) (fib1 (- n 2)))))\n@\n\nFunction with pattern matched arguments, type signature, and\ndocumentation comment:\n\n@\n(defn (:: fib2 (-> Int Int))\n \\\"Documentation comment\\\"\n [0] 0\n [1] 1\n [n] (+ (fib2 (- n 1)) (fib2 (- n 2))))\n@\n\nThe last /fib2/ example is same as below:\n\n@\n(:: fib2 (-> Int Int))\n(:doc^ \\\"Documentation comment\\\")\n(= fib2 0 0)\n(= fib2 1 1)\n(= fib2 n (+ (fib2 (- n 1)) (fib2 (- n 2))))\n@\n\"\n form\n (let ((:: build-decls (-> Code [Code] (Fnk [Code])))\n (= build-decls name\n (let ((= go (: args body rest)\n (do (<- bodies (go rest))\n (return (: `(= ,name ,@args ,body) bodies))))\n (= go [] (pure []))\n (= go _ (finkelSrcError name \"defn: wrong number of forms\")))\n go))\n (:: build-doc (-> (Maybe Code) Code))\n (= build-doc mb-doc\n (case mb-doc\n (Just doc) `((:doc^ ,doc))\n Nothing nil))\n (:: is-tuple (-> FastString Bool))\n (= is-tuple (== (fsLit \",\")))\n (:: is-con (-> Code Bool))\n (= is-con name\n (case (unCode name)\n (Atom (ASymbol n)) (|| (isLexCon n) (is-tuple n))\n _ False))\n (:: build-sig (-> Code Code (Maybe Code) [Code] (Fnk Code)))\n (= build-sig name ty mb-doc bodies0\n (do (<- bodies1 (build-decls name bodies0))\n (return `(:begin\n (:: ,name ,ty)\n ,@(build-doc mb-doc)\n ,@bodies1))))\n (:: build-nosig (-> Code (Maybe Code) [Code] (Fnk Code)))\n (= build-nosig name mb-doc bodies0\n (let ((= go bodies\n (case mb-doc\n Nothing (| ((<- [body] bodies)\n (return body)))\n _ (return `(:begin ,@bodies ,@(build-doc mb-doc))))))\n (>>= (build-decls name bodies0) go)))\n (:: build (-> Code (Maybe Code) [Code] (Fnk Code)))\n (= build sig mb-doc bodies\n (case (unCode sig)\n (List [dc name ty]) (| ((== dc '::)\n (build-sig name ty mb-doc bodies)))\n (List (: name _)) (| ((is-con name)\n (build-nosig sig mb-doc bodies)))\n (Atom _) (build-nosig sig mb-doc bodies)\n (HsList _) (build-nosig sig mb-doc bodies)\n _ (finkelSrcError sig \"defn: invalid signature\"))))\n\n (case (unCode form)\n ;; Declaration of string without documentation need to pattern match\n ;; before declarations with documentation, to support defining plain\n ;; string value without documentation.\n (List [_ sig body])\n (build sig Nothing [nil body])\n\n (List [_ sig (@ doc (LForm (L _ (Atom (AString {}))))) body])\n (build sig (Just doc) [nil body])\n\n (List (: _ sig (@ doc (LForm (L _ (Atom (AString {}))))) rest))\n (build sig (Just doc) rest)\n\n (List (: _ sig arg rest))\n (build sig Nothing (: arg rest))\n\n _ (finkelSrcError form \"defn: invalid form\"))))\n\n(define-macro defn'\n \"Macro to define a function for both of compilation time and load\ntime. This macro uses 'eval_and_compile' and 'defn'.\n\n==== __Syntax__\n\nSee 'defn'.\n\n==== __Examples__\n\nSee 'defn'.\"\n form\n (return `(eval-and-compile\n (defn ,@(cdr form)))))\n\n(define-macro defn-\n \"Macro to define a compilation time only function. This macro uses\n @:eval-when-compile@ and 'defn'.\n\n==== __Syntax__\n\nSee 'defn'.\n\n==== __Examples__\n\nSee 'defn'.\"\n form\n (return `(:eval-when-compile\n (defn ,@(cdr form)))))\n" }, { "path": "finkel-core/src/Finkel/Core/Internal/Stage2.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Stage2 - module containing more macros and functions.\n\n%p(LANGUAGE FlexibleInstances\n TypeSynonymInstances)\n\n(module Finkel.Core.Internal.Stage2\n ;; Macros\n defmodule\n macroexpand macroexpand-1\n exported-macros cond-expand macro-error\n case-do cond heredoc lcase lefn lept\n\n ;; Functions\n is-atom is-pair is-list is-hslist is-symbol is-string is-char\n is-integer is-fractional is-unit\n\n make-symbol mb-symbol-name mb-symbol-name-fs\n\n list (Listable ..)\n\n caar cadr\n caaar caadr cadar caddr\n caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr\n\n cdar cddr\n cdaar cdadr cddar cdddr\n cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr\n\n map1 reduce reduce1 keep curve rev unsnoc trav1 omni omniM\n\n caris\n\n unsafeFinkelSrcError)\n\n;; base\n(import Control.Exception (throw))\n(import Control.Monad (>=> foldM))\n(import Data.Version ((Version ..)))\n(import qualified System.Info)\n\n;; finkel-kernel\n(import Language.Finkel)\n(import Language.Finkel.Form (mkLocatedForm aSymbol genSrc))\n\n;; Internal\n(import Finkel.Core.Internal.Stage0)\n(import Finkel.Core.Internal.Ghc.Version)\n(import Finkel.Core.Internal.Ghc.Compat)\n\n(:require Finkel.Core.Internal.Stage1)\n\n(eval-when [:compile]\n ;; base\n (import Prelude)\n ;; finkel-kernel\n (import Language.Finkel)\n (import Language.Finkel.Form (aSymbol genSrc)))\n\n\n;;; ------------------------------------------------------------------------\n;;;\n;;; Macros\n;;;\n;;; ------------------------------------------------------------------------\n\n(defmacro macro-error\n \"Macro for showing error in macro function. Shows an error message\nwith the location of entire macro form.\n\n==== __Syntax__\n\n> MACRO-ERROR ::= 'macro-error' string\n\n==== __Example__\n\nShow error with non-integer literals:\n\n> (defmacro e1 [a]\n> (case (fromCode a)\n> (Just n) (toCode (:: (+ n 1) Int))\n> _ (macro-error \\\"got non-integer literal\\\")))\n\nSample runs:\n\n>>> (macroexpand '(e1 9))\n10\n>>> (macroexpand '(e1 foo))\n:2:15: error: got non-integer literal\n\"\n [msg]\n `(unsafeFinkelSrcError ,the-macro-arg ,msg))\n\n;;; Expression\n\n(defmacro cond\n \"The 'cond' macro, found in many Lisp languages. The behaviour is same as\nwrapping the body with @case@ expression with dummy unit, or @if@ with\n@MultiWayIf@ GHC language extension.\n\n==== __Syntax__\n\n> COND ::= 'cond' CLAUSE+\n> CLAUSE ::= '(' guard+ expr ')' | '[' guard+ expr ']'\n\n==== __Examples__\n\nSimple function with weird tests:\n\n@\n(defn (:: c01 (-> Int Int Int))\n [a b]\n (cond\n [(even b) b]\n [(odd b) (> a b) b]\n [otherwise a]))\n@\n\nSample run:\n\n>>> (map (c01 5) [1 .. 10])\n[1,2,3,4,5,6,5,8,5,10]\n\"\n body\n `(case ()\n _ ,(cons '| (map1 curve body))))\n\n(defmacroM lcase\n \"Same as @\\\\\\\\case@ enabled with the @LambdaCase@ extension.\n\n==== __Syntax __\n\n> LCASE ::= PAT-EXPR+\n> PAT-EXPR ::= PATTERN EXPR\n\n==== __Example__\n\n>>> (map (lcase 0 \\\"zero\\\" 1 \\\"one\\\" _ \\\"many\\\") [0 1 2 3]\n[\\\"zero\\\", \\\"one\\\", \\\"many\\\",\\\"many\\\"]\n\"\n args\n (do (<- tmp (gensym' \"lcasearg\"))\n (pure `(\\,tmp\n ,(cons 'case (cons tmp args))))))\n\n(defmacroM case-do\n \"Like @case@, but takes an expression with 'Monad' type.\n\n==== __Syntax__\n\n> CASE-DO ::= 'case-do' EXPR PAT-EXPR+\n> PAT-EXPR ::= PATTERN EXPR\n\n==== __Example__\n\nFollowing code:\n\n@\n(case-do getLine\n \\\"hello\\\" (putStrLn \\\"Hi!\\\")\n line (putStrLn (++ \\\"Got: \\\" line)))\n@\n\nIs same as:\n\n@\n(do (<- tmp getLine)\n (case tmp\n \\\"hello\\\" (putStrLn \\\"Hi!\\\")\n line (putStrLn (++ \\\"Got: \\\" line))))\n@\n\"\n args\n (do (<- tmp gensym)\n (return `(do (<- ,tmp ,(car args))\n (case ,tmp ,@(cdr args))))))\n\n(defmacro lefn\n \"Let-fn macro. Like @let@, but bindings take forms used in\n'Finkel.Core.Stage1.defn'.\n\n==== __Syntax__\n\n> LEFN ::= 'lefn' BINDINGS BODY\n> BINDINGS ::= '[' BINDING* ']' | '(' BINDING* ')'\n> BINDING ::= '(' VAR [ARGS] expr ')' | SIG\n> VAR ::= varid | SIG\n> SIG ::= '(' '::' varid type ')'\n> ARGS ::= '[' varid* ']' | '(' varid* ')'\n\n==== __Examples__\n\nFollowing expresion:\n\n@\n(lefn [(x 100)\n (:: f (-> Int Int Int))\n (f [a b]\n (+ (* a b) 2))\n ((:: g (-> Int Int))\n [0] 0\n [n] (+ n 1))]\n (g (f x 3)))\n@\n\nexpands to:\n\n@\n(let ((= x 100)\n (:: f (-> Int Int Int))\n (= f a b\n (+ (* a b) 2))\n (:: g (-> Int Int))\n (= g 0 0)\n (= g n (+ n 1)))\n (g (f x 3)))\n@\"\n args\n ;; Allow empty body to support `lefn' inside `do' syntax.\n (let ((= binds0 (car args))\n (= binds1 (if (|| (is-unit binds0) (null binds0))\n '()\n (curve (map1 (\\bind\n (if (caris ':: bind)\n bind\n (cons 'defn (curve bind))))\n binds0))))\n (= body (cdr args)))\n (cons 'let (cons binds1 body))))\n\n(defmacro lept\n \"Let-pattern macro. Like @let@, but for pattern bindings only, does not\nsupport function bindings. Patterns and expressions are concatenated to make a\nflat bindings list with even number of elements. The pattern in the bindings\nlist could be a varid symbol, or a type signature list form.\n\n==== __Syntax__\n\n> lept ::= 'lept' BINDINGS expr\n> BINDINGS ::= '[' BINDING+ ']' | '(' BINDING+ ')'\n> BINDING ::= PATTERN expr\n> PATTERN ::= varid | '(' '::' varid type ')'\n\n==== __Example__\n\nFollowing expression:\n\n@\n(lept [a 1\n (:: b Int) 2\n (, c d) (, 3 4)\n f (\\\\\\\\ w x y z\n (+ w (* x (+ y z))))]\n (f a b c d))\n@\n\nexpands to:\n\n@\n(let ((= a 1)\n (:: b Int)\n (= b 2)\n (= (, c d) (, 3 4))\n (= f (\\\\\\\\ w x y z\n (+ w (* x (+ y z))))))\n (f a b c d))\n@\"\n args\n (let ((= body (cdr args))\n (= f x (, mb-expr acc)\n (case mb-expr\n (Just expr) (, Nothing\n (if (caris ':: x)\n (: x `(= ,(cadr x) ,expr) acc)\n (: `(= ,x ,expr) acc)))\n Nothing (, (Just x) acc)))\n (= z (, Nothing []))\n (= binds ($ curve toCode snd (reduce f z) car args)))\n (cons 'let (cons binds body))))\n\n;; Auxiliary type for `heredoc'.\n\n(data DocElem\n (Lit String)\n (Var String))\n\n;; Auxliary functions for `heredoc'.\n\n;;; Note [Brace character codes]\n;;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n;;;\n;;; Using #'\\123 for `{', and #'\\125 for `}'. These use of character codes are\n;;; workaround for text editor to avoid mismatching parentheses containing forms\n;;; with literal `{' and `}' characters. When literal characters were handling\n;;; properly, character codes could be replaced with literal braces.\n\n(defn (:: subst (-> Code String [DocElem]))\n [orig str]\n (let ((= go acc xs\n (case xs\n [] acc\n (: #'$ #'$ #'\\123 rest) (case (go acc rest)\n (, tmp ss) (, (: #'$ #'\\123 tmp) ss))\n (: #'$ #'\\123 rest) (let ((= (, var ys) (break (== #'\\125) rest))\n (= (, lit ss) (go acc (drop 1 ys))))\n (if (null var)\n (err \"empty variable\")\n (if (null ys)\n (err \"missing `}'\")\n (, [] (: (Var var)\n (if (null lit)\n ss\n (: (Lit lit) ss)))))))\n (: c rest) (case (go acc rest)\n (, tmp ss) (, (: c tmp) ss))))\n (= err (unsafeFinkelSrcError orig)))\n (case (go (, [] []) str)\n (, xs ss) (if (null xs)\n ss\n (: (Lit xs) ss)))))\n\n(defn (:: doc-elem-to-code (-> DocElem Code))\n [(Lit s)] (toCode s)\n [(Var v)] (make-symbol v))\n\n(defn (:: hdoc (-> [DocElem] Code))\n [es]\n (case es\n [] (toCode \"\")\n [e] (doc-elem-to-code e)\n _ `(<> ,@(map doc-elem-to-code es))))\n\n(defn (:: heredoc-aux (-> Code String Code))\n [orig]\n (. hdoc (subst orig)))\n\n(defmacroM heredoc\n \"Macro for writing literal string value with variable replacements.\n\nThe `heredoc' macro takes single literal string parameter. The format of the\nmacro expanded result preserves newlines and spaces in the input string.\n\nAdditionally, special syntax @${FOO}@ could be used to embed the value of the\nvariable named @FOO@ in the literal string. To write literal @${@, use @$${@.\n\nLiteral strings, new lines and variables are concatenated with `<>'. This will\nenable using other type than `String' which is an instance of\n`Data.String.IsString' and `Semigroup' with @OverloadedStrings@ language\nextension.\n\n==== __Syntax__\n\n> HEREDOC ::= 'heredoc' string\n\n==== __Example__\n\nThe code:\n\n> (defn main\n> (putStrLn (heredoc \\\"foo\n> bar\n> buzz\\\")))\n\nwill print:\n\n> foo\n> bar\n> buzz\n\nAnd the code:\n\n> (defn main\n> (lept [foo \\\"FOO\\\"\n> bar \\\"BAR\\\"]\n> (putStrLn (heredoc \\\"foo is ${foo} and bar is ${bar}\\\"))))\n\nwill print:\n\n> foo is FOO and bar is BAR\n\nUsing `Data.ByteString.ByteString' with @OverloadedStrings@ language extension:\n\n> %p(LANGUAGE OverloadedStrings)\n>\n> (defmodule Main\n> (import\n> (qualified Data.ByteString.Char8)))\n>\n> (defn main\n> (lept [foo \\\"overloaded bytestring\\\"]\n> (Data.ByteString.Char8.putStrLn (heredoc \\\"foo is ${foo}\\\"))))\n\nwill print:\n\n> foo is overloaded bytestring\n\n\"\n [form]\n (case (fromCode form)\n (Just s) (pure (heredoc-aux form s))\n _ (finkelSrcError form \"not a string\")))\n\n;;;; Module header\n\n(defmacroM defmodule\n \"Macro to define header of module named /NAME/. The /IMPEXP/ are forms\nfor imports and exports. Imports and exports forms can appear in any\norder, and starts with one of the following symbols:\n\n[@import@]: The form elements expand to @import@ declaration.\n\n[@import-when@]: Like @import@, but the form elements are wrapped with\n@eval-when@ with given phases.\n\n[@require@]: The form elements expand to @:require@ declaration.\n\n[@require-and-import@]: The form elements are expanded to both\n@import@ and @:require@.\n\n[@export@]: The form elements expand to export entities.\n\n==== __Syntax__\n\n> DEFMODULE ::= 'defmodule' NAME IMPEXP*\n> NAME ::= modid\n> IMPEXP ::= '(' 'import' form+ ')'\n> | '(' 'import-when' phases form+ ')'\n> | '(' 'require' form+ ')'\n> | '(' 'require-and-import' form+ ')'\n> | '(' 'export' form* ')'\n\n==== __Examples__\n\nSample module header:\n\n@\n(defmodule Foo\n (require (Finkel.Prelude hiding (head tail)))\n (import-when [:compile]\n (Control.Monad (foldM)))\n (import (Control.Monad (when))\n (qualified Data.ByteString as BS))\n (export foo bar buzz))\n@\n\nExpands to:\n\n@\n(:begin\n (:require Finkel.Prelude hiding (head tail))\n (module Foo foo bar buzz)\n (eval-when [:compile]\n (import Control.Monad (foldM)))\n (import Control.Monad (when))\n (import qualified Data.ByteString as BS)\n (import Control.Monad (foldM)))\n@\n\"\n form\n (case (unCode form)\n (List [name])\n (return `(module ,name))\n\n (List (: name rest1))\n (do (let ((= merge-sections acc lst\n (let ((= label (car lst))\n (= payload (cdr lst)))\n (case ()\n _ (| ((== label 'export)\n (return\n (if (null (cdr lst))\n (: (, 'export (cons '() nil)) acc)\n (: (, 'export payload) acc))))\n ((|| (== label 'use)\n (== label 'import))\n (return\n (: (, 'import\n (map1 (\\es `(import ,@(curve-el es)))\n payload))\n acc)))\n ((|| (== label 'load)\n (== label 'require))\n (return\n (: (, ':require (map1 (\\es `(:require ,@es))\n payload))\n acc)))\n ((|| (== label 'require-and-import)\n (== label 'load-use))\n (return (: (, 'require-and-import payload) acc)))\n ((== label 'import-when)\n (let ((= phases (car payload))\n (= body0 (cdr payload))\n (= body1 (map1 (\\e `(import ,@(curve-el e)))\n body0)))\n (return (: (, 'eval-when (cons phases body1))\n acc))))\n (otherwise\n (finkelSrcError lst\n \"defmodule: unknown section\"))))))\n (= curve-el\n (map1 curve))))\n (<- alist (foldM merge-sections [] rest1))\n (let ((= emit add-load-too header\n (let ((= e1 (maybe nil id (lookup header alist)))\n (= e2 (maybe nil\n (map1 (\\es `(,header ,@es)))\n (lookup 'require-and-import alist))))\n (if add-load-too\n (mappend e1 e2)\n e1)))))\n (return\n `(:begin\n ,@(emit True ':require)\n\n (module ,name ,@(emit False 'export))\n\n ,@(let ((= evalwhens (filter (\\ (, k _) (== k 'eval-when))\n alist))\n (= f (, _ phases-mdls)\n (let ((= phases (car phases-mdls))\n (= mdls (cdr phases-mdls)))\n `(eval-when ,phases ,@mdls))))\n (map f evalwhens))\n\n ,@(emit True 'import))))\n\n _ (finkelSrcError form \"defmodule: invalid form\")))\n\n\f\n;;; Compilation context macros\n\n(defn (:: cond-expand-aux (-> HscEnv Code (Fnk Code)))\n \"Auxiliary function for `cond-expand'.\"\n [hsc-env]\n (let ((= f x\n (case ()\n _ (| ((== x ':ghc)\n (pure `(:: ,__glasgow_haskell__ Int)))\n ((== x ':os)\n (pure `(:: ,(toCode System.Info.os) String)))\n ((== x ':arch)\n (pure `(:: ,(toCode System.Info.arch) String)))\n ((caris ':min-version x)\n (do (<- v (getPackageVersion hsc-env (cadr x)))\n (pure `(<= (:: [,@(cddr x)] [Int])\n ,(versionBranch v)))))\n (otherwise\n (pure x))))))\n (omniM f)))\n\n(defmacroM cond-expand\n \"Macro for conditional compilation. The `cond-expand' macro has same syntax as\nthe `cond' macro, but the evaluation of the tests are done at compilation\ntime. To gather compilation context information, the tests sections in the\n`cond-expand' macro uses special keywords for getting such information. These\nkeywords are replaced by the described values:\n\n[@:ghc@]: An `Int' value from @__GLASGOW_HASKELL__@, which is the major version\nof the @ghc@ used during the compilation.\n\n[@:arch@]: A `String' value from `System.Info.arch'.\n\n[@:os@]: A `String' value from `System.Info.os'.\n\n[@(:min-version \\\"@PKGNAME@\\\" V1 V2 V3 ...)@]: An expression resulting as a\n`Bool' value. Compares the version of @PKGNAME@ with the version made from\ninteger values @V1@, @V2@, @V3@ and so on. This keyword resembles to the\n@MIN_VERSION@ CPP macro.\n\n==== __Syntax__\n\nSee `cond'.\n\n==== __Examples__\n\nSimple usage to show message:\n\n@\n(defn (:: msg String)\n (cond-expand\n [(<= 810 :ghc)\n \\\"ghc is newer than 8.10.0\\\"]\n [(== 808 :ghc) (== :arch \\\"x86_64\\\") (== :os \\\"linux\\\")\n \\\"ghc version 8.8.x, x86_64-linux\\\"]\n [(:min-version \\\"base\\\" 4 0 0)\n \\\"base version newer than or equals to 4.0.0\\\"]\n [otherwise\n \\\"unknown\\\"]))\n@\n\nWhen compiling above with ghc version @8.8.4@ on @x86_64@ machine running\n@Linux@, the second test will pass and the expanded result would be:\n\n@\n(defn (:: msg String)\n \\\"ghc version 8.8.x, x86_64-linux\\\"\n@\n\"\n forms\n (do (<- tmp (gensym' \"cond-expand-tmp\"))\n (<- hsc-env getSession)\n (let ((= make-quoted-last branches\n (case (unsnoc branches)\n (, bs b) (do (<- bs2 (cond-expand-aux hsc-env bs))\n (pure `(,bs2 ',b)))))))\n (<- body (trav1 make-quoted-last forms))\n (pure `(macrolet [(,tmp []\n (cond ,@body))]\n (,tmp)))))\n\n\f\n;;; Macros for macros\n\n(defmacroM macroexpand-1\n \"Expand given form if the given form is a macro, otherwise return the\ngiven form. Note that 'macroexpand_1' and 'macroexpand' are macros, not\nfunctions.\n\n==== __Syntax__\n\n> MACROEXPAND-1 ::= 'macroexpand-1' form\n\n==== __Examples__\n\n>>> (macroexpand-1 '(defmacrom' m1 [x] `(+ ,x 1)))\n(eval_and_compile\n (defmacro m1 [x]\n (:quasiquote (+ (:unquote x) 1))))\n\"\n [form]\n (case (unCode form)\n (List [q x]) (| ((|| (== q ':quote) (== q ':quasiquote))\n (do (<- expanded (expand1 x))\n (return `',expanded))))\n _ (return form)))\n\n(defmacroM macroexpand\n \"Macro for expanding macro. This macro recursively expands all sub\nforms.\n\n==== __Syntax__\n\n> MACROEXPAND ::= 'macroexpand' form\n\n==== __Examples__\n\n>>> (macroexpand '(defn (:: foo (-> Int Int Int)) [a b] (+ a (* b 2))))\n(:begin\n (:: foo (-> Int Int Int))\n (= foo a b (+ a (* b 2))))\n\"\n [form]\n (case (unCode form)\n (List [q x]) (| ((|| (== q ':quote) (== q ':quasiquote))\n (let ((= go expr\n (do (<- expr' (expand1 expr))\n (if (== expr expr')\n (return `',expr)\n (go expr')))))\n (go x))))\n _ (return form)))\n\n(defmacroM exported-macros\n \"Macro to return macro names exported from given module as a list of\n'String'.\n\n==== __Syntax__\n\n> EXPORTED-MACROS ::= 'exported-macros' modid\n\n==== __Examples__\n\nListing exported macros in \\\"Finkel.Core\\\" module:\n\n>>> (exported-macros Finkel.Core)\n[\\\"eval_when\\\",\\\"eval_and_compile\\\", ...]\n\"\n [name]\n (let ((= f hsc-env mb-thing acc\n (case mb-thing\n (Just (@ thing (AnId var)))\n (| ((isMacro hsc-env thing)\n (: (showSDoc (hsc-dflags hsc-env) (ppr (varName var))) acc)))\n _ acc))\n (= get-exported-names name-str\n (do (<- mdl (lookupModule (mkModuleName name-str) Nothing))\n (<- mb-mod-info (getModuleInfo mdl))\n (case mb-mod-info\n Nothing (return [])\n (Just mi) (do (<- mb-things\n (mapM lookupName (modInfoExports mi)))\n (<- hsc-env getSession)\n (return (foldr (f hsc-env) [] mb-things))))))\n (= invalid-err\n (++ \"exported-macros: got non-module name symbol `\"\n (show name) \"'\"))\n (= toCodes (. toCode (map toCode))))\n (case (mb-symbol-name name)\n (Just name-str) (do (<- names (get-exported-names name-str))\n (return `(:: ,(toCodes names) [String])))\n Nothing (finkelSrcError name invalid-err))))\n\n\n;;; ------------------------------------------------------------------------\n;;;\n;;; Functions\n;;;\n;;; ------------------------------------------------------------------------\n\n\f\n;;; Predicates\n\n(defn (:: is-atom (-> Code Bool))\n \"True when the argument is an 'Atom' or 'nil'.\n\n==== __Examples__\n\n>>> (is-atom \\'foo)\nTrue\n>>> (is-atom nil)\nTrue\n>>> (is-atom '(a b c))\nFalse\n>>> (is-atom '[a b c])\nFalse\"\n [(LForm (L _ form))]\n (case form\n (Atom _) True\n (List []) True\n _ False))\n%p(INLINABLE is-atom)\n\n(defn (:: is-pair (-> Code Bool))\n \"True when the argument is a non-nil 'List'.\"\n [(LForm (L _ (List (: _ _))))] True\n [_] False)\n%p(INLINABLE is-pair)\n\n(macrolet [(defpred [doc name pat]\n `(:begin\n (:doc ,doc)\n (:: ,name (-> Code Bool))\n (= ,name (LForm (L _ form))\n (case form\n ,pat True\n _ False))))]\n (defpred \"True when the argument is a `List'.\"\n is-list (List _))\n (defpred \"True when the argument is a `HsList'.\"\n is-hslist (HsList _))\n (defpred \"True when the argument is an `Atom' of `ASymbol'.\"\n is-symbol (Atom (ASymbol _)))\n (defpred \"True when the argument is an `Atom' of `AString'.\"\n is-string (Atom (AString _ _)))\n (defpred \"True when the argument is an `Atom' of `AChar'.\"\n is-char (Atom (AChar _ _)))\n (defpred \"True when the argument is an `Atom' of `AInteger'.\"\n is-integer (Atom (AInteger _)))\n (defpred \"True when the argument is an `Atom' of `AFractional'.\"\n is-fractional (Atom (AFractional _)))\n (defpred \"True when the argument is an `Atom' of `AUnit'.\"\n is-unit (Atom AUnit)))\n\n(defn (:: caris (-> Code Code Bool))\n \"`True' when the first argument equal to the `car' of the second argument.\n\n==== __Examples__\n\n>>> (caris 'foo '(foo bar buzz))\nTrue\n>>> (caris 'foo '(a b c))\nFalse\n>>> (caris 'foo 'foo)\nFalse\"\n [x lst]\n (&& (is-list lst) (== (car lst) x)))\n%p(INLINABLE caris)\n\n\f\n;;; Symbol functions\n\n(defn (:: make-symbol (-> String Code))\n \"Make an `Atom' of `ASymbol' from given `String'.\"\n (. LForm genSrc Atom aSymbol))\n%p(INLINABLE make-symbol)\n\n(defn (:: mb-symbol-name (-> Code (Maybe String)))\n \"Extract string from given symbol.\n\nGet `Just' `String' when the argument code was an `ASymbol', otherwise\n`Nothing'.\"\n (. (fmap unpackFS) mb-symbol-name-fs))\n%p(INLINABLE mb-symbol-name)\n\n(defn (:: mb-symbol-name-fs (-> Code (Maybe FastString)))\n \"Extract `FastString' from given symbol.\n\nLike `mb_symbol_name', but returns `FastString'\"\n [form]\n (case form\n (LForm (L _ (Atom (ASymbol name)))) (Just name)\n _ Nothing))\n%p(INLINABLE mb-symbol-name-fs)\n\n\f\n;;; Constructing list\n\n(:doc \"Type class for constructing 'List' with polyvariadic function.\")\n(class (Listable l)\n (:: list_ (-> [Code] l)))\n\n(instance (Listable Code)\n (= list_ xs\n (case (mkLocatedForm (reverse xs))\n (L l ys) (LForm (L l (List ys))))))\n\n(instance (=> (Homoiconic elem) (Listable l)\n (Listable (-> elem l)))\n (= list_ acc\n (\\x (list_ (: (toCode x) acc)))))\n\n(defn (:: list (=> (Listable lst) lst))\n \"Make a list from given arguments. This function can take variable number of\narguments, but requires resulting type to be a concrete type.\n\n==== __Examples__\n\n>>> (:: (list \\'a \\'b \\'c) Code)\n(a b c)\n>>> (:: (list \\'a #\\'b \\\"c\\\" (:: 0xd Int)) Code)\n(a #\\'b \\\"c\\\" 13)\"\n (list_ []))\n\n\f\n;;; CXR\n\n(:doc$ cxr \"Rest of /cxr/ functions are composed from 'car' and 'cdr'.\n\nE.g., definition of 'cadr' is:\n\n> (cadr x) == (car (cdr x))\n\nand the definition of 'cdadr' is:\n\n> (cdadr x) == (cdr (car (cdr x)))\n\")\n\n(eval-when [:compile]\n (defn (:: ads [String])\n (let ((= f (concatMap (\\x [(: #'a x) (: #'d x)]))))\n (concat (take 3 (drop 1 (iterate f [[#'a] [#'d]]))))))\n\n (defn (:: cxr-name (-> String Code))\n [x]\n ($ LForm genSrc Atom aSymbol concat [\"c\" x \"r\"]))\n\n (defn (:: doc (-> String Code))\n [xs]\n (let ((= f x (++ \"`c\" x \"r'\"))\n (= g ys (foldr1 (\\y acc (++ y \" of \" acc))\n (map (. f pure) ys))))\n (toCode (++ \"Get the \" (g xs) \".\"))))\n\n (defn (:: cxr (-> String [Code]))\n [xs]\n (let ((= name (cxr-name xs)))\n (case xs\n (: hd tl) [`(:doc ,(doc xs))\n `(:: ,name (-> Code Code))\n `(= ,name (. ,(cxr-name [hd]) ,(cxr-name tl)))\n `%p(INLINABLE ,name)]\n _ (error (++ \"cxr: invalid arg: \" xs)))))\n\n (defmacro cxrs []\n `(:begin ,@(concatMap cxr ads))))\n\n(cxrs)\n\n\f\n;;; List and HsList functions\n\n(defn (:: make-list-fn\n (-> (-> Code b)\n (-> (-> [(LForm a)] (LForm a)) [Code] b)\n Code\n b))\n \"Auxiliary function for making higher order function. Make a function taking\n`SrcSpan' and a list of `Code' from given arguments.\"\n [g f (@ orig (LForm (L l form)))]\n (case form\n (List xs) (f (. LForm (L l) List) xs)\n (HsList xs) (f (. LForm (L l) HsList) xs)\n _ (g orig)))\n%p(INLINE make-list-fn)\n\n(defn (:: map1 (-> (-> Code Code) Code Code))\n \"Like `map', but for `Code'. @map f x@ applies the function @f@ to each\nelement of @x@ when the @x@ is `List' or `HsList'. Otherwise directly applies\n@f@ to @x@.\n\n==== __Examples__\n\n>>> (map1 (\\\\ x `(x is ,x)) '(foo bar buzz))\n((x is foo) (x is bar) (x is buzz))\n>>> (map1 (\\\\ x `(x is ,x)) 'foo)\n(x is foo)\"\n [f] (make-list-fn f (\\c (. c (map f)))))\n%p(INLINABLE map1)\n\n(defn (:: reduce (-> (-> Code a a) a Code a))\n \"Like `foldr', but for `Code'. If the second argument was not a list, applies\nthe function to the second argument and the initial value.\n\n==== __Examples__\n\n>>> (reduce cons nil '(a b c))\n(a b c)\n>>> (reduce (\\\\ x acc (cons `(x is ,x) acc)) nil '(a b c))\n((x is a) (x is b) (x is c))\n>>> (reduce + 0 '(1 2 3 4 5))\n15\n>>> (reduce cons nil 'foo)\n(foo)\"\n [f z] (make-list-fn (flip f z) (\\_ (foldr f z))))\n%p(INLINABLE reduce)\n\n(defn (:: reduce1 (-> (-> Code Code Code) Code Code))\n \"Like `foldr1', but for `Code'. Throws an exception if the second argument\nwas not a list.\n\n==== __Examples__\n\n>>> (reduce1 cons '(a b c))\n(a b c)\n>>> (reduce1 (\\\\ x acc (cons `(x is ,x) acc)) '(a b c))\n((x is a) (x is b) c)\n>>> (reduce1 cons 'foo)\n*** Exception: reduce1: non-list value `foo'\"\n [f] (make-list-fn (non-list \"reduce1\") (\\_ (foldr1 f))))\n%p(INLINABLE reduce1)\n\n(defn (:: keep (-> (-> Code Bool) Code Code))\n \"Like `filter', but for `Code'. Filter out immediate elements of `List' if\nthe test result is `False'.\n\n==== __Examples__\n\n>>> (keep (/= 'a) '(a b r a c a d a b r a))\n(b r c d b r)\n>>> (keep (/= 'a) 'foo)\n*** Exception: keep: non-list value `foo'\"\n [test] (make-list-fn (non-list \"keep\") (\\c (. c (filter test)))))\n%p(INLINABLE keep)\n\n(defn (:: curve (-> Code Code))\n \"Convert `HsList' to `List'. The original value is retained if the given\nargument was not a `HsList' value.\n\n==== __Examples__\n\n>>> (curve '[a b c])\n(a b c)\n>>> (curve 'foo)\nfoo\"\n [(@ orig (LForm (L l form)))]\n (case form\n (HsList xs) (LForm (L l (List xs)))\n _ orig))\n%p(INLINABLE curve)\n\n(defn (:: rev (-> Code Code))\n \"Like `reverse', but for `Code'. Reverse the given `List' or `HsList'. Other\nvalues are kept as-is.\n\n==== __Examples__\n\n>>> (rev '(a b c))\n(c b a)\n>>> (rev 'foo)\nfoo\"\n (make-list-fn id (\\c (. c reverse))))\n%p(INLINABLE rev)\n\n(defn (:: unsnoc (-> Code (, Code Code)))\n \"Split `List' and `HsList' to the elements but last and the last element.\n\n==== __Examples__\n\n>>> (unsnoc '(a b c d e))\n((a b c d),e)\"\n [form]\n (case (rev form)\n mrof (, (rev (cdr mrof)) (car mrof))))\n%p(INLINABLE unsnoc)\n\n(defn (:: trav1 (=> (Applicative f) (-> (-> Code (f Code)) Code (f Code))))\n \"Like `traverse', but for `Code'. Applies given function to the direct element\nof the given `Code'.\n\n==== __Examples__\n\n>>> (trav1 (\\\\ x (>> (print x) (pure x))) '(a (b c) d))\na\n(b c)\nd\n(a (b c) d)\n>>> (trav1 Just 'foo)\nJust foo\"\n [f] (make-list-fn f (\\c (. (fmap c) (traverse f)))))\n%p(INLINABLE trav1)\n\n(defn (:: omni (-> (-> Code Code) Code Code))\n \"Applies given function to every elements.\n\n==== __Examples__\n\n>>> (omni (\\\\ x (if (== 'foo x) 'bar x)) '(a foo (foo b c) (d foo)))\n(a bar (bar b c) (d bar))\n>>> (omni (\\\\ x (if (caris 'foo x) (cons 'bar (cdr x)) x)) '(a foo (foo b c) (d foo)))\n(a foo (bar b c) (d foo))\n>>> (omni (\\\\ x (if (== x 'foo) 'bar x)) 'foo)\nbar\n>>> (omni (\\\\ x (if (== x 'foo) 'bar x)) nil)\nnil\"\n [f]\n (make-list-fn f (\\c (. f c (map (omni f))))))\n%p(INLINABLE omni)\n\n(defn (:: omniM (=> (Monad m) (-> (-> Code (m Code)) Code (m Code))))\n \"Applies given monadic function to every elements.\n\n==== __Examples__\n\n>>> (omniM (\\\\ x (>> (print x) (return x))) '(a (b c) d))\na\nb\nc\n(b c)\nd\n(a (b c) d)\n(a (b c) d)\n\"\n [f]\n (make-list-fn f (\\c (>=> (traverse (omniM f)) (. f c)))))\n%p(INLINABLE omniM)\n\n;;; Error\n\n(defn (:: unsafeFinkelSrcError (-> Code String a))\n \"Throw exception with 'FinkelSrcError', with given code and message. This\nfunction uses `Control.Exception.throw' from the @base@ package.\"\n (. (fmap throw) FinkelSrcError))\n" }, { "path": "finkel-core/src/Finkel/Core/Internal.hs", "content": ";;; -*- mode: finkel -*-\n;;;; For internal types and functions\n\n(:doc \"Module to re-export internal types and functions.\n\nThe intended usage is for internal use only, from test codes and from the\n@finkel-tool@ package.\")\n\n(module Finkel.Core.Internal\n (:dh1 \"For GHC\")\n (module Finkel.Core.Internal.Ghc))\n\n(import Finkel.Core.Internal.Ghc)\n" }, { "path": "finkel-core/src/Finkel/Core/Plugin.hs", "content": ";;; -*- mode: finkel -*-\n\n(:doc \"GHC plugin for compiling Finkel source codes.\")\n\n(module Finkel.Core.Plugin\n plugin\n coreFnkEnv)\n\n;;; finkel-kernel\n(import Language.Finkel (defaultFnkEnv))\n(import Language.Finkel.Fnk ((FnkEnv ..) (FnkInvokedMode ..)\n makeEnvMacros mergeMacros))\n(import Language.Finkel.Plugin (pluginWith))\n(import Language.Finkel.SpecialForms (specialForms))\n\n;;; Internal\n(import Finkel.Core)\n(import Finkel.Core.Internal.Ghc)\n\n;;; Compile time modules\n\n(:require Finkel.Core)\n\n(:eval-when-compile\n (import Prelude)\n (import Language.Finkel)\n (import Finkel.Core.Internal.Stage2))\n\n;;; The plugin function\n\n(:doc \"The plugin to compile Finkel source code.\n\nThis plugin could not be loaded before the /downsweep/ phase of the ghc\ncompilation manager, need other way to parse the module header to resolve the\nhome package module dependencies.\")\n(:: plugin Plugin)\n(= plugin (pluginWith \"Finkel.Core.Plugin\" coreFnkEnv))\n\n(:doc \"The `FnkEnv' containing the macros from `Finkel.Core'.\")\n(:: coreFnkEnv FnkEnv)\n(= coreFnkEnv\n (macrolet [(core-macros ()\n `[,@(map (\\mac `(, ,mac ,(make-symbol mac)))\n (exported-macros Finkel.Core))])]\n (let ((= coreMacros (makeEnvMacros (core-macros)))\n (= myMacros (mergeMacros specialForms coreMacros)))\n (defaultFnkEnv {(= envMacros myMacros)\n (= envDefaultMacros myMacros)\n (= envInvokedMode GhcPluginMode)}))))\n" }, { "path": "finkel-core/src/Finkel/Core.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Finkel core language macros\n\n(:doc \"Core language macros.\n\nMacros exported from this module are available in the @finkel@ executable by\ndefault, i.e., available without /require/-ing the \\\"Finkel.Core\\\" module.\")\n\n(module Finkel.Core\n (:dh1 \"Phase control\")\n eval-when eval-and-compile\n\n (:dh1 \"Module header\")\n defmodule\n\n (:dh1 \"Macro for macros\")\n defmacro defmacro' defmacro- defmacroM defmacroM' defmacroM-\n\n (:dh1 \"Temporary macros\")\n macrolet macroletM\n\n (:dh1 \"Declaring functions\")\n defn defn' defn-\n\n (:dh1 \"Expanding macros\")\n macroexpand macroexpand-1 exported-macros\n\n (:dh1 \"Compilation context macros\")\n cond-expand\n\n (:dh1 \"Error macro\")\n macro-error\n\n (:dh1 \"Expressions\")\n case-do cond heredoc lcase lefn lept)\n\n;; Internal\n(import Finkel.Core.Internal.Stage1)\n(import Finkel.Core.Internal.Stage2)\n" }, { "path": "finkel-core/src/Finkel/Prelude.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Prelude module for Finkel.\n\n(:doc \"Module exporting fundamental functions to work with Finkel macros.\n\nThis module does not export macros, but functions to work with `Code' values for\ndefining macros. Intended usage is to import during compilation:\n\n> (defmodule MyModule\n> (import-when [:compile]\n> (Finkel.Prelude))\n> ...)\n\nto use functions for `Code', such as `cons', `car', `cdr', and so on.\")\n\n(module Finkel.Prelude\n (:dh1 \"Re-exported modules\")\n (module Me))\n\n(import Prelude as Me) ; base\n(import Language.Finkel as Me) ; finkel-kernel\n(import Finkel.Core.Functions as Me) ; Internal\n" }, { "path": "finkel-core/test/CoreTest.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Module to test macros.\n\n(:require Finkel.Core)\n\n(defmodule CoreTest\n (export coreTests\n macroTests)\n (require\n ;; Internal\n (TestAux))\n (import-when [:compile]\n ;; Internal\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Exception [(SomeException)])\n (Data.List [isSubsequenceOf])\n (System.Info [os arch])\n\n ;; hspec\n (Test.Hspec)\n\n ;; finkel-kernel\n (Language.Finkel)\n (Language.Finkel.Form [aString aIntegral])\n (Language.Finkel.Fnk [(FnkEnv ..) makeEnvMacros mergeMacros])\n\n ;; finkel-core\n (Finkel.Core)\n (Finkel.Core.Functions [cadr])\n (Finkel.Core.Internal)\n\n ;; Internal\n (TestAux)))\n\n(defn (:: coreTests Spec)\n (describe \"Macro\" macroTests))\n\n(defn (:: subseqErr (-> String SomeException Bool))\n [str e]\n (isSubsequenceOf str (show e)))\n\n(defn (:: macroTests Spec)\n (do\n (describe \"eval-when\"\n (do\n (it \"should expand to (:begin (:eval-when-compile ...) ...)\"\n (expandTo\n (eval-when (:compile :load)\n (:: foo Int)\n (= foo 42))\n (:begin\n (:eval-when-compile\n (:: foo Int)\n (= foo 42))\n (:: foo Int)\n (= foo 42))))\n (it \"should expand to (:eval-when-compile ...)\"\n (expandTo\n (eval-when (:compile)\n (:: foo Int)\n (= foo 42))\n (:eval-when-compile\n (:: foo Int)\n (= foo 42))))\n (it \"should expand to (:begin ...)\"\n (expandTo\n (eval-when (:load)\n (:: foo Int)\n (= foo 42))\n (:begin\n (:: foo Int)\n (= foo 42))))\n (it \"should support phases in bracket\"\n (expandTo\n (eval-when [:compile :load]\n (= foo True))\n (:begin\n (:eval-when-compile\n (= foo True))\n (= foo True))))\n (it \"throws an exception with unknown phase\"\n (expandFailureWith\n (eval-when (:foo :bar :buzz)\n (:: foo Int)\n (= foo 42))\n (subseqErr \"invalid phase\")))\n (it \"throws and exception on non-list phase\"\n (expandFailureWith\n (eval-when :compile\n (:: foo Int)\n (= foo 42))\n (subseqErr \"eval-when\")))))\n\n (describe \"eval-and-compile\"\n (it \"should expand to (eval-when ...)\"\n (expandTo\n (eval-and-compile\n (:: foo Int)\n (= foo 42))\n (eval-when [:compile :load]\n (:: foo Int)\n (= foo 42)))))\n\n (describe \"defmacroM\"\n (do (it \"should expand to Macro\"\n (expandTo\n (defmacroM m1 (a)\n (return `(putStrLn (++ \"hello, \" ,a))))\n (:begin\n (:: m1 Macro)\n (= m1\n (let ((:: $tmp (-> Code (Fnk Code)))\n (= $tmp __form__\n (case __form__\n (LForm (L _loc (List [_ a])))\n (let ((= $tmp\n (return\n (:quasiquote\n (putStrLn\n (++ \"hello, \" (:unquote a)))))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `m1'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $tmp))))))\n (it \"should replace nil arg with _\"\n (expandTo\n (defmacroM m1 ()\n (return `(print True)))\n (:begin\n (:: m1 Macro)\n (= m1\n (let ((:: $tmp (-> Code (Fnk Code)))\n (= $tmp __form__\n (case __form__\n (LForm (L _loc (List [_])))\n (let ((= $tmp\n (return (:quasiquote (print True)))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `m1'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $tmp))))))\n (it \"should expand symbol arg to rest\"\n (expandTo\n (defmacroM m1 args\n (return `(print ,@args)))\n (:begin\n (:: m1 Macro)\n (= m1\n (let ((:: $tmp (-> Code (Fnk Code)))\n (= $tmp __form__\n (case __form__\n (LForm (L $loc (List (: _ __arg__))))\n (let ((= args\n (LForm (L $loc (List __arg__))))\n (= $tmp (return\n (:quasiquote\n (print\n (:unquote-splice args))))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `m1'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $tmp))))))\n (it \"should allow names with operator symbol\"\n (expandTo\n (defmacroM $$$ ()\n (return `(print True)))\n (:begin\n (:: $$$ Macro)\n (= $$$\n (let ((:: $tmp (-> Code (Fnk Code)))\n (= $tmp __form__\n (case __form__\n (LForm (L _loc (List [_])))\n (let ((= $tmp\n (return (:quasiquote (print True)))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `$$$'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $tmp))))))\n (it \"should replace gensym name with hyphens\"\n (expandTo\n (defmacroM m1 [a]\n (return `(let ((= $b-c-d (* ,a 2)))\n (+ $b-c-d $b-c-d))))\n (:begin\n (:: m1 Macro)\n (= m1\n (let ((:: $tmp (-> Code (Fnk Code)))\n (= $tmp __form__\n (case __form__\n (LForm (L _loc (List [_ a])))\n (let ((= $tmp\n (return (:quasiquote\n (let ((= $b_c_d\n (* (:unquote a) 2)))\n (+ $b_c_d $b_c_d))))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `m1'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $tmp))))))\n (it \"should not replace operator starting with `$'\"\n (expandTo\n (defmacroM m1 [a]\n (return `($$ print show ,a)))\n (:begin\n (:: m1 Macro)\n (= m1\n (let ((:: $tmp (-> Code (Fnk Code)))\n (= $tmp __form__\n (case __form__\n (LForm (L _loc (List [_ a])))\n (let ((= $tmp\n (return\n (:quasiquote\n ($$ print show (:unquote a))))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `m1'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $tmp))))))\n (it \"should expand documentation arg\"\n (expandTo\n (defmacroM m1 \"doccomments\" [] (return '(print True)))\n (:begin\n (:: m1 Macro)\n (:doc^ \"doccomments\")\n (= m1\n (let ((:: $tmp (-> Code (Fnk Code)))\n (= $tmp __form__\n (case __form__\n (LForm (L _loc (List [_])))\n (let ((= $tmp\n (return (:quote (print True)))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `m1'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $tmp_12Jw))))))\n (it \"should detect invalid arg\"\n (expandFailureWith\n (defmacroM m1 \"string\"\n (return 'True))\n (subseqErr \"defmacroM\")))\n (it \"should detect invalid form\"\n (expandFailure\n (defmacroM m1 too many parameters passed)))\n (it \"should detect invalid doc arg\"\n (expandFailure\n (defmacroM m1 [a b] [c d] `[,a ,b ,c ,d])))))\n\n (describe \"defmacroM'\"\n (it \"expands to (eval-when (...) (defmacroM ...))\"\n (expandTo\n (defmacroM' m1 (a)\n `(return (putStrLn ,a)))\n (eval-and-compile\n (defmacroM m1 (a)\n (:quasiquote (return (putStrLn (:unquote a)))))))))\n\n (describe \"defmacroM-\"\n (it \"expands to (:eval-when-compile (defmacroM ...)\"\n (expandTo\n (defmacroM- m1 [a]\n (return `(putStrLn ,a)))\n (:eval-when-compile\n (defmacroM m1 [a]\n (return (:quasiquote (putStrLn (:unquote a)))))))))\n\n (describe \"defmacro\"\n (do\n (it \"should expand to defmacroM\"\n (expandTo\n (defmacro m1 (a)\n `(putStrLn (++ \"hello, \" ,a)))\n (:begin\n (:: m1 Macro)\n (= m1\n (let ((:: $tmp (-> Code (Fnk Code)))\n (= $tmp __form__\n (case __form__\n (LForm (L _loc (List [_ a])))\n (let ((= $tmp\n (return\n (:quasiquote\n (putStrLn (++ \"hello, \" (:unquote a)))))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `m1'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $tmp))))))\n (it \"should fail with invalid form\"\n (expandFailureWith\n (defmacro m1 [arg1 arg2]\n too many body forms)\n (subseqErr \"defmacro\")))))\n\n (describe \"defmacro'\"\n (it \"expands to (eval-and-compile (...) (defmacro ...))\"\n (expandTo\n (defmacro' m1 (a)\n `(putStrLn ,a))\n (eval-and-compile\n (defmacro m1 (a)\n (:quasiquote (putStrLn (:unquote a))))))))\n\n (describe \"defmacro-\"\n (it \"expands to (:eval-when-compile (...) (defmacro ...))\"\n (expandTo\n (defmacro- m1 (a)\n `(putStrLn ,a))\n (:eval-when-compile\n (defmacro m1 (a)\n (:quasiquote (putStrLn (:unquote a))))))))\n\n (describe \"macro containing `$foo'\"\n (it \"should replace `$foo' with gensym\"\n (do (let ((= f code\n (runFnk (macroFunction defmacroM code)\n defaultFnkEnv))))\n (<- e (f '(defmacroM m1 (a b)\n (let ((= $foo (+ ,a ,b)))\n (return $foo)))))\n (shouldNotBe (elem (ASymbol (fsLit \"$foo\")) e)\n True))))\n\n (describe \"macroletM\"\n (do\n (it \"should expand to :with-macro\"\n (expandTo\n (macroletM [(m1 [a b]\n (return `(+ ,a ,b)))]\n (m1 20 22))\n (:with-macro\n ((= m1\n (let ((:: $m1 (-> Code (Fnk Code)))\n (= $m1 __form__\n (case __form__\n (LForm (L _loc (List [_ a b])))\n (let ((= $tmp\n (return\n (:quasiquote\n (+ (:unquote a) (:unquote b))))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `m1'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $m1))))\n (m1 20 22))))\n (it \"should replace () arg with _\"\n (expandTo\n (macroletM ((m1 ()\n (return `(print #'x))))\n (m1))\n (:with-macro ((= m1\n (let ((:: $m1 (-> Code (Fnk Code)))\n (= $m1 __form__\n (case __form__\n (LForm (L _loc (List [_])))\n (let ((= $tmp\n (return\n (:quasiquote (print #'x)))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `m1'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $m1))))\n (m1))))\n (it \"should detect invalid form\"\n (expandFailureWith\n (macroletM)\n (subseqErr \"macroletM\")))\n (it \"should detect invalid local macro form\"\n (expandFailureWith\n (macroletM ((m1 ()\n foo bar buzz))\n (m1))\n (subseqErr \"invalid form\")))))\n\n (describe \"macrolet\"\n (do\n (it \"should expand to macro with `return'\"\n (expandTo\n (macrolet ((m (a b)\n `(+ ,a ,b)))\n (m 20 22))\n (:with-macro\n ((= m (let ((:: $m (-> Code (Fnk Code)))\n (= $m __form__\n (case __form__\n (LForm (L _loc (List [_ a b])))\n (let ((= $tmp\n (return\n (:quasiquote (+ (:unquote a)\n (:unquote b))))))\n $tmp)\n _ (finkelSrcError\n __form__\n (++ \"in macro `m'\\ninvalid form: `\"\n (show __form__) \"'\")))))\n (Macro $m))))\n (m 20 22))))\n (it \"should detect invalid form\"\n (expandFailureWith\n (macrolet)\n (subseqErr \"macrolet\")))))\n\n (describe \"macro-error\"\n (it \"should expand to (unsafeFinkelSrcError ...)\"\n (expandTo\n (macro-error \"message\")\n (unsafeFinkelSrcError __form__ \"message\"))))\n\n (describe \"defn\"\n (do\n (it \"should expand to function declaration\"\n (expandTo\n (defn foo (a b) (+ a b))\n (= foo a b (+ a b))))\n (it \"should expand to function with type signature\"\n (expandTo\n (defn (:: foo (-> Int Int Int)) (a b)\n (+ a b))\n (:begin\n (:: foo (-> Int Int Int))\n (= foo a b (+ a b)))))\n (it \"should expand to function with no arguments\"\n (expandTo\n (defn foo 42)\n (= foo 42)))\n (it \"should expand to string\"\n (expandTo\n (defn foo \"bar\")\n (= foo \"bar\")))\n (it \"should expand to pattern match for `Just'\"\n (expandTo\n (defn (Just foo) (pure True))\n (= (Just foo) (pure True))))\n (it \"should expand to pattern match for list\"\n (expandTo\n (defn [a b c] [\"foo\" \"bar\" \"buzz\"])\n (= [a b c] [\"foo\" \"bar\" \"buzz\"])))\n (it \"should expand to pattern match for list with rest\"\n (expandTo\n (defn (: a b c _) [1 2 ..])\n (= (: a b c _) [1 2 ..])))\n (it \"should expand to pattern match for tuple\"\n (expandTo\n (defn (, a b c) (, True #'x \"string\"))\n (= (, a b c) (, True #'x \"string\"))))\n (it \"should expand argument patterns\"\n (expandTo\n (defn foo\n [a 0] (* a 2)\n [a b] (+ a b))\n (:begin\n (= foo a 0 (* a 2))\n (= foo a b (+ a b)))))\n (it \"should expand argument patterns with type signature\"\n (expandTo\n (defn (:: foo (-> Int Int Int))\n [a 0] (* a 2)\n [a b] (+ a b))\n (:begin\n (:: foo (-> Int Int Int))\n (= foo a 0 (* a 2))\n (= foo a b (+ a b)))))\n (it \"should expand doc without type signature\"\n (expandTo\n (defn foo \"doc\" 42)\n (:begin\n (= foo 42)\n (:doc^ \"doc\"))))\n (it \"should expand doc with type signature\"\n (expandTo\n (defn (:: foo Int) \"doc\" 42)\n (:begin\n (:: foo Int)\n (:doc^ \"doc\")\n (= foo 42))))\n\n (it \"should detect invalid form\"\n (expandFailureWith\n (defn foo)\n (subseqErr \"defn\")))\n (it \"should fail on invalid signature\"\n (expandFailureWith\n (defn (foo (Int) (Int)) (a b)\n (+ a b))\n (subseqErr \"invalid signature\")))\n (it \"should fail on odd number of body forms\"\n (expandFailureWith\n (defn (:: foo (-> Int Int))\n 0 1\n 2 3\n 4)\n (subseqErr \"wrong number of forms\")))))\n\n (describe \"defn'\"\n (it \"should expand to (eval-and-compile (..) (defn ...))\"\n (expandTo\n (defn' foo (a b)\n (+ a b))\n (eval-and-compile\n (defn foo (a b)\n (+ a b))))))\n\n (describe \"defn-\"\n (it \"should expand to (:eval-when-compile (defn ...))\"\n (expandTo\n (defn- foo [a b]\n (+ a b))\n (:eval-when-compile\n (defn foo [a b]\n (+ a b))))))\n\n (describe \"cond\"\n (it \"should expand to case\"\n (expandTo\n (cond [(even x) 0] [otherwise 1])\n (case () _ (| ((even x) 0) (otherwise 1))))))\n\n (describe \"lcase\"\n (it \"should expand to lambda with case\"\n (expandTo\n (lcase (Right a) \"a\" (Left b) \"b\")\n (\\ $tmp (case $tmp (Right a) \"a\" (Left b) \"b\")))))\n\n (describe \"case-do\"\n (it \"should expand to do with case\"\n (expandTo\n (case-do getLine\n \"hello\" (putStrLn \"hi\")\n line (putStrLn (++ \"Got: \" line)))\n (do (<- $tmp getLine)\n (case $tmp\n \"hello\" (putStrLn \"hi\")\n line (putStrLn (++ \"Got: \" line)))))))\n\n (describe \"heredoc\"\n (do\n (it \"should expand to literal string\"\n (expandTo\n (heredoc \"literal string\")\n \"literal string\"))\n\n (it \"should concat multiple lines\"\n (cond-expand\n [(== :os \"mingw32\")\n (expandTo\n (heredoc \"foo\n bar\n buzz\")\n \"foo\\r\\n bar\\r\\n buzz\")]\n [otherwise\n (expandTo\n (heredoc \"foo\n bar\n buzz\")\n \"foo\\n bar\\n buzz\")]))\n\n (it \"should preserve newline at the end\"\n (cond-expand\n [(== :os \"mingw32\")\n (expandTo\n (heredoc \"foo\n\")\n \"foo\\r\\n\")]\n [otherwise\n (expandTo\n (heredoc \"foo\n\")\n \"foo\\n\")]))\n (it \"should replace variable\"\n (expandTo\n (heredoc \"foo is ${foo}\")\n (<> \"foo is \" foo)))\n (it \"should replace multiple variables\"\n (expandTo\n (heredoc \"foo=${foo} bar=${bar} buzz=${buzz}\")\n (<> \"foo=\" foo \" bar=\" bar \" buzz=\" buzz)))\n (it \"should replace variable without literal\"\n (expandTo\n (heredoc \"${foo}\")\n foo))\n (it \"should escape variable replacement\"\n (expandTo\n (heredoc \"escaping $${var}\")\n \"escaping ${var}\"))\n (it \"should result to empty string\"\n (expandTo\n (heredoc \"\")\n \"\"))\n\n (it \"should show error with empty variable name\"\n (expandFailureWith\n (heredoc \"empty var ${}\")\n (subseqErr \"empty variable\")))\n (it \"should show error with unbalanced brace\"\n (expandFailureWith\n (heredoc \"unbalanced ${foo\")\n (subseqErr \"missing\")))\n (it \"should show error on non-string parameters\"\n (expandFailureWith\n (heredoc 42)\n (subseqErr \"not a string\")))))\n\n (describe \"lefn\"\n (do (it \"should expand to let\"\n (expandTo\n (lefn [(v1 1)\n ((:: v2 Int) 2)\n (:: f (-> Int Int))\n (f\n [0] 0\n [1] 1\n [n] (+ (f (- n 1)) (f (- n 2))))\n ((:: g (-> Int Int))\n [n]\n (+ n 1))]\n (f (g (+ v1 v2))))\n (let ((defn v1 1)\n (defn (:: v2 Int) 2)\n (:: f (-> Int Int))\n (defn f\n [0] 0\n [1] 1\n [n] (+ (f (- n 1)) (f (- n 2))))\n (defn (:: g (-> Int Int))\n [n]\n (+ n 1)))\n (f (g (+ v1 v2))))))\n (it \"should expand to let without body\"\n (expandTo\n (lefn [(a 1) (b 2)])\n (let ((defn a 1) (defn b 2)))))\n (it \"should expand to let with empty binds\"\n (expandTo\n (lefn [] True)\n (let () True)))\n (it \"should expand to let with units\"\n (expandTo\n (lefn () True)\n (let () True)))))\n\n (describe \"lept\"\n (do (it \"should expand to let\"\n (expandTo\n (lept [a 1 b 2 c 3]\n (+ a b c))\n (let ((= a 1) (= b 2) (= c 3))\n (+ a b c))))\n (it \"should expand to let with signatures\"\n (expandTo\n (lept [(:: a Int) 1 (:: b Double) 1]\n (>> (print a) (print b)))\n (let ((:: a Int)\n (= a 1)\n (:: b Double)\n (= b 1))\n (>> (print a) (print b)))))))\n\n (describe \"macroexpand-1\"\n (do (it \"should expand to '(toCode 3)\"\n (expandTo\n (macroexpand-1 '(:quasiquote (:unquote 3)))\n '(toCode 3)))\n (it \"should expand to '(toCode 4)\"\n (expandTo\n (macroexpand-1 `(:quasiquote (:unquote 4)))\n '(toCode 4)))\n (it \"should expand to (car nil)\"\n (expandTo\n (macroexpand-1 (car nil)) (car nil)))\n (it \"should expand to itself\"\n (expandTo (macroexpand-1 42) 42))\n\n (it \"should expand to form containing :begin\"\n (lept [m1 (Macro (\\form\n (return `(:begin\n (:: foo String)\n (= foo ,(show (cadr form)))))))\n my-macros (mergeMacros\n (envMacros defaultFnkEnv)\n (makeEnvMacros [(, \"m1\" m1)]))\n my-env (defaultFnkEnv {(= envMacros my-macros)})]\n (expand-form-with-env my-env\n shouldBe\n macroexpand-1\n '(macroexpand-1 '(m1 True))\n '(:quote (:begin\n (:: foo String)\n (= foo \"True\"))))))))\n\n (describe \"macroexpand\"\n (do (it \"should expand to '(toCode 3)\"\n (expandTo\n (macroexpand '(:quasiquote (:unquote 3)))\n '(toCode 3)))\n (it \"should expand to '(toCode 4)\"\n (expandTo\n (macroexpand `(:quasiquote (:unquote 4)))\n '(toCode 4)))\n (it \"should expand to (car nil)\"\n (expandTo\n (macroexpand (car nil)) (car nil)))\n (it \"should expand to itself\"\n (expandTo (macroexpand 42) 42))))\n\n (describe \"defmodule\"\n (do (it \"should expand to module header\"\n (expandTo\n (defmodule Foo\n (export (FooClass ..) f1 f2)\n (require\n (Data.Maybe)\n (Data.List))\n (require-and-import\n (Control.Monad))\n (import (qualified Foo.Types as Types)\n (Foo.Buzz (buzz1 buzz2))))\n (:begin\n (:require Data.Maybe)\n (:require Data.List)\n (:require Control.Monad)\n (module Foo (FooClass ..) f1 f2)\n (import qualified Foo.Types as Types)\n (import Foo.Buzz (buzz1 buzz2))\n (import Control.Monad))))\n (it \"should ignore export when not given\"\n (expandTo\n (defmodule Foo\n (require (Data.Maybe))\n (import (Control.Monad)))\n (:begin\n (:require Data.Maybe)\n (module Foo)\n (import Control.Monad))))\n (it \"should import when compile\"\n (expandTo\n (defmodule Foo\n (import-when [:compile]\n (Prelude)\n (Language.Finkel))\n (import\n (Control.Monad)))\n (:begin\n (module Foo)\n (eval-when [:compile]\n (import Prelude)\n (import Language.Finkel))\n (import Control.Monad))))\n (it \"should export nothing\"\n (expandTo\n (defmodule Foo\n (import (Control.Monad))\n (export))\n (:begin\n (module Foo ())\n (import Control.Monad))))\n (it \"should expand to plain (module ...)\"\n (expandTo\n (defmodule Foo)\n (module Foo)))\n (it \"should convert [] to () for entity list\"\n (expandTo\n (defmodule Foo\n (import\n (Prelude [tail head read])))\n (:begin\n (module Foo)\n (import Prelude (tail head read)))))\n (it \"should fail on unknown section\"\n (expandFailureWith\n (defmodule Foo\n (bar-buzz-quux\n (Control.Monad)))\n (subseqErr \"unknown section\")))\n (it \"should fail on too few parameters\"\n (expandFailure\n (defmodule)))))\n\n (describe \"cond-expand\"\n (do (it \"should contain compile time information\"\n (expandWithPackageDbSatisfy\n (cond-expand\n [(<= 700 :ghc) (== :arch \"x86_64\") (== :os \"linux\")\n (:min-version \"base\" 3 99 99)\n \"ghc newer than 7.0.0, x86_64-linux, base > 3.99.99\"]\n [otherwise\n \"other\"])\n (\\form\n (&& (elem (aIntegral __glasgow_haskell__) form)\n (elem (aString NoSourceText arch) form)\n (elem (aString NoSourceText os) form)\n (elem (aString NoSourceText \"other\") form)\n\n ;; Below test works when using \"base-4.x.x\" package.\n (elem (aIntegral (:: 4 Int)) form)))))\n\n (it \"should fail with non-string package\"\n (expandFailureWith\n (cond-expand\n [(:min-version 0xdeadbeaf 1 2 3)\n \"3735928495\"]\n [otherwise\n \"No such package\"])\n (\\e\n (&& (subseqErr \"want package name\" e)\n (subseqErr \"3735928495\" e)))))\n (it \"should fail with non-existing package\"\n (expandWithPackageDbFailure\n (cond-expand\n [(:min-version \"no-such-package\" 2 4 0)\n \"Found no-such-package\"]\n [otherwise\n \"No such package\"])\n (\\e\n (&& (subseqErr \"cannot find package\" e)\n (subseqErr \"no-such-package\" e)))))))))\n" }, { "path": "finkel-core/test/FunctionTest.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Module to test functions\n\n(:require Finkel.Core)\n\n(defmodule FunctionTest\n (export functionTests\n cxrTests\n listTests)\n (require\n ;; finkel-core\n (Finkel.Core.Internal))\n (import\n ;; base\n (Data.List [isSubsequenceOf])\n\n ;; finkel-kernel\n (Language.Finkel)\n\n ;; hspec\n (Test.Hspec)\n\n ;; quickcheck\n (Test.QuickCheck)\n\n ;; Internal\n (Finkel.Prelude)\n (Orphan [])))\n\n(defn (:: functionTests Spec)\n (do (describe \"Error\" errorTests)\n (describe \"Cxr\" cxrTests)\n (describe \"List\" listTests)))\n\n(defn (:: errorTests Spec)\n (describe \"unsafeFinkelSrcError\"\n (it \"should throw src error\"\n (lept [(:: srcError (-> FinkelException Bool))\n (. (isSubsequenceOf \"foo\") show)]\n (shouldThrow (unsafeFinkelSrcError nil \"foo\") srcError)))))\n\n(defn (:: cxrTests Spec)\n (do (lept [d describe\n t 't\n tt '(t t)\n caxr (. (it \"should be t\") (== 't))\n cdxr (. (it \"should be (t t)\") (== '(t t)))])\n (d \"car\"\n (do (caxr (car (cons t tt)))\n (it \"returns t when arg was '[t t]\"\n (== (car '[t t]) t))\n (it \"returns nil when arg was nil\"\n (== (car nil) nil))\n (it \"returns nil when arg was '[]\"\n (== (car '[]) nil))\n (it \"should show error when applied to non-list\"\n (expectFailure (=== nil (car 'foo))))))\n (d \"cdr\"\n (do (cdxr (cdr (cons t tt)))\n (it \"returns '(t) when arg was '[t t]\"\n (== (cdr '[t t]) '(t)))\n (it \"returns nil when arg was nil\"\n (== (cdr nil) nil))\n (it \"returns nil when arg was '[]\"\n (== (cdr '[]) nil))\n (it \"should show error when applied to non-list\"\n (expectFailure (=== nil (cdr 'foo))))))\n\n (d \"caar\"\n (caxr (caar '((t _) _ _ _))))\n (d \"cadr\"\n (caxr (cadr '(_ t _ _ _))))\n (d \"cdar\"\n (cdxr (cdar '((_ t t) _ _ _))))\n (d \"cddr\"\n (cdxr (cddr '((_ _ _) _ t t))))\n\n (d \"caaar\"\n (caxr (caaar '(((t _) _ _) _ _ _))))\n (d \"caadr\"\n (caxr (caadr '(_ (t _ _) _ _))))\n (d \"cadar\"\n (caxr (cadar '((_ t _) _ _ _))))\n\n (d \"caddr\"\n (caxr (caddr '(_ _ t _))))\n (d \"cdaar\"\n (cdxr (cdaar '(((_ t t) _) _))))\n (d \"cdadr\"\n (cdxr (cdadr '(_ (_ t t) _))))\n (d \"cddar\"\n (cdxr (cddar '((_ _ t t) _))))\n (d \"cdddr\"\n (cdxr (cdddr '(_ _ _ t t))))\n\n (d \"caaaar\"\n (caxr (caaaar '((((t _) _) _) _))))\n (d \"caaadr\"\n (caxr (caaadr '(_ ((t _) _)))))\n (d \"caadar\"\n (caxr (caadar '((_ (t _)) _))))\n (d \"caaddr\"\n (caxr (caaddr '(_ _ (t _)))))\n (d \"cadaar\"\n (caxr (cadaar '(((_ t) _)))))\n\n (d \"cadadr\"\n (caxr (cadadr '(_ ((_ _) t)))))\n (d \"caddar\"\n (caxr (caddar '((_ _ t)))))\n (d \"cadddr\"\n (caxr (cadddr '(_ _ _ t))))\n\n (d \"cdaaar\"\n (cdxr (cdaaar '((((_ t t) _) _) _))))\n (d \"cdaadr\"\n (cdxr (cdaadr '(_ ((_ t t) _)))))\n (d \"cdadar\"\n (cdxr (cdadar '((_ (_ t t)) _))))\n (d \"cdaddr\"\n (cdxr (cdaddr '(_ _ (_ t t)))))\n (d \"cddaar\"\n (cdxr (cddaar '(((_ _ t t) _) _))))\n (d \"cddadr\"\n (cdxr (cddadr '(_ (_ _ t t)))))\n (d \"cdddar\"\n (cdxr (cdddar '((_ _ _ t t) _))))\n (d \"cddddr\"\n (cdxr (cddddr '(_ _ _ _ t t))))))\n\n(defn (:: listTests Spec)\n (do (let ((= d describe)))\n (d \"list of x, y, and z\"\n (it \"should be a list\"\n (let ((:: f (-> Int Char String Bool))\n (= f x y z\n (is-list (list x y z))))\n (property f))))\n\n (d \"filtering pair\"\n (it \"should be pair\"\n (property (\\x\n (or [(&& (is-atom x) (not (is-pair x)))\n (&& (== nil x) (not (is-pair x)))\n (&& (is-hslist x) (not (is-pair x)))\n (is-pair x)])))))\n\n (d \"filtering string\"\n (it \"should be AString\"\n (property (\\x\n (==> (is-string (toCode x))\n (case x\n (AString _ _) True\n _ False))))))\n\n (d \"filtering char\"\n (it \"should be AChar\"\n (property (\\x\n (==> (is-char (toCode x))\n (case x\n (AChar _ _) True\n _ False))))))\n\n (d \"filtering integer\"\n (it \"should be AInteger\"\n (property (\\x\n (==> (is-integer (toCode x))\n (case x\n (AInteger _) True\n _ False))))))\n\n (d \"filtering fractional\"\n (it \"should be AFractional\"\n (property (\\x\n (==> (is-fractional (toCode x))\n (case x\n (AFractional _) True\n _ False))))))\n\n (d \"filtering ()\"\n (it \"should be AUnit\"\n (property (\\x\n (==> (is-unit (toCode x))\n (case x\n AUnit True\n _ False))))))\n\n (d \"length of atom\"\n (it \"should be 1 or nil\"\n (let ((:: f (-> Code Property))\n (= f x\n (==> (is-atom x) (|| (== 1 (length x)) (null x)))))\n (property f))))\n\n (d \"cons\"\n (do (let ((= x 'x)\n (= ret1 (cons x '[b c d]))\n (= ret2 (cons x 'b))))\n (it \"returns a List when consing to List\"\n (is-list (cons 'a '(b c d))))\n (it \"returns a List when consing to HsList\"\n (is-list ret1))\n (it \"has x at car of HsList-consed-list\"\n (&& (== (car ret1) x)\n (== (cdr ret1) '(b c d))))\n (it \"returns a List when consing to Atom\"\n (is-list ret2))\n (it \"has x at car of atom-consed-list\"\n (&& (== (car ret2) x)\n (== (cdr ret2) '(b))))))\n\n (d \"caris\"\n (do (it \"returns True\"\n (== (caris 'a '(a b c)) True))\n (it \"returns False\"\n (== (caris 'a '(c b a)) False))))\n\n (d \"make-symbol\"\n (it \"returns a symbol\"\n (== (make-symbol \"foo\") 'foo)))\n\n (d \"mb-symbol-name\"\n (do (it \"returns a Just String from symbol\"\n (== (mb-symbol-name 'foo) (Just \"foo\")))\n (it \"returns a Nothing from non-symbol\"\n (== Nothing (mb-symbol-name '(foo bar buzz))))))\n\n (d \"curve\"\n (do (it \"returns list from hslist\"\n (== (curve '[a b c]) '(a b c)))\n (it \"returns original value otherwise\"\n (== 'foo (curve 'foo)))))\n\n (d \"list\"\n (do (it \"returns list\"\n (== (list 'a 'b 'c) '(a b c)))\n (it \"returns nil with no arguments\"\n (== nil (list)))))\n\n (d \"reduce\"\n (do (it \"returns the original list\"\n (== (reduce cons nil '(a b c d e)) '(a b c d e)))\n (it \"should apply given function on non-list\"\n (== (reduce cons nil 'foo) '(foo)))))\n\n (d \"reduce1\"\n (do (it \"returns the original list\"\n (== (reduce1 cons '(a b c d e)) '(a b c d e)))\n (it \"should throw exception on non-list\"\n (expectFailure (shouldBe (reduce1 cons 'foo) nil)))))\n\n (d \"map1\"\n (do (it \"replaces non-symbols\"\n (== (map1 (\\x (if (is-symbol x) x '_))\n '(foo bar (a b c) buzz 3 \"string\"))\n '(foo bar _ buzz _ _)))\n (it \"replaces non-symbols in HsList\"\n (== (map1 (\\x (if (is-symbol x) x '_))\n '[foo bar (a b c) buzz 3 \"string\"])\n '[foo bar _ buzz _ _]))\n (it \"apply given function on non-list arg2\"\n (== (map1 (\\x (cons x x)) 'foo) '(foo foo)))))\n\n (d \"keep\"\n (do (it \"removes non atom\"\n (== (keep is-atom '(a (b c) d e (f g h))) '(a d e)))\n (it \"throws an exception on non-list\"\n (expectFailure (shouldBe (keep is-atom '\"string\") nil)))))\n\n (d \"rev\"\n (do (it \"reverses List\"\n (== (rev '(a b c)) '(c b a)))\n (it \"reverses HsList\"\n (== (rev '[a b c]) '[c b a]))\n (it \"does nothing to non-list values\"\n (== (rev 'foo) 'foo))))\n\n (d \"unsnoc\"\n (it \"should split the last element\"\n (== (unsnoc '(a b c d e)) (, '(a b c d) 'e))))\n\n (d \"trav1\"\n (do (it \"should traverse list\"\n (== (trav1 Just '(a b c)) (Just '(a b c))))\n (it \"should apply given function on non-list\"\n (== (trav1 Just 'foo) (Just 'foo)))))\n\n (d \"omni\"\n (do (it \"should replace `a' to `b'\"\n (== (omni (\\x (if (== 'a x) 'b x))\n '(a a (x a x) [y a y] a))\n '(b b (x b x) [y b y] b)))\n (it \"should apply given function on non-list argument\"\n (== (omni (\\x (cons x x)) 'foo) '(foo foo)))))\n\n (d \"omniM\"\n (do (it \"should print all elements\"\n (== (omniM Just '(a a (x a x) [y a y] a))\n (Just '(a a (x a x) [y a y] a))))\n (it \"should apply given function to non-list argument\"\n (== (omniM Just 'foo) (Just 'foo)))))))\n" }, { "path": "finkel-core/test/Orphan.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Orphan instances for QuickCheck\n\n;;; This module contains duplicated codes with `Orphan' module used by\n;;; finkel-kernel test. At the moment, could not find a nice way to\n;;; avoid adding QuickCheck package dependency without code\n;;; duplication.\n\n%p(OPTIONS_GHC -fno-warn-orphans)\n\n(:require Finkel.Core)\n\n(defmodule Orphan\n (import\n ;; QuickCheck\n (Test.QuickCheck\n [(Arbitrary ..) (Gen) arbitraryUnicodeChar elements getUnicodeString\n listOf oneof scale])\n\n ;; finkel-kernel\n (Language.Finkel.Form)))\n\n(instance (Arbitrary Atom)\n (defn arbitrary\n (lept [headChars (++ [#'A .. #'Z] [#'a .. #'z] \"_!$%*+./<=>?@^~:\")\n tailChars (++ headChars \"0123456789'-\")\n symbolG (<*> (pure :) (elements headChars)\n (listOf (elements tailChars)))\n stringG (fmap getUnicodeString arbitrary)]\n (oneof [(return AUnit)\n (fmap aSymbol symbolG)\n (fmap (AChar NoSourceText) arbitraryUnicodeChar)\n (fmap (aString NoSourceText) stringG)\n (fmap aIntegral (:: arbitrary (Gen Integer)))\n (fmap aFractional (:: arbitrary (Gen Double)))]))))\n\n(instance (=> (Arbitrary a) (Arbitrary (Form a)))\n (defn arbitrary\n (oneof [(fmap Atom arbitrary)\n (fmap List (listOf (scale (flip div 3) arbitrary)))\n (fmap HsList (listOf (scale (flip div 3) arbitrary)))]))\n (defn shrink [x]\n (case x\n (Atom _) []\n (List xs) (++ (map unCode xs) (map List (shrink xs)))\n (HsList xs) (++ (map unCode xs) (map HsList (shrink xs)))\n TEnd [])))\n\n(instance (=> (Arbitrary a) (Arbitrary (LForm a)))\n (defn arbitrary (fmap (. LForm genSrc) arbitrary)))\n" }, { "path": "finkel-core/test/PluginTest.hs", "content": ";;; -*- mode: finkel -*-\n\n(module PluginTest)\n\n;; hspec\n(import Test.Hspec)\n\n;;; Compile time home package modules\n\n(:require Finkel.Core)\n(:eval-when-compile\n (import Finkel.Prelude))\n\n;;; Imports\n\n;; base\n(import Control.Monad (void))\n(import Control.Monad.IO.Class ((MonadIO ..)))\n\n;; ghc\n(import GHC\n ((LoadHowMuch ..) DynFlags (GhcMonad ..)\n guessTarget parseDynamicFlags load setTargets noLoc runGhc\n succeeded setSessionDynFlags))\n\n;; filepath\n(import System.FilePath ())\n\n;; finkel-kernel\n(import Language.Finkel.Fnk (getLibDirFromGhc))\n(import Language.Finkel.Plugin (setFinkelPluginWithArgs))\n\n;; Internal\n(import Finkel.Core.Plugin (plugin))\n\n(cond-expand\n [(<= 902 :ghc)\n (import GHC.Driver.Env.Types ((HscEnv ..)))]\n [(<= 900 :ghc)\n (import GHC.Driver.Types ((HscEnv ..)))]\n [otherwise\n (import HscTypes ((HscEnv ..)))])\n\n;;; Tests\n\n(defn (:: pluginTests Spec)\n (describe \"plugin\"\n (compile \"c01.hs\")))\n\n(defn (:: compile (-> String Spec))\n [file]\n (lept [go (do (<- hsc-env0-b getSession)\n (void (setSessionDynFlags (hsc-dflags hsc-env0-b)))\n\n (<- hsc-env2 getSession)\n (lept [pp-args [\"-F\" \"-pgmF\" \"fnkpp\"]\n fnk-args (++ pp-args [\"-fno-code\" (++ \"-i\" pdir)])])\n (<- dflags1 (parseDynFlags hsc-env2 fnk-args))\n (void (setSessionDynFlags dflags1))\n\n (setFinkelPluginWithArgs plugin [])\n\n (<- t (cond-expand\n [(<= 904 :ghc)\n (guessTarget ( pdir file) Nothing Nothing)]\n [otherwise\n (guessTarget ( pdir file) Nothing)]))\n (setTargets [t])\n (load LoadAllTargets))]\n (it (++ \"should compile \" file)\n (do (<- libdir getLibDirFromGhc)\n (<- success-flag (runGhc (Just libdir) go))\n (shouldBe (succeeded success-flag) True)))))\n\n(defn (:: pdir FilePath)\n ( \"test\" \"data\" \"plugin\"))\n\n(defn (:: parseDynFlags (=> (MonadIO m) (-> HscEnv [String] (m DynFlags))))\n [hsc-env args]\n (do (cond-expand\n [(<= 902 :ghc)\n (<- (, df _ _) (parseDynamicFlags (hsc-logger hsc-env)\n (hsc-dflags hsc-env)\n (map noLoc args)))]\n [otherwise\n (<- (, df _ _) (parseDynamicFlags (hsc-dflags hsc-env)\n (map noLoc args)))])\n (pure df)))\n\n" }, { "path": "finkel-core/test/Spec.hs", "content": ";;; -*- mode: finkel -*-\n\n;;; Main entry point of Finkel tests.\n(module Main)\n\n;;; hspec\n(import Test.Hspec)\n\n;;; Internal\n(import CoreTest)\n(import FunctionTest)\n(import PluginTest)\n\n(:: main (IO ()))\n(= main (hspec (do functionTests\n coreTests\n pluginTests)))\n" }, { "path": "finkel-core/test/TestAux.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Auxiliary macros for test\n\n%p(LANGUAGE TypeApplications)\n\n(:require Finkel.Core)\n\n(defmodule TestAux\n (export\n (GensymCode ..)\n expand-form\n expand-form-satisfies\n expand-form-with\n expand-form-with-env\n expand-form-with-package-db-satisfies\n expand-form-with-package-db-failure\n expandTo\n expandFailure\n expandFailureWith\n expandSatisfy\n expandWithPackageDbSatisfy\n expandWithPackageDbFailure)\n (import\n ;; base\n (Control.Exception [(SomeException ..) try])\n (Control.Monad [unless])\n (Data.Function [on])\n\n ;; hspec\n (Test.Hspec\n [Expectation expectationFailure shouldBe shouldSatisfy])\n\n ;; finkel-kernel\n (Language.Finkel.Make [initSessionForMake])\n (Language.Finkel.Fnk [(FnkEnv ..)])\n\n ;; finkel-core\n (Finkel.Prelude)\n (Finkel.Core.Internal)))\n\n;;; Types\n\n;; Using a newtype to compare 'Code's containing symbols generated\n;; with `gensym'.\n(newtype GensymCode (GensymCode Code)\n (deriving Show))\n\n(instance (Eq GensymCode)\n (= == eqGensymCode))\n\n(defn (:: eqGensymCode (-> GensymCode GensymCode Bool))\n [(GensymCode a) (GensymCode b)]\n (eqGensymCode1 a b))\n\n(defn (:: eqGensymCode1 (-> Code Code Bool))\n [a b]\n (eqGensymCode2 (unCode a) (unCode b)))\n\n(defn (:: eqGensymCode2 (-> (Form Atom) (Form Atom) Bool))\n [(Atom (@ asym (ASymbol a))) (Atom (@ bsym (ASymbol b)))]\n (| ((nullFS a) (nullFS b))\n ((<- (: #'$ _) (show asym)) True)\n ((<- (: #'$ _) (show bsym)) True)\n (otherwise (== a b)))\n [(List as) (List bs)] (eqGensymCodes as bs)\n [(HsList as) (HsList bs)] (eqGensymCodes as bs)\n [a b] (== a b))\n\n(defn (:: eqGensymCodes (-> [Code] [Code] Bool))\n [[] []] True\n [[] _] False\n [ _ []] False\n [(: x xs) (: y ys)] (&& (eqGensymCode1 x y) (eqGensymCodes xs ys)))\n\n\n;;; Functions\n\n(defn (:: expand-form (-> Macro Code Code Expectation))\n (expand-form-with (on shouldBe GensymCode)))\n\n(defn (:: expand-form-satisfies (-> Macro Code (-> Code Bool) Expectation))\n [macro in-form test]\n (expand-form-with (\\a _ (shouldSatisfy a test)) macro in-form nil))\n\n(defn (:: expand-form-with (-> (-> Code Code Expectation)\n Macro Code Code Expectation))\n (expand-form-with-env defaultFnkEnv))\n\n(defn (:: expand-form-with-env (-> FnkEnv\n (-> Code Code Expectation)\n Macro Code Code Expectation))\n [fnk-env test macro in-form out-form]\n (lept [p (either (. expectationFailure show) (flip test out-form))]\n (expand-form-with-pre (pure ()) fnk-env p macro in-form)))\n\n(defn (:: expand-form-with-package-db-satisfies\n (-> Macro Code (-> Code Bool) Expectation))\n [macro in-form test]\n (lept [p (either (. expectationFailure show) (flip shouldSatisfy test))]\n (expand-form-with-package-db defaultFnkEnv p macro in-form)))\n\n(defn (:: expand-form-with-package-db-failure\n (-> Macro Code (-> SomeException Bool) Expectation))\n [macro in-form test]\n (lept [p (either (\\e (unless (test e)\n (expectationFailure \"test function failed\")))\n (const (expectationFailure \"no exception thrown\")))]\n (expand-form-with-package-db defaultFnkEnv p macro in-form)))\n\n(defn (:: expand-form-with-package-db\n (-> FnkEnv\n (-> (Either SomeException Code) Expectation)\n Macro Code Expectation))\n (expand-form-with-pre initSessionForMake))\n\n(defn (:: expand-form-with-pre\n (-> (Fnk ()) FnkEnv (-> (Either SomeException Code) Expectation)\n Macro Code Expectation))\n [pre fnk-env test macro in-form]\n (>>= (try (runFnk (do pre\n (macroFunction macro in-form))\n fnk-env))\n test))\n\n;;; Macros\n\n(defmacro expandTo [in-form out]\n `(expand-form ,(car in-form) ',in-form ',out))\n\n(defmacro expandFailureWith [in-form test]\n `(let ((= act\n (do (<- r (runFnk (macroFunction ,(car in-form) ',in-form)\n defaultFnkEnv))\n (seq r (pure r)))))\n (shouldThrow act ,test)))\n\n(defmacro expandFailure [in-form]\n `(expandFailureWith ,in-form anyException))\n\n(defmacro expandSatisfy [in-form test]\n `(expand-form-satisfies ,(car in-form) ',in-form ,test))\n\n(defmacro expandWithPackageDbSatisfy [in-form test]\n `(expand-form-with-package-db-satisfies ,(car in-form) ',in-form ,test))\n\n(defmacro expandWithPackageDbFailure [in-form test]\n `(expand-form-with-package-db-failure ,(car in-form) ',in-form ,test))\n" }, { "path": "finkel-core/test/data/plugin/ImportMe.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule ImportMe)\n\n(defn (:: f1 (-> Int (IO ())))\n [n]\n (putStrLn (if (even n)\n \"even\"\n \"odd\")))\n" }, { "path": "finkel-core/test/data/plugin/c01.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule Main\n (import\n (Control.Monad [forM-])\n (ImportMe [f1])))\n\n(defn (:: main (IO ()))\n (forM- (Just 3) f1))\n" }, { "path": "finkel-kernel/LICENSE", "content": "Copyright (c) 2017-2022, 8c6794b6\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "finkel-kernel/README.md", "content": "finkel-kernel\n=============\n\nPackage for Finkel language kernel.\n\nSee the [documentation][doc] for more details.\n\n[doc]: https://finkel.readthedocs.io/en/latest/\n" }, { "path": "finkel-kernel/Setup.hs", "content": "-- | Custom setup script to pass command line options to happy and alex.\n--\n-- Passing \"--ghc\" option to alex and happy manually. When stack add\n-- supports for passing command line options to arbitrary program used\n-- during build, this script could be removed.\n--\nmodule Main where\n\n-- base\nimport Data.Char (isSpace)\nimport Data.Function (on)\nimport Data.List (unionBy)\n\n-- Cabal\nimport Distribution.Simple (UserHooks (..),\n defaultMainWithHooks,\n simpleUserHooks)\nimport Distribution.Simple.Build (build)\nimport Distribution.Simple.BuildPaths (autogenComponentModulesDir)\nimport Distribution.Simple.LocalBuildInfo\nimport Distribution.Simple.PreProcess (knownSuffixHandlers)\nimport Distribution.Simple.Program (getDbProgramOutput, ghcProgram)\nimport Distribution.Simple.Program.Db (lookupProgram, updateProgram)\nimport Distribution.Simple.Program.Types (ConfiguredProgram (..),\n ProgramLocation (..), programPath,\n simpleConfiguredProgram)\nimport Distribution.Simple.Setup (ConfigFlags (..), fromFlag)\nimport Distribution.Simple.Utils (createDirectoryIfMissingVerbose)\nimport Distribution.Types.PackageDescription (PackageDescription)\nimport Distribution.Verbosity (Verbosity)\n\n-- filepath\nimport System.FilePath (())\n\n-- | Main function for setup.\n--\n-- Setup some addicional flags for /alex/ and /happy/, and emit C\n-- header files with C macros for all components.\nmain :: IO ()\nmain = defaultMainWithHooks myHooks\n where\n myHooks = simpleUserHooks {buildHook = myBuildHooks\n ,postConf = myPostConf}\n\n myBuildHooks pkg_descr lbi hooks flags =\n build pkg_descr lbi' flags (allSuffixHandlers hooks)\n where\n lbi' = lbi {withPrograms =\n updateProgram happy\n (updateProgram alex (withPrograms lbi))}\n alex = alex' { programOverrideArgs = [\"--ghc\"] }\n alex' = simpleConfiguredProgram \"alex\" (FoundOnSystem \"alex\")\n happy = happy' { programOverrideArgs = [\"-a\", \"-g\", \"-c\"]\n -- Happy can take `--strict' flag, which adds\n -- strictness to happy parser.\n --\n -- [\"-a\", \"-c\", \"-g\", \"--strict\"]\n }\n happy' =\n simpleConfiguredProgram \"happy\" (FoundOnSystem \"happy\")\n\n allSuffixHandlers hooks =\n overridesPP (hookedPreProcessors hooks) knownSuffixHandlers\n where overridesPP = unionBy ((==) `on` fst)\n\n myPostConf _args flags pkg_descr lbi =\n writeFinkelKernelConfig pkg_descr lbi flags\n\nwriteFinkelKernelConfig :: PackageDescription -> LocalBuildInfo\n -> ConfigFlags -> IO ()\nwriteFinkelKernelConfig pkg_descr lbi flags = do\n -- FINKEL_KERNEL_LIBDIR and FINKEL_KERNEL_GHC are obtained with\n -- similar way done in \"ghc-paths\" package.\n let verbosity = fromFlag (configVerbosity flags)\n libdir0 <- getLibDir verbosity lbi\n let bdpref = configDistPref flags\n bdpref_path = fromFlag bdpref\n def name str = \"#define \" ++ name ++ ' ':show str\n libdir1 = reverse (dropWhile isSpace (reverse libdir0))\n ghc = case lookupProgram ghcProgram (withPrograms lbi) of\n Just p -> programPath p\n Nothing -> error \"ghc was not found\"\n config_h =\n [\"/* Auto generated by Setup.hs */\"\n ,\"\"\n ,\"/* Path for inplace package lookup */\"\n ,def \"FINKEL_KERNEL_CONFIG_DISTPREF\" bdpref_path\n ,\"\"\n ,\"/* Path for the GHC library directory */\"\n ,def \"FINKEL_KERNEL_LIBDIR\" libdir1\n ,\"\"\n ,\"/* Path for the GHC executable */\"\n ,def \"FINKEL_KERNEL_GHC\" ghc\n ]\n gen comp clbi =\n let autogen_dir = autogenComponentModulesDir lbi clbi\n dest_path = autogen_dir \"finkel_kernel_config.h\"\n work =\n do createDirectoryIfMissingVerbose verbosity True\n autogen_dir\n writeFile dest_path (unlines config_h)\n in case comp of\n CLib _ -> work\n CTest _ -> work\n _ -> return ()\n\n withAllComponentsInBuildOrder pkg_descr lbi gen\n\n-- | Function to get GHC library directory path.\ngetLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath\ngetLibDir verbosity lbi =\n getDbProgramOutput verbosity ghcProgram (withPrograms lbi)\n [\"--print-libdir\"]\n" }, { "path": "finkel-kernel/exec/fnkc.hs", "content": "-- | Simple wrapper for main compiler function.\nmodule Main where\nimport Language.Finkel.Main\nmain :: IO ()\nmain = defaultMain\n" }, { "path": "finkel-kernel/exec/profile.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE TypeApplications #-}\n-- | Simple executable for profiling.\n--\n-- Simple executable to wrap some simple actions.\nmodule Main where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Monad.IO.Class (MonadIO (..))\nimport System.Environment (getArgs)\nimport System.Exit (exitFailure)\nimport System.IO (Handle, stdout)\n\n-- filepath\nimport qualified System.FilePath as FilePath\n\n-- ghc\nimport qualified GHC as GHC\nimport GHC_Data_StringBuffer (hGetStringBuffer)\nimport GHC_Driver_Ppr (printForUser)\nimport GHC_Driver_Session (DynFlags, GeneralFlag (..),\n HasDynFlags (..), gopt_set)\nimport GHC_Types_Basic (SuccessFlag (..))\nimport GHC_Types_SrcLoc (mkGeneralLocated)\nimport GHC_Utils_Outputable (Outputable (..), SDoc,\n neverQualify)\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Types.Error (defaultDiagnosticOpts)\n#elif MIN_VERSION_ghc(9,6,0)\nimport GHC.Types.Error (Diagnostic (..))\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Driver.Errors.Types (GhcMessage)\nimport GHC.Utils.Outputable (NamePprCtx)\n#else\nimport GHC_Utils_Outputable (PrintUnqualified)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Config.Diagnostic (initDiagOpts)\nimport GHC.Driver.Errors (printMessages)\n#else\nimport GHC_Driver_Errors (printBagOfErrors)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Utils.Logger (HasLogger (..))\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Utils_Outputable (Depth (..))\n#endif\n\n-- finkel-kernel\nimport qualified Language.Finkel.Builder as Builder\nimport qualified Language.Finkel.Emit as Emit\nimport qualified Language.Finkel.Expand as Expand\nimport qualified Language.Finkel.Fnk as Fnk\nimport qualified Language.Finkel.Lexer as Lexer\nimport qualified Language.Finkel.Make as Make\nimport qualified Language.Finkel.Reader as Reader\nimport qualified Language.Finkel.SpecialForms as SpecialForms\nimport qualified Language.Finkel.Syntax as Syntax\n\nmain :: IO ()\nmain =\n do args <- getArgs\n case args of\n -- [\"count\", file] -> countTokens file\n [\"expand\", file] -> printExpandedForms file\n [\"parse\", file] -> printForms file\n [\"ppr\", file] -> pprFile file\n [\"hsrc\", file] -> printHsrc file\n [\"lex\", file] -> printTokens file\n \"make\" : files -> doMake files\n _ -> usage\n\nusage :: IO ()\nusage =\n putStrLn\n (unlines\n [\"usage: profile MODE ARGS\"\n ,\"\"\n ,\"MODE:\"\n -- ,\" count - count number of forms\"\n ,\" expand - print expanded forms\"\n ,\" parse - parse input file and print resulting forms\"\n ,\" ppr - pretty print haskell or finkel module with `ppr'\"\n ,\" hsrc - convert Finkel source to Haskell source\"\n ,\" lex - lex input file and print resulting tokens\"\n ,\" make - compile given files to object code\"])\n\nprintExpandedForms :: FilePath -> IO ()\nprintExpandedForms path = Fnk.runFnk go SpecialForms.defaultFnkEnv\n where\n go = do\n Make.initSessionForMake\n contents <- liftIO (hGetStringBuffer path)\n (forms, _) <- Reader.parseSexprs (Just path) contents\n forms' <- Make.withExpanderSettings (Expand.expands forms)\n liftIO (mapM_ print forms')\n\nprintForms :: FilePath -> IO ()\nprintForms path =\n do contents <- hGetStringBuffer path\n case Lexer.evalSP Reader.sexprs (Just path) contents of\n Right forms -> mapM_ print forms\n Left err -> print err\n\npprFile :: FilePath -> IO ()\npprFile path\n | ext == \".fnk\" = pprFnkModule path\n | ext == \".hs\" = pprHsModule path\n | otherwise = putStrLn \"ppr: expeting .fnk or .hs file\"\n where\n ext = FilePath.takeExtension path\n\npprFnkModule :: FilePath -> IO ()\npprFnkModule =\n parseFnkModuleWith\n (\\m _ ->\n do dflags <- getDynFlags\n liftIO (prForUser dflags stdout neverQualify (ppr m)))\n\npprHsModule :: FilePath -> IO ()\npprHsModule path = Fnk.runFnk go SpecialForms.defaultFnkEnv\n where\n go =\n do Make.initSessionForMake\n contents <- liftIO (readFile path)\n dflags0 <- getDynFlags\n#if MIN_VERSION_ghc(9,2,0)\n logger <- getLogger\n#endif\n let dflags1 = gopt_set dflags0 Opt_Haddock\n#if MIN_VERSION_ghc(9,6,0)\n ddopts = defaultDiagnosticOpts @GhcMessage\n pboe = printMessages logger ddopts (initDiagOpts dflags1)\n#elif MIN_VERSION_ghc(9,4,0)\n pboe = printMessages logger (initDiagOpts dflags1)\n#elif MIN_VERSION_ghc(9,2,0)\n pboe = printBagOfErrors logger dflags1\n#else\n pboe = printBagOfErrors dflags1\n#endif\n (_warnings, ret) = GHC.parser contents dflags1 path\n liftIO $ case ret of\n Right lmdl -> prForUser dflags1 stdout neverQualify (ppr lmdl)\n Left err -> putStrLn \"pprHsModule: error\" >> pboe err\n\n#if MIN_VERSION_ghc(9,6,0)\nprForUser :: DynFlags -> Handle -> NamePprCtx -> SDoc -> IO ()\n#else\nprForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nprForUser df hdl qual sdoc = printForUser df hdl qual AllTheWay sdoc\n#else\nprForUser = printForUser\n#endif\n\nprintHsrc :: FilePath -> IO ()\nprintHsrc =\n parseFnkModuleWith\n (\\mdl sp -> do fnk_str <- Emit.genHsSrc sp (Emit.Hsrc mdl)\n liftIO (putStrLn fnk_str))\n\nparseFnkModuleWith ::\n (Builder.HModule -> Lexer.SPState -> Fnk.Fnk ()) -> FilePath -> IO ()\nparseFnkModuleWith act path = Fnk.runFnk go SpecialForms.defaultFnkEnv\n where\n go =\n do Make.initSessionForMake\n contents <- liftIO (hGetStringBuffer path)\n case Lexer.runSP Reader.sexprs (Just path) contents of\n Right (forms, sp) -> do\n forms' <- Make.withExpanderSettings (Expand.expands forms)\n dflags <- getDynFlags\n case Builder.evalBuilder dflags False Syntax.parseModule forms' of\n Right mdl -> act mdl sp\n Left err -> liftIO (putStrLn (\"error: \" ++\n Builder.syntaxErrMsg err))\n Left err -> liftIO (print err)\n\nprintTokens :: FilePath -> IO ()\nprintTokens path = do\n contents <- hGetStringBuffer path\n case Lexer.lexTokens (Just path) contents of\n Right toks -> mapM_ (print . GHC.unLoc) toks\n Left err -> print err\n\n-- countTokens :: FilePath -> IO ()\n-- countTokens path = do\n-- contents <- hGetStringBuffer path\n-- -- contents <- BL.readFile path\n-- let f x acc =\n-- let n = x `seq` length x\n-- in n `seq` acc `seq` n + acc\n-- case Lexer.incrSP Reader.psexpr f 0 (Just path) contents of\n-- Right (n, _) -> print n\n-- Left err -> putStrLn err\n\ndoMake :: [FilePath] -> IO ()\ndoMake files =\n do let act = do\n Make.initSessionForMake\n Make.make (zipWith f files (repeat Nothing)) False Nothing\n f file phase = (mkGeneralLocated \"commandline\" file, phase)\n success_flag <- Fnk.runFnk act SpecialForms.defaultFnkEnv\n case success_flag of\n Failed -> exitFailure\n Succeeded -> return ()\n" }, { "path": "finkel-kernel/finkel-kernel.cabal", "content": "cabal-version: 2.0\nname: finkel-kernel\nversion: 0.0.0\nsynopsis: Finkel kernel language and compiler\ndescription:\n Finkel kernel language and compiler\n .\n See the for more info.\n\nhomepage: https://github.com/finkel-lang/finkel#readme\nlicense: BSD3\nlicense-file: LICENSE\nauthor: 8c6794b6\nmaintainer: 8c6794b6@gmail.com\ncopyright: 2017-2022 8c6794b6\ncategory: Language\nbuild-type: Custom\nextra-source-files: README.md\n include/*.h\n --\n test/data/eval/*.fnk\n test/data/syntax/*.hs\n test/data/main/*.c\n test/data/main/*.hs\n test/data/make/*.c\n test/data/make/*.hs\n test/data/make/*.hs.2\n test/data/make/M4/*.hs\n test/data/make/M6/*.hs\n\ntested-with: GHC == 8.10.7\n , GHC == 9.0.2\n , GHC == 9.2.8\n , GHC == 9.4.7\n , GHC == 9.6.5\n , GHC == 9.8.2\n , GHC == 9.10.1\n\ncustom-setup\n setup-depends: base >= 4.14 && < 5\n , Cabal >= 2.0 && < 3.13\n , filepath >= 1.4 && < 1.6\n\nflag dev\n description: Flag for internal development\n default: False\n manual: True\n\nlibrary\n hs-source-dirs: src\n exposed-modules: Paths_finkel_kernel\n Language.Finkel\n Language.Finkel.Builder\n Language.Finkel.Emit\n Language.Finkel.Error\n Language.Finkel.Eval\n Language.Finkel.Exception\n Language.Finkel.Expand\n Language.Finkel.Form\n Language.Finkel.Homoiconic\n Language.Finkel.Hooks\n Language.Finkel.Lexer\n Language.Finkel.Make\n Language.Finkel.Main\n Language.Finkel.Options\n Language.Finkel.Plugin\n Language.Finkel.Preprocess\n Language.Finkel.Reader\n Language.Finkel.Fnk\n Language.Finkel.SpecialForms\n Language.Finkel.Syntax\n other-modules: Language.Finkel.Data.Fractional\n Language.Finkel.Data.FastString\n Language.Finkel.Data.SourceText\n Language.Finkel.Make.Cache\n Language.Finkel.Make.Recompile\n Language.Finkel.Make.Session\n Language.Finkel.Make.Summary\n Language.Finkel.Make.TargetSource\n Language.Finkel.Make.Trace\n Language.Finkel.ParsedResult\n Language.Finkel.Syntax.Extension\n Language.Finkel.Syntax.Location\n Language.Finkel.Syntax.Utils\n Language.Finkel.Syntax.HBind\n Language.Finkel.Syntax.HDecl\n Language.Finkel.Syntax.HExpr\n Language.Finkel.Syntax.HImpExp\n Language.Finkel.Syntax.HPat\n Language.Finkel.Syntax.HType\n autogen-modules: Paths_finkel_kernel\n includes: ghc_modules.h\n include-dirs: include\n c-sources: include/hooks.c\n build-depends: array >= 0.5 && < 0.6\n , base >= 4.14 && < 5\n , binary >= 0.8 && < 0.9\n , bytestring >= 0.10 && < 0.13\n , containers >= 0.6 && < 0.8\n , deepseq >= 1.4 && < 1.6\n , directory >= 1.3 && < 1.4\n , exceptions >= 0.10 && < 0.11\n , filepath >= 1.4 && < 1.6\n , ghc >= 8.10.0 && < 9.11.0\n , ghc-boot >= 8.10.0 && < 9.11.0\n , ghci >= 8.10.0 && < 9.11.0\n , process >= 1.6 && < 1.7\n , time >= 1.9 && < 1.14\n build-tool-depends: alex:alex >= 3.1 && < 3.6\n , happy:happy >= 1.19 && < 1.23\n default-language: Haskell2010\n ghc-options: -Wall\n\nexecutable finkel-profile\n if !flag(dev)\n buildable: False\n hs-source-dirs: exec\n main-is: profile.hs\n ghc-options: -Wall -threaded -rtsopts\n includes: ghc_modules.h\n include-dirs: include\n build-depends: base\n , bytestring\n , filepath\n , ghc\n , finkel-kernel\n default-language: Haskell2010\n\ntest-suite finkel-kernel-test\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Main.hs\n other-modules: FormTest\n FnkTest\n EmitTest\n EvalTest\n ExceptionTest\n MainTest\n MakeTest\n PluginTest\n PreprocessTest\n SyntaxTest\n Orphan\n TestAux\n Paths_finkel_kernel\n includes: ghc_modules.h\n include-dirs: include\n build-depends: base\n , binary\n , bytestring\n , containers\n , deepseq\n , directory\n , exceptions\n , filepath\n , ghc\n , process\n , finkel-kernel\n --\n , QuickCheck >= 2.10.1 && < 2.16\n , hspec >= 2.4.8 && < 2.12\n , silently >= 1.2 && < 1.3\n , transformers >= 0.5.2 && < 0.7\n\n -- The \"Linker.c\" codes in the \"rts\" package bundled with ghc 8.10.3 had\n -- problem when running the tests with \"+RTS -N\", disabling.\n if impl (ghc >= 8.10.3)\n ghc-options: -Wall -threaded -rtsopts\n else\n ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N\n default-language: Haskell2010\n\nsource-repository head\n type: git\n location: https://github.com/finkel-lang/finkel.git\n subdir: finkel-kernel\n" }, { "path": "finkel-kernel/include/ghc_modules.h", "content": "/**\n * CPP macros to manage module names in ghc.\n */\n\n#pragma once\n\n/*\nChanges happend from ghc 9.0 to 9.2. Also defining the module aliases for ghc\nolder than 9.0.\n*/\n\n#if __GLASGOW_HASKELL__ >= 902\n#define GHC_Driver_Env GHC.Driver.Env\n#define GHC_Driver_Env_Types GHC.Driver.Env.Types\n#define GHC_Driver_Errors GHC.Driver.Errors\n#define GHC_Driver_Ppr GHC.Driver.Ppr\n\n#define GHC_Platform_Ways GHC.Platform.Ways\n#define GHC_Runtime_Context GHC.Runtime.Context\n\n#define GHC_Types_Error GHC.Types.Error\n#define GHC_Types_Fixity GHC.Types.Fixity\n#define GHC_Types_SourceError GHC.Types.SourceError\n#define GHC_Types_SourceFile GHC.Types.SourceFile\n#define GHC_Types_SourceText GHC.Types.SourceText\n#define GHC_Types_Target GHC.Types.Target\n#define GHC_Types_TyThing GHC.Types.TyThing\n#define GHC_Types_TyThing_Ppr GHC.Types.TyThing.Ppr\n\n#define GHC_Unit_Finder GHC.Unit.Finder\n#define GHC_Unit_Home_ModInfo GHC.Unit.Home.ModInfo\n#define GHC_Unit_Module_Deps GHC.Unit.Module.Deps\n#define GHC_Unit_Module_Graph GHC.Unit.Module.Graph\n#define GHC_Unit_Module_ModIface GHC.Unit.Module.ModIface\n#define GHC_Unit_Module_ModSummary GHC.Unit.Module.ModSummary\n\n#elif __GLASGOW_HASKELL__ >= 900\n#define GHC_Driver_Env GHC.Driver.Types\n#define GHC_Driver_Env_Types GHC.Driver.Types\n#define GHC_Driver_Errors GHC.Utils.Error\n#define GHC_Driver_Ppr GHC.Utils.Outputable\n\n#define GHC_Platform_Ways GHC.Driver.Ways\n\n#define GHC_Runtime_Context GHC.Driver.Types\n\n#define GHC_Types_Error GHC.Utils.Error\n#define GHC_Types_Fixity GHC.Types.Basic\n#define GHC_Types_SourceError GHC.Driver.Types\n#define GHC_Types_SourceFile GHC.Driver.Phases\n#define GHC_Types_SourceText GHC.Types.Basic\n#define GHC_Types_Target GHC.Driver.Types\n#define GHC_Types_TyThing GHC.Driver.Types\n#define GHC_Types_TyThing_Ppr GHC.Core.Ppr.TyThing\n\n#define GHC_Unit_Finder GHC.Driver.Finder\n#define GHC_Unit_Home_ModInfo GHC.Driver.Types\n#define GHC_Unit_Module_Deps GHC.Driver.Types\n#define GHC_Unit_Module_Graph GHC.Driver.Types\n#define GHC_Unit_Module_ModIface GHC.Driver.Types\n#define GHC_Unit_Module_ModSummary GHC.Driver.Types\n\n#else /* __GLASGOW_HASKELL__ < 900 */\n#define GHC_Driver_Env HscTypes\n#define GHC_Driver_Env_Types HscTypes\n#define GHC_Driver_Errors ErrUtils\n#define GHC_Driver_Ppr Outputable\n\n#define GHC_Platform_Ways DynFlags\n\n#define GHC_Runtime_Context HscTypes\n\n#define GHC_Types_Error ErrUtils\n#define GHC_Types_Fixity BasicTypes\n#define GHC_Types_SourceError HscTypes\n#define GHC_Types_SourceFile DriverPhases\n#define GHC_Types_SourceText BasicTypes\n#define GHC_Types_Target HscTypes\n#define GHC_Types_TyThing HscTypes\n#define GHC_Types_TyThing_Ppr PprTyThing\n\n#define GHC_Unit_Finder Finder\n#define GHC_Unit_Home_ModInfo HscTypes\n#define GHC_Unit_Module_Deps HscTypes\n#define GHC_Unit_Module_Graph HscTypes\n#define GHC_Unit_Module_ModIface HscTypes\n#define GHC_Unit_Module_ModSummary HscTypes\n#endif\n\n/*\nChanges happened from ghc 8.10 to ghc 9.0. From ghc 9.0.1, ghc uses \"GHC.*\" name\nspace for its modules.\n*/\n\n#if __GLASGOW_HASKELL__ >= 900\n#define GHC_Builtin_Types GHC.Builtin.Types\n#define GHC_Builtin_Types_Prim GHC.Builtin.Types.Prim\n\n#define GHC_Core_Class GHC.Core.Class\n#define GHC_Core_DataCon GHC.Core.DataCon\n#define GHC_Core_TyCo_Rep GHC.Core.TyCo.Rep\n#define GHC_Core_TyCo_Tidy GHC.Core.TyCo.Tidy\n\n#define GHC_Data_Bag GHC.Data.Bag\n#define GHC_Data_FastString GHC.Data.FastString\n#define GHC_Data_EnumSet GHC.Data.EnumSet\n#define GHC_Data_Maybe GHC.Data.Maybe\n#define GHC_Data_OrdList GHC.Data.OrdList\n#define GHC_Data_StringBuffer GHC.Data.StringBuffer\n\n#define GHC_Driver_Flags GHC.Driver.Flags\n#define GHC_Driver_Main GHC.Driver.Main\n#define GHC_Driver_Make GHC.Driver.Make\n#define GHC_Driver_Monad GHC.Driver.Monad\n#define GHC_Driver_Phases GHC.Driver.Phases\n#define GHC_Driver_Pipeline GHC.Driver.Pipeline\n#define GHC_Driver_Session GHC.Driver.Session\n#define GHC_Driver_Types GHC.Driver.Types\n#define GHC_Driver_Ways GHC.Driver.Ways\n\n#define GHC_Hs_Stats GHC.Hs.Stats\n\n#define GHC_Iface_Load GHC.Iface.Load\n#define GHC_Iface_Make GHC.Iface.Make\n#define GHC_Iface_Recomp GHC.Iface.Recomp\n#define GHC_Iface_Recomp_Binary GHC.Iface.Recomp.Binary\n#define GHC_Iface_Recomp_Flags GHC.Iface.Recomp.Flags\n\n#define GHC_IfaceToCore GHC.IfaceToCore\n\n#define GHC_Parser_Annotation GHC.Parser.Annotation\n#define GHC_Parser_CharClass GHC.Parser.CharClass\n#define GHC_Parser_Header GHC.Parser.Header\n#define GHC_Parser_Lexer GHC.Parser.Lexer\n#define GHC_Parser_PostProcess GHC.Parser.PostProcess\n\n#define GHC_Plugins GHC.Plugins\n\n#define GHC_Runtime_Eval GHC.Runtime.Eval\n#define GHC_Runtime_Linker GHC.Runtime.Linker\n#define GHC_Runtime_Loader GHC.Runtime.Loader\n\n#define GHC_Settings_Config GHC.Settings.Config\n\n#define GHC_Tc_Module GHC.Tc.Module\n#define GHC_Tc_Utils_Monad GHC.Tc.Utils.Monad\n#define GHC_Tc_Utils_Zonk GHC.Tc.Utils.Zonk\n\n#define GHC_Types_Basic GHC.Types.Basic\n#define GHC_Types_FieldLabel GHC.Types.FieldLabel\n#define GHC_Types_ForeignCall GHC.Types.ForeignCall\n#define GHC_Types_Name GHC.Types.Name\n#define GHC_Types_Name_Occurrence GHC.Types.Name.Occurrence\n#define GHC_Types_Name_Reader GHC.Types.Name.Reader\n#define GHC_Types_SrcLoc GHC.Types.SrcLoc\n#define GHC_Types_Unique_Set GHC.Types.Unique.Set\n#define GHC_Types_Unique_Supply GHC.Types.Unique.Supply\n#define GHC_Types_Var GHC.Types.Var\n#define GHC_Types_Var_Env GHC.Types.Var.Env\n\n#define GHC_Unit_Module GHC.Unit.Module\n#define GHC_Unit_State GHC.Unit.State\n#define GHC_Unit_Types GHC.Unit.Types\n\n#define GHC_Utils_Encoding GHC.Utils.Encoding\n#define GHC_Utils_Error GHC.Utils.Error\n#define GHC_Utils_Exception GHC.Utils.Exception\n#define GHC_Utils_Fingerprint GHC.Utils.Fingerprint\n#define GHC_Utils_Lexeme GHC.Utils.Lexeme\n#define GHC_Utils_Misc GHC.Utils.Misc\n#define GHC_Utils_Outputable GHC.Utils.Outputable\n#define GHC_Utils_Panic GHC.Utils.Panic\n#define GHC_Utils_Ppr GHC.Utils.Ppr\n\n#else /* __GLASGOW_HASKELL__ < 900 */\n#define GHC_Builtin_Types TysWiredIn\n#define GHC_Builtin_Types_Prim TysPrim\n\n#define GHC_Core_Class Class\n#define GHC_Core_DataCon DataCon\n#define GHC_Core_TyCo_Rep TyCoRep\n#define GHC_Core_TyCo_Tidy TyCoTidy\n\n#define GHC_Data_Bag Bag\n#define GHC_Data_FastString FastString\n#define GHC_Data_EnumSet EnumSet\n#define GHC_Data_Maybe Maybes\n#define GHC_Data_OrdList OrdList\n#define GHC_Data_StringBuffer StringBuffer\n\n#define GHC_Driver_Flags DynFlags\n#define GHC_Driver_Main HscMain\n#define GHC_Driver_Make GhcMake\n#define GHC_Driver_Monad GhcMonad\n#define GHC_Driver_Phases DriverPhases\n#define GHC_Driver_Pipeline DriverPipeline\n#define GHC_Driver_Session DynFlags\n#define GHC_Driver_Types HscTypes\n\n#define GHC_Hs_Stats HscStats\n\n#define GHC_Iface_Load LoadIface\n#define GHC_Iface_Make MkIface\n#define GHC_Iface_Recomp MkIface\n#define GHC_Iface_Recomp_Binary BinFingerprint\n#define GHC_Iface_Recomp_Flags FlagChecker\n\n#define GHC_IfaceToCore TcIface\n\n#define GHC_Parser_Annotation ApiAnnotation\n#define GHC_Parser_CharClass Ctype\n#define GHC_Parser_Header HeaderInfo\n#define GHC_Parser_Lexer Lexer\n#define GHC_Parser_PostProcess RdrHsSyn\n\n#define GHC_Plugins Plugins\n\n#define GHC_Runtime_Eval InteractiveEval\n#define GHC_Runtime_Linker Linker\n#define GHC_Runtime_Loader DynamicLoading\n\n#define GHC_Settings_Config Config\n\n#define GHC_Tc_Module TcRnDriver\n#define GHC_Tc_Utils_Monad TcRnMonad\n#define GHC_Tc_Utils_Zonk TcHsSyn\n\n#define GHC_Types_Basic BasicTypes\n#define GHC_Types_FieldLabel FieldLabel\n#define GHC_Types_ForeignCall ForeignCall\n#define GHC_Types_Name Name\n#define GHC_Types_Name_Occurrence OccName\n#define GHC_Types_Name_Reader RdrName\n#define GHC_Types_SrcLoc SrcLoc\n#define GHC_Types_Unique_Set UniqSet\n#define GHC_Types_Unique_Supply UniqSupply\n#define GHC_Types_Var Var\n#define GHC_Types_Var_Env VarEnv\n\n#define GHC_Unit_Module Module\n#define GHC_Unit_State Packages\n#define GHC_Unit_Types HscTypes\n\n#define GHC_Utils_Encoding Encoding\n#define GHC_Utils_Error ErrUtils\n#define GHC_Utils_Exception Exception\n#define GHC_Utils_Fingerprint Fingerprint\n#define GHC_Utils_Lexeme Lexeme\n#define GHC_Utils_Misc Util\n#define GHC_Utils_Outputable Outputable\n#define GHC_Utils_Panic Panic\n#define GHC_Utils_Ppr Pretty\n#endif\n\n/*\nModules which changed its name between 8.10.x and 9.0.x.\n */\n\n#if __GLASGOW_HASKELL__ >= 900\n#define GHC_Hs_Type GHC.Hs.Type\n#define GHC_Utils_CliOption GHC.Utils.CliOption\n#else\n#define GHC_Hs_Type GHC.Hs.Types\n#define GHC_Utils_CliOption CliOption\n#endif\n\n/*\nFrom ghc 8.10.1, modules for AST were moved under 'GHC.Hs.*'. Defining aliases\nfor import declarations. For more info about module renaming, see:\n\n https://gitlab.haskell.org/ghc/ghc/issues/13009\n\n*/\n#define GHC_Hs GHC.Hs\n#define GHC_Hs_Binds GHC.Hs.Binds\n#define GHC_Hs_Decls GHC.Hs.Decls\n#define GHC_Hs_Doc GHC.Hs.Doc\n#define GHC_Hs_Dump GHC.Hs.Dump\n#define GHC_Hs_Expr GHC.Hs.Expr\n#define GHC_Hs_Extension GHC.Hs.Extension\n#define GHC_Hs_ImpExp GHC.Hs.ImpExp\n#define GHC_Hs_Lit GHC.Hs.Lit\n#define GHC_Hs_Pat GHC.Hs.Pat\n#define GHC_Hs_Utils GHC.Hs.Utils\n" }, { "path": "finkel-kernel/include/hooks.c", "content": "/**\n * Slim variant of \"hschooks.c\" found in ghc source\n */\n\n#include \"Rts.h\"\n#include \"HsFFI.h\"\n\nvoid initGCStatistics (void)\n{\n if (RtsFlags.GcFlags.giveStats == NO_GC_STATS) {\n RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS;\n }\n}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Builder.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n-- | Builder functions for Haskell syntax data type.\n--\n-- This module contains 'Builder' data type and Haskell AST type synonyms. The\n-- 'Builder' data type is used by Happy parser for building various AST types.\n--\n-- The main purpose of AST type synonyms defined in this module are for managing\n-- ghc version compatibility.\n--\nmodule Language.Finkel.Builder\n ( -- * Builders type and functions\n Builder(..)\n , BState(..)\n , SyntaxError(..)\n , syntaxErrMsg\n , syntaxErrCode\n , builderError\n , evalBuilder\n , failB\n , formLexer\n , getBState\n , parse\n , putBState\n , setLastToken\n , runBuilder\n\n -- * Type synonyms for ghc version compatibility\n -- $typesynonym\n , PARSED\n , HBind\n , HBinds\n , HCCallConv\n , HConDecl\n , HConDeclGADTDetails\n , HConDeclH98Details\n , HConDeclField\n , HDecl\n , HDeriving\n , HDerivStrategy\n , HExpr\n , HGRHS\n , HGuardLStmt\n , HIE\n , HIEWrappedName\n , HImportDecl\n , HKind\n , HLocalBinds\n , HMatch\n , HModule\n , HPat\n , HSig\n , HSigType\n , HSigWcType\n , HStmt\n , HTyVarBndr\n , HTyVarBndrSpecific\n , HTyVarBndrVis\n , HType\n\n -- * Function names for @:quote@\n , Quote\n , qListS\n , qHsListS\n , qSymbolS\n , qCharS\n , qStringS\n , qIntegerS\n , qFractionalS\n , qUnitS\n , quoteWith\n\n ) where\n\n#include \"ghc_modules.h\"\n\n-- ghc\nimport GHC_Data_Bag (Bag)\nimport GHC_Data_FastString (FastString, appendFS)\nimport GHC_Driver_Session (DynFlags)\nimport GHC_Hs (HsModule)\nimport GHC_Hs_Binds (HsLocalBinds, LHsBind, LSig)\nimport GHC_Hs_Decls (HsDeriving, LConDecl, LDerivStrategy, LHsDecl)\nimport GHC_Hs_Expr (ExprLStmt, GuardLStmt, LGRHS, LHsExpr, LMatch)\nimport GHC_Hs_Extension (GhcPs)\nimport GHC_Hs_ImpExp (LIE, LIEWrappedName, LImportDecl)\nimport GHC_Hs_Pat (LPat)\nimport GHC_Hs_Type (LConDeclField, LHsSigType, LHsSigWcType,\n LHsTyVarBndr, LHsType)\nimport GHC_Parser_Lexer (PState (..))\nimport GHC_Types_ForeignCall (CCallConv (..))\nimport GHC_Types_SrcLoc (Located, noLoc)\n\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Hs.Type (HsBndrVis (..))\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Config.Parser (initParserOpts)\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Config (initParserOpts)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Hs.Decls (HsConDeclGADTDetails, HsConDeclH98Details)\nimport GHC_Parser_Lexer (initParserState)\n#else\nimport GHC_Hs_Decls (HsConDeclDetails)\nimport GHC_Parser_Lexer (mkPState)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Types_Var (Specificity (..))\n#endif\n\n-- Internal\nimport Language.Finkel.Form\n\n\n-- -------------------------------------------------------------------\n--\n-- Builder data type\n--\n-- -------------------------------------------------------------------\n\n-- | State for 'Builder'.\ndata BState = BState\n { -- | Input tokens to parse.\n inputs :: [Code]\n -- | The 'PState' used for parser from GHC.\n , ghcPState :: PState\n -- | Last token, for error message.\n , lastToken :: Maybe Code\n -- | Whether to use qualified functions when quoting.\n , qualifyQuote :: Bool\n }\n\n-- | Wrapper data for syntax error.\ndata SyntaxError = SyntaxError Code String\n deriving (Eq, Show)\n\n-- | Newtype wrapper for parsing list of 'Code' with Happy.\n--\n-- Implements simple state monad with result value wrapped with 'Either', to\n-- terminate parsing computation with 'SyntaxError'.\nnewtype Builder a =\n Builder { unBuilder :: BState -> Either SyntaxError (a, BState) }\n\ninstance Functor Builder where\n fmap f (Builder m) =\n Builder (\\st0 -> do (a, st1) <- m st0\n return (f a, st1))\n {-# INLINE fmap #-}\n\ninstance Applicative Builder where\n pure x = Builder (\\st -> pure (x, st))\n {-# INLINE pure #-}\n Builder f <*> Builder m =\n Builder (\\st0 -> do (g, st1) <- f st0\n (v, st2) <- m st1\n return (g v, st2))\n {-# INLINE (<*>) #-}\n\ninstance Monad Builder where\n Builder m >>= k =\n Builder (\\st0 -> do (a, st1) <- m st0\n unBuilder (k a) st1)\n {-# INLINE (>>=) #-}\n\n-- | Run given 'Builder' with using given list of 'Code' as input.\nrunBuilder :: DynFlags\n -> Bool\n -> Builder a\n -> [Code]\n -> Either SyntaxError (a, [Code])\nrunBuilder dflags qualify bld toks =\n let buf = error \"PState StringBuffer is empty\"\n rl = error \"PState RealSrcLoc is empty\"\n#if MIN_VERSION_ghc(9,2,0)\n ps = initParserState (initParserOpts dflags) buf rl\n#else\n ps = mkPState dflags buf rl\n#endif\n in case unBuilder bld (BState toks ps Nothing qualify) of\n Right (a, st) -> Right (a, inputs st)\n Left err -> Left err\n\n-- | Like 'runBuilder', but discards left over 'Code's.\nevalBuilder :: DynFlags -> Bool -> Builder a -> [Code] -> Either SyntaxError a\nevalBuilder dflags qualify bld toks =\n fmap fst (runBuilder dflags qualify bld toks)\n\n-- | Fail builder computation with given message.\nfailB :: String -> Builder a\nfailB err = do\n mb_tok <- fmap lastToken getBState\n let tok = case mb_tok of\n Just t -> t\n Nothing -> LForm (noLoc (Atom AUnit))\n Builder (const (Left (SyntaxError tok err)))\n\n-- | Extract message from 'SyntaxError'.\nsyntaxErrMsg :: SyntaxError -> String\nsyntaxErrMsg (SyntaxError _ msg) = msg\n\n-- | Extract code from 'SyntaxError'.\nsyntaxErrCode :: SyntaxError -> Code\nsyntaxErrCode (SyntaxError code _) = code\n\n-- | Get current 'BState'.\ngetBState :: Builder BState\ngetBState = Builder (\\st -> Right (st,st))\n{-# INLINABLE getBState #-}\n\n-- | Put current 'BState'.\nputBState :: BState -> Builder ()\nputBState st = Builder (\\_ -> Right ((), st))\n{-# INLINABLE putBState #-}\n\n-- | Set last token to given 'Code'.\nsetLastToken :: Code -> Builder ()\nsetLastToken code = do\n st <- getBState\n putBState (st {lastToken = Just code})\n{-# INLINABLE setLastToken #-}\n\n-- | Parse with builder using given tokens, continue on successful parse.\nparse :: Builder a -> [Code] -> Builder a\nparse bld toks =\n do bstate <- getBState\n let pstate = ghcPState bstate\n qualify = qualifyQuote bstate\n case unBuilder bld (BState toks pstate Nothing qualify) of\n Right (a, _) -> return a\n Left err -> Builder (const (Left err))\n\n-- | Simple lexer to parse forms.\nformLexer :: (Code -> Builder a) -> Builder a\nformLexer cont = do\n st <- getBState\n case inputs st of\n [] -> cont (LForm (noLoc TEnd))\n x:xs -> do\n putBState (st {inputs = xs, lastToken = Just x})\n cont x\n{-# INLINABLE formLexer #-}\n\n-- | Show simple syntax error message with current 'Code'.\nbuilderError :: Builder a\nbuilderError = do\n st <- getBState\n case lastToken st of\n Nothing -> failB \"Syntax error\"\n Just x -> failB (\"Syntax error on input `\" ++ show x ++ \"'\")\n\n\n-- ---------------------------------------------------------------------\n--\n-- Type synonyms\n--\n-- ---------------------------------------------------------------------\n\n-- $typesynonym\n--\n-- Type synonyms for managing GHC version compatibility.\n--\n-- This 'PARSED' type synonym is wrapped with CPP macro detecting the ghc\n-- package version at compilation time. At the time of initial development of\n-- finkel-kernel package, ghc source codes were not under the /Trees that Grow/\n-- modifications. When updating from ghc 8.2.x to 8.4.x, 'PARSED' were added to\n-- handle the AST argument type modification.\n--\n-- See\n-- \n-- for more information of \\\"Trees that Grow\\\".\n--\n\ntype PARSED = GhcPs\n\ntype HBind = LHsBind PARSED\n\ntype HBinds = Bag (LHsBind PARSED)\n\ntype HCCallConv = Located CCallConv\n\ntype HConDecl = LConDecl PARSED\n\n#if MIN_VERSION_ghc(9,2,0)\ntype HConDeclH98Details = HsConDeclH98Details PARSED\ntype HConDeclGADTDetails = HsConDeclGADTDetails PARSED\n#else\n-- In ghc < 9.2, constructor details were not saparated, internal\n-- representations are same.\ntype HConDeclH98Details = HsConDeclDetails PARSED\ntype HConDeclGADTDetails = HsConDeclDetails PARSED\n#endif\n\ntype HConDeclField = LConDeclField PARSED\n\ntype HDecl = LHsDecl PARSED\n\ntype HDeriving = HsDeriving PARSED\n\ntype HDerivStrategy = LDerivStrategy PARSED\n\ntype HExpr = LHsExpr PARSED\n\ntype HGRHS = LGRHS PARSED HExpr\n\ntype HGuardLStmt = GuardLStmt PARSED\n\ntype HIE = LIE PARSED\n\ntype HIEWrappedName = LIEWrappedName PARSED\n\ntype HImportDecl = LImportDecl PARSED\n\ntype HKind = HType\n\n#if MIN_VERSION_ghc(9,2,0)\ntype HLocalBinds = HsLocalBinds PARSED\n#else\ntype HLocalBinds = Located (HsLocalBinds PARSED)\n#endif\n\ntype HMatch = LMatch PARSED HExpr\n\n#if MIN_VERSION_ghc(9,6,0)\ntype HModule = HsModule PARSED\n#elif MIN_VERSION_ghc(9,0,0)\ntype HModule = HsModule\n#else\ntype HModule = HsModule PARSED\n#endif\n\ntype HPat = LPat PARSED\n\ntype HSig = LSig PARSED\n\ntype HSigType = LHsSigType PARSED\n\ntype HSigWcType = LHsSigWcType PARSED\n\ntype HStmt = ExprLStmt PARSED\n\n#if MIN_VERSION_ghc(9,8,0)\ntype HTyVarBndr = LHsTyVarBndr () PARSED\ntype HTyVarBndrSpecific = LHsTyVarBndr Specificity PARSED\ntype HTyVarBndrVis = LHsTyVarBndr (HsBndrVis PARSED) PARSED\n#elif MIN_VERSION_ghc(9,0,0)\ntype HTyVarBndr = LHsTyVarBndr () PARSED\ntype HTyVarBndrSpecific = LHsTyVarBndr Specificity PARSED\ntype HTyVarBndrVis = HTyVarBndr\n#else\ntype HTyVarBndr = LHsTyVarBndr PARSED\ntype HTyVarBndrSpecific = HTyVarBndr\ntype HTyVarBndrVis = HTyVarBndr\n#endif\n\ntype HType = LHsType PARSED\n\n-- ---------------------------------------------------------------------\n--\n-- Function names for \":quote\"\n--\n-- ---------------------------------------------------------------------\n\n\n-- Note: [Qualified names for quoting functions]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- Quoting functions can use qualified name after expansion, to support quote in\n-- REPL without importing the \"Language.Finkel\" module. See how\n-- \"Opt_ImplicitImportQualified\" flag is set in initialization code of Finkel\n-- REPL in \"finkel-tool\" package.\n\ntype Quote = Bool -> FastString\n\nquoteWith :: FastString -> Quote\nquoteWith name qualify =\n if qualify\n then appendFS \"Language.Finkel.\" name\n else name\n{-# INLINABLE quoteWith #-}\n\nqListS :: Quote\nqListS = quoteWith \"qList\"\n{-# INLINABLE qListS #-}\n\nqHsListS :: Quote\nqHsListS = quoteWith \"qHsList\"\n{-# INLINABLE qHsListS #-}\n\nqSymbolS :: Quote\nqSymbolS = quoteWith \"qSymbol\"\n{-# INLINABLE qSymbolS #-}\n\nqCharS :: Quote\nqCharS = quoteWith \"qChar\"\n{-# INLINABLE qCharS #-}\n\nqStringS :: Quote\nqStringS = quoteWith \"qString\"\n{-# INLINABLE qStringS #-}\n\nqIntegerS :: Quote\nqIntegerS = quoteWith \"qInteger\"\n{-# INLINABLE qIntegerS #-}\n\nqFractionalS :: Quote\nqFractionalS = quoteWith \"qFractional\"\n{-# INLINABLE qFractionalS #-}\n\nqUnitS :: Quote\nqUnitS = quoteWith \"qUnit\"\n{-# INLINABLE qUnitS #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Data/FastString.hs", "content": "{-# LANGUAGE CPP #-}\n\n-- | Version compatibility module for GHC.Data.FastString\nmodule Language.Finkel.Data.FastString\n ( module FS\n , module Language.Finkel.Data.FastString\n ) where\n\n#include \"ghc_modules.h\"\n\n-- binary\nimport Data.Binary (Binary (..), Get, Put)\n\n-- ghc\nimport GHC_Data_FastString as FS\n\n#if !MIN_VERSION_ghc(9,2,0)\nunconsFS :: FastString -> Maybe (Char, FastString)\nunconsFS fs =\n case unpackFS fs of\n [] -> Nothing\n (c : cs) -> Just (c, mkFastString cs)\n{-# INLINABLE unconsFS #-}\n#endif\n\n\n-- ------------------------------------------------------------------------\n-- For Data.Binary.Binary\n-- ------------------------------------------------------------------------\n\n#if MIN_VERSION_ghc(9,0,0)\nputFastString :: FastString -> Put\nputFastString = put . FS.fastStringToShortByteString\n\ngetFastString :: Get FastString\ngetFastString = fmap FS.mkFastStringShortByteString get\n#else\nputFastString :: FastString -> Put\nputFastString = put . FS.bytesFS\n\ngetFastString :: Get FastString\ngetFastString = fmap FS.mkFastStringByteString get\n#endif\n\n{-# INLINABLE getFastString #-}\n{-# INLINABLE putFastString #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Data/Fractional.hs", "content": "{-# LANGUAGE CPP #-}\n-- | Module for version compatible fractional literal value.\nmodule Language.Finkel.Data.Fractional\n ( FractionalLit(..)\n , mkFractionalLit'\n , showFractionalList\n#if MIN_VERSION_ghc(9,2,0)\n -- XXX: Rename 'fl_value' with 'rationalFromFractionalLit'?\n , fl_value\n#endif\n , readFractionalLit\n , putFractionalLit\n , getFractionalLit\n ) where\n\n#include \"ghc_modules.h\"\n\n-- binary\nimport Data.Binary (Binary (..), Get, Put)\n\n#if MIN_VERSION_ghc(9,2,0)\nimport Data.Binary (getWord8, putWord8)\n#endif\n\n-- ghc\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Data.FastString (unpackFS)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Types.SourceText (FractionalExponentBase (..),\n FractionalLit (..), SourceText (..),\n mkSourceFractionalLit,\n mkTHFractionalLit,\n rationalFromFractionalLit)\nimport GHC.Utils.Misc (readSignificandExponentPair)\n#else\nimport GHC_Types_Basic (FractionalLit (..), SourceText (..),\n mkFractionalLit)\nimport GHC_Utils_Misc (readRational)\n#endif\n\n-- Internal\nimport Language.Finkel.Data.SourceText\n\n-- | Make a 'FractionalLit' from given real value.\nmkFractionalLit' :: Real a => a -> FractionalLit\n{-# INLINE mkFractionalLit' #-}\n#if MIN_VERSION_ghc(9,2,0)\nmkFractionalLit' = mkTHFractionalLit . toRational\n#else\nmkFractionalLit' = mkFractionalLit\n#endif\n\n-- | Get string representation of 'FractionalLit'.\nshowFractionalList :: FractionalLit -> String\n{-# INLINE showFractionalList #-}\n#if MIN_VERSION_ghc(9,8,0)\nshowFractionalList fl = case fl_text fl of\n NoSourceText -> error \"fractional literal with no source\"\n SourceText s -> unpackFS s\n#else\nshowFractionalList fl = case fl_text fl of\n NoSourceText -> error \"fractional literal with no source\"\n SourceText s -> s\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\n-- | Get rational value from 'FractionalLit'.\nfl_value :: FractionalLit -> Rational\nfl_value = rationalFromFractionalLit\n{-# INLINE fl_value #-}\n#endif\n\n-- | Read a given string as base 10 'FractionalLit'.\nreadFractionalLit :: String -> FractionalLit\n#if MIN_VERSION_ghc(9,2,0)\nreadFractionalLit str = mkSourceFractionalLit str is_neg i e b\n where\n is_neg = startsWithMinus str\n (i, e) = readSignificandExponentPair str\n b = Base10\n#else\nreadFractionalLit str = FL stxt is_neg rat\n where\n is_neg = startsWithMinus str\n rat = readRational str\n stxt = SourceText str\n#endif\n{-# INLINABLE readFractionalLit #-}\n\n-- | Compare the first character of given string with minis sign.\nstartsWithMinus :: String -> Bool\nstartsWithMinus str = case str of\n '-': _ -> True\n _ -> False\n{-# INLINE startsWithMinus #-}\n\nputFractionalLit :: FractionalLit -> Put\ngetFractionalLit :: Get FractionalLit\n{-# INLINABLE putFractionalLit #-}\n{-# INLINABLE getFractionalLit #-}\n\n#if MIN_VERSION_ghc(9,2,0)\nputFractionalLit fl =\n putSourceText (fl_text fl) *> put (fl_neg fl) *> put (fl_signi fl) *>\n put (fl_exp fl) *> putFEB (fl_exp_base fl)\n\ngetFractionalLit =\n FL <$> getSourceText <*> get <*> get <*> get <*> getFEB\n\nputFEB :: FractionalExponentBase -> Put\nputFEB base = case base of\n Base2 -> putWord8 0\n Base10 -> putWord8 1\n{-# INLINE putFEB #-}\n\ngetFEB :: Get FractionalExponentBase\ngetFEB = do\n t <- getWord8\n case t of\n 0 -> pure Base2\n 1 -> pure Base10\n _ -> error (\"get (FractionalExponentBase): unknown tag \" ++ show t)\n{-# INLINE getFEB #-}\n\n#else\nputFractionalLit fl =\n putSourceText (fl_text fl) *> put (fl_neg fl) *> put (fl_value fl)\n\ngetFractionalLit =\n FL <$> getSourceText <*> get <*> get\n#endif\n" }, { "path": "finkel-kernel/src/Language/Finkel/Data/SourceText.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE FlexibleInstances #-}\n\n-- | Version compatibility module for 'SourceText'.\nmodule Language.Finkel.Data.SourceText\n ( SourceText\n , IsSourceText(..)\n , toQuotedSourceText\n , fsToSourceText\n , strToSourceText\n , putSourceText\n , getSourceText\n ) where\n\n#include \"ghc_modules.h\"\n\n-- binary\nimport Data.Binary (Get, Put, getWord8, putWord8)\n\n#if !MIN_VERSION_ghc(9,8,0)\nimport Data.Binary (Binary (..))\n#endif\n\n-- ghc\nimport GHC_Data_FastString (FastString)\nimport GHC_Types_SourceText (SourceText (..))\n\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC_Data_FastString (fsLit)\n#else\nimport GHC_Data_FastString (unpackFS)\n#endif\n\n-- Internal\n#if MIN_VERSION_ghc(9,8,0)\nimport Language.Finkel.Data.FastString (getFastString, putFastString)\n#endif\n\n\n-- ------------------------------------------------------------------------\n-- Type class\n-- ------------------------------------------------------------------------\n\nclass IsSourceText s where\n toSourceText :: s -> SourceText\n\ninstance IsSourceText String where\n toSourceText = strToSourceText\n {-# INLINE toSourceText #-}\n\ninstance IsSourceText FastString where\n toSourceText = fsToSourceText\n {-# INLINE toSourceText #-}\n\n-- | Make a 'SourceText' quoted with double quotes, uses 'show' function.\ntoQuotedSourceText :: Show a => a -> SourceText\ntoQuotedSourceText = toSourceText . show\n{-# INLINE toQuotedSourceText #-}\n\n\n-- ------------------------------------------------------------------------\n-- For Data.Binary.Binary\n-- ------------------------------------------------------------------------\n\nputSourceText :: SourceText -> Put\nputSourceText st = case st of\n#if MIN_VERSION_ghc(9,8,0)\n SourceText str -> putWord8 0 >> putFastString str\n#else\n SourceText str -> putWord8 0 >> put str\n#endif\n NoSourceText -> putWord8 1\n{-# INLINABLE putSourceText #-}\n\ngetSourceText :: Get SourceText\ngetSourceText = do\n t <- getWord8\n case t of\n#if MIN_VERSION_ghc(9,8,0)\n 0 -> SourceText <$> getFastString\n#else\n 0 -> SourceText <$> get\n#endif\n 1 -> pure NoSourceText\n _ -> error $ \"getSourceText: unknown tag \" ++ show t\n{-# INLINABLE getSourceText #-}\n\n\n-- ------------------------------------------------------------------------\n-- Converting to SourceText\n-- ------------------------------------------------------------------------\n\nfsToSourceText :: FastString -> SourceText\n#if MIN_VERSION_ghc(9,8,0)\nfsToSourceText = SourceText\n#else\nfsToSourceText = SourceText . unpackFS\n#endif\n{-# INLINABLE fsToSourceText #-}\n\nstrToSourceText :: String -> SourceText\n#if MIN_VERSION_ghc(9,8,0)\nstrToSourceText = SourceText . fsLit\n#else\nstrToSourceText = SourceText\n#endif\n{-# INLINABLE strToSourceText #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Emit.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE ConstraintKinds #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE TypeOperators #-}\n{-# LANGUAGE UndecidableInstances #-}\n-- | Emit Haskell source code from Haskell AST value.\n--\n-- This module contains types and functions for generating Haskell source code\n-- from AST data types defined in ghc package.\n--\n-- The main purpose is to emit Haskell source code annotated with documentation\n-- comments understood by hadddock, so the generated result could be messy.\n--\n-- Most of the implementations are defined with 'ppr' function from 'Outputable'\n-- type class.\n--\nmodule Language.Finkel.Emit\n ( HsSrc(..)\n , Hsrc(..)\n , genHsSrc\n , putHsSrc\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Monad.IO.Class (MonadIO (..))\nimport System.IO (Handle)\n\n#if MIN_VERSION_ghc(9,6,0)\nimport Data.Foldable (toList)\n#endif\n\n#if !MIN_VERSION_ghc(9,2,0)\nimport Data.Maybe (fromMaybe)\n#endif\n\n#if MIN_VERSION_base(4,11,0)\nimport Prelude hiding ((<>))\n#endif\n\n-- ghc\nimport GHC (OutputableBndrId)\nimport GHC_Data_Bag (bagToList, isEmptyBag)\nimport GHC_Driver_Env (HscEnv (..))\nimport GHC_Driver_Monad (GhcMonad (..))\nimport GHC_Driver_Ppr (printForUser, showSDocForUser)\nimport GHC_Hs (HsModule (..))\nimport GHC_Hs_Binds (LHsBinds, LSig, Sig (..), pprDeclList)\nimport GHC_Hs_Decls (ConDecl (..), DocDecl (..),\n FamEqn (..), FamilyDecl (..),\n FamilyInfo (..), FamilyResultSig (..),\n HsDataDefn (..), HsDecl (..),\n InjectivityAnn (..), LConDecl,\n LDocDecl, LFamilyDecl,\n LTyFamDefltDecl, TyClDecl (..),\n TyFamInstEqn, pprHsFamInstLHS,\n pprTyFamInstDecl)\nimport GHC_Hs_Extension (GhcPass)\nimport GHC_Hs_ImpExp (IE (..), LIE)\nimport GHC_Hs_Type (ConDeclField (..), HsConDetails (..),\n HsContext, HsType (..),\n HsWildCardBndrs (..), LConDeclField,\n LHsContext, LHsQTyVars (..),\n pprHsForAll)\nimport GHC_Types_Basic (TopLevelFlag (..))\nimport GHC_Types_Fixity (LexicalFixity (..))\nimport GHC_Types_Name_Reader (RdrName)\nimport GHC_Types_SrcLoc (GenLocated (..), sortLocated, unLoc)\nimport GHC_Utils_Outputable (Outputable (..), OutputableBndr (..),\n SDoc, braces, char, comma, darrow,\n dcolon, dot, empty, equals, forAllLit,\n fsep, hang, hsep, interpp'SP,\n interppSP, lparen, nest, parens,\n pprWithCommas, punctuate, sep, text,\n vbar, vcat, ($$), ($+$), (<+>), (<>))\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC (getNamePprCtx)\n#else\nimport GHC (getPrintUnqual)\n#define getNamePprCtx getPrintUnqual\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Hs (XModulePs (..))\nimport GHC.Hs.Extension (GhcPs)\nimport Language.Haskell.Syntax.Decls (DataDefnCons (..),\n dataDefnConsNewOrData)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Hs.Doc (LHsDoc, hsDocString)\n#else\nimport GHC_Hs_Doc (LHsDocString)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Env (hsc_units)\nimport GHC.Hs (XRec)\nimport GHC.Hs.Decls (FunDep (..),\n HsConDeclGADTDetails (..))\nimport GHC.Hs.Type (HsSigType (..),\n pprHsOuterSigTyVarBndrs)\nimport GHC.Parser.Annotation (noAnn)\n#else\nimport GHC_Core_Class (pprFundeps)\nimport GHC_Hs_Type (HsImplicitBndrs (..), LHsType)\nimport GHC_Types_SrcLoc (Located, noLoc)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC_Hs_Type (pprLHsContext)\n#else\nimport GHC_Hs_Type (noLHsContext, pprLHsContext)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC_Utils_Outputable (arrow)\n#else\nimport GHC_Utils_Outputable (arrow, pprPanic)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport Language.Haskell.Syntax.Extension (IdP)\n#else\nimport GHC_Hs_Extension (IdP)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Hs_Type (HsForAllTelescope (..), HsScaled (..),\n hsScaledThing, mkHsForAllInvisTele)\nimport GHC_Utils_Outputable (Depth (..))\n#else\nimport GHC_Types_Var (ForallVisFlag (..))\n#endif\n\n#if !MIN_VERSION_ghc(9,0,0)\nimport GHC_Hs_Type (LHsTyVarBndr)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC_Hs_Doc (HsDocString, renderHsDocString)\n#else\nimport GHC_Hs_Doc (HsDocString, unpackHDS)\n#endif\n\n-- Internal\nimport Language.Finkel.Lexer\nimport Language.Finkel.Syntax.Location\n\n\n-- ---------------------------------------------------------------------\n--\n-- Constraints for Outputable\n--\n-- ---------------------------------------------------------------------\n\ntype OUTPUTABLE a pr = (OutputableBndrId pr, a ~ GhcPass pr)\n\n\n-- ---------------------------------------------------------------------\n--\n-- Annotation dictionary\n--\n-- ---------------------------------------------------------------------\n\n{-\nisDocComment :: Located AnnotationComment -> Bool\nisDocComment x =\n case unLoc x of\n AnnDocCommentNext _ -> True\n AnnDocCommentPrev _ -> True\n AnnDocCommentNamed _ -> True\n AnnDocSection _ _ -> True\n _ -> False\n\nbuildDocMap :: [Located AnnotationComment] -> DocMap\nbuildDocMap acs = go (Map.empty, Nothing, []) (sortLocated acs)\n where\n go :: ( Map.Map SrcSpan [AnnotationComment]\n , Maybe SrcSpan\n , [AnnotationComment] )\n -> [Located AnnotationComment]\n -> DocMap\n go (acc, keySpan, block) [] =\n case keySpan of\n Nothing -> acc\n Just k -> Map.insert k (reverse block) acc\n go (acc, keySpan, block) (com:coms) =\n case keySpan of\n Just k ->\n case (k, getLoc com) of\n (RealSrcSpan k', RealSrcSpan com') ->\n if (srcSpanEndLine k' + 1) == srcSpanStartLine com'\n then go ( acc\n , Just (combineSrcSpans k (getLoc com))\n , unLoc com:block )\n coms\n else\n let acc' = Map.insert k (reverse block) acc\n isDoc = isDocComment com\n keySpan' | isDoc = Just (getLoc com)\n | otherwise = Nothing\n block' | isDoc = [unLoc com]\n | otherwise = []\n in go (acc', keySpan', block') coms\n _ -> go (acc, Nothing, []) coms\n Nothing ->\n if isDocComment com\n then go (acc, Just (getLoc com), [unLoc com]) coms\n else go (acc, Nothing, block) coms\n\nspanStartLine :: SrcSpan -> Int\nspanStartLine l =\n case l of\n RealSrcSpan s -> srcSpanStartLine s\n _ -> -1\n\nspanEndLine :: SrcSpan -> Int\nspanEndLine l =\n case l of\n RealSrcSpan s -> srcSpanEndLine s\n _ -> -1\n\n-- | Lookup previous documentation comment.\n--\n-- Here @previous@ means the end line of documentation comment matches\n-- to the start line of reference span - offset.\n--\nlookupPrevDoc :: Int -> SrcSpan -> DocMap -> Maybe [AnnotationComment]\nlookupPrevDoc offset l =\n let line = spanStartLine l\n f k a | spanEndLine k == line - offset = Just a\n | otherwise = Nothing\n in Map.foldMapWithKey f\n\nemitPrevDoc :: SPState -> Located a -> SDoc\nemitPrevDoc = emitPrevDocWithOffset 1\n\nemitPrevDocWithOffset :: Int -> SPState -> Located a -> SDoc\nemitPrevDocWithOffset offset st ref =\n case lookupPrevDoc offset (getLoc ref) (docMap st) of\n Nothing -> empty\n Just as -> vcat (map f as)\n where\n f annotated = case annotated of\n AnnDocCommentNext doc -> case lines doc of\n c:cs -> vcat ((text \"-- | \" <> text c):\n map (\\ x -> text \"--\" <> text x) cs)\n [] -> empty\n AnnLineComment doc -> text \"-- \" <> text doc\n _ -> ppr annotated\n\n#if !MIN_VERSION_ghc(8,4,0)\n-- | 'whenPprDebug' does not exist in ghc 8.2. Defining one with\n-- 'ifPprDebug'. Also, number of arguments in 'ifPprDebug' changed in\n-- ghc 8.4.\nwhenPprDebug :: SDoc -> SDoc\nwhenPprDebug d = ifPprDebug d\n#endif\n\n-}\n\n\n-- ---------------------------------------------------------------------\n--\n-- HsSrc class\n--\n-- ---------------------------------------------------------------------\n\n-- | Type class for generating textual source code.\nclass HsSrc a where\n toHsSrc :: SPState -> a -> SDoc\n\n-- | A wrapper type to specify instance of 'HsSrc'.\nnewtype Hsrc a = Hsrc {unHsrc :: a}\n\n-- | Generate textual source code from given data.\ngenHsSrc :: (GhcMonad m, HsSrc a) => SPState -> a -> m String\ngenHsSrc st0 x = do\n hsc_env <- getSession\n let dflags = hsc_dflags hsc_env\n unqual <- getNamePprCtx\n#if MIN_VERSION_ghc(9,2,0)\n return (showSDocForUser dflags (hsc_units hsc_env) unqual (toHsSrc st0 x))\n#else\n return (showSDocForUser dflags unqual (toHsSrc st0 x))\n#endif\n\n-- | Print textual source code of given data to given 'Handle'.\nputHsSrc :: (GhcMonad m, HsSrc a, MonadIO m) => Handle -> SPState -> a -> m ()\nputHsSrc hdl st0 x = do\n hsc_env <- getSession\n unqual <- getNamePprCtx\n let dflags = hsc_dflags hsc_env\n#if MIN_VERSION_ghc(9,0,1)\n render = printForUser dflags hdl unqual AllTheWay\n#else\n render = printForUser dflags hdl unqual\n#endif\n liftIO (render (toHsSrc st0 x))\n\n\n-- ---------------------------------------------------------------------\n--\n-- Instances\n--\n-- ---------------------------------------------------------------------\n\ninstance HsSrc RdrName where\n toHsSrc _ = ppr\n\ninstance (HsSrc b) => HsSrc (GenLocated a b) where\n toHsSrc st (L _ e) = toHsSrc st e\n\n-- Some CPP macros to pattern match with constructors of HsModule.\n\n#if MIN_VERSION_ghc(9,6,0)\n#define HSMODEXT modExt\n#define HSMODDEPREC {- no hsmodDeprecMessage -}\n#define HSMODMBDOC {- no hsmodHaddockModHeader -}\n#else\n#define HSMODEXT {- no hsmodExt -}\n#define HSMODDEPREC deprec\n#define HSMODMBDOC mbDoc\n#endif\n\n#if !MIN_VERSION_ghc(9,2,0) || MIN_VERSION_ghc(9,6,0)\n#define HSMODANN {- no hsmodAnn -}\n#else\n#define HSMODANN _hsmodAnn\n#endif\n\n#if !MIN_VERSION_ghc(9,0,0) || MIN_VERSION_ghc(9,6,0)\n#define LAYOUTINFO {- no LayoutInfo -}\n#else\n#define LAYOUTINFO _layout_info\n#endif\n\n-- HsModule used had an argument until 9.0, and then the argument came back in\n-- 9.6.\n#if MIN_VERSION_ghc(9,6,0)\ninstance HsSrc (Hsrc (HsModule GhcPs)) where\n#elif MIN_VERSION_ghc(9,0,0)\ninstance HsSrc (Hsrc HsModule) where\n#else\ninstance OUTPUTABLE a pr => HsSrc (Hsrc (HsModule a)) where\n#endif\n toHsSrc st a = case unHsrc a of\n HsModule HSMODEXT HSMODANN LAYOUTINFO mb_name exports imports decls\n HSMODDEPREC HSMODMBDOC ->\n vcat ([ pp_headerPragmas st\n , pp_mbdocn mbDoc ] ++\n mb_header ++\n [ pp_nonnull imports\n , hsSrc_nonnull st (map unLoc decls)\n , text \"\" ])\n where\n mb_header =\n case mb_name of\n Nothing -> []\n Just name -> [ case exports of\n Nothing -> pp_header name (text \"where\")\n Just es -> vcat [ pp_header name lparen\n , nest 8 (pp_lies st (unLoc es))\n , nest 4 (text \") where\") ]]\n pp_header name rest =\n case deprec of\n Nothing -> pp_modname name <+> rest\n Just d -> vcat [pp_modname name, ppr d, rest]\n pp_modname name =\n text \"module\" <+> ppr name\n#if MIN_VERSION_ghc(9,6,0)\n mbDoc = hsmodHaddockModHeader modExt\n deprec = hsmodDeprecMessage modExt\n#endif\n\ninstance OUTPUTABLE a pr => HsSrc (Hsrc (IE a)) where\n toHsSrc _st (Hsrc ie) =\n case ie of\n IEGroup _ n doc -> commentWithHeader (\"-- \" ++ replicate n '*')\n (getHsDocString doc)\n IEDoc _ doc -> commentWithHeader \"-- |\" (getHsDocString doc)\n IEDocNamed _ doc -> text (\"-- $\" ++ doc)\n _ -> ppr ie\n\n\n-- --------------------------------------------------------------------\n--\n-- Top level declarations\n--\n-----------------------------------------------------------------------\n\ninstance OUTPUTABLE a pr => HsSrc (HsDecl a) where\n toHsSrc st decl =\n case decl of\n SigD _ sig -> toHsSrc st sig\n TyClD _ tycld -> toHsSrc st tycld\n DocD _ doc -> toHsSrc st doc\n _ -> ppr decl\n\n\n-- --------------------------------------------------------------------\n--\n-- Type signature\n--\n-----------------------------------------------------------------------\n\ninstance OUTPUTABLE a pr => HsSrc (Sig a) where\n toHsSrc st sig = case sig of\n TypeSig _ vars ty -> pprVarSig (map unLoc vars)\n (toHsSrc st ty)\n ClassOpSig _ is_dflt vars ty\n | is_dflt -> text \"default\" <+> pprVarSig (map unLoc vars)\n (toHsSrc st ty)\n | otherwise -> pprVarSig (map unLoc vars) (toHsSrc st ty)\n _ -> ppr sig\n\n#if MIN_VERSION_ghc(9,2,0)\ninstance (OUTPUTABLE a pr) => HsSrc (HsSigType a) where\n toHsSrc st (HsSig { sig_bndrs = outer_bndrs, sig_body = body}) =\n pprHsOuterSigTyVarBndrs outer_bndrs <+> toHsSrc st body\n#endif\n\ninstance (OUTPUTABLE a pr, Outputable thing, HsSrc thing)\n => HsSrc (HsWildCardBndrs a thing) where\n toHsSrc st wc = case wc of\n HsWC { hswc_body = ty } -> toHsSrc st ty\n#if !MIN_VERSION_ghc(9,0,0)\n _ -> ppr wc\n#endif\n\n#if !MIN_VERSION_ghc(9,2,0)\ninstance (OUTPUTABLE a pr)\n => HsSrc (HsImplicitBndrs a (LHsType a)) where\n toHsSrc st ib =\n case ib of\n HsIB { hsib_body = ty } -> toHsSrc st ty\n# if !MIN_VERSION_ghc(9,0,0)\n _ -> ppr ib\n# endif\n#endif\n\ninstance (OUTPUTABLE a pr) => HsSrc (HsType a) where\n toHsSrc st ty = case ty of\n#if MIN_VERSION_ghc(9,0,0)\n HsForAllTy {hst_tele=tele, hst_body=ty1} ->\n sep [pprHsTele tele, hsrc ty1]\n#else\n HsForAllTy {hst_bndrs=tvs, hst_body=ty1} ->\n sep [pprHsForAllTvs tvs, hsrc ty1]\n#endif\n#if MIN_VERSION_ghc(9,4,0)\n HsQualTy {hst_ctxt=ctxt, hst_body=ty1} ->\n sep [ pprHsContextAlways (unLoc ctxt)\n , hsrc ty1 ]\n#elif MIN_VERSION_ghc(9,2,0)\n HsQualTy {hst_ctxt=ctxt, hst_body=ty1} ->\n sep [ maybe (parens empty <+> darrow) (pprHsContextAlways . unLoc) ctxt\n , hsrc ty1]\n#else\n HsQualTy {hst_ctxt=L _ ctxt, hst_body=ty1} ->\n sep [pprHsContextAlways ctxt, hsrc ty1]\n#endif\n#if MIN_VERSION_ghc(9,0,0)\n HsFunTy _ _arrow ty1 ty2 -> t_arr_t ty1 ty2\n#else\n HsFunTy _ ty1 ty2 -> t_arr_t ty1 ty2\n#endif\n HsDocTy _ ty1 (L _ docstr) ->\n#if MIN_VERSION_ghc(9,4,0)\n ppr ty1 $+$ commentWithHeader \"-- ^\" (hsDocString docstr)\n#else\n ppr ty1 $+$ commentWithHeader \"-- ^\" docstr\n#endif\n HsParTy _ ty1 -> parens (hsrc ty1)\n _ -> ppr ty\n where\n t_arr_t t1 t2 = sep [hsrc t1, text \"->\", hsrc t2]\n hsrc :: HsSrc a => a -> SDoc\n hsrc = toHsSrc st\n\n#if MIN_VERSION_ghc(9,0,0)\ninstance (HsSrc a) => HsSrc (HsScaled pass a) where\n toHsSrc st (HsScaled _cnt t) = toHsSrc st t\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\npprHsTele :: OutputableBndrId p => HsForAllTelescope (GhcPass p) -> SDoc\npprHsTele hsfat =\n case hsfat of\n HsForAllVis {hsf_vis_bndrs=_bndrs}->\n error \"pprHsTele: HsForAllVis NYI\"\n HsForAllInvis {hsf_invis_bndrs=bndrs} ->\n forAllLit <+> interppSP bndrs <> dot\n#else\npprHsForAllTvs :: OUTPUTABLE n pr => [LHsTyVarBndr n] -> SDoc\npprHsForAllTvs qtvs\n | null qtvs = forAllLit <+> dot\n | otherwise = forAllLit <+> interppSP qtvs <> dot\n#endif\n\n-- From 'HsBinds.pprVarSig'.\npprVarSig :: OutputableBndr id => [id] -> SDoc -> SDoc\npprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]\n where\n pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)\n\n-- From 'HsTypes.pprHsContextAlways'.\npprHsContextAlways :: OUTPUTABLE n pr => HsContext n -> SDoc\npprHsContextAlways [] = parens empty <+> darrow\npprHsContextAlways [L _ ty] = ppr ty <+> darrow\npprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow\n\n\n-- --------------------------------------------------------------------\n--\n-- TyClDecl\n--\n-- --------------------------------------------------------------------\n\ninstance OUTPUTABLE a pr => HsSrc (TyClDecl a) where\n toHsSrc st tcd =\n case tcd of\n SynDecl { tcdLName = ltycon, tcdTyVars = tyvars\n , tcdFixity = fixity, tcdRhs = rhs } ->\n hang (text \"type\" <+>\n#if MIN_VERSION_ghc(9,2,0)\n pp_vanilla_decl_head ltycon tyvars fixity Nothing <+>\n#else\n pp_vanilla_decl_head ltycon tyvars fixity [] <+>\n#endif\n equals)\n 4 (toHsSrc st rhs)\n DataDecl { tcdLName = ltycon, tcdTyVars = tyvars\n , tcdFixity = fixity, tcdDataDefn = defn } ->\n pp_data_defn st (pp_vanilla_decl_head ltycon tyvars fixity) defn\n ClassDecl { tcdCtxt = context, tcdLName = lclas\n , tcdTyVars = tyvars, tcdFixity = fixity\n , tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods\n , tcdATs = ats, tcdATDefs = at_defs\n , tcdDocs = docs }\n | null sigs && isEmptyBag methods && null ats && null at_defs\n -> top_matter\n | otherwise\n -> vcat\n [ top_matter <+> text \"where\"\n , nest 2\n (pprDeclList\n (ppr_cdecl_body st ats at_defs methods sigs docs))]\n where\n top_matter =\n text \"class\"\n#if MIN_VERSION_ghc(9,2,0)\n <+> pp_vanilla_decl_head lclas tyvars fixity context\n#else\n <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)\n#endif\n <+> pprFundeps (map unLoc fds)\n _ -> ppr tcd\n\n#if MIN_VERSION_ghc(9,2,0)\n-- Until ghc 9.0.2, GHC.Core.pprFundeps were reused.\npprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc\npprFundeps [] = empty\npprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))\n\npprFunDep :: OutputableBndrId p => FunDep (GhcPass p) -> SDoc\npprFunDep (FunDep _ us vs) = hsep [interppSP us, arrow, interppSP vs]\n\n#endif\n\n-- --------------------------------------------------------------------\n--\n-- For SynDecl and DataDecl\n--\n-- --------------------------------------------------------------------\n\npp_data_defn :: OUTPUTABLE n pr\n => SPState\n#if MIN_VERSION_ghc(9,2,0)\n -> (Maybe (LHsContext n) -> SDoc)\n#else\n -> (HsContext n -> SDoc)\n#endif\n -> HsDataDefn n\n -> SDoc\npp_data_defn\n st pp_hdr HsDataDefn { dd_cType = mb_ct, dd_kindSig = mb_sig\n#if !MIN_VERSION_ghc(9,6,0)\n , dd_ND = new_or_data\n#endif\n#if MIN_VERSION_ghc(9,2,0)\n , dd_ctxt = context\n#else\n , dd_ctxt = L _ context\n#endif\n , dd_cons = condecls\n , dd_derivs = derivings }\n | null condecls\n = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig\n <+> pp_derivings derivings\n | otherwise\n = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig)\n 2 (pp_cds condecls $$ pp_derivings derivings)\n where\n#if MIN_VERSION_ghc(9,6,0)\n new_or_data = dataDefnConsNewOrData condecls\n pp_cds cds =\n case cds of\n -- The _bool field in `DataTypeCOns' is for TypeData language extension\n -- introduced in ghc 9.6.1.\n NewTypeCon c -> text \"=\" <+> pprConDecl st (unLoc c)\n DataTypeCons _bool cs -> pp_condecls st cs\n#else\n pp_cds = pp_condecls st\n#endif\n pp_ct = maybe empty ppr mb_ct\n pp_sig = maybe empty ((dcolon <+>) . ppr) mb_sig\n#if MIN_VERSION_ghc(9,2,0)\n pp_derivings ds = vcat (map ppr ds)\n#else\n pp_derivings (L _ ds) = vcat (map ppr ds)\n#endif\n#if !MIN_VERSION_ghc(9,0,0)\npp_data_defn _ _ (XHsDataDefn x) = ppr x\n#endif\n\n-- Modified version of 'HsDecls.pp_condecls', no space in front of \"|\",\n-- taking 'SPState' as first argument.\npp_condecls :: (OUTPUTABLE n pr) => SPState -> [LConDecl n] -> SDoc\npp_condecls st cs@(L _ ConDeclGADT {} : _) =\n hang (text \"where\") 2 (vcat (map (pprConDecl st . unLoc) cs))\npp_condecls st cs =\n equals <+> sep (punctuate (text \" |\") (map (pprConDecl st . unLoc) cs))\n\n-- For pattern match of 'PrefixCon' in below 'pprConDecl' function.\n\n#if MIN_VERSION_ghc(9,2,0)\n#define _TYARGS _\n#else\n#define _TYARGS {- no [tyargs] -}\n#endif\n\n-- Modified version of 'HsDecls.pprConDecl'. This function does the pretty\n-- printing of documentation for constructors.\n--\n-- Although the syntax parser for constructor documentation accepts \":doc^\"\n-- form, this function emit documentation before the constructor declaration, to\n-- support documentation for constructor argument. This is because haddock may\n-- concatenate the docstring for the last constructor argument and the docstring\n-- for constructor itself.\npprConDecl :: OUTPUTABLE n pr => SPState -> ConDecl n -> SDoc\npprConDecl st condecl@ConDeclH98 {} =\n pp_mbdocn doc $+$ sep [hforall, ppr_details details]\n where\n#if MIN_VERSION_ghc(9,2,0)\n hforall = pprHsForAll' (mkHsForAllInvisTele noAnn tvs) mcxt\n#elif MIN_VERSION_ghc(9,0,0)\n hforall = pprHsForAll' (mkHsForAllInvisTele tvs) cxt\n cxt = fromMaybe (noLoc []) mcxt\n#else\n hforall = pprHsForAll' tvs cxt\n cxt = fromMaybe (noLoc []) mcxt\n#endif\n ConDeclH98 { con_name = L _ con\n , con_ex_tvs = tvs\n , con_mb_cxt = mcxt\n , con_args = details\n , con_doc = doc } = condecl\n#if MIN_VERSION_ghc(9,0,0)\n ppr_details (InfixCon t1 t2) =\n hsep [hsrc (hsScaledThing t1), pprInfixOcc con, hsrc (hsScaledThing t2)]\n ppr_details (PrefixCon _TYARGS tys) =\n sep (pprPrefixOcc con : map (hsrc . unLoc . hsScaledThing) tys)\n#else\n ppr_details (InfixCon t1 t2) =\n hsep [hsrc t1, pprInfixOcc con, hsrc t2]\n ppr_details (PrefixCon tys) =\n sep (pprPrefixOcc con : map (hsrc . unLoc) tys)\n#endif\n ppr_details (RecCon fields) =\n pprPrefixOcc con <+> pprConDeclFields (unLoc fields)\n hsrc :: HsSrc a => a -> SDoc\n hsrc = toHsSrc st\n\npprConDecl st ConDeclGADT { con_names = cons\n#if MIN_VERSION_ghc(9,2,0)\n , con_bndrs = L _ outer_bndrs\n , con_g_args = args\n#else\n , con_qvars = qvars\n , con_args = args\n#endif\n , con_mb_cxt = mcxt\n , con_res_ty = res_ty\n , con_doc = doc }\n = pp_mbdocn doc $+$ ppr_con_names cons' <+> dcolon\n <+> sep [hforall -- pprHsForAll' (hsq_explicit qvars) cxt\n ,ppr_arrow_chain (get_args args ++ [hsrc res_ty])]\n where\n#if MIN_VERSION_ghc(9,6,0)\n cons' = toList cons\n#else\n cons' = cons\n#endif\n#if MIN_VERSION_ghc(9,2,0)\n hforall = pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt\n#elif MIN_VERSION_ghc(9,0,0)\n hforall = pprHsForAll' (mkHsForAllInvisTele qvars) cxt\n cxt = fromMaybe (noLoc []) mcxt\n#else\n hforall = pprHsForAll' (hsq_explicit qvars) cxt\n cxt = fromMaybe (noLoc []) mcxt\n#endif\n#if MIN_VERSION_ghc(9,10,0)\n get_args (PrefixConGADT _x csts) = map hsrc csts\n get_args (RecConGADT _ fields) = [pprConDeclFields (unLoc fields)]\n#elif MIN_VERSION_ghc(9,4,0)\n get_args (PrefixConGADT csts) = map hsrc csts\n get_args (RecConGADT fields _) = [pprConDeclFields (unLoc fields)]\n#elif MIN_VERSION_ghc(9,2,0)\n get_args (PrefixConGADT csts) = map hsrc csts\n get_args (RecConGADT fields) = [pprConDeclFields (unLoc fields)]\n#else\n get_args (PrefixCon as) = map hsrc as\n get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]\n get_args (InfixCon {}) = pprPanic \"pprConDecl:GADT\" (ppr cons)\n#endif\n ppr_arrow_chain [] = empty\n ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)\n hsrc :: HsSrc a => a -> SDoc\n hsrc = toHsSrc st\n\n#if !MIN_VERSION_ghc(9,0,0)\npprConDecl _ con = ppr con\n#endif\n\n-- From 'HsDecls.ppr_con_names'.\n#if MIN_VERSION_ghc(9,2,0)\nppr_con_names :: OutputableBndr a => [GenLocated l a] -> SDoc\n#else\nppr_con_names :: OutputableBndr a => [Located a] -> SDoc\n#endif\nppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)\n\n-- Modified version of 'HsTypes.pprConDeclFields', to emit documentation\n-- comments of fields in record data type.\npprConDeclFields :: OUTPUTABLE n pr => [LConDeclField n] -> SDoc\npprConDeclFields fields =\n braces (sep (punctuate comma (map ppr_fld fields)))\n where\n ppr_fld (L _ ConDeclField { cd_fld_names = ns\n , cd_fld_type = ty\n , cd_fld_doc = mb_doc })\n = ppr_names ns <+> dcolon <+> ppr ty\n $+$ pp_mbdocp mb_doc $+$ text \"\"\n ppr_fld (L _ (XConDeclField x)) = ppr x\n ppr_names [n] = ppr n\n ppr_names ns = sep (punctuate comma (map ppr ns))\n\n-- From 'HsDecls.pp_vanilla_decl_head'.\npp_vanilla_decl_head :: (OUTPUTABLE n pr)\n#if MIN_VERSION_ghc(9,2,0)\n => XRec n (IdP n)\n#else\n => Located (IdP n)\n#endif\n -> LHsQTyVars n\n -> LexicalFixity\n#if MIN_VERSION_ghc(9,2,0)\n -> Maybe (LHsContext n)\n#else\n -> HsContext n\n#endif\n -> SDoc\npp_vanilla_decl_head thing HsQTvs {hsq_explicit=tyvars} fixity context =\n hsep [pprHsContext context, pp_tyvars tyvars]\n where\n pp_tyvars (varl:varsr)\n | fixity == Infix, varsr_hd:varsr_tl <- varsr\n = hsep [ char '(', ppr (unLoc varl), pprInfixOcc (unLoc thing)\n , ppr (unLoc varsr_hd), char ')'\n , hsep (map (ppr . unLoc) varsr_tl) ]\n | fixity == Infix\n = hsep [ ppr (unLoc varl), pprInfixOcc (unLoc thing)\n , hsep (map (ppr . unLoc) varsr) ]\n | otherwise = hsep [ pprPrefixOcc (unLoc thing)\n , hsep (map (ppr . unLoc) (varl: varsr)) ]\n pp_tyvars [] = pprPrefixOcc (unLoc thing)\n#if !MIN_VERSION_ghc(9,0,0)\npp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x\n#endif\n\n\n-- --------------------------------------------------------------------\n--\n-- For ClassDecl\n--\n-- --------------------------------------------------------------------\n\nppr_cdecl_body :: OUTPUTABLE n pr\n => SPState\n -> [LFamilyDecl n]\n#if MIN_VERSION_ghc(8,10,1)\n -> [LTyFamDefltDecl n]\n#else\n -> [LTyFamDefltEqn n]\n#endif\n -> LHsBinds n\n -> [LSig n]\n#if MIN_VERSION_ghc(9,2,0)\n -> [LDocDecl n]\n#else\n -> [LDocDecl]\n#endif\n -> [SDoc]\nppr_cdecl_body st ats at_defs methods sigs docs = body\n where\n body = map unLoc (sortLocated body0)\n body0 =\n map (reLoc . fmap (pprFamilyDecl NotTopLevel)) ats ++\n#if MIN_VERSION_ghc(9,2,0)\n map (reLoc . fmap (pprTyFamInstDecl NotTopLevel)) at_defs ++\n#else\n map (\\d@(L l _) -> L l (ppr_fam_deflt_eqn d)) at_defs ++\n#endif\n map (reLoc . fmap (toHsSrc st)) sigs ++\n map (reLoc . fmap ppr) (bagToList methods) ++\n map (reLoc . fmap (toHsSrc st)) docs\n\n#if MIN_VERSION_ghc(9,2,0)\n#define XCINJECTIVITYANN unused\n#define _XCINJECTIVITYANN _\n#else\n#define XCINJECTIVITYANN {- no XCInjectivityAnn -}\n#define _XCINJECTIVITYANN {- no XCInjectivityAnn -}\n#endif\n\n-- From 'HsDecls.pprFamilyDecl'. Used during pretty printing type class body\n-- contents, with first argument set to 'NonTopLevel'.\npprFamilyDecl :: (OUTPUTABLE n pr)\n => TopLevelFlag -> FamilyDecl n -> SDoc\npprFamilyDecl top_level FamilyDecl { fdInfo = info\n , fdLName = ltycon\n , fdTyVars = tyvars\n , fdFixity = fixity\n , fdResultSig = L _ result\n , fdInjectivityAnn = mb_inj }\n = vcat [ pprFlavour info <+> pp_top_level <+>\n#if MIN_VERSION_ghc(9,2,0)\n pp_vanilla_decl_head ltycon tyvars fixity Nothing <+>\n#else\n pp_vanilla_decl_head ltycon tyvars fixity [] <+>\n#endif\n pp_kind <+> pp_inj <+> pp_where\n , nest 2 pp_eqns ]\n where\n pp_top_level = case top_level of\n TopLevel -> text \"family\"\n NotTopLevel -> empty\n\n pp_kind = case result of\n NoSig _ -> empty\n KindSig _ kind -> dcolon <+> ppr kind\n TyVarSig _ tv_bndr -> text \"=\" <+> ppr tv_bndr\n#if !MIN_VERSION_ghc(9,0,0)\n XFamilyResultSig x -> ppr x\n#endif\n pp_inj = case mb_inj of\n Just (L _ (InjectivityAnn _XCINJECTIVITYANN lhs rhs)) ->\n hsep [ vbar, ppr lhs, text \"->\", hsep (map ppr rhs) ]\n Nothing -> empty\n (pp_where, pp_eqns) = case info of\n ClosedTypeFamily mb_eqns ->\n ( text \"where\"\n , case mb_eqns of\n Nothing -> text \"..\"\n Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )\n _ -> (empty, empty)\n#if !MIN_VERSION_ghc(9,0,0)\npprFamilyDecl _ (XFamilyDecl x) = ppr x\n#endif\n\n-- From 'HsDecls.pprFlavour'.\npprFlavour :: FamilyInfo pass -> SDoc\npprFlavour DataFamily = text \"data\"\npprFlavour OpenTypeFamily = text \"type\"\npprFlavour ClosedTypeFamily {} = text \"type\"\n\n-- From 'HsDecls.ppr_fam_inst_eqn'\nppr_fam_inst_eqn :: (OUTPUTABLE n pr) => TyFamInstEqn n -> SDoc\n#if MIN_VERSION_ghc(9,2,0)\nppr_fam_inst_eqn (FamEqn { feqn_tycon = L _ tycon\n , feqn_bndrs = bndrs\n , feqn_pats = pats\n , feqn_fixity = fixity\n , feqn_rhs = rhs })\n = pprHsFamInstLHS tycon bndrs pats fixity Nothing <+> equals <+> ppr rhs\n#else\nppr_fam_inst_eqn HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon\n , feqn_bndrs = bndrs\n , feqn_pats = pats\n , feqn_fixity = fixity\n , feqn_rhs = rhs }}\n = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+>\n equals <+> ppr rhs\n# if !MIN_VERSION_ghc(9,0,0)\nppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x\nppr_fam_inst_eqn _ = error \"ppr_fam_inst_eqn\"\n# endif\n#endif\n\n-- From 'HsDecls.ppr_fam_deflt_eqn'\n#if !MIN_VERSION_ghc(9,2,0)\nppr_fam_deflt_eqn :: OUTPUTABLE n pr => LTyFamDefltDecl n -> SDoc\nppr_fam_deflt_eqn (L _ tfdd) = pprTyFamInstDecl NotTopLevel tfdd\n#endif\n\n\n-- ---------------------------------------------------------------------\n--\n-- DocDecl\n--\n-- ---------------------------------------------------------------------\n\n#if MIN_VERSION_ghc(9,4,0)\n#define DOCDECL (DocDecl pass)\n#else\n#define DOCDECL DocDecl\n#endif\n\ninstance HsSrc DOCDECL where\n toHsSrc _st d = case d of\n DocCommentNext ds -> text \"\"\n $+$ commentWithHeader \"-- |\" (getHsDocString ds)\n DocCommentPrev ds -> text \"\"\n $+$ commentWithHeader \"-- ^\" (getHsDocString ds)\n $+$ text \"\"\n DocCommentNamed name ds -> namedDoc name (getHsDocString ds)\n DocGroup n ds -> let stars = replicate n '*'\n in commentWithHeader (\"-- \" ++ stars)\n (getHsDocString ds)\n where\n namedDoc name doc =\n let body = map (\\x -> text \"--\" <+> text x)\n (lines (unpackHDS' doc))\n in vcat (text \"\" : text (\"-- $\" ++ name) : text \"--\" : body)\n\n\n-- -------------------------------------------------------------------\n--\n-- Auxiliary\n--\n-- -------------------------------------------------------------------\n\npp_nonnull :: Outputable t => [t] -> SDoc\npp_nonnull [] = empty\npp_nonnull xs = vcat (map ppr xs)\n\n#if MIN_VERSION_ghc(9,4,0)\npp_mbdocn :: Maybe (LHsDoc pass) -> SDoc\npp_mbdocn = maybe empty (commentWithHeader \"-- |\" . getHsDocString)\n\npp_mbdocp :: Maybe (LHsDoc pass) -> SDoc\npp_mbdocp = maybe empty (commentWithHeader \"-- ^\" . getHsDocString)\n#else\npp_mbdocn :: Maybe LHsDocString -> SDoc\npp_mbdocn = maybe empty (commentWithHeader \"-- |\" . unLoc)\n\npp_mbdocp :: Maybe LHsDocString -> SDoc\npp_mbdocp = maybe empty (commentWithHeader \"-- ^\" . unLoc)\n#endif\n\npp_headerPragmas :: SPState -> SDoc\npp_headerPragmas sp = vcat sorted_pragmas\n where\n sorted_pragmas = map unLoc (sortLocated pragmas)\n pragmas = map lang (langExts sp) ++\n map ghc_opt (ghcOptions sp) ++\n map haddock_opt (haddockOptions sp)\n\n lang (L l e) = L l (gen \"LANGUAGE\" e)\n ghc_opt (L l o) = L l (gen \"OPTIONS_GHC\" o)\n haddock_opt (L l o) = L l (gen \"OPTIONS_HADDOCK\" o)\n gen label x = text \"{-#\" <+> text label <+> text x <+> text \"#-}\"\n\nhsSrc_nonnull :: HsSrc a => SPState -> [a] -> SDoc\nhsSrc_nonnull st xs =\n case xs of\n [] -> empty\n _ -> vcat (map (toHsSrc st) xs)\n\ncommentWithHeader :: String -> HsDocString -> SDoc\ncommentWithHeader header doc =\n case lines (unpackHDS' doc) of\n [] -> empty\n d:ds -> vcat ((text header <+> text d):\n map (\\ x -> text \"--\" <+> text x) ds)\n\n-- | Format located export elements.\n--\n-- This function converts module export elements and comments to 'SDoc'.\n-- Export elements are punctuated with commas, and newlines are inserted\n-- between documentation comments.\npp_lies :: OUTPUTABLE a pr => SPState -> [LIE a] -> SDoc\npp_lies st = go\n where\n go [] = empty\n go ds =\n case break (isDocIE . unLoc) ds of\n (nondocs, rest) ->\n let sdoc = fsep (punctuate comma (map (toHsSrc st . Hsrc . unLoc)\n nondocs))\n sdoc' = case nondocs of\n [] -> sdoc\n _ -> sdoc <> comma\n in case rest of\n [] -> sdoc\n doc:rest' -> sdoc'\n $+$ toHsSrc st (Hsrc (unLoc doc))\n $+$ go rest'\n\n-- | 'True' when the argument is for documentation.\nisDocIE :: IE a -> Bool\nisDocIE ie =\n case ie of\n IEGroup {} -> True\n IEDoc {} -> True\n IEDocNamed {} -> True\n _ -> False\n\n-- | GHC version compatible function for unpacking 'HsDocString'.\nunpackHDS' :: HsDocString -> String\n#if MIN_VERSION_ghc(9,4,0)\n-- XXX: Consider using 'exactPrintHsDocString' or 'pprHsDocString'.\nunpackHDS' = renderHsDocString\n#else\nunpackHDS' = unpackHDS\n#endif\n\n-- | GHC version compatible function for pretty printing 'HsContext'.\n#if MIN_VERSION_ghc(9,2,0)\npprHsContext :: OUTPUTABLE a pr => Maybe (LHsContext a) -> SDoc\npprHsContext = pprLHsContext\n#else\npprHsContext :: OUTPUTABLE n a => HsContext (GhcPass a) -> SDoc\npprHsContext = pprLHsContext . noLoc\n#endif\n\n-- | GHC version compatible function for pretty printing @forall@.\n#if MIN_VERSION_ghc(9,2,0)\npprHsForAll'\n :: OUTPUTABLE a pr => HsForAllTelescope a -> Maybe (LHsContext a) -> SDoc\npprHsForAll' = pprHsForAll\n#elif MIN_VERSION_ghc(9,0,0)\npprHsForAll'\n :: OUTPUTABLE a pr => HsForAllTelescope a -> LHsContext a -> SDoc\npprHsForAll' = pprHsForAll\n#else\npprHsForAll' :: OUTPUTABLE a pr => [LHsTyVarBndr a] -> LHsContext a -> SDoc\npprHsForAll' = pprHsForAll ForallInvis\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\ngetHsDocString :: LHsDoc pass -> HsDocString\ngetHsDocString = hsDocString . unLoc\n#else\ngetHsDocString :: HsDocString -> HsDocString\ngetHsDocString = id\n#endif\n{-# INLINABLE getHsDocString #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Error.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE TypeApplications #-}\n{-# LANGUAGE TypeFamilies #-}\n-- | Version compatible variant of error message type and functions.\n\nmodule Language.Finkel.Error\n (\n -- * Simple SDoc error message\n WrappedMsg\n , mkWrappedMsg\n , mkPlainWrappedMsg\n\n -- * For printing error message\n , HasLogger(..), Logger, WARNINGs\n , printLocatedString\n , printOrThrowDiagnostics'\n\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Monad.IO.Class (MonadIO (..))\n\n#if MIN_VERSION_ghc(9,4,0)\nimport Data.Typeable (Typeable)\n#endif\n\n-- ghc\nimport GHC_Data_Bag (unitBag)\nimport GHC_Driver_Session (DynFlags)\nimport GHC_Types_SrcLoc (SrcSpan)\nimport GHC_Utils_Outputable (SDoc, neverQualify, text)\n\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Driver.Errors (printOrThrowDiagnostics)\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Errors (handleFlagWarnings)\n#else\nimport GHC_Driver_Types (handleFlagWarnings)\n#endif\n\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Driver.Errors.Types (DriverMessage)\nimport GHC.Types.Error (Messages, defaultDiagnosticOpts)\n#elif MIN_VERSION_ghc(9,0,0)\nimport GHC.Driver.CmdLine (Warn)\n#else\nimport CmdLineParser (Warn)\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Types.Error (NoDiagnosticOpts (..))\nimport GHC.Utils.Outputable (NamePprCtx)\n#else\nimport GHC_Utils_Outputable (PrintUnqualified)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Config.Diagnostic (initDiagOpts)\nimport GHC.Driver.Errors (printMessages)\nimport GHC.Types.Error (mkMessages)\n#else\nimport GHC_Driver_Errors (printBagOfErrors)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\n-- For \"instance Diagnostic GhcMessage\"\nimport GHC.Driver.Errors.Ppr ()\nimport GHC.Driver.Errors.Types (GhcMessage (..), ghcUnknownMessage)\nimport GHC.Types.Error (Diagnostic (..), DiagnosticReason (..),\n mkSimpleDecorated, noHints)\nimport GHC.Utils.Error (MsgEnvelope, mkErrorMsgEnvelope,\n mkPlainErrorMsgEnvelope)\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Types.Error (DecoratedSDoc, MsgEnvelope, mkMsgEnvelope,\n mkPlainMsgEnvelope)\n#else\nimport GHC_Utils_Error (ErrMsg, mkErrMsg, mkPlainErrMsg)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Utils.Logger (HasLogger (..), Logger)\n#endif\n\n\n-- ------------------------------------------------------------------------\n-- Wrapper type for SDoc\n-- ------------------------------------------------------------------------\n\n#if MIN_VERSION_ghc(9,4,0)\nnewtype SDocWrapper = SDocWrapper {unSDocWrapper :: SDoc}\n deriving (Typeable)\n\ninstance Diagnostic SDocWrapper where\n#if MIN_VERSION_ghc(9,6,0)\n type DiagnosticOpts SDocWrapper = NoDiagnosticOpts\n diagnosticMessage _no_diagnostic_opts = mkSimpleDecorated . unSDocWrapper\n# if !MIN_VERSION_ghc(9,8,0)\n defaultDiagnosticOpts = NoDiagnosticOpts\n# endif\n -- XXX: May worth adding Finkel specific diagnostic code.\n diagnosticCode _ = Nothing\n#else\n diagnosticMessage = mkSimpleDecorated . unSDocWrapper\n#endif\n\n diagnosticReason = const ErrorWithoutFlag\n diagnosticHints = const noHints\n\nwrapSDoc :: SDoc -> GhcMessage\nwrapSDoc = ghcUnknownMessage . SDocWrapper\n#endif\n\n-- | Synonym for message with 'SDoc'.\n#if MIN_VERSION_ghc(9,4,0)\ntype WrappedMsg = MsgEnvelope GhcMessage\n#elif MIN_VERSION_ghc(9,2,0)\ntype WrappedMsg = MsgEnvelope DecoratedSDoc\n#else\ntype WrappedMsg = ErrMsg\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nmkWrappedMsg :: DynFlags -> SrcSpan -> NamePprCtx -> SDoc -> WrappedMsg\n#else\nmkWrappedMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> WrappedMsg\n#endif\n{-# INLINABLE mkWrappedMsg #-}\n\nmkPlainWrappedMsg :: DynFlags -> SrcSpan -> SDoc -> WrappedMsg\n{-# INLINABLE mkPlainWrappedMsg #-}\n\n#if MIN_VERSION_ghc(9,4,0)\nmkWrappedMsg _dflags sp pq sdoc = mkErrorMsgEnvelope sp pq (wrapSDoc sdoc)\nmkPlainWrappedMsg _dflags sp sdoc = mkPlainErrorMsgEnvelope sp (wrapSDoc sdoc)\n#elif MIN_VERSION_ghc(9,2,0)\nmkWrappedMsg = const mkMsgEnvelope\nmkPlainWrappedMsg = const mkPlainMsgEnvelope\n#else\nmkWrappedMsg = mkErrMsg\nmkPlainWrappedMsg = mkPlainErrMsg\n#endif\n\n\n-- ------------------------------------------------------------------------\n-- For printing error messages\n-- ------------------------------------------------------------------------\n\nprintLocatedString\n :: MonadIO m => Logger -> DynFlags -> SrcSpan -> String -> m ()\nprintLocatedString _logger dflags l str = do\n let em = mkWrappedMsg dflags l neverQualify (text str)\n#if MIN_VERSION_ghc(9,6,0)\n let ghc_msg = mkMessages (unitBag em)\n diagnostic_opts = defaultDiagnosticOpts @GhcMessage\n diag_opts = initDiagOpts dflags\n liftIO (printMessages _logger diagnostic_opts diag_opts ghc_msg)\n#elif MIN_VERSION_ghc(9,4,0)\n let ghc_msg = mkMessages (unitBag em)\n liftIO (printMessages _logger (initDiagOpts dflags) ghc_msg)\n#elif MIN_VERSION_ghc(9,2,0)\n liftIO (printBagOfErrors _logger dflags (unitBag em))\n#else\n liftIO (printBagOfErrors dflags (unitBag em))\n#endif\n{-# INLINABLE printLocatedString #-}\n\n#if MIN_VERSION_ghc(9,8,0)\ntype WARNINGs = Messages DriverMessage\n#else\ntype WARNINGs = [Warn]\n#endif\n\n-- GHC.Utils.Logger did not exist until ghc 9.2.\n#if !MIN_VERSION_ghc(9,2,0)\nclass HasLogger m where\n getLogger :: m Logger\n\ndata Logger -- should never constructed.\n#endif\n\n-- | Version compatibility function for 'printOrThrowDiagnostics', former\n-- @handleFlagWarnings@ function.\nprintOrThrowDiagnostics' :: MonadIO m => Logger -> DynFlags -> WARNINGs -> m ()\nprintOrThrowDiagnostics' _logger dflags warns = do\n#if MIN_VERSION_ghc(9,8,0)\n let diagnostic_opts = defaultDiagnosticOpts @GhcMessage\n diag_opts = initDiagOpts dflags\n msg = GhcDriverMessage <$> warns\n liftIO $ printOrThrowDiagnostics _logger diagnostic_opts diag_opts msg\n#elif MIN_VERSION_ghc(9,6,0)\n let diagnostic_opts = defaultDiagnosticOpts @GhcMessage\n diag_opts = initDiagOpts dflags\n liftIO $ handleFlagWarnings _logger diagnostic_opts diag_opts warns\n#elif MIN_VERSION_ghc(9,4,0)\n liftIO $ handleFlagWarnings _logger (initDiagOpts dflags) warns\n#elif MIN_VERSION_ghc(9,2,0)\n liftIO $ handleFlagWarnings _logger dflags warns\n#else\n liftIO $ handleFlagWarnings dflags warns\n#endif\n" }, { "path": "finkel-kernel/src/Language/Finkel/Eval.hs", "content": "{-# LANGUAGE CPP #-}\n-- | Module containing functions for code evaluation.\nmodule Language.Finkel.Eval\n ( evalDecls\n , evalExpr\n , evalExprType\n , evalTypeKind\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Monad.IO.Class (MonadIO (..))\n\n-- ghc\nimport GHC_Core_TyCo_Rep (Kind, Type (..))\nimport GHC_Core_TyCo_Tidy (tidyType)\nimport GHC_Driver_Env_Types (HscEnv (..))\nimport GHC_Driver_Main (hscParsedDecls)\nimport GHC_Driver_Monad (GhcMonad (..), withSession)\nimport GHC_Runtime_Context (InteractiveContext (..))\nimport GHC_Runtime_Eval (compileParsedExprRemote)\nimport GHC_Tc_Module (TcRnExprMode (..), tcRnExpr, tcRnType)\nimport GHC_Types_TyThing (TyThing (..))\nimport GHC_Types_Var_Env (emptyTidyEnv)\nimport GHC_Utils_Error (Messages)\n\n\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Tc.Zonk.Env (ZonkFlexi (..))\n#else\nimport GHC_Tc_Utils_Zonk (ZonkFlexi (..))\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Errors.Types (GhcMessage, hoistTcRnMessage)\nimport GHC.Tc.Errors.Types (TcRnMessage)\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC_Types_Error (DecoratedSDoc)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC_Types_Error (partitionMessages)\nimport GHC_Types_SourceError (throwErrors)\n#else\nimport Control.Exception (throwIO)\nimport GHC_Types_SourceError (mkSrcErr)\n#endif\n\n-- ghci\nimport GHCi.RemoteTypes (HValue, localRef, withForeignRef)\n\n-- internal\nimport Language.Finkel.Builder (HDecl, HExpr, HType)\n\n\n-- ---------------------------------------------------------------------\n--\n-- Eval functions\n--\n-- ---------------------------------------------------------------------\n\n-- | Evaluate given expression to haskell value.\nevalExpr :: GhcMonad m => HExpr -> m HValue\nevalExpr expr = do\n fhv <- compileParsedExprRemote expr\n liftIO (withForeignRef fhv localRef)\n{-# INLINABLE evalExpr #-}\n\n-- | Evaluate the type of given expression.\nevalExprType :: GhcMonad m => HExpr -> m Type\nevalExprType expr = do\n -- See `InteractiveEval.exprType' and `HscMain.hscTcExpr'. As in `evalDecls',\n -- taking HExpr instead of Haskell source code String.\n --\n -- XXX: Currently, `TcRnExprMode' is hard coded as `TM_Inst' in below call to\n -- `tcRnExpr'. In ghci, user can type in and specify the mode from REPL\n -- session.\n --\n hsc_env <- getSession\n ty <- ioMsgMaybe $ hoistTcRnMessage' $ tcRnExpr hsc_env TM_Inst expr\n return $ tidyType emptyTidyEnv ty\n{-# INLINABLE evalExprType #-}\n\n-- | Evaluate the kind of given type. Returned values is a pair of the\n-- argument type and the kind of that type.\nevalTypeKind :: GhcMonad m => HType -> m (Type, Kind)\nevalTypeKind ty = do\n -- See `InteractiveEval.typeKind' and `HscMain.hscKcType'.\n --\n -- XXX: The second argument of `tcRnType' is hard coded as `True' in below\n -- code.\n --\n hsc_env <- getSession\n ioMsgMaybe $ hoistTcRnMessage' $ tcRnType' hsc_env True ty\n{-# INLINABLE evalTypeKind #-}\n\n-- | Evaluate given declarations. The returned value is resulting 'TyThing's of\n-- declarations and updated interactive context.\nevalDecls :: GhcMonad m => [HDecl] -> m ([TyThing], InteractiveContext)\nevalDecls decls =\n withSession (\\hsc_env -> liftIO (hscParsedDecls hsc_env decls))\n\n\n-- ---------------------------------------------------------------------\n--\n-- Auxiliary\n--\n-- ---------------------------------------------------------------------\n\n-- Separation of TcRnMessage and GhcMessage was introduced in ghc 9.4.\n#if MIN_VERSION_ghc(9,4,0)\nhoistTcRnMessage' ::\n Monad m => m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)\nhoistTcRnMessage' = hoistTcRnMessage\n#else\nhoistTcRnMessage' :: a -> a\nhoistTcRnMessage' = id\n#endif\n{-# INLINABLE hoistTcRnMessage' #-}\n\n-- | Like 'HscMain.ioMsgMaybe', but for 'Fnk'.\n#if MIN_VERSION_ghc(9,4,0)\nioMsgMaybe :: MonadIO m => IO (Messages GhcMessage, Maybe a) -> m a\n#elif MIN_VERSION_ghc(9,2,0)\nioMsgMaybe :: MonadIO m => IO (Messages DecoratedSDoc, Maybe a) -> m a\n#else\nioMsgMaybe :: MonadIO m => IO (Messages, Maybe a) -> m a\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nioMsgMaybe ioA = do\n -- XXX: Log warning messages.\n (msgs, mb_r) <- liftIO ioA\n let (_warns, errs) = partitionMessages msgs\n maybe (throwErrors errs) pure mb_r\n#else\nioMsgMaybe ioA = do\n ((_warns, errs), mb_r) <- liftIO ioA\n maybe (liftIO (throwIO (mkSrcErr errs))) return mb_r\n#endif\n{-# INLINABLE ioMsgMaybe #-}\n\n-- | GHC version compatibility helper for 'tcRnType'.\n#if MIN_VERSION_ghc(9,4,0)\ntcRnType'\n :: HscEnv -> Bool -> HType -> IO (Messages TcRnMessage, Maybe (Type, Kind))\n#elif MIN_VERSION_ghc(9,2,0)\ntcRnType'\n :: HscEnv -> Bool -> HType -> IO (Messages DecoratedSDoc, Maybe (Type, Kind))\n#else\ntcRnType'\n :: HscEnv -> Bool -> HType -> IO (Messages, Maybe (Type, Kind))\n#endif\n\ntcRnType' hsc_env = tcRnType hsc_env DefaultFlexi\n{-# INLINABLE tcRnType' #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Exception.hs", "content": "{-# LANGUAGE CPP #-}\n\n-- | Exception related types and functions in @finkel-kernel@.\nmodule Language.Finkel.Exception\n ( FinkelException(..)\n , finkelExceptionLoc\n , readOrFinkelException\n , handleFinkelException\n , printFinkelException\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Exception (Exception (..), throw)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport System.IO (hPutStrLn, stderr)\n\n-- ghc\nimport GHC_Driver_Session (HasDynFlags (..))\nimport GHC_Types_SrcLoc (GenLocated (..), SrcSpan)\nimport GHC_Utils_Exception (ExceptionMonad)\n\n#if MIN_VERSION_ghc(9,0,0)\n-- exceptions\nimport Control.Monad.Catch (handle)\n#else\n-- ghc\nimport GHC_Utils_Exception (ghandle)\n#endif\n\n-- Internal\nimport Language.Finkel.Error\nimport Language.Finkel.Form\n\n\n-- ---------------------------------------------------------------------\n--\n-- Type\n--\n-- ---------------------------------------------------------------------\n\n-- | Exception for @finkel-kernel@@ package.\ndata FinkelException\n = LexicalException SrcSpan Char\n -- ^ Lexical error.\n | InvalidUnquoteSplice Code\n -- ^ Invalid unquote splice with 'Code' value.\n | FinkelSrcError Code String\n -- ^ Error with 'Code' information and additional message.\n | FinkelException String\n -- ^ General exception with message.\n deriving (Eq, Show)\n\ninstance Exception FinkelException where\n displayException = displayFinkelException\n {-# INLINE displayException #-}\n\ndisplayFinkelException :: FinkelException -> String\ndisplayFinkelException e = case e of\n LexicalException _ c -> \"Lexical error near \" ++ show c\n InvalidUnquoteSplice c -> \"Invalid unquote splice: \" ++ show c\n FinkelSrcError _ s -> s\n FinkelException s -> s\n{-# INLINEABLE displayFinkelException #-}\n\n-- | Get source location information if available.\nfinkelExceptionLoc :: FinkelException -> Maybe SrcSpan\nfinkelExceptionLoc fe = case fe of\n LexicalException l _ -> Just l\n InvalidUnquoteSplice (LForm (L l _)) -> Just l\n FinkelSrcError (LForm (L l _)) _ -> Just l\n _ -> Nothing\n{-# INLINABLE finkelExceptionLoc #-}\n\nreadOrFinkelException :: Read s => String -> String -> String -> s\nreadOrFinkelException what name str =\n case reads str of\n [(x, \"\")] -> x\n _ -> throw (FinkelException (\"Expecting \" ++ what ++\n \" for \" ++ name ++\n \", but got \" ++ show str))\n{-# INLINABLE readOrFinkelException #-}\n\n-- | Print 'FinkelException' with source code information when available.\nprintFinkelException\n :: (HasLogger m, HasDynFlags m, MonadIO m) => FinkelException -> m ()\nprintFinkelException e = case finkelExceptionLoc e of\n Nothing -> liftIO $ hPutStrLn stderr msg\n Just l -> do\n logger <- getLogger\n dflags <- getDynFlags\n printLocatedString logger dflags l msg\n where\n msg = displayException e\n\n-- ------------------------------------------------------------------------\n--\n-- Type fixed variant functions\n--\n-- ------------------------------------------------------------------------\n\nhandleFinkelException :: ExceptionMonad m\n => (FinkelException -> m a) -> m a -> m a\n#if MIN_VERSION_ghc(9,0,0)\nhandleFinkelException = handle\n#else\nhandleFinkelException = ghandle\n#endif\n\n" }, { "path": "finkel-kernel/src/Language/Finkel/Expand.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n-- | Module for macro expansion.\nmodule Language.Finkel.Expand\n ( expand\n , expand1\n , expands\n , expands'\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Data.Char (isLower)\nimport Data.Foldable (foldlM)\n\n-- containers\nimport qualified Data.Map as Map\n\n-- ghc\nimport GHC_Types_SrcLoc (GenLocated (..))\nimport GHC_Utils_Outputable (Outputable (..), SDoc, cat,\n fsep, nest, vcat)\n\n-- Internal\nimport Language.Finkel.Data.FastString (FastString, unconsFS)\nimport Language.Finkel.Fnk\nimport Language.Finkel.Form\n\n\n-- ---------------------------------------------------------------------\n--\n-- Macro expander\n--\n-- ---------------------------------------------------------------------\n\n-- | Returns a list of bounded names in let expression.\nboundedNames :: Code -> [FastString]\nboundedNames form =\n case unCode form of\n List xs -> concatMap boundedName xs\n Atom (ASymbol n) -> [n]\n _ -> []\n{-# INLINABLE boundedNames #-}\n\nboundedName :: Code -> [FastString]\nboundedName form =\n case unCode form of\n List (LForm (L _ (Atom (ASymbol \"=\"))):n:_) -> boundedNameOne n\n _ -> []\n{-# INLINABLE boundedName #-}\n\nboundedNameOne :: Code -> [FastString]\nboundedNameOne form =\n case unCode form of\n Atom (ASymbol n) -> [n]\n List ns -> concatMap f ns\n HsList ns -> concatMap f ns\n _ -> []\n where\n f x =\n case unCode x of\n Atom (ASymbol n) | startsWithLower n -> [n]\n _ -> []\n{-# INLINABLE boundedNameOne #-}\n\nstartsWithLower :: FastString -> Bool\nstartsWithLower fs = case unconsFS fs of\n Just (c, _) -> isLower c\n _ -> False\n{-# INLINABLE startsWithLower #-}\n\n-- | Perform 'Fnk' action with temporary shadowed macro environment.\nwithShadowing :: [FastString] -- ^ Names of macro to shadow.\n -> Fnk a -- ^ Action to perform.\n -> Fnk a\nwithShadowing toShadow act = do\n fnk_env <- getFnkEnv\n let emacros = envMacros fnk_env\n tmacros = envTmpMacros fnk_env\n f name _ = unMacroName name `notElem` toShadow\n putFnkEnv fnk_env { envMacros = Map.filterWithKey f emacros\n , envTmpMacros = map (Map.filterWithKey f) tmacros }\n result <- act\n modifyFnkEnv (\\e -> e { envMacros = emacros\n , envTmpMacros = tmacros })\n return result\n\n-- | Expand forms, with taking care of @begin@ special form.\nexpands :: [Code] -> Fnk [Code]\nexpands forms = do\n fnk_env <- getFnkEnv\n let macro_names me =\n if null me\n then nest 2 \"None\"\n else nest 2 (fsep (map (ppr . unMacroName) (Map.keys me)))\n tmp_macros = Map.unions (envTmpMacros fnk_env)\n debug fnk_env\n Nothing\n [ \"Global macros:\", macro_names (envMacros fnk_env)\n , \"Temporary macros:\", macro_names tmp_macros ]\n expands' forms\n\n-- | Internal works for 'expands'.\nexpands' :: [Code] -> Fnk [Code]\nexpands' = fmap concat . mapM expand'\n{-# INLINABLE expands' #-}\n\n-- | Expand form to list of 'Code', supports special form /begin/.\nexpand' :: Code -> Fnk [Code]\nexpand' form =\n case unCode form of\n List (hd:_) | Atom (ASymbol \":quote\") <- unCode hd -> return [form]\n _ -> do\n form' <- expand form\n case unCode form' of\n List (LForm (L _ (Atom (ASymbol \":begin\"))):rest) ->\n case rest of\n [] -> return []\n _ -> expands' rest\n _ -> return [form']\n{-# INLINABLE expand' #-}\n\n-- | Recursively expands the given 'Code'.\nexpand :: Code -> Fnk Code\nexpand form =\n case unLForm form of\n L l (List forms) ->\n case forms of\n -- Expand `let' expression, `do' expression, `case' expression, lambda\n -- expression and function binding with shadowing the lexically bounded\n -- names. Expansion of other forms are done without name shadowing.\n -- This function does not expand quoted forms, to preserve the structure\n -- of the quoted forms containing `:begin'.\n kw@(LForm (L _ (Atom (ASymbol x)))):y:rest\n | x == \"let\" -> expandLet l kw y rest\n | x == \"do\" -> expandDo l kw (y:rest)\n | x == \"case\" -> expandCase l kw y rest\n | x == \"where\" -> expandWhere l kw y rest\n | x == \"=\" || x == \"\\\\\" -> expandFunBind l kw (y:rest)\n | x == \":quote\" -> return form\n _ -> expandList l forms\n\n L l (HsList forms) ->\n -- Without recursively calling 'expand' on the result, cannot expand\n -- macro-generating macros.\n LForm . L l . HsList <$> expands' forms\n\n -- Non-list forms are untouched.\n _ -> return form\n where\n expandLet l kw binds body = do\n binds' <- expand binds\n let bounded = boundedNames binds'\n body' <- withShadowing bounded (expands' body)\n return $! LForm (L l (List (kw:binds':body')))\n\n expandDo l kw body = do\n (_, body') <- foldlM expandInDo ([], []) body\n return $! LForm (L l (List (kw:reverse body')))\n\n expandFunBind l kw rest = do\n let args = init rest\n body = last rest\n bounded = concatMap boundedNameOne args\n args' <- expands' args\n body' <- withShadowing bounded (expand body)\n return $! LForm (L l (List (kw:args'++[body'])))\n\n expandCase l kw expr rest = do\n let go acc xs =\n case xs of\n -- Pattern may have prefix (e.g. '~' for lazy pattern)\n pat_prefix:pat:expr0:rest0\n | pat_prefix == tilde -> do\n pat' <- expand pat\n expr1 <- withShadowing (boundedNameOne pat')\n (expand expr0)\n go (expr1:pat':pat_prefix:acc) rest0\n pat:expr0:rest0 -> do\n pat' <- expand pat\n expr1 <- withShadowing (boundedNameOne pat')\n (expand expr0)\n go (expr1:pat':acc) rest0\n _ -> return acc\n tilde = LForm (L l (Atom (ASymbol \"~\")))\n expr' <- expand expr\n rest' <- go [] rest\n return $! LForm (L l (List (kw:expr':reverse rest')))\n\n expandWhere l kw expr rest = do\n rest' <- expands' rest\n let bounded = concatMap boundedName rest'\n expr' <- withShadowing bounded (expand expr)\n return $! LForm (L l (List (kw:expr':rest')))\n\n expandList l forms =\n case forms of\n sym@(LForm (L _ (Atom (ASymbol k)))) : rest -> do\n fnk_env <- getFnkEnv\n case lookupMacro k fnk_env of\n Just m -> do_expand k (macroFunction m) >>= expand\n Nothing -> LForm . L l . List . (sym:) <$> expands' rest\n _ -> do\n forms' <- expands' forms\n return $! LForm (L l (List forms'))\n\n do_expand k f =\n do fnk_env <- getFnkEnv\n debug fnk_env Nothing [vcat [\"Expanding:\", nest 2 (ppr form)]]\n ret0 <- f form\n debug fnk_env Nothing [cat [ppr k, \" ==>\"], nest 2 (ppr ret0)]\n return ret0\n\nexpandInDo ::\n ([FastString], [Code]) -> Code -> Fnk ([FastString], [Code])\nexpandInDo (bounded, xs) x = do\n let newbind =\n case x of\n LForm (L _ (List (LForm (L _ (Atom (ASymbol sym))):n:_)))\n | sym == \"<-\" -> boundedNameOne n\n _ -> []\n x' <- withShadowing bounded (expand x)\n return (newbind ++ bounded, x':xs)\n{-# INLINABLE expandInDo #-}\n\n-- | Expand given form once if the form is a macro form, otherwise\n-- return the given form.\nexpand1 :: Code -> Fnk Code\nexpand1 form =\n case unLForm form of\n L _l (List ((LForm (L _ (Atom (ASymbol k)))) : _)) -> do\n fnk_env <- getFnkEnv\n case lookupMacro k fnk_env of\n Just m -> macroFunction m form\n Nothing -> return form\n _ -> return form\n{-# INLINABLE expand1 #-}\n\n-- | Debug function fot macro expansion.\ndebug :: FnkEnv -> Maybe SDoc -> [SDoc] -> Fnk ()\ndebug = debugWith Fnk_trace_expand\n{-# INLINABLE debug #-}\n\ndebugWith :: FnkDebugFlag -> FnkEnv -> Maybe SDoc -> [SDoc] -> Fnk ()\ndebugWith debug_flag fnk_env mb_extra msgs0 =\n let msgs1 = maybe msgs0 (: msgs0) mb_extra\n in debugWhen fnk_env debug_flag msgs1\n{-# INLINABLE debugWith #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Fnk.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TypeApplications #-}\n{-# OPTIONS_GHC -Wno-orphans #-}\n\n-- | Wrapper for Finkel code compilation monad.\nmodule Language.Finkel.Fnk\n ( -- * Finkel compiler monad\n Fnk(..)\n , FnkEnv(..)\n , FnkEnvRef(..)\n , FnkInvokedMode(..)\n , Macro(..)\n , MacroFunction\n , MacroName(..)\n , EnvMacros\n , FlagSet\n , runFnk\n , runFnk'\n , toGhc\n , fromGhc\n , emptyFnkEnv\n , initFnkEnv\n , getFnkEnv\n , putFnkEnv\n , modifyFnkEnv\n , setDynFlags\n , updateDynFlags\n , withTmpDynFlags\n , prepareInterpreter\n , useInterpreter\n\n -- * Error related functions\n , failFnk\n , finkelSrcError\n\n -- * GHC library directory\n , getLibDirFromGhc\n , initializeLibDirFromGhc\n\n -- * Debugging\n , FnkDebugFlag(..)\n , fopt\n , foptSet\n , setFnkVerbosity\n , debugWhen\n , debugWhen'\n , dumpDynFlags\n , dumpHscEnv\n , getFnkDebug\n\n -- * Macro related functions\n , emptyEnvMacros\n , insertMacro\n , lookupMacro\n , makeEnvMacros\n , mergeMacros\n , addMacro\n , deleteMacro\n , macroNames\n , isMacro\n , macroFunction\n\n -- * Gensym and UniqSupply\n , gensym\n , gensym'\n , initUniqSupply'\n\n -- * Re-export from 'exceptions' package\n , MonadCatch(..)\n , MonadThrow(..)\n , MonadMask(..)\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Concurrent (MVar, newMVar, withMVar)\nimport Control.Exception (throw, throwIO)\nimport Control.Monad (mplus, unless, when)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.Bifunctor (first)\nimport Data.Bits (setBit, testBit, zeroBits)\nimport Data.Char (isSpace)\nimport Data.IORef (IORef, atomicModifyIORef',\n atomicWriteIORef, newIORef,\n readIORef)\nimport Data.Word (Word8)\nimport System.Environment (getProgName, lookupEnv)\nimport System.Exit (exitFailure)\nimport System.IO (stderr)\nimport System.IO.Unsafe (unsafePerformIO)\n\n#if MIN_VERSION_ghc(9,10,0)\nimport Data.Word (Word64)\n#endif\n\n-- containers\nimport qualified Data.Map as Map\n\nimport System.Directory (canonicalizePath, doesFileExist,\n findExecutable)\nimport System.FilePath (takeDirectory, ())\n\n-- exceptions\nimport Control.Monad.Catch (MonadCatch (..), MonadMask (..),\n MonadThrow (..))\n\n#if MIN_VERSION_ghc(9,0,0)\nimport Control.Monad.Catch (bracket)\n#else\nimport GHC_Utils_Exception (ExceptionMonad (..))\n#endif\n\n-- process\nimport System.Process (readProcess)\n\n-- ghc\nimport GHC (ModSummary (..), runGhc)\nimport qualified GHC_Data_EnumSet as EnumSet\nimport GHC_Data_FastString (FastString, fsLit, uniqueOfFS,\n unpackFS)\nimport GHC_Driver_Env_Types (HscEnv (..))\nimport GHC_Driver_Main (Messager, batchMsg)\nimport GHC_Driver_Monad (Ghc (..), GhcMonad (..),\n Session (..), modifySession)\nimport GHC_Driver_Ppr (showSDocForUser)\nimport GHC_Driver_Session (DynFlags (..), GeneralFlag (..),\n GhcLink (..), HasDynFlags (..),\n IncludeSpecs (..), gopt, gopt_set,\n gopt_unset, opt_P_signature,\n picPOpts, ways)\nimport GHC_Platform_Ways (wayGeneralFlags,\n wayUnsetGeneralFlags)\nimport GHC_Runtime_Context (InteractiveContext (..))\nimport GHC_Settings_Config (cProjectVersion)\nimport GHC_Types_TyThing (TyThing (..))\nimport GHC_Types_Unique_Supply (MonadUnique (..), UniqSupply,\n initUniqSupply, mkSplitUniqSupply,\n splitUniqSupply, takeUniqFromSupply)\nimport GHC_Types_Var (varType)\nimport GHC_Unit_Home_ModInfo (pprHPT)\nimport GHC_Utils_CliOption (showOpt)\nimport GHC_Utils_Outputable (Outputable (..), SDoc,\n alwaysQualify, defaultErrStyle,\n nest, ppr, printSDocLn, sep, text,\n vcat, (<+>))\nimport qualified GHC_Utils_Ppr as Pretty\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Driver.Backend (interpreterBackend)\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Backend (Backend (..))\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Env (hscSetFlags, hsc_HPT, hsc_HUG)\nimport GHC.Driver.Hooks (Hooks (..))\nimport GHC.Driver.Make (ModIfaceCache, newIfaceCache)\nimport GHC.Settings (ToolSettings (..))\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Env (hsc_units)\n#else\nimport GHC_Driver_Session (HscTarget (..))\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Driver_Session (initSDocContext,\n sccProfilingEnabled)\nimport GHC_Platform_Ways (hostFullWays)\n#else\nimport GHC_Platform_Ways (interpWays, updateWays)\n#endif\n\n-- Internal\nimport Language.Finkel.Error\nimport Language.Finkel.Exception\nimport Language.Finkel.Form\n\n\n-- ---------------------------------------------------------------------\n--\n-- Macro and Fnk monad\n--\n-- ---------------------------------------------------------------------\n\n-- | Macro transformer function.\n--\n-- A macro in Finkel is implemented as a function. The function takes a located\n-- code data argument, and returns a located code data wrapped in 'Fnk'.\ntype MacroFunction = Code -> Fnk Code\n\n-- | Data type to distinguish user defined macros from built-in special forms.\ndata Macro\n = Macro MacroFunction\n | SpecialForm MacroFunction\n\ninstance Show Macro where\n showsPrec _ m =\n case m of\n Macro _ -> showString \"\"\n SpecialForm _ -> showString \"\"\n\n-- | Type synonym to express mapping of macro name to 'Macro' data.\ntype EnvMacros = Map.Map MacroName Macro\n\nnewtype MacroName = MacroName {unMacroName :: FastString}\n deriving (Eq)\n\ninstance Ord MacroName where\n compare (MacroName a) (MacroName b) = compare (uniqueOfFS a) (uniqueOfFS b)\n {-# INLINE compare #-}\n\n-- | Data type for debug information.\ndata FnkDebugFlag\n = Fnk_dump_dflags\n | Fnk_dump_expand\n | Fnk_dump_hs\n | Fnk_dump_session\n | Fnk_trace_expand\n | Fnk_trace_session\n | Fnk_trace_make\n | Fnk_trace_spf\n deriving (Eq, Show, Enum)\n\n-- | Type synonym for holding on/off of 'FnkDebugFlag'.\ntype FlagSet = Word8 -- Word8 is enough for now.\n\n-- | Data type to hold how the compiler was invoked.\ndata FnkInvokedMode\n = ExecMode\n -- ^ Standalone executable mode.\n | GhcPluginMode\n -- ^ GHC plugin mode.\n\ninstance Outputable FnkInvokedMode where\n ppr im = case im of\n ExecMode -> \"exec\"\n GhcPluginMode -> \"ghc-plugin\"\n\n-- | Environment state in 'Fnk'.\ndata FnkEnv = FnkEnv\n { -- | Macros accessible in current compilation context.\n envMacros :: EnvMacros\n -- | Temporary macros in current compilation context.\n , envTmpMacros :: [EnvMacros]\n -- | Default set of macros, these macros will be used when\n -- resetting 'FnkEnv'.\n , envDefaultMacros :: EnvMacros\n\n -- | Modules to import to context.\n , envContextModules :: [String]\n -- | The default 'DynFlags', possibly containing settings from command line.\n , envDefaultDynFlags :: !(Maybe DynFlags)\n\n -- | Messager used in make.\n , envMessager :: Messager\n -- | Required home package modules names in current target.\n , envRequiredHomeModules :: [ModSummary]\n\n -- | Directory to save generated Haskell source codes.\n , envHsOutDir :: !(Maybe FilePath)\n\n -- | Lib directory passed to 'runGhc'.\n , envLibDir :: !(Maybe FilePath)\n\n -- | Whether to use qualified name for primitive functions used in quoting\n -- codes.\n , envQualifyQuotePrimitives :: !Bool\n\n -- | The 'HscEnv' used by the byte-code interpreter for macro expansion.\n , envSessionForExpand :: !(Maybe HscEnv)\n\n -- | The 'UniqSupply' for 'gensym'.\n , envUniqSupply :: UniqSupply\n\n -- | Verbosity level for Fnk related messages.\n , envVerbosity :: {-# UNPACK #-} !Int\n -- | Dump flag settings.\n , envDumpFlags :: {-# UNPACK #-} !FlagSet\n\n -- | How the compiler was invoked.\n , envInvokedMode :: !FnkInvokedMode\n\n -- | ModIFaceCache used by GHC's load function, for interpreter.\n , envInterpModIfaceCache :: !(Maybe ModIfaceCache)\n }\n\n-- | Newtype wrapper for compiling Finkel code to Haskell AST.\nnewtype Fnk a = Fnk {unFnk :: FnkEnvRef -> Ghc a}\n\n-- | Reference to 'FnkEnv'.\nnewtype FnkEnvRef = FnkEnvRef (IORef FnkEnv)\n\ninstance Functor Fnk where\n fmap f (Fnk m) = Fnk (fmap f . m)\n {-# INLINE fmap #-}\n\ninstance Applicative Fnk where\n pure x = Fnk (\\_ -> pure x)\n {-# INLINE pure #-}\n Fnk f <*> Fnk m = Fnk (\\ref -> f ref <*> m ref)\n {-# INLINE (<*>) #-}\n\ninstance Monad Fnk where\n Fnk m >>= k = Fnk (\\ref -> m ref >>= \\v -> unFnk (k v) ref)\n {-# INLINE (>>=) #-}\n\ninstance MonadFail Fnk where\n fail = failFnk\n {-# INLINE fail #-}\n\ninstance MonadIO Fnk where\n liftIO io = Fnk (\\_ -> liftIO io)\n {-# INLINE liftIO #-}\n\ninstance MonadCatch Fnk where\n catch m h =\n Fnk (\\ref -> unFnk m ref `catch` \\e -> unFnk (h e) ref)\n {-# INLINE catch #-}\n\ninstance MonadThrow Fnk where\n throwM e = Fnk (\\ _ -> throwM e)\n {-# INLINE throwM #-}\n\ninstance MonadMask Fnk where\n mask f =\n Fnk (\\ref ->\n mask (\\r -> let r' m = Fnk (r . unFnk m)\n in unFnk (f r') ref))\n {-# INLINE mask #-}\n\n uninterruptibleMask f =\n Fnk (\\ref ->\n uninterruptibleMask (\\r -> let r' m = Fnk (r . unFnk m)\n in unFnk (f r') ref))\n {-# INLINE uninterruptibleMask #-}\n\n#if MIN_VERSION_exceptions(0,10,0)\n generalBracket acquire release use =\n Fnk (\\ref ->\n let acquire' = unFnk acquire ref\n release' r err = unFnk (release r err) ref\n use' v = unFnk (use v) ref\n in generalBracket acquire' release' use')\n {-# INLINE generalBracket #-}\n#endif\n\n#if !MIN_VERSION_ghc(9,0,0)\n\n-- Note: [Orphan instances for type classes from Control.Monad.Catch]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- Manually defining instances instead of \"deriving via\" approach done in ghc\n-- 9.0.1, to support older version of ghc which does not have support of\n-- \"DerivingVia\" language extension.\n\ninstance MonadThrow Ghc where\n throwM e = liftIO (throwM e)\n {-# INLINE throwM #-}\n\ninstance MonadCatch Ghc where\n catch m h =\n Ghc (\\he -> unGhc m he `catch` \\e -> unGhc (h e) he)\n {-# INLINE catch #-}\n\ninstance MonadMask Ghc where\n mask f =\n Ghc (\\he -> mask (\\ r -> let r' m = Ghc (r . unGhc m)\n in unGhc (f r') he))\n {-# INLINE mask #-}\n\n uninterruptibleMask f =\n Ghc (\\he -> uninterruptibleMask (\\r -> let r' m = Ghc (r . unGhc m)\n in unGhc (f r') he))\n {-# INLINE uninterruptibleMask #-}\n\n#if MIN_VERSION_exceptions(0,10,0)\n generalBracket acquire release use =\n Ghc (\\he ->\n let acquire' = unGhc acquire he\n release' r err = unGhc (release r err) he\n use' v = unGhc (use v) he\n in generalBracket acquire' release' use')\n {-# INLINE generalBracket #-}\n#endif\n\ninstance ExceptionMonad Fnk where\n gcatch m h =\n Fnk (\\ref -> unFnk m ref `gcatch` \\e -> unFnk (h e) ref)\n {-# INLINE gcatch #-}\n\n gmask f =\n Fnk (\\ref ->\n gmask (\\r -> let r' m = Fnk (r . unFnk m)\n in unFnk (f r') ref))\n {-# INLINE gmask #-}\n#endif\n\ninstance MonadUnique Fnk where\n getUniqueSupplyM = do\n fnk_env <- getFnkEnv\n let (us1, us2) = splitUniqSupply (envUniqSupply fnk_env)\n putFnkEnv $ fnk_env { envUniqSupply = us2 }\n return us1\n {-# INLINE getUniqueSupplyM #-}\n\n getUniqueM = do\n fnk_env <- getFnkEnv\n let (u, us1) = takeUniqFromSupply (envUniqSupply fnk_env)\n putFnkEnv $ fnk_env { envUniqSupply = us1 }\n return u\n {-# INLINE getUniqueM #-}\n\ninstance HasDynFlags Fnk where\n getDynFlags = Fnk (const getDynFlags)\n {-# INLINE getDynFlags #-}\n\n#if MIN_VERSION_ghc(9,2,0)\ninstance HasLogger Fnk where\n getLogger = Fnk (const getLogger)\n {-# INLINE getLogger #-}\n#else\ninstance HasLogger Fnk where\n getLogger = pure (error \"getLogger (Fnk): no Logger\")\n#endif\n\ninstance GhcMonad Fnk where\n getSession = Fnk (const getSession)\n {-# INLINE getSession #-}\n setSession hsc_env = Fnk (\\_ -> setSession hsc_env)\n {-# INLINE setSession #-}\n\n-- | Run 'Fnk' with given environment.\n--\n-- Internally calls 'initFnkEnv' and 'runGhc'.\nrunFnk :: Fnk a -> FnkEnv -> IO a\nrunFnk m fnk_env0 = do\n fnk_env1 <- initFnkEnv fnk_env0\n ref <- newIORef fnk_env1\n runGhc (envLibDir fnk_env1) (toGhc m (FnkEnvRef ref))\n\n-- | Run 'Fnk' with given 'FnkEnv' and 'HscEnv'.\n--\n-- This function does /NOT/ call 'initFnkEnv', uses 'unGhc' instead of 'runGhc'.\nrunFnk' :: Fnk a -> FnkEnv -> HscEnv -> IO a\nrunFnk' m fnk_env hsc_env = do\n fer <- FnkEnvRef <$> newIORef fnk_env\n session <- Session <$> newIORef hsc_env\n unGhc (toGhc m fer) session\n{-# INLINABLE runFnk' #-}\n\n-- | Extract 'Ghc' from 'Fnk'.\ntoGhc :: Fnk a -> FnkEnvRef -> Ghc a\ntoGhc = unFnk\n{-# INLINABLE toGhc #-}\n\n-- | Lift 'Ghc' to 'Fnk'.\nfromGhc :: Ghc a -> Fnk a\nfromGhc m = Fnk (const m)\n{-# INLINABLE fromGhc #-}\n\n-- | Get current 'FnkEnv'.\ngetFnkEnv :: Fnk FnkEnv\ngetFnkEnv = Fnk (\\(FnkEnvRef ref) -> liftIO $! readIORef ref)\n{-# INLINABLE getFnkEnv #-}\n\n-- | Set current 'FnkEnv' to given argument.\nputFnkEnv :: FnkEnv -> Fnk ()\nputFnkEnv fnk_env =\n Fnk (\\(FnkEnvRef ref) -> liftIO $! atomicWriteIORef ref fnk_env)\n{-# INLINABLE putFnkEnv #-}\n\n-- | Update 'FnkEnv' with applying given function to current 'FnkEnv'.\nmodifyFnkEnv :: (FnkEnv -> FnkEnv) -> Fnk ()\nmodifyFnkEnv f =\n Fnk (\\(FnkEnvRef ref) ->\n liftIO $! atomicModifyIORef' ref (\\fnk_env -> (f fnk_env, ())))\n{-# INLINABLE modifyFnkEnv #-}\n\n-- | Throw 'FinkelException' with given message.\nfailFnk :: MonadIO m => String -> m a\nfailFnk = liftIO . throwIO . FinkelException\n{-# INLINABLE failFnk #-}\n\n-- | Throw 'FinkelSrcError' with given 'Code' and message.\nfinkelSrcError :: (Monad m, MonadIO m) => Code -> String -> m a\nfinkelSrcError code = liftIO . throwIO . FinkelSrcError code\n{-# INLINABLE finkelSrcError #-}\n\n-- | Initialize 'FnkEnv'.\ninitFnkEnv :: FnkEnv -> IO FnkEnv\ninitFnkEnv fnk_env = do\n uniqSupply <- mkSplitUniqSupply '_'\n libdir <- maybe getLibDirFromGhc pure (envLibDir fnk_env)\n interpModIfaceCache <- getNewModIfaceCache\n pure fnk_env { envLibDir = Just libdir\n , envUniqSupply = uniqSupply\n , envInterpModIfaceCache = Just interpModIfaceCache }\n{-# INLINABLE initFnkEnv #-}\n\n-- ModIfaceCache does not exist in ghc < 9.4.\n#if MIN_VERSION_ghc(9,4,0)\ngetNewModIfaceCache :: MonadIO m => m ModIfaceCache\ngetNewModIfaceCache = liftIO newIfaceCache\n#else\ntype ModIfaceCache = ()\ngetNewModIfaceCache :: MonadIO m => m ModIfaceCache\ngetNewModIfaceCache = pure ()\n#endif\n{-# INLINABLE getNewModIfaceCache #-}\n\n-- | Empty 'FnkEnv' for performing computation with 'Fnk'.\nemptyFnkEnv :: FnkEnv\nemptyFnkEnv = FnkEnv\n { envMacros = emptyEnvMacros\n , envTmpMacros = []\n , envDefaultMacros = emptyEnvMacros\n , envContextModules = []\n , envDefaultDynFlags = Nothing\n , envMessager = batchMsg\n , envRequiredHomeModules = []\n , envHsOutDir = Nothing\n , envLibDir = Nothing\n , envQualifyQuotePrimitives = False\n , envSessionForExpand = Nothing\n , envUniqSupply = uninitializedUniqSupply\n , envVerbosity = 1\n , envDumpFlags = zeroBits\n , envInvokedMode = ExecMode\n , envInterpModIfaceCache = Nothing\n }\n where\n uninitializedUniqSupply :: UniqSupply\n uninitializedUniqSupply =\n throw (FinkelException \"FnkEnv: UniqSupply not initialized\")\n{-# INLINABLE emptyFnkEnv #-}\n\n\n-- | Set current 'DynFlags' to given argument. This function also sets the\n-- 'DynFlags' in interactive context.\nsetDynFlags :: GhcMonad m => DynFlags -> m ()\nsetDynFlags dflags = modifySession (updateDynFlags dflags)\n{-# INLINABLE setDynFlags #-}\n\n-- | Update 'DynFlags' to given argument. This function also sets the 'DynFlags'\n-- in interactive context.\nupdateDynFlags :: DynFlags -> HscEnv -> HscEnv\nupdateDynFlags dflags hsc_env =\n -- From ghc 9.4, HomeUnitEnv data type contains its own homeUnitEnv_dflags\n -- field. HomeUnitEnv data type could be reached from hsc_unit_env field of\n -- HscEnv. Using 'hscSetFlags' function to update hsc_dflags and\n -- homeUnitEnv_dflags at once.\n#if MIN_VERSION_ghc(9,4,0)\n hscSetFlags dflags (hsc_env {hsc_IC = (hsc_IC hsc_env) {ic_dflags = dflags}})\n#else\n hsc_env { hsc_dflags = dflags\n , hsc_IC = (hsc_IC hsc_env) {ic_dflags = dflags}}\n#endif\n\n-- | Run given action with temporary 'DynFlags'.\nwithTmpDynFlags :: GhcMonad m => DynFlags -> m a -> m a\nwithTmpDynFlags dflags act = wrap (\\_ -> setDynFlags dflags >> act)\n where\n#if MIN_VERSION_ghc(9,0,0)\n wrap = bracket getDynFlags setDynFlags\n#else\n wrap = gbracket getDynFlags setDynFlags\n#endif\n{-# INLINABLE withTmpDynFlags #-}\n\n-- | Prepare 'DynFlags' for interactive evaluation.\nprepareInterpreter :: GhcMonad m => m ()\nprepareInterpreter = do\n -- See: \"main''\" in \"ghc/Main.hs\".\n hsc_env <- getSession\n let dflags0 = ic_dflags (hsc_IC hsc_env)\n dflags4 = useInterpreter dflags0\n setDynFlags dflags4\n{-# INLINABLE prepareInterpreter #-}\n\n-- | Update given 'DynFlags' to use interpreter.\nuseInterpreter :: DynFlags -> DynFlags\nuseInterpreter dflags0 =\n let platform = targetPlatform dflags0\n upd_gopt setter get_flags df =\n foldl setter df (concatMap (get_flags platform) (ways df))\n dflags1 = dflags0 { ghcLink = LinkInMemory\n , verbosity = 1 }\n#if MIN_VERSION_ghc(9,6,0)\n dflags2 = dflags1 { backend = interpreterBackend\n , targetWays_ = hostFullWays }\n#elif MIN_VERSION_ghc(9,2,0)\n dflags2 = dflags1 { backend = Interpreter\n , targetWays_ = hostFullWays }\n#elif MIN_VERSION_ghc(9,0,0)\n dflags2 = dflags1 { hscTarget = HscInterpreted\n , ways = hostFullWays }\n#else\n dflags2 = updateWays (dflags1 { hscTarget = HscInterpreted\n , ways = hostFullWays })\n hostFullWays = interpWays\n#endif\n dflags3 = upd_gopt gopt_set wayGeneralFlags dflags2\n dflags4 = upd_gopt gopt_unset wayUnsetGeneralFlags dflags3\n in dflags4\n{-# INLINABLE useInterpreter #-}\n\n-- | Insert new macro. This function will override existing macro.\ninsertMacro :: FastString -> Macro -> Fnk ()\ninsertMacro k v =\n modifyFnkEnv (\\e -> e {envMacros = addMacro k v (envMacros e)})\n{-# INLINABLE insertMacro #-}\n\n-- | Lookup macro by name.\n--\n-- Lookup macro from persistent and temporary macros. When macros with\n-- conflicting name exist, the latest temporary macro wins.\nlookupMacro :: FastString -> FnkEnv -> Maybe Macro\nlookupMacro name fnk_env = go (envTmpMacros fnk_env)\n where\n go [] = Map.lookup (MacroName name) (envMacros fnk_env)\n go (t:ts) = Map.lookup (MacroName name) t `mplus` go ts\n{-# INLINABLE lookupMacro #-}\n\n-- | Empty 'EnvMacros'.\nemptyEnvMacros :: EnvMacros\nemptyEnvMacros = Map.empty\n\n-- | Make 'EnvMacros' from list of macro name and value pairs.\nmakeEnvMacros :: [(String, Macro)] -> EnvMacros\nmakeEnvMacros = Map.fromList . map (first (MacroName . fsLit))\n{-# INLINABLE makeEnvMacros #-}\n\n-- | Merge macros.\nmergeMacros :: EnvMacros -> EnvMacros -> EnvMacros\nmergeMacros = Map.union\n{-# INLINABLE mergeMacros #-}\n\n-- | Delete macro by macro name.\ndeleteMacro :: FastString -> EnvMacros -> EnvMacros\ndeleteMacro fs = Map.delete (MacroName fs)\n{-# INLINABLE deleteMacro #-}\n\naddMacro :: FastString -> Macro -> EnvMacros -> EnvMacros\naddMacro fs = Map.insert (MacroName fs)\n{-# INLINABLE addMacro #-}\n\n-- | All macros in given macro environment, filtering out the special\n-- forms.\nmacroNames :: EnvMacros -> [String]\nmacroNames = Map.foldrWithKey f []\n where\n f k m acc = case m of\n Macro _ -> unpackFS (unMacroName k) : acc\n _ -> acc\n{-# INLINABLE macroNames #-}\n\n-- | 'True' when given 'TyThing' is a 'Macro'.\nisMacro :: HscEnv -> TyThing -> Bool\nisMacro hsc_env thing = do\n let dflags = hsc_dflags hsc_env\n#if MIN_VERSION_ghc(9,2,0)\n tystr = showSDocForUser dflags us alwaysQualify . ppr . varType\n us = hsc_units hsc_env\n#else\n tystr = showSDocForUser dflags alwaysQualify . ppr . varType\n#endif\n case thing of\n AnId var -> tystr var == \"Language.Finkel.Fnk.Macro\"\n _ -> False\n{-# INLINABLE isMacro #-}\n\n-- | Extract function from macro and apply to given code. Uses 'emptyFnkEnv'\n-- with 'specialForms' to unwrap the macro from 'Fnk'.\nmacroFunction :: Macro -> Code -> Fnk Code\nmacroFunction mac =\n case mac of\n Macro f -> f\n SpecialForm f -> f\n{-# INLINABLE macroFunction #-}\n\n\n-- ------------------------------------------------------------------------\n--\n-- Gensym\n--\n-- ------------------------------------------------------------------------\n\n#if MIN_VERSION_ghc(9,10,0)\ntype InitialUnique = Word64\n#elif MIN_VERSION_ghc(9,2,0)\ntype InitialUnique = Word\n#else\ntype InitialUnique = Int\n#endif\n\n-- | Generate unique symbol with @gensym'@.\ngensym :: MonadUnique m => m Code\ngensym = gensym' \"gensym_var\"\n{-# INLINABLE gensym #-}\n\n-- | Generate unique symbol with given prefix.\n--\n-- Note that although this function does not generate same symbol twice,\n-- generated symbol has a chance to have a same name from symbols entered from\n-- codes written by arbitrary users.\ngensym' :: MonadUnique m => String -> m Code\ngensym' prefix = do\n u <- getUniqueM\n return (LForm (genSrc (Atom (aSymbol (prefix ++ show u)))))\n{-# INLINABLE gensym' #-}\n\n-- Note: [Initialization of UniqSupply]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- Test codes in finkel-kernel packages are calling the 'defaultMain' function\n-- multiple times. To avoid initialization of UniqSupply multiple times, using\n-- top-level IORef to detect whether the initializatio has been done or not.\n\n-- | Variant of 'initUniqSupply' which does initialization only once.\ninitUniqSupply' :: InitialUnique -> Int -> IO ()\ninitUniqSupply' ini incr = do\n is_initialized <- readIORef uniqSupplyInitialized\n unless is_initialized\n (do initUniqSupply ini incr\n atomicModifyIORef' uniqSupplyInitialized (const (True, ())))\n{-# INLINABLE initUniqSupply' #-}\n\n-- | Top level 'IORef' for book keeping 'UniqSupply' initialization, obtained\n-- with 'unsafePerformIO'.\nuniqSupplyInitialized :: IORef Bool\nuniqSupplyInitialized = unsafePerformIO (newIORef False)\n{-# NOINLINE uniqSupplyInitialized #-}\n\n\n-- ------------------------------------------------------------------------\n--\n-- GHC lib directory\n--\n-- ------------------------------------------------------------------------\n\n-- | Read cached ghc libdir from top-level 'IORef'.\n--\n-- If the libdir is not cached, invoke /ghc/ command to get the libdir.\ngetLibDirFromGhc :: IO FilePath\ngetLibDirFromGhc = do\n mb_path <- readIORef globalLibDirRef\n case mb_path of\n Just path -> pure path\n Nothing -> do\n path <- initializeLibDirFromGhc\n atomicModifyIORef' globalLibDirRef $ const (Just path, path)\n{-# INLINABLE getLibDirFromGhc #-}\n\n-- | Get ghc lib directory by file layout lookup or invoking @ghc\n-- --print-libdir@.\ninitializeLibDirFromGhc :: IO FilePath\ninitializeLibDirFromGhc = do\n -- Manually lookup the path of \"ghc\" executable, then try finding the\n -- \"settings\" file in installed ghc. Assuming file layouts are:\n -- is located at:\n --\n -- .../bin/ghc <- symlink to ghc wrapper script\n -- .../lib/ghc-X.Y.Z <- $topdir\n --\n -- To confirm that the \"ghc-X.Y.Z\" is indeed the library directory to return,\n -- checking the existence of \"settings\" file in the directory. If the\n -- \"settings\" file was not found, delegating the work by invoking the \"ghc\"\n -- command with \"--print-libdir\". This is slower than additional directory and\n -- file lookups, but should be safer and more reliable.\n --\n -- See \"GHC.BaseDir.getBaseDir\" in \"ghc-boot\" package, which is doing similar\n -- work but using \"getExecutablePath\".\n mb_ghc_script <- findExecutable \"ghc\" >>= mapM canonicalizePath\n case mb_ghc_script of\n Nothing -> exitWithGhcNotFound\n Just ghc_script -> do\n let ghc_top_dir = takeDirectory (takeDirectory ghc_script)\n ghc_lib_dir0 = ghc_top_dir \"lib\" \"ghc-\" ++ cProjectVersion\n#if MIN_VERSION_ghc(9,4,0)\n -- Output of \"ghc --print-libdir\" changed in ghc 9.4.\n ghc_lib_dir1 = ghc_lib_dir0 \"lib\"\n#else\n ghc_lib_dir1 = ghc_lib_dir0\n#endif\n settings_found <- doesFileExist (ghc_lib_dir1 \"settings\")\n if settings_found\n then return ghc_lib_dir1\n else do\n out <- readProcess \"ghc\" [\"--print-libdir\"] \"\"\n return (reverse (dropWhile isSpace (reverse out)))\n{-# INLINABLE initializeLibDirFromGhc #-}\n\n-- | Show ghc not found message and exit with 'exitFailure'.\nexitWithGhcNotFound :: IO a\nexitWithGhcNotFound = do\n me <- getProgName\n putStrLn $ me ++ \": Cannot find GHC executable in current PATH\"\n exitFailure\n{-# INLINABLE exitWithGhcNotFound #-}\n\n-- Note: This global ghc libdir is obtained and cached at runtime, not at\n-- compile time.\nglobalLibDirRef :: IORef (Maybe FilePath)\nglobalLibDirRef = unsafePerformIO $ newIORef Nothing\n{-# NOINLINE globalLibDirRef #-}\n\n\n-- ---------------------------------------------------------------------\n--\n-- Debug related functions\n--\n-- ---------------------------------------------------------------------\n\n-- | 'True' when the given 'FnkDebugFlag' is turned on.\nfopt :: FnkDebugFlag -> FnkEnv -> Bool\nfopt flag fnk_env =\n testBit (envDumpFlags fnk_env) (fromEnum flag)\n || envVerbosity fnk_env >= verbosity_to_enable\n where\n verbosity_to_enable =\n case flag of\n -- Dump options\n Fnk_dump_dflags -> 2\n Fnk_dump_expand -> 2\n Fnk_dump_hs -> 2\n Fnk_dump_session -> 2\n -- Trace options\n Fnk_trace_expand -> 3\n Fnk_trace_make -> 3\n Fnk_trace_session -> 3\n Fnk_trace_spf -> 3\n{-# INLINABLE fopt #-}\n\n-- | Turn on the given 'FnkDebugFlag'.\nfoptSet :: FnkDebugFlag -> FnkEnv -> FnkEnv\nfoptSet flag fnk_env =\n fnk_env {envDumpFlags = setBit (envDumpFlags fnk_env) (fromEnum flag)}\n{-# INLINABLE foptSet #-}\n\n-- | Update the 'envVerbosity' to given value.\nsetFnkVerbosity :: Int -> FnkEnv -> FnkEnv\nsetFnkVerbosity v fnk_env = fnk_env {envVerbosity = v}\n{-# INLINABLE setFnkVerbosity #-}\n\n-- | Dump 'SDoc's when the given 'FnkDebugFlag' is turned on.\ndebugWhen\n :: (MonadIO m, HasDynFlags m) => FnkEnv -> FnkDebugFlag -> [SDoc] -> m ()\ndebugWhen fnk_env flag mdocs =\n getDynFlags >>= \\dflags -> debugWhen' dflags fnk_env flag mdocs\n{-# INLINABLE debugWhen #-}\n\ndebugWhen'\n :: MonadIO m => DynFlags -> FnkEnv -> FnkDebugFlag -> [SDoc] -> m ()\ndebugWhen' dflags fnk_env flag mdocs =\n when (fopt flag fnk_env) (dumpSDocs dflags mdocs)\n{-# INLINABLE debugWhen' #-}\n\ndumpSDocs :: MonadIO m => DynFlags -> [SDoc] -> m ()\ndumpSDocs dflags mdocs = liftIO $\n withMVar globalDumpSDocsLock $ const (pr (vcat mdocs))\n where\n#if MIN_VERSION_ghc(9,2,0)\n pr = printSDocLn (initSDocContext dflags err_style)\n (Pretty.PageMode False)\n stderr\n err_style = defaultErrStyle\n#elif MIN_VERSION_ghc(9,0,0)\n pr = printSDocLn (initSDocContext dflags err_style) Pretty.PageMode stderr\n err_style = defaultErrStyle\n#else\n pr = printSDocLn Pretty.PageMode dflags stderr err_style\n err_style = defaultErrStyle dflags\n#endif\n{-# INLINABLE dumpSDocs #-}\n\n-- | Get finkel debug setting from environment variable /FNK_DEBUG/.\ngetFnkDebug :: MonadIO m => m Bool\ngetFnkDebug =\n do mb_debug <- liftIO (lookupEnv \"FNK_DEBUG\")\n case mb_debug of\n Nothing -> return False\n Just _ -> return True\n{-# INLINABLE getFnkDebug #-}\n\n-- | Show some fields in 'DynFlags'.\ndumpDynFlags :: MonadIO m => FnkEnv -> SDoc -> DynFlags -> m ()\ndumpDynFlags fnk_env label dflags =\n debugWhen' dflags fnk_env Fnk_dump_dflags msgs\n where\n msgs =\n [ label\n , \" ghcLink:\" <+> text (show (ghcLink dflags))\n , \" ghcMode:\" <+> ppr (ghcMode dflags)\n#if MIN_VERSION_ghc(9,2,0)\n , \" backend:\" <+> text (show (backend dflags))\n#else\n , \" hscTarget:\" <+> text (show (hscTarget dflags))\n#endif\n#if MIN_VERSION_ghc(9,2,0)\n , \" ways:\" <+> text (show (ways dflags))\n#else\n , \" ways:\" <+> text (show (ways dflags))\n#endif\n , \" forceRecomp:\" <+> text (show (gopt Opt_ForceRecomp dflags))\n#if MIN_VERSION_ghc(9,0,0)\n , \" hostFullWays:\" <+> text (show hostFullWays)\n#else\n , \" interpWays:\" <+> text (show interpWays)\n#endif\n , \" importPaths:\" <+> sep (map text (importPaths dflags))\n#if MIN_VERSION_ghc(9,4,0)\n , \" workingDirectory:\" <+> text (show (workingDirectory dflags))\n , \" num_plugins:\" <+> text (show (length (pluginModNames dflags)))\n , \" opt_pp:\" <+> text (show (gopt Opt_Pp dflags))\n , \" pgmF:\" <+> text (toolSettings_pgm_F (toolSettings dflags))\n#endif\n#if !MIN_VERSION_ghc(9,4,0)\n , \" optLevel:\" <+> text (show (optLevel dflags))\n#endif\n#if MIN_VERSION_ghc(9,2,0)\n , \" homeUnitId_:\" <+> ppr (homeUnitId_ dflags)\n#elif MIN_VERSION_ghc(9,0,0)\n , \" homeUnitId:\" <+> ppr (homeUnitId dflags)\n#else\n , \" thisInstallUnitId:\" <+> ppr (thisInstalledUnitId dflags)\n#endif\n , \" ldInputs:\" <+> sep (map (text . showOpt) (ldInputs dflags))\n#if MIN_VERSION_ghc(9,2,0)\n , \" mainModuleNameIs:\" <+> ppr (mainModuleNameIs dflags)\n#else\n , \" mainModIs:\" <+> ppr (mainModIs dflags)\n#endif\n#if !MIN_VERSION_ghc(9,6,0)\n , \" mainFunIs:\" <+> ppr (mainFunIs dflags)\n#endif\n , \" safeHaskell:\" <+> text (show (safeHaskell dflags))\n , \" lang:\" <+> ppr (language dflags)\n , \" extensionFlags:\" <+> ppr (EnumSet.toList (extensionFlags dflags))\n , \" includePathsQuote:\" <+>\n vcat (map text (includePathsQuote (includePaths dflags)))\n , \" includePathsGlobal:\" <+>\n vcat (map text (includePathsGlobal (includePaths dflags)))\n , \" picPOpts:\" <+> sep (map text (picPOpts dflags))\n#if MIN_VERSION_ghc(9,6,0)\n , \" opt_P_signature:\" <+> ppr (snd (opt_P_signature dflags))\n#else\n , \" opt_P_signature:\" <+> ppr (opt_P_signature dflags)\n#endif\n , \" hcSuf:\" <+> text (hcSuf dflags)\n#if MIN_VERSION_ghc(9,0,0)\n , \" sccProfilingOn:\" <+> text (show (sccProfilingEnabled dflags))\n#else\n , \" sccProfilingOn:\" <+> text (show (gopt Opt_SccProfilingOn dflags))\n#endif\n , \" ticky:\" <+> ppr (map (`gopt` dflags) [ Opt_Ticky\n , Opt_Ticky_Allocd\n , Opt_Ticky_LNE\n , Opt_Ticky_Dyn_Thunk ])\n , \" debugLevel:\" <+> ppr (debugLevel dflags)\n ]\n\n-- | Show 'HomeModInfo' in 'HomePackageTable' (and 'HomeUnitGraph' in ghc >=\n-- 9.4).\ndumpHscEnv :: MonadIO m => FnkEnv -> SDoc -> HscEnv -> m ()\ndumpHscEnv fnk_env label hsc_env =\n debugWhen' (hsc_dflags hsc_env) fnk_env Fnk_dump_session msgs\n where\n msgs =\n label : map (nest 2)\n [ \"hsc_targets:\" <+> ppr (hsc_targets hsc_env)\n , \"hsc_hpt:\" <+> pprHPT (hsc_HPT hsc_env)\n#if MIN_VERSION_ghc(9,4,0)\n , \"home_unit_graph:\" <+> ppr (hsc_HUG hsc_env)\n , \"hsc_type_env_vars:\" <+> ppr (hsc_type_env_vars hsc_env)\n , \"hsc_hooks (runPhaseHook):\" <+>\n ppr (fmap (const (\"\" :: SDoc))\n (runPhaseHook (hsc_hooks hsc_env)))\n#endif\n ]\n\n-- XXX: Unsafe global lock to avoid mixing up messages in concurrent settings.\n-- When FnkEnv is shared, better to add a MVar field in the shared FnkEnv for\n-- such purpose (But FnkEnv is not shared in parsedResultAction).\nglobalDumpSDocsLock :: MVar ()\nglobalDumpSDocsLock = unsafePerformIO (newMVar ())\n{-# NOINLINE globalDumpSDocsLock #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Form.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE DeriveGeneric #-}\n{-# LANGUAGE FlexibleInstances #-}\n-- | S-expression form data.\nmodule Language.Finkel.Form\n (\n -- * Types\n Code\n , Atom(..)\n , Form(..)\n , LForm(..)\n\n -- * Constructor functions\n , QuoteFn\n , qSymbol\n , qChar\n , qString\n , qInteger\n , qFractional\n , qUnit\n , qList\n , qHsList\n , nil\n\n -- * Auxiliary functions\n , aFractional\n , aIntegral\n , aSymbol\n , aString\n , genSrc\n , mkLocatedForm\n , showLoc\n , toListL\n , unCode\n , withLocInfo\n , asLocOf\n\n -- * Re-export\n , IntegralLit (..)\n , mkIntegralLit\n , FractionalLit(..)\n#if MIN_VERSION_ghc(9,2,0)\n , fl_value\n#endif\n , SourceText(..)\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Applicative (Alternative (..))\nimport Control.Monad (MonadPlus (..))\nimport Data.Data (Data, Typeable)\nimport Data.Function (on)\nimport Data.Maybe (fromMaybe)\nimport GHC.Generics (Generic)\n\n-- binary\nimport Data.Binary (Binary (..), Get, Put,\n getWord8, putWord8)\n\n-- ghc\nimport GHC_Data_FastString (FastString, fsLit, unpackFS)\nimport GHC_Types_SourceText (SourceText (..))\nimport GHC_Types_SrcLoc (GenLocated (..), Located,\n RealSrcSpan (..),\n SrcSpan (..), combineLocs,\n combineSrcSpans, mkRealSrcLoc,\n mkRealSrcSpan, mkSrcLoc,\n mkSrcSpan, srcSpanEndCol,\n srcSpanEndLine, srcSpanFile,\n srcSpanFileName_maybe,\n srcSpanStartCol,\n srcSpanStartLine)\nimport GHC_Utils_Outputable (Outputable (..), brackets,\n cat, char, double,\n doubleQuotes, fsep, integer,\n parens, text)\n\n#if MIN_VERSION_ghc(9,4,0)\nimport qualified GHC.Data.Strict as Strict\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Types_SrcLoc (BufPos (..), BufSpan (..),\n UnhelpfulSpanReason (..),\n unhelpfulSpanFS)\n#endif\n\nimport GHC_Types_SourceText (IntegralLit (..),\n mkIntegralLit)\n\n-- deepseq\nimport Control.DeepSeq (NFData (..))\n\n-- Internal\nimport Language.Finkel.Data.FastString (getFastString, putFastString)\nimport Language.Finkel.Data.Fractional\nimport Language.Finkel.Data.SourceText (getSourceText, putSourceText)\n\n\n-- -------------------------------------------------------------------\n--\n-- Form data type\n--\n-- -------------------------------------------------------------------\n\n-- | Atom in tokens.\ndata Atom\n = AUnit\n | ASymbol {-# UNPACK #-} !FastString\n | AChar SourceText {-# UNPACK #-} !Char\n | AString SourceText {-# UNPACK #-} !FastString\n | AInteger {-# UNPACK #-} !IntegralLit\n | AFractional {-# UNPACK #-} !FractionalLit\n deriving (Data, Typeable, Generic)\n\ninstance Eq Atom where\n AUnit == AUnit = True\n ASymbol x == ASymbol y = x == y\n AChar _ x == AChar _ y = x == y\n AString _ x == AString _ y = x == y\n AInteger x == AInteger y = x == y\n AFractional x == AFractional y = x == y\n _ == _ = False\n {-# INLINE (==) #-}\n\ninstance Show Atom where\n showsPrec d x =\n case x of\n AUnit -> showString \"()\"\n ASymbol s -> showString (unpackFS s)\n AChar _ c -> showString $ case c of\n '\\a' -> \"#'\\\\BEL\"\n '\\b' -> \"#'\\\\BS\"\n '\\f' -> \"#'\\\\FF\"\n '\\n' -> \"#'\\\\LF\"\n '\\r' -> \"#'\\\\CR\"\n '\\t' -> \"#'\\\\HT\"\n '\\v' -> \"#'\\\\VT\"\n ' ' -> \"#'\\\\SP\"\n _ -> ['#', '\\'', c]\n AString _ s -> showsPrec d s\n AInteger il -> showsPrec d (il_value il)\n AFractional f -> showString (showFractionalList f)\n\ninstance NFData Atom where\n rnf x =\n case x of\n AUnit -> ()\n ASymbol fs -> seq fs ()\n AChar _ c -> seq c ()\n AString _ str -> seq str ()\n AInteger i -> rnf (il_value i)\n AFractional y -> seq y ()\n\ninstance Outputable Atom where\n ppr form =\n case form of\n AUnit -> ppr ()\n ASymbol x -> ppr x\n AChar _ x -> cat [text \"#'\", char x]\n AString _ x -> doubleQuotes (ppr x)\n AInteger x -> integer (il_value x)\n AFractional x -> double (fromRational (fl_value x))\n\n-- | Form type. Also used as token. Elements of recursive structures\n-- contain location information.\ndata Form a\n = Atom a -- ^ S-expression atom.\n | List [LForm a] -- ^ S-expression list.\n | HsList [LForm a] -- ^ Haskell list.\n | TEnd -- ^ End of token.\n deriving (Eq, Data, Typeable, Generic)\n\n-- | Newtype wrapper for located 'Form'.\nnewtype LForm a = LForm {unLForm :: Located (Form a)}\n deriving (Data, Typeable, Generic)\n\n-- | Type synonym for code data.\n--\n-- The 'Code' data is the fundamental data type used in the entire compilation\n-- work. The 'Code' is used to represed data from parsed source file, and used\n-- for input and output of macros transformer functions. List of 'Code' data are\n-- converted to Haskell AST via syntax parser.\n--\n-- Since 'Code' is returned from parsed source file, source code location\n-- information is attached to 'Code'.\n--\ntype Code = LForm Atom\n\n\n-- ------------------------------------------------------------------------\n--\n-- Instances\n--\n-- ------------------------------------------------------------------------\n\ninstance Eq a => Eq (LForm a) where\n LForm (L _ a) == LForm (L _ b) = a == b\n {-# INLINE (==) #-}\n\ninstance Show a => Show (Form a) where\n showsPrec d form =\n case form of\n Atom a -> showsPrec d a\n List xs -> showL (Just \"nil\") '(' ')' xs\n HsList xs -> showL Nothing '[' ']' xs\n TEnd -> showString \"TEnd\"\n where\n showL mb_nil open close xs next =\n case xs of\n [] -> maybe (open : close : next)\n (++ next)\n mb_nil\n x:xs' -> open : shows x (showL' close xs' next)\n showL' close xs next =\n case xs of\n [] -> close : next\n y:ys -> ' ' : shows y (showL' close ys next)\n\ninstance Show a => Show (LForm a) where\n showsPrec d (LForm (L _ a)) = showsPrec d a\n {-# INLINE showsPrec #-}\n\ninstance Functor Form where\n fmap f form =\n case form of\n Atom a -> Atom (f a)\n List xs -> List (map (fmap f) xs)\n HsList xs -> HsList (map (fmap f) xs)\n TEnd -> TEnd\n {-# INLINE fmap #-}\n\ninstance Functor LForm where\n fmap f (LForm (L l a)) = LForm (L l (fmap f a))\n {-# INLINE fmap #-}\n\ninstance Applicative Form where\n pure = Atom\n {-# INLINE pure #-}\n\n Atom f <*> Atom a = Atom (f a)\n Atom f <*> List as = List (map (fmap f) as)\n Atom f <*> HsList as = HsList (map (fmap f) as)\n\n List fs <*> a@(Atom _) = List (fmap apLF fs <*> [a])\n List fs <*> List as = List (fmap (<*>) fs <*> as)\n List fs <*> HsList as = List (fmap (<*>) fs <*> as)\n\n HsList fs <*> a@(Atom _) = HsList (fmap apLF fs <*> [a])\n HsList fs <*> List as = HsList (fmap (<*>) fs <*> as)\n HsList fs <*> HsList as = HsList (fmap (<*>) fs <*> as)\n\n TEnd <*> _ = TEnd\n _ <*> TEnd = TEnd\n {-# INLINE (<*>) #-}\n\ninstance Applicative LForm where\n pure = LForm . genSrc . pure\n {-# INLINE pure #-}\n\n LForm (L l f) <*> LForm (L _ a) = LForm (L l (f <*> a))\n {-# INLINE (<*>) #-}\n\ninstance Monad Form where\n m >>= k =\n case m of\n Atom a -> k a\n List as -> List (map (liftLF (>>= k)) as)\n HsList as -> HsList (map (liftLF (>>= k)) as)\n TEnd -> TEnd\n {-# INLINE (>>=) #-}\n\ninstance Monad LForm where\n LForm (L l a) >>= k = LForm (L l (a >>= (unCode . k)))\n {-# INLINE (>>=) #-}\n\ninstance Foldable Form where\n foldr f z form =\n case form of\n TEnd -> z\n Atom x -> f x z\n List xs ->\n case xs of\n [] -> z\n y:ys -> foldr f (foldr f z (List ys)) (unCode y)\n HsList xs ->\n case xs of\n [] -> z\n y:ys -> foldr f (foldr f z (HsList ys)) (unCode y)\n {-# INLINE foldr #-}\n\ninstance Foldable LForm where\n foldr f z (LForm (L _ form)) = foldr f z form\n {-# INLINE foldr #-}\n\ninstance Traversable Form where\n traverse f form =\n case form of\n Atom x -> fmap Atom (f x)\n List xs -> fmap List (traverse (traverse f) xs)\n HsList xs -> fmap HsList (traverse (traverse f) xs)\n TEnd -> pure TEnd\n {-# INLINE traverse #-}\n\ninstance Traversable LForm where\n traverse f (LForm (L l form)) = fmap (LForm . L l) (traverse f form)\n {-# INLINE traverse #-}\n\ninstance NFData a => NFData (Form a) where\n rnf x =\n case x of\n Atom a -> rnf a\n List as -> rnf as\n HsList as -> rnf as\n TEnd -> ()\n\ninstance NFData a => NFData (LForm a) where\n rnf (LForm (L l a)) = rnf l `seq` rnf a\n\ninstance Outputable a => Outputable (Form a) where\n ppr x =\n case x of\n Atom a -> ppr a\n List xs -> parens (fsep (map ppr xs))\n HsList xs -> brackets (fsep (map ppr xs))\n TEnd -> text \"\"\n\ninstance Outputable a => Outputable (LForm a) where\n ppr (LForm (L _ a)) = ppr a\n\ninstance Semigroup (Form a) where\n Atom a <> Atom b = List [atomForm a, atomForm b]\n Atom a <> List bs = List (atomForm a : bs)\n Atom a <> HsList bs = List (atomForm a : bs)\n\n List as <> Atom b = List (as <> [atomForm b])\n List as <> List bs = List (as <> bs)\n List as <> HsList bs = List (as <> bs)\n\n HsList as <> Atom b = List (as <> [atomForm b])\n HsList as <> List bs = List (as <> bs)\n HsList as <> HsList bs = List (as <> bs)\n\n TEnd <> b = b\n a <> TEnd = a\n {-# INLINE (<>) #-}\n\ninstance Semigroup (LForm a) where\n LForm (L l a) <> LForm (L r b) = LForm (L (combineSrcSpans l r) (a <> b))\n {-# INLINE (<>) #-}\n\ninstance Monoid (Form a) where\n mempty = List []\n {-# INLINE mempty #-}\n\ninstance Monoid (LForm a) where\n mempty = LForm (genSrc mempty)\n {-# INLINE mempty #-}\n\ninstance Alternative Form where\n empty = mempty\n {-# INLINE empty #-}\n (<|>) = mappend\n {-# INLINE (<|>) #-}\n\ninstance Alternative LForm where\n empty = mempty\n {-# INLINE empty #-}\n (<|>) = mappend\n {-# INLINE (<|>) #-}\n\ninstance MonadPlus Form\n\ninstance MonadPlus LForm\n\ninstance Num (Form Atom) where\n (+) = nop2 aIntegral (+) (+)\n {-# INLINE (+) #-}\n (*) = nop2 aIntegral (*) (*)\n {-# INLINE (*) #-}\n negate = nop1 aIntegral negate negate\n {-# INLINE negate #-}\n abs = nop1 aIntegral abs abs\n {-# INLINE abs #-}\n signum = nop1 aIntegral signum signum\n {-# INLINE signum #-}\n fromInteger = Atom . aIntegral\n {-# INLINE fromInteger #-}\n\ninstance Num Code where\n (+) = liftLF2 (+)\n {-# INLINE (+) #-}\n (*) = liftLF2 (*)\n {-# INLINE (*) #-}\n negate = liftLF negate\n {-# INLINE negate #-}\n abs = liftLF abs\n {-# INLINE abs #-}\n signum = liftLF signum\n {-# INLINE signum #-}\n fromInteger = LForm . genSrc . fromInteger\n {-# INLINE fromInteger #-}\n\ninstance Fractional (Form Atom) where\n (/) = nop2 aDouble ((/) `on` fromIntegral) (/)\n {-# INLINE (/) #-}\n recip = nop1 aDouble (recip . fromInteger) recip\n {-# INLINE recip #-}\n fromRational = Atom . aDouble. fromRational\n {-# INLINE fromRational #-}\n\ninstance Fractional Code where\n (/) = liftLF2 (/)\n {-# INLINE (/) #-}\n recip = liftLF recip\n {-# INLINE recip #-}\n fromRational = LForm . genSrc . fromRational\n {-# INLINE fromRational #-}\n\n\n-- -------------------------------------------------------------------\n--\n-- Instances for classes from binary package\n--\n-- -------------------------------------------------------------------\n\ninstance Binary Atom where\n put x = case x of\n AUnit -> putWord8 0\n ASymbol fs -> putWord8 1 >> putFastString fs\n AChar st c -> putWord8 2 >> putSourceText st >> put c\n AString st fs -> putWord8 3 >> putSourceText st >> putFastString fs\n AInteger il -> putWord8 4 >> putIntegralLit il\n AFractional fl -> putWord8 5 >> putFractionalLit fl\n {-# INLINE put #-}\n\n get = do\n t <- getWord8\n case t of\n 0 -> pure AUnit\n 1 -> ASymbol <$> getFastString\n 2 -> AChar <$> getSourceText <*> get\n 3 -> AString <$> getSourceText <*> getFastString\n 4 -> AInteger <$> getIntegralLit\n 5 -> AFractional <$> getFractionalLit\n _ -> error $ \"get: unknown tag \" ++ show t\n {-# INLINE get #-}\n\nputIntegralLit :: IntegralLit -> Put\nputIntegralLit il =\n putSourceText (il_text il) *> put (il_neg il) *> put (il_value il)\n{-# INLINABLE putIntegralLit #-}\n\ngetIntegralLit :: Get IntegralLit\ngetIntegralLit = IL <$> getSourceText <*> get <*> get\n{-# INLINABLE getIntegralLit #-}\n\ninstance Binary a => Binary (Form a) where\n put form = case form of\n Atom x -> putWord8 0 *> put x\n List xs -> putWord8 1 *> put xs\n HsList xs -> putWord8 2 *> put xs\n TEnd -> putWord8 3\n {-# INLINE put #-}\n\n get = do\n t <- getWord8\n case t of\n 0 -> Atom <$> get\n 1 -> List <$> get\n 2 -> HsList <$> get\n 3 -> pure TEnd\n _ -> error $ \"getForm: unknown tag \" ++ show t\n {-# INLINE get #-}\n\ninstance Binary a => Binary (LForm a) where\n put (LForm (L l a)) = putSrcSpan l *> put a\n {-# INLINE put #-}\n\n get = LForm <$> (L <$> getSrcSpan <*> get)\n {-# INLINE get #-}\n\n#if MIN_VERSION_ghc(9,0,0)\nputSrcSpan :: SrcSpan -> Put\nputSrcSpan s = case s of\n RealSrcSpan p mb -> putWord8 0 *> putRealSrcSpan p *> putMbBufSpan mb\n UnhelpfulSpan reason -> putWord8 1 *> putUnhelpfulSpanReason reason\n\ngetSrcSpan :: Get SrcSpan\ngetSrcSpan = do\n t <- getWord8\n case t of\n 0 -> RealSrcSpan <$> getRealSrcSpan <*> getMbBufSpan\n 1 -> UnhelpfulSpan <$> getUnhelpfulSpanReason\n _ -> error $ \"getSrcSpan: unknown tag \" ++ show t\n\n# if MIN_VERSION_ghc(9,4,0)\nputMbBufSpan :: Strict.Maybe BufSpan -> Put\nputMbBufSpan mb_bs = case mb_bs of\n Strict.Just (BufSpan s e) -> putWord8 0 *> putBufPos s *> putBufPos e\n Strict.Nothing -> putWord8 1\n\ngetMbBufSpan :: Get (Strict.Maybe BufSpan)\ngetMbBufSpan = do\n t <- getWord8\n case t of\n 0 -> Strict.Just <$> (BufSpan <$> getBufPos <*> getBufPos)\n 1 -> pure Strict.Nothing\n _ -> error $ \"getMbBufSpan: unknown tag \" ++ show t\n# else\nputMbBufSpan :: Maybe BufSpan -> Put\nputMbBufSpan mb_bs = case mb_bs of\n Just (BufSpan s e) -> putWord8 0 *> putBufPos s *> putBufPos e\n Nothing -> putWord8 1\n\ngetMbBufSpan :: Get (Maybe BufSpan)\ngetMbBufSpan = do\n t <- getWord8\n case t of\n 0 -> Just <$> (BufSpan <$> getBufPos <*> getBufPos)\n 1 -> pure Nothing\n _ -> error $ \"getMbBufSpan: unknown tag \" ++ show t\n# endif\n\n{-# INLINABLE putMbBufSpan #-}\n{-# INLINABLE getMbBufSpan #-}\n\nputBufPos :: BufPos -> Put\nputBufPos (BufPos p) = put p\n{-# INLINABLE putBufPos #-}\n\ngetBufPos :: Get BufPos\ngetBufPos = BufPos <$> get\n{-# INLINABLE getBufPos #-}\n\nputUnhelpfulSpanReason :: UnhelpfulSpanReason -> Put\nputUnhelpfulSpanReason r = case r of\n UnhelpfulNoLocationInfo -> putWord8 0\n UnhelpfulWiredIn -> putWord8 1\n UnhelpfulInteractive -> putWord8 2\n UnhelpfulGenerated -> putWord8 3\n UnhelpfulOther fs -> putWord8 4 *> putFastString fs\n{-# INLINABLE putUnhelpfulSpanReason #-}\n\ngetUnhelpfulSpanReason :: Get UnhelpfulSpanReason\ngetUnhelpfulSpanReason = do\n t <- getWord8\n case t of\n 0 -> pure UnhelpfulNoLocationInfo\n 1 -> pure UnhelpfulWiredIn\n 2 -> pure UnhelpfulInteractive\n 3 -> pure UnhelpfulGenerated\n 4 -> UnhelpfulOther <$> getFastString\n _ -> error $ \"getUnhelpfulSpanReason: unknown tag \" ++ show t\n{-# INLINABLE getUnhelpfulSpanReason #-}\n\n#else\nputSrcSpan :: SrcSpan -> Put\nputSrcSpan s = case s of\n RealSrcSpan rs -> putWord8 0 *> putRealSrcSpan rs\n UnhelpfulSpan fs -> putWord8 1 *> putFastString fs\n\ngetSrcSpan :: Get SrcSpan\ngetSrcSpan = do\n t <- getWord8\n case t of\n 0 -> RealSrcSpan <$> getRealSrcSpan\n 1 -> UnhelpfulSpan <$> getFastString\n _ -> error $ \"getSrcSpan: unknown tag \" ++ show t\n#endif\n\n{-# INLINABLE putSrcSpan #-}\n{-# INLINABLE getSrcSpan #-}\n\nputRealSrcSpan :: RealSrcSpan -> Put\nputRealSrcSpan rs = do\n putFastString (srcSpanFile rs)\n put (srcSpanStartLine rs)\n put (srcSpanStartCol rs)\n put (srcSpanEndLine rs)\n put (srcSpanEndCol rs)\n{-# INLINEABLE putRealSrcSpan #-}\n\ngetRealSrcSpan :: Get RealSrcSpan\ngetRealSrcSpan = do\n fs <- getFastString\n mkRealSrcSpan\n <$> (mkRealSrcLoc fs <$> get <*> get)\n <*> (mkRealSrcLoc fs <$> get <*> get)\n{-# INLINEABLE getRealSrcSpan #-}\n\n-- -------------------------------------------------------------------\n--\n-- Constructor functions\n--\n-- -------------------------------------------------------------------\n\n-- | Type synonym for functions for quoting form.\ntype QuoteFn\n = String -- ^ File name.\n -> Int -- ^ Start line.\n -> Int -- ^ Start column.\n -> Int -- ^ End line.\n -> Int -- ^ End column.\n -> Code\n\n-- | Make quoted symbol from 'String'.\nqSymbol :: String -> QuoteFn\nqSymbol = quotedWithLoc . Atom . aSymbol\n{-# INLINABLE qSymbol #-}\n\n-- | Make quoted char from 'Char'.\nqChar :: Char -> QuoteFn\nqChar = quotedWithLoc . Atom . AChar NoSourceText\n{-# INLINABLE qChar #-}\n\n-- | Make quoted string from 'String'.\nqString :: String -> QuoteFn\nqString = quotedWithLoc . Atom . aString NoSourceText\n{-# INLINABLE qString #-}\n\n-- | Make quoted integer from 'Integer'.\nqInteger :: Integer -> QuoteFn\nqInteger = quotedWithLoc . Atom . AInteger . mkIntegralLit\n{-# INLINABLE qInteger #-}\n\n-- | Make quoted fractional from 'Real' value.\nqFractional :: (Real a, Show a) => a -> QuoteFn\nqFractional = quotedWithLoc . Atom . aFractional\n{-# INLINABLE qFractional #-}\n\n-- | Make quoted unit.\nqUnit :: QuoteFn\nqUnit = quotedWithLoc (Atom AUnit)\n{-# INLINABLE qUnit #-}\n\n-- | Make quoted list from list of 'Code'.\nqList :: [Code] -> QuoteFn\nqList = quotedWithLoc . List\n{-# INLINABLE qList #-}\n\n-- | Make quoted haskell list from list of 'Code'.\nqHsList :: [Code] -> QuoteFn\nqHsList = quotedWithLoc . HsList\n{-# INLINABLE qHsList #-}\n\n-- -- | Make quoted symbol from 'String'.\n-- | Auxiliary function to construct 'ASymbol' atom.\naSymbol :: String -> Atom\naSymbol = ASymbol . fsLit\n{-# INLINABLE aSymbol #-}\n\n-- | Auxiliary function to construct 'AString' atom.\naString :: SourceText -> String -> Atom\naString st = AString st . fsLit\n{-# INLINABLE aString #-}\n\n-- | Auxiliary function to construct an 'Atom' containing\n-- 'FractionalLit' value from literal fractional numbers.\naFractional :: (Real a, Show a) => a -> Atom\naFractional x = AFractional $! mkFractionalLit' x\n{-# SPECIALIZE aFractional :: Double -> Atom #-}\n{-# SPECIALIZE aFractional :: Float -> Atom #-}\n\n-- | Type fixed variant of 'aFractional'.\naDouble :: Double -> Atom\naDouble = aFractional\n{-# INLINABLE aDouble #-}\n\naIntegral :: Integral a => a -> Atom\naIntegral x = AInteger $! mkIntegralLit x\n{-# SPECIALIZE aIntegral :: Integer -> Atom #-}\n{-# SPECIALIZE aIntegral :: Int -> Atom #-}\n\n-- | A form with empty 'List'.\nnil :: Code\nnil = LForm (genSrc (List []))\n{-# INLINABLE nil #-}\n\nquotedWithLoc :: Form Atom -> QuoteFn\nquotedWithLoc x file start_line start_col end_line end_col =\n let file_fs = fsLit file\n span_start = mkSrcLoc file_fs start_line start_col\n span_end = mkSrcLoc file_fs end_line end_col\n l = mkSrcSpan span_start span_end\n in LForm (L l x)\n{-# INLINABLE quotedWithLoc #-}\n\n-- From ghc 9.0.1, a new field with 'Maybe Int' was added to RealSrcSpan\n-- constructor of SrcLoc data type.\n\n#if __GLASGOW_HASKELL__ >= 900\n#define _MB_BUF_POS _\n#else\n#define _MB_BUF_POS {- empty -}\n#endif\n\n-- | Apply given functions to file name, start line, start column, end line, and\n-- end column.\nwithLocInfo ::\n SrcSpan -- ^ Source code span to get location info.\n -> (FastString -> a) -- ^ Function applied to file name.\n -> (Int -> b) -- ^ Function applied to lines and columns.\n -> (a, b, b, b, b)\nwithLocInfo l f_file f_n =\n let file = f_file (fromMaybe (fsLit \"\") (srcSpanFileName_maybe l))\n sl = get_n srcSpanStartLine\n sc = get_n srcSpanStartCol\n el = get_n srcSpanEndLine\n ec = get_n srcSpanEndCol\n get_n getter = case l of\n RealSrcSpan rspan _MB_BUF_POS -> f_n $! getter rspan\n _ -> f_n 0\n in (file, sl, sc, el, ec)\n{-# INLINABLE withLocInfo #-}\n\n-- | Return the first arg, with location information from the second arg.\nasLocOf :: Code -> Code -> Code\nasLocOf (LForm (L _ a)) (LForm (L l _)) = LForm (L l a)\n{-# INLINABLE asLocOf #-}\n\n\n-- -------------------------------------------------------------------\n--\n-- Auxiliary\n--\n-- -------------------------------------------------------------------\n\nfinkelUnhelpfulSpan :: SrcSpan\n#if MIN_VERSION_ghc(9,0,0)\nfinkelUnhelpfulSpan =\n UnhelpfulSpan (UnhelpfulOther (fsLit \"\"))\n#else\nfinkelUnhelpfulSpan =\n UnhelpfulSpan (fsLit \"\")\n#endif\n{-# INLINABLE finkelUnhelpfulSpan #-}\n\n-- | String representation of located data.\nshowLoc :: LForm a -> String\nshowLoc (LForm (L l _)) =\n case l of\n RealSrcSpan r _MB_BUF_POS ->\n unpackFS (srcSpanFile r) ++ \":\" ++\n show (srcSpanStartLine r) ++ \":\" ++\n show (srcSpanStartCol r) ++ \": \"\n#if MIN_VERSION_ghc(9,0,0)\n UnhelpfulSpan uh -> unpackFS (unhelpfulSpanFS uh) ++ \": \"\n#else\n UnhelpfulSpan fs -> unpackFS fs ++ \": \"\n#endif\n{-# INLINABLE showLoc #-}\n\n-- | Make 'List' from given code. When the given argument was already a 'List',\n-- the given 'List' is returned. If the argument was 'HsList', converted to\n-- 'List'. Otherwise, 'List' with single element.\ntoListL :: Code -> Code\ntoListL orig@(LForm (L l form)) =\n case form of\n List _ -> orig\n HsList xs -> LForm (L l (List xs))\n _ -> LForm (L l (List [orig]))\n{-# INLINABLE toListL #-}\n\n-- | Unwrap 'LForm' to 'Form'.\nunCode :: LForm a -> Form a\nunCode (LForm (L _ a)) = a\n{-# INLINABLE unCode #-}\n\n-- | Attach location to mark generated code.\ngenSrc :: a -> Located a\ngenSrc = L finkelUnhelpfulSpan\n{-# INLINABLE genSrc #-}\n\n-- | Make located list from list of located elements.\n--\n-- When the argument is not null, the resulting list has a combined location of\n-- locations in the argument list elements.\nmkLocatedForm :: [LForm a] -> Located [LForm a]\nmkLocatedForm [] = genSrc []\nmkLocatedForm ms@(hd:_) = L (combineLocs (unLForm hd) (unLForm (last ms))) ms\n{-# INLINABLE mkLocatedForm #-}\n\n-- | Lift given argument to 'LForm'.\natomForm :: a -> LForm a\natomForm = LForm . genSrc . Atom\n{-# INLINABLE atomForm #-}\n\n-- | Apply function taking single 'Form' to 'LForm'.\nliftLF :: (Form a -> Form b) -> LForm a -> LForm b\nliftLF f (LForm (L l a)) = LForm (L l (f a))\n{-# INLINABLE liftLF #-}\n\n-- | Apply function taking two 'Form's to 'LForm's.\nliftLF2 :: (Form a -> Form b -> Form c) -> LForm a -> LForm b -> LForm c\nliftLF2 f (LForm (L l1 a)) (LForm (L _l2 b)) = LForm (L l1 (f a b))\n{-# INLINABLE liftLF2 #-}\n\n-- | Apply functoni in 'LForm' to 'Form'.\napLF :: LForm (a -> b) -> Form a -> LForm b\napLF (LForm (L l f)) b = LForm (L l (f <*> b))\n{-# INLINABLE apLF #-}\n\n-- | Unary numeric operation helper.\nnop1 :: (a -> Atom)\n -> (Integer -> a)\n -> (Rational -> Rational)\n -> Form Atom -> Form Atom\nnop1 c f _ (Atom (AInteger il)) = Atom (c (f (il_value il)))\nnop1 _ _ f (Atom (AFractional fl)) = Atom (aFractional (f (fl_value fl)))\nnop1 _ _ _ _ = List []\n{-# INLINABLE nop1 #-}\n\n-- | Binary numeric operation helper.\nnop2 :: (a -> Atom)\n -> (Integer -> Integer -> a)\n -> (Rational -> Rational -> Rational)\n -> Form Atom -> Form Atom -> Form Atom\nnop2 c f _ (Atom (AInteger il1)) (Atom (AInteger il2)) =\n Atom (c (on f il_value il1 il2))\nnop2 _ _ f (Atom (AFractional fl1)) (Atom (AInteger il2)) =\n Atom (aFractional (f (fl_value fl1) (fromIntegral (il_value il2))))\nnop2 _ _ f (Atom (AInteger il1)) (Atom (AFractional fl2)) =\n Atom (aFractional (f (fromIntegral (il_value il1)) (fl_value fl2)))\nnop2 _ _ f (Atom (AFractional fl1)) (Atom (AFractional fl2)) =\n Atom (aFractional (on f fl_value fl1 fl2))\nnop2 _ _ _ _ _ = List []\n{-# INLINABLE nop2 #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Homoiconic.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE DefaultSignatures #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RankNTypes #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TypeOperators #-}\n-- | Module containing 'Homoiconic' and 'FromCode' type classes and its instance\n-- declarations.\nmodule Language.Finkel.Homoiconic\n ( -- * Homoiconic class\n Homoiconic(..)\n , fromCode\n , Result(..)\n\n -- * Generic functions\n , genericToCode\n , genericFromCode\n , genericParseCode\n\n -- * Generic classes\n , GToCode(..)\n , GParseCode(..)\n\n -- * Data.Data function\n , dataToCode\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Applicative (Alternative (..))\nimport Data.Complex (Complex (..))\nimport Data.Data\nimport Data.Fixed (Fixed (..))\nimport Data.Functor.Compose (Compose (..))\nimport Data.Functor.Const (Const (..))\nimport Data.Functor.Identity (Identity (..))\nimport Data.Int (Int16, Int32, Int64, Int8)\nimport Data.List.NonEmpty (NonEmpty (..))\nimport Data.Monoid (All (..), Alt (..), Any (..), Dual (..),\n First (..), Last (..), Product (..),\n Sum (..))\nimport Data.Ratio (Ratio, denominator, numerator, (%))\nimport Data.Version (Version (..))\nimport Data.Word (Word16, Word32, Word64, Word8)\nimport GHC.Generics (C, Constructor (..), D, Generic (..),\n K1 (..), M1 (..), S, U1 (..), V1,\n (:*:) (..), (:+:) (..))\nimport Numeric.Natural (Natural)\n\nimport qualified Data.Functor.Product as Product\nimport qualified Data.Functor.Sum as Sum\nimport qualified Data.Semigroup as Semigroup\n\n-- ghc\nimport GHC_Data_FastString (FastString, unpackFS)\nimport GHC_Types_SrcLoc (GenLocated (..), SrcSpan, getLoc)\n\n-- Internal\nimport Language.Finkel.Form\n\n\n-- -------------------------------------------------------------------\n--\n-- Homoiconic type class\n--\n-- -------------------------------------------------------------------\n\n-- | Class for handling Haskell value as 'Code'.\n--\n-- Instance of 'Homoiconic' should satisfy the law:\n--\n-- @\n-- 'parseCode' ('toCode' x) ≡ 'Success' x\n-- @\n--\n-- The function 'listToCode' and 'parseHsListCode' are used when handling\n-- Haskell list values specially (e.g., 'Char'). These functions have default\n-- implementations, which simply applies 'toCode' to elements of the argument\n-- list, and which parses elements of 'HsList', respectively.\n--\n-- One can implement 'Homoiconic' instance with 'GHC.Generics.Generic', e.g.:\n--\n-- @\n-- {-# LANGUAGE DeriveGeneric #-}\n--\n-- data MyData\n-- = MyInt Int\n-- | MyChar Char\n-- deriving (Generic)\n--\n-- instance Homoiconic MyData\n-- @\n--\n-- Sample snippet using above @MyData@:\n--\n-- >>> toCode (MyInt 42)\n-- (MyInt 42)\n-- >>> fromCode (toCode (MyChar 'a')) :: Maybe MyData\n-- Just (MyChar 'a')\n---\nclass Homoiconic a where\n -- | Convert Haskell value to 'Code'.\n toCode :: a -> Code\n {-# INLINE toCode #-}\n\n default toCode :: (Generic a, GToCode (Rep a)) => a -> Code\n toCode = genericToCode\n\n -- | Convert list of Haskell values to 'Code'.\n listToCode :: [a] -> Code\n listToCode xs =\n let xs' = map toCode xs\n l = getLoc (mkLocatedForm xs')\n in LForm (L l (HsList xs'))\n {-# INLINE listToCode #-}\n\n -- | Convert 'Code' to Haskell value, or 'Failure' if the code could\n -- not be converted.\n parseCode :: Code -> Result a\n {-# INLINE parseCode #-}\n\n default parseCode :: (Generic a, GParseCode (Rep a)) => Code -> Result a\n parseCode = genericParseCode\n\n -- | Convert 'Code' to list of Haskell values, or 'Failure' if the code\n -- could not be converted.\n parseHsListCode :: Code -> Result [a]\n parseHsListCode xs =\n case unCode xs of\n HsList as -> mapM parseCode as\n _ -> fail \"got non HsList value\"\n {-# INLINE parseHsListCode #-}\n\n-- | Like 'parseCode', but the result wrapped with 'Maybe' instead of 'Result'.\nfromCode :: Homoiconic a => Code -> Maybe a\nfromCode code = case parseCode code of\n Success a -> Just a\n _ -> Nothing\n\n\n-- -------------------------------------------------------------------\n--\n-- Instances of Homoiconic\n--\n-- -------------------------------------------------------------------\n\n--\n-- Prelude\n--\n\ninstance Homoiconic () where\n toCode _ = LForm (genSrc (Atom AUnit))\n parseCode a =\n case unCode a of\n Atom AUnit -> pure ()\n _ -> failedToParse \"()\"\n\ninstance Homoiconic Char where\n toCode = LForm . genSrc . Atom . AChar NoSourceText\n listToCode = LForm . genSrc . Atom . aString NoSourceText\n parseCode a =\n case unCode a of\n Atom (AChar _ x) -> pure x\n _ -> failedToParse \"Char\"\n parseHsListCode a = case unCode a of\n Atom (AString _ s) -> pure (unpackFS s)\n _ -> failedToParse \"String\"\n\ninstance Homoiconic Int where\n toCode = integralToCode\n parseCode = integralFromCode\n\ninstance Homoiconic Word where\n toCode = integralToCode\n parseCode = integralFromCode\n\ninstance Homoiconic Integer where\n toCode = integralToCode\n parseCode = integralFromCode\n\ninstance Homoiconic Float where\n toCode = realFracToCode\n parseCode = fractionalFromCode\n\ninstance Homoiconic Double where\n toCode = realFracToCode\n parseCode = fractionalFromCode\n\ninstance Homoiconic a => Homoiconic [a] where\n toCode = listToCode\n parseCode = parseHsListCode\n\ninstance Homoiconic Bool where\n toCode = showAsSymbolCode\n parseCode a =\n case unCode a of\n Atom (ASymbol sym) | sym == \"True\" -> pure True\n | sym == \"False\" -> pure False\n _ -> failedToParse \"Bool\"\n\ninstance Homoiconic Ordering where\n toCode = showAsSymbolCode\n parseCode a =\n case unCode a of\n Atom (ASymbol sym) | sym == \"EQ\" -> pure EQ\n | sym == \"LT\" -> pure LT\n | sym == \"GT\" -> pure GT\n _ -> failedToParse \"Ordering\"\n\ninstance Homoiconic a => Homoiconic (Maybe a) where\n toCode a =\n case a of\n Nothing -> toCode (aSymbol \"Nothing\")\n Just x -> toCode1 \"Just\" x\n parseCode a =\n case unCode a of\n Atom (ASymbol \"Nothing\") -> pure Nothing\n List [LForm (L _ (Atom (ASymbol \"Just\"))), x] -> pure <$> parseCode x\n _ -> failedToParse \"Maybe\"\n\ninstance (Homoiconic a, Homoiconic b) => Homoiconic (Either a b) where\n toCode a =\n case a of\n Right x -> toCode1 \"Right\" x\n Left x -> toCode1 \"Left\" x\n parseCode a =\n case unCode a of\n List [LForm (L _ (Atom (ASymbol x))), y]\n | x == \"Right\" -> fmap Right (parseCode y)\n | x == \"Left\" -> fmap Left (parseCode y)\n _ -> failedToParse \"Either\"\n\ninstance (Homoiconic a, Homoiconic b) => Homoiconic (a, b) where\n toCode (a1, a2) = toCode2 \",\" a1 a2\n parseCode = parseCode2 \",\" (,)\n\ninstance (Homoiconic a, Homoiconic b, Homoiconic c)\n => Homoiconic (a, b, c) where\n toCode (a1, a2, a3) =\n toCode (List [symbolCode \",\", toCode a1, toCode a2, toCode a3])\n parseCode a =\n case unCode a of\n List [LForm (L _ (Atom (ASymbol \",\"))), a1, a2, a3]\n -> (,,) <$> parseCode a1 <*> parseCode a2 <*> parseCode a3\n _ -> failedToParse \"(,,)\"\n\ninstance (Homoiconic a, Homoiconic b, Homoiconic c, Homoiconic d)\n => Homoiconic (a, b, c, d) where\n toCode (a1, a2, a3, a4) =\n toCode (List [ symbolCode \",\", toCode a1, toCode a2, toCode a3\n , toCode a4])\n parseCode a =\n case unCode a of\n List [LForm (L _ (Atom (ASymbol \",\"))), a1, a2, a3, a4]\n -> (,,,) <$>\n parseCode a1 <*> parseCode a2 <*> parseCode a3 <*> parseCode a4\n _ -> failedToParse \"(,,,)\"\n\ninstance (Homoiconic a, Homoiconic b, Homoiconic c, Homoiconic d, Homoiconic e)\n => Homoiconic (a, b, c, d, e) where\n toCode (a1, a2, a3, a4, a5) =\n toCode (List [ symbolCode \",\", toCode a1, toCode a2, toCode a3\n , toCode a4, toCode a5])\n parseCode a =\n case unCode a of\n List [LForm (L _ (Atom (ASymbol \",\"))), a1, a2, a3, a4, a5]\n -> (,,,,) <$>\n parseCode a1 <*> parseCode a2 <*> parseCode a3 <*>\n parseCode a4 <*> parseCode a5\n _ -> failedToParse \"(,,,,)\"\n\ninstance (Homoiconic a, Homoiconic b, Homoiconic c, Homoiconic d, Homoiconic e, Homoiconic f)\n => Homoiconic (a, b, c, d, e, f) where\n toCode (a1, a2, a3, a4, a5, a6) =\n toCode (List [ symbolCode \",\", toCode a1, toCode a2, toCode a3\n , toCode a4, toCode a5, toCode a6])\n parseCode a =\n case unCode a of\n List [LForm (L _ (Atom (ASymbol \",\"))), a1, a2, a3, a4, a5, a6]\n -> (,,,,,) <$>\n parseCode a1 <*> parseCode a2 <*> parseCode a3 <*>\n parseCode a4 <*> parseCode a5 <*> parseCode a6\n _ -> failedToParse \"(,,,,,)\"\n\n\n--\n-- Data.Complex\n--\n\ninstance Homoiconic a => Homoiconic (Complex a) where\n toCode (a :+ b) = toCode2 \":+\" a b\n parseCode = parseCode2 \":+\" (:+)\n\n--\n-- Data.Fixed\n--\n\ninstance Homoiconic (Fixed a) where\n toCode (MkFixed a) = toCode1 \"MkFixed\" a\n parseCode = parseCode1 \"MkFixed\" MkFixed\n\n--\n-- Data.Functor.Compose\n\ninstance Homoiconic (f (g a)) => Homoiconic (Compose f g a) where\n toCode (Compose a) = toCode1 \"Compose\" a\n parseCode = parseCode1 \"Compose\" Compose\n\n--\n-- Data.Functor.Const\n--\n\ninstance Homoiconic a => Homoiconic (Const a b) where\n toCode (Const a) = toCode1 \"Const\" a\n parseCode = parseCode1 \"Const\" Const\n\n--\n-- Data.Functor.Identity\n--\n\ninstance Homoiconic a=> Homoiconic (Identity a) where\n toCode (Identity a) = toCode1 \"Identity\" a\n parseCode = parseCode1 \"Identity\" Identity\n\n--\n-- Data.Functor.Product\n--\n\ninstance (Homoiconic (f a), Homoiconic (g a))\n => Homoiconic (Product.Product f g a) where\n toCode (Product.Pair a b) = toCode2 \"Pair\" a b\n parseCode = parseCode2 \"Pair\" Product.Pair\n\n--\n-- Data.Functor.Sum\n--\n\ninstance (Homoiconic (f a), Homoiconic (g a)) => Homoiconic (Sum.Sum f g a) where\n toCode a =\n case a of\n Sum.InL x -> toCode1 \"InL\" x\n Sum.InR x -> toCode1 \"InR\" x\n parseCode a =\n case unCode a of\n List [LForm (L _ (Atom (ASymbol tag))), b]\n | tag == \"InL\" -> Sum.InL <$> parseCode b\n | tag == \"InR\" -> Sum.InR <$> parseCode b\n _ -> failedToParse \"Sum\"\n\n--\n-- Data.Int\n--\n\ninstance Homoiconic Int8 where\n toCode = integralToCode\n parseCode = integralFromCode\n\ninstance Homoiconic Int16 where\n toCode = integralToCode\n parseCode = integralFromCode\n\ninstance Homoiconic Int32 where\n toCode = integralToCode\n parseCode = integralFromCode\n\ninstance Homoiconic Int64 where\n toCode = integralToCode\n parseCode = integralFromCode\n\n--\n-- Data.List.NonEmpty\n--\n\ninstance Homoiconic a => Homoiconic (NonEmpty a) where\n toCode (a :| as) = toCode2 \":|\" a as\n parseCode = parseCode2 \":|\" (:|)\n\n--\n-- Data.Monoid\n--\n\ninstance Homoiconic All where\n toCode (All a) = toCode1 \"All\" a\n parseCode = parseCode1 \"All\" All\n\ninstance Homoiconic (f a) => Homoiconic (Alt f a) where\n toCode (Alt a) = toCode1 \"Alt\" a\n parseCode = parseCode1 \"Alt\" Alt\n\ninstance Homoiconic Any where\n toCode (Any a) = toCode1 \"Any\" a\n parseCode = parseCode1 \"Any\" Any\n\ninstance Homoiconic a => Homoiconic (Dual a) where\n toCode (Dual a) = toCode1 \"Dual\" a\n parseCode = parseCode1 \"Dual\" Dual\n\ninstance Homoiconic a => Homoiconic (First a) where\n toCode (First a) = toCode1 \"First\" a\n parseCode = parseCode1 \"First\" First\n\ninstance Homoiconic a => Homoiconic (Last a) where\n toCode (Last a) = toCode1 \"Last\" a\n parseCode = parseCode1 \"Last\" Last\n\ninstance Homoiconic a => Homoiconic (Product a) where\n toCode (Product a) = toCode1 \"Product\" a\n parseCode = parseCode1 \"Product\" Product\n\ninstance Homoiconic a => Homoiconic (Sum a) where\n toCode (Sum a) = toCode1 \"Sum\" a\n parseCode = parseCode1 \"Sum\" Sum\n\n--\n-- Data.Proxy\n--\n\ninstance Homoiconic a => Homoiconic (Proxy a) where\n toCode _ = symbolCode \"Proxy\"\n parseCode a = case unCode a of\n Atom (ASymbol \"Proxy\") -> pure Proxy\n _ -> failedToParse \"Proxy\"\n\n--\n-- Data.Version\n--\n\ninstance Homoiconic Version where\n toCode (Version b t) = toCode2 \"Version\" b t\n parseCode = parseCode2 \"Version\" Version\n\n--\n-- Data.Ratio\n--\n\ninstance (Integral a, Homoiconic a) => Homoiconic (Ratio a) where\n toCode a =\n let n = toCode (numerator a)\n d = toCode (denominator a)\n in toCode (List [symbolCode \":%\", n, d])\n parseCode = parseCode2 \":%\" (%)\n\n\n--\n-- Data.Semigroup\n--\n\ninstance (Homoiconic a, Homoiconic b) => Homoiconic (Semigroup.Arg a b) where\n toCode (Semigroup.Arg a b) = toCode2 \"Arg\" a b\n parseCode = parseCode2 \"Arg\" Semigroup.Arg\n\ninstance Homoiconic a => Homoiconic (Semigroup.First a) where\n toCode (Semigroup.First a) = toCode1 \"First\" a\n parseCode = parseCode1 \"First\" Semigroup.First\n\ninstance Homoiconic a => Homoiconic (Semigroup.Last a) where\n toCode (Semigroup.Last a) = toCode1 \"Last\" a\n parseCode = parseCode1 \"Last\" Semigroup.Last\n\ninstance Homoiconic a => Homoiconic (Semigroup.Max a) where\n toCode (Semigroup.Max a) = toCode1 \"Max\" a\n parseCode = parseCode1 \"Max\" Semigroup.Max\n\ninstance Homoiconic a => Homoiconic (Semigroup.Min a) where\n toCode (Semigroup.Min a) = toCode1 \"Min\" a\n parseCode = parseCode1 \"Min\" Semigroup.Min\n\n#if !MIN_VERSION_ghc(9,0,0)\ninstance Homoiconic a => Homoiconic (Semigroup.Option a) where\n toCode (Semigroup.Option a) = toCode1 \"Option\" a\n parseCode = parseCode1 \"Option\" Semigroup.Option\n#endif\n\ninstance Homoiconic a => Homoiconic (Semigroup.WrappedMonoid a) where\n toCode (Semigroup.WrapMonoid a) = toCode1 \"WrapMonoid\" a\n parseCode = parseCode1 \"WrapMonoid\" Semigroup.WrapMonoid\n\n--\n-- Data.Word\n--\n\ninstance Homoiconic Word8 where\n toCode = integralToCode\n parseCode = integralFromCode\n\ninstance Homoiconic Word16 where\n toCode = integralToCode\n parseCode = integralFromCode\n\ninstance Homoiconic Word32 where\n toCode = integralToCode\n parseCode = integralFromCode\n\ninstance Homoiconic Word64 where\n toCode = integralToCode\n parseCode = integralFromCode\n\n--\n-- Numeric.Natural\n--\n\ninstance Homoiconic Natural where\n toCode = integralToCode\n parseCode = integralFromCode\n\n--\n-- Language.Finkel.Form\n--\n\ninstance Homoiconic Atom where\n toCode = LForm . genSrc . Atom\n parseCode a =\n case unCode a of\n Atom x -> pure x\n _ -> failedToParse \"Atom\"\n\ninstance Homoiconic (Form Atom) where\n toCode = LForm . genSrc\n parseCode = pure . unCode\n\ninstance Homoiconic (LForm Atom) where\n toCode = id\n parseCode = pure\n\n\n-- -------------------------------------------------------------------\n--\n-- Generic toCode\n--\n-- -------------------------------------------------------------------\n\n-- | Generic variant of 'toCode'.\ngenericToCode :: (Generic a, GToCode (Rep a)) => a -> Code\ngenericToCode = unCodeArgs . gToCode . from\n{-# INLINABLE genericToCode #-}\n\n-- | To distinguish arguments of constructor from non-argument.\ndata CodeArgs\n = NonArg Code\n | Args [Code]\n\nunCodeArgs :: CodeArgs -> Code\nunCodeArgs ca = case ca of\n NonArg c -> c\n Args cs -> toCode (List cs)\n{-# INLINABLE unCodeArgs #-}\n\ninstance Semigroup.Semigroup CodeArgs where\n Args xs <> Args ys = Args (xs Semigroup.<> ys)\n Args xs <> NonArg y = Args (xs Semigroup.<> [y])\n NonArg x <> Args ys = Args (x : ys)\n NonArg x <> NonArg y = Args [x, y]\n {-# INLINE (<>) #-}\n\n-- | For making 'Code' with 'Generic' instances.\nclass GToCode f where\n gToCode :: f a -> CodeArgs\n\ninstance GToCode V1 where\n gToCode _ = NonArg undefined\n {-# INLINE gToCode #-}\n\ninstance GToCode U1 where\n gToCode U1 = NonArg nil\n {-# INLINE gToCode #-}\n\ninstance (GToCode f, GToCode g) => GToCode (f :+: g) where\n gToCode lr = case lr of\n L1 x -> gToCode x\n R1 x -> gToCode x\n {-# INLINE gToCode #-}\n\ninstance (GToCode f, GToCode g) => GToCode (f :*: g) where\n gToCode (f :*: g) = gToCode f Semigroup.<> gToCode g\n {-# INLINE gToCode #-}\n\ninstance Homoiconic c => GToCode (K1 i c) where\n gToCode (K1 x) = NonArg (toCode x)\n {-# INLINE gToCode #-}\n\ninstance GToCode f => GToCode (M1 D c f) where\n gToCode (M1 x) = gToCode x\n {-# INLINE gToCode #-}\n\ninstance (Constructor c, GToCode f) => GToCode (M1 C c f) where\n gToCode m1@(M1 x) =\n let constr = toCode (aSymbol (conName m1))\n in case gToCode x of\n NonArg c -> if null c\n then NonArg constr\n else NonArg (toCode (List [constr, c]))\n Args cs -> NonArg (toCode (List (constr : cs)))\n {-# INLINE gToCode #-}\n\ninstance GToCode f => GToCode (M1 S c f) where\n gToCode (M1 x) = gToCode x\n {-# INLINE gToCode #-}\n\n\n-- -------------------------------------------------------------------\n--\n-- Generic FromCode\n--\n-- -------------------------------------------------------------------\n\n-- | Generic variant of 'fromCode'.\ngenericFromCode :: (Generic a, GParseCode (Rep a)) => Code -> Maybe a\ngenericFromCode x = case genericParseCode x of\n Success a -> Just a\n _ -> Nothing\n{-# INLINABLE genericFromCode #-}\n\n-- | Generic function to get result value from 'Code'.\ngenericParseCode :: (Generic a, GParseCode (Rep a)) => Code -> Result a\ngenericParseCode =\n let f a xs = if null xs\n then pure (to a)\n else fail \"Unexpected leftover\"\n in runCodeP gParseCode fail f\n{-# INLINABLE genericParseCode #-}\n\n-- | For getting value from 'Code' with 'Generic' instances.\nclass GParseCode f where\n gParseCode :: CodeP (f a)\n\ninstance GParseCode V1 where\n gParseCode = pure undefined\n {-# INLINE gParseCode #-}\n\ninstance GParseCode U1 where\n gParseCode = pure U1\n {-# INLINE gParseCode #-}\n\ninstance (GParseCode f, GParseCode g) => GParseCode (f :+: g) where\n gParseCode = fmap L1 gParseCode <|> fmap R1 gParseCode\n {-# INLINE gParseCode #-}\n\ninstance (GParseCode f, GParseCode g) => GParseCode (f :*: g) where\n gParseCode = (:*:) <$> gParseCode <*> gParseCode\n {-# INLINE gParseCode #-}\n\ninstance Homoiconic c => GParseCode (K1 i c) where\n gParseCode =\n unconsP (\\l c cs ->\n case parseCode c of\n Success a -> contP (K1 a) (LForm (L l (List cs)))\n _ -> failP (\"Unexpected: \" ++ show c))\n {-# INLINE gParseCode #-}\n\ninstance GParseCode f => GParseCode (M1 D c f) where\n gParseCode = fmap M1 gParseCode\n {-# INLINE gParseCode #-}\n\ninstance {-# OVERLAPPABLE #-} Constructor c => GParseCode (M1 C c U1) where\n gParseCode =\n let c1 :: M1 C c U1 a\n c1 = undefined\n in eqP (toCode (aSymbol (conName c1))) *> fmap M1 gParseCode\n {-# INLINE gParseCode #-}\n\ninstance {-# OVERLAPPABLE #-} (Constructor c, GParseCode f)\n => GParseCode (M1 C c f) where\n gParseCode =\n let c1 :: M1 C c f a\n c1 = undefined\n in eqCarP (toCode (aSymbol (conName c1))) *> fmap M1 gParseCode\n {-# INLINE gParseCode #-}\n\ninstance GParseCode f => GParseCode (M1 S c f) where\n gParseCode = fmap M1 gParseCode\n {-# INLINE gParseCode #-}\n\n\n-- -------------------------------------------------------------------\n--\n-- Code parser for GParseCode\n--\n-- -------------------------------------------------------------------\n\n-- | Dedicated data type to hold parsed result of 'Code'.\n--\n-- Using dedicated data type when parsing 'Code' data type for 'parseCode'. This\n-- data type is intentionally not defined as an instance of 'Homoiconic', so\n-- that the user defined data types can tell the parse error from explicit\n-- failure constructor of the target type, e,g, 'Nothing' for 'Maybe', 'Left'\n-- for 'Either', ... etc.\ndata Result a\n = Success a\n | Failure String\n deriving (Eq, Show)\n\ninstance Functor Result where\n fmap f r = case r of\n Success a -> Success (f a)\n Failure e -> Failure e\n {-# INLINE fmap #-}\n\ninstance Applicative Result where\n pure = Success\n {-# INLINE pure #-}\n f <*> m = f >>= flip fmap m\n {-# INLINE (<*>) #-}\n\ninstance Monad Result where\n m >>= k = case m of\n Success a -> k a\n Failure e -> Failure e\n {-# INLINE (>>=) #-}\n\ninstance MonadFail Result where\n fail = Failure\n {-# INLINE fail #-}\n\nfailedToParse :: String -> Result a\nfailedToParse ty = Failure (\"Failed to parse \" ++ ty)\n{-# INLINABLE failedToParse #-}\n\n-- | Simple parser for 'Code'.\nnewtype CodeP a =\n CodeP {runCodeP :: forall r. (String -> r) -- On failure\n -> (a -> Code -> r) -- On success\n -> Code -- Input\n -> r}\n\ninstance Functor CodeP where\n fmap f p = CodeP (\\err go -> runCodeP p err (go . f))\n {-# INLINE fmap #-}\n\ninstance Applicative CodeP where\n pure a = CodeP (\\_ go -> go a)\n {-# INLINE pure #-}\n\n f <*> p = f >>= flip fmap p\n {-# INLINE (<*>) #-}\n\ninstance Monad CodeP where\n m >>= k = CodeP (\\err go -> runCodeP m err (\\a -> runCodeP (k a) err go))\n {-# INLINE (>>=) #-}\n\ninstance Alternative CodeP where\n empty = failP \"Alternative.empty\"\n {-# INLINE empty #-}\n\n p1 <|> p2 =\n CodeP (\\err go cs ->\n runCodeP p1 (\\_ -> runCodeP p2 err go cs) go cs)\n {-# INLINE (<|>) #-}\n\nfailP :: String -> CodeP a\nfailP msg = CodeP (\\err _ _ -> err msg)\n{-# INLINABLE failP #-}\n\ncontP :: a -> Code -> CodeP a\ncontP a cs = CodeP (\\_ go _ -> go a cs)\n{-# INLINEABLE contP #-}\n\nunconsP :: (SrcSpan -> Code -> [Code] -> CodeP a) -> CodeP a\nunconsP f =\n CodeP (\\err go cs ->\n case cs of\n LForm (L l (List (x : xs))) -> runCodeP (f l x xs) err go cs\n _ -> err \"Not a list\")\n{-# INLINEABLE unconsP #-}\n\neqP :: Code -> CodeP ()\neqP x =\n CodeP (\\err go cs ->\n if cs == x\n then go () nil\n else err (\"eqP: unexpected \" ++ show cs))\n{-# INLINABLE eqP #-}\n\neqCarP :: Code -> CodeP ()\neqCarP x =\n unconsP (\\l c cs ->\n if x == c\n then contP () (LForm (L l (List cs)))\n else failP (\"eqCarP: unexpected \" ++ show c))\n{-# INLINABLE eqCarP #-}\n\n\n-- -------------------------------------------------------------------\n--\n-- Data to Code\n--\n-- -------------------------------------------------------------------\n\ndataToCode :: Data d => d -> Code\ndataToCode x =\n let constr = toConstr x\n isTupleStr cs = case cs of\n '(':cs1 -> go cs1\n _ -> False\n where go xs = case xs of\n ',':xs' -> go xs'\n [')'] -> True\n _ -> False\n cstr = case showConstr constr of\n str | isTupleStr str -> \",\"\n | otherwise -> str\n hd = toCode (aSymbol cstr)\n in case constrRep constr of\n IntConstr n -> toCode (aIntegral n)\n FloatConstr f -> toCode (aFractional (fromRational f :: Double))\n CharConstr c -> toCode c\n _ ->\n case gmapQ dataToCode x of\n [] -> hd\n _ -> toCode (List (hd:gmapQ dataToCode x))\n\n\n-- -------------------------------------------------------------------\n--\n-- Auxiliary\n--\n-- -------------------------------------------------------------------\n\nrealFracToCode :: (Real a, Show a) => a -> Code\nrealFracToCode = LForm . genSrc . Atom . aFractional\n{-# INLINABLE realFracToCode #-}\n\nfractionalFromCode :: Fractional a => Code -> Result a\nfractionalFromCode a =\n case unCode a of\n Atom (AFractional x) -> pure (fromRational (fl_value x))\n _ -> failedToParse \"fractional\"\n{-# INLINABLE fractionalFromCode #-}\n\nsymbolCode :: String -> Code\nsymbolCode = LForm . genSrc . Atom . aSymbol\n{-# INLINABLE symbolCode #-}\n\nshowAsSymbolCode :: Show a => a -> Code\nshowAsSymbolCode = symbolCode . show\n{-# INLINABLE showAsSymbolCode #-}\n\nintegralToCode :: Integral a => a -> Code\nintegralToCode = LForm . genSrc . Atom . aIntegral\n{-# INLINABLE integralToCode #-}\n\nintegralFromCode :: Integral a => Code -> Result a\nintegralFromCode a =\n case unCode a of\n Atom (AInteger n) -> pure (fromIntegral (il_value n))\n _ -> failedToParse \"integral\"\n\ntoCode1 :: Homoiconic a => FastString -> a -> Code\ntoCode1 tag arg1 =\n toCode (List [LForm (genSrc (Atom (ASymbol tag))), toCode arg1])\n{-# INLINABLE toCode1 #-}\n\ntoCode2 :: (Homoiconic a, Homoiconic b) => FastString -> a -> b -> Code\ntoCode2 tag arg1 arg2 =\n toCode (List [ LForm (genSrc (Atom (ASymbol tag)))\n , toCode arg1, toCode arg2 ])\n{-# INLINABLE toCode2 #-}\n\nparseCode1 :: (Homoiconic a) => FastString -> (a -> h) -> Code -> Result h\nparseCode1 tag f a =\n case unCode a of\n List [LForm (L _ (Atom (ASymbol tag'))), x]\n | tag == tag' -> f <$> parseCode x\n _ -> failedToParse (unpackFS tag)\n{-# INLINABLE parseCode1 #-}\n\nparseCode2 :: (Homoiconic a, Homoiconic b)\n => FastString -> (a -> b -> h) -> Code -> Result h\nparseCode2 tag f a =\n case unCode a of\n List [LForm (L _ (Atom (ASymbol tag'))), x, y]\n | tag == tag' -> f <$> parseCode x <*> parseCode y\n _ -> failedToParse (unpackFS tag)\n{-# INLINABLE parseCode2 #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Hooks.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE GADTs #-}\n-- Hooks, in HscEnv\nmodule Language.Finkel.Hooks\n ( finkelHooks\n ) where\n\n#if MIN_VERSION_ghc(9,6,0)\n-- base\nimport Control.Exception (displayException)\nimport Control.Monad (when)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.Maybe (fromMaybe)\nimport System.Console.GetOpt (ArgOrder (..), getOpt)\nimport System.Exit (exitFailure, exitSuccess)\nimport System.IO (hPutStrLn, stderr)\n\n#if !MIN_VERSION_base(4,20,0)\nimport Data.List (foldl')\n#endif\n\n-- ghc\nimport GHC.Driver.Env (HscEnv (..), hscSetFlags, runHsc')\nimport GHC.Driver.Errors.Types (GhcMessage)\nimport GHC.Driver.Hooks (Hooks (..))\nimport GHC.Driver.Main (hscTypecheckAndGetWarnings,\n hscTypecheckRename)\nimport GHC.Driver.Phases (Phase (..))\nimport GHC.Driver.Pipeline.Execute (phaseOutputFilenameNew, runPhase)\nimport GHC.Driver.Pipeline.Phases (PhaseHook (..), TPhase (..))\nimport GHC.Driver.Session (GeneralFlag (..), gopt)\n\nimport GHC.Plugins (CommandLineOption)\n\nimport GHC.Types.SourceError (throwOneError)\nimport GHC.Types.SourceFile (HscSource (..))\nimport GHC.Types.SrcLoc (noLoc, noSrcSpan)\n\nimport GHC.Unit.Module.Location (ModLocation (..))\nimport GHC.Unit.Module.ModSummary (ModSummary (..))\n\nimport GHC.Utils.Error (Messages)\nimport GHC.Utils.Exception (ExceptionMonad)\nimport GHC.Utils.Misc (getModificationUTCTime,\n modificationTimeIfExists)\nimport GHC.Utils.Outputable (text)\n\nimport GHC.Runtime.Context (InteractiveContext (..))\nimport GHC.Tc.Types (FrontendResult (..))\n\n-- Internal\nimport Language.Finkel.Error (mkPlainWrappedMsg)\nimport Language.Finkel.Exception (finkelExceptionLoc,\n handleFinkelException)\nimport Language.Finkel.Fnk (FnkEnv (..), FnkInvokedMode (..),\n initFnkEnv, runFnk')\nimport Language.Finkel.Make (fnkSourceToSummary)\nimport Language.Finkel.Make.Session (bcoDynFlags)\nimport Language.Finkel.Make.Summary (TargetSummary (..))\nimport Language.Finkel.Make.TargetSource (TargetSource (..),\n findTargetSourceWithPragma)\nimport Language.Finkel.Options (FnkPluginOptions (..),\n defaultFnkPluginOptions,\n fnkPluginOptions, fpoPragma,\n printPluginUsage)\nimport Language.Finkel.Preprocess (PpOptions (..), mkPpOptions,\n preprocessOrCopy)\n\n-- | Add hooks for compiling Finkel source codes.\n--\n-- This function will constantly turn on the 'Opt_Pp' flag in the 'DynFlags' of\n-- given 'HscEnv' to always trigger the preprocess phase.\nfinkelHooks :: String -> FnkEnv -> [CommandLineOption] -> HscEnv -> IO HscEnv\n\n-- Actual implementation is for ghc >= 9.6, older versions are not supported.\nfinkelHooks mod_name fnk_env0 cmd_line_opts hsc_env0 = do\n -- Always setting the Opt_Pp flag on for dflags_from_ic1 and dflags1,\n -- otherwise the hook for T_HsPp will not run.\n let dflags_from_ic = bcoDynFlags (ic_dflags (hsc_IC hsc_env0))\n -- XXX: Update targets in expanding session?\n -- enable_pp_phase =\n -- setGeneralFlag' Opt_Pp .\n -- setGeneralFlag' Opt_UseBytecodeRatherThanObjects .\n -- setGeneralFlag' Opt_WriteIfSimplifiedCore .\n -- flip xopt_set TemplateHaskell\n\n -- XXX: File local plugin options are ignored.\n (os, _ls, errs) = getOpt Permute fnkPluginOptions cmd_line_opts\n fpo0 = foldl' (flip id) (defaultFnkPluginOptions fnk_env0) os\n fnk_env1 = fpoFnkEnv fpo0\n fnk_env2 = fnk_env1 { envDefaultDynFlags = Just dflags_from_ic\n , envInvokedMode = GhcPluginMode }\n\n fnk_env3 <- initFnkEnv fnk_env2\n\n let fpo1 = fpo0 {fpoFnkEnv = fnk_env3}\n phase_hook = PhaseHook (fnkPhaseHook fpo1)\n hooks = (hsc_hooks hsc_env0) {runPhaseHook = Just phase_hook}\n hsc_env1 = hsc_env0 {hsc_hooks = hooks}\n\n case errs of\n _ | fpoHelp fpo1 -> printPluginUsage mod_name >> exitSuccess\n _:_ -> mapM_ putStrLn errs >> exitFailure\n [] -> pure hsc_env1\n\n\n-- ------------------------------------------------------------------------\n--\n-- Internal\n--\n-- ------------------------------------------------------------------------\n\n-- | Hooks for compiling Finkel source codes.\n--\n-- The hook modifies 'T_HsPp' and 'T_Hsc' phases, other phases are delegated to\n-- 'runPhase'.\n--\n-- The 'T_HsPp' phase is to get preprocessed module header, which is\n-- used during module dependency resolution.\n--\n-- The 'T_Hsc' phase does the compilation of the body of the source code to get\n-- 'FrontendResult'.\nfnkPhaseHook :: FnkPluginOptions -> TPhase a -> IO a\nfnkPhaseHook fpo phase = do\n logStrLn fpo (\"fnkPhaseHook: running \" <> showTPhase phase)\n case phase of\n T_HsPp pipe_env hsc_env fp hsc_src -> do\n let next = HsPp HsSrcFile\n out_path <- phaseOutputFilenameNew next pipe_env hsc_env Nothing\n runFnkPpPhase fpo hsc_env fp hsc_src out_path\n T_Hsc hsc_env ms -> runFnkTcPhase fpo hsc_env ms\n _ -> runPhase phase\n\nshowTPhase :: TPhase a -> String\nshowTPhase phase = case phase of\n T_Unlit {} -> \"T_Unlit\"\n T_FileArgs _ path -> \"T_FileArgs: \" <> path\n T_Cpp {} -> \"T_Cpp\"\n T_HsPp _ _ o i -> \"T_HsPp: \" <> o <> \" \" <> i\n T_HscRecomp {} -> \"T_HscRecomp\"\n T_Hsc {} -> \"T_Hsc\"\n T_HscPostTc {} -> \"T_HscPostTc\"\n T_HscBackend {} -> \"T_HscBackend\"\n T_CmmCpp {} -> \"T_CmmCpp\"\n T_Cmm {} -> \"T_Cmm\"\n T_Cc {} -> \"T_Cc\"\n T_As {} -> \"T_As\"\n#if MIN_VERSION_ghc(9,6,0)\n T_Js {} -> \"T_Js\"\n T_ForeignJs {} -> \"T_ForeignJs\"\n#endif\n T_LlvmOpt {} -> \"T_LlvmOpt\"\n T_LlvmLlc {} -> \"T_LlvmLlc\"\n T_LlvmMangle {} -> \"T_LlvmMangle\"\n#if MIN_VERSION_ghc(9,10,0)\n T_LlvmAs {} -> \"T_LlvmAs\"\n#endif\n T_MergeForeign {} -> \"T_MergeForeign\"\n\nrunFnkPpPhase\n :: FnkPluginOptions -> HscEnv -> FilePath -> FilePath -> FilePath\n -> IO FilePath\nrunFnkPpPhase fpo hsc_env _orig_fn input_fn output_fn = do\n -- Not parsing command line argument in preprocess phase, the arguments are\n -- shared with fnkPluginOptions.\n let fnk_env = fpoFnkEnv fpo\n ppo0 = mkPpOptions \"runFnkPpPhase\" fnk_env\n ppo1 = ppo0 { ppoWarnInterp = False\n , ppoFnkSrcOptions = fpoSrcOptions fpo\n , ppoVerbosity = envVerbosity fnk_env }\n\n -- XXX: Not checking the dependency files (the 'mi_usages' field) stored in\n -- interface, will not preprocess this module when the macros in required\n -- modules were changed ... is it fine?\n input_mtime <- getModificationUTCTime input_fn\n mb_output_mtime <- modificationTimeIfExists output_fn\n let can_reuse_output = maybe False (input_mtime <) mb_output_mtime\n no_force_recomp = not $ gopt Opt_ForceRecomp (hsc_dflags hsc_env)\n\n if no_force_recomp && can_reuse_output\n then logStrLn fpo (\"runFnkPpPhase: Reusing \" <> output_fn)\n else withFinkelExceptionHandler hsc_env $\n preprocessOrCopy (Just hsc_env) ppo1 input_fn (Just output_fn)\n\n pure output_fn\n\nrunFnkTcPhase :: FnkPluginOptions -> HscEnv -> ModSummary\n -> IO (FrontendResult, Messages GhcMessage)\nrunFnkTcPhase fpo hsc_env ms0 =\n case ml_hs_file (ms_location ms0) of\n Nothing -> error \"runFnkTcPhase: no hs file ...\"\n Just hs_file -> do\n let dflags = hsc_dflags hsc_env\n pragma = fpoPragma fpo\n fnk_env = fpoFnkEnv fpo\n ts <- findTargetSourceWithPragma pragma dflags (noLoc hs_file)\n case ts of\n FnkSource {} -> fnkTypecheckAndGetWarnings fnk_env hsc_env ts\n HsSource {} -> hscTypecheckAndGetWarnings hsc_env ms0\n _ -> error \"runFnkTcPhase: other source ...\"\n\n-- See: GHC.Driver.Main.hsc_typecheck, which is not exported.\nfnkTypecheckAndGetWarnings :: FnkEnv -> HscEnv -> TargetSource\n -> IO (FrontendResult, Messages GhcMessage)\nfnkTypecheckAndGetWarnings fnk_env hsc_env ts = runHsc' hsc_env $ do\n ems <- liftIO $ withFinkelExceptionHandler hsc_env $\n runFnk' (fnkSourceToSummary ts) fnk_env hsc_env\n case ems of\n -- XXX: Invoke hscFrontendHook as done in hscTypecheckAndGetWarings?\n EMS ms1 _ _ | Just pm <- ms_parsed_mod ms1 -> do\n let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms1) hsc_env\n (tc_gbl, _) <- liftIO $ hscTypecheckRename lcl_hsc_env ms1 pm\n pure $ FrontendTypecheck tc_gbl\n _ -> error \"runFnkTcPhase: no parsed mod ...\"\n\nlogStrLn :: FnkPluginOptions -> String -> IO ()\nlogStrLn fpo msg =\n when (1 < envVerbosity (fpoFnkEnv fpo)) $ hPutStrLn stderr msg\n\nwithFinkelExceptionHandler :: ExceptionMonad m => HscEnv -> m a -> m a\nwithFinkelExceptionHandler hsc_env = handleFinkelException handler\n where\n handler e =\n throwOneError (mkPlainWrappedMsg (hsc_dflags hsc_env) (mb_loc e)\n (text (displayException e)))\n mb_loc = fromMaybe noSrcSpan . finkelExceptionLoc\n\n#else /* ghc < 9.6.0 */\n-- Does nothing in ghc < 9.6.\nfinkelHooks :: str -> fnk_env -> opts -> hsc_env -> IO hsc_env\nfinkelHooks _name _fnk_env _cmd_line_opts = pure\n#endif\n" }, { "path": "finkel-kernel/src/Language/Finkel/Lexer.x", "content": "-- -*- mode: haskell; -*-\n{\n{-# OPTIONS_GHC -fno-warn-unused-imports #-}\n{-# OPTIONS_GHC -fno-warn-name-shadowing #-}\n{-# LANGUAGE CPP #-}\n{-# LANGUAGE UnboxedTuples #-}\n-- | Lexical analyser of S-expression tokens.\n--\n-- This file contains Alex lexical analyser for tokeninzing S-expression.\n-- Lexcial analyser is used by Happy parser in S-expression reader.\nmodule Language.Finkel.Lexer\n ( -- * Types\n Token(..)\n , LexicalError(..)\n\n -- * Lexer function\n , tokenLexer\n , lexTokens\n\n -- * S-expression parser monad\n , SP(..)\n , SPState(..)\n , initialSPState\n , runSP\n , evalSP\n -- , incrSP\n , errorSP\n , lexErrorSP\n , putSPState\n , getSPState\n , modifySPState\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Exception (Exception(..))\nimport Control.Monad (ap, liftM, msum)\nimport Data.Char (GeneralCategory(..), chr,\n generalCategory, ord,\n isDigit, isOctDigit,\n isHexDigit, isSpace,\n toUpper)\nimport Data.List (intercalate)\nimport Data.Maybe (fromMaybe)\nimport Data.Word (Word8)\nimport qualified GHC.Char as Char\n\n-- bytestring\nimport qualified Data.ByteString as W8\nimport qualified Data.ByteString.Char8 as C8\n\n-- ghc\nimport GHC_Data_FastString (FastString, bytesFS,\n fsLit, nullFS,\n mkFastStringByteString,\n unpackFS)\nimport GHC_Data_StringBuffer (StringBuffer, atEnd,\n byteDiff, cur, currentChar,\n lexemeToFastString,\n lexemeToString, nextChar,\n prevChar, stepOn)\nimport GHC_Parser_CharClass (is_space)\nimport GHC_Utils_Encoding (utf8DecodeByteString)\nimport GHC_Types_SrcLoc (GenLocated(..), Located,\n RealSrcLoc, SrcLoc(..),\n SrcSpan(..), advanceSrcLoc,\n mkRealSrcLoc, mkRealSrcSpan,\n srcLocCol, srcLocLine)\n\nimport GHC_Utils_Lexeme (startsConSym, startsVarId,\n startsVarSym)\nimport GHC_Utils_Misc (readRational)\n\n#if MIN_VERSION_ghc(9,4,0)\nimport qualified GHC.Data.Strict as Strict\n#endif\n\n-- ghc-boot\nimport qualified GHC.LanguageExtensions as LangExt\n\n-- Internal\nimport Language.Finkel.Data.FastString (unconsFS)\nimport Language.Finkel.Data.SourceText\nimport Language.Finkel.Data.Fractional\nimport Language.Finkel.Form\n}\n\n$nl = [\\n\\r\\f]\n$white = [$nl\\v\\t\\ ]\n$white_no_nl = $white # $nl\n\n$negative = \\-\n$octit = [0-7]\n$digit = [0-9]\n$hexit = [$digit A-F a-f]\n\n$hsymhead = [^\\(\\)\\[\\]\\{\\}\\;\\'\\`\\,\\\"\\#\\%$digit$white]\n$hsymtail = [$hsymhead\\'\\#\\%$digit]\n$hsymtail_no_qt = $hsymtail # \\'\n$hsymtail_no_ub = $hsymtail # \\_\n\n@signed = $negative?\n@octal = $octit+\n@decimal = $digit+\n@hexadecimal = $hexit+\n\n@exponent = [eE] [\\-\\+]? @decimal\n@frac = @decimal \\. @decimal @exponent?\n | @decimal @exponent\n\n@hsymbol = $hsymhead $hsymtail*\n | \\# $hsymtail_no_qt*\n\n@contdoc = $nl [\\t\\ ]* \\;+ ~$nl+\n\ntokens :-\n\n$white+ ;\n\n--- Comments\n\n\\;+ $white+ \\^ $white_no_nl+ ~$nl+ @contdoc* { tok_doc_prev }\n\\;+ $white+ \\| $white_no_nl+ ~$nl+ @contdoc* { tok_doc_next }\n\\;+ $white+ \\*+ $white_no_nl+ .* { tok_doc_group }\n\\;+ $white+ \\$ @hsymbol $white_no_nl* ~$nl* @contdoc* { tok_doc_named }\n\n\\; .* { tok_line_comment }\n\\{\\- .* { tok_block_comment }\n\n--- Discard prefix\n\\% \\_ { tok_discard }\n\n--- Pragma and symbols starting with '%'\n\\% $hsymtail_no_ub* { tok_percent }\n\n--- Parenthesized commas, handled before parentheses\n\\( $white* \\,+ $white* \\) { tok_pcommas }\n\n--- Parentheses\n\\( { tok_oparen }\n\\) { tok_cparen }\n\n\\[ { tok_obracket }\n\\] { tok_cbracket }\n\n\\{ { tok_ocurly }\n\\} { tok_ccurly }\n\n-- Quote, unquote, quasiquote, and unquote splice\n\\' { tok_quote }\n\\` { tok_quasiquote }\n\n\\,\\ { tok_comma }\n\n\\,\\@ { tok_unquote_splice }\n\\, { tok_unquote }\n\n-- Lambda\n\\\\ ~$white* { tok_lambda }\n\n--- Literal values\n\\\" { tok_string }\n\\#\\' { tok_char }\n@signed @decimal { tok_integer }\n@signed 0[oO] @octal { tok_integer }\n@signed 0[xX] @hexadecimal { tok_integer }\n@signed @frac { tok_fractional }\n\n-- Symbols\n@hsymbol { tok_symbol }\n\n{\n-- ---------------------------------------------------------------------\n--\n-- Parser monad\n--\n-- ---------------------------------------------------------------------\n\n-- | Data type to hold states while reading source code.\ndata SPState = SPState\n { -- | Target file for lexical analysis.\n targetFile :: FastString\n -- | @{-# LANGUAGE ... #-}@ found in target file.\n , langExts :: [Located String]\n -- | @{-# GHC_OPTIONS ... #-}@ found in target file.\n , ghcOptions :: [Located String]\n -- | @{-# OPTIONS_HADDOCK ... #-}@ found in target file.\n , haddockOptions :: [Located String]\n -- | Buffer to hold current input.\n , buf :: StringBuffer\n -- | Current location of input stream.\n , currentLoc :: RealSrcLoc\n }\n\n-- | Initial empty state for 'SP'.\ninitialSPState :: FastString -> Int -> Int -> SPState\ninitialSPState file linum colnum =\n SPState { targetFile = file\n , langExts = []\n , ghcOptions = []\n , haddockOptions = []\n , buf = error \"SPState.buf not initialized\"\n , currentLoc = mkRealSrcLoc file linum colnum\n }\n\ndata SPResult a\n = SPOK {-# UNPACK #-} !SPState a\n | SPNG SrcLoc Char String\n\n-- | A state monad newtype to pass around 'SPstate'.\nnewtype SP a = SP { unSP :: SPState -> SPResult a }\n\ninstance Functor SP where\n fmap = liftM\n {-# INLINE fmap #-}\n\ninstance Applicative SP where\n pure a = SP (\\st -> SPOK st a)\n {-# INLINE pure #-}\n (<*>) = ap\n {-# INLINE (<*>) #-}\n\ninstance Monad SP where\n m >>= k = SP (\\st -> case unSP m st of\n SPOK st' a -> unSP (k a) st'\n SPNG l c msg -> SPNG l c msg)\n {-# INLINE (>>=) #-}\n\ndata AlexInput = AlexInput RealSrcLoc StringBuffer\n\n-- | Lexical error with location and message.\ndata LexicalError = LexicalError SrcLoc Char String\n deriving (Eq, Show)\n\ninstance Exception LexicalError where\n displayException (LexicalError _ _ m) = m\n {-# INLINE displayException #-}\n\n-- | Perform given 'SP' computation with target file name and input contents.\nrunSP :: SP a -- ^ Computation to perform.\n -> Maybe FilePath -- ^ File name of target. If 'Nothing', assumed as\n -- anonymous target.\n -> StringBuffer -- ^ Input contents.\n -> Either LexicalError (a, SPState)\nrunSP sp target input =\n let st0 = initialSPState target' 1 1\n st1 = st0 {buf = input}\n target' = maybe (fsLit \"anon\") fsLit target\n in case unSP sp st1 of\n SPOK sp' a -> Right (a, sp')\n SPNG loc c msg -> Left (LexicalError loc c msg)\n\n-- | Like 'runSP', but discard resulting 'SPState'.\nevalSP :: SP a -> Maybe FilePath -> StringBuffer -> Either LexicalError a\nevalSP sp target input = fmap fst (runSP sp target input)\n\n-- | Update current 'SPState' to given value.\nputSPState :: SPState -> SP ()\nputSPState st = SP (\\_ -> SPOK st ())\n{-# INLINABLE putSPState #-}\n\n-- | Get current 'SPState' value.\ngetSPState :: SP SPState\ngetSPState = SP (\\st -> SPOK st st)\n{-# INLINABLE getSPState #-}\n\n-- | Modify current 'SPState' with given function.\nmodifySPState :: (SPState -> SPState) -> SP ()\nmodifySPState f = SP (\\st -> SPOK (f st) ())\n{-# INLINABLE modifySPState #-}\n\n-- | Get previous character in buffer from given 'SPState'.\nprevCharSP :: SPState -> Char\nprevCharSP st = prevChar (buf st) '\\n'\n{-# INLINABLE prevCharSP #-}\n\n-- -- | Incrementally perform computation with parsed result and given\n-- -- function.\n-- incrSP :: SP a -- ^ The partial parser.\n-- -> (a -> b -> b) -- ^ Function to apply.\n-- -> b -- ^ Initial argument to the function.\n-- -> Maybe FilePath -- ^ Filepath of the input.\n-- -> StringBuffer -- ^ Input contents.\n-- -> Either String (b, SPState)\n-- incrSP sp f z target input = go st1 z\n-- where\n-- go st acc =\n-- case unSP sp st of\n-- SPNG _loc msg\n-- | atEnd (buf st) -> Right (acc, st)\n-- | otherwise -> Left msg\n-- SPOK st' ret ->\n-- -- let st'' = st' {buf=C8.cons (prevChar st') (buf st')}\n-- let st'' = st' {} -- ... efficient way to cons prev char?\n-- in go st'' $! f ret acc\n-- st0 = initialSPState target' 1 1\n-- st1 = st0 {buf = input}\n-- target' = maybe (fsLit \"anon\") fsLit target\n\n-- | Show alex error with location of given 'Code' and error message.\nerrorSP :: Code -- ^ Code for showing location information.\n -> String -- ^ Error message to show.\n -> SP a\nerrorSP code msg = alexError (showLoc code ++ msg)\n\n-- | Show error message with current input.\nlexErrorSP :: SP a\nlexErrorSP = do\n st <- getSPState\n AlexInput loc buf <- alexGetInput\n let lno = srcLocLine loc\n cno = srcLocCol loc\n trg = unpackFS (targetFile st)\n c = prevChar buf '\\n'\n msg = trg ++ \": lexer error at line \" ++ show lno ++\n \", column \" ++ show cno ++\n \", near \" ++ show c\n alexError msg\n\nalexGetByte :: AlexInput -> Maybe (Word8, AlexInput)\nalexGetByte (AlexInput loc0 buf0) =\n if atEnd buf0\n then Nothing\n else case nextChar buf0 of\n (c, buf1) -> let w = adjustChar c\n loc1 = advanceSrcLoc loc0 c\n in w `seq` loc1 `seq` buf1 `seq`\n Just (w, AlexInput loc1 buf1)\n{-# INLINABLE alexGetByte #-}\n\nalexGetChar :: AlexInput -> Maybe (Char, AlexInput)\nalexGetChar (AlexInput loc0 buf0) =\n if atEnd buf0\n then Nothing\n else case nextChar buf0 of\n (c, buf1) -> let loc1 = advanceSrcLoc loc0 c\n in c `seq` loc1 `seq` buf1 `seq`\n Just (c, AlexInput loc1 buf1)\n{-# INLINABLE alexGetChar #-}\n\nalexInputPrevChar :: AlexInput -> Char\nalexInputPrevChar (AlexInput _ buf) = prevChar buf '\\NUL'\n{-# INLINABLE alexInputPrevChar #-}\n\nalexError :: String -> SP a\n#if MIN_VERSION_ghc(9,4,0)\nalexError msg =\n SP (\\st ->\n let rloc = RealSrcLoc (currentLoc st) Strict.Nothing\n in SPNG rloc (prevCharSP st) msg)\n#elif MIN_VERSION_ghc(9,0,0)\nalexError msg =\n SP (\\st -> SPNG (RealSrcLoc (currentLoc st) Nothing) (prevCharSP st) msg)\n#else\nalexError msg =\n SP (\\st -> SPNG (RealSrcLoc (currentLoc st)) (prevCharSP st) msg)\n#endif\n{-# INLINABLE alexError #-}\n\nalexGetInput :: SP AlexInput\nalexGetInput =\n SP (\\st@SPState {currentLoc=l,buf=b} -> SPOK st (AlexInput l b))\n{-# INLINABLE alexGetInput #-}\n\nalexSetInput :: AlexInput -> SP ()\nalexSetInput (AlexInput l b) =\n SP (\\st -> SPOK (st {buf=b,currentLoc=l}) ())\n{-# INLINABLE alexSetInput #-}\n\n\n-- ---------------------------------------------------------------------\n--\n-- Token data and actions\n--\n-- ---------------------------------------------------------------------\n\n-- | Data type for token.\ndata Token\n = TOparen\n -- ^ Open parenthesis.\n | TCparen\n -- ^ Close parenthesis.\n | TObracket\n -- ^ Open bracket.\n | TCbracket\n -- ^ Close bracket.\n | TOcurly\n -- ^ Open curly.\n | TCcurly\n -- ^ Close curly.\n | TQuote\n -- ^ Quote.\n | TQuasiquote\n -- ^ Quasi-quote.\n | TUnquote\n -- ^ Unquote.\n | TUnquoteSplice\n -- ^ Unquote-splice.\n | TComment\n -- ^ Comment.\n | TSymbol FastString\n -- ^ Symbol data.\n | TChar SourceText Char\n -- ^ Character data.\n | TString SourceText String\n -- ^ Literal string data.\n | TInteger SourceText Integer\n -- ^ Literal integer number.\n | TFractional FractionalLit\n -- ^ Literal fractional number.\n | TPercent Char\n -- ^ Special prefix @%@.\n | TPcommas Int\n -- ^ Parenthesized commas with number of repeats.\n | TDocNext FastString\n -- ^ Documentation comment for next thing.\n | TDocPrev FastString\n -- ^ Documentation comment for previous thing.\n | TDocGroup Int FastString\n -- ^ Documentation comment for section.\n | TDocNamed FastString (Maybe FastString)\n -- ^ Documentation comment for named documentation.\n | TEOF\n -- ^ End of form.\n deriving (Eq, Show)\n\ntype Action = AlexInput -> Int -> SP Token\n\n-- Tokenizer actions for documentation\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- Currently, documentation comment starting with `;'s are converted to 'Token'\n-- data during lexical analysis. Once the documentation string were converted to\n-- 'Token' data type, it cannot distinguish between block documentation comment\n-- and line documentation comment. From this reason, the documentation comments\n-- generated with \"Language.Finkel.Emit\" are always using single-line comment\n-- syntax.\n\ntok_oparen :: Action\ntok_oparen _ _ = return TOparen\n{-# INLINABLE tok_oparen #-}\n\ntok_cparen :: Action\ntok_cparen _ _ = return TCparen\n{-# INLINABLE tok_cparen #-}\n\ntok_obracket :: Action\ntok_obracket _ _ = return TObracket\n{-# INLINABLE tok_obracket #-}\n\ntok_cbracket :: Action\ntok_cbracket _ _ = return TCbracket\n{-# INLINABLE tok_cbracket #-}\n\ntok_ocurly :: Action\ntok_ocurly _ _ = return TOcurly\n{-# INLINABLE tok_ocurly #-}\n\ntok_ccurly :: Action\ntok_ccurly _ _ = return TCcurly\n{-# INLINABLE tok_ccurly #-}\n\ntok_quote :: Action\ntok_quote _ _ = return TQuote\n{-# INLINABLE tok_quote #-}\n\ntok_quasiquote :: Action\ntok_quasiquote _ _ = return TQuasiquote\n{-# INLINABLE tok_quasiquote #-}\n\ntok_pcommas :: Action\ntok_pcommas (AlexInput _ buf) l =\n do let commas0 = lexemeToFastString buf (fromIntegral l)\n commas1 = bytesFS commas0\n commas2 = C8.filter (not . isSpace) commas1\n return $! TPcommas (fromIntegral (C8.length commas1 - 2))\n{-# INLINABLE tok_pcommas #-}\n\ntok_comma :: Action\ntok_comma _ _ = return $ TSymbol $! fsLit \",\"\n{-# INLINABLE tok_comma #-}\n\ntok_unquote :: Action\ntok_unquote _ _ = return TUnquote\n{-# INLINABLE tok_unquote #-}\n\ntok_unquote_splice :: Action\ntok_unquote_splice _ _ = return TUnquoteSplice\n{-# INLINABLE tok_unquote_splice #-}\n\ntok_percent :: Action\ntok_percent (AlexInput _ buf) l\n | l == 2\n , let c = currentChar (snd (nextChar buf))\n , not (startsVarSym c)\n , not (startsConSym c)\n = return $! TPercent c\n | otherwise\n = let fs = lexemeToFastString buf l\n in fs `seq` return $! TSymbol fs\n{-# INLINABLE tok_percent #-}\n\ntok_discard :: Action\ntok_discard _ _ = return (TPercent '_')\n{-# INLINABLE tok_discard #-}\n\ntok_line_comment :: Action\ntok_line_comment _ _ = return TComment\n{-# INLINABLE tok_line_comment #-}\n\ntok_block_comment :: Action\ntok_block_comment = tok_block_comment_with (const TComment) alexGetChar\n{-# INLINABLE tok_block_comment #-}\n\ntok_block_comment_with :: (String -> Token)\n -> (AlexInput -> Maybe (Char, AlexInput))\n -> Action\ntok_block_comment_with tok ini inp0 _ = do\n case alexGetChar inp0 of\n Just ('{', inp1)\n | Just ('-', inp2) <- alexGetChar inp1\n , Just (c, inp3) <- ini inp2\n , Just (com, inp4) <- go inp3 c \"\"\n -> alexSetInput inp4 >> return (tok (reverse com))\n _ -> alexError \"tok_block_comment: panic\"\n where\n go inp prev acc =\n case alexGetChar inp of\n Just (c, inp') | prev == '-', c == '}', _:tl <- acc -> Just (tl, inp')\n | otherwise -> go inp' c (c:acc)\n Nothing -> Nothing\n{-# INLINABLE tok_block_comment_with #-}\n\ntok_doc_prev :: Action\ntok_doc_prev = tok_doc_with TDocPrev '^'\n{-# INLINABLE tok_doc_prev #-}\n\ntok_doc_next :: Action\ntok_doc_next = tok_doc_with TDocNext '|'\n{-# INLINABLE tok_doc_next #-}\n\ntok_doc_with :: (FastString -> Token) -> Char -> Action\ntok_doc_with constr char (AlexInput _ s) l = do\n let fs0 = takeUtf8FS l s\n bs0 = bytesFS fs0\n case C8.lines bs0 of\n line0:bss -> do\n let line1 = C8.tail (C8.dropWhile (/= char) line0)\n bs1 = C8.unlines (line1 : map dropCommentBeginning bss)\n fs1 = mkFastStringByteString bs1\n return $! constr fs1\n _ -> alexError \"tok_doc_with: panic\"\n{-# INLINABLE tok_doc_with #-}\n\ntok_doc_named :: Action\ntok_doc_named (AlexInput _ s) l = do\n let fs0 = takeUtf8FS l s\n bs0 = bytesFS fs0\n case C8.lines bs0 of\n line1:bss -> do\n let line2 = C8.dropWhile isSpace (dropCommentBeginning line1)\n line3 = C8.tail line2\n key = mkFastStringByteString line3\n bs1 = map dropCommentBeginning bss\n fs1 = mkFastStringByteString (C8.unlines bs1)\n fs2 = case bss of\n [] -> Nothing\n _ -> Just fs1\n return $! TDocNamed key fs2\n _ -> alexError \"panic: tok_doc_named\"\n{-# INLINABLE tok_doc_named #-}\n\ntok_doc_group :: Action\ntok_doc_group (AlexInput _ s) l =\n let bs0 = bytesFS (takeUtf8FS l s)\n bs1 = C8.dropWhile isSpace (dropCommentBeginning bs0)\n (stars, bs2) = C8.span (== '*') bs1\n level = C8.length stars\n fs0 = mkFastStringByteString (C8.tail bs2)\n in return $! TDocGroup level fs0\n{-# INLINABLE tok_doc_group #-}\n\ntok_lambda :: Action\ntok_lambda inp0@(AlexInput _ buf) l = do\n let return_lam_sym = return $ TSymbol $! fsLit \"\\\\\"\n if l == 1\n then return_lam_sym\n else case alexGetChar inp0 of\n Just (_, inp1) | Just (c, _) <- alexGetChar inp1 ->\n -- Decide whether the token is a varsym starting with \"\\\", or lambda\n -- and argument pattern.\n if startsVarSym c\n then return $ TSymbol $! takeUtf8FS l buf\n else alexSetInput inp1 >> return_lam_sym\n _ -> error \"tok_lambda: panic\"\n{-# INLINABLE tok_lambda #-}\n\n-- | Make token symbol. When the given symbol starts with non-operatator\n-- character, replace hyphens with underscores.\ntok_symbol :: Action\ntok_symbol (AlexInput _ buf) l =\n let fs0 = takeUtf8FS l buf\n fs1 | c == '!', secondIsVarId fs0 = replaceHyphens fs0\n | startsVarSym c || startsConSym c = fs0\n | otherwise = replaceHyphens fs0\n where c = currentChar buf\n in fs0 `seq` fs1 `seq` return $! TSymbol fs1\n{-# INLINABLE tok_symbol #-}\n\nsecondIsVarId :: FastString -> Bool\nsecondIsVarId fs0 = case unconsFS fs0 of\n Just (_,fs1) | Just (c,_) <- unconsFS fs1 -> startsVarId c\n _ -> False\n{-# INLINABLE secondIsVarId #-}\n\nreplaceHyphens :: FastString -> FastString\nreplaceHyphens =\n mkFastStringByteString .\n C8.map (\\c -> if c == '-' then '_' else c) .\n bytesFS\n{-# INLINABLE replaceHyphens #-}\n\ntok_char :: Action\ntok_char inp0 _ = do\n case alexGetChar inp0 of\n Just ('#', inp1) -> go0 inp1\n _ -> alexError \"tok_char: panic\"\n where\n go0 inp =\n case alexGetChar inp of\n Just ('\\'', inp') -> go1 inp'\n _ -> alexError \"tok_char.go0: panic\"\n go1 inp\n | Just (c, inp') <- alexGetChar inp =\n case c of\n '\\\\' -> case escapeChar inp' of\n Just (st, c', inp'') ->\n do alexSetInput inp''\n return $! TChar st c'\n Nothing ->\n do alexSetInput inp'\n return $! TChar (strToSourceText \"'\\\\\\\\'\") '\\\\'\n _ ->\n do alexSetInput inp'\n let st | c == '\\'' = '\\'' : '\\\\' : c : \"'\"\n | otherwise = '\\'' : c : \"'\"\n return $! TChar (strToSourceText st) c\n | otherwise = alexError \"tok_char.go1: panic\"\n{-# INLINABLE tok_char #-}\n\ntok_string :: Action\ntok_string inp@(AlexInput _ buf) _l =\n -- Currently String tokenizer does not update alex input per character. This\n -- makes the code a bit more effiicient, but getting unhelpful message on\n -- lexical error with literal string.\n case alexGetChar inp of\n Just ('\"', inp1)\n | Just (TString _ str, inp2@(AlexInput _ buf2)) <- go inp1 \"\" ->\n -- Refill the source text with string extracted with updated buffer\n -- location.\n do alexSetInput inp2\n#if MIN_VERSION_ghc(9,8,0)\n let lexeme = lexemeToFastString\n#else\n let lexeme = lexemeToString\n#endif\n let src = lexeme buf (cur buf2 - cur buf)\n return $! TString (SourceText src) str\n _ -> lexErrorSP\n where\n go inp0 acc =\n case alexGetChar inp0 of\n Nothing -> Nothing\n Just (c1, inp1)\n | c1 == '\"' -> do\n let acc' = reverse acc\n return $! (TString NoSourceText acc', inp1)\n | c1 == '\\\\' ->\n case escapeChar inp1 of\n Just (_st, c1, inp2) -> go inp2 $! (c1:acc)\n _ ->\n case alexGetChar inp1 of\n Just (c2, inp2)\n | c2 == '&' -> go inp2 $! acc\n | is_space' c2 -> string_gap inp2 acc\n _ -> Nothing\n | otherwise -> go inp1 $! (c1:acc)\n string_gap inp0 acc =\n case alexGetChar inp0 of\n Just (c, inp1)\n | c == '\\\\' -> go inp1 acc\n | is_space' c -> string_gap inp1 acc\n _ -> Nothing\n{-# INLINABLE tok_string #-}\n\n-- See \"lex_stringgap\" in \"compiler/parser/Lexer.x\".\nis_space' :: Char -> Bool\nis_space' c = c <= '\\x7f' && is_space c\n{-# INLINABLE is_space' #-}\n\nescapeChar :: AlexInput -> Maybe (SourceText, Char, AlexInput)\nescapeChar inp0\n | Just (c1, inp1) <- alexGetChar inp0 =\n let ret x = Just $! (strToSourceText (show x), x, inp1)\n esc str = strToSourceText ('\\'':'\\\\':str)\n numericChar test acc0 f =\n let lp inp acc =\n case alexGetChar inp of\n Just (c2, inp')\n | test c2 -> lp inp' (c2:acc)\n | otherwise ->\n let acc' = reverse acc\n in Just (esc (acc'++\"'\"), Char.chr (read (f acc')), inp)\n Nothing -> Nothing\n in lp inp1 acc0\n controlChar\n | Just (c2, inp2) <- alexGetChar inp1\n , c2 >= '@' && c2 <= '_' =\n Just (esc ('^':c2:\"'\"), chr (ord c2 - ord '@'), inp2)\n | otherwise = Nothing\n lkup cs = lookup (C8.pack cs)\n bstbl = map (\\(str,c) -> (C8.pack str, c))\n tbl2 = bstbl tbl2_str\n tbl2_str =\n [ (\"BS\", '\\BS'), (\"HT\", '\\HT'), (\"LF\", '\\LF'), (\"VT\", '\\VT')\n , (\"FF\", '\\FF'), (\"CR\", '\\CR'), (\"SO\", '\\SO'), (\"SI\", '\\SI')\n , (\"EM\", '\\EM'), (\"FS\", '\\FS'), (\"GS\", '\\GS'), (\"RS\", '\\RS')\n , (\"US\", '\\US'), (\"SP\", '\\SP') ]\n tbl3 = bstbl tbl3_str\n tbl3_str =\n [ (\"NUL\", '\\NUL'), (\"SOH\", '\\SOH'), (\"STX\", '\\STX')\n , (\"ETX\", '\\ETX'), (\"EOT\", '\\EOT'), (\"ENQ\", '\\ENQ')\n , (\"ACK\", '\\ACK'), (\"BEL\", '\\BEL'), (\"DLE\", '\\DLE')\n , (\"DC1\", '\\DC1'), (\"DC2\", '\\DC2'), (\"DC3\", '\\DC3')\n , (\"DC4\", '\\DC4'), (\"NAK\", '\\NAK'), (\"SYN\", '\\SYN')\n , (\"ETB\", '\\ETB'), (\"CAN\", '\\CAN'), (\"SUB\", '\\SUB')\n , (\"ESC\", '\\ESC') , (\"DEL\", '\\DEL') ]\n in case c1 of\n 'a' -> ret '\\a'\n 'b' -> ret '\\b'\n 'f' -> ret '\\f'\n 'n' -> ret '\\n'\n 'r' -> ret '\\r'\n 't' -> ret '\\t'\n 'v' -> ret '\\v'\n '\"' -> ret '\\\"'\n '\\'' -> ret '\\''\n '\\\\' -> ret '\\\\'\n '^' -> controlChar\n 'x' -> numericChar isHexDigit [c1] ('0':)\n 'o' -> numericChar isOctDigit [c1] ('0':)\n _ | isDigit c1 -> numericChar isDigit [c1] id\n | Just (c2, inp2) <- alexGetChar inp1\n , Just (c3, inp3) <- alexGetChar inp2\n -> case lkup [c1,c2,c3] tbl3 of\n Just c -> Just (esc [c1,c2,c3,'\\''], c, inp3)\n Nothing\n | Just c <- lkup [c1,c2] tbl2 ->\n Just (esc [c1,c2,'\\''], c, inp2)\n _ -> Nothing\n | otherwise -> Nothing\n | otherwise = Nothing\n{-# INLINABLE escapeChar #-}\n\ntok_integer :: Action\ntok_integer (AlexInput _ buf) l =\n let str = lexemeToString buf (fromIntegral l)\n in return $ TInteger (strToSourceText str) $! read $! str\n{-# INLINABLE tok_integer #-}\n\ntok_fractional :: Action\ntok_fractional (AlexInput _ buf) l =\n let str = lexemeToString buf $! fromIntegral l\n in return $! TFractional $! readFractionalLit $! str\n{-# INLINABLE tok_fractional #-}\n\n\n-- ---------------------------------------------------------------------\n--\n-- Lexer\n--\n-- ---------------------------------------------------------------------\n\n-- | Lexical analyzer for S-expression. Intended to be used with a parser made\n-- from Happy. This functions will not pass comment tokens to continuation.\ntokenLexer :: (Located Token -> SP a) -> SP a\ntokenLexer cont = go\n where\n go = do\n ltok@(L _span tok) <- scanToken\n case tok of\n TComment -> go\n _ -> cont ltok\n{-# INLINABLE tokenLexer #-}\n\nscanToken :: SP (Located Token)\nscanToken = do\n inp0@(AlexInput loc0 _) <- alexGetInput\n let sc = 0\n case alexScan inp0 sc of\n AlexToken inp1 len act -> do\n alexSetInput inp1\n tok <- act inp0 len\n -- Getting current location again after invoking 'act', to update\n -- location information of String tokens.\n loc1 <- fmap currentLoc getSPState\n#if MIN_VERSION_ghc(9,4,0)\n let span = RealSrcSpan (mkRealSrcSpan loc0 loc1) Strict.Nothing\n#elif MIN_VERSION_ghc(9,0,0)\n let span = RealSrcSpan (mkRealSrcSpan loc0 loc1) Nothing\n#else\n let span = RealSrcSpan (mkRealSrcSpan loc0 loc1)\n#endif\n return (L span tok)\n AlexError (AlexInput loc1 buf) -> do\n sp <- getSPState\n let l = srcLocLine loc1\n c = srcLocCol loc1\n trg = unpackFS (targetFile sp)\n alexError (trg ++ \": lexical error at line \" ++ show l ++\n \", column \" ++ show c ++\n \", near \" ++ show (currentChar buf))\n AlexSkip inp1 _ -> do\n alexSetInput inp1\n scanToken\n AlexEOF -> return (L undefined TEOF)\n{-# INLINABLE scanToken #-}\n\n-- | Lex the input to list of 'Token's.\nlexTokens :: Maybe FilePath\n -> StringBuffer\n -> Either LexicalError [Located Token]\nlexTokens = evalSP go\n where\n go = do\n tok <- tokenLexer return\n case tok of\n L _ TEOF -> return []\n _ -> (tok :) <$> go\n\n\n-- ---------------------------------------------------------------------\n--\n-- Auxiliary\n--\n-- ---------------------------------------------------------------------\n\ntakeUtf8 :: Int -> StringBuffer -> String\ntakeUtf8 = go []\n where\n go acc n buf =\n if n == 0\n then reverse acc\n else case nextChar buf of\n (c, buf') -> let acc' = c: acc\n n' = n - 1\n in acc' `seq` n' `seq` go acc' n' buf'\n{-# INLINABLE takeUtf8 #-}\n\ntakeUtf8FS :: Int -> StringBuffer -> FastString\ntakeUtf8FS n sb0 = lexemeToFastString sb0 diff\n where\n diff = byteDiff sb0 (step n sb0)\n step i sb =\n if i == 0\n then sb\n else let i' = i -1\n sb' = stepOn sb\n in i' `seq` sb' `seq` step i' sb'\n{-# INLINABLE takeUtf8FS #-}\n\n-- Taken from \"compiler/parser/Lexer.x.source\" ghc source.\nadjustChar :: Char -> Word8\nadjustChar c = fromIntegral $ ord adj_c\n where non_graphic = '\\x00'\n upper = '\\x01'\n lower = '\\x02'\n digit = '\\x03'\n symbol = '\\x04'\n space = '\\x05'\n other_graphic = '\\x06'\n uniidchar = '\\x07'\n\n adj_c\n | c <= '\\x07' = non_graphic\n | c <= '\\x7f' = c\n -- Alex doesn't handle Unicode, so when Unicode character is\n -- encountered we output these values with the actual character value\n -- hidden in the state.\n | otherwise =\n -- NB: The logic behind these definitions is also reflected in\n -- basicTypes/Lexeme.hs Any changes here should likely be\n -- reflected there.\n case generalCategory c of\n UppercaseLetter -> upper\n LowercaseLetter -> lower\n TitlecaseLetter -> upper\n ModifierLetter -> uniidchar -- see #10196\n OtherLetter -> lower -- see #1103\n NonSpacingMark -> uniidchar -- see #7650\n SpacingCombiningMark -> other_graphic\n EnclosingMark -> other_graphic\n DecimalNumber -> digit\n LetterNumber -> other_graphic\n OtherNumber -> digit -- see #4373\n ConnectorPunctuation -> symbol\n DashPunctuation -> symbol\n OpenPunctuation -> other_graphic\n ClosePunctuation -> other_graphic\n InitialQuote -> other_graphic\n FinalQuote -> other_graphic\n OtherPunctuation -> symbol\n MathSymbol -> symbol\n CurrencySymbol -> symbol\n ModifierSymbol -> symbol\n OtherSymbol -> symbol\n Space -> space\n _other -> non_graphic\n{-# INLINABLE adjustChar #-}\n\ndropCommentBeginning :: C8.ByteString -> C8.ByteString\ndropCommentBeginning = C8.dropWhile (== ';')\n{-# INLINABLE dropCommentBeginning #-}\n}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Main.hs", "content": "{-# LANGUAGE CPP #-}\n-- | Main function for Finkel compiler.\n--\n-- This module contains 'main' function, which does similar and simplified works\n-- done in @\"ghc/Main.hs\"@ found in ghc source.\n--\nmodule Language.Finkel.Main\n ( defaultMain\n , defaultMainWith\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Exception (displayException, throwIO)\nimport Control.Monad (unless)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.List (intercalate, partition)\nimport Data.Version (showVersion)\nimport System.Console.GetOpt (ArgDescr (..), ArgOrder (..),\n OptDescr (..), getOpt, usageInfo)\nimport System.Environment (getArgs, getProgName)\nimport System.Exit (exitFailure, exitWith)\nimport System.FilePath (normalise)\nimport System.IO (BufferMode (..), hSetBuffering,\n stderr, stdout)\nimport System.Process (CreateProcess (..),\n createProcess_, proc,\n waitForProcess)\n\n#if !MIN_VERSION_base(4,20,0)\nimport Data.List (foldl')\n#endif\n\n-- ghc\nimport GHC (defaultErrorHandler,\n parseDynamicFlags)\nimport GHC_Driver_Monad (printException)\nimport GHC_Driver_Phases (isDynLibFilename,\n isObjectFilename)\nimport GHC_Driver_Session (DynFlags (..), GeneralFlag (..),\n HasDynFlags (..), compilerInfo,\n defaultFatalMessager,\n defaultFlushOut, gopt)\nimport GHC_Types_Basic (SuccessFlag (..))\nimport GHC_Types_SrcLoc (mkGeneralLocated, unLoc)\nimport GHC_Utils_CliOption (Option (FileOption))\nimport GHC_Utils_Misc (looksLikeModuleName)\nimport GHC_Utils_Panic (GhcException (..),\n throwGhcException)\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Types.SourceError (handleSourceError)\n#else\nimport GHC_Driver_Types (handleSourceError)\n#endif\n\n#if MIN_VERSION_ghc(8,10,1) && !MIN_VERSION_ghc(8,10,3)\nimport GHC_Driver_Session (HscTarget (..), gopt_set)\n#endif\n\n-- ghc-boot\nimport GHC.HandleEncoding (configureHandleEncoding)\n\n-- internal\nimport Language.Finkel.Error\nimport Language.Finkel.Exception\nimport Language.Finkel.Fnk\nimport Language.Finkel.Make\nimport Language.Finkel.Options\nimport Language.Finkel.Reader (supportedLangExts)\nimport Language.Finkel.SpecialForms (defaultFnkEnv)\nimport qualified Paths_finkel_kernel\n\n\n-- ---------------------------------------------------------------------\n--\n-- The main function\n--\n-- ---------------------------------------------------------------------\n\n-- [Main entry point]\n-- ~~~~~~~~~~~~~~~~~~\n--\n-- Formerly, the Finkel compiler executable was written as ghc frontend\n-- plugin. However, passing conflicting options used in ghc's \"--make\" to the\n-- Finkel compiler executable was cumbersome, since frontend option cannot be\n-- used when ghc is invoked in /make/ mode.\n--\n-- Functions exported from this module is doing almost the same work done in the\n-- \"Main\" module of the ghc executable, but command line argument handling works\n-- are simplified, since Finkel compiler delegates works done in non-make mode\n-- to the ghc executable.\n\n-- | Function used by the Finkel kernel compiler.\ndefaultMain :: IO ()\ndefaultMain = defaultMainWith []\n\n-- | Make a main compiler function from given list of macros.\n--\n-- This functions does simplified command line argument parsing done in default\n-- @ghc@ mode (i.e., @make@ mode).\ndefaultMainWith :: [(String, Macro)]\n -- ^ List of pairs of macro name and 'Macro' value loaded to\n -- macro expander.\n -> IO ()\ndefaultMainWith macros = do\n args0 <- getArgs\n if any (`elem` rawGhcOptions) args0\n then rawGhc args0\n else showBriefUsageOnException $ do\n (fnk_opts, args1) <- parseFinkelOption defaultFnkEnv args0\n let fnk_env0 = finkelEnv fnk_opts\n\n -- Filtering out `--make' flag when exist. Otherwise make flag would be\n -- treated as input file, and Finkel flags as unknown flags from this\n -- point.\n args3 = filter (/= \"--make\") args1\n\n -- Using the `macros' from argument as first argument to the\n -- 'mergeMacros' function, so that the caller of this function can\n -- have a chance to override the behaviour of special forms in\n -- 'defaultFnkEnv'.\n macros' = mergeMacros (makeEnvMacros macros)\n (envMacros defaultFnkEnv)\n\n fnk_env1 = fnk_env0 { envDefaultMacros = macros'\n , envMacros = macros' }\n next = maybe (main1 fnk_env1 args1 args3)\n printFinkelHelp\n (finkelHelp fnk_opts)\n\n next\n\nshowBriefUsageOnException :: IO a -> IO a\nshowBriefUsageOnException =\n handleFinkelException\n (\\e -> do me <- getProgName\n putStrLn (me ++ \": \" ++ displayException e)\n printBriefUsage\n exitFailure)\n\nmain1 :: FnkEnv -> [String] -> [String] -> IO ()\nmain1 fnk_env orig_args ghc_args = do\n initGCStatistics\n hSetBuffering stdout LineBuffering\n hSetBuffering stderr LineBuffering\n configureHandleEncoding\n defaultErrorHandler\n defaultFatalMessager\n defaultFlushOut\n (runFnk (handleFinkelException\n (\\e -> do printFinkelException e\n liftIO exitFailure)\n (handleSourceError (\\e -> do printException e\n liftIO exitFailure)\n (main2 orig_args ghc_args)))\n fnk_env)\n\nmain2 :: [String] -> [String] -> Fnk ()\nmain2 orig_arg ghc_args =\n if \"--info\" `elem` ghc_args\n -- Show info and exit. Using the 'DynFlags' from the finkel compiler\n -- executable, not the delegated \"ghc\" executable.\n then getDynFlags >>= liftIO . showInfo\n else main3 orig_arg ghc_args\n\nmain3 :: [String] -> [String] -> Fnk ()\nmain3 orig_args ghc_args = do\n dflags0 <- getDynFlags\n\n let largs = map on_the_cmdline ghc_args\n on_the_cmdline = mkGeneralLocated \"on the commandline\"\n dflags1 = dflags0 {verbosity = 1}\n#if MIN_VERSION_ghc(8,10,3)\n dflags1b = dflags1\n#elif MIN_VERSION_ghc(8,10,1)\n -- Workaround for \"-fbyte-code\" command line option handling in ghc\n -- 8.10.1 and 8.10.2. The use of `noArgM' and `pure $ gopt_set ...' for\n -- \"-fbyte-code\" option in \"compiler/main/DynFlags.hs\" is ignoring the\n -- updated hscTarget ...\n dflags1b =\n if \"-fbyte-code\" `elem` ghc_args\n then gopt_set (dflags1 {hscTarget=HscInterpreted}) Opt_ByteCode\n else dflags1\n#else\n dflags1b = dflags1\n#endif\n\n -- From ghc 9.0, \"interpretPackageEnv\" is called from \"parseDynamicFlags\". In\n -- older versions, package environment initialization works were done by\n -- \"setSessionDynFlags\" via \"initPackages\".\n logger <- getLogger\n#if MIN_VERSION_ghc(9,2,0)\n (dflags2, lfileish, warnings) <- parseDynamicFlags logger dflags1b largs\n#else\n (dflags2, lfileish, warnings) <- parseDynamicFlags dflags1b largs\n#endif\n\n let fileish = map unLoc lfileish\n platform = targetPlatform dflags2\n isObjeish x = isObjectFilename platform x || isDynLibFilename platform x\n\n -- Partition source-code-ish from object-ish in file-ish arguments.\n (objish, srcish) = partition isObjeish fileish\n\n -- Partition Finkel and Haskell source codes in args. Delegate to raw ghc\n -- when source codes were null. Don't bother with ldInput, delegate the\n -- linking work to raw ghc.\n (srcs, non_srcs) = partition isSourceTarget srcish\n\n case srcs of\n [] -> liftIO (rawGhc orig_args)\n _ -> do\n -- Update ld inputs with object file inputs, as done in Main.hs of ghc.\n let ld_inputs = map (FileOption \"\") objish ++ ldInputs dflags2\n dflags3 = dflags2 {ldInputs = ld_inputs}\n\n -- Using 'setDynFlags' instead of 'setSessionDynFlags', since\n -- 'setSessionDynFlags' will be called from 'initSessionForMake' below.\n setDynFlags dflags3\n\n -- Some IO works. Check unknown flags, and update uniq supply. See Note\n -- [Initialization of UniqSupply] in 'Language.Finkel.Fnk'.\n liftIO (do checkUnknownFlags fileish\n initUniqSupply' (initialUnique dflags3)\n (uniqueIncrement dflags3))\n\n -- Show DynFlags warnings.\n handleSourceError\n (\\e -> do printException e\n liftIO exitFailure)\n (printOrThrowDiagnostics' logger dflags3 warnings)\n\n -- Initialization works for Finkel.\n initSessionForMake\n\n -- At the moment, compiling with phase specification are not supported,\n -- phase is always set to 'Nothing'.\n let phased_srcs = map phase_it srcs\n phased_non_srcs = map phase_it non_srcs\n phased_inputs = phased_srcs ++ phased_non_srcs\n phase_it path = (on_the_cmdline (normalise path), Nothing)\n force_recomp = gopt Opt_ForceRecomp dflags3\n#if MIN_VERSION_ghc(9,2,0)\n ofile = outputFile_ dflags3\n#else\n ofile = outputFile dflags3\n#endif\n\n -- Do the `make' work.\n success_flag <- make phased_inputs force_recomp ofile\n case success_flag of\n Succeeded -> return ()\n Failed -> liftIO exitFailure\n\n\n-- ---------------------------------------------------------------------\n--\n-- Finkel specific options\n--\n-- ---------------------------------------------------------------------\n\ndata FinkelOption = FinkelOption\n { finkelHelp :: Maybe FinkelHelp\n\n -- Using strict field to get exception soon after command line parsing, to\n -- show command line argument errors without GHC panic message.\n , finkelEnv :: !FnkEnv\n }\n\ndata FinkelHelp\n = Languages\n | Usage\n | Version\n\ndefaultFinkelOption :: FnkEnv -> FinkelOption\ndefaultFinkelOption fnk_env = FinkelOption\n { finkelHelp = Nothing\n , finkelEnv = fnk_env\n }\n\nparseFinkelOption :: FnkEnv -> [String] -> IO (FinkelOption, [String])\nparseFinkelOption fnk_env args0 = do\n let (fnk_args, other_args) = partitionFnkEnvOptions args0\n case getOpt Permute finkelOptDescrs fnk_args of\n (o,_,es) ->\n if null es\n then do\n -- Strictly evaluating 'FinkelOption' to show error message early as\n -- possible.\n let fo = foldl' (flip id) (defaultFinkelOption fnk_env) o\n fo `seq` pure (fo, other_args)\n else throwIO (FinkelException (concat es))\n\nfinkelOptDescrs :: [OptDescr (FinkelOption -> FinkelOption)]\nfinkelOptDescrs = helpOptDescrs ++ debugOptDescrs\n\nhelpOptDescrs :: [OptDescr (FinkelOption -> FinkelOption)]\nhelpOptDescrs =\n [ opt [\"fnk-help\"]\n (NoArg (\\o -> o {finkelHelp = Just Usage}))\n \"Show this help and exit.\"\n , opt [\"fnk-languages\"]\n (NoArg (\\o -> o {finkelHelp = Just Languages}))\n \"Show supported language extensions and exit.\"\n , opt [\"fnk-version\"]\n (NoArg (\\o -> o {finkelHelp = Just Version}))\n \"Show Finkel version and exit.\"\n ]\n where\n opt = Option []\n\ndebugOptDescrs :: [OptDescr (FinkelOption -> FinkelOption)]\ndebugOptDescrs = fromFnkEnvOptions (\\f o -> o {finkelEnv = f (finkelEnv o)})\n\nprintFinkelHelp :: FinkelHelp -> IO ()\nprintFinkelHelp fh =\n case fh of\n Languages -> printLanguages\n Usage -> printFinkelUsage\n Version -> printFinkelVersion\n\nprintFinkelUsage :: IO ()\nprintFinkelUsage = do\n name <- getProgName\n putStrLn (unlines (message name))\n where\n message name =\n [ \"USAGE: \" ++ name ++ \" [command-line-options-and-files]\"\n , \"\"\n , usageInfo \"HELP OPTIONS:\\n\" helpOptDescrs\n , fnkEnvOptionsUsage \"DEBUG OPTIONS:\\n\"\n , \" Other options are passed to ghc.\" ]\n\nprintBriefUsage :: IO ()\nprintBriefUsage =\n putStrLn \"Usage: For basic information, try the `--fnk-help' option.\"\n\nprintLanguages :: IO ()\nprintLanguages =\n mapM_ (putStrLn . snd) supportedLangExts\n\nprintFinkelVersion :: IO ()\nprintFinkelVersion = putStrLn v\n where\n v = \"finkel kernel compiler, version \" ++\n showVersion Paths_finkel_kernel.version\n\n\n-- ---------------------------------------------------------------------\n--\n-- Auxiliary\n--\n-- ---------------------------------------------------------------------\n\nrawGhc :: [String] -> IO ()\nrawGhc args = do\n (_,_,_,p) <- createProcess_ \"ghc\" (proc \"ghc\" args) {delegate_ctlc=True}\n waitForProcess p >>= exitWith\n\n-- | When any of options listed here were found, invoke raw @ghc@ without using\n-- Finkel compiler. Otherwise @ghc@ will complain with error message. These\n-- options are listed in \"ghc/Main.hs\" as `mode_flags'.\nrawGhcOptions :: [String]\nrawGhcOptions =\n [ \"-?\"\n , \"--help\"\n , \"-V\"\n , \"--version\"\n , \"--numeric-version\"\n , \"--show-options\"\n , \"--supported-languages\"\n , \"--supported-extensions\"\n , \"--show-packages\"\n , \"--show-iface\"\n , \"--backpack\"\n , \"--interactive\"\n , \"--abi-hash\"\n , \"-e\"\n , \"--frontend\"\n ]\n\n-- | Throw 'UsageError' when unknown flag were found.\ncheckUnknownFlags :: [String] -> IO ()\ncheckUnknownFlags fileish = do\n let unknowns = [f | f@('-':_) <- fileish]\n oneErr f = \"unrecognised flag: \" ++ f ++ \"\\n\"\n unless (null unknowns)\n (throwGhcException (UsageError (concatMap oneErr unknowns)))\n\n-- | True if given 'String' was module name, Finkel source file, or\n-- Haskell source file.\nisSourceTarget :: String -> Bool\nisSourceTarget str = looksLikeModuleName str || isFnkFile str || isHsFile str\n\n-- | Show the information of given 'DynFlags', doing the same thing as done in\n-- the @Main.hs@ found in ghc-bin.\nshowInfo :: DynFlags -> IO ()\nshowInfo dflags = do\n let sq x = \" [\" ++ x ++ \"\\n ]\"\n putStrLn (sq (intercalate \"\\n ,\" (map show (compilerInfo dflags))))\n\nforeign import ccall safe \"initGCStatistics\"\n initGCStatistics :: IO ()\n" }, { "path": "finkel-kernel/src/Language/Finkel/Make/Cache.hs", "content": "{-# LANGUAGE CPP #-}\n-- | Module for managing home module cache.\n--\n-- When compiling a module containing nested :require form, the required module\n-- is expanded twice, once when pre-processing and again when compiling byte\n-- code. This module contains functions for caching the home module to avoid\n-- redundant recompilation.\n\nmodule Language.Finkel.Make.Cache\n ( ExpandedCode(..)\n , lookupExpandedCodeCache\n , addToExpandedCodeCache\n , clearExpandedCodeCache\n\n , storeHomeModCache\n , updateHomeModCache\n , clearHomeModCache\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.IORef (IORef, atomicModifyIORef',\n newIORef, readIORef)\nimport System.IO.Unsafe (unsafePerformIO)\n\n-- containers\nimport Data.Map (Map)\nimport qualified Data.Map as Map\n\n-- ghc\nimport GHC_Unit_Module_ModSummary (ModSummary (..))\n\n-- Internal\nimport Language.Finkel.Form (Code)\nimport Language.Finkel.Lexer (SPState (..))\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC_Driver_Make (ModIfaceCache (..), newIfaceCache)\nimport Language.Finkel.Fnk (Fnk (..), FnkEnv (..), getFnkEnv,\n modifyFnkEnv)\n#endif\n\n-- ------------------------------------------------------------------------\n-- ExpandedCode cache\n-- ------------------------------------------------------------------------\n\n-- | Data type to represent parsed module from source code.\ndata ExpandedCode = ExpandedCode\n { ec_sp :: !SPState\n -- ^ Header information of expanded code.\n , ec_forms :: ![Code]\n -- ^ Parsed module compiled from expanded code.\n , ec_required :: [ModSummary]\n -- ^ Required home module during expansion.\n }\n\n-- | Lookup 'ExpandedCode' in cache.\nlookupExpandedCodeCache :: MonadIO m => FilePath -> m (Maybe ExpandedCode)\nlookupExpandedCodeCache path =\n liftIO $ Map.lookup path <$> readIORef unsafeExpandedCodeCacheRef\n{-# INLINABLE lookupExpandedCodeCache #-}\n\n-- | Add 'ExpandedCode' to cache with 'FilePath' key.\naddToExpandedCodeCache :: MonadIO m => FilePath -> ExpandedCode -> m ()\naddToExpandedCodeCache path ec = liftIO $ do\n atomicModifyIORef' unsafeExpandedCodeCacheRef $ \\ec_map ->\n (Map.insert path ec ec_map, ())\n{-# INLINABLE addToExpandedCodeCache #-}\n\n-- | Update the whole cache with empty 'Map.Map'.\nclearExpandedCodeCache :: MonadIO m => m ()\nclearExpandedCodeCache = liftIO $ do\n atomicModifyIORef' unsafeExpandedCodeCacheRef $ \\_ -> (Map.empty, ())\n{-# INLINABLE clearExpandedCodeCache #-}\n\n-- A global ref, IORef with unsafePerformIO.\nunsafeExpandedCodeCacheRef :: IORef (Map FilePath ExpandedCode)\nunsafeExpandedCodeCacheRef = unsafePerformIO $ newIORef Map.empty\n{-# NOINLINE unsafeExpandedCodeCacheRef #-}\n\n\n-- ------------------------------------------------------------------------\n-- Home ModIface cache\n-- ------------------------------------------------------------------------\n\n#if MIN_VERSION_ghc(9,4,0)\n\n-- XXX: Unfortunately, home module caching is not working when compiled without\n-- @-dynamic@ or @-dynamic-too@ option.\n--\n-- Seems like, when compiling byte code target, the module is always force\n-- compiled.\n\n-- | Store current 'HomeModCache' to private global reference.\nstoreHomeModCache :: Fnk ()\nstoreHomeModCache = do\n mb_mic <- fmap envInterpModIfaceCache getFnkEnv\n liftIO $ do\n new_ifc <- case mb_mic of\n -- XXX: Copy the contents of ModIfaceCache?\n Just mic -> pure $ HomeModCache {ifc_mic = mic}\n Nothing -> newHomeModCache\n atomicModifyIORef' unsafeHomeModCacheRef $ \\_ifc -> (new_ifc, ())\n{-# INLINABLE storeHomeModCache #-}\n\n-- | Update 'HomeModCache' in current 'FnkEnv'.\nupdateHomeModCache :: Fnk ()\nupdateHomeModCache = do\n HomeModCache {ifc_mic = mic} <- liftIO $ readIORef unsafeHomeModCacheRef\n modifyFnkEnv (\\fnk_env -> fnk_env {envInterpModIfaceCache = Just mic})\n{-# INLINABLE updateHomeModCache #-}\n\n-- | Clear 'HomeModCache' in privarte global reference.\nclearHomeModCache :: MonadIO m => m ()\nclearHomeModCache = liftIO $ do\n mic <- newIfaceCache\n atomicModifyIORef' unsafeHomeModCacheRef $ \\ifc -> (ifc {ifc_mic = mic}, ())\n{-# INLINABLE clearHomeModCache #-}\n\n-- | Data type to store home module cache passed from pre-process phase.\nnewtype HomeModCache = HomeModCache { ifc_mic :: ModIfaceCache }\n\nnewHomeModCache :: IO HomeModCache\nnewHomeModCache = fmap HomeModCache newIfaceCache\n{-# INLINABLE newHomeModCache #-}\n\n-- | Unsafe global IORef to share home module information from pre-process phase\n-- to hsc phase.\nunsafeHomeModCacheRef :: IORef HomeModCache\nunsafeHomeModCacheRef = unsafePerformIO $ do\n hmc <- newHomeModCache\n newIORef hmc\n{-# NOINLINE unsafeHomeModCacheRef #-}\n\n#else /* ghc < 9.4 */\n\n-- ModIfaceCache does not exist in ghc < 9.4. Do nothing with dummy functions.\n\nstoreHomeModCache :: Monad m => m ()\nstoreHomeModCache = pure ()\n\nupdateHomeModCache :: Monad m => m ()\nupdateHomeModCache = pure ()\n\nclearHomeModCache :: Monad m => m ()\nclearHomeModCache = pure ()\n\n#endif /* ghc < 9.4 */\n" }, { "path": "finkel-kernel/src/Language/Finkel/Make/Recompile.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n-- | Module containing types and functions for object code recompilation check.\nmodule Language.Finkel.Make.Recompile\n ( RecompM(..)\n , RecompState(..)\n , emptyRecompState\n , checkRecompileRequired\n , checkModSummary\n , adjustIncludePaths\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Monad (forM_, when)\nimport Control.Monad.Fail (MonadFail (..))\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.Bifunctor (first)\nimport GHC.Fingerprint (getFileHash)\nimport System.IO (fixIO)\n\n#if MIN_VERSION_ghc(9,4,0)\n-- containers\nimport qualified Data.Set as Set\n#endif\n\n-- filepath\nimport System.FilePath (dropExtension,\n takeDirectory)\n\n-- ghc\nimport GHC_Data_FastString (FastString)\nimport GHC_Driver_Env_Types (HscEnv (..))\nimport GHC_Driver_Phases (Phase (..))\nimport GHC_Driver_Session (DynFlags (..),\n HasDynFlags (..),\n addQuoteInclude)\nimport GHC_Iface_Load (readIface)\nimport GHC_Iface_Recomp (checkOldIface)\nimport GHC_Iface_Recomp_Binary (putNameLiterally)\nimport GHC_Iface_Recomp_Flags (fingerprintDynFlags)\nimport GHC_IfaceToCore (typecheckIface)\nimport GHC_Tc_Module (getModuleInterface)\nimport GHC_Tc_Utils_Monad (initIfaceLoad)\nimport GHC_Types_SrcLoc (Located, noLoc, unLoc)\nimport GHC_Types_Unique_Set (UniqSet, addOneToUniqSet,\n elementOfUniqSet,\n emptyUniqSet)\nimport GHC_Unit_Finder (findObjectLinkableMaybe)\nimport GHC_Unit_Home_ModInfo (HomeModInfo (..), addToHpt,\n lookupHpt)\nimport GHC_Unit_Module (ModLocation (..),\n ModuleName, mkModuleName,\n moduleName,\n moduleNameString)\nimport GHC_Unit_Module_Deps (Dependencies (..),\n Usage (..))\nimport GHC_Unit_Module_ModIface (ModIface, ModIface_ (..),\n mi_flag_hash, mi_mod_hash)\nimport GHC_Unit_Module_ModSummary (ModSummary (..),\n msHiFilePath, ms_mod_name)\nimport GHC_Unit_State (LookupResult (..),\n lookupModuleWithSuggestions)\nimport GHC_Unit_Types (IsBootInterface)\nimport GHC_Utils_Exception (handleIO)\nimport GHC_Utils_Fingerprint (Fingerprint)\nimport GHC_Utils_Outputable (Outputable (..), SDoc, text,\n (<+>))\n\nimport qualified GHC_Data_Maybe as Maybes\n\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Data.FastString (unpackFS)\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Unit.Home.ModInfo (HomeModLinkable (..),\n emptyHomeModInfoLinkable)\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.SysTools.Cpp (offsetIncludePaths)\n#elif MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Pipeline.Execute (offsetIncludePaths)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Env (hscUpdateHPT, hsc_HPT)\nimport GHC.Iface.Recomp (MaybeValidated (..))\nimport GHC.Rename.Names (renamePkgQual)\nimport GHC.Types.PkgQual (PkgQual (..))\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Types.SourceFile (SourceModified (..))\n#else\nimport GHC_Driver_Types (SourceModified (..))\n#endif\n\n#if !MIN_VERSION_ghc(9,4,0)\nimport GHC_Iface_Recomp (RecompileRequired (..))\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Env (hsc_units)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Unit_Types (GenWithIsBoot (..),\n ModuleNameWithIsBoot)\n#endif\n\n-- internal\nimport Language.Finkel.Error\nimport Language.Finkel.Fnk\nimport Language.Finkel.Make.Summary\nimport Language.Finkel.Make.TargetSource\nimport Language.Finkel.Make.Trace\n\n\n-- ------------------------------------------------------------------------\n--\n-- Recompilation check for ModSummary\n--\n-- ------------------------------------------------------------------------\n\ncheckModSummary :: MonadIO m => HscEnv -> ModSummary -> m Bool\ncheckModSummary hsc_env ms = do\n let mb_usages = do\n old_hmi <- lookupHpt (hsc_HPT hsc_env) (ms_mod_name ms)\n return (mi_usages (hm_iface old_hmi))\n maybe (pure False) runUsageFileCheck mb_usages\n\n-- | Simple function to check whther the 'UsageFile' is up to date.\nrunUsageFileCheck :: MonadIO m => [Usage] -> m Bool\nrunUsageFileCheck = go\n -- See: 'MkIface.checkModUsage'.\n where\n go us =\n case us of\n [] -> return True\n u:us' -> do\n ret <- check u\n if ret\n then go us'\n else return False\n check u =\n case u of\n UsageFile {usg_file_path = file\n ,usg_file_hash = old_hash} ->\n liftIO (handleIO (const (return False))\n (fmap (== old_hash) (getFileHash' file)))\n _ -> return True\n\n#if MIN_VERSION_ghc(9,8,0)\n getFileHash' = getFileHash . unpackFS\n#else\n getFileHash' = getFileHash\n#endif\n\n\n-- ------------------------------------------------------------------------\n--\n-- Recompilation check for interface file\n--\n-- ------------------------------------------------------------------------\n\n-- | State used for recompilation check.\ndata RecompState = RecompState\n { rs_hsc_env :: !HscEnv\n , rs_outdated :: !ModuleNameSet\n }\n\ntype ModuleNameSet = UniqSet ModuleName\n\nemptyRecompState :: HscEnv -> RecompState\nemptyRecompState hsc_env = RecompState hsc_env emptyUniqSet\n{-# INLINABLE emptyRecompState #-}\n\naddOutdated :: ModuleName -> RecompState -> RecompState\naddOutdated name rs = rs {rs_outdated = addOneToUniqSet (rs_outdated rs) name}\n{-# INLINABLE addOutdated #-}\n\nelemOutdated :: ModuleName -> RecompState -> Bool\nelemOutdated name rs = name `elementOfUniqSet` rs_outdated rs\n{-# INLINABLE elemOutdated #-}\n\n-- \"RecompM a\" is same as \"FnkT (ExceptT SDoc (State RecompState)) a\".\n\n-- | Newtype for recompilation check, state monad combined with Fnk with either\n-- value.\nnewtype RecompM a =\n RecompM {unRecompM :: RecompState -> Fnk (Either SDoc a, RecompState)}\n\ninstance Functor RecompM where\n fmap f (RecompM m) = RecompM (fmap (first (fmap f)) . m)\n {-# INLINE fmap #-}\n\ninstance Applicative RecompM where\n pure a = RecompM (\\st0 -> pure (pure a, st0))\n {-# INLINE pure #-}\n f <*> m = f >>= flip fmap m\n {-# INLINE (<*>) #-}\n\ninstance Monad RecompM where\n RecompM m >>= k =\n RecompM (\\st0 -> do (et1, st1) <- m st0\n case et1 of\n Left why -> st1 `seq` return (Left why, st1)\n Right a -> st1 `seq` unRecompM (k a) st1)\n {-# INLINE (>>=) #-}\n\ninstance MonadFail RecompM where\n fail e = RecompM (\\_ -> Control.Monad.Fail.fail e)\n {-# INLINE fail #-}\n\ninstance MonadThrow RecompM where\n throwM e = RecompM (\\_ -> throwM e)\n {-# INLINE throwM #-}\n\ninstance MonadIO RecompM where\n liftIO io = RecompM (\\st -> liftIO io >>= \\a -> pure (Right a, st))\n {-# INLINE liftIO #-}\n\ninstance HasDynFlags RecompM where\n getDynFlags = RecompM (\\st -> pure (Right (hsc_dflags (rs_hsc_env st)), st))\n {-# INLINE getDynFlags #-}\n\ninstance HasLogger RecompM where\n#if MIN_VERSION_ghc(9,2,0)\n getLogger = RecompM (\\st -> pure (Right (hsc_logger (rs_hsc_env st)), st))\n {-# INLINE getLogger #-}\n#else\n getLogger = pure (error \"getLogger (RecompM): no Logger\")\n#endif\n\n-- | Check whether recompilation is required.\ncheckRecompileRequired\n :: FnkEnv -> TargetUnit -> RecompM ModSummary\ncheckRecompileRequired fnk_env tu = do\n hsc_env <- getHscEnv\n ms0 <- mkModSummaryForRecompile hsc_env tu\n checkOutdatedCache (ms_mod_name ms0)\n checkObjDate ms0\n iface0 <- lookupOrLoadIface ms0\n checkUsagePackageModules (mi_usages iface0)\n ms1 <- refillHomeImports fnk_env ms0 iface0\n iface1 <- doCheckOldIface ms1 iface0\n hsc_env1 <- getHscEnv\n hmi <- mkHomeModInfo hsc_env1 ms0 iface1\n addHomeModInfo (ms_mod_name ms0) hmi\n return ms1\n\ngetRecompState :: RecompM RecompState\ngetRecompState = RecompM (\\st -> pure (Right st, st))\n{-# INLINABLE getRecompState #-}\n\ngetHscEnv :: RecompM HscEnv\ngetHscEnv = RecompM (\\st -> pure (Right (rs_hsc_env st), st))\n{-# INLINABLE getHscEnv #-}\n\nrecomp :: SDoc -> RecompM a\nrecomp why = RecompM (\\st -> pure (Left why, st))\n{-# INLINABLE recomp #-}\n\noutdate :: ModuleName -> SDoc -> RecompM a\noutdate name why = RecompM (\\st0 -> pure (Left why, addOutdated name st0))\n{-# INLINABLE outdate #-}\n\noutdateToo :: ModuleName -> RecompM a -> RecompM a\noutdateToo name (RecompM r) =\n RecompM $ \\st0 -> do\n et_a <- r st0\n case et_a of\n (Left why, st1) -> pure (Left why, addOutdated name st1)\n (Right a, st1) -> pure (Right a, st1)\n{-# INLINABLE outdateToo #-}\n\naddHomeModInfo :: ModuleName -> HomeModInfo -> RecompM ()\naddHomeModInfo name hmi =\n RecompM (\\rs0 ->\n let hsc_env0 = rs_hsc_env rs0\n hpt1 = addToHpt (hsc_HPT hsc_env0) name hmi\n#if MIN_VERSION_ghc(9,4,0)\n hsc_env1 = hscUpdateHPT (const hpt1) hsc_env0\n#else\n hsc_env1 = hsc_env0 {hsc_HPT = hpt1}\n#endif\n rs1 = rs0 {rs_hsc_env = hsc_env1}\n in pure (Right (), rs1))\n{-# INLINABLE addHomeModInfo #-}\n\ncheckOutdatedCache :: ModuleName -> RecompM ()\ncheckOutdatedCache mname = do\n st <- getRecompState\n when (elemOutdated mname st)\n (recomp (text (moduleNameString mname ++ \" in outdated cache\")))\n{-# INLINABLE checkOutdatedCache #-}\n\ncheckObjDate :: ModSummary -> RecompM ()\n#if MIN_VERSION_ghc(9,4,0)\n-- ms_hs_date disappeared in ghc 9.4.\n-- XXX: Should check with Fingerprint in ms_hs_hash field?\ncheckObjDate _ms = pure ()\n#else\ncheckObjDate ms = do\n let name = ms_mod_name ms\n hdate = ms_hs_date ms\n out str = outdate name (text (moduleNameString name) <+>\n text \"has\" <+>\n text str)\n case ms_obj_date ms of\n Just odate | hdate < odate -> return ()\n Just _ -> out \"outdated object code\"\n _ -> out \"no object code\"\n#endif\n{-# INLINABLE checkObjDate #-}\n\nlookupOrLoadIface :: ModSummary -> RecompM ModIface\nlookupOrLoadIface ms = do\n rs <- getRecompState\n case lookupHpt (hsc_HPT (rs_hsc_env rs)) (ms_mod_name ms) of\n Just hmi -> return (hm_iface hmi)\n Nothing -> loadIface (rs_hsc_env rs) ms\n{-# INLINABLE lookupOrLoadIface #-}\n\n-- | Check whether 'UsagePackageModule' elements are up to date or not.\ncheckUsagePackageModules :: [Usage] -> RecompM ()\ncheckUsagePackageModules usages = getHscEnv >>= forM_ usages . go\n -- Since RecompM might use a ModSummary without parsing source code, import\n -- declarations of external modules are not filled in the ModSummary. This\n -- function is for manually checking the status of imported modules from\n -- external package.\n where\n -- Checking the Usage for external package modules, to decide whether the\n -- source code file should be parsed or not.\n go hsc_env u =\n case u of\n UsagePackageModule {usg_mod=mdl,usg_mod_hash=old_hash} -> do\n let mname = moduleName mdl\n mname_str = moduleNameString mname\n check_mod_hash = do\n -- External package modules are also stored in outdated cache,\n -- looking up the cache before loading the interface.\n checkOutdatedCache mname\n (_, mb_iface) <- liftIO (getModuleInterface hsc_env mdl)\n case mb_iface of\n Nothing -> outdate mname (text (mname_str ++\n \" iface not found\"))\n Just iface ->\n when (miModHash' iface /= old_hash)\n (outdate mname (text (mname_str ++ \" hash changed\")))\n#if MIN_VERSION_ghc(9,2,0)\n lmws_arg1 = hsc_units\n#elif MIN_VERSION_ghc(9,0,0)\n lmws_arg1 = unitState . hsc_dflags\n#else\n lmws_arg1 = hsc_dflags\n#endif\n -- case lookupModuleWithSuggestions (lmws_arg1 hsc_env) mname Nothing of\n#if MIN_VERSION_ghc(9,4,0)\n no_pkgq = NoPkgQual\n#else\n no_pkgq = Nothing\n#endif\n case lookupModuleWithSuggestions (lmws_arg1 hsc_env) mname no_pkgq of\n LookupFound {} -> check_mod_hash\n LookupMultiple {} -> check_mod_hash\n LookupHidden {} -> check_mod_hash\n LookupUnusable {} -> outdate mname (text (mname_str ++ \" unusable\"))\n LookupNotFound {} -> outdate mname (text (mname_str ++ \" not found\"))\n _ -> return ()\n\n-- | Refill 'ms_textual_imps' field with 'UsageHomeModule' in interface.\nrefillHomeImports :: FnkEnv -> ModSummary -> ModIface -> RecompM ModSummary\nrefillHomeImports fnk_env ms mi = do\n -- XXX: At the moment cannot find any clue to get textual imports of external\n -- packages from ModIface, recompilation due to changes in external package\n -- modules are done with \"checkUsagePackageModules\".\n let dmods0 = get_dep_mods (mi_deps mi)\n#if MIN_VERSION_ghc(9,4,0)\n get_dep_mods = dep_direct_mods\n#else\n get_dep_mods = dep_mods\n#endif\n dmods1 = mapDMS unDeps dmods0\n tr = traceMake fnk_env \"refillHomeImports\"\n mname = ms_mod_name ms\n\n tr [ \"dep_mods mi_deps of\" <+> ppr mname\n , nvcOrNone (dmsToList (mapDMS fst dmods1))\n ]\n\n -- Marking this module as outdated when any of the imported home package\n -- module was outdated, and at the same time, preserving the state with\n -- outdated home package module.\n imps0 <- outdateToo mname (mapM (collectOldIface fnk_env) (dmsToList dmods1))\n\n#if MIN_VERSION_ghc(9,4,0)\n hsc_env <- getHscEnv\n let imps1 = map rename imps0\n rename (mb_fs, lmname) =\n (renamePkgQual unit_env (unLoc lmname) mb_fs, lmname)\n unit_env = hsc_unit_env hsc_env\n#else\n let imps1 = imps0\n#endif\n\n return (ms {ms_textual_imps=imps1})\n\n#if MIN_VERSION_ghc(9,4,0)\nunDeps :: (a, ModuleNameWithIsBoot) -> (ModuleName, IsBootInterface)\nunDeps (_, mnwib) = (gwib_mod mnwib, gwib_isBoot mnwib)\n#elif MIN_VERSION_ghc(9,0,0)\nunDeps :: ModuleNameWithIsBoot -> (ModuleName, IsBootInterface)\nunDeps gwib = (gwib_mod gwib, gwib_isBoot gwib)\n#else\nunDeps :: a -> a\nunDeps = id\n#endif\n{-# INLINABLE unDeps #-}\n\n-- | Load old interface when usable and not yet loaded.\ncollectOldIface\n :: FnkEnv -> (ModuleName, IsBootInterface)\n -> RecompM (Maybe FastString, Located ModuleName)\ncollectOldIface fnk_env (mname, _is_boot) = do\n hsc_env <- getHscEnv\n let tr = traceMake fnk_env \"collectOldIface\"\n\n -- Lookup HomeModInfo in current HomePackageTable. If not found, updating\n -- HomeModInfo, so that the later \"checkOlfIface\" can lookup the interface\n -- files in HomePackageTable. If the interface were not added, fake interface\n -- would be added to PIT by the \"checkOldIface\" via \"LoadIface.loadInterface\".\n case lookupHpt (hsc_HPT hsc_env) mname of\n Just _hmi -> do\n tr [\"Found iface of\" <+> ppr mname <+> \"in HPT\"]\n return (Nothing, noLoc mname)\n Nothing -> do\n -- Before doing any other check, lookup the outdated cache.\n checkOutdatedCache mname\n\n -- Checking the existence of the old module, could be deleted.\n tu <- checkTargetUnit (noLoc (moduleNameString mname), Nothing)\n\n dep_ms <- mkModSummaryForRecompile hsc_env tu\n checkObjDate dep_ms\n\n -- Comparing the DynFlags hash at this point, to trigger recompilation\n -- with changes in the DynFlag.\n iface <- loadIface hsc_env dep_ms\n checkFlagHash hsc_env dep_ms iface\n\n -- External packages are not in textual import of ModSummary when reusing\n -- interface, checking now.\n checkUsagePackageModules (mi_usages iface)\n\n tr [\"Collecting old iface of\" <+> ppr mname]\n hmi <- mkHomeModInfo hsc_env dep_ms iface\n addHomeModInfo mname hmi\n\n return (Nothing, noLoc mname)\n\n-- | Check whether recompile is required or not via 'checkOldIface'.\ndoCheckOldIface :: ModSummary -> ModIface -> RecompM ModIface\ndoCheckOldIface ms iface0 = do\n hsc_env0 <- getHscEnv\n let dflags_with_new_paths = adjustIncludePaths (ms_hspp_opts ms) ms\n hsc_env1 = hsc_env0 {hsc_dflags = dflags_with_new_paths}\n mb_iface0 = Just iface0\n mname = ms_mod_name ms\n#if MIN_VERSION_ghc(9,4,0)\n -- 'SourceModified' data type disappeared in ghc 9.4.\n mbv_iface <- liftIO (checkOldIface hsc_env1 ms mb_iface0)\n case mbv_iface of\n UpToDateItem iface -> pure iface\n OutOfDateItem reason _ -> outdate mname (ppr reason)\n#else\n -- Delegating the interface test to \"checkOldIface\", except for the\n -- up-to-date-ness of source code by comparing the timestamps of the source\n -- code file and object code file.\n let src_modified =\n case ms_obj_date ms of\n Just odate | ms_hs_date ms < odate -> SourceUnmodified\n _ -> SourceModified\n recompileReason rr =\n case rr of\n UpToDate -> text \"up to date\"\n MustCompile -> text \"must compile\"\n RecompBecause why -> text why\n (rr, mb_iface1) <- liftIO (checkOldIface hsc_env1 ms src_modified mb_iface0)\n let why = recompileReason rr\n case rr of\n UpToDate | Just iface <- mb_iface1 -> return iface\n _ -> outdate mname why\n#endif\n\ncheckTargetUnit :: (Located String, Maybe Phase) -> RecompM TargetUnit\ncheckTargetUnit name_and_mb_phase@(lname, _) = do\n dflags <- hsc_dflags <$> getHscEnv\n let name = unLoc lname\n mname = mkModuleName (asModuleName name)\n mb_tu <- findTargetUnitMaybe dflags name_and_mb_phase\n case mb_tu of\n Nothing -> outdate mname (text (\"Source of \" ++ name ++ \" not found\"))\n Just tu -> return tu\n{-# INLINABLE checkTargetUnit #-}\n\ncheckFlagHash :: HscEnv -> ModSummary -> ModIface -> RecompM ()\ncheckFlagHash _he ms iface = do\n -- See \"checkFlagHash\" function in \"MkIface\".\n let old_hash = miFlagHash' iface\n dflags0 = ms_hspp_opts ms\n dflags1 = adjustIncludePaths dflags0 ms\n mdl = mi_module iface\n#if MIN_VERSION_ghc(9,2,0)\n new_hash <-\n let he1 = _he {hsc_dflags = dflags1}\n in liftIO (fingerprintDynFlags he1 mdl putNameLiterally)\n#else\n new_hash <- liftIO (fingerprintDynFlags dflags1 mdl putNameLiterally)\n#endif\n when (old_hash /= new_hash) (outdate (moduleName mdl) \"flag hash changed\")\n{-# INLINABLE checkFlagHash #-}\n\n-- | Wrapper function to load interface file with 'readIface'.\nloadIface :: HscEnv -> ModSummary -> RecompM ModIface\nloadIface hsc_env ms = do\n let mdl = ms_mod ms\n mname = moduleName mdl\n mname_str = moduleNameString mname\n#if MIN_VERSION_ghc(9,4,0)\n let load_iface =\n readIface (hsc_dflags hsc_env) (hsc_NC hsc_env) mdl (msHiFilePath ms)\n read_result <- liftIO (initIfaceLoad hsc_env (liftIO load_iface))\n#else\n let load_iface = readIface mdl (msHiFilePath ms)\n read_result <- liftIO (initIfaceLoad hsc_env load_iface)\n#endif\n case read_result of\n Maybes.Failed _e -> outdate mname (text (\"no iface for \" ++ mname_str))\n Maybes.Succeeded iface -> pure iface\n\n-- | Make 'HomeModInfo' for object code recompilation.\nmkHomeModInfo\n :: MonadIO m => HscEnv -> ModSummary -> ModIface -> m HomeModInfo\nmkHomeModInfo hsc_env0 ms iface0 = liftIO $ do\n let mdl = ms_mod ms\n mloc = ms_location ms\n#if MIN_VERSION_ghc(9,4,0)\n update_hpt = hscUpdateHPT\n#else\n update_hpt f he = he {hsc_HPT = f (hsc_HPT he)}\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\n empty_home_mod_info_linkable = emptyHomeModInfoLinkable\n asObjLinkable mb_linkable = HomeModLinkable { homeMod_object = mb_linkable\n , homeMod_bytecode = Nothing }\n#else\n empty_home_mod_info_linkable = Nothing\n asObjLinkable = id\n#endif\n -- See Note [Knot-tying typecheckIface] in GhcMake.\n knot_tying hsc_env mname iface =\n fixIO $ \\details' -> do\n let hmi = HomeModInfo iface details' empty_home_mod_info_linkable\n hsc_env1 = update_hpt (\\hpt -> addToHpt hpt mname hmi) hsc_env\n initIfaceLoad hsc_env1 (typecheckIface iface)\n details <- knot_tying hsc_env0 (ms_mod_name ms) iface0\n mb_linkable <- findObjectLinkableMaybe mdl mloc\n return $! HomeModInfo iface0 details (asObjLinkable mb_linkable)\n\n-- | Adjust the 'includePaths' field in given 'DynFlags' to prepare for getting\n-- flag hash value.\nadjustIncludePaths :: DynFlags -> ModSummary -> DynFlags\nadjustIncludePaths dflags0 ms =\n -- See: \"DriverPipeline.compileOne'\", it is doing similar work for updating\n -- the \"includePaths\" of the \"DynFlags\" used in \"checkOldInterface\".\n case ml_hs_file (ms_location ms) of\n Nothing -> dflags0\n Just path ->\n let old_paths = includePaths dflags0\n current_dir = takeDirectory (dropExtension path)\n new_paths0 = addQuoteInclude old_paths [current_dir]\n#if MIN_VERSION_ghc(9,4,0)\n new_paths1 = offsetIncludePaths dflags0 new_paths0\n#else\n new_paths1 = new_paths0\n#endif\n in dflags0 {includePaths = new_paths1}\n\nmiModHash', miFlagHash' :: ModIface -> Fingerprint\nmiModHash' = mi_mod_hash . mi_final_exts\nmiFlagHash' = mi_flag_hash . mi_final_exts\n{-# INLINABLE miModHash' #-}\n{-# INLINABLE miFlagHash' #-}\n\n-- ------------------------------------------------------------------------\n--\n-- GHC version compatibility functions\n--\n-- ------------------------------------------------------------------------\n\n-- Fields in Dependency module set\n--\n-- Data type for dependency module is defined in GHC.Unit.Module.Deps as\n-- `Dependencies'. Some of the fields in this data type has changed to use `Set'\n-- from plain list. Following `DepModSet' tries to absorb the modification.\n\nmapDMS :: (Ord a, Ord b) => (a -> b) -> DepModSet a -> DepModSet b\n{-# INLINABLE mapDMS #-}\n\ndmsToList :: DepModSet a -> [a]\n{-# INLINABLE dmsToList #-}\n\n#if MIN_VERSION_ghc(9,4,0)\ntype DepModSet a = Set.Set a\nmapDMS = Set.map\ndmsToList = Set.toList\n#else\ntype DepModSet a = [a]\nmapDMS = map\ndmsToList = id\n#endif\n" }, { "path": "finkel-kernel/src/Language/Finkel/Make/Session.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n-- | Module to manage HscEnv for macro expansion.\nmodule Language.Finkel.Make.Session\n ( withExpanderSettings\n , setExpanding\n , isExpanding\n , bcoDynFlags\n , isInterpreted\n , discardInteractiveContext\n , clearGlobalSession\n , expandContents\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Concurrent (MVar, modifyMVar, newMVar)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.Foldable (for_)\nimport Data.IORef (atomicModifyIORef', newIORef)\nimport Data.List (intercalate)\nimport Data.Maybe (isJust)\nimport System.IO.Unsafe (unsafePerformIO)\n\n#if MIN_VERSION_ghc(9,0,0)\nimport qualified Data.Set as Set\n#endif\n\n-- exception\nimport Control.Monad.Catch (bracket)\n\n-- ghc\nimport GHC_Data_StringBuffer (hGetStringBuffer)\nimport GHC_Driver_Env_Types (HscEnv (..))\nimport GHC_Driver_Main (newHscEnv)\nimport GHC_Driver_Monad (Ghc (..), GhcMonad (..),\n Session (..), getSession,\n setSession)\nimport GHC_Driver_Session (DynFlags (..), GeneralFlag (..),\n GhcLink (..), HasDynFlags (..),\n WarningFlag (..), setGeneralFlag',\n updOptLevel, wopt_unset)\nimport GHC_Utils_Outputable (Outputable (..), fsep, nest, text,\n (<+>))\n\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Driver.DynFlags (ParMakeCount (..))\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Driver.Backend (backendWritesFiles)\nimport GHC.Driver.Session (topDir, unSetGeneralFlag')\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Driver.Backend (backendCanReuseLoadedCode,\n interpreterBackend)\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Backend (Backend (..))\n#else\nimport GHC_Driver_Session (HscTarget (..))\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Env (discardIC)\n#else\nimport GHC_Runtime_Context (InteractiveContext (..),\n emptyInteractiveContext)\nimport GHC_Types_Name (nameIsFromExternalPackage)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Env (hsc_home_unit)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)\nimport GHC_Driver_Session (homeUnit)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC (setSessionDynFlags)\nimport GHC_Platform_Ways (Way (..), hostFullWays)\n#else\nimport GHC_Driver_Session (Way (..), interpWays, thisPackage)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC.Runtime.Loader (initializePlugins)\n#else\nimport DynamicLoading (initializePlugins)\n#endif\n\n-- Internal\nimport Language.Finkel.Expand (expands)\nimport Language.Finkel.Fnk\nimport Language.Finkel.Make.Cache\nimport Language.Finkel.Reader (parseSexprs)\n\n-- ---------------------------------------------------------------------\n--\n-- Expanded home module form\n--\n-- ---------------------------------------------------------------------\n\n-- | Get expanded module form of given file path.\n--\n-- This function first lookup the global cache with using the file path as the\n-- key of the cache. If not found in cache, read the file, expand macros, and\n-- cache the result.\nexpandContents :: FilePath -> Fnk ExpandedCode\nexpandContents path = do\n fnk_env <- getFnkEnv\n dflags <- getDynFlags\n\n let tr = debugWhen' dflags fnk_env Fnk_trace_session\n path_text = text path\n\n mb_ec <- lookupExpandedCodeCache path\n case mb_ec of\n Just ec -> do\n tr [\"expandContents: reusing expanded code in\" <+> path_text]\n pure ec\n _other -> do\n -- XXX: When to reset macros to envDefaultMacros? Or, no need for\n -- resetting since the expansion happens in pre-processing phase?\n tr [\"expandContents: expanding\" <+> path_text <+> \"...\"]\n buf <- liftIO $ hGetStringBuffer path\n (forms0, sp) <- parseSexprs (Just path) buf\n forms1 <- withExpanderSettings $ expands forms0\n reqs <- envRequiredHomeModules <$> getFnkEnv\n resetRequiredHomeModules\n let ec = ExpandedCode sp forms1 reqs\n tr [\"expandContents: adding cache for\" <+> path_text]\n addToExpandedCodeCache path ec\n pure ec\n\nresetRequiredHomeModules :: Fnk ()\nresetRequiredHomeModules = modifyFnkEnv $ \\fnk_env ->\n fnk_env {envRequiredHomeModules = []}\n{-# INLINABLE resetRequiredHomeModules #-}\n\n\n-- ---------------------------------------------------------------------\n--\n-- Session management\n--\n-- ---------------------------------------------------------------------\n\n-- | Perform given action with 'HscEnv' updated for macroexpansion with\n-- interactive evaluation, then reset to the preserved original 'HscEnv'.\nwithExpanderSettings :: Fnk a -> Fnk a\nwithExpanderSettings act = do\n fnk_env <- getFnkEnv\n dflags <- getDynFlags\n\n debugWhen' dflags fnk_env Fnk_trace_session\n [\"withExpanderSettings: envInvokedMode:\" <+> ppr (envInvokedMode fnk_env)]\n\n case envInvokedMode fnk_env of\n ExecMode -> withExpanderSettingsE act\n GhcPluginMode -> withExpanderSettingsG act\n\n-- | Like 'withExpanderSettings', but takes a flag to discard interactive\n-- context in the session used for the expansion.\nwithExpanderSettingsE :: Fnk a -> Fnk a\nwithExpanderSettingsE act =\n do dflags <- getDynFlags\n -- Switching to the dedicated 'HscEnv' for macro expansion when compiling\n -- object code. If not, assuming current session is using the bytecode\n -- interpreter, using the given action as-is.\n if isInterpreted dflags\n then act\n else bracket prepare restore (const act)\n where\n prepare = do\n fnk_env <- getFnkEnv\n hsc_env_old <- getSession\n\n -- Reusing previous 'HscEnv' for macro expansion if exist, or making a new\n -- 'HscEnv'. When reusing, discarding the previous 'InteractiveContext',\n -- to avoid file local compile time functions to affect other modules.\n case envSessionForExpand fnk_env of\n Just he -> setSession $! discardInteractiveContext he\n Nothing -> do\n he1 <- newHscEnvForExpand fnk_env hsc_env_old\n setSession he1\n postSetSession\n he2 <- getSession\n modifyFnkEnv (\\e -> e {envSessionForExpand = Just he2})\n\n return hsc_env_old\n\n restore hsc_env_old = do\n hsc_env_new <- getSession\n modifyFnkEnv (\\e -> e {envSessionForExpand = Just hsc_env_new})\n setSession hsc_env_old\n\n#if MIN_VERSION_ghc(9,0,0)\n -- To set the \"hsc_interp\" field in the new session.\n postSetSession = getDynFlags >>= setSessionDynFlags\n#else\n postSetSession = return ()\n#endif\n\n-- | Make new 'HscEnv' from given 'DynFlags'.\n--\n-- Adjusting the 'DynFlags' used by the macro expansion session, to support\n-- evaluating expressions in dynamic and non-dynamic builds of the Finkel\n-- compiler executable.\nnewHscEnvForExpand :: MonadIO m => FnkEnv -> HscEnv -> m HscEnv\nnewHscEnvForExpand fnk_env orig_hsc_env = do\n let tr = debugWhen' dflags0 fnk_env Fnk_trace_session\n dflags0 = hsc_dflags orig_hsc_env\n -- XXX: Constantly updating the backend to interpreter, the original\n -- backend information is gone. If the 'bcoDynFlags' was not applied,\n -- compilation of finkel-core package failed in ghc <= 8.10.\n dflags1 = bcoDynFlags dflags0\n dflags2 = if interpHasNoWayDyn\n then removeWayDyn dflags1\n else dflags1\n tr [ \"newHscEnvForExpand.hsc_targets\"\n , nest 2 (fsep (map ppr (hsc_targets orig_hsc_env)))]\n\n#if MIN_VERSION_ghc(9,6,0)\n -- In ghc 9.6, arguments of newHscEnv takes top directory of ghc library path.\n new_hsc_env_0 <- liftIO $! newHscEnv (topDir dflags2) dflags2\n#else\n new_hsc_env_0 <- liftIO $! newHscEnv dflags2\n#endif\n#if MIN_VERSION_ghc(9,4,0)\n -- From ghc 9.4, plugins (loaded and static) are stored in HscEnv instead of\n -- DynFlags. Updating the hsc_plugins and hsc_hooks fields from old hsc_env\n -- value.\n let new_hsc_env_1 = new_hsc_env_0 { hsc_plugins = hsc_plugins orig_hsc_env\n , hsc_hooks = hsc_hooks orig_hsc_env }\n#elif MIN_VERSION_ghc(9,2,0)\n -- From ghc 9.2, hsc_env has separate fields for loaded plugins and static\n -- plugins.\n let new_hsc_env_1 =\n new_hsc_env_0 { hsc_plugins = hsc_plugins orig_hsc_env\n , hsc_static_plugins = hsc_static_plugins orig_hsc_env }\n#else\n -- No need to update hsc_env, plugins are stored in DynFlags.\n let new_hsc_env_1 = new_hsc_env_0\n#endif\n\n pure new_hsc_env_1\n\n-- | Run given 'Fnk' action with macro expansion settings for 'GhcPluginMode'.\nwithExpanderSettingsG :: Fnk a -> Fnk a\nwithExpanderSettingsG act = do\n dflags <- getDynFlags\n fnk_env <- getFnkEnv\n let tr = debugWhen' dflags fnk_env Fnk_trace_session\n if isExpanding dflags\n then do\n -- Clearing the current target, but not using 'withGlobalSession'. The\n -- 'withGlobalSesion' function locks the top level MVar, using it will\n -- cause a dead lock.\n tr [\"withExpanderSettingsG: clearing hsc_targets for nested call\"]\n tr [\"withExpanderSettingsG: keys\" <+> text (showExpanding dflags)]\n withEmptyTargets act\n else do\n tr [\"withExpanderSettingsG: withGlobalSession\"]\n withGlobalSession act\n\n-- Run given action with empty 'hsc_targets', restores the original target after\n-- running.\nwithEmptyTargets :: Fnk a -> Fnk a\nwithEmptyTargets act0 = bracket prepare restore act1\n where\n prepare = do\n hsc_env <- getSession\n let orig_targets = hsc_targets hsc_env\n setSession (hsc_env {hsc_targets = []})\n pure orig_targets\n\n restore orig_targets = do\n hsc_env <- getSession\n setSession (hsc_env {hsc_targets = orig_targets})\n\n act1 _ = act0\n\n-- Note: [Global HscEnv for plugin]\n-- --------------------------------\n--\n-- When compiling with ghc plugin, FnkEnv is unwrapped with \"toGhc\" and \"unGhc\"\n-- to perform the inner IO action. This way of invokation could not share the\n-- FnkEnv when compiling multiple module, so reading from and writing to a\n-- global MVar to pass around the \"Session\" to avoid redundant module compilation\n-- when using home package modules during macro expansion.\n\n-- | Wrapper to perform given action with global 'Session', to share the\n-- underlying 'HscEnv' when compiling as ghc plugin.\nwithGlobalSession :: Fnk a -> Fnk a\nwithGlobalSession act0 = do\n fer <- Fnk pure\n fenv0 <- getFnkEnv\n orig_hsc_env <- getSession\n\n let tr = debugWhen' (hsc_dflags orig_hsc_env) fenv0 Fnk_trace_session\n prepare do_init = do\n hsc_env <- if do_init\n then initializeGlobalSession\n else getSession\n dumpHscEnv fenv0 \"withGlobalSession (prepare)\" hsc_env\n pure hsc_env\n\n restore hsc_env_orig = do\n hsc_env <- getSession\n dumpHscEnv fenv0 \"withGlobalSession (restore):\" hsc_env\n setSession hsc_env_orig\n\n act1 do_init = bracket (prepare do_init) restore $ \\mex0 -> do\n let mex1 = discardInteractiveContext mex0\n setSession mex1\n modifyFnkEnv (\\e -> e {envSessionForExpand = Just mex1})\n retval <- act0\n mex2 <- getSession\n modifyFnkEnv (\\e -> e {envSessionForExpand = Just mex2})\n fnk_env <- getFnkEnv\n pure (retval, fnk_env)\n\n (retval, fnk_env) <- liftIO $ do\n modifyMVar globalSessionVar $ \\mb_s0 -> do\n (do_init, s1@(Session r1)) <- case mb_s0 of\n Just s0 -> do\n tr [\"withGlobalSession: global session already initialized\"]\n pure (False, s0)\n Nothing -> do\n tr [\"withGlobalSession: invoking newHscEnvForExpand\"]\n new_hsc_env <- newHscEnvForExpand fenv0 orig_hsc_env\n r0 <- newIORef new_hsc_env\n pure (True, Session r0)\n (retval, fnk_env) <- unGhc (toGhc (act1 do_init) fer) s1\n for_ (envSessionForExpand fnk_env) $ \\he ->\n atomicModifyIORef' r1 (const (he, ()))\n pure (Just s1, (retval, fnk_env))\n\n putFnkEnv fnk_env\n liftIO $ tr [\"withGlobalSession: clearing expanded code cache\"]\n clearExpandedCodeCache\n pure retval\n\n-- | Clear the contents of global 'MVar' containing 'HscEnv' for macro\n-- expansion.\nclearGlobalSession :: IO ()\nclearGlobalSession = modifyMVar globalSessionVar $ const $ pure (Nothing, ())\n{-# INLINABLE clearGlobalSession #-}\n\ninitializeGlobalSession :: GhcMonad m => m HscEnv\ninitializeGlobalSession = do\n#if MIN_VERSION_ghc(9,0,0)\n -- To set the \"hsc_interp\" field in the new session.\n _ <- getDynFlags >>= setSessionDynFlags\n#endif\n getSession >>= initializePlugin'\n{-# INLINABLE initializeGlobalSession #-}\n\n-- Version compatible variant of 'initializePlugins'.\ninitializePlugin' :: MonadIO m => HscEnv -> m HscEnv\n#if MIN_VERSION_ghc(9,2,0)\ninitializePlugin' = liftIO . initializePlugins\n#else\ninitializePlugin' hsc_env = do\n plugin_dflags <- liftIO $ initializePlugins hsc_env (hsc_dflags hsc_env)\n return (updateDynFlags plugin_dflags hsc_env)\n#endif\n{-# INLINABLE initializePlugin' #-}\n\n-- | Unsafe global 'MVar' to share the 'HscEnv' when compiling as plugin.\nglobalSessionVar :: MVar (Maybe Session)\nglobalSessionVar = unsafePerformIO (newMVar Nothing)\n{-# NOINLINE globalSessionVar #-}\n\n-- XXX: Workaround for passing state to recursively called \"load'\" function\n-- defined in GHC driver. Modifying the \"rawSettings\" field in the DynFlags with\n-- dummy String value, so that recursive call to the \"load'\" function can tell\n-- whether current module is compiled for macro expansion or not.\n--\n-- The \"parMakeCount\" field update is a wokaround for concurrent build. Current\n-- approach does not work with \"-j\" ghc option, which could cause race\n-- conditions when multiple mudoles were requiring same home package module,\n-- since the HscEnv is shared between all home package modules.\n\n-- | Modify given 'DynFlags' as in macro expansion state.\nsetExpanding :: DynFlags -> DynFlags\nsetExpanding dflags0 =\n let raw_settings = rawSettings dflags0\n#if MIN_VERSION_ghc(9,8,0)\n dflags1 = dflags0 {parMakeCount = Just (ParMakeThisMany 1)}\n#else\n dflags1 = dflags0 {parMakeCount = Just 1}\n#endif\n dflags2 = dflags1 {rawSettings = expandingKey : raw_settings}\n in dflags2\n{-# INLINABLE setExpanding #-}\n\n-- | 'True' if given 'DynFlags' is in macro expansion state.\nisExpanding :: DynFlags -> Bool\nisExpanding = isJust . lookup (fst expandingKey) . rawSettings\n{-# INLINABLE isExpanding #-}\n\n-- | Internally used key value pair to mark macro expansion state.\nexpandingKey :: (String, String)\nexpandingKey = (\"FNK_MEX\", \"1\")\n{-# INLINABLE expandingKey #-}\n\n-- | Show expanding key.\nshowExpanding :: DynFlags -> String\nshowExpanding dflags =\n let keys = [ k <> \"=\" <> v\n | kv@(k, v) <- rawSettings dflags, kv == expandingKey]\n in intercalate \" \" keys\n{-# INLINABLE showExpanding #-}\n\nremoveWayDyn :: DynFlags -> DynFlags\n#if MIN_VERSION_ghc(9,2,0)\nremoveWayDyn df = df {targetWays_ = removeDynFromWays (targetWays_ df)}\n#else\nremoveWayDyn df = df {ways = removeDynFromWays (ways df)}\n#endif\n{-# INLINABLE removeWayDyn #-}\n\n#if MIN_VERSION_ghc(9,0,0)\nremoveDynFromWays :: Set.Set Way -> Set.Set Way\nremoveDynFromWays = Set.filter (/= WayDyn)\n#else\nremoveDynFromWays :: [Way] -> [Way]\nremoveDynFromWays = filter (/= WayDyn)\n#endif\n{-# INLINABLE removeDynFromWays #-}\n\n-- | From `discardIC'.\ndiscardInteractiveContext :: HscEnv -> HscEnv\n#if MIN_VERSION_ghc(9,4,0)\ndiscardInteractiveContext = discardIC\n#else\ndiscardInteractiveContext hsc_env =\n let dflags = hsc_dflags hsc_env\n empty_ic = emptyInteractiveContext dflags\n new_ic_monad = keep_external_name ic_monad\n old_ic = hsc_IC hsc_env\n keep_external_name ic_name =\n if nameIsFromExternalPackage this_pkg old_name\n then old_name\n else ic_name empty_ic\n where\n old_name = ic_name old_ic\n# if MIN_VERSION_ghc(9,2,0)\n this_pkg = hsc_home_unit hsc_env\n# elif MIN_VERSION_ghc(9,0,0)\n this_pkg = homeUnit dflags\n# else\n this_pkg = thisPackage dflags\n# endif\n in hsc_env {hsc_IC = empty_ic {ic_monad = new_ic_monad}}\n#endif\n{-# INLINABLE discardInteractiveContext #-}\n\n-- | Setup 'DynFlags' for interactive evaluation.\nbcoDynFlags :: DynFlags -> DynFlags\n-- XXX: See: 'GhcMake.enableCodeGenForUnboxedTupleOrSums'.\nbcoDynFlags dflags0 =\n let dflags1 = dflags0 { ghcLink = LinkInMemory\n#if MIN_VERSION_ghc(9,6,0)\n , backend = interpreterBackend\n#elif MIN_VERSION_ghc(9,2,0)\n , backend = Interpreter\n#else\n , hscTarget = HscInterpreted\n#endif\n }\n#if MIN_VERSION_ghc(9,6,0)\n -- See 'GHC.Driver.Main.hscMaybeWriteIface'. The function will panic if\n -- writing simple interface file with dyanmic-too option enabled. The\n -- simple interface is written from\n -- \"GHC.Driver.Pipeline.Execute.runHscBackendPhase\" if backend does not\n -- write files.\n --\n -- XXX: Not sure whether possible to have -dynamic-too with\n -- non-file-writing backend, confirm it.\n dflags2 | not (backendWritesFiles (backend dflags0))\n = unSetGeneralFlag' Opt_BuildDynamicToo dflags1\n | otherwise = dflags1\n#else\n dflags2 = dflags1\n#endif\n#if MIN_VERSION_ghc(9,6,0)\n -- In ghc 9.6, seems like `Opt_ByteCode' is not in use any more.\n dflags3 = setGeneralFlag' Opt_UseBytecodeRatherThanObjects dflags2\n#elif MIN_VERSION_ghc(9,2,0)\n dflags3 = setGeneralFlag' Opt_ByteCode dflags2\n#elif MIN_VERSION_ghc(8,10,3)\n dflags3 = setGeneralFlag' Opt_ByteCodeIfUnboxed dflags2\n#elif MIN_VERSION_ghc(8,10,1)\n dflags3 = setGeneralFlag' Opt_ByteCode dflags2\n#else\n dflags3 = dflags2\n#endif\n dflags4 = setGeneralFlag' Opt_IgnoreOptimChanges $\n setGeneralFlag' Opt_IgnoreHpcChanges $\n updOptLevel 0 dflags3\n -- XXX: Warning message for missing home package module is shown with\n -- -Wall option, suppressing for now ...\n dflags5 = wopt_unset dflags4 Opt_WarnMissingHomeModules\n in dflags5\n{-# INLINABLE bcoDynFlags #-}\n\ninterpHasNoWayDyn :: Bool\n#if MIN_VERSION_ghc(9,0,0)\ninterpHasNoWayDyn = WayDyn `notElem` hostFullWays\n#else\ninterpHasNoWayDyn = WayDyn `notElem` interpWays\n#endif\n{-# INLINABLE interpHasNoWayDyn #-}\n\n-- | 'True' when the 'DynFlags' is using interpreter.\nisInterpreted :: DynFlags -> Bool\n#if MIN_VERSION_ghc(9,6,0)\n-- As of ghc 9.6.2, interpreter backend is the only backend which can reuse\n-- loaded code.\nisInterpreted = backendCanReuseLoadedCode . backend\n#elif MIN_VERSION_ghc(9,2,0)\nisInterpreted dflags = backend dflags == Interpreter\n#else\nisInterpreted dflags = hscTarget dflags == HscInterpreted\n#endif\n{-# INLINABLE isInterpreted #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Make/Summary.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TypeApplications #-}\n-- | Internal module for 'ModSummary'.\nmodule Language.Finkel.Make.Summary\n ( -- * Target summary\n TargetSummary(..)\n , plainEMS\n\n -- * ModSummary helpers\n , summariseTargetUnit\n , mkModSummaryForRecompile\n , updateSummaryTimestamps\n , compileFnkFile\n , dumpParsedAST\n , dumpModSummary\n\n -- * Builder helpers\n , buildHsSyn\n\n -- * GHC version compatibility\n , mkModuleGraph'\n , mgModSummaries'\n , mgElemModule'\n , extendMG'\n , withTiming'\n , isObjectBackend\n\n -- * Re-export\n , Option(..)\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Monad (when)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.Foldable (find)\nimport Data.List (nub)\nimport Data.Maybe (isJust)\nimport System.IO (IOMode (..), withFile)\n\n#if !MIN_VERSION_base(4,20,0)\nimport Data.List (foldl')\n#endif\n\n-- container\n#if !MIN_VERSION_ghc(9,2,0)\nimport qualified Data.Map as Map\n#endif\n\n-- date\nimport Data.Time (UTCTime)\n\n-- directory\nimport System.Directory (createDirectoryIfMissing)\n\n-- filepath\nimport System.FilePath (takeBaseName, takeDirectory,\n (<.>), ())\n\n-- ghc\nimport GHC_Data_FastString (fsLit)\nimport GHC_Data_StringBuffer (StringBuffer,\n hGetStringBuffer)\nimport GHC_Driver_Env_Types (HscEnv (..))\nimport GHC_Driver_Monad (GhcMonad (..))\nimport GHC_Driver_Phases (Phase (..))\nimport GHC_Driver_Pipeline (compileFile, preprocess)\nimport GHC_Driver_Ppr (printForUser)\nimport GHC_Driver_Session (DumpFlag (..),\n DynFlags (..),\n HasDynFlags (..),\n parseDynamicFilePragma)\nimport GHC_Hs (HsModule (..))\nimport GHC_Hs_Dump (BlankSrcSpan (..),\n showAstData)\nimport GHC_Hs_ImpExp (ImportDecl (..))\nimport GHC_Hs_Stats (ppSourceStats)\nimport GHC_Parser_Header (getImports)\nimport GHC_Types_SourceError (throwErrors, throwOneError)\nimport GHC_Types_SourceFile (HscSource (..))\nimport GHC_Types_SrcLoc (GenLocated (..), Located,\n mkSrcLoc, mkSrcSpan, unLoc)\nimport GHC_Unit_Finder (addHomeModuleToFinder,\n mkHomeModLocation)\nimport GHC_Unit_Home_ModInfo (HomeModInfo (..), lookupHpt)\nimport GHC_Unit_Module (ModLocation (..), Module,\n ModuleName, mkModuleName,\n moduleName,\n moduleNameSlashes,\n moduleNameString)\nimport GHC_Unit_Module_Deps (Usage (..))\nimport GHC_Unit_Module_Graph (ModuleGraph, mgLookupModule,\n mgModSummaries,\n mkModuleGraph)\nimport GHC_Unit_Module_ModIface (ModIface_ (..))\nimport GHC_Unit_Module_ModSummary (ModSummary (..),\n ms_mod_name)\nimport GHC_Utils_CliOption (Option (..))\nimport GHC_Utils_Misc (looksLikeModuleName,\n modificationTimeIfExists)\nimport GHC_Utils_Outputable (Outputable (..), SDoc, hcat,\n quotes, text, vcat, ($$),\n (<+>))\n\n\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Data.FastString (unpackFS)\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Runtime.Context (icNamePprCtx)\n#else\nimport GHC_Runtime_Context (icPrintUnqual)\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Driver.Backend (backendWritesFiles)\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Backend (backendProducesObject)\n#else\nimport GHC_Driver_Session (isObjectTarget)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Config.Finder (initFinderOpts)\nimport GHC.Driver.Env (hscSetFlags, hsc_HPT)\nimport GHC.Driver.Phases (StopPhase (..))\nimport GHC.Parser.Header (mkPrelImports)\nimport GHC.Rename.Names (renameRawPkgQual)\nimport GHC.Types.PkgQual (PkgQual (..),\n RawPkgQual (..))\nimport GHC.Unit.Module.Graph (ModuleGraphNode (..))\nimport qualified GHC.Unit.Module.Graph as Graph\nimport GHC.Unit.Module.ModSummary (ms_imps)\nimport GHC.Utils.Fingerprint (getFileHash)\n#else\nimport GHC_Data_FastString (FastString)\nimport GHC_Driver_Pipeline (writeInterfaceOnlyMode)\nimport GHC_Unit_Module_Graph (mgElemModule)\nimport GHC_Utils_Misc (getModificationUTCTime)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Config.Parser (initParserOpts)\nimport GHC.Driver.Errors.Types (GhcMessage (..))\nimport GHC.Utils.Logger (putDumpFileMaybe)\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Config (initParserOpts)\nimport GHC.Parser.Errors.Ppr (pprError)\nimport GHC.Utils.Logger (dumpIfSet_dyn)\n#else\nimport GHC_Utils_Error (dumpIfSet_dyn)\n#endif\n\n#if !MIN_VERSION_ghc(9,4,0)\nimport GHC_Unit_Module_ModSummary (ms_home_allimps)\n#endif\n\n#if !MIN_VERSION_ghc(9,4,0) && MIN_VERSION_ghc(9,2,0)\nimport GHC.Unit.Module.ModSummary (extendModSummaryNoDeps)\n#endif\n\n#if !MIN_VERSION_ghc(9,4,0)\nimport GHC_Unit_Module_Graph (extendMG)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Env (hsc_home_unit)\nimport GHC.Driver.Session (xopt)\nimport GHC.Hs.Dump (BlankEpAnnotations (..))\nimport GHC.LanguageExtensions (Extension (ImplicitPrelude))\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Hs (HsParsedModule (..))\n#else\nimport GHC_Driver_Types (HsParsedModule (..))\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Unit.Home (mkHomeModule)\n#elif MIN_VERSION_ghc(9,0,0)\nimport GHC_Driver_Session (homeUnit)\nimport GHC_Unit_Module (mkModule)\n#else\nimport GHC_Driver_Session (thisPackage)\nimport GHC_Unit_Module (mkModule)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Utils.Logger (DumpFormat (..))\n#elif MIN_VERSION_ghc(9,0,0)\nimport GHC_Parser_Annotation (ApiAnns (..))\nimport GHC_Utils_Error (DumpFormat (..))\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Monad (withTimingM)\n#else\nimport GHC_Utils_Error (withTimingD)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Utils_Outputable (Depth (..))\n#endif\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Emit\nimport Language.Finkel.Error\nimport Language.Finkel.Fnk\nimport Language.Finkel.Form\nimport Language.Finkel.Lexer\nimport Language.Finkel.Make.Cache\nimport Language.Finkel.Make.Session\nimport Language.Finkel.Make.TargetSource\nimport Language.Finkel.Reader\nimport Language.Finkel.Syntax\nimport Language.Finkel.Syntax.Location\n\n\n-- | Data type to represent summarised 'TargetSource'.\ndata TargetSummary\n = -- | Expanded 'ModSummary', from 'FnkSource' and 'HsSource'.\n EMS !ModSummary -- ^ Summary of itself\n !(Maybe SPState) -- ^ Parsed state for FnkSource\n [ModSummary] -- ^ Required home package modules for FnkSource\n\n -- | Link time file option, from 'OtherSource'.\n | LdInput !Option\n\n#if !MIN_VERSION_ghc(9,4,0)\n-- PkgQual and RawPkgQual did not exist until ghc 9.4, instead, Maybe FastString\n-- were used for both types of package qualified imports.\ntype PkgQual = Maybe FastString\ntype RawPkgQual = Maybe FastString\n#endif\n\n-- | Make 'EMS' with no 'SPState' and empty list of required 'ModSummary'.\nplainEMS :: ModSummary -> TargetSummary\nplainEMS ms = EMS ms Nothing []\n\n-- | Make a 'TargetSummary' from given 'TargetUnit'.\nsummariseTargetUnit :: TargetUnit -> Fnk TargetSummary\nsummariseTargetUnit (tsrc, mbphase) =\n case tsrc of\n FnkSource path mn -> compileFnkFile path mn\n HsSource path _ -> compileHsFile path mbphase\n OtherSource path -> compileOtherFile path\n\n-- | Compile Finkel source.\ncompileFnkFile :: FilePath -> ModuleName -> Fnk TargetSummary\ncompileFnkFile path modname = do\n fnk_env0 <- getFnkEnv\n hsc_env <- getSession\n\n ExpandedCode {ec_sp=sp, ec_forms=forms, ec_required=reqs} <-\n expandContents path\n\n dflags1 <- getDynFlagsFromSPState hsc_env sp\n\n let tr = traceSummary fnk_env0 \"compileFnkFile\"\n mname_str = moduleNameString modname\n mname_sdoc = text (mname_str ++ \":\")\n\n tr [\"path:\" <+> text path]\n\n -- Compile the form with local DynFlags to support file local pragmas.\n mdl <- withTmpDynFlags dflags1 $\n withTiming' (\"FinkelModule [\" ++ mname_str ++ \"]\") $ do\n -- Reset current FnkEnv. No need to worry about managing DynFlags, this\n -- action is wrapped with 'withTmpDynFlags' above.\n resetEnvMacros\n compileFnkModuleForm forms\n\n tr [\"reqs in\" <+> mname_sdoc <+> ppr (map ms_mod_name reqs)]\n\n let rreqs = reverse reqs\n\n -- XXX: Pass the Bool value for ms_ghc_prim_import somehow.\n ms <- mkModSummary hsc_env dflags1 path mdl rreqs\n\n -- Dump the module contents as Haskell source code when any of the dump\n -- options was set and this is the first time for compiling the target module.\n dumpHsSourceCode fnk_env0 hsc_env (Just sp) ms\n\n -- Also showing the parsed AST to support -ddump-parsed-ast option.\n dumpParsedAST hsc_env (ms_hspp_opts ms) ms\n\n return $! EMS ms (Just sp) rreqs\n\n-- | Parse the file header LANGUAGE pragmas and update given 'DynFlags'.\nparseFnkFileHeader\n :: (HasLogger m, MonadIO m, MonadThrow m) => HscEnv -> FilePath -> m DynFlags\nparseFnkFileHeader hsc_env path = do\n contents <- liftIO (hGetStringBuffer path)\n (_, sp) <- parseHeaderPragmas (Just path) contents\n getDynFlagsFromSPState hsc_env sp\n\n-- | Compile 'HModule' from given list of 'Code'.\ncompileFnkModuleForm :: [Code] -> Fnk HModule\ncompileFnkModuleForm form = do\n fnk_env <- getFnkEnv\n let colons = replicate 19 ';'\n debugWhen fnk_env\n Fnk_dump_expand\n [ text \"\"\n , text colons <+> text \"Expanded\" <+> text colons\n , vcat (map ppr form)\n , text \"\"]\n buildHsSyn parseModule form\n\n-- | Get language extensions in current 'Fnk' from given 'SPState'.\ngetDynFlagsFromSPState :: (HasLogger m, MonadIO m) => HscEnv -> SPState -> m DynFlags\ngetDynFlagsFromSPState hsc_env sp = do\n -- Adding \"-X\" to 'String' representation of 'LangExt' data type, as done in\n -- 'HeaderInfo.checkExtension'.\n let dflags0 = hsc_dflags hsc_env\n mkx = fmap (\"-X\" ++)\n exts = map mkx (langExts sp)\n logger <- getLogger\n (dflags1,_,warns1) <- parseDynamicFilePragma dflags0 exts\n printOrThrowDiagnostics' logger dflags1 warns1\n (dflags2,_,warns2) <- parseDynamicFilePragma dflags1 (ghcOptions sp)\n printOrThrowDiagnostics' logger dflags2 warns2\n return dflags2\n\nresetEnvMacros :: Fnk ()\nresetEnvMacros =\n modifyFnkEnv (\\fnk_env ->\n fnk_env {envMacros = envDefaultMacros fnk_env})\n{-# INLINABLE resetEnvMacros #-}\n\ncompileHsFile :: FilePath -> Maybe Phase -> Fnk TargetSummary\ncompileHsFile path mb_phase = do\n -- Not fully parsing the Haskell source code, it will be parsed by the \"load'\"\n -- function later.\n hsc_env <- getSession\n (dflags, pp_path) <- liftIO (preprocess' hsc_env (path, mb_phase))\n sbuf <- liftIO (hGetStringBuffer pp_path)\n (simps, timps, ghc_prim_import, L _l mname) <-\n liftIO (getImports' dflags sbuf pp_path path)\n let simps' = fmap (rnRPQI hsc_env) simps\n timps' = fmap (rnRPQI hsc_env) timps\n ms <- mkModSummary' hsc_env dflags path mname simps' timps'\n Nothing (Just sbuf) ghc_prim_import\n return $! plainEMS ms\n\n-- | Rename raw package qualified import. See\n-- 'GHC.Driver.Make.getPreprocessedImports', which is not exported.\nrnRPQI :: HscEnv -> (RawPkgQual, Located ModuleName) -> (PkgQual, Located ModuleName)\n#if MIN_VERSION_ghc(9,4,0)\nrnRPQI hsc_env (pk, lmn@(L _ mn)) =\n (renameRawPkgQual (hsc_unit_env hsc_env) mn pk, lmn)\n#else\nrnRPQI _ = id\n#endif\n{-# INLINABLE rnRPQI #-}\n\ncompileOtherFile :: FilePath -> Fnk TargetSummary\ncompileOtherFile path = do\n hsc_env <- getSession\n fnk_env <- getFnkEnv\n traceSummary fnk_env\n \"compileOtherFile\"\n [\"Compiling OtherSource:\" <+> text path]\n#if MIN_VERSION_ghc(9,4,0)\n -- ghc 9.4, introduced StopPhase data type. Before that, Phase data type was\n -- directly used as stopping phase.\n let phase_to_stop = NoStop\n#else\n let phase_to_stop = StopLn\n#endif\n o_file0 <- liftIO (compileFile hsc_env phase_to_stop (path, Nothing))\n#if MIN_VERSION_ghc(9,4,0)\n -- Resulting type of compileFile changed in ghc 9.4 from 'FilePath' to 'Maybe\n -- FilePath'.\n let o_file1 = maybe \"\" id o_file0\n#else\n let o_file1 = o_file0\n#endif\n return $! LdInput (FileOption \"\" o_file1)\n\n-- Note [Avoiding Recompilation]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- See below for details of how GHC avoid recompilation:\n--\n-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance\n--\n-- To support recompiling the target module when the required modules were\n-- changed, checking the file paths of home package modules are stored as\n-- \"UsageFile\" in \"mi_usages\", via \"hpm_src_files\" field in \"HsParsedModule\"\n-- used when making \"ModSummary\" data.\n--\n-- Currently, dependencies of required home package module are chased with plain\n-- file path, since the information of required module is stored as a plain file\n-- path, not as a module. This is to avoid compiling required modules as object\n-- code, because macro expansions are done with byte code interpreter.\n\n-- | Make 'ModSummary'.\nmkModSummary\n :: HscEnv -- ^ Current session.\n -> DynFlags -- ^ File local 'DynFlags'.\n -> FilePath -- ^ The source code path.\n -> HModule -- ^ Parsed module.\n -> [ModSummary] -- ^ List of required 'ModSummary' in home package.\n -> Fnk ModSummary\nmkModSummary hsc_env dflags file mdl reqs = do\n let mod_name = case hsmodName mdl of\n Just name -> unLoc name\n Nothing -> mkModuleName \"Main\"\n r_s_loc = mkSrcLoc (fsLit file) 1 1\n r_s_span = mkSrcSpan r_s_loc r_s_loc\n\n -- XXX: PackageImports language extension not yet supported. See\n -- 'HscTypes.ms_home_imps'\n rn_idecl = reLoc . ideclName . unLoc\n imports0 = hsmodImports mdl\n#if MIN_VERSION_ghc(9,4,0)\n implicit_prelude = xopt ImplicitPrelude dflags\n imports1 = mkPrelImports mod_name r_s_span implicit_prelude imports0\n imports2 = map (\\lm -> (NoPkgQual, rn_idecl lm)) (imports1 ++ imports0)\n#else\n imports2 = map (\\lm -> (Nothing, rn_idecl lm)) imports0\n#endif\n\n -- Adding file path of the required modules and file paths of imported home\n -- package modules to \"hpm_src_files\" to support recompilation.\n req_srcs <- requiredDependencies reqs\n\n let pm = HsParsedModule\n { hpm_module = L r_s_span mdl\n , hpm_src_files = req_srcs\n#if !MIN_VERSION_ghc(9,2,0)\n -- The hpm_annotations field disappeared in ghc 9.2.\n , hpm_annotations = mkEmptyApiAnns\n#endif\n }\n\n mkModSummary' hsc_env dflags file mod_name [] imports2 (Just pm) Nothing False\n\n#if !MIN_VERSION_ghc(9,2,0)\n# if MIN_VERSION_ghc(9,0,0)\nmkEmptyApiAnns :: ApiAnns\nmkEmptyApiAnns = ApiAnns { apiAnnItems = Map.empty\n , apiAnnEofPos = Nothing\n , apiAnnComments = Map.empty\n , apiAnnRogueComments = []\n }\n# else\nmkEmptyApiAnns :: (Map.Map a b, Map.Map c d)\nmkEmptyApiAnns = (Map.empty, Map.empty)\n# endif\n#endif\n\n-- | Make 'ModSummary' for recompilation check done with 'doCheckOldIface'.\nmkModSummaryForRecompile :: (HasLogger m, MonadIO m, MonadThrow m)\n => HscEnv -> TargetUnit -> m ModSummary\nmkModSummaryForRecompile hsc_env tu@(tsource, _) = do\n let path = targetSourcePath tsource\n mod_name = targetUnitName tu\n dflags1 <- case tsource of\n FnkSource {} -> parseFnkFileHeader hsc_env path\n _ -> return (hsc_dflags hsc_env)\n mkModSummary' hsc_env dflags1 path mod_name [] [] Nothing Nothing False\n\n-- | Make 'ModSummary' from source file, module name, and imports.\nmkModSummary'\n :: MonadIO m\n => HscEnv\n -> DynFlags -- Potentially file local DynFlags\n -> FilePath\n -> ModuleName\n -> [(PkgQual, Located ModuleName)]\n -> [(PkgQual, Located ModuleName)]\n -> Maybe HsParsedModule\n -> Maybe StringBuffer\n -> Bool\n -> m ModSummary\nmkModSummary' hsc_env dflags file mod_name srcimps txtimps mb_pm mb_buf\n _ghc_prim_import = do\n -- Throw an exception on module name mismatch.\n assertModuleNameMatch dflags file mb_pm\n\n let tryGetObjectDate path =\n if isObjectBackend dflags\n then modificationTimeIfExists path\n else return Nothing\n#if MIN_VERSION_ghc(9,4,0)\n let mkMLoc df mname path =\n pure (mkHomeModLocation (initFinderOpts df) mname path)\n addHomeMod henv =\n addHomeModuleToFinder (hsc_FC henv) (hsc_home_unit henv)\n#else\n let mkMLoc = mkHomeModLocation\n addHomeMod = addHomeModuleToFinder\n#endif\n\n liftIO\n (do mloc <- mkMLoc dflags mod_name file\n mmod <- addHomeMod hsc_env mod_name mloc\n obj_date <- tryGetObjectDate (ml_obj_file mloc)\n#if MIN_VERSION_ghc(9,4,0)\n src_hash <- getFileHash file\n dyn_obj_date <- modificationTimeIfExists (ml_dyn_obj_file mloc)\n#else\n hs_date <- getModificationUTCTime file\n#endif\n iface_date <- maybeGetIfaceDate dflags mloc\n hie_date <- modificationTimeIfExists (ml_hie_file mloc)\n return ModSummary { ms_mod = mmod\n , ms_hsc_src = HsSrcFile\n , ms_location = mloc\n#if MIN_VERSION_ghc(9,4,0)\n , ms_hs_hash = src_hash\n , ms_dyn_obj_date = dyn_obj_date\n , ms_ghc_prim_import = _ghc_prim_import\n#else\n , ms_hs_date = hs_date\n#endif\n , ms_obj_date = obj_date\n , ms_iface_date = iface_date\n , ms_hie_date = hie_date\n , ms_parsed_mod = mb_pm\n , ms_srcimps = srcimps\n , ms_textual_imps = txtimps\n , ms_hspp_file = file\n , ms_hspp_opts = dflags\n , ms_hspp_buf = mb_buf })\n\n-- | Update timestamps of given 'ModSummary'.\nupdateSummaryTimestamps\n :: MonadIO m => DynFlags -> Bool -> ModSummary -> m ModSummary\nupdateSummaryTimestamps dflags obj_allowed ms = do\n -- Check timestamps, update the obj_data, iface_date, and hie_date to reflect\n -- the changes in file system from last compilation. See\n -- 'GhcMake.checkSummaryTimestamp' called during down sweep, which does\n -- similar works.\n let ms_loc = ms_location ms\n obj_date <-\n if isObjectBackend dflags || obj_allowed\n then liftIO (modificationTimeIfExists (ml_obj_file ms_loc))\n else return Nothing\n iface_date <- liftIO (maybeGetIfaceDate dflags ms_loc)\n hie_date <- liftIO (modificationTimeIfExists (ml_hie_file ms_loc))\n -- XXX: Fill in the list of required ModSummary.\n return (ms { ms_obj_date = obj_date\n , ms_iface_date = iface_date\n , ms_hie_date = hie_date })\n\n-- See: \"GhcMake.summariseModule\"\nassertModuleNameMatch\n :: MonadIO m => DynFlags -> FilePath -> Maybe HsParsedModule -> m ()\nassertModuleNameMatch dflags file mb_pm =\n case mb_pm of\n Just pm | Just lsaw <- hsmodName (unLoc (hpm_module pm))\n , let wanted = asModuleName file\n , let saw = moduleNameString (unLoc lsaw)\n , saw /= \"Main\"\n , saw /= wanted\n -> let msg = text \"File name does not match module\"\n $$ text \"Saw:\" <+> quotes (text saw)\n $$ text \"Expected:\" <+> quotes (text wanted)\n loc = getLocA lsaw\n in throwOneError (mkPlainWrappedMsg dflags loc msg)\n _ -> return ()\n\n-- See: GhcMake.maybeGetIfaceDate\nmaybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)\nmaybeGetIfaceDate dflags location =\n if writeIface dflags\n then modificationTimeIfExists (ml_hi_file location)\n else return Nothing\n where\n#if MIN_VERSION_ghc(9,4,0)\n writeIface = const True\n#else\n writeIface = writeInterfaceOnlyMode\n#endif\n\n-- | Dump the Haskell source code of given 'ModSummary' if options in 'FnkEnv'\n-- are set. Will not dump when the 'ModSummary' was found in current home\n-- package table.\ndumpHsSourceCode :: (MonadIO m, HasDynFlags m)\n => FnkEnv -> HscEnv -> Maybe SPState -> ModSummary -> m ()\ndumpHsSourceCode fnk_env hsc_env mb_sp ms =\n when (fopt Fnk_dump_hs fnk_env || isJust (envHsOutDir fnk_env)) $\n case lookupHpt (hsc_HPT hsc_env) (ms_mod_name ms) of\n Nothing -> dumpModSummary fnk_env hsc_env mb_sp ms\n Just _ -> return ()\n\n-- | Dump the module contents of given 'ModSummary'.\ndumpModSummary\n :: (MonadIO m, HasDynFlags m)\n => FnkEnv -> HscEnv -> Maybe SPState -> ModSummary -> m ()\ndumpModSummary fnk_env hsc_env mb_sp ms =\n case mb_sp of\n Just sp | Just pm <- ms_parsed_mod ms -> work sp pm\n _ -> return ()\n where\n work sp pm = do\n let hsrc = gen sp pm\n hdr = text (unwords [colons, orig_path, colons])\n debugWhen fnk_env Fnk_dump_hs [\"\", hdr, \"\" , hsrc, \"\"]\n mapM_ (doWrite hsrc) (envHsOutDir fnk_env)\n doWrite hsrc dir = do\n let out_path = get_out_path dir\n out_dir = takeDirectory out_path\n traceSummary fnk_env \"dumpModSummary\" [\"Writing to\" <+> text out_path]\n let dflags = hsc_dflags hsc_env\n#if MIN_VERSION_ghc(9,6,0)\n unqual = icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)\n#elif MIN_VERSION_ghc(9,2,0)\n unqual = icPrintUnqual (hsc_unit_env hsc_env) (hsc_IC hsc_env)\n#else\n unqual = icPrintUnqual dflags (hsc_IC hsc_env)\n#endif\n#if MIN_VERSION_ghc(9,0,0)\n emit hdl = printForUser dflags hdl unqual AllTheWay hsrc\n#else\n emit hdl = printForUser dflags hdl unqual hsrc\n#endif\n liftIO (do createDirectoryIfMissing True out_dir\n withFile out_path WriteMode emit)\n get_out_path dir =\n let mname = moduleName (ms_mod ms)\n bname = takeBaseName orig_path\n file_name = if looksLikeModuleName bname\n then moduleNameSlashes mname\n else bname\n in dir file_name <.> \"hs\"\n gen sp pm = toHsSrc sp (Hsrc (unLoc (hpm_module pm)))\n orig_path = ms_hspp_file ms\n colons = replicate 20 ';'\n\n-- See: \"hscParse'\" in GHC.Driver.Main (or main/HscMain.hs in ghc < 9).\ndumpParsedAST :: MonadIO m => HscEnv -> DynFlags -> ModSummary -> m ()\ndumpParsedAST _hsc_env dflags ms =\n liftIO\n (case ms_parsed_mod ms of\n Just pm ->\n do let rdr_module = hpm_module pm\n dumpIfSet_dyn_hs dflags Opt_D_dump_parsed \"Parser\"\n (ppr rdr_module)\n dumpIfSet_dyn_hs dflags Opt_D_dump_parsed_ast \"Parser AST\"\n (show_ast_data NoBlankSrcSpan rdr_module)\n dumpIfSet_dyn_txt dflags Opt_D_source_stats \"Source Statistic\"\n (ppSourceStats False rdr_module)\n Nothing -> return ())\n where\n#if MIN_VERSION_ghc(9,2,0)\n show_ast_data sp = showAstData sp NoBlankEpAnnotations\n#else\n show_ast_data = showAstData\n#endif\n#if MIN_VERSION_ghc(9,4,0)\n dumpIfSet_dyn_hs = putDumpFileMaybe_for FormatHaskell\n dumpIfSet_dyn_txt = putDumpFileMaybe_for FormatText\n putDumpFileMaybe_for format df flag label sdoc =\n let hsc_env = hscSetFlags df _hsc_env\n in putDumpFileMaybe (hsc_logger hsc_env) flag label format sdoc\n#elif MIN_VERSION_ghc(9,2,0)\n dumpIfSet_dyn_hs = dumpIfSet_dyn_with FormatHaskell\n dumpIfSet_dyn_txt = dumpIfSet_dyn_with FormatText\n dumpIfSet_dyn_with format df flag label sdoc =\n dumpIfSet_dyn (hsc_logger _hsc_env) df flag label format sdoc\n#elif MIN_VERSION_ghc(9,0,0)\n dumpIfSet_dyn_hs = dumpIfSet_dyn_with FormatHaskell\n dumpIfSet_dyn_txt = dumpIfSet_dyn_with FormatText\n dumpIfSet_dyn_with format df flag label sdoc =\n dumpIfSet_dyn df flag label format sdoc\n#else\n dumpIfSet_dyn_hs = dumpIfSet_dyn\n dumpIfSet_dyn_txt = dumpIfSet_dyn\n#endif\n\n-- Note [Chasing dependencies of required home package module]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- When home package module were required, recompilation happen when any of the\n-- required module was changed.\n--\n-- The required modules lives in a dedicated HscEnv (the one stored at\n-- `envSessionForExpand' field in 'FnkEnv') which uses bytecode interpreter.\n-- Required modules are stored as 'UsageFile' in the 'mi_usages' field of\n-- 'ModIface', not as 'UsageHomeModule', because if stored as 'UsageHomeModule',\n-- required modules will compiled as object codes, which is not used by the\n-- macro expander at the moment.\n--\n-- To chase dependencies of the required home package modules, the\n-- \"requiredDependencies\" functions temporary switch to the macro expansion\n-- session and recursively chases the file paths of imported modules and\n-- required modules.\n\nrequiredDependencies :: [ModSummary] -> Fnk [FilePath]\nrequiredDependencies mss = do\n hsc_env0 <- getSession\n let getDeps he = pure $! nub $! foldl' (requiredDependency he) [] mss\n if isExpanding (hsc_dflags hsc_env0)\n then getDeps hsc_env0\n else do\n mb_hsc_env <- envSessionForExpand <$> getFnkEnv\n case mb_hsc_env of\n Just hsc_env -> getDeps hsc_env\n Nothing -> getDeps hsc_env0\n\nrequiredDependency :: HscEnv -> [FilePath] -> ModSummary -> [FilePath]\nrequiredDependency hsc_env = go\n where\n go acc ms =\n case ml_hs_file (ms_location ms) of\n Nothing -> acc\n Just me -> dep_files (me : acc) ms\n\n dep_files acc ms =\n let mg = hsc_mod_graph hsc_env\n hpt = hsc_HPT hsc_env\n acc1 = find_require_paths hpt acc ms\n in foldl' (find_import_path mg) acc1 (msHomeAllimps ms)\n\n find_import_path mg acc mod_name =\n let mdl = mkModuleFromHscEnv hsc_env mod_name\n in maybe acc (go acc) (mgLookupModule' mg mdl)\n\n find_require_paths hpt acc ms =\n case lookupHpt hpt (ms_mod_name ms) of\n Nothing -> acc\n Just hmi -> foldl' req_paths acc (mi_usages (hm_iface hmi))\n\n req_paths acc usage =\n case usage of\n -- Recursively calling `go' with the ModSummary referred by the usage\n -- file path, but only for Haskell and Finkel source codes.\n --\n -- It is important to track only those \"UsageFile\"s of source code that\n -- potentially containing macro definitions. Otherwise the compilation\n -- time of modules containing \":require\" of home package module was\n -- noticeably slow in ghc 9.4.2.\n UsageFile {usg_file_path = path_fs} | isFnkFile path || isHsFile path ->\n let mb_ms1 = find is_my_path mss\n is_my_path = (Just path ==) . ml_hs_file . ms_location\n mss = mgModSummaries' (hsc_mod_graph hsc_env)\n acc1 = path : acc\n in maybe acc1 (go acc1) mb_ms1\n where\n path = unpackFSFor908 path_fs\n _ -> acc\n\n#if MIN_VERSION_ghc(9,8,0)\n unpackFSFor908 = unpackFS\n#else\n unpackFSFor908 = id\n#endif\n\nmkModuleFromHscEnv :: HscEnv -> ModuleName -> Module\nmkModuleFromHscEnv hsc_env =\n#if MIN_VERSION_ghc(9,2,0)\n mkHomeModule (hsc_home_unit hsc_env)\n#elif MIN_VERSION_ghc(9,0,0)\n mkModule (homeUnit (hsc_dflags hsc_env))\n#else\n mkModule (thisPackage (hsc_dflags hsc_env))\n#endif\n\n-- | Trace function for this module.\ntraceSummary\n :: (MonadIO m, HasDynFlags m) => FnkEnv -> SDoc -> [SDoc] -> m ()\ntraceSummary fnk_env name msgs0 =\n let msgs1 = hcat [\";;; [Language.Finkel.Make.Summary.\", name, \"]:\"] : msgs0\n in debugWhen fnk_env Fnk_trace_make msgs1\n\n-- | Run given builder.\nbuildHsSyn\n :: Builder a -- ^ Builder to use.\n -> [Code] -- ^ Input codes.\n -> Fnk a\nbuildHsSyn bldr forms = do\n dflags <- getDynFlags\n qualify <- envQualifyQuotePrimitives <$> getFnkEnv\n case evalBuilder dflags qualify bldr forms of\n Right a -> return a\n Left (SyntaxError code msg) -> finkelSrcError code msg\n\n\n-- ------------------------------------------------------------------------\n-- ModuleGraph\n-- ------------------------------------------------------------------------\n\nextendMG' :: ModuleGraph -> ModSummary -> ModuleGraph\n{-# INLINABLE extendMG' #-}\n\nmgElemModule' :: ModuleGraph -> Module -> Bool\n{-# INLINABLE mgElemModule' #-}\n\nmkModuleGraph' :: [ModSummary] -> ModuleGraph\n{-# INLINABLE mkModuleGraph' #-}\n\nmgModSummaries' :: ModuleGraph -> [ModSummary]\n{-# INLINABLE mgModSummaries' #-}\n\nmgLookupModule' :: ModuleGraph -> Module -> Maybe ModSummary\n{-# INLINABLE mgLookupModule' #-}\n\n#if MIN_VERSION_ghc(9,4,0)\nextendMG' g ms = Graph.extendMG' g (ModuleNode [] ms)\nmgElemModule' mg m = moduleName m `elem` map ms_mod_name (mgModSummaries mg)\nmkModuleGraph' = mkModuleGraph . map (\\ms -> ModuleNode [] ms)\nmgModSummaries' = mgModSummaries\nmgLookupModule' = mgLookupModule\n#elif MIN_VERSION_ghc(9,2,0)\nextendMG' g ms = extendMG g (extendModSummaryNoDeps ms)\nmgElemModule' = mgElemModule\nmkModuleGraph' = mkModuleGraph . map extendModSummaryNoDeps\nmgModSummaries' = mgModSummaries\nmgLookupModule' = mgLookupModule\n#else\nextendMG' = extendMG\nmgElemModule' = mgElemModule\nmkModuleGraph' = mkModuleGraph\nmgModSummaries' = mgModSummaries\nmgLookupModule' = mgLookupModule\n#endif\n\n-- The `ms_home_allimps' function did not exist until ghc 8.10.x, and removed in\n-- ghc 9.4.x.\n#if MIN_VERSION_ghc(9,4,0)\n-- XXX: Use 'GHC.Unit.Module.ModSummary.home_imps' ?\nmsHomeAllimps :: ModSummary -> [ModuleName]\nmsHomeAllimps = map (unLoc . snd) . ms_imps\n#else\nmsHomeAllimps :: ModSummary -> [ModuleName]\nmsHomeAllimps = ms_home_allimps\n#endif\n\n-- ------------------------------------------------------------------------\n-- Header parser\n-- ------------------------------------------------------------------------\n\npreprocess' :: HscEnv -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath)\n{-# INLINABLE preprocess' #-}\n\npreprocess' hsc_env (path, mb_phase) = do\n et_result <- preprocess hsc_env path Nothing mb_phase\n case et_result of\n# if MIN_VERSION_ghc(9,4,0)\n Left err -> throwErrors (fmap GhcDriverMessage err)\n# else\n Left err -> throwErrors err\n# endif\n Right pair -> return pair\n\ngetImports' :: DynFlags -> StringBuffer -> FilePath -> FilePath\n -> IO ([(RawPkgQual, Located ModuleName)],\n [(RawPkgQual, Located ModuleName)],\n Bool,\n Located ModuleName)\n{-# INLINABLE getImports' #-}\n\n#if MIN_VERSION_ghc(9,4,0)\ngetImports' dflags sbuf pp_path path = do\n let imp_prelude = xopt ImplicitPrelude dflags\n popts = initParserOpts dflags\n et_ret <- getImports popts imp_prelude sbuf pp_path path\n either (throwErrors . fmap GhcPsMessage) pure et_ret\n#elif MIN_VERSION_ghc(9,2,0)\ngetImports' dflags sbuf pp_path path = do\n let imp_prelude = xopt ImplicitPrelude dflags\n popts = initParserOpts dflags\n et_ret <- getImports popts imp_prelude sbuf pp_path path\n case et_ret of\n Right (simps, timps, lm) -> pure (simps, timps, False, lm)\n Left err -> throwErrors (fmap pprError err)\n#else\ngetImports' dflags sbuf pp_path path = do\n et_ret <- getImports dflags sbuf pp_path path\n case et_ret of\n Right (simps, timps, lm) -> pure (simps, timps, False, lm)\n Left err -> throwErrors err\n#endif\n\n-- ------------------------------------------------------------------------\n-- Timing\n-- ------------------------------------------------------------------------\n\n-- | Label and wrap the given action with 'withTiming'.\nwithTiming' :: String -> Fnk a -> Fnk a\n#if MIN_VERSION_ghc(9,2,0)\nwithTiming' label = withTimingM (text label) (const ())\n#else\nwithTiming' label = withTimingD (text label) (const ())\n#endif\n{-# INLINABLE withTiming' #-}\n\n-- | 'True' if the backend used by given 'DynFlags' produces object code.\nisObjectBackend :: DynFlags -> Bool\n#if MIN_VERSION_ghc(9,6,0)\nisObjectBackend = backendWritesFiles . backend\n#elif MIN_VERSION_ghc(9,2,0)\nisObjectBackend = backendProducesObject . backend\n#else\nisObjectBackend = isObjectTarget . hscTarget\n#endif\n{-# INLINEABLE isObjectBackend #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Make/TargetSource.hs", "content": "{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE CPP #-}\n{-# LANGUAGE TupleSections #-}\n-- | Module for source code file path look up.\nmodule Language.Finkel.Make.TargetSource\n (\n -- * Target unit\n TargetUnit\n , emptyTargetUnit\n , findTargetUnit\n , findTargetUnitMaybe\n , targetUnitName\n\n -- * Target source\n , TargetSource(..)\n , targetSourcePath\n\n -- * Finder functions\n , findTargetModuleName\n , findTargetModuleNameMaybe\n , findTargetSource\n , findTargetSourceMaybe\n , findTargetSourceWithPragma\n\n -- * File type related functions\n , asModuleName\n , isFnkFile\n , isHsFile\n , findPragmaString\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Applicative (Alternative (..))\nimport Control.Exception (SomeException, try)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.Char (isUpper)\nimport Data.List (isSubsequenceOf)\n\n-- directory\nimport System.Directory (doesFileExist)\n\n-- filepath\nimport System.FilePath (dropExtension, normalise, pathSeparator,\n replaceExtension, splitPath, takeExtension,\n (<.>), ())\n\n-- ghc\nimport GHC_Data_StringBuffer (StringBuffer, atEnd, hGetStringBuffer, nextChar)\nimport GHC_Driver_Phases (Phase)\nimport GHC_Driver_Session (DynFlags (..))\nimport GHC_Types_SourceError (throwOneError)\nimport GHC_Types_SrcLoc (GenLocated (..), Located)\nimport GHC_Unit_Module (ModuleName, mkModuleName, moduleNameSlashes,\n moduleNameString)\nimport GHC_Utils_Misc (looksLikeModuleName)\nimport GHC_Utils_Outputable (Outputable (..), sep, text)\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Session (augmentByWorkingDirectory)\n#endif\n\n-- Internal\nimport Language.Finkel.Error\n\n\n-- ---------------------------------------------------------------------\n--\n-- Target unit\n--\n-- ---------------------------------------------------------------------\n\n-- | Unit for compilation target.\n--\n-- Simply a 'TargetSource' paired with 'Maybe' 'Phase'.\ntype TargetUnit = (TargetSource, Maybe Phase)\n\n-- | Make empty 'TargetUnit' from 'TargetSource'\nemptyTargetUnit :: TargetSource -> TargetUnit\nemptyTargetUnit ts = (ts, Nothing)\n\n-- | Get 'TargetUnit' from pair of module name or file path, and phase.\nfindTargetUnit\n :: MonadIO m => DynFlags -> (Located String, Maybe Phase) -> m TargetUnit\nfindTargetUnit dflags (lpath,mbp) =\n (,) <$> findTargetSource dflags lpath <*> pure mbp\n\nfindTargetUnitMaybe\n :: MonadIO m\n => DynFlags -> (Located String, Maybe Phase) -> m (Maybe TargetUnit)\nfindTargetUnitMaybe dflags (lpath,mbp) =\n fmap (, mbp) <$> findTargetSourceMaybe dflags lpath\n\n-- | Get 'ModuleName' from given 'TargetUnit'.\ntargetUnitName :: TargetUnit -> ModuleName\ntargetUnitName (ts, _) =\n case ts of\n FnkSource _ mn -> mn\n HsSource _ mn -> mn\n _ -> mkModuleName \"module-name-unknown\"\n\n\n-- ---------------------------------------------------------------------\n--\n-- Target source\n--\n-- ---------------------------------------------------------------------\n\n-- | Data type to represent target source.\ndata TargetSource\n = FnkSource FilePath ModuleName\n -- ^ Finkel source with file path of the source code and module name.\n | HsSource FilePath ModuleName\n -- ^ Haskell source with file path of the source code and module name.\n | OtherSource FilePath\n -- ^ Other source with file path of other contents.\n\ninstance Show TargetSource where\n show s = case s of\n FnkSource path _ -> \"FnkSource \" ++ show path\n HsSource path _ -> \"HsSource \" ++ show path\n OtherSource path -> \"OtherSource \" ++ show path\n\ninstance Outputable TargetSource where\n ppr s =\n case s of\n FnkSource path mdl -> sep [text \"FnkSource\", text path, ppr mdl]\n HsSource path _ -> sep [text \"HsSource\", text path]\n OtherSource path -> sep [text \"OtherSource\", text path]\n\n-- | Get the file path of given 'TargetSource'.\ntargetSourcePath :: TargetSource -> FilePath\ntargetSourcePath mt =\n case mt of\n FnkSource path _ -> path\n HsSource path _ -> path\n OtherSource path -> path\n\n-- | True if given file has Finkel extension.\nisFnkFile :: FilePath -> Bool\nisFnkFile path = takeExtension path == \".fnk\"\n\n-- | True if given file has Haskell extension.\nisHsFile :: FilePath -> Bool\nisHsFile path = takeExtension path `elem` [\".hs\", \".lhs\"]\n\n-- | Construct module name from given 'String'.\nasModuleName :: String -> String\nasModuleName name =\n if looksLikeModuleName name\n then name\n else map sep_to_dot (concat names)\n where\n -- Taking the directory names from last to first, to support auto generated\n -- modules made by stack.\n names = reverse (takeWhile startsWithUpper\n (reverse (splitPath (dropExtension name))))\n startsWithUpper cs = case cs of\n [] -> False\n c:_ -> isUpper c\n sep_to_dot c =\n if c == pathSeparator\n then '.'\n else c\n\n-- | Find source code file path by module name.\n--\n-- Current approach for source code lookup is search for file with @*.fnk@\n-- suffix first. Return it if found, otherwise search file with @*.hs@ suffix.\n--\n-- This searching strategy can used when compiling cabal package containing\n-- mixed codes with '*.fnk' and '*.hs' suffixes.\n--\nfindFileInImportPaths :: MonadIO m\n => [FilePath] -- ^ Directories to look for.\n -> String -- ^ Module name or file name.\n -> m (Maybe FilePath)\n -- ^ File path of the module, if found.\nfindFileInImportPaths dirs modName = do\n let suffix = takeExtension modName\n moduleFileName = moduleNameSlashes (mkModuleName modName)\n moduleFileName' = if suffix `elem` [\".fnk\", \".hs\", \".c\"]\n then modName\n else moduleFileName <.> \"fnk\"\n search mb_hs ds =\n case ds of\n [] -> return mb_hs\n d:ds' -> do\n -- Extension not yet sure for `aPath', so searching both '.fnk' and\n -- '.hs' files.\n let aPath = normalise (d moduleFileName')\n hsPath = replaceExtension aPath \".hs\"\n exists <- liftIO (doesFileExist aPath)\n if exists\n then return (Just aPath)\n else do\n exists' <- liftIO (doesFileExist hsPath)\n if exists'\n then search (mb_hs <|> Just hsPath) ds'\n else search mb_hs ds'\n dirs' = if \".\" `elem` dirs\n then dirs\n else dirs ++ [\".\"]\n search Nothing dirs'\n\n-- | Like 'findTargetSource', but takes 'ModuleName' argument.\nfindTargetModuleName\n :: MonadIO m => DynFlags -> Located ModuleName -> m TargetSource\nfindTargetModuleName dflags =\n findTargetSource dflags . fmap moduleNameString\n\n-- | Like 'findTargetSourceMaybe', but takes 'ModuleName' argument.\nfindTargetModuleNameMaybe\n :: MonadIO m => DynFlags -> Located ModuleName -> m (Maybe TargetSource)\nfindTargetModuleNameMaybe dflags =\n findTargetSourceMaybe dflags . fmap moduleNameString\n\n-- | Like 'findTargetSource', but the result wrapped in 'Maybe'.\nfindTargetSourceMaybe\n :: MonadIO m => DynFlags -> Located String -> m (Maybe TargetSource)\nfindTargetSourceMaybe dflags modName = do\n et_ret <- liftIO (try (findTargetSource dflags modName))\n case et_ret of\n Right found -> return (Just found)\n Left _err -> let _err' = _err :: SomeException\n in return Nothing\n\n-- | Find 'TargetSource' from command line argument. This function throws\n-- 'SourceError' when the target source was not found.\nfindTargetSource :: MonadIO m => DynFlags -> Located String -> m TargetSource\nfindTargetSource = findTargetSourceWithPragma \";;;\"\n\n-- | Like 'findTargetSource', but with given pragma string.\nfindTargetSourceWithPragma\n :: MonadIO m => String -> DynFlags -> Located String -> m TargetSource\nfindTargetSourceWithPragma pragma dflags (L l modNameOrFilePath)= do\n let import_paths0 = importPaths dflags\n#if MIN_VERSION_ghc(9,4,0)\n -- See GHC.Unit.Finder.augmentImports which is not exported.\n import_paths1 = map (augmentByWorkingDirectory dflags) import_paths0\n#else\n import_paths1 = import_paths0\n#endif\n mb_inputPath <- findFileInImportPaths import_paths1 modNameOrFilePath\n let detectSource path\n | isFnkFile path = return (FnkSource path modName)\n | isHsFile path = do\n buf <- liftIO (hGetStringBuffer path)\n if findPragmaString pragma buf\n then return (FnkSource path modName)\n else return (HsSource path modName)\n | otherwise = return (OtherSource path)\n where\n modName = mkModuleName (asModuleName path)\n case mb_inputPath of\n Just path -> detectSource path\n Nothing ->\n let doc = text (\"cannot find target source: \" ++ modNameOrFilePath)\n in throwOneError (mkPlainWrappedMsg dflags l doc)\n\n\n-- ------------------------------------------------------------------------\n--\n-- Finkel buffer detection\n--\n-- ------------------------------------------------------------------------\n\nfindPragmaString :: String -> StringBuffer -> Bool\nfindPragmaString pragma buf = findInFirstNLines buf 3 (isSubsequenceOf pragma)\n{-# INLINABLE findPragmaString #-}\n\nfindInFirstNLines :: StringBuffer -> Int -> (String -> Bool) -> Bool\nfindInFirstNLines buf n test = go n buf\n where\n -- False when the source code contained less number of lines than\n -- the number specified by the argument.\n go i buf0 =\n not (i == 0 || atEnd buf0) &&\n (case getStringBufferLine buf0 of\n (l, buf1) -> test l || go (i-1) buf1)\n{-# INLINABLE findInFirstNLines #-}\n\ngetStringBufferLine :: StringBuffer -> (String, StringBuffer)\ngetStringBufferLine = go []\n where\n go !acc buf0 =\n let (c, buf1) = nextChar buf0\n in if c == '\\n'\n then (reverse acc, buf1)\n else go (c:acc) buf1\n{-# INLINABLE getStringBufferLine #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Make/Trace.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Language.Finkel.Make.Trace\n ( traceMake\n , traceMake'\n , nvcOrNone\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Monad.IO.Class (MonadIO (..))\n\n-- ghc\nimport GHC_Driver_Session (DynFlags, HasDynFlags (..))\nimport GHC_Utils_Outputable (Outputable (..), SDoc, hcat, nest, vcat)\n\n-- Internal\nimport Language.Finkel.Fnk (FnkDebugFlag (..), FnkEnv, debugWhen')\n\n-- | Trace function for 'make' related modules.\ntraceMake\n :: (MonadIO m, HasDynFlags m) => FnkEnv -> SDoc -> [SDoc] -> m ()\ntraceMake fnk_env fn_name msgs0 =\n getDynFlags >>= \\df -> traceMake' df fnk_env fn_name msgs0\n\n-- | Like 'traceMake', but takes 'DynFlags' from argument.\ntraceMake'\n :: MonadIO m => DynFlags -> FnkEnv -> SDoc -> [SDoc] -> m ()\ntraceMake' dflags fnk_env fn_name msgs0 =\n let msgs1 = (hcat [\";;; [Language.Finkel.Make.\", fn_name, \"]:\"] : msgs0)\n in debugWhen' dflags fnk_env Fnk_trace_make msgs1\n\n-- | Nested 'vcat' or text @\"none\"@.\nnvcOrNone :: Outputable a => [a] -> SDoc\nnvcOrNone xs = nest 2 sdoc\n where\n sdoc =\n if null xs\n then \"none\"\n else vcat (map ppr xs)\n" }, { "path": "finkel-kernel/src/Language/Finkel/Make.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n-- | Make mode for Finkel compiler.\nmodule Language.Finkel.Make\n (\n -- * Make functions\n make\n , makeFromRequire\n , makeFromRequirePlugin\n , simpleMake\n\n -- * Summary\n , fnkSourceToSummary\n\n -- * Session related functions\n , initSessionForMake\n , setContextModules\n , discardInteractiveContext\n\n -- * Macro expander session related functions\n , withExpanderSettings\n , clearGlobalSession\n , clearExpandedCodeCache\n\n -- * Syntax builder utility\n , buildHsSyn\n\n -- * Target unit utilities\n , TargetUnit\n , TargetSource(..)\n , findTargetModuleName\n , findTargetModuleNameMaybe\n , findTargetSource\n , findTargetSourceMaybe\n , asModuleName\n , isFnkFile\n , isHsFile\n\n -- * ParsedResult\n , mkParsedResult\n ) where\n\n#include \"ghc_modules.h\"\n\n\n-- base\nimport Control.Monad (foldM, unless, void, (>=>))\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.Bifunctor (first)\nimport Data.Foldable (find)\n\n#if MIN_VERSION_ghc(9,4,0)\nimport Data.Maybe (catMaybes)\n-- Module GHC.Fingerprint is from package 'base'.\nimport GHC.Fingerprint (getFileHash)\n#endif\n\n-- container\n#if MIN_VERSION_ghc(9,4,0)\nimport qualified Data.Map as Map\n#endif\n\n-- filepath\nimport System.FilePath (splitExtension)\n\n-- ghc\nimport GHC (guessTarget,\n setSessionDynFlags,\n setTargets)\nimport GHC_Driver_Env (HscEnv (..), runHsc)\nimport GHC_Driver_Main (Messager)\nimport GHC_Driver_Make (LoadHowMuch (..), load')\nimport GHC_Driver_Monad (GhcMonad (..))\nimport GHC_Driver_Phases (Phase (..))\nimport GHC_Driver_Session (DynFlags (..),\n GeneralFlag (..),\n GhcMode (..),\n HasDynFlags (..), gopt,\n gopt_set, gopt_unset)\nimport GHC_Hs_ImpExp (simpleImportDecl)\nimport GHC_Plugins (Plugin (..), withPlugins)\nimport GHC_Runtime_Context (InteractiveImport (..))\nimport GHC_Runtime_Eval (setContext)\nimport GHC_Runtime_Loader (initializePlugins)\nimport GHC_Types_Basic (SuccessFlag (..))\nimport GHC_Types_SourceError (throwOneError)\nimport GHC_Types_SrcLoc (GenLocated (..), Located,\n getLoc, unLoc)\nimport GHC_Unit_Finder (FindResult (..),\n findExposedPackageModule)\nimport GHC_Unit_Module (ModuleName, mkModuleName)\nimport GHC_Unit_Module_Graph (ModuleGraph)\nimport GHC_Unit_Module_ModSummary (ModSummary (..),\n ms_mod_name)\nimport GHC_Utils_Outputable (Outputable (..), SDoc,\n brackets, nest, text, vcat,\n (<+>))\n\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Driver.Config.Diagnostic (initIfaceMessageOpts)\nimport GHC.Iface.Errors.Ppr (missingInterfaceErrorDiagnostic)\nimport GHC.Types.Error (mkUnknownDiagnostic)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Config.Finder (initFinderOpts)\nimport GHC.Driver.Env (hscActiveUnitId,\n hscSetFlags, hsc_HUG,\n hsc_units)\nimport GHC.Driver.Plugins (ParsedResult (..),\n PsMessages (..))\nimport GHC.Driver.Session (GhcLink (..))\nimport GHC.Hs (HsParsedModule)\nimport GHC.Types.Error (emptyMessages)\nimport GHC.Types.PkgQual (PkgQual (..))\nimport GHC.Unit.Env (homeUnitEnv_dflags,\n unitEnv_foldWithKey)\nimport GHC.Unit.Module.Graph (ModNodeKeyWithUid (..),\n ModuleGraphNode (..),\n NodeKey (..), mkModuleGraph,\n mkNodeKey,\n moduleGraphNodeUnitId,\n msKey)\nimport GHC.Unit.Module.ModSummary (ms_imps)\nimport GHC.Unit.Types (GenWithIsBoot (..),\n IsBootInterface (..))\n#else\nimport GHC_Utils_Misc (getModificationUTCTime)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Session (ways)\nimport GHC.Platform.Ways (Way (..), hasWay)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Iface.Load (cannotFindModule)\n#else\nimport GHC_Unit_Finder (cannotFindModule)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Unit_Types (moduleUnit)\n#else\nimport GHC_Unit_Module (Module (..), moduleUnitId)\n#endif\n\nimport GHC_Driver_Make (depanal)\nimport GHC_Types_Target (Target (..), TargetId (..))\n\n-- internal\nimport Language.Finkel.Error\nimport Language.Finkel.Fnk\nimport Language.Finkel.Make.Cache\nimport Language.Finkel.Make.Recompile\nimport Language.Finkel.Make.Session\nimport Language.Finkel.Make.Summary\nimport Language.Finkel.Make.TargetSource\nimport Language.Finkel.Make.Trace\n\n\n-- ---------------------------------------------------------------------\n--\n-- The make function\n--\n-- ---------------------------------------------------------------------\n\n-- Note [Requiring home package module]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- The problem in dependency resolution when requiring home package module is,\n-- we need module imports list to make ModSummary, but modules imports could not\n-- be obtained unless the source code is macro expanded. However,\n-- macro-expansion may use macros from other home package modules, which are not\n-- loaded to GHC session yet.\n--\n-- Currently, compilation is done with recursively calling 'make' function from\n-- 'require' macro, during macro-expansion.\n--\n-- Once these dependency resolution works were tried with custom user hooks in\n-- cabal setup script. However, as of Cabal version 1.24.2, building part of\n-- some modules from contents of cabal configuration file were not so\n-- easy. Though when cabal support multiple libraraies, situation might change.\n\n-- | Finkel variant of @\"ghc --make\"@.\nmake\n :: [(Located FilePath, Maybe Phase)]\n -- ^ List of pairs of input file and phase.\n -> Bool -- ^ Force recompilation when 'True'.\n -> Maybe FilePath -- ^ Output file, if any.\n -> Fnk SuccessFlag\nmake infiles force_recomp mb_output = do\n -- Setting ghcMode as done in ghc's \"Main.hs\".\n --\n -- Also setting the force recompilation field from the argument, since the\n -- current ghc may running in OneShot mode instead of CompManager mode until\n -- this point. Some of the dump flags will turn the force recompilation flag\n -- on. Ghc does this in DynFlags.{setDumpFlag',forceRecompile}.\n dflags0 <- getDynFlags\n let dflags1 = set_outputFile mb_output $ dflags0 {ghcMode = CompManager}\n dflags2 = if force_recomp\n then gopt_set dflags1 Opt_ForceRecomp\n else gopt_unset dflags1 Opt_ForceRecomp\n#if MIN_VERSION_ghc(9,2,0)\n set_outputFile f d = d { outputFile_ = f }\n#else\n set_outputFile f d = d { outputFile = f }\n#endif\n setDynFlags dflags2\n dflags3 <- getDynFlags\n\n fnk_env <- getFnkEnv\n dumpDynFlags fnk_env \"Language.Finkel.Make.make\" dflags3\n\n -- Decide the kind of sources of the inputs, inputs arguments could be file\n -- paths, or module names.\n targets <- mapM (findTargetUnit dflags3) infiles\n\n -- Do the compilation work.\n old_summaries <- fmap (mgModSummaries' . hsc_mod_graph) getSession\n make1 LoadAllTargets old_summaries targets\n\n-- | Calls 'GHC.setSessionDynFlags' and do some works to initialize session.\ninitSessionForMake :: Fnk ()\ninitSessionForMake = do\n dflags0 <- getDynFlags\n\n -- Initializing the DynFlags for plugin at this point, to avoid repeated calls\n -- of \"initializePlugins\" before applying plugin action \"parsedResultAction\".\n -- The 'setSessionDynFlags' changes the current 'DynFlags', so getting the\n -- updated \"DynFlags\". Returned list of 'InstalledUnitId's are ignored.\n _preload0 <- setSessionDynFlags dflags0\n hsc_env <- getSession\n#if MIN_VERSION_ghc(9,2,0)\n hsc_env1 <- liftIO $! initializePlugins hsc_env\n setSession hsc_env1\n let dflags1 = hsc_dflags hsc_env1\n#else\n let dflags0' = hsc_dflags hsc_env\n dflags1 <- liftIO $! initializePlugins hsc_env dflags0'\n#endif\n\n -- Mangle the function name in \"mainFunIs\" field, to support mangled name,\n -- e.g. to support \"foo-bar-buzz\" instead of \"foo_bar_buzz\".\n let mangle = map (\\c -> if c == '-' then '_' else c)\n dflags2 = dflags1 { mainFunIs = fmap mangle (mainFunIs dflags1) }\n\n -- ... And setting and getting the DynFlags again.\n _preload1 <- setSessionDynFlags dflags2\n dflags3 <- getDynFlags\n\n -- Load module names in FnkEnv to current interactive context.\n fnk_env <- getFnkEnv\n let ctx_modules = envContextModules fnk_env\n unless (null ctx_modules) (setContextModules ctx_modules)\n\n -- Verbosity level could be specified from environment variable and command\n -- line option.\n debug0 <- getFnkDebug\n let vrbs1 = envVerbosity fnk_env\n vrbs2 = if debug0\n then max 3 vrbs1\n else vrbs1\n\n -- Updating the debug settings. Also setting the default 'DynFlag' at this\n -- point.\n putFnkEnv (fnk_env { envVerbosity = vrbs2\n , envDefaultDynFlags = Just dflags3 })\n\n-- | Set context modules in current session to given modules.\nsetContextModules :: GhcMonad m => [String] -> m ()\nsetContextModules = setContext . map (IIDecl . simpleImportDecl . mkModuleName)\n{-# INLINABLE setContextModules #-}\n\n-- | Simple make function returning compiled home module information. Intended\n-- to be used in 'require' macro.\nmakeFromRequire :: Located ModuleName -> Fnk SuccessFlag\nmakeFromRequire lmname = do\n fnk_env <- getFnkEnv\n hsc_env <- getSession\n\n let old_summaries = mgModSummaries' (hsc_mod_graph hsc_env)\n tr = traceMake fnk_env \"makeFromRequire\"\n dflags = hsc_dflags hsc_env\n\n tr [\"old summaries:\", nvcOrNone old_summaries]\n tr [\"required module:\" <+> ppr (unLoc lmname)]\n tu <- emptyTargetUnit <$> findTargetModuleName dflags lmname\n\n success_flag <- withTmpDynFlags (setExpanding dflags) $\n make1 LoadAllTargets old_summaries [tu]\n\n mgraph <- hsc_mod_graph <$> getSession\n let mod_summaries = mgModSummaries' mgraph\n tr [\"summaries:\", nvcOrNone mod_summaries]\n pure success_flag\n\n-- An adhoc CPP macro for 'Maybe UnitId' argument of 'guessTarget'.\n#if MIN_VERSION_ghc(9,4,0)\n#define MAYBE_UNITID Nothing\n#else\n#define MAYBE_UNITID {- nothing -}\n#endif\n\n-- | Simple function to perform module dependency analysis and loading.\nsimpleMake\n :: [(Located FilePath, Maybe Phase)]\n -> Bool\n -> Maybe FilePath\n -> Fnk SuccessFlag\nsimpleMake infiles _force_recomp _mb_output = do\n -- See: function 'doMake' in \"ghc/Main.hs\".\n let guess_target (L _ modname_or_path, mb_phase) =\n guessTarget modname_or_path MAYBE_UNITID mb_phase\n\n new_targets <- mapM guess_target infiles\n setTargets new_targets\n\n msgr <- envMessager <$> getFnkEnv\n mg <- depanal [] False\n doLoad LoadAllTargets (Just msgr) mg\n\n-- | Make function used when the Finkel compiler was invoked as a ghc plugin.\nmakeFromRequirePlugin :: Located ModuleName -> Fnk SuccessFlag\nmakeFromRequirePlugin lmname = do\n fnk_env <- getFnkEnv\n hsc_env <- getSession\n\n let mname = unLoc lmname\n dflags = hsc_dflags hsc_env\n -- XXX: Not sure when the target can use object code. Add some tests for\n -- combination of \"-fno-code\" and newly added options,\n -- Opt_ByteCodeAndObjectCode, and Opt_WriteIfSimplifiedCore.\n --\n -- XXX: Under certain condition in ghc 9.6, it is possible to allow object\n -- codes when the backend does not write files (for -fno-code\n -- option). Though at the moment, the backend at this point is always set\n -- to interpreter. Find out a way to get the backend of the original\n -- DynFlags, at this point, the backend of `dflags' is always set to\n -- interpreter. See 'Language.Finkel.Expand.newHscEnvForExpand'.\n --\n -- XXX: Find out a way to support compiling with \"-fno-code\" option in ghc\n -- 9.6, which is used when generating documentations with haddock.\n --\n -- allow_obj_code =\n -- case envDefaultDynFlags fnk_env of\n -- Just df -> not (backendWritesFiles (backend df)) ||\n -- ways df `hasWay` WayDyn || gopt Opt_BuildDynamicToo df\n -- Nothing -> False\n --\n -- XXX: In ghc 9.4, see 'GHC.Driver.Pipeline.compileOne'', when the\n -- targetAllowObjCode is set to False, Opt_ForceRecomp of the local\n -- dynflags is always turned on. When the GHCi is built to prefer dynamic\n -- object, and when dynamic object of home package module did not exist,\n -- interpreter may try to load non-dynamic object and shows an error\n -- during macro expansion.\n --\n -- For ghc >= 9.2, allowing object code when current compilation contains\n -- \"-dynamic\" or \"-dynamic-too\".\n#if MIN_VERSION_ghc(9,2,0)\n allow_obj_code =\n case envDefaultDynFlags fnk_env of\n Just df -> ways df `hasWay` WayDyn || gopt Opt_BuildDynamicToo df\n Nothing -> False\n#else\n allow_obj_code = False\n#endif\n target = Target { targetId = TargetModule mname\n , targetAllowObjCode = allow_obj_code\n#if MIN_VERSION_ghc(9,4,0)\n , targetUnitId = hscActiveUnitId hsc_env\n#endif\n , targetContents = Nothing\n }\n old_targets = hsc_targets hsc_env\n messager = envMessager fnk_env\n tr = traceMake fnk_env \"makeFromRequirePlugin\"\n new_targets = target : old_targets\n hsc_env_new = hsc_env {hsc_targets = new_targets}\n\n#if MIN_VERSION_ghc(9,2,0)\n let extra_dump =\n case envDefaultDynFlags fnk_env of\n Just default_dflags ->\n [ \"ways:\" <+> text (show (ways dflags))\n , \"ways (fnk):\" <+> text (show (ways default_dflags))\n , \"backend:\" <+> text (show (backend dflags))\n , \"backend (fnk):\" <+> text (show (backend default_dflags)) ]\n Nothing -> []\n#else\n let extra_dump = []\n#endif\n\n tr ([ \"target:\" <+> ppr target\n , \"old_targets:\" <+> nvcOrNone old_targets\n , \"new_targets:\" <+> nvcOrNone new_targets\n , \"allowObjCode:\" <+> text (show (allow_obj_code))\n ] <> extra_dump)\n\n setSession hsc_env_new\n\n -- XXX: Using hardcoded additional import paths `src'\n --\n -- For haskell-language-server to work with finkel-core library and\n -- finkel-tool library. However, tests in the packages need to take \"test\"\n -- directory instead of \"src\", the directory name is specified by the\n -- 'hs-source-dirs' in the cabal configuration file. But, currently not sure\n -- how to get the value of 'hs-source-dirs'.\n --\n -- Also, when \"src\" is added, compiling the tests in finkel-core and\n -- finkel-tool will fail, because these tests will search files under src\n -- instead of importing from its internal library.\n\n -- let adjust_dynflags df =\n -- (setExpanding df) {importPaths = \"src\" : importPaths df}\n let adjust_dynflags = setExpanding\n\n dumpHscEnv fnk_env \"makeFromRequirePlugin (before load):\" hsc_env_new\n\n success_flag <- withTmpDynFlags (adjust_dynflags dflags) $ do\n tmp_dflags <- fmap hsc_dflags getSession\n dumpDynFlags fnk_env \"makeFromRequirePlugin (withTmpDynFlags)\" tmp_dflags\n mg <- depanal [] False\n doLoad LoadAllTargets (Just messager) mg\n\n hsc_env_after <- getSession\n dumpHscEnv fnk_env \"makeFromRequirePlugin (after load):\" hsc_env_after\n tr [\"isExpanding:\" <+> ppr (isExpanding (hsc_dflags hsc_env_after))]\n\n pure success_flag\n\n-- | Make new 'TargetSummary' from given 'TargetUnit'.\nfnkSourceToSummary :: TargetSource -> Fnk TargetSummary\nfnkSourceToSummary ts = do\n fnk_env <- getFnkEnv\n hsc_env <- getSession\n let tu = emptyTargetUnit ts\n fst <$> unMakeM (makeNewSummary fnk_env hsc_env tu) emptyMkSt\n\n\n-- ---------------------------------------------------------------------\n--\n-- Internal of make\n--\n-- ---------------------------------------------------------------------\n\n-- | Compile 'TargetUnit' to interface file and object code.\n--\n-- This function does macro expansion, convert 'TargetUnit' to 'ModSummary', and\n-- pass the results to 'GhcMake.load''.\n--\nmake1 :: LoadHowMuch -> [ModSummary] -> [TargetUnit] -> Fnk SuccessFlag\nmake1 how_much old_summaries targets = do\n fnk_env <- getFnkEnv\n\n let tr = traceMake fnk_env \"make1\"\n targets_sdoc = nest 2 (vcat (map ppr targets))\n total = length targets\n\n tr [ \"total:\" <+> text (show total)\n , \"targets:\", targets_sdoc\n , \"old summaries:\", nvcOrNone old_summaries]\n\n hsc_env <- getSession\n (mss0, options) <- summariseTargets hsc_env old_summaries targets\n unless (null options) (updateFlagOptions options)\n\n -- Make new ModuleGrpah from expanded summaries, then update the old mod\n -- summaries if the summaries were missing.\n#if MIN_VERSION_ghc(9,4,0)\n let updateMG ms acc =\n if any (\\old -> ms_mod_name old == ms_mod_name ms) acc\n then acc\n else ms : acc\n mnodes0 = foldr updateMG mss0 old_summaries\n\n -- Additionally, fill in the NodeKeys for topological sort, and link node\n -- to support compiling executable.\n mnodes1 = fillInNodeKeys mnodes0\n mnodes2 = addLinkNodesIfAny hsc_env mnodes1\n mgraph0 = mkModuleGraph mnodes2\n#else\n let updateMG ms mg = if mgElemModule' mg (ms_mod ms)\n then mg\n else extendMG' mg ms\n mgraph0 = foldr updateMG (mkModuleGraph' mss0) old_summaries\n#endif\n tr [\"new summaries:\", nvcOrNone (mgModSummaries' mgraph0)]\n\n -- Pass the merged ModuleGraph to the \"load'\" function, delegate the hard\n -- works to it.\n success_flag <- doLoad how_much (Just (envMessager fnk_env)) mgraph0\n tr [\"done:\", targets_sdoc]\n\n return success_flag\n\nupdateFlagOptions :: [Option] -> Fnk ()\nupdateFlagOptions options = do\n hsc_env <- getSession\n let dflags0 = hsc_dflags hsc_env\n dflags1 = dflags0 {ldInputs = options ++ ldInputs dflags0}\n void (setSessionDynFlags dflags1)\n\n#if MIN_VERSION_ghc(9,4,0)\n-- See: local functions 'loopSummaries' and 'loopImports' in 'downsweep' in\n-- GHC.Driver.Make.\nfillInNodeKeys :: [ModSummary] -> [ModuleGraphNode]\nfillInNodeKeys mss =\n let home_mod_map :: Map.Map ModuleName NodeKey\n home_mod_map = Map.fromList [ (ms_mod_name ms, NodeKey_Module (msKey ms))\n | ms <- mss ]\n get_node_key (_, L _ mname) = Map.lookup mname home_mod_map\n get_node_keys ms = catMaybes (map get_node_key (ms_imps ms))\n convert ms = ModuleNode (get_node_keys ms) ms\n in map convert mss\n\n-- See: 'linkNodes' in GHC.Driver.Make.\naddLinkNodesIfAny :: HscEnv -> [ModuleGraphNode] -> [ModuleGraphNode]\naddLinkNodesIfAny hsc_env mg0 = unitEnv_foldWithKey f mg0 hug\n where\n hug = hsc_HUG hsc_env\n f nodes uid hue = maybe id (:) (linkOne mg0 uid hue) nodes\n linkOne mg uid hue =\n let dflags = homeUnitEnv_dflags hue\n pre_nodes = filter ((== uid) . moduleGraphNodeUnitId) mg\n unit_nodes = map mkNodeKey pre_nodes\n no_hs_main = gopt Opt_NoHsMain dflags\n gwib = GWIB (mainModuleNameIs dflags) NotBoot\n isMainModule = (== NodeKey_Module (ModNodeKeyWithUid gwib uid))\n main_sum = any isMainModule unit_nodes\n do_linking = main_sum || no_hs_main ||\n ghcLink dflags == LinkDynLib ||\n ghcLink dflags == LinkStaticLib\n in if ghcLink dflags /= NoLink && do_linking\n then Just (LinkNode unit_nodes uid)\n else Nothing\n#endif\n\n\n-- ------------------------------------------------------------------------\n--\n-- For summarising TargetUnit\n--\n-- ------------------------------------------------------------------------\n\n-- See 'GhcMake.{summariseModule,summariseFile}'.\n--\n-- Seems like 'addDependentFile' method used by Template Haskell is not working\n-- well in GHCi (as of ghc 8.8), see:\n--\n-- https://gitlab.haskell.org/ghc/ghc/-/issues/18330\n\n-- | Newtype to summaries list of 'TargetUnit'.\nnewtype MakeM a = MakeM {unMakeM :: MkSt -> Fnk (a, MkSt)}\n\ninstance Functor MakeM where\n fmap f (MakeM k) = MakeM (fmap (first f) . k)\n {-# INLINE fmap #-}\n\ninstance Applicative MakeM where\n pure a = MakeM (\\st -> pure (a, st))\n {-# INLINE pure #-}\n f <*> m = f >>= flip fmap m\n {-# INLINE (<*>) #-}\n\ninstance Monad MakeM where\n MakeM m >>= k = MakeM (m >=> \\(a,s) -> unMakeM (k a) s)\n {-# INLINE (>>=) #-}\n\ninstance MonadIO MakeM where\n liftIO io = MakeM (\\s -> liftIO io >>= \\a -> pure (a, s))\n {-# INLINE liftIO #-}\n\n-- | State for 'MakeM'.\ndata MkSt = MkSt\n { -- | Resulting list of 'ModSummary'.\n mks_summarised :: ![ModSummary]\n -- | Resulting list of 'Option'.\n , mks_flag_options :: ![Option]\n -- | List of 'TargetUnit' to compile.\n , mks_to_summarise :: ![TargetUnit]\n\n -- | Old ModSummary from last run, if any.\n , mks_old_summaries :: ![ModSummary]\n }\n\nemptyMkSt :: MkSt\nemptyMkSt = MkSt\n { mks_summarised = []\n , mks_flag_options = []\n , mks_to_summarise = []\n , mks_old_summaries = []\n }\n\ngetMkSt :: MakeM MkSt\ngetMkSt = MakeM (\\s -> pure (s,s))\n{-# INLINABLE getMkSt #-}\n\nputMkSt :: MkSt -> MakeM ()\nputMkSt s = MakeM (\\_ -> pure ((),s))\n{-# INLINABLE putMkSt #-}\n\ntoMakeM :: Fnk a -> MakeM a\ntoMakeM fnk = MakeM (\\st -> fnk >>= \\a -> pure (a,st))\n{-# INLINABLE toMakeM #-}\n\n-- | Make a list of 'ModSummary' and 'Option' from the given 'TargetUnit's.\n--\n-- Purpose is similar to the 'downsweep' function, but does less work (e.g.,\n-- does not detect circular module dependencies).\nsummariseTargets\n :: HscEnv\n -- ^ Current session.\n -> [ModSummary]\n -- ^ List of old 'ModSummary'.\n -> [TargetUnit]\n -- ^ List of 'TargetUnit' to compile.\n -> Fnk ([ModSummary], [Option])\n -- ^ A pair of list of 'ModSummary' and list of file option.\nsummariseTargets hsc_env old_summaries tus_to_summarise =\n withTiming' \"summariseTargets [Finkel]\" $ do\n fnk_env <- getFnkEnv\n let mks0 = emptyMkSt { mks_to_summarise = tus_to_summarise\n , mks_old_summaries = old_summaries }\n rs0 = emptyRecompState hsc_env\n (_, mks1) <- unMakeM (summariseAll fnk_env hsc_env rs0) mks0\n return (mks_summarised mks1, reverse (mks_flag_options mks1))\n\n-- | 'MakeM' action to summarise all 'TargetUnit's.\nsummariseAll :: FnkEnv -> HscEnv -> RecompState -> MakeM RecompState\nsummariseAll fnk_env hsc_env = go\n where\n -- When compiling object codes, macro expander will update HomePackageTable\n -- to check old interface read from file. Recursively passing the\n -- RecompState to use the updated HomePackageTable.\n go rs = do\n s0 <- getMkSt\n case mks_to_summarise s0 of\n [] -> return rs\n t:ts -> do\n putMkSt (s0 {mks_to_summarise = ts})\n summariseOne fnk_env hsc_env t rs >>= go\n\n-- | Summarise one 'TargetUnit'.\nsummariseOne\n :: FnkEnv -> HscEnv -> TargetUnit -> RecompState -> MakeM RecompState\nsummariseOne fnk_env hsc_env tu rs0 = do\n mks@MkSt{ mks_summarised = summarised\n , mks_flag_options = flag_options\n , mks_to_summarise = to_summarise } <- getMkSt\n\n let summarised_names = map ms_mod_name summarised\n names_to_summarise = map targetUnitName to_summarise\n reqs_not_in_mss =\n filter (\\r -> ms_mod_name r `notElem` summarised_names)\n not_yet_ready ms =\n foldr (\\(_, lmn) acc ->\n if unLoc lmn `elem` names_to_summarise ||\n unLoc lmn `elem` summarised_names\n then acc\n else lmn:acc)\n []\n (ms_textual_imps ms)\n\n -- Skip the expansion when earlier modules already saw this TargetUnit.\n if targetUnitName tu `elem` summarised_names\n then return rs0\n else do\n (tsum, rs1) <- makeTargetSummary fnk_env rs0 tu\n case tsum of\n -- Linker option, not a module.\n LdInput fo -> putMkSt (mks {mks_flag_options=fo:flag_options})\n\n -- Expanded to ModSummary, add imported home modules if not added yet.\n -- Adding the required ModSummary to the accumulator when using\n -- interpreter, since it could be reused.\n EMS ms _ reqs -> do\n not_compiled <- filterNotCompiled fnk_env hsc_env (not_yet_ready ms)\n putMkSt (mks { mks_summarised =\n if isInterpreted (hsc_dflags hsc_env)\n then ms:reqs_not_in_mss reqs ++ summarised\n else ms:summarised\n , mks_to_summarise = not_compiled ++ to_summarise\n })\n return rs1\n\n-- | Returns 'Just' pair of compiled 'ModSummary' and the required home package\n-- module 'ModSummary' for 'FnkSource' and 'HsSource', or 'Nothing' for\n-- 'OtherSource'.\nmakeTargetSummary\n :: FnkEnv -> RecompState -> TargetUnit -> MakeM (TargetSummary, RecompState)\nmakeTargetSummary fnk_env rs0 tu@(tsource,_) = do\n -- To maximize recompilation avoidance when compiling object codes, seems like\n -- it is required to first scan all the home package interfaces on file system\n -- to mark outdated \"ModSummary\"s, and then do the expansion to avoid parsing\n -- the source codes.\n --\n -- Perhaps the \"checkOldIface\" function is designed to work with topologically\n -- sorted list of \"ModSummary\", not to be called during macro expansion of\n -- Finkel module source code. 'MkIface.getFromModIface' is calling\n -- 'loadInterface', which is adding empty interface to PIT when loading non\n -- hi-boot interface for home package module. To avoid loading dummy\n -- interfaces, recompilation checks done in \"RecompM\" is reading interfaces\n -- and updating HPT before invoking 'checkOldIface'.\n\n old_summaries <- mks_old_summaries <$> getMkSt\n\n let tr = traceMake' dflags fnk_env \"makeTargetSummary\"\n hsc_env = rs_hsc_env rs0\n dflags = hsc_dflags hsc_env\n this_mod_name = targetUnitName tu\n by_mod_name = (== this_mod_name) . ms_mod_name\n\n update_summary obj_allowed rs ms0 = do\n ms1 <- updateSummaryTimestamps dflags obj_allowed ms0\n return (plainEMS ms1, rs)\n\n new_summary rs why = do\n tr [\"Making new summary for\" <+> ppr this_mod_name <+> brackets why]\n tsum <- makeNewSummary fnk_env hsc_env tu\n return (tsum, rs)\n\n -- XXX: In below, `obj_allowed' argument is constantly 'False' at the\n -- moment, it will be nice to pass this arg from REPL.\n reuse_summary rs ms0 = do\n tr [\"Reusing old summary for\" <+> ppr this_mod_name]\n update_summary False rs ms0\n\n reuse_iface rs ms0 = do\n tr [\"Reusing iface file for\" <+> ppr this_mod_name]\n update_summary True rs ms0\n\n if gopt Opt_ForceRecomp dflags\n then new_summary rs0 \"force recomp\"\n else case find by_mod_name old_summaries of\n -- Old summaries did not contain this module, checking whether the\n -- interface file and object code file are reusable when compiling to\n -- object code.\n Nothing ->\n if not (isObjectBackend dflags)\n then new_summary rs0 \"non object target\"\n else do\n (et_ms, rs1) <- runRecompilationCheck fnk_env rs0 tu\n case et_ms of\n Left why -> new_summary rs1 why\n Right ms -> reuse_iface rs1 ms\n\n -- Checking whether recompilation is required or not at this point, since\n -- when reompiling, may need to parse the source code to reflect the\n -- changes in macros from home package modules.\n Just ms -> do\n file_modified <- liftIO (isFileModified ms (targetSourcePath tsource))\n if file_modified\n then new_summary rs0 \"source code is new\"\n else do\n summary_ok <- checkModSummary hsc_env ms\n if not summary_ok\n then new_summary rs0 \"out of date usages\"\n else reuse_summary rs0 ms\n\nisFileModified :: ModSummary -> FilePath -> IO Bool\n#if MIN_VERSION_ghc(9,4,0)\nisFileModified ms = fmap (/= ms_hs_hash ms) . getFileHash\n#else\nisFileModified ms = fmap (ms_hs_date ms <) . getModificationUTCTime\n#endif\n\n-- | Make new 'TargetSummary'.\nmakeNewSummary :: FnkEnv -> HscEnv -> TargetUnit -> MakeM TargetSummary\nmakeNewSummary fnk_env hsc_env tu = toMakeM $ do\n tsum <- summariseTargetUnit tu\n case tsum of\n LdInput _option -> return tsum\n EMS ms0 mb_sp reqs -> do\n dumpDynFlags fnk_env \"makeNewSummary\" (ms_hspp_opts ms0)\n -- Since the entire compilation work does not use DriverPipeline,\n -- setting the dumpPrefix at this point.\n setDumpPrefix (ms_hspp_file ms0)\n\n -- XXX: The dumpParsedAST is evaluated in 'compileFnkFile', which is\n -- before setting the dump prefix, is this fine?\n\n -- To support parsedResultAction in plugin. See \"HscMain.hscParse'\"\n ms1 <- case ms_parsed_mod ms0 of\n Nothing -> return ms0\n Just pm -> do\n let do_action p opts = parsedResultAction p opts ms0\n dflags0 = hsc_dflags hsc_env\n dflags1 = adjustIncludePaths dflags0 ms0\n hsc_env' = hsc_env {hsc_dflags = dflags1}\n#if MIN_VERSION_ghc(9,4,0)\n plugins = hsc_plugins (hscSetFlags dflags1 hsc_env)\n act = parsedResultModule <$>\n withPlugins plugins do_action (mkParsedResult pm)\n#elif MIN_VERSION_ghc(9,2,0)\n act = withPlugins (hsc_env {hsc_dflags=dflags1}) do_action pm\n#else\n act = withPlugins dflags1 do_action pm\n#endif\n parsed_mod <- liftIO (runHsc hsc_env' act)\n return $! ms0 {ms_parsed_mod = Just parsed_mod}\n return $! EMS ms1 mb_sp reqs\n\n#if MIN_VERSION_ghc(9,4,0)\n-- XXX: Always using empty messages\nmkParsedResult :: HsParsedModule -> ParsedResult\nmkParsedResult pm =\n let msgs = PsMessages { psWarnings = emptyMessages\n , psErrors = emptyMessages }\n in ParsedResult { parsedResultModule = pm\n , parsedResultMessages = msgs }\n#else\nmkParsedResult :: a -> a\nmkParsedResult = id\n#endif\n{-# INLINABLE mkParsedResult #-}\n\n-- | Set 'dumpPrefix' from file path.\nsetDumpPrefix :: GhcMonad m => FilePath -> m ()\nsetDumpPrefix path = do\n dflags0 <- getDynFlags\n let (basename, _suffix) = splitExtension path\n#if MIN_VERSION_ghc(9,4,0)\n dflags1 = dflags0 {dumpPrefix = basename ++ \".\"}\n#else\n dflags1 = dflags0 {dumpPrefix = Just (basename ++ \".\")}\n#endif\n setDynFlags dflags1\n{-# INLINABLE setDumpPrefix #-}\n\n-- | Run the recompilation check.\nrunRecompilationCheck\n :: FnkEnv -> RecompState -> TargetUnit\n -> MakeM (Either SDoc ModSummary, RecompState)\nrunRecompilationCheck fnk_env rs tu =\n toMakeM (unRecompM (checkRecompileRequired fnk_env tu) rs)\n{-# INLINABLE runRecompilationCheck #-}\n\n-- | Return a list of 'TargetUnit' to compile for given 'ModuleName's.\nfilterNotCompiled\n :: MonadIO m => FnkEnv -> HscEnv -> [Located ModuleName] -> m [TargetUnit]\nfilterNotCompiled fnk_env hsc_env = foldM find_not_compiled []\n where\n dflags = hsc_dflags hsc_env\n tr = traceMake' dflags fnk_env \"filterNotCompiled\"\n find_not_compiled acc lmname = do\n let mname = unLoc lmname\n mb_ts <- findTargetModuleNameMaybe dflags lmname\n case mb_ts of\n Just ts -> do\n tr [\"Found\" <+> ppr mname <+> \"at\" <+> text (targetSourcePath ts)]\n return $! (emptyTargetUnit ts : acc)\n Nothing -> do\n#if MIN_VERSION_ghc(9,4,0)\n let fc = hsc_FC hsc_env\n units = hsc_units hsc_env\n fopts = initFinderOpts dflags\n fr <- liftIO (findExposedPackageModule fc fopts units mname NoPkgQual)\n#else\n fr <- liftIO (findExposedPackageModule hsc_env mname Nothing)\n#endif\n case fr of\n Found _ mdl -> do\n#if MIN_VERSION_ghc(9,0,0)\n let mod_unit = moduleUnit mdl\n#else\n let mod_unit = moduleUnitId mdl\n#endif\n tr [\"Found\" <+> ppr mname <+> \"in\" <+> ppr mod_unit]\n return acc\n _ -> do\n let err = mkPlainWrappedMsg dflags (getLoc lmname) doc\n#if MIN_VERSION_ghc(9,8,0)\n doc = missingInterfaceErrorDiagnostic opts body\n opts = initIfaceMessageOpts dflags\n body = cannotFindModule hsc_env mname fr\n#elif MIN_VERSION_ghc(9,2,0)\n doc = cannotFindModule hsc_env mname fr\n#else\n doc = cannotFindModule dflags mname fr\n#endif\n throwOneError err\n\n-- From ghc 9.4, the `load'' function takes ModIface cache.\n--\n-- From ghc 9.8, the `load'' function takes (GhcMessage -> AnyGhcDiagnostic)\n-- function.\ndoLoad :: LoadHowMuch -> Maybe Messager -> ModuleGraph -> Fnk SuccessFlag\n#if MIN_VERSION_ghc(9,4,0)\ndoLoad lhm mb_msgr mg = do\n dflags <- getDynFlags\n fnk_env <- getFnkEnv\n\n -- ModIfaceCache is used by interpreter only.\n let mb_hmi_cache =\n if isInterpreted dflags\n then envInterpModIfaceCache fnk_env\n else Nothing\n\n# if MIN_VERSION_ghc(9,8,0)\n load' mb_hmi_cache lhm mkUnknownDiagnostic mb_msgr mg\n# else\n load' mb_hmi_cache lhm mb_msgr mg\n# endif\n#else\ndoLoad = load'\n#endif\n" }, { "path": "finkel-kernel/src/Language/Finkel/Options.hs", "content": "-- | Codes for command line options.\nmodule Language.Finkel.Options\n (\n -- * Plugin options\n FnkPluginOptions(..)\n , defaultFnkPluginOptions\n , fnkPluginOptions\n , fpoPragma\n , fpoIgnore\n , printPluginUsage\n\n -- * Fnk source options\n , FnkSrcOptions (..)\n , defaultFnkSrcOptions\n , fromFnkSrcOptions\n\n -- * FnkEnv options\n , fnkEnvOptions\n , fnkEnvOptionsWithLib\n , partitionFnkEnvOptions\n , fromFnkEnvOptions\n , fnkEnvOptionsUsage\n\n ) where\n\n-- base\nimport Data.Char (toLower)\nimport Data.List (isPrefixOf, partition)\nimport System.Console.GetOpt (ArgDescr (..), OptDescr (..), usageInfo)\nimport System.Environment (getProgName)\n\n-- Internal\nimport Language.Finkel.Exception\nimport Language.Finkel.Fnk\n\n\n-- ------------------------------------------------------------------------\n--\n-- Options for plugin\n--\n-- ------------------------------------------------------------------------\n\ndata FnkPluginOptions = FnkPluginOptions\n { fpoHelp :: Bool\n , fpoSrcOptions :: FnkSrcOptions\n , fpoFnkEnv :: FnkEnv\n }\n\ndefaultFnkPluginOptions :: FnkEnv -> FnkPluginOptions\ndefaultFnkPluginOptions fnk_env = FnkPluginOptions\n { fpoHelp = False\n , fpoSrcOptions = defaultFnkSrcOptions\n , fpoFnkEnv = fnk_env\n }\n\nfpoPragma :: FnkPluginOptions -> String\nfpoPragma = fsrcPragma . fpoSrcOptions\n\nfpoIgnore :: FnkPluginOptions -> Bool\nfpoIgnore = fsrcIgnore . fpoSrcOptions\n\nfnkPluginOptions :: [OptDescr (FnkPluginOptions -> FnkPluginOptions)]\nfnkPluginOptions = help : sopts ++ eopts\n where\n help = Option [] [\"help\"]\n (NoArg (\\o -> o {fpoHelp = True}))\n \"Show this help and exit.\"\n eopts = adjustFnkEnvOptions (fromFnkEnvOptions wenv)\n wenv f o = o {fpoFnkEnv = f (fpoFnkEnv o)}\n sopts = fromFnkSrcOptions wsrc\n wsrc f o = o {fpoSrcOptions = f (fpoSrcOptions o)}\n\nadjustFnkEnvOptions :: [OptDescr a] -> [OptDescr a]\nadjustFnkEnvOptions = foldr f []\n where\n f opt@(Option so lo ad descr) acc =\n if is_removed_option opt\n then acc\n else Option so (map dropFnk lo) ad descr : acc\n dropFnk = drop (length \"fnk-\")\n is_removed_option (Option so _ _ _) = so == ['B']\n\nprintPluginUsage :: String -> IO ()\nprintPluginUsage mod_name = do\n prog <- getProgName\n let fplugin_opt = \"-fplugin-opt=\" ++ mod_name ++ \":OPTION\"\n header = unlines\n [ \"USAGE:\"\n , \"\"\n , \" \" ++ prog ++ \" ... [\" ++ fplugin_opt ++ \"]\"\n , \"\"\n , \"OPTIONS:\"\n ]\n putStrLn (usageInfo header fnkPluginOptions)\n\n\n-- ------------------------------------------------------------------------\n--\n-- Options for finkel source code\n--\n-- ------------------------------------------------------------------------\n\ndata FnkSrcOptions = FnkSrcOptions\n { fsrcPragma :: !String\n -- ^ String to be searched at the beginning section of a file to detect\n -- Finkel source code.\n , fsrcIgnore :: !Bool\n -- ^ Flag for ignoring the given file.\n }\n\ndefaultFnkSrcOptions :: FnkSrcOptions\ndefaultFnkSrcOptions = FnkSrcOptions\n { fsrcPragma = \";;;\"\n , fsrcIgnore = False\n }\n\nfnkSrcOptions :: [OptDescr (FnkSrcOptions -> FnkSrcOptions)]\nfnkSrcOptions =\n [ Option [] [\"pragma\"]\n (ReqArg (\\i o -> o {fsrcPragma = i}) \"STR\")\n (unlines [ \"Searched string to detect Finkel source file.\"\n , \"(default: \" ++ fsrcPragma defaultFnkSrcOptions ++ \")\" ])\n , Option [] [\"ignore\"]\n (NoArg (\\o -> o {fsrcIgnore = True}))\n \"Ignore this file.\"\n ]\n\nfromFnkSrcOptions :: ((FnkSrcOptions -> FnkSrcOptions) -> a) -> [OptDescr a]\nfromFnkSrcOptions f = map (fmap f) fnkSrcOptions\n\n\n-- ---------------------------------------------------------------------\n--\n-- FnkEnv options\n--\n-- ---------------------------------------------------------------------\n\n-- | Separate Finkel debug options from others.\npartitionFnkEnvOptions\n :: [String]\n -- ^ Flag inputs, perhaps given as command line arguments.\n -> ([String], [String])\n -- ^ Pair of @(finkel_flags, other_flags)@.\npartitionFnkEnvOptions = partition test\n where\n -- The \"-B\" option is to update the ghc libdir in FnkEnv.\n test arg = \"--fnk-\" `isPrefixOf` arg || \"-B\" `isPrefixOf` arg\n\n-- | Command line option handlers to update 'FnkDumpFlag' in 'FnkEnv'.\nfnkEnvOptions :: [OptDescr (FnkEnv -> FnkEnv)]\nfnkEnvOptions =\n [ opt [\"fnk-verbose\"]\n (ReqArg (\\i o -> o {envVerbosity = parseVerbosity i}) \"INT\")\n \"Set verbosity level to INT.\"\n , opt [\"fnk-hsdir\"]\n (ReqArg (\\path o -> o {envHsOutDir = Just path}) \"DIR\")\n \"Set Haskell code output directory to DIR.\"\n\n -- Dump and trace options\n , debug_opt Fnk_dump_dflags \"Dump DynFlags settings.\"\n , debug_opt Fnk_dump_expand \"Dump expanded code.\"\n , debug_opt Fnk_dump_hs \"Dump Haskell source code.\"\n , debug_opt Fnk_dump_session \"Dump session information.\"\n , debug_opt Fnk_trace_expand \"Trace macro expansion.\"\n , debug_opt Fnk_trace_session \"Trace session env.\"\n , debug_opt Fnk_trace_make \"Trace make function.\"\n , debug_opt Fnk_trace_spf \"Trace builtin special forms.\"\n ]\n where\n opt = Option []\n debug_opt flag = opt [to_str flag] (NoArg (foptSet flag))\n to_str = map replace . show\n replace '_' = '-'\n replace c = toLower c\n parseVerbosity = readOrFinkelException \"INT\" \"verbosity\"\n\n-- | Options for @FnkEnv@ with an option to set ghc @libdir@.\nfnkEnvOptionsWithLib :: [OptDescr (FnkEnv -> FnkEnv)]\nfnkEnvOptionsWithLib = lib_option : fnkEnvOptions\n where\n lib_option =\n Option ['B'] []\n (ReqArg (\\path o -> o {envLibDir = Just path}) \"DIR\")\n \"Set ghc library directory to DIR.\"\n\n-- | Convert 'fnkEnvOptions' to list of 'OptDescr' taking a function modifying\n-- 'FnkEnv'.\nfromFnkEnvOptions :: ((FnkEnv -> FnkEnv) -> a) -> [OptDescr a]\nfromFnkEnvOptions f = map (fmap f) fnkEnvOptionsWithLib\n\n-- | Usage information for 'fnkEnvOptions', without @-B@ option.\nfnkEnvOptionsUsage :: String -> String\nfnkEnvOptionsUsage = flip usageInfo fnkEnvOptions\n" }, { "path": "finkel-kernel/src/Language/Finkel/ParsedResult.hs", "content": "{-# LANGUAGE CPP #-}\n\nmodule Language.Finkel.ParsedResult (\n fnkParsedResultAction\n ) where\n\n\n#if MIN_VERSION_ghc(8,6,0)\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Exception (displayException, throwIO)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.Maybe (fromMaybe)\nimport System.Console.GetOpt (ArgOrder (..), getOpt)\nimport System.Environment (getProgName)\nimport System.Exit (exitFailure, exitSuccess)\n\n#if !MIN_VERSION_base(4,20,0)\nimport Data.List (foldl')\n#endif\n\n-- ghc\nimport GHC_Driver_Env (Hsc (..), HscEnv (..))\nimport GHC_Driver_Main (getHscEnv)\nimport GHC_Plugins (CommandLineOption)\nimport GHC_Runtime_Context (InteractiveContext (..))\nimport GHC_Types_SourceError (throwOneError)\nimport GHC_Types_SrcLoc (noLoc, noSrcSpan)\nimport GHC_Unit_Module (ModLocation (..))\nimport GHC_Unit_Module_ModSummary (ModSummary (..), ms_mod_name)\nimport GHC_Utils_Outputable (text)\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Plugins (ParsedResult)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Hs (HsParsedModule (..))\n#else\nimport GHC_Driver_Types (HsParsedModule (..))\n#endif\n\n-- Internal\nimport Language.Finkel.Error (mkPlainWrappedMsg)\nimport Language.Finkel.Exception (FinkelException (..),\n finkelExceptionLoc,\n handleFinkelException)\nimport Language.Finkel.Fnk (FnkEnv (..), FnkInvokedMode (..),\n dumpDynFlags, initFnkEnv, runFnk')\nimport Language.Finkel.Make (mkParsedResult)\nimport Language.Finkel.Make.Summary (TargetSummary (..), compileFnkFile)\nimport Language.Finkel.Make.TargetSource (TargetSource (..),\n findTargetSourceWithPragma)\nimport Language.Finkel.Options (FnkPluginOptions (..),\n defaultFnkPluginOptions,\n fnkPluginOptions, fpoIgnore,\n fpoPragma, printPluginUsage)\n\n\n-- ------------------------------------------------------------------------\n--\n-- Exported\n--\n-- ------------------------------------------------------------------------\n\n#if MIN_VERSION_ghc(9,4,0)\nfnkParsedResultAction\n :: String -> FnkEnv -> [CommandLineOption] -> ModSummary -> ParsedResult\n -> Hsc ParsedResult\n#else\nfnkParsedResultAction\n :: String -> FnkEnv -> [CommandLineOption] -> ModSummary -> HsParsedModule\n -> Hsc HsParsedModule\n#endif\n\nfnkParsedResultAction mod_name fnk_env0 args0 ms pm =\n case getOpt Permute fnkPluginOptions (concatMap words args0) of\n (_, _, es@(_:_)) -> liftIO (exitWithBriefUsage mod_name es)\n (os, _ls, []) -> do\n let fpo = foldl' (flip id) (defaultFnkPluginOptions fnk_env0) os\n if fpoHelp fpo\n then liftIO (printPluginUsage mod_name >> exitSuccess)\n else if fpoIgnore fpo\n then pure pm\n else case ml_hs_file (ms_location ms) of\n Nothing -> pure pm\n Just path -> do\n let pragma = fpoPragma fpo\n lpath = noLoc path\n fnk_env1 = fpoFnkEnv fpo\n dflags = ms_hspp_opts ms\n mkPR = mkParsedResult\n fnk_env2 <- liftIO $ initFnkEnv fnk_env1\n ts <- findTargetSourceWithPragma pragma dflags lpath\n case ts of\n FnkSource {} -> mkPR <$> parseFnkModule fnk_env2 path ms\n _ -> pure pm\n\n\n-- ------------------------------------------------------------------------\n--\n-- Internal\n--\n-- ------------------------------------------------------------------------\n\nparseFnkModule :: FnkEnv -> FilePath -> ModSummary -> Hsc HsParsedModule\nparseFnkModule fenv0 path ms = do\n henv <- getHscEnv\n\n let mb_loc = fromMaybe noSrcSpan . finkelExceptionLoc\n mname = ms_mod_name ms\n dflags = hsc_dflags henv\n dflags_in_ic = ic_dflags (hsc_IC henv)\n\n -- Setting the default DynFlags of FnkEnv to the DynFlags from interactive\n -- context, since the DynFlags from 'hsc_dflags' field of HscEnv is\n -- already updated with file local options at this point. This will\n -- prevent redundant recompilation when requireing home package modules.\n fenv1 = fenv0 { envInvokedMode = GhcPluginMode\n , envDefaultDynFlags = Just dflags_in_ic }\n\n handler e = throwOneError (mkPlainWrappedMsg dflags (mb_loc e)\n (text (displayException e)))\n fnk = handleFinkelException handler $ compileFnkFile path mname\n\n let dump_dyn_flags lbl = dumpDynFlags fenv1 (text lbl)\n dump_dyn_flags \"parseFnkModule:dflags\" dflags\n dump_dyn_flags \"parseFnkModule:dflags_in_ic\" dflags_in_ic\n\n summary <- liftIO $ runFnk' fnk fenv1 henv\n\n case summary of\n EMS ems _mb_sp _reqs | Just pm <- ms_parsed_mod ems -> pure pm\n _ -> liftIO (throwIO (FinkelException (\"Failed to parse \" ++ path)))\n\nexitWithBriefUsage :: String -> [String] -> IO a\nexitWithBriefUsage mod_name errs = do\n me <- getProgName\n let msgs =\n [ \"Try:\"\n , \"\"\n , \" \" ++ me ++\n \" -fplugin=\" ++ mod_name ++\n \" -fplugin-opt=\" ++ mod_name ++ \":--help\" ++\n \" ...\"\n , \"\"\n , \"to see available options.\"\n ]\n putStr (unlines (errs ++ msgs))\n exitFailure\n\n-- Note: [Workaround to support \"-fno-code\" option in ghc 9.6]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- When compiling with \"-fno-code\", home package module might required from\n-- other home package modules. In 'GHC.Driver.Make.enableCodeGenWhen', byte\n-- codes are generated when the TemplateHaskell language extension is turned\n-- on. However, at the moment finkel does not understand TemplateHaskell, so\n-- manually updating the 'HscEnv' with 'driverPlugin' plugin action. The three\n-- updates done to the 'DynFlags' are same as passing \"-fprefer-byte-code\",\n-- \"-fwrite-if-simplified-core\", and \"-XTemplateHaskell\" from command line.\n--\n-- XXX: haddock generation is not working with ghc 9.6 yet. Seems like the\n-- GHC plugins are not initialized before module dependency analysis.\n\n-- fnkNoCodePlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv\n-- fnkNoCodePlugin _ hsc_env = do\n-- let dflags0 = hsc_dflags hsc_env\n-- generates_code = backendGeneratesCode (backend dflags0)\n-- if generates_code\n-- then pure hsc_env\n-- else do\n-- let update df = setGeneralFlag' Opt_UseBytecodeRatherThanObjects $\n-- setGeneralFlag' Opt_WriteIfSimplifiedCore $\n-- xopt_set df TemplateHaskell\n-- dflags1 = update dflags0\n-- pure (hscSetFlags dflags1 hsc_env)\n\n#else /* ghc < 8.6.0 */\n\nfnkParsedResultAction :: a\nfnkParsedResultAction = error \"Unsupported GHC version, requires >= 8.6.0\"\n\n#endif /* ghc < 8.6.0 */\n\n" }, { "path": "finkel-kernel/src/Language/Finkel/Plugin.hs", "content": "{-# LANGUAGE CPP #-}\n-- | Plugin version of the finkel compiler.\nmodule Language.Finkel.Plugin\n ( -- * Finkel plugin\n plugin\n , pluginWith\n , setFinkelPluginWithArgs\n )\nwhere\n\n#include \"ghc_modules.h\"\n\n-- base\n#if MIN_VERSION_ghc(9,6,0)\nimport Control.Monad.IO.Class (MonadIO (..))\n#endif\n\n#if !MIN_VERSION_ghc(9,2,0)\nimport Data.Functor (void)\n#endif\n\n-- ghc\nimport GHC_Driver_Env (HscEnv (..))\nimport GHC_Driver_Monad (GhcMonad (..))\nimport GHC_Plugins (Plugin (..), PluginWithArgs (..),\n StaticPlugin (..), defaultPlugin,\n flagRecompile)\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Plugins (Plugins (..))\n#endif\n\n#if !MIN_VERSION_ghc(9,2,0)\nimport GHC (setSessionDynFlags)\nimport GHC_Driver_Session (DynFlags (..))\n#endif\n\n-- Internal\nimport Language.Finkel.Fnk (FnkEnv)\nimport Language.Finkel.SpecialForms (defaultFnkEnv)\n\n#if MIN_VERSION_ghc(9,6,0)\nimport Language.Finkel.Hooks (finkelHooks)\n#else\nimport Language.Finkel.ParsedResult (fnkParsedResultAction)\n#endif\n\n-- | Finkel compiler plugin.\nplugin :: Plugin\nplugin = pluginWith \"Language.Finkel.Plugin\" defaultFnkEnv\n\n-- | Finkel compiler plugin with given 'FnkEnv'.\npluginWith\n :: String -- ^ Plugin module name.\n -> FnkEnv -- ^ The environment used by the plugin.\n -> Plugin\npluginWith mod_name fnk_env =\n#if MIN_VERSION_ghc(9,6,0)\n defaultPlugin\n { driverPlugin = finkelHooks mod_name fnk_env\n , pluginRecompile = flagRecompile\n }\n#else\n defaultPlugin\n { parsedResultAction = fnkParsedResultAction mod_name fnk_env\n , pluginRecompile = flagRecompile\n }\n#endif\n\n-- | Initialize finkel plugin with given arguments.\nsetFinkelPluginWithArgs :: GhcMonad m => Plugin -> [String] -> m ()\nsetFinkelPluginWithArgs plgn args = do\n hsc_env <- getSession\n\n#if MIN_VERSION_ghc(9,6,0)\n -- In ghc >= 9.6, updating current session with driverPlugin, because\n -- `GHC.Loader.initializePlugins' does not check the addition of static\n -- plugins, according to the comment in the function.\n hsc_env' <- liftIO $ driverPlugin plgn args hsc_env\n let sp = StaticPlugin (PluginWithArgs plgn args)\n old_plugins = hsc_plugins hsc_env'\n old_static_plugins = staticPlugins old_plugins\n new_static_plugins = sp : old_static_plugins\n new_plugins = old_plugins {staticPlugins = new_static_plugins}\n setSession (hsc_env' {hsc_plugins = new_plugins})\n#elif MIN_VERSION_ghc(9,4,0)\n let sp = StaticPlugin (PluginWithArgs plgn args)\n old_plugins = hsc_plugins hsc_env\n old_static_plugins = staticPlugins old_plugins\n new_static_plugins = sp : old_static_plugins\n new_plugins = old_plugins {staticPlugins = new_static_plugins}\n setSession (hsc_env {hsc_plugins = new_plugins})\n#elif MIN_VERSION_ghc(9,2,0)\n -- In ghc < 9.6, adding static plugin. From ghc 9.2, plugins are stored in\n -- HscEnv. Before 9.2, plugins are stored in DynFlags.\n let sp = StaticPlugin (PluginWithArgs plgn args)\n old_static_plugins = hsc_static_plugins hsc_env\n new_static_plugins = sp : old_static_plugins\n setSession (hsc_env {hsc_static_plugins = new_static_plugins})\n#else\n let sp = StaticPlugin (PluginWithArgs plgn args)\n old_dflags = hsc_dflags hsc_env\n old_staticPlugins = staticPlugins old_dflags\n new_staticPlugins = sp : old_staticPlugins\n new_dflags = old_dflags {staticPlugins = new_staticPlugins}\n void (setSessionDynFlags new_dflags)\n#endif\n" }, { "path": "finkel-kernel/src/Language/Finkel/Preprocess.hs", "content": "{-# LANGUAGE CPP #-}\n-- Module header preprocessor\n\nmodule Language.Finkel.Preprocess\n (\n -- Preprocessor functions\n defaultPreprocess\n , defaultPreprocessEnv\n , defaultPreprocessWith\n\n -- Auxiliary\n , preprocessOrCopy\n , PpOptions(..)\n , ppOptions\n , mkPpOptions\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Exception (Exception (..), throw)\nimport Control.Monad (when)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.Char (toLower)\nimport Data.Maybe (fromMaybe)\nimport System.Console.GetOpt (ArgDescr (..), ArgOrder (..),\n OptDescr (..), getOpt, usageInfo)\nimport System.Environment (getArgs, getProgName)\nimport System.Exit (exitFailure)\nimport System.IO (IOMode (..), hPutStrLn, stderr,\n stdout, withFile)\n\n#if !MIN_VERSION_base(4,20,0)\nimport Data.List (foldl')\n#endif\n\n#if MIN_VERSION_base(4,11,0)\nimport Prelude hiding ((<>))\n#endif\n\n-- directory\nimport System.Directory (copyFile)\n\n-- ghc\nimport GHC_Data_Bag (unitBag)\nimport GHC_Data_FastString (fsLit)\nimport GHC_Data_StringBuffer (hGetStringBuffer)\nimport GHC_Driver_Env (HscEnv (..))\nimport GHC_Types_SrcLoc (GenLocated (..))\nimport GHC_Utils_Outputable (text, ($$), (<>))\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Config.Diagnostic (initDiagOpts)\nimport GHC.Driver.Errors.Types (ghcUnknownMessage)\nimport GHC.Types.Error (DiagnosticReason (..), mkMessages,\n mkPlainDiagnostic, noHints)\nimport GHC.Utils.Error (mkPlainMsgEnvelope)\nimport GHC_Driver_Monad (logDiagnostics)\n#else\nimport GHC (getPrintUnqual)\nimport GHC_Driver_Flags (WarnReason (..))\nimport GHC_Driver_Monad (logWarnings)\nimport GHC_Utils_Error (makeIntoWarning, mkWarnMsg)\n#endif\n\n#if !MIN_VERSION_ghc(9,2,0) || MIN_VERSION_ghc(9,4,0)\nimport GHC_Driver_Session (HasDynFlags (..))\n#endif\n\n-- finkel-kernel\nimport Language.Finkel.Emit (Hsrc (..), putHsSrc)\nimport Language.Finkel.Exception (FinkelException (..),\n handleFinkelException,\n printFinkelException,\n readOrFinkelException)\nimport Language.Finkel.Fnk (FnkEnv (..), Macro (..), addMacro,\n lookupMacro, macroFunction,\n makeEnvMacros, mergeMacros,\n modifyFnkEnv, runFnk, runFnk')\nimport Language.Finkel.Form (Form (..), LForm (..), aSymbol,\n unCode)\nimport Language.Finkel.Make.Cache\nimport Language.Finkel.Make.Session (expandContents)\nimport Language.Finkel.Make.Summary (buildHsSyn, withTiming')\nimport Language.Finkel.Make.TargetSource (findPragmaString)\nimport Language.Finkel.SpecialForms (defaultFnkEnv, emptyForm,\n specialForms)\nimport Language.Finkel.Syntax (parseHeader, parseModule)\n\nimport Language.Finkel.Options (FnkSrcOptions (..),\n defaultFnkSrcOptions,\n fromFnkSrcOptions)\n\n\n-- ------------------------------------------------------------------------\n--\n-- Exported\n--\n-- ------------------------------------------------------------------------\n\n-- | Default main function for preprocessor.\ndefaultPreprocess :: IO ()\ndefaultPreprocess = getArgs >>= defaultPreprocessWith defaultPreprocessEnv\n\n-- | 'FnkEnv' used in 'defaultPreprocess'.\ndefaultPreprocessEnv :: FnkEnv\ndefaultPreprocessEnv = defaultFnkEnv {envMacros=myMacros}\n where\n -- Adding \":require\", \":with-macro\", and \":eval-when-compile\" special forms\n -- to empty macros with dummy contents, because the preprocessor does not\n -- know the module lookup paths from the command line argument.\n myMacros = foldr f z interpMacros\n f name = addMacro (fsLit name) emptyFormMacro\n z = addMacro (fsLit \"defmodule\") defmoduleForDownsweep specialForms\n\ninterpMacros :: [String]\ninterpMacros =\n [ \":eval-when-compile\"\n , \":require\"\n , \":with-macro\"\n ]\n\n-- | Default main function for preprocessor, with given 'FnkEnv' and command\n-- line arguments.\ndefaultPreprocessWith\n :: FnkEnv -- ^ Environment for running 'Fnk'.\n -> [String] -- ^ Command line arguments.\n -> IO ()\ndefaultPreprocessWith fnk_env args =\n case getOpt Permute ppOptions args of\n ( _, _, errs@(_:_)) -> exitWithErrors errs\n (opts, files, _ ) -> handleFinkelException handler $ do\n me <- getProgName\n let ppo = foldl' (flip id) myPpOptions opts\n myPpOptions = mkPpOptions me fnk_env\n go = preprocessOrCopy Nothing ppo\n if ppoHelp ppo\n then printUsage\n else do\n debug ppo 2 (\"args: \" ++ show args)\n case files of\n [isrc] -> go isrc Nothing\n [isrc, opath] -> go isrc (Just opath)\n [_, isrc, opath] -> go isrc (Just opath)\n _ -> exitWithErrors []\n where\n handler e = do\n me <- getProgName\n hPutStrLn stderr (me ++ \": \" ++ displayException e)\n exitFailure\n exitWithErrors es = do\n mapM_ putStrLn es\n printUsage\n exitFailure\n\n-- | Preprocess Finkel source code file with given 'FnkEnv', or copy\n-- the file if the file was a Haskell source code.\npreprocessOrCopy\n :: Maybe HscEnv\n -- ^ Environment used for expanding macros.\n -> PpOptions\n -- ^ Pre-processor options.\n -> FilePath\n -- ^ Path of input Finkel source code.\n -> Maybe FilePath\n -- ^ 'Just' path to write preprocessed output, or 'Nothing' for 'stdout'.\n -> IO ()\npreprocessOrCopy mb_hsc_env ppo isrc mb_opath = do\n buf <- hGetStringBuffer isrc\n if not (ppoIgnore ppo) && findPragmaString (ppoPragma ppo) buf\n then do\n let opath = fromMaybe \"stdout\" mb_opath\n debug ppo 2 (\"Preprocessing \" ++ isrc ++ \" to \" ++ opath)\n writeModule mb_hsc_env ppo isrc mb_opath\n debug ppo 2 (\"Finished wriitng \" ++ isrc ++ \" to \" ++ opath)\n else do\n debug ppo 2 (\"Skipping \" ++ isrc)\n mapM_ (copyFile isrc) mb_opath\n\n\n-- ------------------------------------------------------------------------\n--\n-- Internal\n--\n-- ------------------------------------------------------------------------\n\nprintUsage :: IO ()\nprintUsage = do\n me <- getProgName\n let header = unlines\n [ me ++ \": Finkel source code preprocessor\"\n , \"\"\n , \"USAGE:\"\n , \"\"\n , \" \" ++ me ++ \" [OPTIONS] INPATH\"\n , \" \" ++ me ++ \" [OPTIONS] INPATH OUTPATH\"\n , \" \" ++ me ++ \" [OPTIONS] ORIGPATH INPATH OUTPATH\"\n , \"\"\n , \"OPTIONS:\" ]\n putStrLn (usageInfo header ppOptions)\n\nwriteModule\n :: Maybe HscEnv -> PpOptions -> FilePath -> Maybe FilePath -> IO ()\nwriteModule mb_hsc_env ppo ipath mb_opath =\n case mb_opath of\n Nothing -> run stdout\n Just opath -> withFile opath WriteMode run\n where\n run hdl =\n case mb_hsc_env of\n -- When hsc_env is given, assuming that given FnkEnv is already\n -- initialized.\n Just hsc_env -> runFnk' (go hdl) fnk_env hsc_env\n Nothing -> runFnk (go hdl) fnk_env\n fnk_env = (ppoFnkEnv ppo) {envVerbosity=ppoVerbosity ppo}\n parser = if ppoFull ppo\n then parseModule\n else parseHeader\n warn_interp_macros = 0 < ppoVerbosity ppo && ppoWarnInterp ppo\n go hdl = withTiming' \"writeModule\" $ handleFinkelException handler $ do\n when warn_interp_macros $\n modifyFnkEnv (replaceWithWarnings interpMacros)\n ExpandedCode {ec_sp=sp,ec_forms=forms1} <- expandContents ipath\n mdl <- buildHsSyn parser forms1\n putHsSrc hdl sp (Hsrc mdl)\n handler e = do\n printFinkelException e\n liftIO exitFailure\n\ndebug :: MonadIO m => PpOptions -> Int -> String -> m ()\ndebug ppo level msg =\n when (level < ppoVerbosity ppo) $\n liftIO (hPutStrLn stderr (ppoExecName ppo ++ \": \" ++ msg))\n\n\n-- ------------------------------------------------------------------------\n--\n-- Macros\n--\n-- ------------------------------------------------------------------------\n\n-- Macro constantly returning empty form.\nemptyFormMacro :: Macro\nemptyFormMacro = Macro (const (pure emptyForm))\n\n-- Variant of defmodule macro to support 'downsweep' function in ghc's make\n-- function. Actual implementation of 'defmodule' macro is written in\n-- finkel-core package.\ndefmoduleForDownsweep :: Macro\ndefmoduleForDownsweep = Macro (pure . f)\n where\n f (LForm (L l0 lst)) = case lst of\n List (_:name:rest) -> go name rest\n _ -> emptyForm\n where\n go name rest =\n if null rest\n then moduleForm name\n else begin (moduleForm name : foldr accImportForm [] rest)\n begin xs = mkL0 (List (sym \":begin\" : xs))\n accImportForm x acc =\n case unCode x of\n List (y : ys) | y == sym \"import\" -> foldr accModule acc ys\n | y == sym \"import_when\"\n , ps:ys' <- ys\n , hasLoadPhase ps -> foldr accModule acc ys'\n _ -> acc\n accModule x acc =\n case x of\n LForm (L l1 (List ys)) -> importForm l1 ys : acc\n _ -> acc\n hasLoadPhase xs =\n case unCode (curve xs) of\n List ys -> sym \":load\" `elem` ys\n _ -> False\n moduleForm n = mkL0 (List [sym \"module\", n])\n importForm l xs = LForm (L l (List (sym \"import\" : map curve xs)))\n curve x = case x of\n LForm (L l (HsList ys)) -> LForm (L l (List ys))\n _ -> x\n sym = mkL0 . Atom . aSymbol\n mkL0 = LForm . L l0\n\n-- Replace given macro names with original macro with warning message.\nreplaceWithWarnings :: [String] -> FnkEnv -> FnkEnv\nreplaceWithWarnings names fnk_env = fnk_env {envMacros=added}\n where\n added = mergeMacros replaced orig_macros\n orig_macros = envMacros fnk_env\n replaced = makeEnvMacros (foldr f [] names)\n f name acc = case lookupMacro (fsLit name) fnk_env of\n Just macro -> (name, Macro (addWarning name macro)) : acc\n Nothing -> acc\n addWarning name macro form@(LForm (L loc _)) = do\n let msg =\n text \"Preprocessor does not interpret during macro expansion.\" $$\n text \"Replacing '(\" <> text name <> text \" ...)' with '(:begin)'.\" $$\n text \"Use \\\"--warn-interp=False\\\" to suppress this message.\"\n\n -- XXX: See \"GHC.SysTools.Process.{builderMainLoop,readerProc}\".\n --\n -- Until ghc 9.4, the messages from the Finkel preprocessor command are\n -- parsed, and then hard coded \"SevError\" message is printed by the\n -- logger. Although the below \"logWarnings\" is using \"SevWarning\", the\n -- parsed message is shown with \"SevError\".\n\n#if MIN_VERSION_ghc(9,4,0)\n dflags <- getDynFlags\n let diag = mkPlainDiagnostic WarningWithoutFlag noHints msg\n warning = mkPlainMsgEnvelope (initDiagOpts dflags) loc diag\n logDiagnostics (mkMessages (unitBag (fmap ghcUnknownMessage warning)))\n#elif MIN_VERSION_ghc(9,2,0)\n unqual <- getPrintUnqual\n let wmsg = mkWarnMsg loc unqual msg\n warning = makeIntoWarning NoReason wmsg\n logWarnings (unitBag warning)\n#else\n dflags <- getDynFlags\n unqual <- getPrintUnqual\n let wmsg = mkWarnMsg dflags loc unqual msg\n warning = makeIntoWarning NoReason wmsg\n logWarnings (unitBag warning)\n#endif\n\n -- Deleget to the original function\n macroFunction macro form\n\n-- ------------------------------------------------------------------------\n--\n-- Options for preprocessor\n--\n-- ------------------------------------------------------------------------\n\n-- | Preprocessor options\ndata PpOptions = PpOptions\n { ppoHelp :: Bool\n -- ^ Flag for showing help message.\n , ppoVerbosity :: !Int\n -- ^ Verbosity level.\n , ppoFull :: !Bool\n -- ^ Preprocess full module if 'True', otherwise parse module header only.\n , ppoWarnInterp :: !Bool\n -- ^ Flag for showing warning message for macros using interpreter.\n , ppoFnkSrcOptions :: !FnkSrcOptions\n -- ^ Finkel source code option for preprocessor.\n , ppoFnkEnv :: FnkEnv\n -- ^ The 'FnkEnv' to run 'Fnk'.\n , ppoExecName :: String\n -- ^ Executable name shown in debug message.\n }\n\n-- | Make 'PpOption' with some fields set to default value.\nmkPpOptions :: String -> FnkEnv -> PpOptions\nmkPpOptions exec_name fnk_env = PpOptions\n { ppoHelp = False\n , ppoVerbosity = 1\n , ppoFull = False\n , ppoWarnInterp = True\n , ppoFnkSrcOptions = defaultFnkSrcOptions\n , ppoFnkEnv = fnk_env\n , ppoExecName = exec_name\n }\n\nppoPragma :: PpOptions -> String\nppoPragma = fsrcPragma . ppoFnkSrcOptions\n\nppoIgnore :: PpOptions -> Bool\nppoIgnore = fsrcIgnore . ppoFnkSrcOptions\n\nppOptions :: [OptDescr (PpOptions -> PpOptions)]\nppOptions =\n [ Option [] [\"help\"]\n (NoArg (\\o -> o {ppoHelp = True}))\n \"Show this help and exit.\"\n , Option [] [\"verbose\"]\n (ReqArg (\\n o -> o {ppoVerbosity=readInt n}) \"INT\")\n \"Set verbosity level to INT.\"\n , Option [] [\"warn-interp\"]\n (OptArg (\\mb o -> o {ppoWarnInterp=maybe True parseBoolish mb}) \"BOOL\")\n (\"Show warning in macros using interpreter.\\n\" ++\n \"(default: True)\")\n , Option [] [\"no-warn-interp\"]\n (NoArg (\\o -> o {ppoWarnInterp=False}))\n \"Do not show warning in macros using interpreter.\"\n , Option [] [\"full\"]\n (NoArg (\\o -> o {ppoFull = True}))\n \"Parse full module instead of module header.\"\n ] ++ fnk_src_opts\n where\n fnk_src_opts = fromFnkSrcOptions wrap\n wrap f o = o {ppoFnkSrcOptions = f (ppoFnkSrcOptions o)}\n readInt = readOrFinkelException \"INT\" \"verbosity\"\n\nparseBoolish :: String -> Bool\nparseBoolish str\n | low_str `elem` trueish = True\n | low_str `elem` falsish = False\n | otherwise = throw (FinkelException msg)\n where\n low_str = map toLower str\n trueish = [\"true\", \"yes\", \"1\"]\n falsish = [\"false\", \"no\", \"0\"]\n msg = \"Expecting boolean value but got \\\"\" ++ str ++ \"\\\"\"\n" }, { "path": "finkel-kernel/src/Language/Finkel/Reader.y", "content": "-- -*- mode: haskell; -*-\n{\n{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n-- | S-expression reader.\n--\n-- Parser functions in this module are written with Happy parser generator.\n--\nmodule Language.Finkel.Reader\n ( parseSexprs\n , parseHeaderPragmas\n , sexpr\n , sexprs\n , psexpr\n , supportedLangExts\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Data.Char (toLower)\nimport Data.List (foldl')\n\n-- exceptions\nimport Control.Monad.Catch (MonadThrow(..))\n\n-- ghc\nimport GHC_Data_FastString (FastString, fsLit, unpackFS)\nimport GHC_Hs_ImpExp (ideclName)\nimport GHC_Unit_Module (moduleNameString)\nimport GHC_Types_SrcLoc (GenLocated(..), Located, SrcSpan,\n mkSrcSpan, combineSrcSpans)\nimport GHC_Types_SourceText (SourceText(..))\nimport GHC_Data_StringBuffer (StringBuffer)\n\n-- ghc-boot\nimport GHC.LanguageExtensions (Extension(..))\n\n-- Internal\nimport Language.Finkel.Data.SourceText\nimport Language.Finkel.Form\nimport Language.Finkel.Exception\nimport Language.Finkel.Lexer\n}\n\n%name sexpr_ sexp\n%name sexprs_ sexps\n\n%partial psexpr_ sexp\n%partial pheader header\n\n%tokentype { Located Token }\n%monad { SP } { >>= } { return }\n%lexer { tokenLexer } { L _ TEOF }\n\n%token\n'(' { L _ TOparen }\n')' { L _ TCparen }\n'[' { L _ TObracket }\n']' { L _ TCbracket }\n'{' { L _ TOcurly }\n'}' { L _ TCcurly }\n\n'quote' { L _ TQuote }\n'`' { L _ TQuasiquote }\n',' { L _ TUnquote }\n',@' { L _ TUnquoteSplice }\n'%_' { L _ (TPercent '_') }\n'%' { L _ (TPercent $$) }\n'pcommas' { L _ (TPcommas _) }\n\n'symbol' { L _ (TSymbol _) }\n'char' { L _ (TChar _ _) }\n'string' { L _ (TString _ _) }\n'integer' { L _ (TInteger _ _) }\n'frac' { L _ (TFractional _) }\n\n'doc' { L _ (TDocNext _) }\n'doc^' { L _ (TDocPrev _) }\n'doch' { L _ (TDocGroup _ _) }\n'doc$' { L _ (TDocNamed _ _) }\n\n%%\n\n-- Unit and List\n-- ~~~~~~~~~~~~~\n--\n-- Empty list will parsed as a unit (i.e. '()' in Haskell), non-empty lists are\n-- pased as 'List' value of 'Code'. Empty 'List' value of 'Code' could be\n-- referred with 'Language.Finkel.Form.nil'.\n\nsexp :: { Code }\n : atom { $1 }\n | 'quote' sexp { mkQuote $1 $2 }\n | '`' sexp { mkQuasiquote $1 $2 }\n | ',' sexp { mkUnquote $1 $2 }\n | ',@' sexp { mkUnquoteSplice $1 $2 }\n | '[' sexps ']' { mkHsList $1 $2 $3 }\n | 'pcommas' { mkPcommas $1 }\n | '(' sexps ')' { mkUnitOrList $1 $2 $3}\n | prag { $1 }\n\nsexps :: { [Code] }\n : rsexps { reverse $1 }\n\nrsexps :: { [Code] }\n : {- empty -} { [] }\n | rsexps sexp { $2 : $1 }\n | rsexps '%_' sexp { $1 }\n\natom :: { Code }\n : 'symbol' { mkASymbol $1 }\n | 'char' { mkAChar $1 }\n | 'string' { mkAString $1 }\n | 'integer' { mkAInteger $1 }\n | 'frac' { mkAFractional $1 }\n | '{' { mkOcSymbol $1 }\n | '}' { mkCcSymbol $1 }\n | 'doc' { mkDoc $1 }\n | 'doc^' { mkDocp $1 }\n | 'doch' { mkDoch $1 }\n | 'doc$' { mkDock $1 }\n\nprag :: { Code }\n : '%' sexp {% rmac $1 $2 }\n\n\nheader :: { [Code] }\n : {- empty -} { [] }\n | header prag { $2 : $1 }\n\n{\natom :: SrcSpan -> Atom -> Code\natom l x = LForm $ L l $ Atom x\n{-# INLINABLE atom #-}\n\nsym :: SrcSpan -> FastString -> Code\nsym l str = atom l $ ASymbol str\n{-# INLINABLE sym #-}\n\nli :: SrcSpan -> [Code] -> Code\nli l xs = LForm $ L l $ List xs\n{-# INLINABLE li #-}\n\nmkQuote :: Located Token -> Code -> Code\nmkQuote (L l _) body = li l [sym l \":quote\", body]\n{-# INLINABLE mkQuote #-}\n\nmkQuasiquote :: Located Token -> Code -> Code\nmkQuasiquote (L l _) body = li l [sym l \":quasiquote\", body]\n{-# INLINABLE mkQuasiquote #-}\n\nmkUnquote :: Located Token -> Code -> Code\nmkUnquote (L l _) body = li l [sym l \":unquote\", body]\n{-# INLINABLE mkUnquote #-}\n\nmkUnquoteSplice :: Located Token -> Code -> Code\nmkUnquoteSplice (L l _) body = li l [sym l \":unquote-splice\", body]\n{-# INLINABLE mkUnquoteSplice #-}\n\nmkHsList :: Located Token -> [Code] -> Located Token -> Code\nmkHsList (L lo _) body (L lc _) =\n LForm $ L (combineSrcSpans lo lc) $ HsList body\n{-# INLINABLE mkHsList #-}\n\nmkPcommas :: Located Token -> Code\nmkPcommas (L l (TPcommas n)) = li l [sym l (fsLit (replicate n ','))]\n{-# INLINABLE mkPcommas #-}\n\nmkUnitOrList :: Located Token -> [Code] -> Located Token -> Code\nmkUnitOrList (L lo _) body (L lc _) =\n let l = combineSrcSpans lo lc\n in case body of\n [] -> atom l AUnit\n _ -> li l body\n{-# INLINABLE mkUnitOrList #-}\n\nmkASymbol :: Located Token -> Code\nmkASymbol (L l (TSymbol x)) = atom l $ ASymbol x\n{-# INLINABLE mkASymbol #-}\n\nmkAChar :: Located Token -> Code\nmkAChar (L l (TChar st x)) = atom l $ AChar st x\n{-# INLINABLE mkAChar #-}\n\nmkAString :: Located Token -> Code\nmkAString (L l (TString st x)) = atom l $ aString st x\n{-# INLINABLE mkAString #-}\n\nmkAInteger :: Located Token -> Code\nmkAInteger (L l (TInteger st n)) = atom l $ AInteger lit\n where\n lit = IL { il_text = st\n , il_neg = n < 0\n , il_value = n }\n{-# INLINABLE mkAInteger #-}\n\nmkAFractional :: Located Token -> Code\nmkAFractional (L l (TFractional x)) = atom l $ AFractional x\n{-# INLINABLE mkAFractional #-}\n\nmkOcSymbol :: Located Token -> Code\nmkOcSymbol (L l _) = sym l \"{\"\n{-# INLINABLE mkOcSymbol #-}\n\nmkCcSymbol :: Located Token -> Code\nmkCcSymbol (L l _) = sym l \"}\"\n{-# INLINABLE mkCcSymbol #-}\n\nmkDoc :: Located Token -> Code\nmkDoc (L l (TDocNext str)) =\n li l [sym l \":doc\", atom l (AString (toSourceText str) str)]\n{-# INLINABLE mkDoc #-}\n\nmkDocp :: Located Token -> Code\nmkDocp (L l (TDocPrev str)) =\n li l [sym l \":doc^\", atom l (AString (toSourceText str) str)]\n{-# INLINABLE mkDocp #-}\n\nmkDoch :: Located Token -> Code\nmkDoch (L l (TDocGroup n s)) = li l [sym l dh, atom l (AString st s)]\n where\n dh = case n of\n 1 -> \":dh1\"\n 2 -> \":dh2\"\n 3 -> \":dh3\"\n _ -> \":dh4\"\n st = toSourceText s\n{-# INLINABLE mkDoch #-}\n\nmkDock :: Located Token -> Code\nmkDock (L l (TDocNamed k mb_doc)) =\n case mb_doc of\n Nothing -> li l pre\n Just d -> li l (pre ++ [atom l (AString (toSourceText d) d)])\n where\n pre = [sym l \":doc$\", atom l (ASymbol k)]\n{-# INLINABLE mkDock #-}\n\nrmac :: Char -> Code -> SP Code\nrmac c expr =\n case c of\n 'p' -> pragma expr\n _ -> errorSP expr (\"rmac: unsupported char \" ++ show c)\n{-# INLINABLE rmac #-}\n\n-- Module from ghc package with codes related to language pragma:\n--\n-- + libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs: The file containing\n-- definition of language extensions.\n--\n-- + compiler/main/HeaderInfo.hs: Parses header information.\n--\n-- + compiler/main/DynFlags.hs: Contains 'supportedExtensions :: [String]'. This\n-- is a list of language extension names, and the names with \"No\"\n-- prefix. 'xFlagsDeps' contains list of pair language extension and\n-- deprecation messages.\n--\n\npragma :: Code -> SP Code\npragma orig@(LForm (L l form)) =\n case form of\n -- Pragma with no arguments.\n List [LForm (L _ (Atom (ASymbol sym)))]\n -- Return the UNPACK form as is. This pragma is handled by syntax parser\n -- of data constructor field.\n | normalize sym `elem` noArgPragmas -> return orig\n\n -- Pragma with arguments.\n List (LForm (L l' (Atom (ASymbol sym))):rest)\n | normalize sym `elem` inlinePragmas -> return orig\n | normalize sym == \"language\" -> do\n let (exts, invalids) = groupExts rest\n case invalids of\n [] -> do\n sp <- getSPState\n putSPState (sp {langExts = exts ++ langExts sp})\n return (emptyBody l)\n _ -> errorSP orig (\"Unsupported LANGUAGE pragma: \" ++\n show invalids)\n | normalize sym `elem` spcls -> do\n let specialize = LForm (L l' (Atom (ASymbol \"SPECIALIZE\")))\n return (LForm (L l (List (specialize:rest))))\n | normalize sym == \"options_ghc\" -> do\n modifySPState\n (\\sp -> sp {ghcOptions =\n makeOptionFlags rest ++ ghcOptions sp})\n return (emptyBody l)\n | normalize sym == \"options_haddock\" -> do\n modifySPState\n (\\sp -> sp {haddockOptions =\n makeOptionFlags rest ++ haddockOptions sp})\n return (emptyBody l)\n _ -> errorSP orig (\"Unknown pragma: \" ++ show form)\n where\n normalize = map toLower . unpackFS\n inlinePragmas = [\"inline\", \"noinline\", \"inlinable\"]\n spcls = [\"specialize\", \"specialise\"]\n\nnoArgPragmas :: [String]\nnoArgPragmas =\n [ \"unpack\"\n , \"overlappable\", \"overlapping\", \"overlaps\", \"incoherent\"]\n\ngroupExts :: [Code] -> ([Located String],[Code])\ngroupExts = foldr f ([],[])\n where\n f form (exts, invalids) =\n case form of\n LForm (L l (Atom (ASymbol sym)))\n | Just ext <- lookup sym supportedLangExts ->\n (L l ext:exts, invalids)\n _ -> (exts, form:invalids)\n\nsupportedLangExts :: [(FastString, String)]\nsupportedLangExts =\n f [ BangPatterns\n , DataKinds\n , DefaultSignatures\n , DeriveAnyClass\n , DeriveDataTypeable\n , DeriveFoldable\n , DeriveFunctor\n , DeriveGeneric\n , DeriveTraversable\n , DerivingStrategies\n , DerivingVia\n , EmptyCase\n , EmptyDataDeriving\n , ExistentialQuantification\n , ExplicitForAll\n , FlexibleContexts\n , FlexibleInstances\n , GADTs\n , GeneralizedNewtypeDeriving\n , ImplicitPrelude\n , ImpredicativeTypes\n , KindSignatures\n , MultiParamTypeClasses\n , MonoLocalBinds\n , MonomorphismRestriction\n#if MIN_VERSION_ghc(9,4,0)\n , NamedFieldPuns\n#endif\n , OverloadedStrings\n , OverloadedLabels\n , OverloadedLists\n , PolyKinds\n , RankNTypes\n#if !MIN_VERSION_ghc(9,4,0)\n , RecordPuns\n#endif\n , RecordWildCards\n , ScopedTypeVariables\n , StandaloneKindSignatures\n , StandaloneDeriving\n , TypeApplications\n , TypeFamilies\n , TypeInType\n , TypeOperators\n , TypeSynonymInstances\n , UndecidableInstances ]\n where\n -- Adding `\"No\"' prefix, as done in `DynFlags.supportedExtensions'. Might\n -- worth looking up `DynFlags.xFlags' to get string representation of\n -- language extension instead of applying `show' function.\n f = concatMap g\n g ext = [(fsLit name, name), (fsLit noname, noname)]\n where\n#if MIN_VERSION_ghc(9,4,0)\n name = show ext\n#else\n -- Until ghc 9.4.0, NamedFieldPuns constructor did not exist\n -- in LanguageExtensions.\n name = case ext of\n RecordPuns -> \"NamedFieldPuns\"\n _ -> show ext\n#endif\n noname = \"No\" ++ name\n\nmakeOptionFlags :: [Code] -> [Located String]\nmakeOptionFlags = foldl' f []\n where\n f acc code =\n case code of\n LForm (L l (Atom (ASymbol sym))) -> L l (unpackFS sym) : acc\n _ -> acc\n\nemptyBody :: SrcSpan -> Code\nemptyBody l = li l [sym l \":begin\"]\n\ndispatch :: Located Token -> Code -> SP Code\ndispatch (L _ (TSymbol sym)) form =\n case sym of\n \".\" -> error \"dispatch: dot\"\n _ -> errorSP form \"dispatch\"\n\nhappyError :: SP a\nhappyError = lexErrorSP\n\n-- | Parse S-expressions.\nparseSexprs :: MonadThrow m\n => Maybe FilePath -- ^ Name of input file.\n -> StringBuffer -- ^ Contents to parse.\n -> m ([Code], SPState)\nparseSexprs = parseWith sexprs_\n\n-- | Parse file header pragmas.\nparseHeaderPragmas :: MonadThrow m\n => Maybe FilePath\n -> StringBuffer\n -> m ([Code], SPState)\nparseHeaderPragmas = parseWith pheader\n\nparseWith :: MonadThrow m\n => SP a\n -> Maybe FilePath\n -> StringBuffer\n -> m (a, SPState)\nparseWith p mb_file contents =\n either (throwM . toLexicalException) pure (runSP p mb_file contents)\n where\n toLexicalException (LexicalError l c _) = LexicalException (mkSrcSpan l l) c\n{-# INLINABLE parseWith #-}\n\n-- | Parse single S-expression.\nsexpr :: SP Code\nsexpr = sexpr_\n\n-- | Parse list of S-expressions.\nsexprs :: SP [Code]\nsexprs = sexprs_\n\n-- | Partial S-expression parser.\npsexpr :: SP Code\npsexpr = psexpr_\n}\n" }, { "path": "finkel-kernel/src/Language/Finkel/SpecialForms.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE MagicHash #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE ViewPatterns #-}\n\n-- | Special forms.\nmodule Language.Finkel.SpecialForms\n ( specialForms\n , unquoteSplice\n , defaultFnkEnv\n , emptyForm\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Exception (throw)\nimport Control.Monad (foldM, unless, when)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.Foldable (toList)\nimport Data.Functor (void)\nimport Data.Maybe (catMaybes)\nimport GHC.Exts (unsafeCoerce#)\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Utils.Outputable ((<>))\nimport Prelude hiding ((<>))\n#endif\n\n-- containers\nimport Data.Map (fromList)\n\n-- exceptions\nimport Control.Monad.Catch (bracket)\n\n-- ghc\nimport GHC (ModuleInfo, getModuleInfo,\n lookupModule, lookupName,\n modInfoExports, setContext)\nimport GHC_Data_FastString (FastString, fsLit, unpackFS)\nimport GHC_Driver_Env_Types (HscEnv (..))\nimport GHC_Driver_Main (Messager, hscTcRnLookupRdrName,\n showModuleIndex)\nimport GHC_Driver_Monad (GhcMonad (..), modifySession)\nimport GHC_Driver_Ppr (showPpr)\nimport GHC_Driver_Session (DynFlags (..), GeneralFlag (..),\n HasDynFlags (..), getDynFlags,\n unSetGeneralFlag')\nimport GHC_Hs (HsModule (..))\nimport GHC_Hs_ImpExp (ImportDecl (..), ieName)\nimport GHC_Iface_Recomp (RecompileRequired (..),\n recompileRequired)\nimport GHC_Runtime_Context (InteractiveImport (..))\nimport GHC_Runtime_Eval (getContext)\nimport GHC_Types_Name (nameOccName, occName)\nimport GHC_Types_Name_Occurrence (occNameFS)\nimport GHC_Types_Name_Reader (rdrNameOcc)\nimport GHC_Types_SrcLoc (GenLocated (..), SrcSpan (..), unLoc)\nimport GHC_Types_TyThing (TyThing (..))\nimport GHC_Types_Var (varName)\nimport GHC_Unit_Finder (FindResult (..), findImportedModule)\nimport GHC_Unit_Home_ModInfo (lookupHpt)\nimport GHC_Unit_Module (Module, moduleNameString)\nimport GHC_Unit_Module_Graph (ModuleGraph, mgLookupModule,\n showModMsg)\nimport GHC_Unit_Module_ModSummary (ModSummary (..))\nimport GHC_Utils_Error (compilationProgressMsg)\nimport GHC_Utils_Outputable (SDoc, fsep, nest, ppr, text, vcat,\n (<+>))\n\n#if MIN_VERSION_ghc(9,6,0)\nimport Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..))\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Env (hscActiveUnitId, hsc_HUG)\nimport GHC.Unit.Env (lookupHug)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Env (hsc_HPT, hsc_units)\nimport GHC.Iface.Recomp (CompileReason (..))\nimport GHC.Types.PkgQual (PkgQual (..))\nimport GHC.Unit.Module.Graph (ModuleGraphNode (..))\nimport GHC.Unit.State (pprWithUnitState)\nimport GHC.Utils.Logger (logVerbAtLeast)\nimport GHC.Utils.Outputable (empty)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Types_SrcLoc (UnhelpfulSpanReason (..))\n#endif\n\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Data.SourceText\nimport Language.Finkel.Eval\nimport Language.Finkel.Exception\nimport Language.Finkel.Expand (expand, expands')\nimport Language.Finkel.Fnk\nimport Language.Finkel.Form\nimport Language.Finkel.Homoiconic\nimport Language.Finkel.Make (findTargetModuleNameMaybe,\n makeFromRequire,\n makeFromRequirePlugin)\nimport Language.Finkel.Make.Session (bcoDynFlags)\nimport Language.Finkel.Make.TargetSource (targetSourcePath)\nimport Language.Finkel.Syntax (parseExpr, parseLImport,\n parseModuleNoHeader)\nimport Language.Finkel.Syntax.Utils\n\n\n-- ---------------------------------------------------------------------\n--\n-- Quasiquote\n--\n-- ---------------------------------------------------------------------\n\n-- Quasiquote is implemented as special form in Haskell. Though it could be\n-- implemented in Finkel code later. If done in Finkel code, lexer and reader\n-- still need to handle the special case for backtick, comma, and comma-at,\n-- because currently there's no way to define read macro.\n\nquasiquote :: Bool -> Code -> Code\nquasiquote qual orig@(LForm (L l form)) =\n case form of\n List [LForm (L _ (Atom (ASymbol \":unquote\"))), x]\n | isUnquoteSplice x -> x\n | otherwise -> tList l [tSym l (toCodeS qual), x]\n List forms'\n | [q, body] <- forms'\n , q == tSym l \":quasiquote\" -> qq (qq body)\n | any isUnquoteSplice forms' -> spliced qListS forms'\n | otherwise -> nonSpliced qListS forms'\n HsList forms'\n | any isUnquoteSplice forms' -> spliced qHsListS forms'\n | otherwise -> nonSpliced qHsListS forms'\n Atom _ -> tList l [tSym l \":quote\", orig]\n TEnd -> orig\n where\n spliced tag forms =\n tList l [ tSym l (tag qual)\n , tList l [ tSym l (concatS qual)\n , tHsList l (go [] forms) ]\n , fname, sl, sc, el, ec ]\n nonSpliced tag forms =\n tList l [ tSym l (tag qual)\n , tHsList l (map qq forms)\n , fname, sl, sc, el, ec ]\n (fname, sl, sc, el, ec) = withLocInfo l (tString qq_l) (tInt qq_l)\n go acc forms =\n let (pre, post) = break isUnquoteSplice forms\n in case post of\n LForm (L ls (List (_:body))):post' ->\n go (acc ++ [tHsList l (map qq pre)\n ,tList ls [ tSym l (unquoteSpliceS qual)\n , tList l body]])\n post'\n _ | null pre -> acc\n | otherwise -> acc ++ [tHsList l (map qq pre)]\n qq = quasiquote qual\n#if MIN_VERSION_ghc(9,0,0)\n qq_l = UnhelpfulSpan (UnhelpfulOther (fsLit \"\"))\n#else\n qq_l = UnhelpfulSpan (fsLit \"\")\n#endif\n\nisUnquoteSplice :: Code -> Bool\nisUnquoteSplice (LForm form) =\n case form of\n L _ (List (LForm (L _ (Atom (ASymbol \":unquote-splice\"))):_))\n -> True\n _ -> False\n{-# INLINABLE isUnquoteSplice #-}\n\n-- | Internally used by macro expander for @:unquote-splice@ special form.\n--\n-- This functions throw 'InvalidUnquoteSplice' when the given argument could not\n-- be unquote spliced.\nunquoteSplice :: Homoiconic a => a -> [Code]\nunquoteSplice form =\n case unCode c of\n List xs -> xs\n HsList xs -> xs\n Atom AUnit -> []\n Atom (AString _ xs) -> map toCode (unpackFS xs)\n _ -> throw (InvalidUnquoteSplice c)\n where\n c = toCode form\n\n\n-- ---------------------------------------------------------------------\n--\n-- Macro\n--\n-- ---------------------------------------------------------------------\n\ncoerceMacro :: DynFlags -> Code -> Fnk Macro\ncoerceMacro dflags name =\n case unCode name of\n Atom (ASymbol _) -> go\n _ -> failFnk \"coerceMacro: expecting name symbol\"\n where\n go = do\n qualify <- envQualifyQuotePrimitives <$> getFnkEnv\n case evalBuilder dflags qualify parseExpr [name] of\n Right hexpr -> unsafeCoerce# <$> evalExpr hexpr\n Left err -> failFnk (syntaxErrMsg err)\n{-# INLINABLE coerceMacro #-}\n\n-- CPP macro hack to support pattern matching with ImportListInterpretation\n-- introduced in ghc 9.6 to work with older version of ghc .\n#if !MIN_VERSION_ghc(9,6,0)\n#define EverythingBut True\n#define Exactly False\n#endif\n\ngetTyThingsFromIDecl :: GhcMonad m => HImportDecl -> ModuleInfo -> m [TyThing]\ngetTyThingsFromIDecl (L _ idecl) minfo = do\n -- 'toImportList' borrowed from local definition in\n -- 'TcRnDriver.tcPreludeClashWarn'.\n let exportedNames = modInfoExports minfo\n ieName' (dL->L l ie) = la2la (cL l (ieName ie))\n toImportList (h, dL->L _ loc) = (h, map ieName' loc)\n#if MIN_VERSION_ghc(9,6,0)\n ideclImportList' = ideclImportList\n#else\n ideclImportList' = ideclHiding\n#endif\n getNames =\n case fmap toImportList (ideclImportList' idecl) of\n -- Import with `hiding' entities. Comparing 'Name' and 'RdrName' via\n -- OccName'.\n Just (EverythingBut, ns) -> do\n let f n acc = if nameOccName n `elem` ns'\n then acc\n else n : acc\n ns' = map (rdrNameOcc . unLoc) ns\n return (foldr f [] exportedNames)\n\n -- Import with explicit entities.\n Just (Exactly, ns) -> do\n hsc_env <- getSession\n let lkup_name = fmap toList . hscTcRnLookupRdrName hsc_env\n concat <$> mapM (liftIO . lkup_name) ns\n\n -- Import whole module.\n Nothing -> return exportedNames\n\n catMaybes <$> (getNames >>= mapM lookupName)\n\naddImportedMacro :: HscEnv -> TyThing -> Fnk ()\naddImportedMacro hsc_env thing = go\n where\n go =\n case thing of\n AnId var -> do\n let name_str = showPpr dflags (varName var)\n name_sym = toCode (aSymbol name_str)\n coerceMacro dflags name_sym >>= insertMacro (fsLit name_str)\n _ -> failFnk \"addImportedmacro\"\n dflags = hsc_dflags hsc_env\n\n-- Note [Bytecode and object code for require and :eval_when_compile import]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- Use of object codes are not working well for importing home package modules\n-- when optimization option were enabled. Conservatively using bytecode by\n-- delegating further works to 'makeFromRequire' via 'withInternalLoad' for\n-- such cases.\n\nwithInternalLoad :: Fnk a -> Fnk a\nwithInternalLoad act = do\n -- 'DynFlags' in the current session might be updated by the file local\n -- pragmas. Using the 'DynFlags' from 'envDefaultDynFlags', which is\n -- initialized when entering the 'make' function in 'initSessionForMake' for\n -- ExecMode mode and 'newHscEnvForExpand' in GhcPluginMode.\n --\n -- Updating the current context in HscEnv, to avoid home module import errors,\n -- which may happen when compiling with bytecode interpreter (e.g., done when\n -- generating Haddock documentation) in ghc 9.4.2.\n --\n let acquire = (,,) <$> getContext <*> getDynFlags <*> getFnkEnv\n restore (context, dflags, fnk_env) = do\n setContext context\n setDynFlags dflags\n putFnkEnv fnk_env\n no_force_recomp = unSetGeneralFlag' Opt_ForceRecomp\n update = setDynFlags . no_force_recomp . bcoDynFlags\n\n bracket acquire restore $ \\(_context, _dflags, fnk_env) -> do\n setContext []\n -- XXX: Is haskell-language-server updating interactive dynflags?\n --\n -- The envDefaultDynFlags field is initialized to the DynFlags from\n -- interactive context, in Language.Finkel.ParsedResult when initializing\n -- the plugin.\n mapM_ update (envDefaultDynFlags fnk_env)\n putFnkEnv fnk_env {envMessager = if 0 < envVerbosity fnk_env\n then internalLoadMessager\n else doNothingMessager}\n act\n\ninternalLoadMessager :: Messager\ninternalLoadMessager hsc_env mod_index recomp node =\n -- See: GHC.Driver.Main.batchMsg\n#if MIN_VERSION_ghc(9,4,0)\n case recomp of\n UpToDate -> when (logVerbAtLeast (hsc_logger hsc_env) 2)\n (showMsg (text \"Skipping \") \"\")\n NeedsRecompile reason0 ->\n let herald = case node of\n LinkNode {} -> \"Linking \"\n InstantiationNode {} -> \"Instantiating \"\n ModuleNode {} -> \"Compiling \"\n in showMsg (text herald) $ case reason0 of\n MustCompile -> empty\n (RecompBecause reason1) ->\n let state = hsc_units hsc_env\n in text \" [\" <> pprWithUnitState state (ppr reason1) <> text \"]\"\n#else\n case recomp of\n MustCompile -> showMsg \"Compiling \" \"\"\n UpToDate -> when (verbosity dflags >= 2) (showMsg \"Skipping \" \"\")\n# if MIN_VERSION_ghc(9,2,0)\n RecompBecause why -> showMsg \"Compiling \" (\" [\" <> text why <> \"]\")\n# else\n RecompBecause why -> showMsg \"Compiling \" (\" [\" ++ why ++ \"]\")\n# endif\n#endif\n where\n dflags = hsc_dflags hsc_env\n showMsg msg reason =\n#if MIN_VERSION_ghc(9,4,0)\n compilationProgressMsg (hsc_logger hsc_env)\n (text \"(*) \" <> showModuleIndex mod_index <> msg <>\n showModMsg dflags (recompileRequired recomp) node <>\n reason)\n#elif MIN_VERSION_ghc(9,2,0)\n compilationProgressMsg (hsc_logger hsc_env) dflags\n (text \"(*) \" <> showModuleIndex mod_index <> msg <>\n showModMsg dflags (recompileRequired recomp) node <>\n reason)\n#else\n compilationProgressMsg dflags\n (\"(*) \" ++ showModuleIndex mod_index ++ msg ++\n showModMsg dflags (hscTarget dflags)\n (recompileRequired recomp)\n node ++\n reason)\n#endif\n\ndoNothingMessager :: Messager\ndoNothingMessager _hsc_env _mod_index _recomp _node = pure ()\n\nmakeMissingHomeMod :: HImportDecl -> Fnk ()\nmakeMissingHomeMod (L _ idecl) = do\n -- Try finding the required module. Delegate the work to 'makeFromRequire'\n -- function when the file is found in import paths.\n -- Look up module with \"findTargetModuleNameMaybe\" before \"findImportedModule\"\n -- is to avoid loading modules from own package when generating documentation\n -- with haddock. Always checking up-to-date ness via \"makeFromRequire\".\n --\n -- N.B. 'findImportedModule' does not know \".fnk\" file extension, so it will\n -- not return Finkel source files for home package modules.\n --\n hsc_env <- getSession\n fnk_env <- getFnkEnv\n\n let mname = unLoc lmname\n lmname = reLoc (ideclName idecl)\n invoked = envInvokedMode fnk_env\n mk_fn = case invoked of\n ExecMode -> makeFromRequire\n\n -- Some attempts to get incrementally compiled home module info in ghc\n -- 9.6. One is to use the ModIfaceCache, another is to use hscUpdateHPT.\n --\n -- GhcPluginMode -> \\lm -> do\n -- -- XXX: keep old modiface cache, combine and update after calling\n -- -- makeFromRequirePlugin.\n -- old_caches <- getCachedIface\n -- makeFromRequirePlugin lm\n -- liftIO $ case envInterpModIfaceCache fnk_env of\n -- Just mic -> mapM_ (iface_addToCache mic) old_caches\n -- _ -> pure ()\n --\n -- -- let -- get the old hpt before invoking makeFromRequirePlugin ...\n -- -- update_hpt hpt = foldr addHomeModInfoToHpt hpt (eltsHpt old_hpt)\n -- -- new_hsc_env = hscUpdateHPT update_hpt hsc_env\n -- -- setSession new_hsc_env\n\n GhcPluginMode -> makeFromRequirePlugin\n\n smpl_mk = withInternalLoad (void $ mk_fn lmname)\n dflags = hsc_dflags hsc_env\n tr = debug fnk_env \"makeMissinghomeMod\"\n do_mk msgs = tr msgs >> smpl_mk\n dont_mk = tr\n\n -- XXX: See 'GHC.Driver.Make.enableCodeGenWhen', which is looking up dynflags\n -- from mod summary, and looking up node key from 'needs_codegen_map'. The\n -- 'needs_codegen_map' will filter out modules not containing TemplateHaskell\n -- language extension when backend does not generate codes (which means ghc\n -- invoked with \"-fno-code\" option).\n\n -- Alternate attemps to get incrementally added home modules in ghc 9.6, which\n -- did not work ...:\n --\n -- mb_installed_mod <- do\n -- let installed_mod = mkModule (hscActiveUnitId hsc_env) mname\n -- FinderCache ref _ = hsc_FC hsc_env\n -- im_env <- liftIO (readIORef ref)\n -- pure (lookupInstalledModuleEnv im_env installed_mod)\n --\n -- let by_mname ms = ms_mod_name ms == mname\n -- mb_installed_mod = find by_mname (mgModSummaries (hsc_mod_graph hsc_env))\n\n let mb_installed_mod = lookupHpt (hsc_HPT hsc_env) mname\n\n case mb_installed_mod of\n -- When the compiler was invoked as ghc plugin, skipping compilation of home\n -- module when the module was found in current home package table.\n -- Otherwise, homeModError would be shown when loading interface file.\n Just _ -> case invoked of\n ExecMode -> do_mk [\"Found\" <+> ppr mname <+> \"in HPT\"]\n GhcPluginMode -> dont_mk [\"Skipping\" <+> ppr mname <+> \"found in HPT\"]\n _ -> do\n\n#if MIN_VERSION_ghc(9,4,0)\n tr [\"No\" <+> ppr mname <+> \"in HPT\"]\n case lookupHug (hsc_HUG hsc_env) (hscActiveUnitId hsc_env) mname of\n Just _ -> tr [\"Found\" <+> ppr mname <+> \"in home unit graph\"]\n _ -> tr [\"No\" <+> ppr mname <+> \"in home unit graph\"]\n#endif\n\n mb_ts <- findTargetModuleNameMaybe dflags lmname\n case mb_ts of\n Just ts -> do_mk [\"Found file\" <+> text (targetSourcePath ts)]\n Nothing -> do\n#if MIN_VERSION_ghc(9,4,0)\n let no_pkg_qual = NoPkgQual\n#else\n let no_pkg_qual = Nothing\n#endif\n fresult <- liftIO (findImportedModule hsc_env mname no_pkg_qual)\n case fresult of\n Found {} -> dont_mk [\"Skipping\" <+> ppr mname <+> \"found in Finder\"]\n _ -> do_mk [\"Module\" <+> ppr mname <+> \"not found\"]\n\n\n-- ---------------------------------------------------------------------\n--\n-- Special forms\n--\n-- ---------------------------------------------------------------------\n\nm_quasiquote :: MacroFunction\nm_quasiquote form =\n case unLForm form of\n L l (List [_,body]) -> do\n qualify <- fmap envQualifyQuotePrimitives getFnkEnv\n let LForm (L _ body') = quasiquote qualify body\n return (LForm (L l body'))\n _ -> finkelSrcError form \"Malformed quasiquote\"\n\nm_withMacro :: MacroFunction\nm_withMacro form =\n case unLForm form of\n L l1 (List (_:LForm (L _ (List forms)):rest)) -> do\n fnkc_env0 <- getFnkEnv\n hsc_env <- getSession\n\n -- Expand body of `with-macro' with temporary macros.\n macros <- fromList <$> evalMacroDefs hsc_env forms\n let tmpMacros0 = envTmpMacros fnkc_env0\n putFnkEnv (fnkc_env0 {envTmpMacros = macros : tmpMacros0})\n expanded <- expands' rest\n\n -- Getting 'FnkEnv' again, so that the persistent macros defined inside\n -- the `with-macro' body could be used from here. Then restoring tmporary\n -- macros to preserved value.\n fnkc_env1 <- getFnkEnv\n putFnkEnv (fnkc_env1 {envTmpMacros = tmpMacros0})\n\n case expanded of\n [x] -> return x\n _ -> return (tList l1 (tSym l1 \":begin\" : expanded))\n _ -> finkelSrcError form (\"with-macro: malformed args:\\n\" ++ show form)\n where\n evalMacroDefs hsc_env forms = do\n forms' <- mapM expand forms\n qualify <- envQualifyQuotePrimitives <$> getFnkEnv\n case evalBuilder (hsc_dflags hsc_env) qualify parseModuleNoHeader forms' of\n Right HsModule {hsmodDecls=decls} -> do\n (tythings, ic) <- evalDecls decls\n modifySession (\\he -> he {hsc_IC=ic})\n foldM (asMacro hsc_env) [] tythings\n Left err -> finkelSrcError form (syntaxErrMsg err)\n asMacro hsc_env acc tything =\n case tything of\n AnId var | isMacro hsc_env tything ->\n do let name_fs = occNameFS (occName (varName var))\n name_sym = toCode (ASymbol name_fs)\n macro <- coerceMacro (hsc_dflags hsc_env) name_sym\n return ((MacroName name_fs, macro):acc)\n _ -> return acc\n\nm_require :: MacroFunction\nm_require form =\n -- The special form `require' modifies the HscEnv at the time of macro\n -- expansion, to update the context in compile time session. The `require' is\n -- implemented as special form, to support dependency analysis during\n -- compilation of multiple modules with `--make' command.\n --\n -- Note that the form body of `require' is parsed twice, once in Reader, and\n -- again in this module. Parsing twice because the first parse is done before\n -- expanding macro, to analyse the module dependency graph of home package\n -- module.\n --\n case form of\n LForm (L _ (List (_:code))) ->\n do dflags <- getDynFlags\n qualify <- envQualifyQuotePrimitives <$> getFnkEnv\n case evalBuilder dflags qualify parseLImport code of\n Right lidecl@(L _ idecl) -> do\n fnk_env <- getFnkEnv\n let tr = debug fnk_env \"m_require\"\n mname = unLoc (ideclName idecl)\n tr [ppr idecl]\n\n -- Handle home modules.\n makeMissingHomeMod lidecl\n context <- getContext\n tr (case context of\n [] -> [\"Got empty context\"]\n _ -> \"Got context: \" : [nest 2 (vcat (map ppr context))])\n let new_context = IIDecl idecl : context\n tr (\"Calling setContext with:\" : [nest 2 (vcat (map ppr new_context))])\n setContext new_context\n mgraph <- hsc_mod_graph <$> getSession\n tr [\"Calling lookupModule\"]\n mdl <- lookupModule mname Nothing\n\n -- Update required module names and compiled home modules in\n -- FnkEnv. These are used by the callee module (i.e. the module\n -- containing this 'require' form).\n let reqs0 = envRequiredHomeModules fnk_env\n reqs1 = case mgLookupModule' mgraph mdl of\n Just m -> m:reqs0\n _ -> reqs0\n modifyFnkEnv (\\e -> e {envRequiredHomeModules = reqs1})\n\n -- Look up Macros in parsed module, add to FnkEnv when found.\n tr [\"Getting module info\"]\n mb_minfo <- getModuleInfo mdl\n case mb_minfo of\n Just minfo -> do\n tr [\"Getting TyThings from IDecl:\" <+> ppr lidecl]\n things <- getTyThingsFromIDecl lidecl minfo\n hsc_env <- getSession\n let macros = filter (isMacro hsc_env) things\n tr [\"Number of TyThings:\" <+> text (show (length things))]\n tr [\"Adding macros:\", nest 2 (fsep (map ppr macros))]\n mapM_ (addImportedMacro hsc_env) macros\n return emptyForm\n Nothing ->\n finkelSrcError form\n (\"require: module \" ++\n moduleNameString mname ++ \" not found.\")\n Left err -> finkelSrcError form (\"require: \" ++ syntaxErrMsg err)\n _ -> finkelSrcError form \"require: malformed body\"\n\nm_evalWhenCompile :: MacroFunction\nm_evalWhenCompile form =\n case unLForm form of\n L l (List (_ : body)) -> do\n expanded <- expands' body\n dflags <- getDynFlags\n qualify <- envQualifyQuotePrimitives <$> getFnkEnv\n case evalBuilder dflags qualify parseModuleNoHeader expanded of\n Right HsModule { hsmodDecls = decls\n , hsmodImports = limps } -> do\n\n -- If module imports were given, add to current interactive context.\n -- Compile home modules if not found.\n unless (null limps) $ do\n mapM_ makeMissingHomeMod limps\n context <- getContext\n setContext (map (IIDecl . unLoc) limps ++ context)\n\n -- Then evaluate the declarations and set the interactive context with\n -- the update `tythings'. If the compiled decls contain macros, add\n -- to current Finkel environment.\n unless (null decls) $ do\n (tythings, ic) <- evalDecls decls\n modifySession (\\hsc_env -> hsc_env {hsc_IC=ic})\n fnk_env <- getFnkEnv\n hsc_env <- getSession\n let macros = filter (isMacro hsc_env) tythings\n debug fnk_env \"m_evalWhenCompile\"\n [\"Adding macros:\", nest 2 (fsep (map ppr macros))]\n mapM_ (addImportedMacro hsc_env) macros\n\n return emptyForm\n\n Left err -> finkelSrcError (LForm (L l (List body)))\n (syntaxErrMsg err)\n _ -> finkelSrcError form (\"eval-when-compile: malformed body: \" ++\n show form)\n\n-- | The special forms. The macros listed in 'specialForms' are used\n-- in default 'FnkEnv'.\nspecialForms :: EnvMacros\nspecialForms =\n makeEnvMacros\n [(\":eval-when-compile\", SpecialForm m_evalWhenCompile)\n ,(\":with-macro\", SpecialForm m_withMacro)\n ,(\":quasiquote\", SpecialForm m_quasiquote)\n ,(\":require\", SpecialForm m_require)]\n\n-- | Default 'FnkEnv'.\ndefaultFnkEnv :: FnkEnv\ndefaultFnkEnv = emptyFnkEnv\n { envMacros = specialForms\n , envDefaultMacros = specialForms\n }\n\n\n-- ---------------------------------------------------------------------\n--\n-- Auxiliary\n--\n-- ---------------------------------------------------------------------\n\ntSym :: SrcSpan -> FastString -> Code\ntSym l s = LForm (L l (Atom (ASymbol s)))\n{-# INLINABLE tSym #-}\n\ntString :: SrcSpan -> FastString -> Code\ntString l s = LForm (L l (Atom (AString (toQuotedSourceText s) s)))\n{-# INLINABLE tString #-}\n\ntInt :: SrcSpan -> Int -> Code\ntInt l i = LForm (L l (Atom (AInteger (mkIntegralLit i))))\n{-# INLINABLE tInt #-}\n\ntList :: SrcSpan -> [Code] -> Code\ntList l forms = LForm (L l (List forms))\n{-# INLINABLE tList #-}\n\ntHsList :: SrcSpan -> [Code] -> Code\ntHsList l forms = LForm (L l (HsList forms))\n{-# INLINABLE tHsList #-}\n\nemptyForm :: Code\nemptyForm =\n LForm (genSrc (List [LForm (genSrc (Atom (ASymbol \":begin\")))]))\n{-# INLINABLE emptyForm #-}\n\ntoCodeS :: Quote\ntoCodeS = quoteWith \"toCode\"\n{-# INLINABLE toCodeS #-}\n\nunquoteSpliceS :: Quote\nunquoteSpliceS = quoteWith \"unquoteSplice\"\n{-# INLINABLE unquoteSpliceS #-}\n\nconcatS :: Quote\nconcatS qual =\n if qual\n then \"Data.Foldable.concat\"\n else \"concat\"\n{-# INLINABLE concatS #-}\n\n-- | Debug function for this module\ndebug :: (MonadIO m, HasDynFlags m) => FnkEnv -> SDoc -> [SDoc] -> m ()\ndebug fnk_env _fn = debugWhen fnk_env Fnk_trace_spf\n\nmgLookupModule' :: ModuleGraph -> Module -> Maybe ModSummary\n#if MIN_VERSION_ghc (8,4,0)\nmgLookupModule' = mgLookupModule\n#else\nmgLookupModule' mg mdl = go mg\n where\n go [] = Nothing\n go (ms:mss) = if ms_mod ms == mdl then Just ms else go mss\n#endif\n" }, { "path": "finkel-kernel/src/Language/Finkel/Syntax/Extension.hs", "content": "{-# LANGUAGE CPP #-}\n-- | Modul for extenson field in Haskell AST.\n--\n-- This module condains type class and instances for extension field in Haskell\n-- AST. It seemed better to create dedicated specific class for ignored\n-- extension field.\n--\nmodule Language.Finkel.Syntax.Extension\n ( Unused(..)\n ) where\n\n#if MIN_VERSION_ghc(9,10,0)\nimport GHC.Hs.Binds (AnnSig (..), NamespaceSpecifier (..))\nimport GHC.Hs.Expr (AnnsIf, EpAnnHsCase (..))\nimport GHC.Parser.Annotation (AddEpAnn (..), AnnList (..),\n AnnParen (..), EpLayout (..),\n EpToken (..), EpUniToken (..),\n NoAnn (..))\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Parser.Annotation (SrcSpanAnn' (..))\nimport GHC.Types.SrcLoc (noSrcSpan)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Parser.Annotation (AnnSortKey (..), EpAnn (..),\n EpAnnComments (..))\nimport Language.Haskell.Syntax.Extension (NoExtField (..), noExtField)\n#else\nimport GHC.Hs.Extension (NoExtField (..), noExtField)\n#endif\n\n-- | Type class to represent field value which is not in use.\nclass Unused a where\n -- | Unused value for extension field in AST data types.\n unused :: a\n\n#if MIN_VERSION_ghc(9,10,0)\ninstance Unused (AnnSortKey tag) where\n unused = NoAnnSortKey\n {-# INLINE unused #-}\n\ninstance Unused NamespaceSpecifier where\n unused = NoNamespaceSpecifier\n {-# INLINE unused #-}\n\ninstance Unused EpLayout where\n unused = EpNoLayout\n {-# INLINE unused #-}\n\ninstance NoAnn a => Unused (EpAnn a) where\n unused = noAnn\n {-# INLINE unused #-}\n\ninstance Unused AddEpAnn where\n unused = noAnn\n {-# INLINE unused #-}\n\ninstance Unused AnnList where\n unused = noAnn\n {-# INLINE unused #-}\n\ninstance Unused AnnParen where\n unused = noAnn\n {-# INLINE unused #-}\n\ninstance Unused AnnSig where\n unused = noAnn\n {-# INLINE unused #-}\n\ninstance Unused (EpToken s) where\n unused = noAnn\n {-# INLINE unused #-}\n\ninstance Unused (EpUniToken s t) where\n unused = noAnn\n {-# INLINE unused #-}\n\ninstance Unused EpAnnHsCase where\n unused = noAnn\n {-# INLINE unused #-}\n\ninstance Unused AnnsIf where\n unused = noAnn\n {-# INLINE unused #-}\n\n#elif MIN_VERSION_ghc(9,2,0)\ninstance Unused (EpAnn a) where\n unused = EpAnnNotUsed\n {-# INLINE unused #-}\n\ninstance Unused a => Unused (SrcSpanAnn' a) where\n unused = SrcSpanAnn {ann = unused, locA = noSrcSpan}\n {-# INLINE unused #-}\n\ninstance Unused AnnSortKey where\n unused = NoAnnSortKey\n {-# INLINE unused #-}\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\ninstance Unused EpAnnComments where\n unused = EpaComments {priorComments = []}\n {-# INLINE unused #-}\n\ninstance Unused a => Unused [a] where\n unused = []\n {-# INLINE unused #-}\n#endif\n\ninstance Unused NoExtField where\n unused = noExtField\n {-# INLINE unused #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Syntax/HBind.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE ViewPatterns #-}\n\n-- | Syntax for binds.\nmodule Language.Finkel.Syntax.HBind where\n\n#include \"ghc_modules.h\"\n\n-- ghc\nimport GHC_Data_Bag (listToBag)\nimport GHC_Data_OrdList (toOL)\nimport GHC_Hs_Binds (FixitySig (..), HsBind,\n HsBindLR (..),\n HsLocalBindsLR (..),\n HsValBindsLR (..), Sig (..),\n emptyLocalBinds)\nimport GHC_Hs_Decls (HsDecl (..))\nimport GHC_Hs_Expr (GRHSs (..), LGRHS)\nimport qualified GHC_Parser_PostProcess as PostProcess\nimport GHC_Types_Fixity (Fixity)\nimport GHC_Types_Name_Reader (RdrName)\nimport GHC_Types_SrcLoc (GenLocated (..))\n\n#if MIN_VERSION_ghc(9,10,0)\nimport GHC_Hs_Binds (HsMultAnn (..))\n#endif\n\n#if !MIN_VERSION_ghc(9,2,0)\nimport GHC_Types_SrcLoc (SrcSpan)\n#endif\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Syntax.Utils\n\n\nmkPatBind_compat :: HPat -> [HGRHS] -> [HDecl] -> HsBind PARSED\nmkPatBind_compat (dL->L l pat) grhss decls =\n PatBind { pat_lhs = cL l pat\n , pat_rhs = mkGRHSs grhss decls l\n#if MIN_VERSION_ghc(9,10,0)\n -- XXX: Does not support HsMultAnn.\n , pat_mult = HsNoMultAnn unused\n#endif\n -- XXX: From ghc 9.6 (8.6?), the `pat_ext' field is used for holding\n -- former `pat_ticks' information.\n , pat_ext = unused\n#if !MIN_VERSION_ghc(9,6,0)\n , pat_ticks = ([], [])\n#endif\n }\n{-# INLINABLE mkPatBind_compat #-}\n\nmkHsValBinds :: HBinds -> [HSig] -> HsLocalBindsLR PARSED PARSED\nmkHsValBinds binds sigs = HsValBinds unused (ValBinds unused binds sigs)\n{-# INLINABLE mkHsValBinds #-}\n\n#if MIN_VERSION_ghc(9,2,0)\nmkGRHSs :: [LGRHS PARSED t] -> [HDecl] -> a -> GRHSs PARSED t\n#else\nmkGRHSs :: [LGRHS PARSED t] -> [HDecl] -> SrcSpan -> GRHSs PARSED t\n#endif\nmkGRHSs grhss decls l = GRHSs unused grhss (declsToBinds l decls)\n{-# INLINABLE mkGRHSs #-}\n\n-- | Build 'HLocalBinds' from list of 'HDecl's.\n#if MIN_VERSION_ghc(9,2,0)\ndeclsToBinds :: a -> [HDecl] -> HLocalBinds\ndeclsToBinds _ decls = binds'\n#else\ndeclsToBinds :: SrcSpan -> [HDecl] -> HLocalBinds\ndeclsToBinds l decls = L l binds'\n#endif\n where\n binds' = case decls of\n [] -> emptyLocalBinds\n _ -> mkHsValBinds (listToBag binds) sigs\n -- Using 'PostProcess.cvTopDecls' to group same names in where\n -- clause. Perhaps better to do similar things done in\n -- 'PostProcess.cvBindGroup', which is dedicated for 'P' monad ...\n decls' = PostProcess.cvTopDecls (toOL decls)\n (binds, sigs) = go ([],[]) decls'\n go (bs,ss) ds =\n case ds of\n [] -> (bs, ss)\n d:ds' -> case d of\n L ld (ValD _ b) -> go (L ld b:bs,ss) ds'\n L ld (SigD _ s) -> go (bs,L ld s:ss) ds'\n -- XXX: Ignoring.\n _ -> go (bs,ss) ds'\n{-# INLINABLE declsToBinds #-}\n\nmkFixSig :: [LocatedN RdrName] -> Fixity -> Sig PARSED\n-- XXX: Does not support NamespaceSpecifier.\nmkFixSig lnames fixity = FixSig unused (FixitySig unused lnames fixity)\n{-# INLINABLE mkFixSig #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Syntax/HDecl.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE ViewPatterns #-}\n\n-- | Syntax for declaration.\nmodule Language.Finkel.Syntax.HDecl where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Data.Maybe (fromMaybe)\n\n-- ghc\nimport GHC_Core_DataCon (SrcStrictness (..))\nimport GHC_Data_FastString (FastString, unpackFS)\nimport GHC_Data_OrdList (toOL)\nimport GHC_Hs_Binds (Sig (..))\nimport GHC_Hs_Decls (ClsInstDecl (..), ConDecl (..),\n DataFamInstDecl (..), DefaultDecl (..),\n DerivDecl (..), DerivStrategy (..),\n DocDecl (..), FamEqn (..),\n FamilyDecl (..), FamilyInfo (..),\n FamilyResultSig (..), ForeignDecl (..),\n ForeignExport (..), HsDataDefn (..),\n HsDecl (..), HsDerivingClause (..),\n InstDecl (..), LTyFamDefltDecl,\n TyClDecl (..), TyFamInstDecl (..),\n TyFamInstEqn)\nimport GHC_Hs_Doc (LHsDocString)\nimport GHC_Hs_Expr (HsMatchContext (..), Match (..))\nimport GHC_Hs_Pat (Pat (..))\nimport GHC_Hs_Type (ConDeclField (..), HsArg (..),\n HsConDetails (..), HsTyVarBndr (..),\n HsType (..), HsWildCardBndrs (..),\n mkFieldOcc, mkHsQTvs)\nimport GHC_Hs_Utils (mkClassOpSigs, mkFunBind)\nimport GHC_Parser_Lexer (P (..), ParseResult (..))\nimport GHC_Parser_PostProcess (mkConDeclH98, mkGadtDecl,\n mkInlinePragma, mkStandaloneKindSig,\n parseCImport)\nimport GHC_Types_Basic (Activation (..), InlineSpec (..),\n Origin (..), OverlapMode (..),\n PhaseNum, RuleMatchInfo (..))\nimport GHC_Types_Fixity (Fixity (..), FixityDirection (..),\n LexicalFixity (..))\nimport GHC_Types_ForeignCall (CCallConv (..), CExportSpec (..),\n Safety (..))\nimport GHC_Types_Name_Occurrence (dataName, tcName)\nimport GHC_Types_Name_Reader (RdrName, mkUnqual)\nimport GHC_Types_SrcLoc (GenLocated (..), Located, getLoc,\n noLoc, unLoc)\n\n#if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0)\nimport GHC.Parser.PostProcess (mkTokenLocation)\nimport Language.Haskell.Syntax.Concrete (HsUniToken (..))\n#endif\n\n#if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0)\nimport Language.Haskell.Syntax.Concrete (LayoutInfo (..))\n#elif !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,0,0)\nimport GHC_Types_SrcLoc (LayoutInfo (..))\n#endif\n\n#if MIN_VERSION_ghc(9,8,0)\nimport GHC.Data.FastString (fsLit)\nimport Language.Haskell.Syntax.Type (HsBndrVis (..))\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport Language.Haskell.Syntax.Decls (DataDefnCons (..))\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport Language.Haskell.Syntax.Decls (NewOrData (..))\n#else\nimport GHC_Hs_Decls (NewOrData (..))\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Hs.Doc (LHsDoc)\nimport GHC.Hs.DocString (HsDocStringDecorator (..))\nimport GHC.Parser.Annotation (l2l)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC_Hs_Decls (DerivClauseTys (..),\n XViaStrategyPs (..))\nimport GHC_Hs_Type (mkHsOuterImplicit)\nimport GHC_Hs_Utils (hsTypeToHsSigType, hsTypeToHsSigWcType)\nimport GHC_Parser_Annotation (AnnSortKey (..))\nimport GHC_Types_Basic (TopLevelFlag (..))\n#else\nimport GHC_Hs_Type (mkHsImplicitBndrs)\nimport GHC_Hs_Utils (mkLHsSigType, mkLHsSigWcType)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Hs_Type (LHsTyVarBndr, hsLinear)\nimport GHC_Types_Var (Specificity (..))\n#endif\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Data.SourceText\nimport Language.Finkel.Form\nimport Language.Finkel.Syntax.HBind\nimport Language.Finkel.Syntax.HType\nimport Language.Finkel.Syntax.Utils\n\n\n-- ---------------------------------------------------------------------\n--\n-- Declarations\n--\n-- ---------------------------------------------------------------------\n\nb_dataD :: Code\n -> (FastString, [HTyVarBndrVis], Maybe HKind)\n -> (HDeriving, [HConDecl])\n -> HDecl\nb_dataD = mkNewtypeOrDataD DataType\n{-# INLINABLE b_dataD #-}\n\nb_newtypeD :: Code\n -> (FastString, [HTyVarBndrVis], Maybe HKind)\n -> (HDeriving, [HConDecl])\n -> HDecl\nb_newtypeD = mkNewtypeOrDataD NewType\n{-# INLINABLE b_newtypeD #-}\n\nmkNewtypeOrDataD :: NewOrData\n -> Code\n -> (FastString, [HTyVarBndrVis], Maybe HKind)\n -> (HDeriving, [HConDecl])\n -> HDecl\nmkNewtypeOrDataD newOrData (LForm (L l _)) (name, tvs, ksig) (derivs, cs) =\n lA l (tyClD decl)\n where\n decl = DataDecl { tcdLName = lN l (mkUnqual tcName name)\n , tcdFixity = Prefix\n , tcdTyVars = mkHsQTvs tvs\n , tcdDataDefn = defn\n , tcdDExt = unused\n }\n defn = HsDataDefn { dd_cType = Nothing\n#if !MIN_VERSION_ghc(9,6,0)\n , dd_ND = newOrData\n#endif\n#if MIN_VERSION_ghc(9,2,0)\n , dd_ctxt = Nothing\n#else\n , dd_ctxt = noLoc []\n#endif\n , dd_kindSig = ksig\n , dd_cons = condecls\n , dd_derivs = derivs\n , dd_ext = unused\n }\n#if MIN_VERSION_ghc(9,6,0)\n condecls = case newOrData of\n NewType | c:_ <- cs -> NewTypeCon c\n DataType -> DataTypeCons False cs\n -- XXX: Not sure reaching below is possible.\n _ -> error \"mkNewTypeOrDataD:condecls\"\n#else\n condecls = cs\n#endif\n{-# INLINABLE mkNewtypeOrDataD #-}\n\nb_typeD :: Code\n -> (FastString, [HTyVarBndrVis], Maybe HKind)\n -> HType\n -> HDecl\nb_typeD (LForm (L l _)) (name, tvs, _) ty = lA l (tyClD synonym)\n where\n synonym = SynDecl { tcdLName = lN l (mkUnqual tcName name)\n , tcdFixity = Prefix\n , tcdTyVars = mkHsQTvs tvs\n , tcdRhs = ty\n , tcdSExt = unused\n }\n{-# INLINABLE b_typeD #-}\n\nb_standaloneKindSigD\n :: Code -> (FastString, [a], Maybe HKind) -> Builder HDecl\nb_standaloneKindSigD (LForm (L l _)) (name, _tvs, mb_knd) = do\n -- StandaloneKindSignature is not supported in ghc < 8.10. Also the arguments\n -- of \"mkStandaloneKindSig\" differ from ghc 9.0.x to ghc 9.2.x.\n#if MIN_VERSION_ghc(9,2,0)\n knd <- maybe builderError (pure . hsTypeToHsSigType) mb_knd\n let sigP = mkStandaloneKindSig l (L l [lN l (mkRdrName name)]) knd []\n#else\n knd <- maybe builderError pure mb_knd\n let sigP = mkStandaloneKindSig l (L l [lN l (mkRdrName name)]) knd\n#endif\n ps <- fmap ghcPState getBState\n case unP sigP ps of\n POk _ sig -> pure (lA l (KindSigD unused (unLoc sig)))\n PFailed _ -> builderError\n\nb_conD :: Code -> HConDeclH98Details -> Builder HConDecl\nb_conD form@(LForm (L l _)) details = do\n name <- getConId form\n let name' = lN l (mkUnqual dataName name)\n cxt = Nothing\n#if MIN_VERSION_ghc(9,2,0)\n pure (lA l (mkConDeclH98 unused name' Nothing cxt details))\n#else\n pure (L l (mkConDeclH98 name' Nothing cxt details))\n#endif\n{-# INLINABLE b_conD #-}\n\nb_qtyconD :: (HConDecl, [HType]) -> HConDecl\nb_qtyconD (whole@(L l decl), tys) =\n case tys of\n [] -> whole\n#if MIN_VERSION_ghc(9,10,0)\n _ -> L l (decl { con_mb_cxt = Just (mkLocatedListA tys) })\n#else\n _ -> L l (decl { con_mb_cxt = Just (la2la (mkLocatedListA tys)) })\n#endif\n{-# INLINABLE b_qtyconD #-}\n\n#if MIN_VERSION_ghc(9,0,0)\nb_forallD\n :: [LHsTyVarBndr Specificity PARSED]\n -> (HConDecl, [HType])\n -> Builder HConDecl\n#else\nb_forallD :: [HTyVarBndr] -> (HConDecl, [HType]) -> Builder HConDecl\n#endif\nb_forallD vars (L l cdecl@ConDeclH98{}, cxts) = pure d\n where\n d = L l cdecl { con_ex_tvs = vars\n#if MIN_VERSION_ghc(9,2,0)\n , con_forall = True\n#else\n , con_forall = noLoc True\n#endif\n#if MIN_VERSION_ghc(9,10,0)\n , con_mb_cxt = Just (mkLocatedListA cxts)\n#else\n , con_mb_cxt = Just (la2la (mkLocatedListA cxts))\n#endif\n }\nb_forallD _ _ = builderError\n{-# INLINABLE b_forallD #-}\n\nb_gadtD :: Code -> ([HType], HType) -> Builder HConDecl\nb_gadtD form@(LForm (L l1 _)) (ctxt, bodyty) = do\n name <- getConId form\n let name' = pure $ lN l1 (mkUnqual dataName name)\n#if MIN_VERSION_ghc(9,0,0)\n -- Removing parentheses of the body type, so that the 'mkGadtDecl' can\n -- split the internal elements. Parentheses are added to the body of GADT\n -- when it is HsForAllTy, to support documentation string.\n ty = case qty of\n HsParTy _ unpar_ty -> unpar_ty\n _ -> lA l1 qty\n\n#else\n ty = lA l1 qty\n#endif\n#if MIN_VERSION_ghc(9,10,0)\n qty = mkHsQualTy' (mkLocatedListA ctxt) bodyty\n#else\n qty = mkHsQualTy' (la2la (mkLocatedListA ctxt)) bodyty\n#endif\n#if MIN_VERSION_ghc(9,10,0)\n ldecl <- do\n ps <- fmap ghcPState getBState\n case unP (mkGadtDecl l1 name' unused (hsTypeToHsSigType ty)) ps of\n POk _ d -> pure d\n _ -> builderError\n#elif MIN_VERSION_ghc(9,6,0)\n ldecl <- do\n ps <- fmap ghcPState getBState\n let dcolon = L (mkTokenLocation l1) HsNormalTok\n case unP (mkGadtDecl l1 name' dcolon (hsTypeToHsSigType ty)) ps of\n POk _ d -> pure d\n _ -> builderError\n#elif MIN_VERSION_ghc(9,2,0)\n ldecl <- do\n ps <- fmap ghcPState getBState\n case unP (mkGadtDecl l1 name' (hsTypeToHsSigType ty) []) ps of\n POk _ d -> pure d\n _ -> builderError\n#elif MIN_VERSION_ghc(9,0,0)\n ldecl <- do\n ps <- fmap ghcPState getBState\n case unP (mkGadtDecl name' ty) ps of\n POk _ d -> pure (L l1 (fst d))\n _ -> builderError\n#else\n let ldecl = L l1 (fst (mkGadtDecl name' ty))\n#endif\n return ldecl\n{-# INLINABLE b_gadtD #-}\n\nb_conOnlyD :: Code -> Builder HConDecl\nb_conOnlyD name = b_conD name pcon\n where\n#if MIN_VERSION_ghc(9,2,0)\n pcon = PrefixCon [] []\n#else\n pcon = PrefixCon []\n#endif\n{-# INLINABLE b_conOnlyD #-}\n\n-- XXX: Infix data constructor not supported.\n-- XXX: Does not support liner types and unicode syntax (ghc >= 9.0)\nb_conDeclDetails :: [HType] -> HConDeclH98Details\n#if MIN_VERSION_ghc(9,2,0)\nb_conDeclDetails = PrefixCon [] . map (hsLinear . parTyApp)\n#elif MIN_VERSION_ghc(9,0,0)\nb_conDeclDetails = PrefixCon . map (hsLinear . parTyApp)\n#else\nb_conDeclDetails = PrefixCon . map parTyApp\n#endif\n{-# INLINABLE b_conDeclDetails #-}\n\nb_recFieldsD :: [HConDeclField] -> HConDeclH98Details\n#if MIN_VERSION_ghc(9,10,0)\nb_recFieldsD = RecCon . mkLocatedListA\n#else\nb_recFieldsD = RecCon . la2la . mkLocatedListA\n#endif\n{-# INLINABLE b_recFieldsD #-}\n\nb_recFieldD :: Maybe LHsDocString -> ([Code], HType) -> Builder HConDeclField\nb_recFieldD mb_doc (names, ty) = do\n let f (LForm (L l form)) =\n case form of\n Atom (ASymbol name) ->\n#if MIN_VERSION_ghc(9,4,0)\n return (reLocA (L l (mkFieldOcc (lN l (mkRdrName name)))))\n#else\n return (L l (mkFieldOcc (lN l (mkRdrName name))))\n#endif\n _ -> builderError\n let mb_doc' = fmap lHsDocString2LHsDoc mb_doc\n names' <- mapM f names\n let field = ConDeclField { cd_fld_names = names'\n , cd_fld_ext = unused\n , cd_fld_type = ty\n , cd_fld_doc = mb_doc' }\n loc = getLoc (mkLocatedForm names)\n return (lA loc field)\n{-# INLINABLE b_recFieldD #-}\n\nb_derivD :: Maybe HDerivStrategy -> [HType] -> HDeriving\nb_derivD mb_strat tys = hds\n where\n#if MIN_VERSION_ghc(9,4,0)\n hds = [la2la (L l dc)]\n clauses = la2la (L l (DctMulti unused (map hsTypeToHsSigType tys)))\n#elif MIN_VERSION_ghc(9,2,0)\n hds = [reLoc (L l dc)]\n clauses = la2la (L l (DctMulti unused (map hsTypeToHsSigType tys)))\n#else\n hds = L l [L l dc]\n clauses = L l (map hsTypeToHsSigType tys)\n#endif\n dc = HsDerivingClause unused mb_strat clauses\n l = getLoc (mkLocatedListA' tys)\n{-# INLINABLE b_derivD #-}\n\nb_derivsD :: HDeriving -> HDeriving -> HDeriving\n#if MIN_VERSION_ghc(9,2,0)\nb_derivsD new acc = new ++ acc\n#else\nb_derivsD (dL->L _ new) (dL->L _ acc) = mkLocatedList (new ++ acc)\n#endif\n{-# INLINABLE b_derivsD #-}\n\nb_emptyDeriving :: HDeriving\n#if MIN_VERSION_ghc(9,2,0)\nb_emptyDeriving = []\n#else\nb_emptyDeriving = noLoc []\n#endif\n{-# INLINABLE b_emptyDeriving #-}\n\nb_viaD :: HType -> Builder (Maybe HDerivStrategy)\n#if MIN_VERSION_ghc(9,4,0)\nb_viaD ty@(L l _) =\n pure (Just (L (l2l l) (ViaStrategy (XViaStrategyPs unused sig))))\n where\n sig = hsTypeToHsSigType ty\n#elif MIN_VERSION_ghc(9,2,0)\nb_viaD ty@(L l _) =\n pure (Just (reLoc (L l (ViaStrategy (XViaStrategyPs unused sig)))))\n where\n sig = hsTypeToHsSigType ty\n#else\nb_viaD ty@(dL->L l _) =\n pure (Just (lA l (ViaStrategy (hsTypeToHsSigType ty))))\n#endif\n{-# INLINABLE b_viaD #-}\n\nb_standaloneD :: Maybe HDerivStrategy\n -> Maybe (Located OverlapMode)\n -> HType -> HDecl\nb_standaloneD mb_strategy mb_overlap ty0@(dL-> L l _) = L l (DerivD unused dd)\n where\n#if MIN_VERSION_ghc(9,10,0)\n -- XXX: Does not support WarningTxt.\n dd = DerivDecl (Nothing, unused) ty1 mb_strategy mb_overlap'\n#else\n dd = DerivDecl unused ty1 mb_strategy mb_overlap'\n#endif\n mb_overlap' = fmap reLocA mb_overlap\n ty1 = hsTypeToHsSigWcType ty0\n{-# INCLUDE b_standaloneD #-}\n\nb_classD :: ([HType],HType) -> [HDecl] -> Builder HDecl\nb_classD (tys,ty) decls = do\n cd <- cvBindsAndSigs (toOL decls)\n let\n#if MIN_VERSION_ghc(9,10,0)\n userTV = UserTyVar unused (HsBndrRequired unused)\n kindedTV = KindedTyVar unused (HsBndrRequired unused)\n#elif MIN_VERSION_ghc(9,8,0)\n -- XXX: Does not support HsBndrInvisible\n userTV = UserTyVar unused HsBndrRequired\n kindedTV = KindedTyVar unused HsBndrRequired\n#elif MIN_VERSION_ghc(9,0,0)\n userTV = UserTyVar unused ()\n kindedTV = KindedTyVar unused ()\n#else\n userTV = UserTyVar unused\n kindedTV = KindedTyVar unused\n#endif\n -- Recursing in `HsAppTy' to support MultiParamTypeClasses.\n let unAppTy t =\n case t of\n L l (HsTyVar _ _ n) ->\n return (l, n, [L l (userTV n)])\n L _ (HsAppTy _ t1 v) -> do\n (l1, n1, vs1) <- unAppTy t1\n (_, _, vs2) <- unAppTy v\n return (l1, n1, vs2 ++ vs1)\n L _ (HsParTy _ t') -> unAppTy t'\n L l1 (HsKindSig _ t1 k) -> do\n (_, n, _) <- unAppTy t1\n return (l1, n, [L l1 (kindedTV n k)])\n _ -> builderError\n\n atdefs <- cd2atdefs cd\n (l, name, bndrs) <- unAppTy ty\n -- Note that the `bndrs' are gathered from left to right,\n -- re-ordering with reverse and removing the duplicated head at this\n -- point.\n bndrs' <- case reverse bndrs of\n [] -> builderError\n _:tl -> pure tl\n\n#if MIN_VERSION_ghc(9,10,0)\n let tcd_ctxt | null tys = Nothing\n | otherwise = Just (mkLocatedListA tys)\n#elif MIN_VERSION_ghc(9,2,0)\n let tcd_ctxt | null tys = Nothing\n | otherwise = Just (la2la (mkLocatedListA tys))\n#else\n let tcd_ctxt = mkLocatedList tys\n#endif\n\n#if MIN_VERSION_ghc(9,10,0)\n let tcd_cext = (unused, unused, NoAnnSortKey)\n#elif MIN_VERSION_ghc(9,6,0)\n let tcd_cext = (unused, NoAnnSortKey)\n#elif MIN_VERSION_ghc(9,2,0)\n let tcd_cext = (unused, NoAnnSortKey, NoLayoutInfo)\n#elif MIN_VERSION_ghc(9,0,0)\n let tcd_cext = NoLayoutInfo\n#else\n let tcd_cext = unused\n#endif\n\n let cls = ClassDecl { tcdLName = name\n#if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0)\n , tcdLayout = NoLayoutInfo\n#endif\n , tcdCtxt = tcd_ctxt\n , tcdFixity = Prefix\n , tcdTyVars = mkHsQTvs bndrs'\n , tcdFDs = []\n , tcdSigs = mkClassOpSigs (cd_sigs cd)\n , tcdMeths = cd_binds cd\n , tcdATs = cd_fds cd\n , tcdATDefs = atdefs\n , tcdDocs = cd_docs cd\n , tcdCExt = tcd_cext\n }\n return (L l (tyClD cls))\n{-# INLINABLE b_classD #-}\n\nb_instD :: Maybe (Located OverlapMode) -> ([HType], HType)\n -> [HDecl] -> Builder HDecl\nb_instD mb_overlap (ctxts,ty@(L l _)) decls = do\n cd <- cvBindsAndSigs (toOL decls)\n let decl = ClsInstDecl { cid_poly_ty = hsTypeToHsSigType qty\n , cid_binds = cd_binds cd\n , cid_sigs = mkClassOpSigs (cd_sigs cd)\n , cid_tyfam_insts = cd_tfis cd\n , cid_datafam_insts = cd_dfis cd\n , cid_overlap_mode = fmap reLocA mb_overlap\n#if MIN_VERSION_ghc(9,10,0)\n -- XXX: Does not support WarningTxt\n , cid_ext = (Nothing, unused, NoAnnSortKey)\n#elif MIN_VERSION_ghc(9,2,0)\n , cid_ext = (unused, NoAnnSortKey)\n#else\n , cid_ext = unused\n#endif\n }\n#if MIN_VERSION_ghc(9,10,0)\n qty = L l (mkHsQualTy' (mkLocatedListA ctxts) ty)\n#else\n qty = L l (mkHsQualTy' (la2la (mkLocatedListA ctxts)) ty)\n#endif\n instD = InstD unused\n clsInstD = ClsInstD unused\n return (L l (instD (clsInstD decl)))\n{-# INLINABLE b_instD #-}\n\nb_datafamD :: Code -> (FastString, [HTyVarBndrVis], Maybe HType) -> HDecl\nb_datafamD = mkFamilyDecl DataFamily\n{-# INLINABLE b_datafamD #-}\n\nb_tyfamD :: [(Located FastString, [HType], HType)]\n -> Code\n -> (FastString, [HTyVarBndrVis], Maybe HType)\n -> HDecl\nb_tyfamD insts =\n if null insts\n then mkFamilyDecl OpenTypeFamily\n else mkFamilyDecl (ClosedTypeFamily (Just tfies))\n where\n tfies = map f insts\n f (L l name, argtys, ty) =\n let rname = L l (mkUnqual tcName name)\n in lA l (mkTyFamInstEqn rname argtys ty)\n{-# INLINABLE b_tyfamD #-}\n\n-- See: \"RdrHsSyn.mkFamDecl\" and 'Convert.cvtDec'.\nmkFamilyDecl :: FamilyInfo PARSED\n -> Code\n -> (FastString, [HTyVarBndrVis], Maybe HType)\n -> HDecl\nmkFamilyDecl finfo (LForm (L l _)) (name, bndrs, mb_kind) =\n let fam = FamilyDecl\n { fdInfo = finfo\n , fdLName = lname\n , fdTyVars = hsqtyvars\n , fdFixity = Prefix\n#if MIN_VERSION_ghc(9,4,0)\n , fdResultSig = reLocA (L l rsig)\n#else\n , fdResultSig = L l rsig\n#endif\n , fdInjectivityAnn = Nothing\n , fdExt = unused\n#if MIN_VERSION_ghc(9,2,0)\n -- XXX: When to use 'NotTopLevel'?\n , fdTopLevel = TopLevel\n#endif\n }\n lname = lN l (mkUnqual tcName name)\n hsqtyvars = mkHsQTvs bndrs\n -- XXX: Does not support 'TyVarsig'.\n rsig = maybe (NoSig unused) (KindSig unused) mb_kind\n in lA l (TyClD unused (FamDecl unused fam))\n{-# INLINABLE mkFamilyDecl #-}\n\nb_dfltSigD :: HDecl -> Builder HDecl\nb_dfltSigD (dL->L l decl) =\n case decl of\n SigD _ (TypeSig _ ids ty) ->\n return (cL l (sigD (ClassOpSig unused True ids (hswc_body ty))))\n _ -> builderError\n{-# INLINABLE b_dfltSigD #-}\n\n-- See: \"Convert.cvtDec\".\nb_datainstD\n :: Code\n -> (Located FastString, [HType], Maybe HType)\n -> (HDeriving, [HConDecl])\n -> HDecl\nb_datainstD = mk_data_or_newtype_instD DataType\n{-# INLINABLE b_datainstD #-}\n\nb_newtypeinstD\n :: Code\n -> (Located FastString, [HType], Maybe HType)\n -> (HDeriving, [HConDecl])\n -> HDecl\nb_newtypeinstD = mk_data_or_newtype_instD NewType\n{-# INCLUDE b_newtypeinsD #-}\n\nmk_data_or_newtype_instD\n :: NewOrData -> Code\n -> (Located FastString, [HType], Maybe HType)\n -> (HDeriving, [HConDecl]) -> HDecl\nmk_data_or_newtype_instD new_or_data (LForm (L l _)) (L ln name, pats, mb_kind)\n (deriv, condecls) =\n let faminst = DataFamInstD { dfid_inst = inst\n , dfid_ext = unused\n }\n -- XXX: Contexts and kind signatures not supported.\n rhs = HsDataDefn { dd_cType = Nothing\n#if !MIN_VERSION_ghc(9,6,0)\n , dd_ND = new_or_data\n#endif\n#if MIN_VERSION_ghc(9,2,0)\n , dd_ctxt = Nothing\n#else\n , dd_ctxt = L l []\n#endif\n , dd_kindSig = mb_kind\n , dd_cons = condecls'\n , dd_derivs = deriv\n , dd_ext = unused\n }\n tycon = L ln (mkUnqual tcName name)\n inst = mkDataFamInstDecl tycon pats rhs\n#if MIN_VERSION_ghc(9,6,0)\n condecls' = case new_or_data of\n NewType | c:_ <- condecls -> NewTypeCon c\n DataType -> DataTypeCons False condecls\n -- XXX: Again, not sure reaching below is possible.\n _ -> error \"mk_data_or_newtype_instD:condecls'\"\n#else\n condecls' = condecls\n#endif\n in lA l (InstD unused faminst)\n{-# INLINABLE mk_data_or_newtype_instD #-}\n\nb_tyinstD :: Code -> (Located FastString, [HType]) -> HType -> HDecl\nb_tyinstD (LForm (L l _)) (L ln name, pats) rhs =\n let rname = L ln (mkUnqual tcName name)\n inst = mkTyFamInstEqn rname pats rhs\n tyfaminstD = TyFamInstD unused tfid\n#if MIN_VERSION_ghc(9,2,0)\n tfid = TyFamInstDecl unused inst\n#else\n tfid = TyFamInstDecl inst\n#endif\n in lA l (InstD unused tyfaminstD)\n{-# INLINABLE b_tyinstD #-}\n\nb_overlapP :: Code -> Builder (Maybe (Located OverlapMode))\nb_overlapP (LForm (L _ (List [LForm (L l (Atom (ASymbol mode)))]))) =\n pure $ case mode of\n \"OVERLAPPABLE\" -> pragma Overlappable\n \"OVERLAPPING\" -> pragma Overlapping\n \"OVERLAPS\" -> pragma Overlaps\n \"INCOHERENT\" -> pragma Incoherent\n _ -> Nothing\n where\n pragma con = Just (L l (con stxt))\n -- XXX: Adding extra pragma comment header to support translation to\n -- Haskell source code.\n#if MIN_VERSION_ghc(9,8,0)\n stxt = SourceText (fsLit \"{-# \" <> mode)\n#else\n stxt = SourceText (\"{-# \" ++ unpackFS mode)\n#endif\nb_overlapP _ = builderError\n{-# INLINABLE b_overlapP #-}\n\nb_qtyclC :: [HType] -> Builder ([HType], HType)\nb_qtyclC ts =\n case ts of\n [] -> builderError\n _ -> case splitAt (length ts - 1) ts of\n (ctxt, [t]) -> return (ctxt, t)\n _ -> builderError\n{-# INLINABLE b_qtyclC #-}\n\nb_defaultD :: [HType] -> HDecl\nb_defaultD types = L l (defD (defaultDecl types))\n where\n l = getLoc (mkLocatedListA types)\n defD = DefD unused\n defaultDecl = DefaultDecl unused\n{-# INLINABLE b_defaultD #-}\n\nb_fixityD :: FixityDirection -> Code -> [Code] -> Builder HDecl\nb_fixityD dir (LForm (L l form)) syms =\n case form of\n Atom (AInteger IL {il_value=n}) -> do\n let lname (LForm (L l0 x)) =\n case x of\n Atom (ASymbol name) -> return (lN l0 (mkRdrName name))\n _ -> builderError\n fixity = Fixity dir' (fromIntegral n) dir\n dir' = case dir of\n InfixL -> strToSourceText \"infixl\"\n InfixR -> strToSourceText \"infixr\"\n InfixN -> strToSourceText \"infix\"\n names <- mapM lname syms\n return (lA l (sigD (mkFixSig names fixity)))\n _ -> builderError\n{-# INLINABLE b_fixityD #-}\n\nb_ffiD :: Code -> Code -> HCCallConv -> Maybe (Located Safety)\n -> Code -> (Code, HType) -> Builder HDecl\nb_ffiD (LForm (L l _)) imp_or_exp ccnv mb_safety ename (nm, ty)\n | LForm (L ln (Atom (ASymbol name))) <- nm\n , LForm (L _ls (Atom (AString _ ename'_fs))) <- ename =\n let lname = reLocA (L ln (mkRdrName name))\n tsig = hsTypeToHsSigType ty\n ename' = unpackFS ename'_fs\n source =\n case ename' of\n \"\" -> L l NoSourceText\n _ -> L l (toQuotedSourceText ename'_fs)\n#if MIN_VERSION_ghc(9,10,0)\n safety = reLoc $ fromMaybe (noLoc PlaySafe) mb_safety\n ccnv' = reLoc ccnv\n#else\n safety = fromMaybe (noLoc PlaySafe) mb_safety\n ccnv' = ccnv\n#endif\n forD = ForD unused\n in case unCode imp_or_exp of\n Atom (ASymbol ie)\n | ie == \"import\"\n , Just ispec <- parseCImport ccnv' safety name ename' source -> do\n let fi = ForeignImport { fd_name = lname\n , fd_sig_ty = tsig\n , fd_i_ext = unused\n , fd_fi = ispec}\n return (lA l (forD fi))\n | ie == \"export\" -> do\n let fe = ForeignExport { fd_name = lname\n , fd_sig_ty = tsig\n , fd_e_ext = unused\n , fd_fe = e }\n ces = CExportStatic stxt ename'_fs (unLoc ccnv)\n#if MIN_VERSION_ghc(9,8,0)\n stxt = SourceText ename'_fs\n#else\n stxt = SourceText ename'\n#endif\n#if MIN_VERSION_ghc(9,10,0)\n e = CExport (reLoc (L l stxt)) (reLoc (L l ces))\n#elif MIN_VERSION_ghc(9,6,0)\n e = CExport (L l stxt) (L l ces)\n#else\n e = CExport (L l ces) (L l stxt)\n#endif\n return (lA l (forD fe))\n _ -> builderError\n | otherwise = builderError\n{-# INLINABLE b_ffiD #-}\n\nb_callConv :: Code -> Builder (Located CCallConv)\nb_callConv (LForm (L l form)) =\n case form of\n Atom (ASymbol sym)\n | sym == \"capi\" -> r CApiConv\n | sym == \"ccall\" -> r CCallConv\n | sym == \"prim\" -> r PrimCallConv\n | sym == \"javascript\" -> r JavaScriptCallConv\n | sym == \"stdcall\" -> r StdCallConv\n _ -> builderError\n where\n r = return . L l\n{-# INLINABLE b_callConv #-}\n\nb_safety :: Code -> Builder (Located Safety)\nb_safety (LForm (L l form)) =\n case form of\n Atom (ASymbol sym) ->\n case sym of\n \"interruptible\" -> return (L l PlayInterruptible)\n \"safe\" -> return (L l PlaySafe)\n \"unsafe\" -> return (L l PlayRisky)\n _ -> builderError\n _ -> builderError\n{-# INLINABLE b_safety #-}\n\nb_funOrPatD :: Code -> [HPat] -> ([HGRHS], [HDecl]) -> Builder HDecl\nb_funOrPatD eq_form pats gxd@(grhss,decls) =\n case pats of\n [] -> setLastToken eq_form >> failB \"Empty binding\"\n lpat@(dL->L l (BangPat _ pat)):pats' ->\n case pats' of\n [] -> return (b_patBindD gxd lpat)\n _ -> let name = reLoc (L l (mkRdrName \"!\"))\n in b_funBindD name (pat:pats') grhss decls\n lpat@(dL->L _ pat):pats'\n | isVarPat pat -> do\n name <- varToName pat\n b_funBindD (reLoc name) pats' grhss decls\n | null pats' -> return (b_patBindD gxd lpat)\n | otherwise -> setLastToken eq_form >> failB \"Malformed binding\"\n where\n isVarPat VarPat {} = True\n isVarPat _ = False\n varToName (VarPat _ lname) = return lname\n varToName _ = failB \"Invalid name\"\n{-# INLINABLE b_funOrPatD #-}\n\nb_funBindD :: Located RdrName -> [HPat] -> [HGRHS] -> [HDecl] -> Builder HDecl\nb_funBindD lname0@(L l _) args grhss decls = do\n let body = mkGRHSs grhss decls l\n lname = reLocA lname0\n match = lA l (Match unused ctxt args body)\n ctxt = FunRhs { mc_fun = lname\n , mc_fixity = Prefix\n -- XXX: Get strictness from ... where?\n , mc_strictness = NoSrcStrict }\n -- bind = mkFunBind_compat lname [match]\n bind = mkFunBind FromSource lname [match]\n return (lA l (ValD unused bind))\n{-# INLINABLE b_funBindD #-}\n\nb_patBindD :: ([HGRHS],[HDecl]) -> HPat -> HDecl\nb_patBindD (grhss,decls) lpat@(dL->L l _pat) =\n let bind = mkPatBind_compat lpat grhss decls\n in L l (ValD unused bind)\n{-# INLINABLE b_patBindD #-}\n\nb_tsigD :: [Code] -> ([HType], HType) -> Builder HDecl\nb_tsigD names (ctxts,typ0) = do\n let typ' = hsTypeToHsSigWcType qtyp\n qtyp = if null ctxts then typ1 else lqty1\n#if MIN_VERSION_ghc(9,10,0)\n lqty1 = lA l (mkHsQualTy' (mkLocatedListA ctxts) typ1)\n#else\n lqty1 = lA l (mkHsQualTy' (la2la (mkLocatedListA ctxts)) typ1)\n#endif\n typ1 = unParTy typ0\n mkName form =\n case form of\n LForm (L l1 (Atom (ASymbol name))) -> return (lN l1 (mkRdrName name))\n _ -> builderError\n l = getLoc (mkLocatedForm names)\n typeSig = TypeSig unused\n names' <- mapM mkName names\n return (lA l (sigD (typeSig names' typ')))\n{-# INLINABLE b_tsigD #-}\n\n#if MIN_VERSION_ghc(9,4,0)\nb_inlineD ::\n (SourceText -> InlineSpec) -> Maybe Activation -> Code -> Builder HDecl\n#else\nb_inlineD :: InlineSpec -> Maybe Activation -> Code -> Builder HDecl\n#endif\nb_inlineD ispec mb_act (LForm (L l form)) =\n case form of\n Atom (ASymbol name) ->\n let inlineSig = InlineSig unused\n in return (lA l (sigD (inlineSig (lN l (mkRdrName name)) ipragma)))\n _ -> builderError\n where\n ipragma = mkInlinePragma stxt (ispec', FunLike) mb_act\n source =\n case ispec'' (strToSourceText \"\") of\n NoInline {} -> \"{-# NOINLINE\"\n Inlinable {} -> \"{-# INLINABLE\"\n _ -> \"{-# INLINE\"\n stxt = strToSourceText source\n#if MIN_VERSION_ghc(9,4,0)\n ispec' = ispec stxt\n ispec'' = ispec\n#else\n ispec' = ispec\n ispec'' = const ispec\n#endif\n{-# INLINABLE b_inlineD #-}\n\nb_activation :: (SourceText -> PhaseNum -> Activation)\n -> Code -> Builder Activation\nb_activation f code@(LForm (L _l atom))\n | Atom (AInteger il) <- atom = return (f source (fromIntegral (il_value il)))\n -- Supporting symbols in \"~N\" form, where \"N\" is an integer.\n | Atom (ASymbol s) <- atom\n , '~':rest <- unpackFS s\n , [(n,\"\")] <- reads rest = return (f source n)\n | otherwise = builderError\n where\n source = strToSourceText (show code)\n{-# INLINABLE b_activation #-}\n\nb_specializeD :: Code -> Maybe Activation -> (Code, HType) -> Builder HDecl\nb_specializeD = specializeBuilder noUserInline \"{-# SPECIALISE\"\n{-# INLINABLE b_specializeD #-}\n\nb_specializeInlineD :: Code -> Maybe Activation -> (Code, HType)\n -> Builder HDecl\n#if MIN_VERSION_ghc(9,4,0)\nb_specializeInlineD =\n let str = \"{-# SPECIALISE INLINE\"\n in specializeBuilder (Inline (strToSourceText str)) str\n#else\nb_specializeInlineD = specializeBuilder Inline \"{-# SPECIALISE INLINE\"\n#endif\n{-# INLINABLE b_specializeInlineD #-}\n\nspecializeBuilder\n :: InlineSpec -> String -> Code -> Maybe Activation -> (Code, HType)\n -> Builder HDecl\nspecializeBuilder ispec txt (LForm (L l _)) mb_act (nsym, tsig)\n | LForm (L ln (Atom (ASymbol name))) <- nsym = do\n let lname = lN ln (mkRdrName name)\n ipragma = mkInlinePragma source (ispec, FunLike) mb_act\n source = strToSourceText txt\n specSig = SpecSig unused lname [hsTypeToHsSigType tsig] ipragma\n return (lA l (sigD specSig))\n | otherwise = builderError\n{-# INLINABLE specializeBuilder #-}\n\nb_docnextD :: Code -> Builder HDecl\nb_docnextD = docDWith DocCommentNext hsDocStringNext\n{-# INLINABLE b_docnextD #-}\n\nb_docprevD :: Code -> Builder HDecl\nb_docprevD = docDWith DocCommentPrev hsDocStringPrevious\n{-# INLINABLE b_docprevD #-}\n\n#if MIN_VERSION_ghc(9,4,0)\ndocDWith :: (LHsDoc PARSED -> DocDecl PARSED) -> HsDocStringDecorator\n -> Code -> Builder HDecl\n#else\ndocDWith :: (LHsDoc PARSED -> DocDecl) -> HsDocStringDecorator\n -> Code -> Builder HDecl\n#endif\ndocDWith constr deco (LForm (L l form)) =\n case form of\n Atom (AString _ str) ->\n -- Adding space to the beginning and the end of the given documentation\n -- content at this point, to ensure at least one space will appear between\n -- the doc body and decoration header/footer. Though more suitable place\n -- to add spaces should exist ...\n let doc = mkLHsDocWithDecorator deco l (wrapWithSpaces str)\n in pure $! lA l (DocD unused (constr doc))\n _ -> builderError\n{-# INLINABLE docDWith #-}\n\nb_docGroupD :: Int -> Code -> Builder HDecl\nb_docGroupD n form@(LForm (L l _))\n | List [_,doc_code] <- unCode form\n , Atom (AString _ doc) <- unCode doc_code\n = return $! lA l (DocD unused (DocGroup (fromIntegral n) (mkLHsDoc l doc)))\n | otherwise = setLastToken form >> failB \"Invalid group doc\"\n{-# INLINABLE b_docGroupD #-}\n\nb_docNamed :: Code -> Builder HDecl\nb_docNamed form@(LForm (L l body))\n | List [_,name_code,doc_code] <- body\n , Atom (ASymbol name) <- unCode name_code\n , Atom (AString _ doc) <- unCode doc_code\n = let name' = unpackFS name\n in return $! lA l (DocD unused (DocCommentNamed name' (mkLHsDoc l doc)))\n | otherwise\n = setLastToken form >> failB \"Invalid named doc\"\n{-# INLINABLE b_docNamed #-}\n\ntyClD :: TyClDecl PARSED -> HsDecl PARSED\ntyClD = TyClD unused\n{-# INLINABLE tyClD #-}\n\nsigD :: Sig PARSED -> HsDecl PARSED\nsigD = SigD unused\n{-# INLINABLE sigD #-}\n\nmkDataFamInstDecl :: Located RdrName\n -> [HType]\n -> HsDataDefn PARSED\n -> DataFamInstDecl PARSED\nmkDataFamInstDecl tycon pats rhs = dfid\n where\n#if MIN_VERSION_ghc(9,2,0)\n dfid = DataFamInstDecl (mkFamEqn tycon pats rhs)\n#else\n dfid = DataFamInstDecl (mkHsImplicitBndrs (mkFamEqn tycon pats rhs))\n#endif\n{-# INLINABLE mkDataFamInstDecl #-}\n\nmkTyFamInstEqn :: Located RdrName -> [HType] -> HType -> TyFamInstEqn PARSED\nmkTyFamInstEqn tycon pats rhs =\n#if MIN_VERSION_ghc(9,2,0)\n mkFamEqn tycon pats rhs\n#else\n mkHsImplicitBndrs (mkFamEqn tycon pats rhs)\n#endif\n{-# INLINABLE mkTyFamInstEqn #-}\n\nmkFamEqn :: Located RdrName -> [HType] -> rhs -> FamEqn PARSED rhs\nmkFamEqn tycon pats rhs =\n FamEqn { feqn_tycon = reLocA tycon\n , feqn_fixity = Prefix\n , feqn_rhs = rhs\n#if MIN_VERSION_ghc(9,10,0)\n , feqn_pats = map (HsValArg unused) pats\n , feqn_bndrs = mkHsOuterImplicit\n#elif MIN_VERSION_ghc(9,2,0)\n , feqn_pats = map HsValArg pats\n , feqn_bndrs = mkHsOuterImplicit\n#else\n , feqn_pats = map HsValArg pats\n , feqn_bndrs = Nothing\n#endif\n , feqn_ext = unused\n }\n{-# INLINABLE mkFamEqn #-}\n\nunParTy :: HType -> HType\nunParTy t0 =\n case t0 of\n L _ (HsParTy _ t1) -> t1\n _ -> t0\n{-# INLINABLE unParTy #-}\n\nnoUserInline :: InlineSpec\n#if MIN_VERSION_ghc(9,2,0)\nnoUserInline = NoUserInlinePrag\n#else\nnoUserInline = NoUserInline\n#endif\n{-# INLINABLE noUserInline #-}\n\ncd2atdefs :: CategorizedDecls -> Builder [LTyFamDefltDecl PARSED]\ncd2atdefs = pure . cd_tfis\n{-# INLINABLE cd2atdefs #-}\n\n#if !MIN_VERSION_ghc(9,2,0)\nhsTypeToHsSigType :: HType -> HSigType\nhsTypeToHsSigType = mkLHsSigType\n{-# INLINABLE hsTypeToHsSigType #-}\n\nhsTypeToHsSigWcType :: HType -> HSigWcType\nhsTypeToHsSigWcType = mkLHsSigWcType\n{-# INLINABLE hsTypeToHsSigWcType #-}\n#endif\n" }, { "path": "finkel-kernel/src/Language/Finkel/Syntax/HExpr.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE ViewPatterns #-}\n\n-- | Syntax for expression.\nmodule Language.Finkel.Syntax.HExpr where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Arrow (first, second)\nimport Data.Either (partitionEithers)\nimport Data.List (foldl1')\n\n#if !MIN_VERSION_base(4,20,0)\nimport Data.List (foldl')\n#endif\n\n-- ghc\nimport GHC_Builtin_Types (tupleDataCon)\nimport GHC_Data_OrdList (toOL)\nimport GHC_Hs_Doc (HsDocString)\nimport GHC_Hs_Expr (ArithSeqInfo (..), GRHS (..),\n HsExpr (..), HsMatchContext (..),\n HsTupArg (..), Match (..),\n StmtLR (..))\nimport GHC_Hs_Lit (HsLit (..), HsOverLit (..))\nimport GHC_Hs_Pat (HsRecFields (..), LHsRecField)\nimport GHC_Hs_Type (mkHsWildCardBndrs)\nimport GHC_Hs_Utils (mkBodyStmt, mkHsApp, mkHsComp, mkHsDo,\n mkHsFractional, mkHsIf, mkHsIntegral,\n mkLHsPar, mkLHsTupleExpr,\n mkMatchGroup)\nimport GHC_Parser_PostProcess (mkRdrRecordCon)\nimport GHC_Types_Basic (Arity, Boxity (..), Origin (..),\n opPrec)\nimport GHC_Types_Name_Reader (RdrName, getRdrName)\nimport GHC_Types_SrcLoc (GenLocated (..), Located,\n SrcSpan (..), getLoc, noLoc)\nimport GHC_Utils_Lexeme (isLexCon, isLexSym, isLexVarId)\n\n#if MIN_VERSION_ghc(9,10,0)\nimport Language.Haskell.Syntax.Expr (HsLamVariant (..))\n#elif MIN_VERSION_ghc(9,6,0)\nimport GHC.Hs.Extension (noHsTok)\n#endif\n\n#if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0)\nimport Language.Haskell.Syntax.Concrete (HsToken (..))\n#elif !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,4,0)\nimport Language.Haskell.Syntax.Extension (HsToken (..))\n#endif\n\n#if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,4,0)\nimport GHC.Parser.PostProcess (mkTokenLocation)\n#endif\n\n#if MIN_VERSION_ghc(9,8,0)\nimport Language.Haskell.Syntax.Expr (LHsRecUpdFields (..))\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Hs.Pat (RecFieldsDotDot (..))\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Hs.DocString (HsDocStringDecorator (..))\nimport GHC.Hs.Expr (gHsPar)\nimport Language.Haskell.Syntax.Expr (HsDoFlavour (..))\n#else\nimport GHC_Hs_Expr (HsStmtContext (..))\n#endif\n\n#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,6,0)\nimport GHC_Parser_Annotation (locA)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC_Hs_Utils (hsTypeToHsSigWcType)\n#else\nimport GHC_Hs_Utils (mkLHsSigWcType)\nimport GHC_Parser_PostProcess (mkRdrRecordUpd)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Hs_Utils (mkPsBindStmt, mkSimpleMatch)\nimport GHC_Types_SrcLoc (UnhelpfulSpanReason (..))\n#else\nimport GHC_Hs_Utils (mkBindStmt, mkHsLam)\n#endif\n\nimport GHC_Hs_Expr (parenthesizeHsExpr)\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Data.FastString (FastString, fsLit, lengthFS, nullFS,\n unconsFS, unpackFS)\nimport Language.Finkel.Data.SourceText\nimport Language.Finkel.Form\nimport Language.Finkel.Syntax.HBind\nimport Language.Finkel.Syntax.HType\nimport Language.Finkel.Syntax.Utils\n\n\n-- ---------------------------------------------------------------------\n--\n-- Expression\n--\n-- ---------------------------------------------------------------------\n\nb_ifE :: Code -> HExpr -> HExpr -> HExpr -> HExpr\nb_ifE (LForm (L l _)) p t f =\n#if MIN_VERSION_ghc(9,2,0)\n lA l (mkHsIf p t f unused)\n#else\n L l (mkHsIf p t f)\n#endif\n{-# INLINABLE b_ifE #-}\n\nb_lamE :: (HExpr,[HPat]) -> HExpr\n#if MIN_VERSION_ghc(9,0,0)\nb_lamE (body,pats) = mkLHsPar (lA l hsLam)\n -- Using 'mkHsLam' will make a 'MatchGroup' value with 'Generated' origin\n -- instead of 'FromSource', and contains 'noLoc' location. These were causing\n -- some issues when \"-Wincomplete-patterns\" flag was turned on.\n where\n# if MIN_VERSION_ghc(9,10,0)\n hsLam = HsLam unused LamSingle mg\n# else\n hsLam = HsLam unused mg\n# endif\n l = getLoc (reLoc body)\n mg = mkMatchGroup FromSource ms\n# if MIN_VERSION_ghc(9,10,0)\n ms = reLocA (L l [mkSimpleMatch (LamAlt LamSingle) pats body])\n# elif MIN_VERSION_ghc(9,2,0)\n ms = reLocA (L l [mkSimpleMatch LambdaExpr pats body])\n# else\n ms = [mkSimpleMatch LambdaExpr pats body]\n# endif\n#else\nb_lamE (body,pats) = mkHsLam pats body\n#endif\n{-# INLINABLE b_lamE #-}\n\nb_tupE :: Code -> [HExpr] -> HExpr\nb_tupE (LForm (L l _)) args = lA l e\n where\n e = explicitTuple (map mkArg args) Boxed\n#if MIN_VERSION_ghc(9,2,0)\n mkArg x = present x\n#else\n mkArg x@(L al _) = L al (present x)\n#endif\n explicitTuple = ExplicitTuple unused\n present = Present unused\n{-# INLINABLE b_tupE #-}\n\n-- Expression for tuple constructor function (i.e. the (,)\n-- function). See also 'b_varE' for tuples with more elements.\nb_tupConE :: Code -> HExpr\nb_tupConE (LForm (L l _)) = lA l (HsVar unused (lN l (tupConName Boxed 2)))\n{-# INLINABLE b_tupConE #-}\n\nb_letE :: Code -> [HDecl] -> HExpr -> Builder HExpr\nb_letE (LForm (L l _)) decls body = do\n cd <- cvBindsAndSigs (toOL decls)\n#if MIN_VERSION_ghc(9,2,0)\n let valbinds = mkHsValBinds (cd_binds cd) (cd_sigs cd)\n#else\n let valbinds = L l (mkHsValBinds (cd_binds cd) (cd_sigs cd))\n#endif\n#if MIN_VERSION_ghc(9,10,0)\n pure (lA l (HsLet (unused, unused) valbinds body))\n#elif MIN_VERSION_ghc(9,4,0)\n let tokLet = L (mkTokenLocation l) HsTok\n tokIn = L (mkTokenLocation l) HsTok\n return (lA l (HsLet unused tokLet valbinds tokIn body))\n#else\n return (lA l (HsLet unused valbinds body))\n#endif\n{-# INLINABLE b_letE #-}\n\nb_caseE :: Code -> HExpr -> [HMatch] -> HExpr\nb_caseE (LForm (L l _)) expr matches = lA l (hsCase expr mg)\n where\n hsCase = HsCase unused\n#if MIN_VERSION_ghc(9,2,0)\n mg = mkMatchGroup FromSource (lL l matches)\n#else\n mg = mkMatchGroup FromSource matches\n#endif\n{-# INLINABLE b_caseE #-}\n\nb_match :: HPat -> ([HGRHS],[HDecl]) -> HMatch\nb_match pat (grhss,decls) = L l (Match unused ctxt [pat] grhss')\n where\n grhss' = mkGRHSs grhss decls l\n ctxt = CaseAlt\n l = getLoc (dL pat)\n{-# INLINABLE b_match #-}\n\nb_hgrhs :: [HGRHS] -> (HExpr, [HGuardLStmt]) -> [HGRHS]\nb_hgrhs rhss (body, gs) =\n let lrhs = case gs of\n#if MIN_VERSION_ghc(9,10,0)\n [] -> reLocA (noLoc rhs)\n _ -> let l = getLoc (mkLocatedListA gs) in L l rhs\n#elif MIN_VERSION_ghc(9,4,0)\n [] -> reLocA (noLoc rhs)\n _ -> let l = getLoc (mkLocatedListA gs) in la2la (L l rhs)\n#else\n [] -> noLoc rhs\n _ -> let l = getLoc (mkLocatedListA gs) in reLoc (L l rhs)\n#endif\n rhs = b_GRHS gs body\n in (lrhs:rhss)\n{-# INLINABLE b_hgrhs #-}\n\nb_GRHS :: [HGuardLStmt] -> HExpr -> GRHS PARSED HExpr\nb_GRHS = GRHS unused\n{-# INLINABLE b_GRHS #-}\n\nb_doE :: Code -> [HStmt] -> HExpr\n-- XXX: Does not support \"[ModuleName.].do\" syntax yet.\nb_doE (LForm (L l _)) exprs =\n#if MIN_VERSION_ghc(9,2,0)\n lA l (mkHsDo (DoExpr Nothing) (reLocA (L l exprs)))\n#elif MIN_VERSION_ghc(9,0,0)\n L l (mkHsDo (DoExpr Nothing) exprs)\n#else\n L l (mkHsDo DoExpr exprs)\n#endif\n{-# INLINABLE b_doE #-}\n\nb_tsigE :: Code -> HExpr -> ([HType], HType) -> HExpr\nb_tsigE (LForm (L l _)) e0 (ctxt,t) =\n let t' = case ctxt of\n [] -> t\n#if MIN_VERSION_ghc(9,10,0)\n _ -> lA l (mkHsQualTy' (mkLocatedListA ctxt) t)\n#else\n _ -> lA l (mkHsQualTy' (la2la (mkLocatedListA ctxt)) t)\n#endif\n#if MIN_VERSION_ghc(9,2,0)\n e1 = ExprWithTySig unused e0 (hsTypeToHsSigWcType t')\n#else\n e1 = ExprWithTySig unused e0 (mkLHsSigWcType t')\n#endif\n in mkLHsPar (lA l e1)\n{-# INLINABLE b_tsigE #-}\n\nb_recConOrUpdE :: Code\n -> [Either Code (Located FastString, Maybe HExpr)]\n -> Builder HExpr\nb_recConOrUpdE whole@(LForm (L l form)) flds =\n case form of\n Atom (ASymbol name) | isLexCon name ->\n#if MIN_VERSION_ghc(9,2,0)\n pure (lA l (mkRdrRecordCon (lN l (mkVarRdrName name)) cflds unused))\n#else\n pure (L l (mkRdrRecordCon (L l (mkVarRdrName name)) cflds))\n#endif\n _ -> do\n v <- b_varE whole\n#if MIN_VERSION_ghc(9,8,0)\n -- XXX: Use mkRdrRecordUpd, runPV, and unP?\n pure (lA l (RecordUpd { rupd_ext = unused\n , rupd_expr = v\n , rupd_flds = RegularRecUpdFields\n { xRecUpdFields = unused\n , recUpdFields = uflds }}))\n#elif MIN_VERSION_ghc(9,2,0)\n pure (lA l (RecordUpd { rupd_ext = unused\n , rupd_expr = v\n , rupd_flds = Left uflds }))\n#else\n pure (L l (mkRdrRecordUpd v uflds))\n#endif\n where\n cflds = HsRecFields { rec_flds = map mkcfld' non_wilds\n , rec_dotdot = mb_dotdot }\n uflds = map mkufld non_wilds\n mkufld = cfld2ufld . mkcfld'\n (wilds, non_wilds) = partitionEithers flds\n mb_dotdot = case wilds of\n [] -> Nothing\n#if MIN_VERSION_ghc(9,10,0)\n LForm (L wl _):_ -> Just (la2la\n (L wl (RecFieldsDotDot (length non_wilds))))\n#elif MIN_VERSION_ghc(9,6,0)\n LForm (L wl _):_ -> Just (L wl (RecFieldsDotDot (length non_wilds)))\n#else\n LForm (L wl _):_ -> Just (L wl (length non_wilds))\n#endif\n{-# INLINABLE b_recConOrUpdE #-}\n\nb_recUpdE :: Builder HExpr -> [PreRecField HExpr] -> Builder HExpr\nb_recUpdE expr flds = do\n expr' <- expr\n let uflds = map (cfld2ufld . mkcfld') non_wilds\n (wilds, non_wilds) = partitionEithers flds\n l = getLoc expr'\n case wilds of\n (_:_) -> builderError\n#if MIN_VERSION_ghc(9,8,0)\n -- XXX: Does not support OverloadedRecUpdFields. Use mkRdrRecordUpd, runPV,\n -- and unP?\n [] -> pure (L l (RecordUpd { rupd_ext = unused\n , rupd_expr = mkLHsPar expr'\n , rupd_flds = RegularRecUpdFields\n { xRecUpdFields = unused\n , recUpdFields = uflds }}))\n#elif MIN_VERSION_ghc(9,2,0)\n -- XXX: Does not support record dot syntax yet. The return type of\n -- 'mkRdrRecordUpd' function changed from previous ghc release, now the\n -- function returns 'PV (HsExpr GhcPs)', formerly it was 'HsExpr GhcPs'.\n [] -> pure (L l (RecordUpd { rupd_ext = unused\n , rupd_expr = mkLHsPar expr'\n , rupd_flds = Left uflds }))\n#else\n [] -> pure (L l (mkRdrRecordUpd (mkLHsPar expr') uflds))\n#endif\n{-# INLINABLE b_recUpdE #-}\n\nmkcfld' :: (Located FastString, Maybe HExpr) -> LHsRecField PARSED HExpr\nmkcfld' (n,mb_e) =\n case mb_e of\n Just e -> mkcfld False (n, e)\n Nothing -> mkcfld True (n, punned)\n where\n punned = lA l (HsVar unused (lN l punRDR))\n l = getLoc n\n{-# INLINABLE mkcfld' #-}\n\nb_opOrAppE :: Code -> ([HExpr], [HType]) -> Builder HExpr\nb_opOrAppE code (args, tys) = do\n fn <- b_varE code\n let fn' = mkAppTypes fn tys\n mkOp loc lhs rhs = lA loc (mkOpApp fn' lhs (mkLHsParOp rhs))\n case code of\n -- Perform operator expansion, or delegate to `b_appE' if the head of the\n -- form was non-operator.\n LForm (L l (Atom (ASymbol name)))\n | let name' = maybe name snd (splitQualName name)\n , isLexSym name'\n , hd:rest@(_:_) <- args\n -> pure (foldl' (mkOp l) (mkLHsParOp hd) rest)\n _ -> pure (b_appE (fn':args, tys))\n{-# INLINABLE b_opOrAppE #-}\n\nmkLHsParOp :: HExpr -> HExpr\nmkLHsParOp = parenthesizeHsExpr opPrec\n{-# INLINABLE mkLHsParOp #-}\n\nmkOpApp :: HExpr -> HExpr -> HExpr -> HsExpr PARSED\nmkOpApp op l = OpApp unused l op\n{-# INLINABLE mkOpApp #-}\n\nb_appE :: ([HExpr], [HType]) -> HExpr\nb_appE (args,_tys) = foldl1' f args\n where\n f a b = mkHsApp a (mkLHsPar b)\n{-# INLINABLE b_appE #-}\n\nmkAppTypes :: HExpr -> [HType] -> HExpr\nmkAppTypes = foldl' mkAppType\n{-# INLINABLE mkAppTypes #-}\n\nmkAppType :: HExpr -> HType -> HExpr\nmkAppType (dL->expr@(L l _)) ty =\n#if MIN_VERSION_ghc(9,10,0)\n L l (HsAppType unused expr (mkHsWildCardBndrs ty))\n#elif MIN_VERSION_ghc(9,6,0)\n L l (HsAppType unused expr noHsTok (mkHsWildCardBndrs ty))\n#elif MIN_VERSION_ghc(9,2,0)\n L l (HsAppType (locA l) expr (mkHsWildCardBndrs ty))\n#else\n cL l (HsAppType unused expr (mkHsWildCardBndrs ty))\n#endif\n\nb_charE :: Code -> Builder HExpr\nb_charE (LForm (L l form)) =\n case form of\n Atom (AChar st x) -> return (lA l (hsLit (HsChar st x)))\n _ -> builderError\n{-# INLINABLE b_charE #-}\n\nb_stringE :: Code -> Builder HExpr\nb_stringE (LForm (L l form)) =\n case form of\n Atom (AString st x) -> return (lA l (hsLit (HsString st x)))\n _ -> builderError\n{-# INLINABLE b_stringE #-}\n\nb_integerE :: Code -> Builder HExpr\nb_integerE (LForm (L l form)) =\n case form of\n Atom (AInteger x)\n | il_value x < 0 -> return (lA l (hsPar (expr x)))\n | otherwise -> return (expr x)\n _ -> builderError\n where\n expr x = lA l (hsOverLit $! mkHsIntegral x)\n{-# INLINABLE b_integerE #-}\n\nb_fracE :: Code -> Builder HExpr\nb_fracE (LForm (L l form)) =\n case form of\n Atom (AFractional x)\n | fl_value x < 0 -> return (lA l (hsPar (expr x)))\n | otherwise -> return (expr x)\n _ -> builderError\n where\n expr x = lA l (hsOverLit $! mkHsFractional x)\n{-# INLINABLE b_fracE #-}\n\nb_varE :: Code -> Builder HExpr\nb_varE (LForm (L l form))\n | Atom (ASymbol x) <- form\n , not (nullFS x)\n , Just (hdchr,tlchrs) <- unconsFS x\n = case hdchr of\n -- Overloaded label starts with `#'. Tail characters need to be a valid\n -- variable identifier.\n '#' | isLexVarId tlchrs ->\n#if MIN_VERSION_ghc(9,6,0)\n ret (HsOverLabel unused (toQuotedSourceText tlchrs) tlchrs)\n#elif MIN_VERSION_ghc(9,2,0)\n ret (HsOverLabel unused tlchrs)\n#else\n ret (HsOverLabel unused Nothing tlchrs)\n#endif\n\n -- Tuple constructor function with more than two elements are written as\n -- symbol with sequence of commas, handling such case in this function.\n ',' | all (== ',') (unpackFS tlchrs)\n -> ret (var (tupConName Boxed (lengthFS x + 1)))\n\n -- Plain variable identifier.\n _ -> ret (var (mkVarRdrName x))\n | otherwise = builderError\n where\n ret = return . lA l\n var n = HsVar unused (lN l n)\n{-# INLINABLE b_varE #-}\n\nb_unitE :: Code -> HExpr\nb_unitE (LForm (L l _)) =\n#if MIN_VERSION_ghc(9,2,0)\n case mkLHsTupleExpr [] unused of L _ t -> lA l t\n#else\n case mkLHsTupleExpr [] of L _ t -> L l t\n#endif\n{-# INLINABLE b_unitE #-}\n\nb_docStringNext :: Code -> Builder (Located HsDocString)\nb_docStringNext = docStringWith hsDocStringNext\n{-# INLINABLE b_docStringNext #-}\n\nb_docStringPrev :: Code -> Builder (Located HsDocString)\nb_docStringPrev = docStringWith hsDocStringPrevious\n{-# INLINABLE b_docStringPrev #-}\n\ndocStringWith :: HsDocStringDecorator -> Code -> Builder (Located HsDocString)\ndocStringWith deco (LForm (L l form)) =\n case form of\n Atom (AString _ x) -> pure $! L l (mkHsDocStringWithDecorator deco l x)\n _ -> builderError\n{-# INLINABLE docStringWith #-}\n\nb_hsListE :: Either HExpr [HExpr] -> HExpr\nb_hsListE expr =\n case expr of\n#if MIN_VERSION_ghc(9,2,0)\n Right exprs -> L l (ExplicitList unused exprs)\n#else\n Right exprs -> L l (ExplicitList unused Nothing exprs)\n#endif\n where\n l = getLoc (mkLocatedListA exprs)\n Left arithSeqExpr -> arithSeqExpr\n{-# INLINABLE b_hsListE #-}\n\nb_lcompE :: HExpr -> [HStmt] -> HExpr\nb_lcompE ret stmts = L l (mkHsComp ListComp stmts ret)\n where l = getLoc ret\n{-# INLINABLE b_lcompE #-}\n\nb_arithSeqE :: HExpr -> Maybe HExpr -> Maybe HExpr -> HExpr\nb_arithSeqE fromE thenE toE = L l (ArithSeq unused Nothing info)\n where\n info | Just thenE' <- thenE, Just toE' <- toE =\n FromThenTo fromE thenE' toE'\n | Just thenE' <- thenE =\n FromThen fromE thenE'\n | Just toE' <- toE =\n FromTo fromE toE'\n | otherwise = From fromE\n l = getLoc fromE\n{-# INLINABLE b_arithSeqE #-}\n\nb_quoteE :: Code -> Builder HExpr\nb_quoteE (LForm (L l form)) = do\n qualify <- fmap qualifyQuote getBState\n case form of\n Atom atom -> b_quoteAtomE l qualify atom\n List xs -> b_quoteLocListE l (qListS qualify) xs\n HsList xs -> b_quoteLocListE l (qHsListS qualify) xs\n _ -> builderError\n{-# INLINABLE b_quoteE #-}\n\nb_quoteAtomE :: SrcSpan -> Bool -> Atom -> Builder HExpr\nb_quoteAtomE l qualify atom =\n case atom of\n ASymbol s -> mk_lapp qSymbolS (mk_sym s)\n AChar st c -> mk_lapp qCharS (lA l (hsLit (HsChar st c)))\n AString st str -> mk_lapp qStringS (mk_str st str)\n AInteger _il -> b_integerE orig >>= mk_lapp qIntegerS\n AFractional _fl -> b_fracE orig >>= mk_lapp qFractionalS\n AUnit -> mk_unit\n where\n mk_sym s = lA l (hsLit (HsString (toQuotedSourceText s) s))\n mk_str st str = lA l (hsLit (HsString st str))\n orig = LForm (L l (Atom atom))\n mk_lapp lname arg = do\n let (fname, sl, sc, el, ec) = getLocInfo l\n fn <- b_varE (LForm (L l (Atom (ASymbol (lname qualify)))))\n return (b_appE ([fn, arg, fname, sl, sc, el, ec], []))\n mk_unit = do\n let (fname, sl, sc, el, ec) = getLocInfo l\n fn <- b_varE (LForm (L l (Atom (ASymbol (qUnitS qualify)))))\n return (b_appE ([fn, fname, sl, sc, el, ec], []))\n{-# INLINABLE b_quoteAtomE #-}\n\nb_quoteLocListE :: SrcSpan -> FastString -> [Code] -> Builder HExpr\nb_quoteLocListE l fn_name xs = do\n mk_list <- b_varE (LForm (L l (Atom (ASymbol fn_name))))\n args <- fmap (b_hsListE . Right) (mapM b_quoteE xs)\n let (fname, sl, sc, el, ec) = getLocInfo l\n return (b_appE ([mk_list, args, fname, sl, sc, el, ec], []))\n{-# INLINABLE b_quoteLocListE #-}\n\ngetLocInfo :: SrcSpan -> (HExpr, HExpr, HExpr, HExpr, HExpr)\ngetLocInfo l = withLocInfo l fname mk_int\n where\n -- Using unhelpful location for file names, lines, and columns. Otherwise,\n -- hpc code coverage will mark the location information as non-evaluated\n -- expressions.\n fname fs = lA ql (hsLit (HsString (toQuotedSourceText fs) fs))\n mk_int n = lA ql $! hsOverLit $! mkHsIntegral $! mkIntegralLit n\n#if MIN_VERSION_ghc(9,0,0)\n ql = UnhelpfulSpan (UnhelpfulOther (fsLit \"\"))\n#else\n ql = UnhelpfulSpan (fsLit \"\")\n#endif\n{-# INLINABLE getLocInfo #-}\n\nb_rapp :: Either a b -> ([a],[b]) -> ([a],[b])\nb_rapp = either (first . (:)) (second . (:))\n{-# INLINABLE b_rapp #-}\n\nb_exprOrTyArg :: Code -> Builder (Either HExpr HType)\nb_exprOrTyArg lform = case lform of\n LForm (L l (Atom (ASymbol sym)))\n | Just ('@', rest) <- unconsFS sym, not (nullFS rest)\n -> fmap Right (b_symT (LForm (L l (Atom (ASymbol rest)))))\n _ -> fmap Left (b_varE lform)\n{-# INLINABLE b_exprOrTyArg #-}\n\n\n-- ------------------------------------------------------------------------\n--\n-- Auxiliary\n--\n-- ------------------------------------------------------------------------\n\nhsLit :: HsLit PARSED -> HsExpr PARSED\nhsLit = HsLit unused\n{-# INLINABLE hsLit #-}\n\nhsPar :: HExpr -> HsExpr PARSED\n#if MIN_VERSION_ghc(9,4,0)\nhsPar = gHsPar\n#else\nhsPar = HsPar unused\n#endif\n{-# INLINABLE hsPar #-}\n\nhsOverLit :: HsOverLit PARSED -> HsExpr PARSED\nhsOverLit = HsOverLit unused\n{-# INLINABLE hsOverLit #-}\n\ntupConName :: Boxity -> Arity -> RdrName\ntupConName boxity arity = getRdrName (tupleDataCon boxity arity)\n{-# INLINABLE tupConName #-}\n\n\n-- ---------------------------------------------------------------------\n--\n-- Statement\n--\n-- ---------------------------------------------------------------------\n\nb_bindS :: Code -> HPat -> HExpr -> HStmt\nb_bindS (LForm (L l _)) pat expr =\n#if MIN_VERSION_ghc(9,2,0)\n lA l (mkPsBindStmt unused pat expr)\n#elif MIN_VERSION_ghc(9,0,0)\n L l (mkPsBindStmt pat expr)\n#else\n L l (mkBindStmt pat expr)\n#endif\n{-# INLINABLE b_bindS #-}\n\nb_letS :: Code -> [HDecl] -> Builder HStmt\nb_letS (LForm (L l _)) decls = do\n cd <- cvBindsAndSigs (toOL decls)\n let valbinds = mkHsValBinds (cd_binds cd) (cd_sigs cd)\n letStmt = LetStmt unused\n#if MIN_VERSION_ghc(9,2,0)\n return (lA l (letStmt valbinds))\n#else\n return (L l (letStmt (L l valbinds)))\n#endif\n{-# INLINABLE b_letS #-}\n\nb_bodyS :: HExpr -> HStmt\nb_bodyS expr = L (getLoc expr) (mkBodyStmt expr)\n{-# INLINABLE b_bodyS #-}\n\n\n-- ------------------------------------------------------------------------\n--\n-- Parenthesizing\n--\n-- ------------------------------------------------------------------------\n\n-- Below note is for parenthesizing under ghc < 8.10, which won't hold any more:\n\n-- Note: [Parenthesizing HsExpr for patterns]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- Following \"parenthesizeHsExpr'\" is almost same as 'parenthesizeHsExpr' found\n-- in the source code of ghc 8.6.x and above, but will add parentheses for\n-- ELazyPat when given 'PprPrec' is equal or greater than 'appPrec'. This is to\n-- support lazy constructor patterns (e.g.: ~(Just n)) inside 'as' pattern.\n--\n-- For instance, below codes:\n--\n-- (@ foo (~(Just n))) ; Finkel\n--\n-- foo@(~(Just n)) -- Haskell\n--\n-- will fail to parse in Haskell when the \"~(Just n)\" is not surrounded by\n-- parentheses.\n" }, { "path": "finkel-kernel/src/Language/Finkel/Syntax/HImpExp.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE TypeFamilies #-}\n\n-- | Syntax for module header, import and export entities.\nmodule Language.Finkel.Syntax.HImpExp where\n\n#include \"ghc_modules.h\"\n\n-- ghc\nimport GHC_Data_FastString (FastString, unpackFS)\nimport GHC_Data_OrdList (toOL)\nimport GHC_Hs (HsModule (..))\nimport GHC_Hs_Doc (LHsDocString)\nimport GHC_Hs_ImpExp (IE (..), IEWildcard (..),\n IEWrappedName (..), ImportDecl (..),\n simpleImportDecl)\nimport GHC_Parser_PostProcess (cvTopDecls)\nimport GHC_Types_Name_Occurrence (tcClsName)\nimport GHC_Types_Name_Reader (RdrName, mkQual, mkUnqual)\nimport GHC_Types_SrcLoc (GenLocated (..), SrcSpan)\nimport GHC_Unit_Module (mkModuleNameFS)\nimport GHC_Utils_Lexeme (isLexCon)\nimport GHC_Hs_ImpExp (ImportDeclQualifiedStyle (..))\n\n#if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0)\nimport Language.Haskell.Syntax.Concrete (LayoutInfo (..))\n#elif !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,0,0)\nimport GHC_Types_SrcLoc (LayoutInfo (..))\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Hs (XModulePs (..))\nimport Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..))\n#endif\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Form\nimport Language.Finkel.Syntax.Utils\n\n-- ---------------------------------------------------------------------\n--\n-- Module\n--\n-- ---------------------------------------------------------------------\n\n-- In GHC source code, there is a file \"compiler/hsSyn/Convert.hs\".\n-- This module contains codes converting Template Haskell data types to\n-- GHC's internal data type, which is a helpful resource for\n-- understanding the values and types for constructing Haskell AST data.\n\ntype ModFn = Maybe LHsDocString -> [HImportDecl] -> [HDecl] -> HModule\n\nb_module :: Maybe Code -> [HIE] -> Builder ModFn\nb_module mb_form exports =\n case mb_form of\n Nothing -> return (modfn Nothing)\n Just (LForm (L l form)) | Atom (ASymbol name) <- form\n -> return (modfn (Just (lA l (mkModuleNameFS name))))\n _ -> builderError\n where\n modfn mb_name mbdoc imports decls =\n HsModule { hsmodName = mb_name\n , hsmodExports = if null exports\n then Nothing\n#if MIN_VERSION_ghc(9,10,0)\n else Just (mkLocatedListA exports)\n#else\n else Just (la2la (mkLocatedListA exports))\n#endif\n , hsmodImports = imports\n -- Function `cvTopDecls' is used for mergeing multiple top-level\n -- FunBinds, which may take different patterns in its arguments.\n , hsmodDecls = cvTopDecls (toOL decls)\n#if MIN_VERSION_ghc(9,6,0)\n , hsmodExt = XModulePs\n { hsmodAnn = unused\n# if MIN_VERSION_ghc(9,10,0)\n , hsmodLayout = unused\n# else\n , hsmodLayout = NoLayoutInfo\n# endif\n , hsmodDeprecMessage = Nothing\n , hsmodHaddockModHeader = fmap lHsDocString2LHsDoc mbdoc\n }\n#else\n -- XXX: Does not support DEPRECATED message.\n , hsmodDeprecMessage = Nothing\n# if MIN_VERSION_ghc(9,2,0)\n , hsmodAnn = unused\n# endif\n# if MIN_VERSION_ghc(9,0,0)\n , hsmodLayout = NoLayoutInfo\n# endif\n , hsmodHaddockModHeader = fmap lHsDocString2LHsDoc mbdoc\n#endif\n }\n{-# INLINABLE b_module #-}\n\nb_implicitMainModule :: Builder ([HImportDecl] -> [HDecl] -> HModule)\nb_implicitMainModule = b_module Nothing [] <*> pure Nothing\n{-# INLINABLE b_implicitMainModule #-}\n\nb_ieSym :: Code -> Builder HIE\nb_ieSym form@(LForm (L l _)) = do\n name <- getVarOrConId form\n let con = iEThingAbs l\n#if MIN_VERSION_ghc(9,10,0)\n let var x = lA l (IEVar Nothing (lA l (ieName l (mkRdrName x))) Nothing)\n#elif MIN_VERSION_ghc(9,8,0)\n let var x = lA l (IEVar Nothing (lA l (ieName l (mkRdrName x))))\n#else\n let var x = lA l (IEVar unused (lA l (ieName l (mkRdrName x))))\n#endif\n pure (if isLexCon name\n then con name\n else var name)\n{-# INLINABLE b_ieSym #-}\n\nb_ieGroup :: Int -> Code -> Builder HIE\nb_ieGroup n form@(LForm (L l body))\n | List [_, doc_code] <- body\n , Atom (AString _ doc) <- unCode doc_code\n = return $! lA l (IEGroup unused (fromIntegral n) (mkLHsDoc l doc))\n | otherwise\n = setLastToken form >> failB \"Invalid group documentation\"\n{-# INLINABLE b_ieGroup #-}\n\nb_ieDoc :: Code -> Builder HIE\nb_ieDoc (LForm (L l form)) =\n case form of\n Atom (AString _ str) -> return $! lA l (IEDoc unused (mkLHsDoc l str))\n _ -> builderError\n{-# INLINABLE b_ieDoc #-}\n\nb_ieDocNamed :: Code -> Builder HIE\nb_ieDocNamed (LForm (L l form))\n | List [_,name_code] <- form\n , Atom (ASymbol name) <- unCode name_code\n = return $! lA l (IEDocNamed unused (unpackFS name))\n | otherwise = builderError\n{-# INLINABLE b_ieDocNamed #-}\n\nb_ieAbs :: Code -> Builder HIE\nb_ieAbs form@(LForm (L l _)) = iEThingAbs l <$> getConId form\n{-# INLINABLE b_ieAbs #-}\n\nb_ieAll :: Code -> Builder HIE\nb_ieAll form@(LForm (L l _)) = do\n name <- getConId form\n#if MIN_VERSION_ghc(9,10,0)\n -- XXX: Does not support ExportDoc.\n let iEThingAll ie_name = IEThingAll (Nothing, unused) ie_name Nothing\n#elif MIN_VERSION_ghc(9,8,0)\n let iEThingAll = IEThingAll (Nothing, unused)\n#else\n let iEThingAll = IEThingAll unused\n#endif\n return $ lA l (iEThingAll (lA l (ieName l (mkUnqual tcClsName name))))\n{-# INLINABLE b_ieAll #-}\n\nb_ieWith :: Code -> [Code] -> Builder HIE\nb_ieWith (LForm (L l form)) names =\n case form of\n Atom (ASymbol name) -> return (thing name)\n _ -> builderError\n where\n#if MIN_VERSION_ghc(9,10,0)\n -- XXX: Does not support ExportDoc.\n thing name = lA l (iEThingWith (wrapped name) wc ns Nothing)\n#elif MIN_VERSION_ghc(9,2,0)\n -- XXX: Does not support DuplicateRecordFields.\n thing name = lA l (iEThingWith (wrapped name) wc ns)\n#else\n thing name = L l (iEThingWith (wrapped name) wc ns _fs)\n#endif\n wrapped name = lA l (ieName l (qn name))\n qn name =\n maybe (mkUnqual tcClsName name) (mkQual tcClsName) (splitQualName name)\n (ns, _fs) = foldr f ([],[]) names\n f (LForm (L l0 (Atom (ASymbol n0)))) (ns0, fs0) =\n (lA l0 (ieName l (mkRdrName n0)) : ns0, fs0)\n f _ acc = acc\n#if MIN_VERSION_ghc(9,8,0)\n iEThingWith = IEThingWith (Nothing, unused)\n#else\n iEThingWith = IEThingWith unused\n#endif\n wc = NoIEWildcard\n{-# INLINABLE b_ieWith #-}\n\nb_ieMdl :: [Code] -> Builder HIE\nb_ieMdl xs =\n case xs of\n [LForm (L l (Atom (ASymbol name)))] -> return (thing l name)\n _ -> builderError\n where\n thing l n = lA l (iEModuleContents (lA l (mkModuleNameFS n)))\n#if MIN_VERSION_ghc(9,8,0)\n iEModuleContents = IEModuleContents (Nothing, unused)\n#else\n iEModuleContents = IEModuleContents unused\n#endif\n{-# INLINABLE b_ieMdl #-}\n\nb_importD :: (Code, Bool, Maybe Code) -> (Bool, Maybe [HIE])\n -> Builder HImportDecl\nb_importD (name, qualified, mb_as) (hiding, mb_entities) =\n case name of\n LForm (L l (Atom (ASymbol m))) ->\n let decl = simpleImportDecl mname\n decl' = decl { ideclQualified = qualified'\n , ideclAs = fmap asModName mb_as\n , ideclName = lA l mname\n#if MIN_VERSION_ghc(9,6,0)\n , ideclImportList = hiding'\n#else\n , ideclHiding = hiding'\n#endif\n }\n mname = mkModuleNameFS m\n qualified' | qualified = QualifiedPre\n | otherwise = NotQualified\n asModName (LForm (L l' (Atom (ASymbol x)))) =\n lA l' (mkModuleNameFS x)\n asModName _ = error \"b_importD.asModName\"\n hiding' =\n case mb_entities of\n Nothing -> Nothing\n Just es -> Just (interp, lL l es)\n where\n#if MIN_VERSION_ghc(9,6,0)\n interp = if hiding then EverythingBut else Exactly\n#else\n interp = hiding\n#endif\n in return (lA l decl')\n _ -> builderError\n{-# INLINABLE b_importD #-}\n\n\n-- ------------------------------------------------------------------------\n--\n-- Auxiliary\n--\n-- ------------------------------------------------------------------------\n\niEThingAbs :: SrcSpan -> FastString -> HIE\niEThingAbs l name =\n#if MIN_VERSION_ghc(9,10,0)\n -- XXX: Does not support ExportDoc.\n lA l (IEThingAbs (Nothing, unused) (lA l (ieName l (mkUnqual tcClsName name)))\n Nothing)\n#elif MIN_VERSION_ghc(9,8,0)\n lA l (IEThingAbs (Nothing, unused) (lA l (ieName l (mkUnqual tcClsName name))))\n#else\n lA l (IEThingAbs unused (lA l (ieName l (mkUnqual tcClsName name))))\n#endif\n{-# INLINABLE iEThingAbs #-}\n\n#if MIN_VERSION_ghc(9,6,0)\nieName :: SrcSpan -> RdrName -> IEWrappedName PARSED\n#else\nieName :: SrcSpan -> RdrName -> IEWrappedName RdrName\n#endif\n#if MIN_VERSION_ghc(9,6,0)\nieName l x = IEName unused (lN l x)\n#else\nieName l x = IEName (lN l x)\n#endif\n" }, { "path": "finkel-kernel/src/Language/Finkel/Syntax/HPat.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE ViewPatterns #-}\n\n-- | Syntax for patterns.\nmodule Language.Finkel.Syntax.HPat where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Data.Either (partitionEithers)\n#if !MIN_VERSION_base(4,20,0)\nimport Data.List (foldl')\n#endif\n\n-- ghc\nimport GHC_Hs_Lit (HsLit (..), HsOverLit)\nimport GHC_Hs_Pat (HsConPatDetails, HsRecFields (..),\n Pat (..), parenthesizePat)\nimport GHC_Hs_Type (HsConDetails (..))\nimport GHC_Hs_Utils (mkHsIntegral, mkHsIsString, mkNPat,\n nlWildPat)\nimport GHC_Types_Basic (Boxity (..), appPrec, opPrec)\nimport GHC_Types_SrcLoc (GenLocated (..), Located)\nimport GHC_Utils_Lexeme (isLexCon, isLexConId, isLexConSym,\n isLexSym)\n\n#if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,6,0)\nimport GHC.Hs.Extension (noHsTok)\n#endif\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC.Hs.Pat (RecFieldsDotDot (..))\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Hs.Pat (gParPat)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Hs_Pat (ConLikeP)\n#else\nimport GHC_Hs_Extension (IdP)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Hs_Type (mkHsPatSigType)\n#else\nimport GHC_Hs_Utils (mkLHsSigWcType)\n#endif\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Data.FastString (nullFS, unconsFS)\nimport Language.Finkel.Form\nimport Language.Finkel.Syntax.Utils\n\n\n-- ------------------------------------------------------------------------\n--\n-- Pattern\n--\n-- ------------------------------------------------------------------------\n\n-- Note: [Pattern from expression]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- Until ghc-8.8.x, parser in GHC had intermediate constructors in HsExpr data\n-- type, to make HsPat values from HsExpr. In ghc-8.10.1, the intermediate\n-- constructors were removed and RdrHsSyn.{PatBuilder,ECP,DisambECP} and related\n-- functions were introduced. Those modules were renamed to\n-- GHC.Parser.PostProcess in ghc 9.0.1.\n--\n-- At the moment, Finkel parser does not use the ECP, since the prefix notation\n-- does not introduce ambiguous syntax so much. Also, due to the ubiquitous use\n-- of the parentheses, parsing without adding redundant parentheses in the AST\n-- seemed difficult with the ECP approach.\n\nb_intP :: Code -> Builder HPat\nb_intP (LForm (L l form)) =\n case form of\n Atom (AInteger n) -> return $! lA l (npat n)\n _ -> builderError\n where\n npat n = mkNPat' (L l (mkHsIntegral n))\n{-# INLINABLE b_intP #-}\n\nb_stringP :: Code -> Builder HPat\nb_stringP (LForm (L l form)) =\n case form of\n Atom (AString stxt str) -> return $! lA l (npat stxt str)\n _ -> builderError\n where\n npat stxt str = mkNPat' (L l (mkHsIsString stxt str))\n{-# INLINABLE b_stringP #-}\n\nb_charP :: Code -> Builder HPat\nb_charP (LForm (L l form)) =\n case form of\n Atom (AChar stxt c) -> return $! lA l (LitPat unused (HsChar stxt c))\n _ -> builderError\n{-# INLINABLE b_charP #-}\n\nb_unitP :: Code -> Builder HPat\nb_unitP (LForm (L l form)) =\n case form of\n Atom AUnit -> return $! lA l (mkTuplePat [])\n _ -> builderError\n{-# INLINABLE b_unitP #-}\n\nb_wildP :: Code -> HPat\nb_wildP (LForm (L l _)) = lA l wildPat\n where\n wildPat | L _ pat <- dL nlWildPat = pat\n{-# INLINABLE b_wildP #-}\n\nb_symP :: Code -> Builder HPat\nb_symP orig@(LForm (L l form))\n | (Atom (ASymbol name)) <- form\n , Just (hdchr,tlchrs) <- unconsFS name\n = case () of\n _ | isLexCon name\n -- Constructor.\n -> return (lA l (mkConPat (lN l (mkVarRdrName name)) (mkPrefixCon [])))\n | hdchr == '~'\n -- Lazy pattern or operator function.\n -> if nullFS tlchrs\n then failB \"Invalid use of `~'\"\n else if isLexSym tlchrs\n -- Operator function.\n then do checkVarId orig name\n let name' = lN l (mkRdrName name)\n return (lA l (VarPat unused name'))\n -- Lazy pattern.\n else do checkVarId orig tlchrs\n let name' = lN l (mkRdrName tlchrs)\n pat = lA l (VarPat unused name')\n return (lA l (LazyPat unused pat))\n | hdchr == '!'\n , not (nullFS tlchrs)\n , not (isLexSym tlchrs)\n -- Bang pattern.\n -> do let pat = lA l (VarPat unused (lN l (mkRdrName tlchrs)))\n checkVarId orig tlchrs\n return (lA l (BangPat unused pat))\n | otherwise\n -- Varid.\n -> do checkVarId orig name\n return (lA l (VarPat unused (lN l (mkRdrName name))))\n | otherwise = builderError\n{-# INLINABLE b_symP #-}\n\nb_hsListP :: [HPat] -> HPat\nb_hsListP pats = p\n where\n p = case dL (mkLocatedListA pats) of L l _ -> L l (listPat pats)\n listPat = ListPat unused\n{-# INLINABLE b_hsListP #-}\n\nb_labeledP :: Code -> [PreRecField HPat] -> Builder HPat\nb_labeledP (LForm (L l form)) ps\n | Atom (ASymbol name) <- form\n , isLexCon name = do\n let mkcfld' (lab, mb_p) =\n case mb_p of\n Just p -> mkcfld False (lab, p)\n Nothing -> mkcfld True (lab, punned)\n punned = lA l (VarPat unused (lN l punRDR))\n (wilds, non_wilds) = partitionEithers ps\n mb_dotdot = case wilds of\n [] -> Nothing\n#if MIN_VERSION_ghc(9,10,0)\n (LForm (L wl _): _) -> Just (la2la\n (L wl (RecFieldsDotDot (length non_wilds))))\n#elif MIN_VERSION_ghc(9,6,0)\n (LForm (L wl _): _) -> Just (L wl (RecFieldsDotDot (length non_wilds)))\n#else\n (LForm (L wl _): _) -> Just (L wl (length non_wilds))\n#endif\n flds = map mkcfld' non_wilds\n rc = HsRecFields { rec_flds = flds\n , rec_dotdot = mb_dotdot }\n cid = lN l (mkVarRdrName name)\n cpd = RecCon rc\n return (lA l (mkConPat cid cpd))\n | otherwise = builderError\n{-# INLINABLE b_labeledP #-}\n\nb_tupP :: Code -> [HPat] -> HPat\nb_tupP (LForm (L l _)) ps = lA l (mkTuplePat ps)\n{-# INLINABLE b_tupP #-}\n\nb_asP :: Code -> HPat -> Builder HPat\nb_asP (LForm (dL->L l form)) pat =\n case form of\n Atom (ASymbol name) ->\n return $! lA l (asPat (lN l (mkRdrName name)) (mkParPat' pat))\n _ -> builderError\n where\n#if MIN_VERSION_ghc(9,10,0)\n asPat lid p = AsPat unused lid p\n#elif MIN_VERSION_ghc(9,6,0)\n asPat lid p = AsPat unused lid noHsTok p\n#else\n asPat = AsPat unused\n#endif\n{-# INLINABLE b_asP #-}\n\nb_lazyP :: HPat -> HPat\nb_lazyP (dL-> L l pat0) = cL l (LazyPat unused pat1)\n where\n pat1 = parenthesizePat appPrec (cL l pat0)\n{-# INLINABLE b_lazyP #-}\n\nb_bangP :: HPat -> HPat\nb_bangP (dL->L l pat) = cL l (BangPat unused (cL l pat))\n{-# INLINABLE b_bangP #-}\n\nb_conP :: [Code] -> Bool -> [HPat] -> Builder HPat\nb_conP forms is_paren rest =\n case forms of\n [LForm (L l (Atom (ASymbol name)))]\n | is_paren, isLexConSym name -> prefixPat\n | isLexConId name -> prefixPat\n | isLexConSym name -> infixPat\n where\n rname = mkVarRdrName name\n lrname = lN l rname\n prefixPat = return (lA l (mkConPat lrname (mkPrefixCon prest)))\n prest = map (parenthesizePat appPrec) rest\n infixPat =\n case rest of\n (hd:rest') ->\n let f lh rh = lA l (mkConPat lrname (InfixCon lh (paren rh)))\n paren = parenthesizePat opPrec\n in return (foldl' f (parenthesizePat opPrec hd) rest')\n _ -> builderError\n _ -> builderError\n{-# INLINABLE b_conP #-}\n\nb_sigP :: Code -> HPat -> HType -> HPat\nb_sigP (LForm (L l _)) pat ty =\n#if MIN_VERSION_ghc(9,2,0)\n lA l (SigPat unused pat (mkHsPatSigType unused ty))\n#elif MIN_VERSION_ghc(9,0,0)\n lA l (SigPat unused pat (mkHsPatSigType ty))\n#else\n cL l (SigPat unused pat (mkLHsSigWcType ty))\n#endif\n{-# INLINABLE b_sigP #-}\n\nmkTuplePat :: [HPat] -> Pat PARSED\nmkTuplePat ps = TuplePat unused ps Boxed\n{-# INLINABLE mkTuplePat #-}\n\n-- XXX: Consider using GHC.Hs.Utils.mkParPat\nmkParPat' :: HPat -> HPat\n#if MIN_VERSION_ghc(9,4,0)\nmkParPat' pat@(L l _) = cL l (gParPat pat)\n#else\nmkParPat' (dL->L l p) =\n -- This newline is mandatory to support 'unused' CPP macro. Seems like, the C\n -- preprocessor is not working well with view pattern.\n cL l (ParPat unused (cL l p))\n#endif\n{-# INLINABLE mkParPat' #-}\n\n#if MIN_VERSION_ghc(9,0,0)\nmkConPat :: LocatedN (ConLikeP PARSED) -> HsConPatDetails PARSED -> Pat PARSED\nmkConPat = ConPat unused\n#else\nmkConPat :: Located (IdP PARSED) -> HsConPatDetails PARSED -> Pat PARSED\nmkConPat = ConPatIn\n#endif\n\nmkNPat' :: Located (HsOverLit PARSED) -> Pat PARSED\n#if MIN_VERSION_ghc(9,4,0)\nmkNPat' li = mkNPat (reLocA li) Nothing unused\n#elif MIN_VERSION_ghc(9,2,0)\nmkNPat' li = mkNPat li Nothing unused\n#else\nmkNPat' li = mkNPat li Nothing\n#endif\n{-# INLINABLE mkNPat' #-}\n\n#if MIN_VERSION_ghc(9,2,0)\nmkPrefixCon :: [a] -> HsConDetails ta a r\nmkPrefixCon = PrefixCon []\n#else\nmkPrefixCon :: [a] -> HsConDetails a r\nmkPrefixCon = PrefixCon\n#endif\n{-# INLINABLE mkPrefixCon #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Syntax/HType.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE ViewPatterns #-}\n\n-- | Syntax for type.\nmodule Language.Finkel.Syntax.HType where\n\n#include \"ghc_modules.h\"\n\n-- base\n#if !MIN_VERSION_base(4,20,0)\nimport Data.List (foldl')\n#endif\n\n-- ghc\nimport GHC_Builtin_Types (consDataCon, eqTyCon_RDR, listTyCon_RDR,\n tupleTyCon)\nimport GHC_Hs_Doc (LHsDocString)\nimport GHC_Hs_Type (HsSrcBang (..), HsTupleSort (..),\n HsTyLit (..), HsType (..),\n SrcStrictness (..),\n SrcUnpackedness (..), mkAnonWildCardTy,\n mkHsAppTy, mkHsOpTy, parenthesizeHsType)\nimport GHC_Types_Basic (Boxity (..), PprPrec (..),\n PromotionFlag (..), appPrec, funPrec,\n opPrec)\nimport GHC_Types_Name_Occurrence (dataName, tcName, tvName)\nimport GHC_Types_Name_Reader (getRdrName, mkQual, mkUnqual)\nimport GHC_Types_SrcLoc (GenLocated (..), getLoc)\nimport GHC_Utils_Lexeme (isLexCon, isLexConSym, isLexVarSym)\n\n#if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,2,0)\nimport GHC_Parser_Annotation (Anchor (..), AnchorOperation (..),\n EpAnn (..))\nimport GHC_Types_SrcLoc (srcSpanToRealSrcSpan)\n#endif\n\n#if !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,4,0)\nimport GHC.Hs.Extension (noHsUniTok)\nimport GHC.Parser.Annotation (NoEpAnns (..))\n#elif !MIN_VERSION_ghc(9,10,0) && MIN_VERSION_ghc(9,2,0)\nimport GHC_Parser_Annotation (EpaLocation (..), TrailingAnn (..))\n#endif\n\n#if !MIN_VERSION_ghc(9,4,0) && MIN_VERSION_ghc(9,0,0)\nimport GHC_Parser_Annotation (IsUnicodeSyntax (..))\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Builtin_Types (unrestrictedFunTyCon)\n#else\nimport GHC_Builtin_Types_Prim (funTyCon)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Hs_Type (HsArrow (..), mkHsForAllInvisTele)\n#else\nimport GHC_Types_Var (ForallVisFlag (..))\n#endif\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Data.FastString (lengthFS, nullFS, unconsFS)\nimport Language.Finkel.Form\nimport Language.Finkel.Syntax.Utils\n\n-- ---------------------------------------------------------------------\n--\n-- Promotion\n--\n-- ---------------------------------------------------------------------\n\nunPromoteTyVar :: HType -> HType\nunPromoteTyVar ty =\n case ty of\n (dL->L l (HsTyVar _EXT _ (L ln name))) ->\n L l (hsTyVar NotPromoted (L ln name))\n _ -> ty\n{-# INLINABLE unPromoteTyVar #-}\n\n\n-- ---------------------------------------------------------------------\n--\n-- Types\n--\n-- ---------------------------------------------------------------------\n\nb_anonWildT :: Code -> HType\nb_anonWildT (LForm (L l _)) = lA l mkAnonWildCardTy\n{-# INLINABLE b_anonWildT #-}\n\nb_symT :: Code -> Builder HType\nb_symT whole@(LForm (L l form)) =\n case form of\n Atom (ASymbol name) -> return $! ty name\n _ -> builderError\n where\n ty name =\n case splitQualName name of\n Just qual -> tv (mkQual (namespace name) qual)\n Nothing -> case unconsFS name of\n -- XXX: Handle \"StarIsType\" language extension. Name of the type kind\n -- could be obtained from \"TysWiredIn.liftedTypeKindTyCon\".\n Just (x, xs)\n | ',' == x -> tv (getRdrName (tupleTyCon Boxed arity))\n | '!' == x -> bang (tv (mkUnqual (namespace xs) xs))\n | '*' == x, nullFS xs ->\n lA l (HsStarTy unused False)\n _ -> tv (mkUnqual (namespace name) name)\n where\n arity = 1 + lengthFS name\n namespace ns\n -- Using \"isLexVarSym\" for \"TypeOperator\" extension.\n | isLexCon ns || isLexVarSym ns = tcName\n | otherwise = tvName\n tv rname = lA l (hsTyVar NotPromoted (lN l rname))\n bang = b_bangT whole\n{-# INLINABLE b_symT #-}\n\nb_unitT :: Code -> HType\nb_unitT (LForm (L l _)) = lA l (hsTupleTy hsBoxedTuple [])\n{-# INLINABLE b_unitT #-}\n\nb_tildeT :: Code -> HType\nb_tildeT (LForm (L l _)) = lA l (hsTyVar NotPromoted (lN l eqTyCon_RDR))\n{-# INLINABLE b_tildeT #-}\n\nb_funT :: Code -> [HType] -> Builder HType\nb_funT (LForm (L l _)) ts =\n -- For single argument, making HsAppTy with '(->)' instead of HsFunTy.\n case ts of\n [] -> return funty\n [t] -> return (mkHsAppTy funty t)\n _ -> return (foldr1 f ts)\n where\n f a b = addCLocAA a b (hsFunTy (parenthesizeHsType' funPrec a) b)\n -- XXX: Does not support linear type and unicode syntax.\n#if MIN_VERSION_ghc(9,2,0)\n -- XXX: As of ghc 9.2.1, the 'GHC.Hs.Type.splitHsFunType' function in the\n -- ghc package is ignoring \"EpAnnNotUsed\" constructor in the pattern match\n -- during recursion. Using \"EpAnn\" to make a dummy EpAnn typed value with\n -- \"mkDummyAnn\". Without the dummy value, GADT constructors will show\n -- compilation errors.\n# if MIN_VERSION_ghc(9,10,0)\n hsFunTy = HsFunTy ann (HsUnrestrictedArrow unused)\n# elif MIN_VERSION_ghc(9,4,0)\n hsFunTy = HsFunTy ann (HsUnrestrictedArrow noHsUniTok)\n# else\n hsFunTy = HsFunTy ann (HsUnrestrictedArrow NormalSyntax)\n# endif\n# if MIN_VERSION_ghc(9,10,0)\n ann = unused\n# else\n ann = maybe unused mkDummyAnn (srcSpanToRealSrcSpan l)\n mkDummyAnn real_span =\n let dummy_anchor = Anchor real_span UnchangedAnchor\n# if MIN_VERSION_ghc(9,4,0)\n dummy_anns = NoEpAnns\n# else\n dummy_anns = AddRarrowAnn (EpaSpan real_span)\n# endif\n dummy_comments = unused\n in EpAnn dummy_anchor dummy_anns dummy_comments\n# endif\n#elif MIN_VERSION_ghc(9,0,0)\n hsFunTy = HsFunTy unused (HsUnrestrictedArrow NormalSyntax)\n#else\n hsFunTy = HsFunTy unused\n#endif\n#if MIN_VERSION_ghc(9,0,0)\n funty = lA l (hsTyVar NotPromoted (lN l (getRdrName unrestrictedFunTyCon)))\n#else\n funty = lA l (hsTyVar NotPromoted (lN l (getRdrName funTyCon)))\n#endif\n{-# INLINABLE b_funT #-}\n\nb_tyLitT :: Code -> Builder HType\nb_tyLitT (LForm (L l form))\n | Atom (AString stxt str) <- form =\n return (mkLit l (HsStrTy stxt str))\n | Atom (AInteger IL {il_value=n, il_text=stxt}) <- form =\n return (mkLit l (HsNumTy stxt n))\n | otherwise = builderError\n where\n mkLit loc lit = lA loc (HsTyLit unused lit)\n{-# INLINABLE b_tyLitT #-}\n\nb_opOrAppT :: Code -> [HType] -> Builder HType\nb_opOrAppT form@(LForm (L l ty)) typs\n -- Perhaps empty list\n | null typs = b_symT form\n -- Constructor application (not promoted)\n | Atom (ASymbol name) <- ty\n , isLexConSym name =\n let lrname = lN l (mkUnqual tcName name)\n#if MIN_VERSION_ghc(9,4,0)\n f lhs rhs = lA l (mkHsOpTy NotPromoted lhs lrname rhs)\n#else\n f lhs rhs = lA l (mkHsOpTy lhs lrname rhs)\n#endif\n in return (foldr1 f (map (parenthesizeHsType' opPrec) typs))\n -- Var type application\n | otherwise =\n do op <- b_symT form\n b_appT (op:typs)\n{-# INLINABLE b_opOrAppT #-}\n\nb_prmConT :: Code -> Builder HType\nb_prmConT (LForm (L l form)) =\n case form of\n Atom (ASymbol name) -> return $! ty name\n _ -> builderError\n where\n ty name = lA l (hsTyVar IsPromoted (lN l (rname name)))\n rname name =\n case name of\n \":\" -> getRdrName consDataCon\n _ -> maybe (mkUnqual (namespace name) name)\n (mkQual tcName)\n (splitQualName name)\n namespace n\n | isLexCon n = dataName\n | isLexVarSym n = tcName\n | otherwise = tvName\n{-# INLINABLE b_prmConT #-}\n\nb_appT :: [HType] -> Builder HType\nb_appT [] = builderError\nb_appT (x:xs) =\n case xs of\n [] -> return x\n _ -> let f t1 t2 = addCLocAA t1 t2 (HsAppTy unused t1 (parTyApp t2))\n in pure (foldl' f x xs)\n{-# INLINABLE b_appT #-}\n\nb_listT :: HType -> HType\nb_listT ty@(L l _) = L l (HsListTy unused ty)\n{-# INLINABLE b_listT #-}\n\nb_nilT :: Code -> HType\nb_nilT (LForm (L l _)) = lA l (hsTyVar NotPromoted (lN l listTyCon_RDR))\n{-# INLINABLE b_nilT #-}\n\nb_tupT :: Code -> [HType] -> HType\nb_tupT (LForm (L l _)) ts =\n case ts of\n [] -> lA l (hsTyVar NotPromoted (lN l tup))\n where\n tup = getRdrName (tupleTyCon Boxed 2)\n _ -> lA l (hsTupleTy hsBoxedTuple ts)\n{-# INLINABLE b_tupT #-}\n\nb_bangT :: Code -> HType -> HType\nb_bangT (LForm (L l _)) t = lA l (hsBangTy srcBang (parTyApp t))\n where\n srcBang = HsSrcBang (SourceText \"b_bangT\") NoSrcUnpack SrcStrict\n{-# INLINABLE b_bangT #-}\n\nb_forallT :: Code -> ([HTyVarBndrSpecific], ([HType], HType)) -> HType\nb_forallT (LForm (L l0 _)) (bndrs, (ctxts, body)) =\n let ty0 = lA l0 (mkHsQualTy' ctxts' body)\n#if MIN_VERSION_ghc(9,10,0)\n ctxts' = mkLocatedListA ctxts\n#else\n ctxts' = la2la (mkLocatedListA ctxts)\n#endif\n ty1 = hsParTy (lA l0 (forAllTy bndrs ty0))\n in lA l0 ty1\n{-# INLINABLE b_forallT #-}\n\nb_qualT :: Code -> ([HType], HType) -> HType\nb_qualT (LForm (L l _)) (ctxts, body) =\n#if MIN_VERSION_ghc(9,10,0)\n lA l (mkHsQualTy' (mkLocatedListA ctxts) body)\n#else\n lA l (mkHsQualTy' (la2la (mkLocatedListA ctxts)) body)\n#endif\n{-# INLINABLE b_qualT #-}\n\nb_kindedType :: Code -> HType -> HType -> HType\nb_kindedType (LForm (L l _)) ty kind =\n lA l (hsParTy (lA l (HsKindSig unused ty kind)))\n{-# INLINABLE b_kindedType #-}\n\nb_docT :: HType -> LHsDocString -> HType\nb_docT ty doc = let l = getLocA ty in lA l (HsDocTy unused ty doc')\n where\n doc' = lHsDocString2LHsDoc doc\n{-# INLINABLE b_docT #-}\n\nb_unpackT :: Code -> HType -> HType\nb_unpackT (LForm (L l _)) t = lA l (hsBangTy bang t')\n where\n bang = HsSrcBang (SourceText \"b_unpackT\") SrcUnpack strictness\n (strictness, t') =\n case t of\n L _ (HsBangTy _EXT (HsSrcBang _ _ st) t0) -> (st, t0)\n _ -> (NoSrcStrict, t)\n{-# INLINABLE b_unpackT #-}\n\nb_prmListT :: ([Code] -> Builder [HType]) -> Code -> Builder HType\nb_prmListT prsr typs =\n case typs of\n LForm (L l (HsList xs))\n | null xs -> return (lA l (hsExplicitListTy []))\n | otherwise -> do\n tys <- prsr xs\n return $! lA l (hsExplicitListTy tys)\n _ -> builderError\n{-# INLINABLE b_prmListT #-}\n\nb_prmTupT :: ([Code] -> Builder [HType]) -> [Code] -> Builder HType\nb_prmTupT prsr typs =\n case typs of\n hd:tl\n | isCommaSymbol hd -> do\n tys <- prsr tl\n let tys' = map unPromoteTyVar tys\n l = getLoc (mkLocatedList (map unLForm typs))\n return (lA l (HsExplicitTupleTy unused tys'))\n _ -> builderError\n{-# INLINABLE b_prmTupT #-}\n\nisCommaSymbol :: Code -> Bool\nisCommaSymbol (LForm (L _ form)) =\n case form of\n Atom (ASymbol \",\") -> True\n _ -> False\n{-# INLINABLE isCommaSymbol #-}\n\nhsTupleTy :: HsTupleSort -> [HType] -> HsType PARSED\nhsTupleTy = HsTupleTy unused\n{-# INLINABLE hsTupleTy #-}\n\nhsBangTy :: HsSrcBang -> HType -> HsType PARSED\nhsBangTy = HsBangTy unused\n{-# INLINABLE hsBangTy #-}\n\nforAllTy :: [HTyVarBndrSpecific] -> HType -> HsType PARSED\nforAllTy bndrs body =\n HsForAllTy { hst_body = body\n#if MIN_VERSION_ghc(9,2,0)\n , hst_tele = mkHsForAllInvisTele unused bndrs\n#elif MIN_VERSION_ghc(9,0,0)\n , hst_tele = mkHsForAllInvisTele bndrs\n#else\n , hst_bndrs = bndrs\n , hst_fvf = ForallInvis\n#endif\n , hst_xforall = unused\n }\n{-# INLINABLE forAllTy #-}\n\nhsParTy :: HType -> HsType PARSED\nhsParTy = HsParTy unused\n{-# INLINABLE hsParTy #-}\n\nhsTyVar :: PromotionFlag -> LIdP PARSED -> HsType PARSED\nhsTyVar = HsTyVar unused\n{-# INLINABLE hsTyVar #-}\n\nhsExplicitListTy :: [HType] -> HsType PARSED\nhsExplicitListTy = HsExplicitListTy unused IsPromoted\n{-# INLINABLE hsExplicitListTy #-}\n\nhsBoxedTuple :: HsTupleSort\n#if MIN_VERSION_ghc(9,2,0)\nhsBoxedTuple = HsBoxedOrConstraintTuple\n#else\nhsBoxedTuple = HsBoxedTuple\n#endif\n\n-- ---------------------------------------------------------------------\n--\n-- Parenthesizing\n--\n-- ---------------------------------------------------------------------\n\n-- Unlike \"HsTypes.parenthesizeHsType\" in ghc 8.6.x, does not\n-- parenthesize \"HsBangTy\" constructor, because\n-- \"HsTypes.parenthesizeHsType\" is used for parenthesizing argument in\n-- HsFunTy.\n\n-- | Parenthesize given 'HType' with 'appPrec'.\nparTyApp :: HType -> HType\nparTyApp = parenthesizeHsType' appPrec\n{-# INLINABLE parTyApp #-}\n\nparenthesizeHsType' :: PprPrec -> HType -> HType\nparenthesizeHsType' p lty@(L _ ty)\n | HsBangTy {} <- ty = lty\n | otherwise = parenthesizeHsType p lty\n" }, { "path": "finkel-kernel/src/Language/Finkel/Syntax/Location.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE FlexibleContexts #-}\n\n -- For HasLoc (GenLocated l e)\n{-# LANGUAGE MonoLocalBinds #-}\n\n-- | Module for location in Haskell AST\nmodule Language.Finkel.Syntax.Location\n ( -- * Auxiliary function\n lN, lA, lL\n , mkLocatedList, mkLocatedListA\n , mkLocatedListA'\n\n -- * Re-export or aliase\n , LocatedN, LIdP\n , getLocA, la2la, reLoc, reLocA, addCLocA, addCLocAA\n , cL, dL\n\n ) where\n\n#include \"ghc_modules.h\"\n\n-- ghc\n\nimport GHC_Types_SrcLoc (GenLocated (..), Located,\n SrcSpan, combineLocs, noLoc)\n\n#if MIN_VERSION_ghc(9,10,0)\nimport qualified GHC.Hs.Utils (mkLocatedList)\nimport GHC.Parser.Annotation (HasAnnotation (..),\n HasLoc (..), LocatedAn,\n NoAnn (..))\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Parser.Annotation (SrcAnn, SrcSpanAnn' (..),\n addCLocAA, combineLocsA,\n noAnn, noAnnSrcSpan, reLocA)\nimport GHC.Types.SrcLoc (noSrcSpan)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport Language.Haskell.Syntax.Extension (LIdP)\n#else\nimport GHC.Hs.Extension (LIdP)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Parser.Annotation (LocatedA, LocatedL,\n LocatedN, addCLocA, getLocA,\n la2la, reLoc)\n#else\nimport GHC_Types_SrcLoc (addCLoc, getLoc)\n#endif\n\n#if MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(9,0,0)\nimport SrcLoc (HasSrcSpan, SrcSpanLess)\nimport qualified SrcLoc\n#endif\n\n-- Note [Location helper functions]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- From 9.2.x, ghc has shifted to use EPA (Exact Print Annotation), and quite a\n-- lot of data types with location information has changed to use dedicated type\n-- synonyms for located elements, such as 'LocatedA', 'LocatedN', 'LocatedL',\n-- etc. Those new type synonyms are defined in 'GHC.Parser.Annotation' module in\n-- ghc 9.2.x source.\n\n#if !MIN_VERSION_ghc(9,2,0)\ntype LocatedN a = Located a\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nlN :: SrcSpan -> a -> LocatedN a\nlN l = L (noAnnSrcSpan l)\n\nlA :: SrcSpan -> a -> LocatedA a\nlA l = L (noAnnSrcSpan l)\n\nlL :: SrcSpan -> a -> LocatedL a\nlL l = L (noAnnSrcSpan l)\n#elif MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(9,0,0)\nlN :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a\nlN = cL\n\nlA :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a\nlA = cL\n\nlL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a\nlL = cL\n#else\nlN :: SrcSpan -> a -> Located a\nlN = L\n\nlA :: SrcSpan -> a -> Located a\nlA = L\n\nlL :: SrcSpan -> a -> Located a\nlL = L\n#endif\n{-# INLINABLE lN #-}\n{-# INLINABLE lA #-}\n{-# INLINABLE lL #-}\n\n#if MIN_VERSION_ghc(9,10,0)\nreLocA :: (HasLoc (GenLocated a e), HasAnnotation b)\n => GenLocated a e -> GenLocated b e\nreLocA = reLoc\n{-# INLINE reLocA #-}\n\naddCLocAA :: (HasLoc a, HasLoc b, HasAnnotation l)\n => a -> b -> c -> GenLocated l c\naddCLocAA = addCLocA\n{-# INLINE addCLocAA #-}\n#endif\n\n#if !MIN_VERSION_ghc(9,2,0)\ngetLocA :: Located a -> SrcSpan\ngetLocA = getLoc\n{-# INLINE getLocA #-}\n\nreLoc :: a -> a\nreLoc = id\n{-# INLINE reLoc #-}\n\nreLocA :: a -> a\nreLocA = id\n{-# INLINE reLocA #-}\n\naddCLocA :: Located a -> Located b -> c -> Located c\naddCLocA = addCLoc\n{-# INLINE addCLocA #-}\n\naddCLocAA :: Located a -> Located b -> c -> Located c\naddCLocAA = addCLoc\n{-# INLINE addCLocAA #-}\n\nla2la :: a -> a\nla2la = id\n{-# INLINE la2la #-}\n#endif\n\n-- For 8.8.x and 8.10.x compatibility in source code location management\n\n#if MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(9,0,0)\ndL :: HasSrcSpan a => a -> Located (SrcSpanLess a)\ndL = SrcLoc.dL\n\ncL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a\ncL = SrcLoc.cL\n#else\ndL :: a -> a\ndL = id\n\ncL :: s -> a -> GenLocated s a\ncL = L\n#endif\n\n{-# INLINABLE cL #-}\n{-# INLINABLE dL #-}\n\n-- For concrete 'Located' input and output.\nmkLocatedList :: [Located a] -> Located [Located a]\nmkLocatedList [] = noLoc []\nmkLocatedList ms@(hd:_) = L (combineLocs hd (last ms)) ms\n{-# INLINABLE mkLocatedList #-}\n\n#if MIN_VERSION_ghc(9,10,0)\nmkLocatedListA :: (Semigroup a, NoAnn an)\n => [LocatedAn a e] -> LocatedAn an [LocatedAn a e]\nmkLocatedListA = GHC.Hs.Utils.mkLocatedList\n\n-- The expression is same as 'mkLocatedListA', but the type signature of the\n-- resulting value has the same annotation as the element of given list.\nmkLocatedListA' :: (Semigroup a, NoAnn a)\n => [LocatedAn a e] -> LocatedAn a [LocatedAn a e]\nmkLocatedListA' = mkLocatedListA\n\n#elif MIN_VERSION_ghc(9,2,0)\nmkLocatedListA\n :: Semigroup a\n => [GenLocated (SrcAnn a) e]\n -> GenLocated (SrcAnn a) [GenLocated (SrcAnn a) e]\nmkLocatedListA [] = L (SrcSpanAnn noAnn noSrcSpan) []\nmkLocatedListA ms@(hd:_) = L (combineLocsA hd (last ms)) ms\n\nmkLocatedListA'\n :: Semigroup a\n => [GenLocated (SrcAnn a) e]\n -> GenLocated (SrcAnn a) [GenLocated (SrcAnn a) e]\nmkLocatedListA' = mkLocatedListA\n#else\nmkLocatedListA :: [Located a] -> Located [Located a]\nmkLocatedListA = mkLocatedList\n\nmkLocatedListA' :: [Located a] -> Located [Located a]\nmkLocatedListA' = mkLocatedList\n#endif\n{-# INLINABLE mkLocatedListA #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Syntax/Utils.hs", "content": "{-# LANGUAGE CPP #-}\n\n-- | Utility codes for syntax.\nmodule Language.Finkel.Syntax.Utils\n ( -- * This module\n module Language.Finkel.Syntax.Utils\n\n -- * Extension module\n , module Language.Finkel.Syntax.Extension\n\n -- * Location module\n , module Language.Finkel.Syntax.Location\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\n#if MIN_VERSION_ghc(9,0,0)\nimport Control.Applicative (Alternative (..))\n#endif\nimport Data.Char (isUpper)\n\n-- ghc\nimport GHC_Builtin_Types (consDataConName)\nimport GHC_Data_FastString (appendFS, bytesFS, consFS)\nimport GHC_Data_OrdList (OrdList)\nimport GHC_Hs_Decls (DerivStrategy (..), LConDecl,\n LDataFamInstDecl, LDocDecl,\n LFamilyDecl, LTyFamInstDecl)\nimport GHC_Hs_Doc (LHsDocString)\nimport GHC_Hs_Pat (LHsRecField, LHsRecUpdField)\nimport GHC_Hs_Type (AmbiguousFieldOcc (..),\n FieldOcc (..),\n HsTyVarBndr (..),\n HsType (..), LHsContext,\n mkFieldOcc)\nimport GHC_Parser_Lexer (P (..), ParseResult (..))\nimport qualified GHC_Parser_PostProcess as PostProcess\nimport GHC_Types_Name_Occurrence (NameSpace, srcDataName,\n tcName, tvName, varName)\nimport GHC_Types_Name_Reader (RdrName, mkQual, mkUnqual,\n mkVarUnqual, nameRdrName)\nimport GHC_Types_SrcLoc (GenLocated (..), Located,\n unLoc)\nimport GHC_Utils_Lexeme (isLexCon, isLexConSym,\n isLexVar, isLexVarSym)\n\n#if MIN_VERSION_ghc(9,10,0)\nimport GHC.Parser.Annotation (noAnnSrcSpan)\n#elif MIN_VERSION_ghc(9,4,0)\nimport GHC.Parser.Annotation (SrcSpanAnn' (..), noComments)\n#endif\n\n#if MIN_VERSION_ghc(9,8,0)\nimport Language.Haskell.Syntax.Type (HsBndrVis (..))\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Hs.Doc (LHsDoc)\nimport GHC.Hs.DocString (HsDocStringDecorator (..))\nimport GHC.Hs.Pat (HsFieldBind (..))\nimport GHC.Parser (parseIdentifier)\nimport GHC.Parser.HaddockLex (lexHsDoc)\nimport GHC.Types.SrcLoc (SrcSpan)\n#else\nimport GHC_Hs_Pat (HsRecField' (..))\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Hs.Extension (GhcPass (..))\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Hs_Decls (ConDecl (..))\nimport GHC_Hs_Type (LHsTyVarBndr)\nimport GHC_Types_Var (Specificity (..))\n#else\nimport HaddockUtils (addConDoc)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Hs.Doc (HsDocString (..),\n mkHsDocStringChunkUtf8ByteString)\n#else\nimport GHC_Hs_Doc (HsDocString,\n mkHsDocStringUtf8ByteString)\n#endif\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Data.FastString (FastString, fsLit, unconsFS,\n unpackFS)\nimport Language.Finkel.Form\nimport Language.Finkel.Syntax.Extension\nimport Language.Finkel.Syntax.Location\n\n\n-- ------------------------------------------------------------------------\n--\n-- Types\n--\n-- ------------------------------------------------------------------------\n\n-- | An alias for record field to suuport named field puns and record wild\n-- cards.\n--\n-- @Left form@ represent a record wild pattern with @form@ being the @..@\n-- code form, @Right (fld, Nothing)@ means named field pun with @fld@ being the\n-- punned field name, and @Right (fld, Just x)@ is a traditional @field = x@\n-- style form.\ntype PreRecField a = Either Code (Located FastString, Maybe a)\n\n\n-- ------------------------------------------------------------------------\n--\n-- Functions\n--\n-- ------------------------------------------------------------------------\n\nmkRdrName :: FastString -> RdrName\nmkRdrName = mkRdrName' tcName\n{-# INLINABLE mkRdrName #-}\n\nmkVarRdrName :: FastString -> RdrName\nmkVarRdrName = mkRdrName' srcDataName\n{-# INLINABLE mkVarRdrName #-}\n\nmkRdrName' :: NameSpace -> FastString -> RdrName\nmkRdrName' upperCaseNameSpace name\n -- ':' is special syntax. It is defined in module \"GHC.Types\" in\n -- package \"ghc-prim\", but not exported.\n | name == fsLit \":\" = nameRdrName consDataConName\n\n -- Names starting with ':' are data constructor.\n | nameStartsWith (== ':') = mkUnqual srcDataName name\n\n -- Names starting with capital letters might be qualified var names or\n -- data constructor names.\n | nameStartsWith isUpper =\n case splitQualName name of\n Nothing -> mkUnqual upperCaseNameSpace name\n Just q@(_, name') -> if isLexCon name'\n then mkQual upperCaseNameSpace q\n else mkQual varName q\n\n -- Variable.\n | otherwise = mkVarUnqual name\n where\n nameStartsWith test = case unconsFS name of\n Just (x,_) -> test x\n _ -> False\n{-# INLINABLE mkRdrName' #-}\n\n-- See also \"compiler/parser/Lexer.x.source\" in ghc source code. It has\n-- private function named \"splitQualName\".\nsplitQualName :: FastString -> Maybe (FastString, FastString)\nsplitQualName fstr =\n -- e.g. \":.+.\", \":+:\". Symbol may contain \".\".\n if isLexConSym fstr\n then Nothing\n else go (unpackFS fstr) \"\" []\n where\n go [] tmp acc = case concat acc of\n [] -> Nothing\n _:tl -> let mdl = reverse tl\n var = reverse tmp\n in Just (fsLit mdl, fsLit var)\n go \".\" tmp acc = go [] ('.':tmp) acc\n go ('.':cs) tmp acc = go cs [] (('.':tmp) : acc)\n go (c:cs) tmp acc = go cs (c:tmp) acc\n{-# INLINABLE splitQualName #-}\n\ncheckVarId :: Code -> FastString -> Builder ()\ncheckVarId orig name =\n if isLexVar name\n then return ()\n else setLastToken orig >> failB \"Invalid variable identifier\"\n{-# INLINABLE checkVarId #-}\n\ngetConId :: Code -> Builder FastString\ngetConId orig@(LForm (L _ form)) =\n case form of\n Atom (ASymbol sym)\n -- `isLexVarSym' is for \"TypeOperators\" extension.\n | isLexCon sym -> return sym\n | isLexVarSym sym -> return sym\n _ -> setLastToken orig >> failB \"Invalid constructor identifier\"\n{-# INLINABLE getConId #-}\n\ngetLConId :: Code -> Builder (Located FastString)\ngetLConId orig@(LForm (L l _)) = fmap (L l) (getConId orig)\n{-# INLINABLE getLConId #-}\n\ngetVarOrConId :: Code -> Builder FastString\ngetVarOrConId orig@(LForm (L _ form)) =\n case form of\n Atom (ASymbol sym)\n | isLexCon sym -> return sym\n | isLexVar sym -> return sym\n _ -> setLastToken orig >> failB \"Invalid identifier\"\n{-# INLINABLE getVarOrConId #-}\n\n-- | Convert record field constructor expression to record field update\n-- expression.\ncfld2ufld :: LHsRecField PARSED HExpr\n#if MIN_VERSION_ghc(9,8,0)\n -> LHsRecUpdField PARSED PARSED\n#else\n -> LHsRecUpdField PARSED\n#endif\n-- Almost same as 'mk_rec_upd_field' in 'RdrHsSyn'\n#if MIN_VERSION_ghc(9,4,0)\ncfld2ufld (L l0 (HsFieldBind _ann (L l1 (FieldOcc _ rdr)) rhs pun)) =\n L l0 (HsFieldBind unused (L l1 (Unambiguous unused rdr)) rhs pun)\n#elif MIN_VERSION_ghc(9,2,0)\ncfld2ufld (L l0 (HsRecField _ (L l1 (FieldOcc _ rdr)) arg pun)) =\n L l0 (HsRecField unused (L l1 (Unambiguous unused rdr)) arg pun)\n#else\ncfld2ufld (L l0 (HsRecField (L l1 (FieldOcc _ rdr)) arg pun)) =\n L l0 (HsRecField (L l1 unambiguous) arg pun)\n where\n unambiguous = Unambiguous unused rdr\n# if !MIN_VERSION_ghc(9,0,0)\ncfld2ufld _ = error \"Language.Finkel.Syntax.Utils:cfld2ufld\"\n# endif\n#endif\n{-# INLINABLE cfld2ufld #-}\n\n-- | Make 'HsRecField' with given name and located data.\nmkcfld :: Bool -> (Located FastString, a) -> LHsRecField PARSED a\nmkcfld is_pun (L nl name, e) =\n#if MIN_VERSION_ghc(9,10,0)\n lA nl HsFieldBind { hfbAnn = unused\n , hfbLHS = L (noAnnSrcSpan nl)\n (mkFieldOcc (lN nl (mkRdrName name)))\n , hfbRHS = e\n , hfbPun = is_pun }\n#elif MIN_VERSION_ghc(9,4,0)\n lA nl HsFieldBind { hfbAnn = unused\n -- XXX: Not much sure below location is appropriate\n , hfbLHS = L (SrcSpanAnn noComments nl)\n (mkFieldOcc (lN nl (mkRdrName name)))\n , hfbRHS = e\n , hfbPun = is_pun }\n#elif MIN_VERSION_ghc(9,2,0)\n lA nl HsRecField { hsRecFieldLbl = L nl (mkFieldOcc (lN nl (mkRdrName name)))\n , hsRecFieldAnn = unused\n , hsRecFieldArg = e\n , hsRecPun = is_pun }\n#else\n lA nl HsRecField { hsRecFieldLbl = L nl (mkFieldOcc (lN nl (mkRdrName name)))\n , hsRecFieldArg = e\n , hsRecPun = is_pun }\n#endif\n{-# INLINABLE mkcfld #-}\n\n-- | Dummy name for named field puns. See: @GHC.Parser.PostProcess.pun_RDR@.\npunRDR :: RdrName\npunRDR = mkUnqual varName (fsLit \"pun-right-hand-side\")\n{-# INLINABLE punRDR #-}\n\n-- Following `cvBindsAndSigs`, `getMonoBind`, `has_args`, and\n-- `makeFunBind` functions are based on resembling functions defined in\n-- `RdrHsSyn` module in ghc package.\n--\n-- Unlike the original version, `cvBindsAndSigs` has pattern matches\n-- for 'ValD' and 'SigD' only, and `getMonoBind` ignores 'DocD'\n-- declarations.\n\n#if MIN_VERSION_ghc(9,2,0)\ntype LDocDecl' a = LDocDecl a\n#else\ntype LDocDecl' a = LDocDecl\n#endif\n\ndata CategorizedDecls = CategorizedDecls\n { cd_binds :: HBinds\n , cd_sigs :: [HSig]\n , cd_fds :: [LFamilyDecl PARSED]\n , cd_tfis :: [LTyFamInstDecl PARSED]\n , cd_dfis :: [LDataFamInstDecl PARSED]\n , cd_docs :: [LDocDecl' PARSED]\n }\n\ntoCategorizedDecls :: ( HBinds\n , [HSig]\n , [LFamilyDecl PARSED]\n , [LTyFamInstDecl PARSED]\n , [LDataFamInstDecl PARSED]\n , [LDocDecl' PARSED] )\n -> CategorizedDecls\ntoCategorizedDecls (binds, sigs, fds, tfis, dfis, docs) =\n CategorizedDecls { cd_binds = binds\n , cd_sigs = sigs\n , cd_fds = fds\n , cd_tfis = tfis\n , cd_dfis = dfis\n , cd_docs = docs }\n\ncvBindsAndSigs :: OrdList HDecl -> Builder CategorizedDecls\ncvBindsAndSigs fb =\n do ps <- fmap ghcPState getBState\n case unP (fmap toCategorizedDecls (PostProcess.cvBindsAndSigs fb)) ps of\n POk _ cd -> return cd\n _ -> builderError\n\nkindedTyVar :: Code -> Code -> HType -> Builder HTyVarBndrVis\nkindedTyVar (LForm (L l _dc)) name kind =\n case name of\n LForm (L ln (Atom (ASymbol name'))) -> do\n let name'' = lN ln (mkUnqual tvName name')\n#if MIN_VERSION_ghc(9,10,0)\n return $! lA l (KindedTyVar unused (HsBndrRequired unused) name'' kind)\n#elif MIN_VERSION_ghc(9,8,0)\n return $! lA l (KindedTyVar unused HsBndrRequired name'' kind)\n#elif MIN_VERSION_ghc(9,0,0)\n return $! lA l (KindedTyVar unused () name'' kind)\n#else\n return $! L l (KindedTyVar unused name'' kind)\n#endif\n _ -> builderError\n{-# INLINABLE kindedTyVar #-}\n\nkindedTyVarSpecific :: Code -> Code -> HType -> Builder HTyVarBndrSpecific\n#if MIN_VERSION_ghc(9,0,0)\nkindedTyVarSpecific (LForm (L l _dc)) name kind =\n case name of\n LForm (L ln (Atom (ASymbol name'))) -> do\n let name'' = lN ln (mkUnqual tvName name')\n return $! lA l (KindedTyVar unused SpecifiedSpec name'' kind)\n _ -> builderError\n#else\nkindedTyVarSpecific = kindedTyVar\n#endif\n{-# INLINABLE kindedTyVarSpecific #-}\n\n#if MIN_VERSION_ghc(9,10,0)\ncodeToUserTyVar :: Code -> HTyVarBndrVis\ncodeToUserTyVar code =\n -- XXX: Always using HsBndrRequired.\n case code of\n LForm (L l (Atom (ASymbol name))) ->\n let bvis = HsBndrRequired unused\n in lA l (UserTyVar unused bvis (lN l (mkUnqual tvName name)))\n _ -> error \"Language.Finkel.Syntax.Utils:codeToUserTyVar\"\ncodeToUserTyVarSpecific :: Code -> LHsTyVarBndr Specificity PARSED\ncodeToUserTyVarSpecific code =\n case code of\n LForm (L l (Atom (ASymbol name))) ->\n lA l (UserTyVar unused SpecifiedSpec (lN l (mkUnqual tvName name)))\n -- XXX: Does not support 'InferredSpec' yet.\n _ -> error \"Language.Finkel.Syntax.Utils:codeToUserTyVarSpecific\"\n#elif MIN_VERSION_ghc(9,8,0)\ncodeToUserTyVar :: Code -> HTyVarBndrVis\ncodeToUserTyVar code =\n case code of\n LForm (L l (Atom (ASymbol name))) ->\n lA l (UserTyVar unused HsBndrRequired (lN l (mkUnqual tvName name)))\n _ -> error \"Language.Finkel.Syntax.Utils:codeToUserTyVar\"\ncodeToUserTyVarSpecific :: Code -> LHsTyVarBndr Specificity PARSED\ncodeToUserTyVarSpecific code =\n -- XXX: Does not support 'InferredSpec' yet.\n case code of\n LForm (L l (Atom (ASymbol name))) ->\n lA l (UserTyVar unused SpecifiedSpec (lN l (mkUnqual tvName name)))\n _ -> error \"Language.Finkel.Syntax.Utils:codeToUserTyVarSpecific\"\n#elif MIN_VERSION_ghc(9,0,0)\ncodeToUserTyVar :: Code -> LHsTyVarBndr () PARSED\ncodeToUserTyVar code =\n case code of\n LForm (L l (Atom (ASymbol name))) ->\n lA l (UserTyVar unused () (lN l (mkUnqual tvName name)))\n _ -> error \"Language.Finkel.Syntax.Utils:codeToUserTyVar\"\n\ncodeToUserTyVarSpecific :: Code -> LHsTyVarBndr Specificity PARSED\ncodeToUserTyVarSpecific code =\n case code of\n LForm (L l (Atom (ASymbol name))) ->\n lA l (UserTyVar unused SpecifiedSpec (lN l (mkUnqual tvName name)))\n -- XXX: Does not support 'InferredSpec' yet.\n _ -> error \"Language.Finkel.Syntax.Utils:codeToUserTyVarSpecific\"\n#else\ncodeToUserTyVar :: Code -> HTyVarBndr\ncodeToUserTyVar code =\n case code of\n LForm (L l (Atom (ASymbol name))) ->\n L l (UserTyVar unused (L l (mkUnqual tvName name)))\n _ -> error \"Language.Finkel.Syntax.Utils:codeToUserTyVar\"\n\ncodeToUserTyVarSpecific :: Code -> HTyVarBndrSpecific\ncodeToUserTyVarSpecific = codeToUserTyVar\n#endif\n{-# INLINABLE codeToUserTyVar #-}\n{-# INLINABLE codeToUserTyVarSpecific #-}\n\n-- XXX: Move HsDocString related functions to separate module?\n\n#if !MIN_VERSION_ghc(9,4,0)\n-- These two types did not exist in ghc < 9.4, setting up simple aliases.\ntype LHsDoc pass = HsDocString\ntype HsDocStringDecorator = () -- dummy, not in use.\n#endif\n\n-- | Auxiliary function to make 'HsDocString'.\nmkHsDocString :: FastString -> HsDocString\n#if MIN_VERSION_ghc(9,4,0)\nmkHsDocString = GeneratedDocString . mkHsDocStringChunkUtf8ByteString . bytesFS\n#else\nmkHsDocString = mkHsDocStringUtf8ByteString . bytesFS\n#endif\n{-# INLINABLE mkHsDocString #-}\n\n#if MIN_VERSION_ghc(9,4,0)\nlHsDocString2LHsDoc :: LHsDocString -> LHsDoc PARSED\nlHsDocString2LHsDoc = fmap (lexHsDoc parseIdentifier)\n\nmkLHsDoc :: SrcSpan -> FastString -> LHsDoc PARSED\nmkLHsDoc l = lHsDocString2LHsDoc . L l . mkHsDocString\n\nmkLHsDocWithDecorator ::\n HsDocStringDecorator -> SrcSpan -> FastString -> LHsDoc PARSED\nmkLHsDocWithDecorator deco l fs =\n lHsDocString2LHsDoc (L l (mkHsDocStringWithDecorator deco l fs))\n\nmkHsDocStringWithDecorator ::\n HsDocStringDecorator -> SrcSpan -> FastString -> HsDocString\nmkHsDocStringWithDecorator decorator loc fs =\n let chunk = mkHsDocStringChunkUtf8ByteString (bytesFS fs)\n in NestedDocString decorator (L loc chunk)\n#else\nlHsDocString2LHsDoc :: a -> a\nlHsDocString2LHsDoc = id\n\nmkLHsDoc :: a -> FastString -> HsDocString\nmkLHsDoc _ = mkHsDocString\n\nmkLHsDocWithDecorator :: a -> b -> FastString -> LHsDoc PARSED\nmkLHsDocWithDecorator _ _ = mkHsDocString\n\nmkHsDocStringWithDecorator :: a -> b -> FastString -> HsDocString\nmkHsDocStringWithDecorator _ _ = mkHsDocString\n#endif\n{-# INLINABLE lHsDocString2LHsDoc #-}\n{-# INLINABLE mkLHsDoc #-}\n{-# INLINABLE mkLHsDocWithDecorator #-}\n{-# INLINABLE mkHsDocStringWithDecorator #-}\n\nhsDocStringNext, hsDocStringPrevious :: HsDocStringDecorator\n#if MIN_VERSION_ghc(9,4,0)\nhsDocStringNext = HsDocStringNext\nhsDocStringPrevious = HsDocStringPrevious\n#else\nhsDocStringNext = ()\nhsDocStringPrevious = ()\n#endif\n{-# INLINABLE hsDocStringNext #-}\n{-# INLINABLE hsDocStringPrevious #-}\n\nmkHsQualTy' :: LHsContext PARSED -> HType -> HsType PARSED\nmkHsQualTy' ctxt body\n | nullLHsContext ctxt = unLoc body\n | otherwise =\n HsQualTy { hst_ctxt = real_ctxt\n , hst_xqual = unused\n , hst_body = body }\n where\n#if MIN_VERSION_ghc(9,4,0)\n real_ctxt = ctxt\n#elif MIN_VERSION_ghc(9,2,0)\n real_ctxt = Just ctxt\n#else\n real_ctxt = ctxt\n#endif\n{-# INLINABLE mkHsQualTy' #-}\n\nnullLHsContext :: LHsContext PARSED -> Bool\nnullLHsContext (L _ cs) = null cs\n{-# INLINABLE nullLHsContext #-}\n\n#if MIN_VERSION_ghc(9,4,0)\naddConDoc' :: Maybe LHsDocString -> LConDecl PARSED -> LConDecl PARSED\n#else\naddConDoc' :: Maybe LHsDocString -> LConDecl' a -> LConDecl' a\n#endif\naddConDoc' = flip addConDoc\n{-# INLINABLE addConDoc' #-}\n\n#if MIN_VERSION_ghc(9,4,0)\naddConDoc'' :: LHsDocString -> LConDecl PARSED -> LConDecl PARSED\n#else\naddConDoc'' :: LHsDocString -> LConDecl' a -> LConDecl' a\n#endif\naddConDoc'' = flip addConDoc . Just\n{-# INLINABLE addConDoc'' #-}\n\n#if MIN_VERSION_ghc(9,2,0)\ntype LConDecl' a = LConDecl (GhcPass a)\n#else\ntype LConDecl' a = LConDecl a\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\naddConDoc :: LConDecl PARSED -> Maybe LHsDocString -> LConDecl PARSED\naddConDoc decl Nothing = decl\naddConDoc (L p c) (Just ld) = L p (c {con_doc = con_doc c <|> doc'})\n where\n doc' = case ld of L l d -> Just (L l (lexHsDoc parseIdentifier d))\n{-# INLINABLE addConDoc #-}\n#elif MIN_VERSION_ghc(9,0,0)\naddConDoc :: LConDecl' a -> Maybe LHsDocString -> LConDecl' a\naddConDoc decl Nothing = decl\naddConDoc (L p c) doc = L p (c {con_doc = con_doc c <|> doc})\n{-# INLINABLE addConDoc #-}\n#endif\n\nconsListWith :: [Code] -> String -> Code\nconsListWith rest sym =\n LForm (genSrc (List (LForm (genSrc (Atom (aSymbol sym))) : rest)))\n{-# INLINABLE consListWith #-}\n\nfsSymbol :: Code -> Builder (Located FastString)\nfsSymbol (LForm (L l x)) =\n case x of\n Atom (ASymbol sym) -> pure (L l sym)\n _ -> builderError\n{-# INLINABLE fsSymbol #-}\n\nstockStrategy, anyclassStrategy, newtypeStrategy :: DerivStrategy PARSED\n\n#if MIN_VERSION_ghc(9,2,0)\nstockStrategy = StockStrategy unused\nanyclassStrategy = AnyclassStrategy unused\nnewtypeStrategy = NewtypeStrategy unused\n#else\nstockStrategy = StockStrategy\nanyclassStrategy = AnyclassStrategy\nnewtypeStrategy = NewtypeStrategy\n#endif\n\n{-# INLINABLE stockStrategy #-}\n{-# INLINABLE anyclassStrategy #-}\n{-# INLINABLE newtypeStrategy #-}\n\nwrapWithSpaces :: FastString -> FastString\nwrapWithSpaces fs = consFS ' ' (appendFS fs (fsLit \" \"))\n{-# INLINABLE wrapWithSpaces #-}\n" }, { "path": "finkel-kernel/src/Language/Finkel/Syntax.y", "content": "-- -*- mode: haskell; -*-\n{\n{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\n-- | Module for parsing form data.\n--\n-- This module contains Happy parser for S-expression forms. Unlike the lexer\n-- for reading source code, parser defined in this module takes a list of 'Code'\n-- data as input, and converts to internal abstract syntax tree data defined in\n-- GHC.\n--\nmodule Language.Finkel.Syntax\n (\n -- * Forms for documentation comment\n -- $docforms\n\n -- * Haskell AST parsers\n parseModule\n , parseModuleNoHeader\n , parseHeader\n , parseImports\n , parseLImport\n , parseStmt\n , parseDecls\n , parseTopDecls\n , parseExpr\n , parseType\n ) where\n\n#include \"ghc_modules.h\"\n\n-- ghc\nimport GHC_Data_FastString (FastString)\nimport GHC_Hs_Doc (LHsDocString)\nimport GHC_Hs_Expr (GRHS(..))\nimport GHC_Types_Basic ( Activation(..), InlineSpec(..), OverlapMode(..) )\nimport GHC_Types_Fixity (FixityDirection (..))\nimport GHC_Types_ForeignCall (Safety)\nimport GHC_Types_SrcLoc (GenLocated(..), Located, getLoc, noLoc)\nimport GHC_Types_SourceText (SourceText (..))\nimport GHC_Hs_Decls (DerivStrategy(..))\n\n#if MIN_VERSION_ghc(9,10,0)\nimport GHC.Parser.Annotation (NoAnn(..))\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Parser.Annotation (LocatedA, LocatedAn, la2la)\n#endif\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Form\nimport Language.Finkel.Syntax.HDecl\nimport Language.Finkel.Syntax.HExpr\nimport Language.Finkel.Syntax.HImpExp\nimport Language.Finkel.Syntax.HPat\nimport Language.Finkel.Syntax.HType\nimport Language.Finkel.Syntax.Utils\n}\n\n%name parse_module module\n%name parse_module_no_header module_no_header\n%partial parse_header header\n\n%name p_mod_header mod_header\n\n%name p_entity entity\n%name p_entities entities\n\n%name p_imports imports\n%name p_limport limport\n\n%name p_top_decls top_decls\n%name p_top_decl top_decl\n%name p_decl decl\n%name p_decls decls\n%name p_decl_tsig decl_tsig\n%name p_lcdecl lcdecl\n%name p_lidecl lidecl\n%name p_field_detail field_detail\n%name p_lqtycl lqtycl\n%name p_sfsig sfsig\n%name p_lsimpletype lsimpletype\n%name p_ldinsthd ldinsthd\n%name p_famconhd famconhd\n%name p_lfinsthd lfinsthd\n%name p_lfameq lfameq\n%name p_phase phase\n\n%name p_type type\n%name p_types types\n%name p_types0 types0\n%name p_lconstr lconstr\n%name p_lqtycon lqtycon\n%name p_lkindtv lkindtv\n%name p_lkindtv_specific lkindtv_specific\n%name p_lh98constr lh98constr\n%name p_deriving_clause deriving_clause\n%name p_standalone_deriv standalone_deriv\n\n%name p_pat pat\n%name p_pats pats\n%name p_pats0 pats0\n%name p_pats1 pats1\n%name p_label1p label1p\n\n%name p_expr expr\n%name p_exprs exprs\n%name p_hlist hlist\n%name p_match match\n%name p_guards0 guards0\n%name p_guards1 guards1\n%name p_guard guard\n%name p_where where\n%name p_lbinds0 lbinds0\n%name p_rfbind rfbind\n%name p_app app\n\n%name p_stmt stmt\n%name p_stmt1 stmt1\n\n%tokentype { Code }\n%monad { Builder }\n%lexer { formLexer } { LForm (L _ TEnd) }\n\n%token\n\n-- Haskell 2010 reserved ids\n'case' { LForm (L _ (Atom (ASymbol \"case\"))) }\n'class' { LForm (L _ (Atom (ASymbol \"class\"))) }\n'data' { LForm (L _ (Atom (ASymbol \"data\"))) }\n'default' { LForm (L _ (Atom (ASymbol \"default\"))) }\n'deriving' { LForm (L _ (List (LForm (L _ (Atom (ASymbol \"deriving\"))):$$))) }\n'do' { LForm (L _ (Atom (ASymbol \"do\"))) }\n'foreign' { LForm (L _ (Atom (ASymbol \"foreign\"))) }\n'if' { LForm (L _ (Atom (ASymbol \"if\"))) }\n'import' { LForm (L _ (List ((LForm (L _ (Atom (ASymbol \"import\")))):$$))) }\n'infix' { LForm (L _ (Atom (ASymbol \"infix\"))) }\n'infixl' { LForm (L _ (Atom (ASymbol \"infixl\"))) }\n'infixr' { LForm (L _ (Atom (ASymbol \"infixr\"))) }\n'instance' { LForm (L _ (Atom (ASymbol \"instance\"))) }\n'let' { LForm (L _ (Atom (ASymbol \"let\"))) }\n'module' { LForm (L _ (List ((LForm (L _ (Atom (ASymbol \"module\")))):$$))) }\n'newtype' { LForm (L _ (Atom (ASymbol \"newtype\"))) }\n'type' { LForm (L _ (Atom (ASymbol \"type\"))) }\n'where' { LForm (L _ (List ((LForm (L _ (Atom (ASymbol \"where\")))):$$))) }\n\n'!' { LForm (L _ (Atom (ASymbol \"!\"))) }\n',' { LForm (L _ (Atom (ASymbol \",\"))) }\n'->' { LForm (L _ (Atom (ASymbol \"->\"))) }\n'..' { LForm (L _ (Atom (ASymbol \"..\"))) }\n'::' { LForm (L _ (Atom (ASymbol \"::\"))) }\n'<-' { LForm (L _ (Atom (ASymbol \"<-\"))) }\n'=' { LForm (L _ (Atom (ASymbol \"=\"))) }\n'=>' { LForm (L _ (Atom (ASymbol \"=>\"))) }\n'@' { LForm (L _ (Atom (ASymbol \"@\"))) }\n'\\\\' { LForm (L _ (Atom (ASymbol \"\\\\\"))) }\n'{' { LForm (L _ (Atom (ASymbol \"{\"))) }\n'|' { LForm (L _ (Atom (ASymbol \"|\"))) }\n'}' { LForm (L _ (Atom (ASymbol \"}\"))) }\n'~' { LForm (L _ (Atom (ASymbol \"~\"))) }\n'_' { LForm (L _ (Atom (ASymbol \"_\"))) }\n\n-- Non Haskell 2010 reserved id, but treated specially\n'as' { LForm (L _ (Atom (ASymbol \"as\"))) }\n'hiding' { LForm (L _ (Atom (ASymbol \"hiding\"))) }\n'qualified' { LForm (L _ (Atom (ASymbol \"qualified\"))) }\n\n-- GHC Extensions\n'anyclass' { LForm (L _ (Atom (ASymbol \"anyclass\"))) }\n'family' { LForm (L _ (Atom (ASymbol \"family\"))) }\n'forall' { LForm (L _ (Atom (ASymbol \"forall\"))) }\n'stock' { LForm (L _ (Atom (ASymbol \"stock\"))) }\n'via' { LForm (L _ (Atom (ASymbol \"via\"))) }\n\n-- Pragmas\n'inlinable' { LForm (L _ (Atom (ASymbol \"INLINABLE\"))) }\n'inline' { LForm (L _ (Atom (ASymbol \"INLINE\"))) }\n'noinline' { LForm (L _ (Atom (ASymbol \"NOINLINE\"))) }\n'specialize' { LForm (L _ (Atom (ASymbol \"SPECIALIZE\"))) }\n'unpack' { LForm (L _ (List [LForm\n (L _ (Atom (ASymbol \"UNPACK\")))])) }\n'overlappable' { LForm\n (L _ (List [LForm\n (L _ (Atom (ASymbol \"OVERLAPPABLE\")))])) }\n'overlapping' { LForm\n (L _ (List [LForm\n (L _ (Atom (ASymbol \"OVERLAPPING\")))])) }\n'overlaps' { LForm\n (L _ (List [LForm\n (L _ (Atom (ASymbol \"OVERLAPS\")))])) }\n'incoherent' { LForm\n (L _ (List [LForm\n (L _ (Atom (ASymbol \"INCOHERENT\")))])) }\n\n-- Documentation forms\n\n'doc' { LForm (L _ (List [LForm (L _ (Atom (ASymbol \":doc\"))), $$])) }\n'doc^' { LForm (L _ (List [LForm (L _ (Atom (ASymbol \":doc^\"))), $$])) }\n'doc$' { LForm (L _ (List (LForm (L _ (Atom (ASymbol \":doc$\"))) : _))) }\n'dh1' { LForm (L _ (List (LForm (L _ (Atom (ASymbol \":dh1\"))) : _))) }\n'dh2' { LForm (L _ (List (LForm (L _ (Atom (ASymbol \":dh2\"))) : _))) }\n'dh3' { LForm (L _ (List (LForm (L _ (Atom (ASymbol \":dh3\"))) : _))) }\n'dh4' { LForm (L _ (List (LForm (L _ (Atom (ASymbol \":dh4\"))) : _))) }\n\n-- Finkel specific quote primitive\n':quote' { LForm (L _ (Atom (ASymbol \":quote\"))) }\n\n-- Plain constructors\n'symbol' { LForm (L _ (Atom (ASymbol _))) }\n'char' { LForm (L _ (Atom (AChar _ _))) }\n'string' { LForm (L _ (Atom (AString _ _))) }\n'integer' { LForm (L _ (Atom (AInteger _))) }\n'frac' { LForm (L _ (Atom (AFractional _))) }\n'unit' { LForm (L _ (Atom AUnit)) }\n'list' { LForm (L _ (List _)) }\n'hslist' { LForm (L _ (HsList _)) }\n\n\n%%\n\n-- ---------------------------------------------------------------------\n--\n-- For getting elements from list form\n--\n-- ---------------------------------------------------------------------\n\nlist_es :: { [Code] }\n : 'list' {% case unCode $1 of List xs -> pure xs; _ -> builderError }\n\n\n-- ---------------------------------------------------------------------\n--\n-- Documentation\n--\n-- ---------------------------------------------------------------------\n\ndocnext :: { LHsDocString }\n : 'doc' {% b_docStringNext $1}\n\ndocprev :: { LHsDocString }\n : 'doc^' {% b_docStringPrev $1 }\n\nmbdocprev :: { Maybe LHsDocString }\n : docprev { Just $1 }\n | {- empty -} { Nothing }\n\n\n-- ---------------------------------------------------------------------\n--\n-- Module\n--\n-- ---------------------------------------------------------------------\n\n-- Note: [module_no_header parser]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- The top level \"module_no_header\" parser is used by \":eval-when-compile\"\n-- special form, which does not contain module header in its body form. Since\n-- the \":eval-when-compile\" allows to parse body forms consists of module\n-- imports only, using dedicated parser to support such situations.\n\nmodule :: { HModule }\n : mhead imports top_decls {% $1 `fmap` pure $2 <*> pure $3 }\n | imports top_decls {% b_implicitMainModule <*> pure $1 <*> pure $2 }\n | mhead imports {% $1 `fmap` pure $2 <*> pure [] }\n | mhead top_decls {% $1 `fmap` pure [] <*> pure $2 }\n | top_decls {% b_implicitMainModule <*> pure [] <*> pure $1 }\n\nmodule_no_header :: { HModule }\n : imports {% b_implicitMainModule <*> pure $1 <*> pure [] }\n | imports top_decls {% b_implicitMainModule <*> pure $1 <*> pure $2 }\n | top_decls {% b_implicitMainModule <*> pure [] <*> pure $1 }\n\nmhead :: { [HImportDecl] -> [HDecl] -> HModule }\n : 'module' {% parse p_mod_header $1 <*> pure Nothing }\n | docnext 'module' {% parse p_mod_header $2 <*> pure (Just $1) }\n\nmod_header :: { Maybe LHsDocString -> [HImportDecl] -> [HDecl] -> HModule }\n : 'symbol' exports {% b_module (Just $1) $2 }\n\nexports :: { [HIE] }\n : rexports { reverse $1 }\n\nrexports :: { [HIE] }\n : {- empty -} { [] }\n | rexports export { $2 : $1 }\n\nexport :: { HIE }\n : idsym {% b_ieSym $1 }\n | 'module' {% b_ieMdl $1 }\n | 'dh1' {% b_ieGroup 1 $1 }\n | 'dh2' {% b_ieGroup 2 $1 }\n | 'dh3' {% b_ieGroup 3 $1 }\n | 'dh4' {% b_ieGroup 4 $1 }\n | 'doc' {% b_ieDoc $1 }\n | 'doc$' {% b_ieDocNamed $1 }\n | list_es {% parse p_entity $1 }\n\nentity :: { HIE }\n : conid {- empty -} {% b_ieAbs $1 }\n | conid '..' {% b_ieAll $1 }\n | conid idsyms1 {% b_ieWith $1 $2 }\n\nentities :: { [HIE] }\n : rentities { reverse $1 }\n\nrentities :: { [HIE] }\n : {- empty -} { [] }\n | rentities idsym {% b_ieSym $2 >>= \\es -> return (es:$1) }\n | rentities list_es {% fmap (:$1) (parse p_entity $2) }\n\nimports :: { [HImportDecl] }\n : rimports { reverse $1 }\n\nrimports :: { [HImportDecl] }\n : import { [$1] }\n | rimports import { $2 : $1 }\n\nimport :: { HImportDecl }\n : 'import' {% parse p_limport $1 }\n\nlimport :: { HImportDecl }\n : 'qualified' 'symbol' 'as' 'symbol' impspec\n {% b_importD ($2, True, Just $4) $5 }\n | 'qualified' 'symbol' impspec\n {% b_importD ($2, True, Nothing) $3 }\n | 'symbol' 'as' 'symbol' impspec\n {% b_importD ($1, False, Just $3) $4 }\n | 'symbol' impspec\n {% b_importD ($1, False, Nothing) $2 }\n\nimpspec :: { (Bool, Maybe [HIE]) }\n : 'hiding' list_es {% do { es <- parse p_entities $2\n ; return (True, Just es) } }\n | list_es {% do { es <- parse p_entities $1\n ; return (False, Just es) } }\n | 'unit' { (False, Just []) }\n | {- empty -} { (False, Nothing) }\n\n-- Module declaration & imports only\nheader :: { HModule }\n : mhead imports {% $1 `fmap` pure $2 <*> pure [] }\n | mhead {% $1 `fmap` pure [] <*> pure [] }\n | imports {% b_implicitMainModule <*> pure $1 <*> pure [] }\n | {- empty -} {% b_implicitMainModule <*> pure [] <*> pure [] }\n\n\n-- ---------------------------------------------------------------------\n--\n-- Declarations\n--\n-- ---------------------------------------------------------------------\n\ntop_decls :: { [HDecl] }\n : rtop_decls { reverse $1 }\n\nrtop_decls :: { [HDecl] }\n : top_decl_with_doc { [$1] }\n | rtop_decls top_decl_with_doc { $2 : $1 }\n\ntop_decl_with_doc :: { HDecl }\n : list_es {% parse p_top_decl $1 }\n | 'deriving' {% parse p_standalone_deriv $1 }\n | 'doc' {% b_docnextD $1 }\n | 'doc^' {% b_docprevD $1 }\n | 'dh1' {% b_docGroupD 1 $1 }\n | 'dh2' {% b_docGroupD 2 $1 }\n | 'dh3' {% b_docGroupD 3 $1 }\n | 'dh4' {% b_docGroupD 4 $1 }\n | 'doc$' {% b_docNamed $1 }\n\ntop_decl :: { HDecl }\n : 'data' simpletype constrs { b_dataD $1 $2 $3 }\n | 'data' 'family' dconhead { b_datafamD $1 $3 }\n | 'data' 'instance' dinsthd constrs { b_datainstD $1 $3 $4 }\n | 'type' simpletype type { b_typeD $1 $2 $3 }\n | 'type' simpletype {% b_standaloneKindSigD $1 $2 }\n | 'type' 'family' dconhead fameqs { b_tyfamD $4 $1 $3 }\n | 'type' 'instance' finsthd type { b_tyinstD $1 $3 $4 }\n | 'newtype' simpletype constrs { b_newtypeD $1 $2 $3 }\n | 'newtype' 'instance' dinsthd constrs { b_newtypeinstD $1 $3 $4 }\n | 'class' qtycl cdecls {% b_classD $2 $3 }\n | 'instance' overlap qtycl idecls {% b_instD $2 $3 $4 }\n | 'default' zero_or_more_types { b_defaultD $2 }\n | fixity 'integer' idsyms1 {% b_fixityD $1 $2 $3 }\n | foreign { $1 }\n | decl { $1 }\n\ndinsthd :: { (Located FastString, [HType], Maybe HType) }\n : conid {% getLConId $1 >>= \\ln -> pure (ln, [], Nothing) }\n | list_es {% parse p_ldinsthd $1 }\n\nldinsthd :: { (Located FastString, [HType], Maybe HType) }\n : '::' finsthd type { case $2 of (n,ts) -> (n, ts, Just $3) }\n | conid types {% getLConId $1 >>= \\ln -> pure (ln, $2, Nothing) }\n\noverlap :: { Maybe (Located OverlapMode) }\n : {- empty -} { Nothing }\n | 'overlappable' {% b_overlapP $1 }\n | 'overlapping' {% b_overlapP $1 }\n | 'overlaps' {% b_overlapP $1 }\n | 'incoherent' {% b_overlapP $1 }\n\nsfsig :: { (Code, HType) }\n : '::' idsym type { ($2, $3) }\n\nsimpletype :: { (FastString, [HTyVarBndrVis], Maybe HKind)}\n : conid {% getConId $1 >>= \\n -> return (n, [], Nothing) }\n | list_es {% parse p_lsimpletype $1 }\n\nlsimpletype :: { (FastString, [HTyVarBndrVis], Maybe HKind) }\n : '::' conid type {% getConId $2 >>= \\n -> return (n, [], Just $3) }\n | '::' list_es type {% do { (n,tv) <- parse p_famconhd $2\n ; return (n,tv,Just $3)} }\n | famconhd { case $1 of (n,tv) -> (n,tv,Nothing) }\n\nfamconhd :: { (FastString, [HTyVarBndrVis]) }\n : conid tvbndrs {% getConId $1 >>= \\n -> return (n,$2) }\n\nconstrs :: { (HDeriving, [HConDecl]) }\n : rconstrs deriving { ($2,reverse $1) }\n\nrconstrs :: { [HConDecl] }\n : {- empty -} { [] }\n | rconstrs constr { $2 : $1 }\n\nconstr :: { HConDecl }\n : conid mbdocprev {% addConDoc' $2 `fmap` b_conOnlyD $1 }\n | list_es mbdocprev {% addConDoc' $2 `fmap` parse p_lconstr $1 }\n | docnext conid {% addConDoc'' $1 `fmap` b_conOnlyD $2 }\n | docnext list_es {% addConDoc'' $1 `fmap` parse p_lconstr $2 }\n\nderiving :: { HDeriving }\n : {- empty -} { b_emptyDeriving }\n | 'deriving' deriving {% do { ds1 <- parse p_deriving_clause $1\n ; return (b_derivsD ds1 $2) } }\n\nderiving_clause :: { HDeriving }\n : 'anyclass' types { b_derivD (Just (uLA $1 anyclassStrategy)) $2 }\n | 'newtype' types { b_derivD (Just (uLA $1 newtypeStrategy)) $2 }\n | 'stock' types { b_derivD (Just (uLA $1 stockStrategy)) $2 }\n | types mb_via { b_derivD $2 $1 }\n\nmb_via :: { Maybe HDerivStrategy }\n : {- empty -} { Nothing }\n | 'via' type {% b_viaD $2 }\n\nstandalone_deriv :: { HDecl }\n : 'anyclass' 'instance' overlap type\n { b_standaloneD (Just (uLA $1 anyclassStrategy)) $3 $4 }\n | 'newtype' 'instance' overlap type\n { b_standaloneD (Just (uLA $1 newtypeStrategy)) $3 $4 }\n | 'stock' 'instance' overlap type\n { b_standaloneD (Just (uLA $1 stockStrategy)) $3 $4}\n | mb_via 'instance' overlap type\n { b_standaloneD $1 $3 $4 }\n\nlconstr :: { HConDecl }\n : '::' conid dtype {% b_gadtD $2 $3 }\n | 'forall' forallcon {% b_forallD (fst $2) (snd $2) }\n | lqtycon { b_qtyconD $1 }\n\nforallcon :: { ([HTyVarBndrSpecific], (HConDecl, [HType])) }\n : qtycon { ([], $1) }\n | tvbndr_specific forallcon { case $2 of (vs,con) -> ($1:vs,con) }\n\nlkindtv :: { HTyVarBndrVis }\n : '::' idsym type {% kindedTyVar $1 $2 $3 }\n\ntvbndr_specific :: { HTyVarBndrSpecific }\n : idsym { codeToUserTyVarSpecific $1 }\n | list_es {% parse p_lkindtv_specific $1 }\n\nlkindtv_specific :: { HTyVarBndrSpecific }\n : '::' idsym type {% kindedTyVarSpecific $1 $2 $3 }\n\nqtycon :: { (HConDecl, [HType]) }\n : list_es {% parse p_lqtycon $1 }\n\nlqtycon :: { (HConDecl, [HType]) }\n : '=>' type tys_h98constr { let (c,ts) = $3 in (c, $2:reverse ts) }\n | lh98constr { ($1, []) }\n\ntys_h98constr :: { (HConDecl, [HType]) }\n : h98constr { ($1, []) }\n | type tys_h98constr { let (c,ts) = $2 in (c,$1:ts) }\n\nh98constr :: { HConDecl }\n : conid {% b_conOnlyD $1 }\n | list_es {% parse p_lh98constr $1 }\n\nlh98constr :: { HConDecl }\n : conid condetails {% b_conD $1 $2 }\n | conid '{' fielddecls '}' {% b_conD $1 $3 }\n\ncondetails :: { HConDeclH98Details }\n : type_args { b_conDeclDetails $1 }\n\nfielddecls :: { HConDeclH98Details }\n : fielddecls1 { b_recFieldsD $1 }\n\nfielddecls1 :: { [HConDeclField] }\n : rfielddecls { reverse $1 }\n\nrfielddecls :: { [HConDeclField] }\n : fielddecl { [$1] }\n | rfielddecls fielddecl { $2:$1 }\n\nfielddecl :: { HConDeclField }\n : list_es mbdocprev {% parse p_field_detail $1 >>= b_recFieldD $2 }\n | docnext list_es {% parse p_field_detail $2 >>= b_recFieldD (Just $1) }\n\nfield_detail :: { ([Code], HType) }\n : '::' fields_and_type { $2 }\n\nfields_and_type :: { ([Code], HType) }\n : type_without_doc { ([], $1) }\n | idsym_no_bang fields_and_type { case $2 of (ns,t) -> ($1:ns,t) }\n\nqtycl :: { ([HType], HType) }\n : list_es {% parse p_lqtycl $1 }\n\nlqtycl :: { ([HType], HType) }\n : '=>' 'unit' type { ([], $3) }\n | '=>' list_es types {% parse p_types0 $2 >>= b_qtyclC . (:$3) }\n | types0_no_qtype { ([], $1) }\n\ncdecls :: { [HDecl] }\n : rcdecls { reverse $1 }\n\nrcdecls :: { [HDecl] }\n : {- empty -} { [] }\n | rcdecls cdecl { $2:$1 }\n\ncdecl :: { HDecl }\n : 'doc^' {% b_docprevD $1 }\n | 'doc' {% b_docnextD $1 }\n | list_es {% parse p_lcdecl $1 }\n\nlcdecl :: { HDecl }\n : 'type' dconhead { b_tyfamD [] $1 $2 }\n | 'type' 'instance' finsthd type { b_tyinstD $1 $3 $4 }\n | 'data' dconhead { b_datafamD $1 $2 }\n | 'default' list_es {% parse p_decl_tsig $2 >>= b_dfltSigD }\n | decl { $1 }\n\nidecls :: { [HDecl] }\n : ridecls { reverse $1 }\n\nridecls :: { [HDecl] }\n : {- empty -} { [] }\n | ridecls idecl { $2:$1 }\n\nidecl :: { HDecl }\n : list_es {% parse p_lidecl $1 }\n\nlidecl :: { HDecl }\n : 'type' finsthd type { b_tyinstD $1 $2 $3 }\n | 'data' dinsthd constrs { b_datainstD $1 $2 $3 }\n | decl { $1 }\n\ndconhead :: { (FastString, [HTyVarBndrVis], Maybe HType) }\n : simpletype { $1 }\n\ntvbndrs :: { [HTyVarBndrVis] }\n : rtvbndrs { reverse $1 }\n\nrtvbndrs :: { [HTyVarBndrVis] }\n : {- empty -} { [] }\n | rtvbndrs tvbndr { $2:$1 }\n\ntvbndr :: { HTyVarBndrVis }\n : idsym { codeToUserTyVar $1 }\n | list_es {% parse p_lkindtv $1 }\n\nfinsthd :: { (Located FastString, [HType]) }\n : list_es {% parse p_lfinsthd $1 }\n | conid {% getLConId $1 >>= \\ln -> pure (ln, []) }\n\nlfinsthd :: { (Located FastString, [HType]) }\n : conid types {% getLConId $1 >>= \\ln -> pure (ln, map parTyApp $2) }\n\nfameqs :: { [(Located FastString, [HType], HType)] }\n : rfameqs { reverse $1 }\n\nrfameqs :: { [(Located FastString, [HType], HType)] }\n : {- empty -} { [] }\n | rfameqs fameq { $2:$1 }\n\nfameq :: { (Located FastString, [HType], HType) }\n : list_es {% parse p_lfameq $1 }\n\nlfameq :: { (Located FastString, [HType], HType) }\n : '=' finsthd type { case $2 of (c,ts) -> (c,ts,$3) }\n\nfixity :: { FixityDirection }\n : 'infixl' { InfixL }\n | 'infixr' { InfixR }\n | 'infix' { InfixN }\n\nforeign :: { HDecl }\n : 'foreign' 'symbol' ccnv {- safety -} {- \"\" -} list_es\n {% do { (name, ty) <- parse p_sfsig $4\n ; let entity = LForm (noLoc (Atom (AString NoSourceText \"\")))\n ; b_ffiD $1 $2 $3 Nothing entity (name, ty) } }\n | 'foreign' 'symbol' ccnv {- safety -} fentity list_es\n {% parse p_sfsig $5 >>= b_ffiD $1 $2 $3 Nothing $4 }\n | 'foreign' 'symbol' ccnv safety fentity list_es\n {% parse p_sfsig $6 >>= b_ffiD $1 $2 $3 (Just $4) $5 }\n\nccnv :: { HCCallConv }\n : 'symbol' {% b_callConv $1 }\n\nsafety :: { Located Safety }\n : 'symbol' {% b_safety $1 }\n\nfentity :: { Code }\n : 'string' { $1 }\n\ndecl :: { HDecl }\n : '=' pats_and_guards {% case $2 of (g,p) -> b_funOrPatD $1 p g }\n | decl_tsig { $1 }\n | 'inline' actv idsym {% b_inlineD Inline $2 $3 }\n | 'noinline' actv idsym {% b_inlineD NoInline $2 $3 }\n | 'inlinable' actv idsym {% b_inlineD Inlinable $2 $3 }\n | 'specialize' actv list_es\n {% do { sig <- parse p_sfsig $3\n ; b_specializeD $1 $2 sig }}\n | 'specialize' 'inline' actv list_es\n {% do { sig <- parse p_sfsig $4\n ; b_specializeInlineD $1 $3 sig }}\n\npats_and_guards :: { (([HGRHS],[HDecl]), [HPat]) }\n : guards { ($1, []) }\n | pat pats_and_guards { ($1:) `fmap` $2 }\n\ndecl_tsig :: { HDecl }\n : '::' idsyms_dtype {% case $2 of (ns,t) -> b_tsigD ns t }\n\ndtype :: { ([HType], HType) }\n : 'symbol' {% (\\t -> ([], t)) `fmap` b_symT $1}\n | 'unit' { ([], b_unitT $1) }\n | 'hslist' {% do { t <- parse p_type [toListL $1]\n ; return ([], b_listT t) }}\n | qtycl { $1 }\n\nidsyms_dtype :: { ([Code], ([HType], HType)) }\n : dtype { ([],$1) }\n | idsym idsyms_dtype { case $2 of (ns,t) -> ($1:ns,t) }\n\nactv :: { Maybe Activation }\n : {- empty -} { Nothing }\n | 'hslist' {% fmap Just (parse p_phase (unListL $1)) }\n\nphase :: { Activation }\n : 'integer' {% b_activation ActiveAfter $1 }\n | '~' 'integer' {% b_activation ActiveBefore $2 }\n | idsym {% b_activation ActiveBefore $1 }\n\ndecls :: { [HDecl] }\n : rdecls { reverse $1 }\n\nrdecls :: { [HDecl] }\n : {- empty -} { [] }\n | rdecls list_es {% (:$1) `fmap` parse p_decl $2 }\n\n\n-- ---------------------------------------------------------------------\n--\n-- Type\n--\n-- ---------------------------------------------------------------------\n\ntype :: { HType }\n : type_without_doc mbdocprev { maybe $1 (b_docT $1) $2 }\n\ntype_without_doc :: { HType }\n : 'symbol' {% b_symT $1 }\n | type_no_symbol { $1 }\n\ntype_no_symbol :: { HType }\n : 'unpack' type { b_unpackT $1 $2 }\n | '!' type { b_bangT $1 $2 }\n | '_' { b_anonWildT $1 }\n | 'unit' { b_unitT $1 }\n | '~' { b_tildeT $1 }\n | 'string' {% b_tyLitT $1 }\n | 'integer' {% b_tyLitT $1 }\n | 'hslist' {% case toListL $1 of\n LForm (L _ (List [])) -> return (b_nilT $1)\n xs -> fmap b_listT (parse p_type [xs]) }\n | list_es {% parse p_types0 $1 }\n\ntypes0 :: { HType }\n : '=>' qtypes { b_qualT $1 $2 }\n | types0_no_qtype { $1 }\n\ntypes0_no_qtype :: { HType }\n : '->' type_args {% b_funT $1 $2 }\n | ',' type_args { b_tupT $1 $2 }\n | 'forall' forallty { b_forallT $1 $2 }\n | '::' type type { b_kindedType $1 $2 $3 }\n | ':quote' conid {% b_prmConT $2 }\n | ':quote' 'hslist' {% b_prmListT (parse p_types) $2 }\n | ':quote' list_es {% b_prmTupT (parse p_types) $2 }\n | 'symbol' type_args {% b_opOrAppT $1 $2 }\n | type_no_symbol type_args {% b_appT ($1:$2) }\n\nforallty :: { ([HTyVarBndrSpecific], ([HType], HType)) }\n : qtycl { ([], $1) }\n | tvbndr_specific forallty { case $2 of (vs,ty) -> ($1:vs,ty) }\n\nqtypes :: { ([HType], HType) }\n : type { ([], $1) }\n | type qtypes { case $2 of (ctxts,ty) -> ($1:ctxts,ty) }\n\ntype_args :: { [HType] }\n : {- empty -} { [] }\n | rtype_args { reverse $1 }\n\nrtype_args :: { [HType] }\n : type_arg { [$1] }\n | rtype_args type_arg { $2 : $1 }\n\ntype_arg :: { HType }\n : special_id_no_bang_no_at {% b_symT $1 }\n | type { $1 }\n\ntypes :: { [HType] }\n : rtypes { reverse $1 }\n\nrtypes :: { [HType] }\n : type { [$1] }\n | rtypes type { $2 : $1 }\n\nzero_or_more_types :: { [HType] }\n : {- empty -} { [] }\n | types { $1 }\n\n\n-- ---------------------------------------------------------------------\n--\n-- Patterns\n--\n-- ---------------------------------------------------------------------\n\npats :: { [HPat] }\n : 'unit' { [] }\n | list_es {% parse p_pats0 $1 }\n\npats0 :: { [HPat] }\n : rpats0 { reverse $1 }\n\nrpats0 :: { [HPat] }\n : {- empty -} { [] }\n | rpats0 pat { $2 : $1 }\n\npat :: { HPat }\n : '~' pat_ { b_lazyP $2 }\n | '!' pat_ { b_bangP $2 }\n | pat_ { $1 }\n\npat_ :: { HPat }\n : 'integer' {% b_intP $1 }\n | 'string' {% b_stringP $1 }\n | 'char' {% b_charP $1 }\n | 'unit' {% b_unitP $1 }\n | '_' { b_wildP $1 }\n | idsym_no_bang {% b_symP $1 }\n | 'hslist' {% b_hsListP `fmap` parse p_pats0 (unListL $1) }\n | list_es {% parse p_pats1 $1 }\n\npats1 :: { HPat }\n : ',' pats0 { b_tupP $1 $2 }\n | '@' idsym_no_at pat {% b_asP $2 $3 }\n | conid '{' labelp '}' {% b_labeledP $1 $3 }\n | conid pats0 {% b_conP [$1] False $2 }\n | list_es pats0 {% b_conP $1 True $2 }\n | '::' pat type { b_sigP $1 $2 $3 }\n\nlabelp :: { [PreRecField HPat] }\n : rlabelp { reverse $1 }\n\nrlabelp :: { [PreRecField HPat] }\n : {- empty -} { [] }\n | rlabelp '..' { Left $2:$1 }\n | rlabelp idsym {% fsSymbol $2 >>= \\s -> pure (Right (s, Nothing):$1) }\n | rlabelp list_es {% (:$1) `fmap` parse p_label1p $2 }\n\nlabel1p :: { PreRecField HPat }\n : '=' idsym pat {% fsSymbol $2 >>= \\s -> pure (Right (s, Just $3)) }\n\n\n-- ---------------------------------------------------------------------\n--\n-- Expressions\n--\n-- ---------------------------------------------------------------------\n\nexpr :: { HExpr }\n : atom { $1 }\n | list_es {% parse p_exprs $1 }\n\nexpr_no_idsym :: { HExpr }\n : atom_no_idsym { $1 }\n | list_es {% parse p_exprs $1 }\n\natom :: { HExpr }\n : idsym {% b_varE $1 }\n | atom_no_idsym { $1 }\n\natom_no_idsym :: { HExpr }\n : 'char' {% b_charE $1 }\n | 'string' {% b_stringE $1 }\n | 'integer' {% b_integerE $1 }\n | 'frac' {% b_fracE $1 }\n | 'unit' { b_unitE $1 }\n | 'hslist' {% b_hsListE `fmap` parse p_hlist (unListL $1) }\n\nexprs :: { HExpr }\n : '\\\\' lambda { b_lamE $2 }\n | ',' app { b_tupE $1 (fst $2) }\n | ',' { b_tupConE $1 }\n | 'let' lbinds expr {% b_letE $1 $2 $3 }\n | 'if' expr expr expr { b_ifE $1 $2 $3 $4 }\n | 'case' expr matches { b_caseE $1 $2 $3 }\n | 'do' stmts { b_doE $1 $2 }\n | '::' expr dtype { b_tsigE $1 $2 $3 }\n | idsym '{' fbinds '}' {% b_recConOrUpdE $1 $3 }\n | list_es '{' fbinds '}' {% b_recUpdE (parse p_exprs $1) $3 }\n | ':quote' form {% b_quoteE $2 }\n | idsym app {% b_opOrAppE $1 $2 }\n | expr_no_idsym app { case $2 of (es,ts) -> b_appE ($1:es,ts) }\n | expr { $1 }\n\nlambda :: { (HExpr,[HPat]) }\n : expr { ($1,[]) }\n | pat lambda { fmap ($1:) $2 }\n\nlbinds :: { [HDecl] }\n : 'unit' { [] }\n | list_es {% parse p_lbinds0 $1 }\n\nlbinds0 :: { [HDecl] }\n : rlbinds0 { reverse $1 }\n\nrlbinds0 :: { [HDecl] }\n : {- empty -} { [] }\n | rlbinds0 list_es {% fmap (:$1) (parse p_decl $2) }\n\nfbinds :: { [PreRecField HExpr] }\n : rfbinds { reverse $1 }\n\nrfbinds :: { [PreRecField HExpr] }\n : {- empty -} { [] }\n | rfbinds '..' { Left $2:$1 }\n | rfbinds idsym {% fsSymbol $2 >>= \\s -> pure (Right (s, Nothing):$1) }\n | rfbinds list_es {% (:$1) `fmap` parse p_rfbind $2 }\n\nrfbind :: { PreRecField HExpr }\n : '=' 'symbol' expr {% (\\s -> (Right (s, Just $3))) `fmap` fsSymbol $2 }\n\napp :: { ([HExpr], [HType]) }\n : rapp { case $1 of (es,ts) -> (reverse es, reverse ts) }\n\nrapp :: { ([HExpr], [HType]) }\n : et_arg { b_rapp $1 ([], []) }\n | '@' type { b_rapp (Right (parTyApp $2)) ([], []) }\n | rapp et_arg { b_rapp $2 $1 }\n | rapp '@' type { b_rapp (Right (parTyApp $3)) $1 }\n\net_arg :: { Either HExpr HType }\n : idsym_no_at {% b_exprOrTyArg $1 }\n | expr_no_idsym { Left $1 }\n\nmatches :: { [HMatch] }\n : rmatches { reverse $1 }\n\nrmatches :: { [HMatch] }\n : {- empty -} { [] }\n | rmatches match { $2 : $1 }\n\nmatch :: { HMatch }\n : pat guards { b_match $1 $2 }\n\nhlist :: { Either HExpr [HExpr] }\n : expr expr '..' expr { Left (b_arithSeqE $1 (Just $2) (Just $4)) }\n | expr expr '..' { Left (b_arithSeqE $1 (Just $2) Nothing) }\n | expr '..' expr { Left (b_arithSeqE $1 Nothing (Just $3)) }\n | expr '..' { Left (b_arithSeqE $1 Nothing Nothing) }\n | expr '|' stmts { Left (b_lcompE $1 $3) }\n | hlist0 { Right $1 }\n\nhlist0 :: { [HExpr] }\n : {- empty -} { [] }\n | expr hlist0 { $1:$2 }\n\n\n-- Parsing form for guards\n-- ~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- Separating the rule for 'where', list_es and atom, so that the 'guards0' rule\n-- can try matching the symbol '|' before 'expr' rule, to differentiate the\n-- entire form from function application of reserved symbol '|'.\n\nguards :: { ([HGRHS],[HDecl]) }\n : 'where' {% parse p_where $1 }\n | list_es {% parse p_guards0 $1 >>= \\gs -> return (gs,[]) }\n | atom { (b_hgrhs [] ($1, []), []) }\n\nguards0 :: { [HGRHS] }\n : '|' guards1 { $2 }\n | exprs { b_hgrhs [] ($1, []) }\n\nguards1 :: { [HGRHS] }\n : list_es {% b_hgrhs [] `fmap` parse p_guard $1 }\n | list_es guards1 {% b_hgrhs $2 `fmap` parse p_guard $1 }\n\nguard :: { (HExpr, [HGuardLStmt]) }\n : expr { ($1, []) }\n | stmt guard { fmap ($1:) $2 }\n\nwhere :: { ([HGRHS],[HDecl]) }\n : list_es lbinds0 {% parse p_guards0 $1 >>= \\gs -> return (gs,$2) }\n | atom lbinds0 { (b_hgrhs [] ($1, []), $2) }\n\n-- Quoted form\n\nform :: { Code }\n : 'symbol' { $1 }\n | all_syms { $1 }\n | 'char' { $1 }\n | 'string' { $1 }\n | 'integer' { $1 }\n | 'frac' { $1 }\n | 'unit' { $1 }\n | 'list' { $1 }\n | all_lists { $1 }\n | 'hslist' { $1 }\n\nall_syms :: { Code }\n : 'case' { $1 }\n | 'class' { $1 }\n | 'data' { $1 }\n | 'default' { $1 }\n | 'do' { $1 }\n | 'foreign' { $1 }\n | 'if' { $1 }\n | 'infix' { $1 }\n | 'infixl' { $1 }\n | 'infixr' { $1 }\n | 'instance' { $1 }\n | 'let' { $1 }\n | 'newtype' { $1 }\n | 'type' { $1 }\n\n | '!' { $1 }\n | ',' { $1 }\n | '->' { $1 }\n | '..' { $1 }\n | '::' { $1 }\n | '<-' { $1 }\n | '=' { $1 }\n | '=>' { $1 }\n | '@' { $1 }\n | '\\\\' { $1 }\n | '{' { $1 }\n | '|' { $1 }\n | '}' { $1 }\n | '~' { $1 }\n | '_' { $1 }\n\n | special_id_no_bang_no_at { $1 }\n\n | 'inlinable' { $1 }\n | 'inline' { $1 }\n | 'noinline' { $1 }\n | 'specialize' { $1 }\n\n | ':quote' { $1 }\n\nall_lists :: { Code }\n : 'deriving' { consListWith $1 \"deriving\" }\n | 'import' { consListWith $1 \"import\" }\n | 'module' { consListWith $1 \"module\" }\n | 'where' { consListWith $1 \"where\" }\n | 'unpack' { $1 }\n | 'overlappable' { $1 }\n | 'overlapping' { $1 }\n | 'overlaps' { $1 }\n | 'incoherent' { $1 }\n | 'doc' { consListWith [$1] \":doc\" }\n | 'doc^' { consListWith [$1] \":doc^\" }\n | 'doc$' { $1 }\n | 'dh1' { $1 }\n | 'dh2' { $1 }\n | 'dh3' { $1 }\n | 'dh4' { $1 }\n\n\n-- ---------------------------------------------------------------------\n--\n-- Do statement\n--\n-- ---------------------------------------------------------------------\n\nstmts :: { [HStmt] }\n : rstmts { reverse $1 }\n\nrstmts :: { [HStmt] }\n : stmt { [$1] }\n | rstmts stmt { $2 : $1 }\n\nstmt :: { HStmt }\n : atom { b_bodyS $1 }\n | list_es {% parse p_stmt1 $1 }\n\nstmt1 :: { HStmt }\n : '<-' pat expr { b_bindS $1 $2 $3 }\n | 'let' lbinds {% b_letS $1 $2 }\n | exprs { b_bodyS $1 }\n\n\n-- ---------------------------------------------------------------------\n--\n-- Identifier\n--\n-- ---------------------------------------------------------------------\n\nidsym :: { Code }\n : 'symbol' { $1 }\n | special_id { $1 }\n\nidsym_no_bang :: { Code }\n : 'symbol' { $1 }\n | '@' { $1 }\n | special_id_no_bang_no_at { $1 }\n\nidsym_no_at :: { Code }\n : 'symbol' { $1 }\n | '!' { $1 }\n | special_id_no_bang_no_at { $1 }\n\nspecial_id :: { Code }\n : '!' { $1 }\n | '@' { $1 }\n | special_id_no_bang_no_at { $1 }\n\nspecial_id_no_bang_no_at :: { Code }\n : 'forall' { $1 }\n | special_id_no_bg_at_fa { $1 }\n\n-- special id, no bang, no forall\nspecial_id_no_bg_at_fa :: { Code }\n : 'anyclass' { $1 }\n | 'as' { $1 }\n | 'family' { $1 }\n | 'hiding' { $1 }\n | 'stock' { $1 }\n | 'via' { $1 }\n | 'qualified' { $1 }\n\nidsyms1 :: { [Code] }\n : ridsyms { reverse $1 }\n\nridsyms :: { [Code] }\n : idsym { [$1] }\n | ridsyms idsym { $2 : $1 }\n\nconid :: { Code }\n : 'symbol' { $1 }\n\n{\nhappyError :: Builder a\nhappyError = builderError\n\n-- | Parser for Haskell module.\nparseModule :: Builder HModule\nparseModule = parse_module\n\n-- | Parser for Haskell module with out module header.\nparseModuleNoHeader :: Builder HModule\nparseModuleNoHeader = parse_module_no_header\n\n-- | Parse module declaration and imports only.\nparseHeader :: Builder HModule\nparseHeader = parse_header\n\n-- | Parser for import declarations.\nparseImports :: Builder [HImportDecl]\nparseImports = p_imports\n\n-- | Parser for single import declaration.\nparseLImport :: Builder HImportDecl\nparseLImport = p_limport\n\n-- | Parser for statement.\nparseStmt :: Builder HStmt\nparseStmt = p_stmt\n\n-- | Parser for declarations.\nparseDecls :: Builder [HDecl]\nparseDecls = p_decls\n\n-- | Parser for top level declarations.\nparseTopDecls :: Builder [HDecl]\nparseTopDecls = p_top_decls\n\n-- | Parser for Haskell expression.\nparseExpr :: Builder HExpr\nparseExpr = p_expr\n\n-- | Parser for Haskell type.\nparseType :: Builder HType\nparseType = p_type\n\n-- | Unwrap the element of 'List' and 'HsList', otherwise returns '[]'.\nunListL :: Code -> [Code]\nunListL (LForm (L _ form)) =\n case form of\n List xs -> xs\n HsList xs -> xs\n _ -> []\n\nuL :: Code -> a -> Located a\nuL (LForm (L l _)) a = L l a\n{-# INLINE uL #-}\n\n#if MIN_VERSION_ghc(9,10,0)\nuLA :: NoAnn ann => Code -> a -> LocatedAn ann a\nuLA (LForm (L l _)) a = reLocA (L l a)\n#elif MIN_VERSION_ghc(9,4,0)\nuLA :: Code -> a -> LocatedAn ann a\nuLA (LForm (L l _)) a = la2la (reLocA (L l a))\n#else\nuLA :: Code -> a -> Located a\nuLA = uL\n#endif\n{-# INLINE uLA #-}\n\n-- $docforms\n--\n-- There are four kinds of forms for documentation comments.\n--\n-- [@:doc@]: The @(:doc \"comment\")@ form is for writing documentation with\n-- @comment@ for the next element. It can appear in export entities list, or in\n-- top level declarations. It is analogous to Haskell comments starting with\n-- @|@.\n--\n-- [@:doc^@]: The @(:doc^ \"comment\")@ form is like /:doc/, but for previous\n-- form. Unlike /:doc/, it cannot appear in export entities list. It is\n-- analogous to Haskell comments starting with @^@.\n--\n-- [@:doc$@]: The @(:doc$ name)@ and @(:doc$ name \"comment\")@ form is for\n-- referencing documentation. @(:doc$ name)@ is used in export entities list to\n-- refer other documentation comment, and @(:doc$ name \"comment\")@ is for top\n-- level to contain the documentation contents. It is analogous to Haskell\n-- comment starting with @$name@.\n--\n-- [@:dh1, :dh2, :dh3, and :dh4@]: The @(:dh1 \"comment\")@ is for level 1\n-- documentation section header. There are four levels of section headers:\n-- @:dh1@, @:dh2@, @:dh3@, and @:dh4@. It could be used in export entities list,\n-- or in top level declaration when the module does not contain explicit export\n-- entities. It is analogous to Haskell comments starting with @*@s.\n}\n" }, { "path": "finkel-kernel/src/Language/Finkel.hs", "content": "{-# LANGUAGE CPP #-}\n-- | Module re-exporting runtime dependency for Finkel kernel programs.\n--\n-- This module exports types and functions for writing Finkel kernel\n-- programs, with quotes, quasi-quotes, unquotes, unquote-splicings, and\n-- macros.\n--\nmodule Language.Finkel\n (\n -- * Form\n Atom(..)\n , Form(..)\n , LForm(..)\n\n , Code\n , unCode\n , Homoiconic(..)\n , fromCode\n\n , QuoteFn\n , qSymbol\n , qChar\n , qString\n , qInteger\n , qFractional\n , qUnit\n , qList\n , qHsList\n , nil\n , asLocOf\n\n -- * Fnk\n , Fnk\n , runFnk\n , defaultFnkEnv\n\n -- * Macro\n , Macro(Macro)\n , isMacro\n , expand\n , expands\n , expand1\n , gensym\n , gensym'\n , unquoteSplice\n , macroFunction\n\n -- * Exceptions\n , FinkelException(..)\n , finkelSrcError\n\n -- * Re-export from ghc\n , Located\n , GenLocated(..)\n , SrcSpan\n ) where\n\n#include \"ghc_modules.h\"\n\n-- ghc\nimport GHC_Types_SrcLoc (GenLocated (..), Located, SrcSpan)\n\n-- Internal\nimport Language.Finkel.Exception\nimport Language.Finkel.Expand\nimport Language.Finkel.Fnk\nimport Language.Finkel.Form\nimport Language.Finkel.Homoiconic\nimport Language.Finkel.SpecialForms\n" }, { "path": "finkel-kernel/test/EmitTest.hs", "content": "{-# LANGUAGE CPP #-}\n\nmodule EmitTest where\n\n#include \"ghc_modules.h\"\n\n-- ghc\nimport GHC_Data_FastString (fsLit)\nimport GHC_Types_Name_Reader (mkVarUnqual)\nimport GHC_Types_SrcLoc (GenLocated (..), noSrcSpan)\n\n-- hspec\nimport Test.Hspec\n\n-- finkel-kernel\nimport Language.Finkel.Emit\nimport Language.Finkel.Fnk\nimport Language.Finkel.Lexer\n\n-- Internal\nimport TestAux\n\nemitTests :: Spec\nemitTests = do\n let fooVar = mkVarUnqual (fsLit \"foo\")\n describe \"emit RdrName\" $ do\n it \"should show \\\"foo\\\"\" $ do\n foo <- emitSimple fooVar\n foo `shouldBe` \"foo\"\n describe \"emit located thing\" $ do\n it \"should show located contents\" $ do\n x <- emitSimple (L noSrcSpan fooVar)\n x `shouldBe` \"foo\"\n\nemitSimple :: HsSrc a => a -> IO String\nemitSimple h = runFnk (genHsSrc sp h) fnkTestEnv\n where\n sp = initialSPState (fsLit \"\") 0 0\n" }, { "path": "finkel-kernel/test/EvalTest.hs", "content": "{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE CPP #-}\n{-# LANGUAGE MagicHash #-}\nmodule EvalTest (evalFnkTests) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Exception (throwIO)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport GHC.Exts (unsafeCoerce#)\nimport System.Info (os)\n\n-- filepath\nimport System.FilePath (takeBaseName)\n\n-- ghc\nimport GHC_Data_StringBuffer (StringBuffer, hGetStringBuffer,\n stringToStringBuffer)\nimport GHC_Driver_Monad (printException)\nimport GHC_Driver_Ppr (showSDocForUser)\nimport GHC_Driver_Session (HasDynFlags (..))\nimport GHC_Settings_Config (cProjectVersionInt)\n\nimport GHC_Types_SourceError (handleSourceError)\n\nimport GHC_Utils_Outputable (SDoc)\n\n#if MIN_VERSION_ghc(9,6,0)\nimport GHC (getNamePprCtx)\n#else\nimport GHC (getPrintUnqual)\n#endif\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Core.TyCo.Ppr (pprSigmaType)\n#else\nimport GHC (Type)\nimport GHC_Types_TyThing_Ppr (pprTypeForUser)\n#endif\n\n#if MIN_VERSION_ghc(9,2,0)\nimport GHC.Driver.Env (hsc_units)\nimport GHC.Driver.Monad (getSession)\n#endif\n\n-- hspec\nimport Test.Hspec\n\n-- finkel-kernel\nimport Language.Finkel.Builder (Builder)\nimport Language.Finkel.Eval (evalExpr, evalExprType, evalTypeKind)\nimport Language.Finkel.Fnk (Fnk, FnkEnv (..), runFnk)\nimport Language.Finkel.Syntax (parseExpr, parseType)\n\n-- Test internal\nimport TestAux\n\n\nevalFnkTests :: FnkSpec\nevalFnkTests = do\n files <- runIO (getTestFiles \"eval\")\n mapM_ exprTest files\n exprTypeTest\n typeKindTest\n\nexprTest :: FilePath -> FnkSpec\nexprTest file =\n describe file $\n it \"should evaluate to True\" work\n where\n work ftr\n | cProjectVersionInt == \"810\"\n , os == \"mingw32\"\n , takeBaseName file `elem` skipped\n = pendingWith \"Not yet supported\"\n | otherwise\n = do contents <- hGetStringBuffer file\n ret <- runEvalExpr ftr contents\n ret `shouldBe` True\n skipped = [ \"0002-shadowing-macro\"\n , \"0004-unquote-unquote-splice\" ]\n runEvalExpr ftr !buf =\n runFnk (handleSourceError\n (\\se -> printException se >> liftIO (throwIO se))\n (doEval ftr \"\" parseExpr act buf))\n evalFnkEnv\n act = fmap unsafeCoerce# . evalExpr\n\nexprTypeTest :: FnkSpec\nexprTypeTest =\n describe \"type of True\" $\n it \"should be Bool\" $ \\ftr -> do\n ret <- runEvalType ftr \"True\"\n ret `shouldBe` \"Bool\"\n where\n runEvalType ftr str =\n let buf = stringToStringBuffer str\n in runFnk (doEval ftr \"\" parseExpr act buf) evalFnkEnv\n act expr = do\n ty <- evalExprType expr\n pprDocForUser (pprSigmaType ty)\n\ntypeKindTest :: FnkSpec\ntypeKindTest = do\n describe \"kind of Maybe\" $\n it \"should be * -> *\" $ \\ftr -> do\n ret <- runTypeKind ftr \"Maybe\"\n ret `shouldBe` \"* -> *\"\n where\n runTypeKind ftr str =\n let buf = stringToStringBuffer str\n in runFnk (doEval ftr \"\" parseType act buf) evalFnkEnv\n act expr = do\n (_, kind) <- evalTypeKind expr\n pprDocForUser (pprSigmaType kind)\n\ndoEval :: FnkTestResource\n -> String -> Builder a -> (a -> Fnk b) -> StringBuffer -> Fnk b\ndoEval !ftr !label !parser !act !input = do\n ftr_init ftr\n evalWith label parser act input\n\nevalFnkEnv :: FnkEnv\nevalFnkEnv = fnkTestEnv {envContextModules = modules}\n where\n modules = [\"Prelude\", \"Language.Finkel\"]\n\npprDocForUser :: SDoc -> Fnk String\npprDocForUser sdoc = do\n dflags <- getDynFlags\n#if MIN_VERSION_ghc(9,6,0)\n unqual <- getNamePprCtx\n#else\n unqual <- getPrintUnqual\n#endif\n#if MIN_VERSION_ghc(9,2,0)\n unit_state <- hsc_units <$> getSession\n pure (showSDocForUser dflags unit_state unqual sdoc)\n#else\n pure (showSDocForUser dflags unqual sdoc)\n#endif\n\n-- Auxiliary\n\n#if !MIN_VERSION_ghc(9,4,0)\npprSigmaType :: Type -> SDoc\npprSigmaType = pprTypeForUser\n#endif\n" }, { "path": "finkel-kernel/test/ExceptionTest.hs", "content": "module ExceptionTest\n ( exceptionTests\n , exceptionFnkTests\n ) where\n\n-- base\nimport Control.Exception (bracket)\nimport System.Environment (lookupEnv, setEnv)\nimport System.Exit (ExitCode (..))\n\n-- hspec\nimport Test.Hspec\n\n-- -- finkel-kernel\nimport Language.Finkel.Fnk (initializeLibDirFromGhc)\n\n-- Internal\nimport TestAux\n\nexceptionTests :: Spec\nexceptionTests = beforeAll getFnkTestResource exceptionFnkTests\n\nexceptionFnkTests :: FnkSpec\nexceptionFnkTests = do\n noGhcTest\n compileErrorTests\n\nnoGhcTest :: FnkSpec\nnoGhcTest =\n describe \"No ghc found in current PATH\" $\n it \"should fail with non-0 exit code\" $ \\_ -> do\n let act = withEmptyPATH initializeLibDirFromGhc\n act `shouldThrow` exitFailureSelector\n\ncompileErrorTests :: FnkSpec\ncompileErrorTests = runIO (getTestFiles \"exception\") >>= mapM_ mkTest\n\nmkTest :: FilePath -> FnkSpec\nmkTest path =\n describe path $\n it \"should not compile successfully\" $ \\ftr ->\n let go = ftr_main ftr [\"-fno-code\", path]\n in go `shouldThrow` exitFailureSelector\n\nexitFailureSelector :: ExitCode -> Bool\nexitFailureSelector (ExitFailure _) = True\nexitFailureSelector _ = False\n\nwithEmptyPATH :: IO a -> IO a\nwithEmptyPATH = bracket acquire restore . const\n where\n acquire = do\n mb_path <- lookupEnv \"PATH\"\n case mb_path of\n Nothing -> return \"\"\n Just path -> setEnv \"PATH\" \"/\" >> return path\n restore = setEnv \"PATH\"\n" }, { "path": "finkel-kernel/test/FnkTest.hs", "content": "{-# LANGUAGE CPP #-}\n\nmodule FnkTest where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Exception (throwIO)\nimport qualified Control.Monad.Fail as MonadFail\nimport Control.Monad.IO.Class\nimport Data.Maybe (fromMaybe, isNothing)\n\n-- ghc\nimport GHC_Data_FastString (fsLit)\nimport GHC_Data_StringBuffer (stringToStringBuffer)\nimport GHC_Types_SrcLoc (GenLocated (..))\nimport GHC_Unit_Module (moduleNameString)\nimport GHC_Unit_Module_ModSummary (ms_mod_name)\n\n-- exceptions\nimport Control.Monad.Catch (bracket)\n\n-- hspec\nimport Test.Hspec\nimport Test.QuickCheck\n\n-- Internal\nimport Language.Finkel.Builder\nimport Language.Finkel.Exception\nimport Language.Finkel.Expand\nimport Language.Finkel.Fnk\nimport Language.Finkel.Form\nimport Language.Finkel.Homoiconic\nimport Language.Finkel.Make\nimport Language.Finkel.Reader\nimport Language.Finkel.SpecialForms\nimport Language.Finkel.Syntax\n\nimport TestAux\n\nfnkTests :: Spec\nfnkTests = do\n exceptionTest\n fromGhcTest\n gensymTest\n expandTest\n envTest\n\nexceptionTest :: Spec\nexceptionTest = do\n\n let e_foo :: FinkelException\n e_foo = FinkelException \"foo\"\n\n test_e_foo :: FinkelException -> Bool\n test_e_foo e = case e of\n FinkelException msg -> msg == \"foo\"\n _ -> False\n\n fnkSrcErrorSelector :: FinkelException -> Bool\n fnkSrcErrorSelector (FinkelSrcError {}) = True\n fnkSrcErrorSelector _ = False\n\n run :: Fnk a -> IO a\n run = flip runFnk fnkTestEnv\n\n describe \"Eq and Show instance of FinkelException\" $ do\n it \"should return True when comparing with itself\" $\n property (\\str -> let e1 = FinkelException str\n e2 = FinkelException str\n in e1 == e2 && show e1 == show e2)\n it \"should return False when message is different\" $\n FinkelException \"foo\" /= FinkelException \"bar\" `shouldBe` True\n\n describe \"Eq and Show instance of SyntaxError\" $ do\n it \"should return True when cmparing with itself\" $\n property (\\str -> let e1 = SyntaxError nil str\n e2 = SyntaxError nil str\n in e1 == e2 && show e1 == show e2)\n it \"should return False when message is different\" $\n let e1 = SyntaxError nil \"foo\"\n e2 = SyntaxError nil \"bar\"\n in e1 `shouldNotBe` e2\n\n describe \"Code and message in SyntaxError\" $ do\n let se = SyntaxError nil \"message\"\n it \"should have given code\" $\n syntaxErrCode se `shouldBe` nil\n it \"should have given message\" $\n syntaxErrMsg se `shouldBe` \"message\"\n\n describe \"Applicative instance of Fnk\" $\n it \"should return 42\" $ do\n let act = (*) <$> pure 6 <*> pure 7\n run act `shouldReturn` (42 :: Int)\n\n describe \"ExceptionMonad instance of Fnk\" $ do\n it \"should return 42 with action in bracket\" $ do\n let act = bracket (return 21) return (\\x -> return (x * 2))\n run act `shouldReturn` (42 :: Int)\n\n it \"should catch exception from throwM\" $ do\n let act = throwM e `catch` handler\n e = FinkelException \"\"\n handler :: FinkelException -> Fnk Int\n handler _ = return 42\n run act `shouldReturn` 42\n\n it \"masks an exception\" $ do\n let act = mask (\\restore -> restore (throwM e_foo))\n run act `shouldThrow` test_e_foo\n\n it \"masks an exception (uninterruptible)\" $ do\n let act = uninterruptibleMask (\\restore -> restore (throwM e_foo))\n run act `shouldThrow` test_e_foo\n\n describe \"Handling FinkelException\" $\n it \"should return 42\" $ do\n let act = handleFinkelException\n (\\_ -> return (42 :: Int))\n (liftIO (throwIO (FinkelException \"\")))\n run act `shouldReturn` 42\n\n describe \"running Fnk action containing `failFnk'\" $\n it \"should throw FinkelException\" $ do\n let act = failFnk \"foo\"\n run act `shouldThrow` test_e_foo\n\n describe \"running Fnk action containing `fail'\" $\n it \"should throw FinkelException\" $ do\n let act = MonadFail.fail \"foo\"\n run act `shouldThrow` test_e_foo\n\n describe \"running Fnk action containing FinkelSrcError\" $\n it \"should throw SourceError\" $ do\n let act = finkelSrcError nil \"foo\"\n run act `shouldThrow` fnkSrcErrorSelector\n\n describe \"applying macroNames to specialForms\" $\n it \"should not return name of special forms\" $ do\n let ns = macroNames specialForms\n ns `shouldBe` []\n\n describe \"running buildHsSyn action\" $\n it \"should throw FinkelSrcError\" $ do\n let form = \"(:: foo ->) (= foo 100)\"\n form' = stringToStringBuffer form\n build = do (form'', _) <- parseSexprs Nothing form'\n buildHsSyn parseDecls form''\n run build `shouldThrow` fnkSrcErrorSelector\n\nfromGhcTest :: Spec\nfromGhcTest =\n describe \"converting Ghc to Fnk\" $\n it \"should return the returned value in Ghc\" $ do\n let v :: Int\n v = 42\n x <- runFnk (fromGhc (return v)) fnkTestEnv\n x `shouldBe` v\n\ngensymTest :: Spec\ngensymTest =\n describe \"generating two gensyms\" $\n it \"should not be equal\" $ do\n let gen _ = do\n g1 <- gensym\n g2 <- gensym\n return $ toCode [g1, g2]\n f = macroFunction (Macro gen)\n env = cleanFnkEnv\n ret <- runFnk (f nil) env\n case ret of\n LForm (L _ (HsList [g1, g2])) -> g1 `shouldNotBe` g2\n _ -> expectationFailure \"macro expansion failed\"\n\nexpandTest :: Spec\nexpandTest = do\n let expand1_fn code =\n runFnk (macroFunction (Macro expand1) code) env\n env = cleanFnkEnv\n describe \"expand-1 of nil\" $\n it \"should return nil\" $ do\n ret <- expand1_fn nil\n ret `shouldBe` nil\n describe \"expand-1 of (:quote 42.0)\" $\n it \"should return non-empty form\" $ do\n let form = toCode (List [toCode $ aSymbol \":quote\"\n ,toCode $ aFractional (42.0 :: Double)])\n ret <- expand1_fn form\n length ret `shouldSatisfy` (>= 1)\n describe \"expand-1 of non-macro\" $\n it \"should return the original form\" $ do\n let form = toCode (List [toCode $ aSymbol \"show\"\n ,toCode $ aFractional (42 :: Double)])\n ret <- expand1_fn form\n ret `shouldBe` form\n describe \"expanding with macroFunction\" $\n it \"should return empty form\" $ do\n let mb_qt = lookupMacro (fsLit \":quasiquote\") env\n qt = fromMaybe (error \"macro not found\") mb_qt\n s x = LForm (genSrc (Atom (ASymbol (fsLit x))))\n li xs = LForm (genSrc (List xs))\n form0 = li [s \":quasiquote\", s \"a\"]\n form1 = li [s \":quote\", s \"a\"]\n ret <- runFnk (macroFunction qt form0) env\n ret `shouldBe` form1\n\nenvTest :: Spec\nenvTest = do\n describe \"deleting macro from specialForms\" $\n it \"should delete macro with matching name\" $ do\n let m0 = specialForms\n m1 = deleteMacro (fsLit \":with-macro\") m0\n e1 = emptyFnkEnv {envMacros = m1}\n mb_let_macro = lookupMacro (fsLit \":with-macro\") e1\n isNothing mb_let_macro `shouldBe` True\n\n describe \"deleting macro from emptyMacros\" $\n it \"should delete nothing\" $ do\n let m0 = emptyEnvMacros\n m1 = deleteMacro (fsLit \":no-such-macro\") m0\n n0 = macroNames m0\n n1 = macroNames m1\n n0 `shouldBe` n1\n\n describe \"merging macros with itself\" $\n it \"should not change\" $ do\n let m0 = specialForms\n m1 = mergeMacros specialForms specialForms\n n0 = macroNames m0\n n1 = macroNames m1\n n0 `shouldBe` n1\n\n describe \"showing special forms\" $\n it \"should be \" $ do\n let e1 = emptyFnkEnv {envMacros = specialForms}\n mb_let_macro = lookupMacro (fsLit \":eval-when-compile\") e1\n let_macro = fromMaybe (error \"not found\") mb_let_macro\n show let_macro `shouldBe` \"\"\n\n describe \"empty finkel env\" $ do\n it \"should have empty envMacros\" $\n macroNames (envMacros emptyFnkEnv) `shouldBe` []\n it \"should have empty envDefaultMacros\" $\n macroNames (envDefaultMacros emptyFnkEnv) `shouldBe` []\n it \"should set verbosity to 1\" $\n envVerbosity emptyFnkEnv `shouldBe` 1\n it \"should not have required module names\" $\n map (moduleNameString . ms_mod_name) (envRequiredHomeModules emptyFnkEnv)\n `shouldBe` []\n\nemptyForm :: Code\nemptyForm =\n let bgn = LForm (genSrc (Atom (ASymbol (fsLit \":begin\"))))\n in LForm (genSrc (List [bgn]))\n\ncleanFnkEnv :: FnkEnv\ncleanFnkEnv = fnkTestEnv {envDefaultMacros = emptyEnvMacros}\n" }, { "path": "finkel-kernel/test/FormTest.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE DeriveGeneric #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TypeApplications #-}\n-- | Tests for forms.\nmodule FormTest where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Applicative (Alternative (..))\nimport Data.Char (toUpper)\nimport Data.Complex\nimport Data.Data\nimport qualified Data.Fixed as Fixed\nimport Data.Functor.Compose\nimport Data.Functor.Const\nimport Data.Functor.Identity\nimport qualified Data.Functor.Product as Product\nimport qualified Data.Functor.Sum as Sum\nimport Data.Int\nimport Data.List (isPrefixOf, isSubsequenceOf)\nimport Data.List.NonEmpty (NonEmpty (..))\nimport Data.Monoid\nimport Data.Ratio\nimport qualified Data.Semigroup as Semigroup\nimport Data.Version\nimport Data.Word\nimport GHC.Generics (Generic (..))\nimport Numeric.Natural\nimport Text.Show.Functions ()\n\n#if !MIN_VERSION_ghc(8,4,0)\nimport Data.Monoid ((<>))\n#endif\n\n-- binary\nimport Data.Binary (decode, encode)\n\n-- deepseq\nimport Control.DeepSeq\n\n-- ghc\nimport GHC_Data_FastString (fsLit, unpackFS)\nimport GHC_Data_StringBuffer (stringToStringBuffer)\nimport GHC_Driver_Session (HasDynFlags (..))\nimport GHC_Types_SrcLoc (GenLocated (..), SrcSpan (..),\n noSrcSpan)\nimport GHC_Driver_Ppr (showPpr)\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Types_SrcLoc (UnhelpfulSpanReason (..))\n#endif\n\n-- transformers\nimport Control.Monad.Trans.State\n\n-- hspec\nimport Test.Hspec\n\n-- QuickCheck\nimport Test.QuickCheck\n\n-- finkel-kernel\nimport Language.Finkel.Fnk\nimport Language.Finkel.Form\nimport Language.Finkel.Homoiconic\nimport qualified Language.Finkel.Homoiconic as Homoiconic\nimport Language.Finkel.Lexer\nimport Language.Finkel.Reader\nimport Language.Finkel.SpecialForms\n\n-- Internal\nimport Orphan ()\n\nformTests :: Spec\nformTests = do\n mapM_ readShow\n [ \"foo\", \"#'a\", \"12345\", \"6.789\", \"0.001\"\n , \"(foo bar buzz)\"\n , \"(#'a #'\\\\SP #'\\\\ \\\"bcd\\\")\"\n , \"[#'\\\\BEL #'\\\\BS #'\\\\FF #'\\\\LF #'\\\\CR #'\\\\HT #'\\\\VT]\"\n , \"[()]\"\n , \"(1 -2 345 6.789 0.001)\" ]\n\n readUnicodeStringProp\n readShowFormProp\n\n dataInstanceTests\n qFunctionTests\n\n fracTest 1.23\n fracTest (-1.23)\n fracTest 0\n fracTest 1e-9\n\n showTest\n pprTest\n functorTest \"(a \\\"foo\\\" \\\\x [True False])\"\n applicativeTest\n monadTest\n foldableTest\n traversableTest\n binaryTest\n\n eqTest \"(a \\\"bcd\\\" \\\\e [f g] (h i))\"\n eqPropTest\n\n locationTest Nothing \"foo\"\n locationTest (Just \"locationTest\") \"foo\"\n asLocOfTest\n\n lengthTest 3 \"(a b c)\"\n lengthTest 5 \"(a (b (c)) d e)\"\n lengthTest 1 \"()\"\n lengthTest 8 \"[a (b (c d e) [f g]) h]\"\n lengthTest 1 \"foo\"\n\n homoiconicTests\n rnfTest\n listTest\n numTest\n fractionalTest\n monoidTest\n alternativeTest\n\n fromCodeTest\n fromCodeErrorTest\n\n dataToCodeTest\n genericHomoiconicTest\n\n unquoteSpliceTest\n\nreadShow :: String -> Spec\nreadShow str =\n describe (\"read and show `\" ++ str ++ \"'\") $\n it \"should match the input\" $\n show (parseE str) `shouldBe` str\n\nreadUnicodeStringProp :: Spec\nreadUnicodeStringProp =\n describe \"read and show unicode string\" $\n it \"should return itself\" $\n property (\\uni ->\n let str = getUnicodeString uni\n in parseE (show str) == toCode (aString NoSourceText str))\n\nreadShowFormProp :: Spec\nreadShowFormProp =\n describe \"read and show form property\" $\n it \"should match the input\" $\n property (\\form ->\n form == form && parseE (show form) `eqForm` form)\n\ndataInstanceTests :: Spec\ndataInstanceTests = do\n let gfoldl_self atom =\n gfoldl (\\mb_f x -> case mb_f of\n Just f -> pure (f x)\n _ -> error \"should not happen\")\n return atom\n t_gfoldl_self x = gfoldl_self x `shouldBe` Just x\n t_show_constr x y = show (toConstr x) `shouldBe` y\n describe \"Data instance for Atom\" $ do\n let aunit = AUnit\n asym = ASymbol (fsLit \"foo\")\n achar = AChar NoSourceText 'a'\n astr = AString NoSourceText (fsLit \"string\")\n aint = AInteger (mkIntegralLit (42 :: Int))\n afrac = aFractional (1.23 :: Double)\n it \"should return Just self with simple gfoldl\" $ do\n t_gfoldl_self aunit\n t_gfoldl_self asym\n t_gfoldl_self achar\n t_gfoldl_self astr\n t_gfoldl_self aint\n t_gfoldl_self afrac\n it \"should show itself with toConstr\" $ do\n t_show_constr aunit \"AUnit\"\n t_show_constr asym \"ASymbol\"\n t_show_constr achar \"AChar\"\n t_show_constr astr \"AString\"\n t_show_constr aint \"AInteger\"\n t_show_constr afrac \"AFractional\"\n it \"should return AUnit with simple gunfold\" $ do\n gunfold (const Nothing) Just (toConstr AUnit) `shouldBe` Just AUnit\n it \"should return AUnit constr\" $ do\n let dtype = dataTypeOf AUnit\n cnstr = toConstr AUnit\n readConstr dtype \"AUnit\" `shouldBe` Just cnstr\n describe \"Data instance for Form\" $ do\n let fatom = Atom AUnit\n qc c = qChar c \"\" 0 0 0 0\n flist = List [qc 'a', qc 'b']\n fhslist = HsList [qc 'a', qc 'b']\n ftend :: Form Atom\n ftend = TEnd\n it \"should return Just self with simple gfoldl\" $ do\n t_gfoldl_self fatom\n t_gfoldl_self flist\n t_gfoldl_self fhslist\n t_gfoldl_self ftend\n it \"should show itself with toConstr\" $ do\n t_show_constr fatom \"Atom\"\n t_show_constr flist \"List\"\n t_show_constr fhslist \"HsList\"\n t_show_constr ftend \"TEnd\"\n it \"should return TEnd with simple gunfold\" $\n gunfold (const Nothing) Just (toConstr ftend) `shouldBe` Just ftend\n it \"should return Atom constr\" $ do\n let dtype = dataTypeOf fatom\n cnstr = toConstr fatom\n readConstr dtype \"Atom\" `shouldBe` Just cnstr\n it \"should return same result from dataCast1 and gcast1\" $ do\n (dataCast1 [TEnd] :: Maybe [Form Atom]) `shouldBe` Just [TEnd]\n describe \"Data instance for LForm\" $ do\n let qc = qChar 'x' \"\" 0 0 0 0\n d1, d2, d3 :: Data a => a\n d1 = fromConstr (toConstr noSrcSpan)\n d2 = fromConstrB (fromConstr (toConstr AUnit))\n (toConstr (Atom AUnit))\n d3 = evalState m 0\n where\n m = fromConstrM act (toConstr (L noSrcSpan (Atom AUnit)))\n act :: Data d => State Int d\n act = do\n i <- get\n modify succ\n case i of\n 0 -> return d1\n 1 -> return d2\n _ -> error (\"index \" ++ show i ++ \" for LForm\")\n d4 = fromConstrB d3 (toConstr qu)\n gc1 :: Data a => Maybe [LForm a]\n gc1 =\n let a :: Data a => a\n a = fromConstr (toConstr AUnit)\n in dataCast1 [LForm (L noSrcSpan (Atom a))]\n qu = qUnit \"\" 0 0 0 0\n it \"should return Just self with simple gfoldl\" $ do\n t_gfoldl_self qc\n it \"should show itself with toConstr\" $ do\n t_show_constr qc \"LForm\"\n it \"should return LForm constr\" $ do\n let dtype = dataTypeOf qc\n cnstr = toConstr qc\n readConstr dtype \"LForm\" `shouldBe` Just cnstr\n it \"should construct qUnit from constructors\" $ do\n d4 `shouldBe` qu\n it \"should return qUnit from dataCast1\" $\n gc1 `shouldBe` Just [qu]\n\nqFunctionTests :: Spec\nqFunctionTests = do\n describe \"qSymbol function\" $\n it \"should equal to quoted symbol\" $\n qSymbol \"foo\" \"\" 0 0 0 0 `shouldBe` toCode (ASymbol (fsLit \"foo\"))\n describe \"qChar function\" $\n it \"should equal to quoted char\" $\n qChar 'x' \"\" 0 0 0 0 `shouldBe` toCode 'x'\n describe \"qString function\" $\n it \"should equal to quoted string\" $\n qString \"foo\" \"\" 0 0 0 0 `shouldBe` toCode \"foo\"\n describe \"qInteger function\" $\n it \"should equal to quoted integer\" $\n qInteger 42 \"\" 0 0 0 0 `shouldBe` toCode (42 :: Integer)\n describe \"qFractional function\" $\n it \"should equal to quoted fractional\" $\n qFractional (1.23 :: Double) \"\" 0 0 0 0\n `shouldBe` toCode (1.23 :: Double)\n describe \"qUnit function\" $\n it \"should equal to quoted unit\" $\n qUnit \"\" 0 0 0 0 `shouldBe` toCode ()\n\n let qc x = qChar x \"\" 0 0 0 0\n describe \"qList function\" $\n it \"should equal to quoted codes\" $\n let xs = [qc 'a', qc 'b']\n in qList xs \"\" 0 0 0 0 `shouldBe` toCode (List xs)\n describe \"qHsList function\" $\n it \"should equal to quoted haskell list\" $\n let xs = [qc 'a', qc 'b']\n in qHsList xs \"\" 0 0 0 0 `shouldBe` toCode (HsList xs)\n\nfracTest :: Double -> Spec\nfracTest x =\n describe (\"read and show a fractional number `\" ++ show x ++ \"'\") $\n it \"should match the input\" $\n show (aFractional x) `shouldBe` show x\n\nshowTest :: Spec\nshowTest =\n describe \"showing TEnd\" $\n it \"should be \\\"TEnd\\\"\" $\n show (TEnd :: Form Atom) `shouldBe` \"TEnd\"\n\nfunctorTest :: String -> Spec\nfunctorTest str = do\n describe (\"Functor instance of Code `\" ++ str ++ \"'\") $\n it \"should obey the Functor law\" $\n let c = parseE str\n in fmap id c `shouldBe` c\n describe \"fmap to TEnd\" $\n it \"should be TEnd\" $ do\n let te :: Form Atom\n te = TEnd\n f :: Atom -> Atom\n f _ = AUnit\n fmap f te `shouldBe` te\n\napplicativeTest :: Spec\napplicativeTest = do\n let atom_a = AChar NoSourceText 'a'\n char_a = toCode atom_a\n al2 = qList [char_a, char_a] \"\" 0 0 0 0\n ahl2 = qHsList [char_a, char_a] \"\" 0 0 0 0\n unit = toCode ()\n f1 a b = (a,b)\n a_pair = lf (Atom (atom_a, atom_a))\n a_pair_ls = mk_a_pairs List 2 -- lf (List [a_pair, a_pair])\n a_pair_hls = mk_a_pairs HsList 2 -- lf (HsList [a_pair, a_pair])\n mk_a_pairs f n = lf (f (replicate n a_pair))\n lf = LForm . genSrc\n tend :: Form Atom\n tend = TEnd\n\n describe \"pure\" $\n it \"should result in atom\" $\n toCode (pure AUnit :: Form Atom) `shouldBe` unit\n\n describe \"<*>\" $ do\n it \"should apply f1 to atom and atom\" $\n f1 <$> char_a <*> char_a `shouldBe` a_pair\n it \"should apply f1 to atom and list\" $\n f1 <$> char_a <*> al2 `shouldBe` a_pair_ls\n it \"should apply f1 to atom and hslist\" $\n f1 <$> char_a <*> ahl2 `shouldBe` a_pair_hls\n it \"should aply f1 to list and atom\" $\n f1 <$> al2 <*> char_a `shouldBe` a_pair_ls\n it \"should apply f1 to list and list\" $\n f1 <$> al2 <*> al2 `shouldBe` mk_a_pairs List 4\n it \"should apply f1 to list and hslist\" $\n f1 <$> al2 <*> ahl2 `shouldBe` mk_a_pairs List 4\n it \"should aply f1 to list and atom\" $\n f1 <$> ahl2 <*> char_a `shouldBe` a_pair_hls\n it \"should apply f1 to list and list\" $\n f1 <$> ahl2 <*> al2 `shouldBe` mk_a_pairs HsList 4\n it \"should apply f1 to list and list\" $\n f1 <$> ahl2 <*> ahl2 `shouldBe` mk_a_pairs HsList 4\n it \"should result in TEnd\" $ do\n f1 <$> char_a <*> lf tend `shouldBe` lf TEnd\n f1 <$> lf tend <*> char_a `shouldBe` lf TEnd\n\nmonadTest :: Spec\nmonadTest = do\n let f1 x = case x of\n AChar st c -> AChar st (toUpper c)\n _ -> x\n qh x = qHsList x \"\" 0 0 0 0\n ql x = qList x \"\" 0 0 0 0\n describe \"bind\" $ do\n it \"should apply f1 to atom\" $\n do {x <- toCode 'x'; return (f1 x)} `shouldBe` toCode 'X'\n it \"should apply f1 to list\" $\n do {x <- ql [toCode 'x', toCode 'x']; return (f1 x)} `shouldBe`\n ql [toCode 'X', toCode 'X']\n it \"should apply f1 to hslist\" $\n do {x <- qh [toCode 'x',toCode 'x']; return (f1 x)} `shouldBe`\n qh [toCode 'X', toCode 'X']\n it \"should apply f1 to TEnd\" $\n do {x <- toCode (TEnd :: Form Atom); return (f1 x)} `shouldBe`\n toCode (TEnd :: Form Atom)\n\nfoldableTest :: Spec\nfoldableTest = do\n let fsum = foldr (\\x acc -> case x of\n AInteger il -> acc + il_value il\n _ -> acc)\n 0\n describe \"taking sum of 1 to 10 with foldr\" $ do\n let str1 = \"(1 2 3 4 5 6 7 8 9 10)\"\n it (\"should be 55 for \" ++ str1) $\n fsum (parseE str1) `shouldBe` 55\n it \"should be 0 for TEnd\" $ do\n#if MIN_VERSION_ghc(9,0,0)\n let sp = UnhelpfulSpan (UnhelpfulOther (fsLit \"\"))\n#else\n let sp = UnhelpfulSpan (fsLit \"\")\n#endif\n fsum (LForm (L sp TEnd)) `shouldBe` 0\n describe \"length of nil\" $\n it \"should be 0\" $\n length nil `shouldBe` 0\n\ntraversableTest :: Spec\ntraversableTest = do\n let f atom = case atom of\n ASymbol sym | '$' : _ <- unpackFS sym\n -> return (aSymbol \"_\")\n _ -> return atom\n describe \"replacing symbol with mapM\" $ do\n let str1 = \"(a $b c [$d e] [f g $h] ($i $j))\"\n str2 = \"(a _ c [ _ e] [f g _] ( _ _))\"\n it \"should replace $.* with _\" $ do\n let form1 = parseE str1\n form2 = parseE str2\n mapM f form1 `shouldBe` Just form2\n describe \"traversing TEnd\" $\n it \"should be Just TEnd\" $\n mapM f TEnd `shouldBe` Just TEnd\n\nbinaryTest :: Spec\nbinaryTest = do\n describe \"Instances of Get and Put from binary\" $ do\n it \"should return the original value\" $ do\n let to_from_bin :: Code -> Bool\n to_from_bin x = decode (encode x) == x\n property to_from_bin\n\neqTest :: String -> Spec\neqTest str =\n describe \"parsing same string twice\" $\n it \"should result in equal codes\" $\n let c1 = parseE str\n c2 = parseE str\n in c1 `shouldBe` c2\n\neqPropTest :: Spec\neqPropTest = do\n describe \"Eq instance for LForm\" $\n it \"should ignore location information\" $ do\n let g :: Code -> Bool\n g x@(LForm (L _ body)) = x == LForm (L sp body)\n#if MIN_VERSION_ghc(9,0,0)\n sp = UnhelpfulSpan (UnhelpfulOther (fsLit \"\"))\n#else\n sp = UnhelpfulSpan (fsLit \"\")\n#endif\n property g\n describe \"comparing TEnd with TEnd\" $\n it \"should be True\" $\n (TEnd :: Form Atom) `shouldBe` (TEnd :: Form Atom)\n\nlocationTest :: Maybe FilePath -> String -> Spec\nlocationTest mb_path str =\n describe (\"location of `\" ++ str ++ \"'\") $\n it (case mb_path of\n Just path -> \"should contain `\" ++ path ++ \"'\"\n Nothing -> \"should be unhelpful\") $ do\n let c = parseE' mb_path str\n l = showLoc c\n case mb_path of\n Just path -> (path `isPrefixOf` l) `shouldBe` True\n Nothing -> (\"anon\" `isSubsequenceOf` l) `shouldBe` True\n\nasLocOfTest :: Spec\nasLocOfTest =\n describe (\"apply asLocOf to code\") $ do\n it \"should return the value of first arg\" $\n property (\\ a b -> asLocOf a b == a)\n it \"should use the location of second arg\" $\n property (\\ a b -> case (asLocOf a b, b) of\n (LForm (L l1 _), LForm (L l2 _)) -> l1 == l2)\n\nlengthTest :: Int -> String -> Spec\nlengthTest n str =\n describe (\"length of \" ++ str) $\n it (\"should be \" ++ show n) $\n length (parseE str) `shouldBe` n\n\nhomoiconicTests :: Spec\nhomoiconicTests = do\n let t x = describe (\"to/from code \" ++ show x) $\n it \"shoult match the input\" $\n case fromCode (toCode x) of\n Just y -> y `shouldBe` x\n Nothing -> error (\"got Nothing with \" ++ show x)\n t (aIntegral (42 :: Int))\n t ()\n t 'x'\n t \"string\"\n t (42 :: Int)\n t (42 :: Int8)\n t (42 :: Int16)\n t (42 :: Int32)\n t (42 :: Int64)\n t (42 :: Integer)\n t (42 :: Word)\n t (42 :: Word8)\n t (42 :: Word16)\n t (42 :: Word32)\n t (42 :: Word64)\n t (0.123456789 :: Double)\n t (1.234 :: Float)\n t ([1,2,3] :: [Int])\n t (Fixed.MkFixed 2 :: Fixed.Pico)\n t (Identity 'a')\n t (1 :+ 2 :: Complex Int)\n t (Compose (Just (Just 'a')))\n t (Const True :: Const Bool Char)\n t (Product.Pair (Just 'a') (Just 'b'))\n t [Sum.InL (Just 'a'), Sum.InR (Right 'b'), Sum.InR (Left \"foo\")]\n t ('a' :| ['b', 'c', 'd'])\n t (All False)\n t (Alt (Just True))\n t (Any False)\n t (Dual 'x')\n t (First (Just 'a'))\n t (Last (Just 'a'))\n t (Product (42 :: Int))\n t (Sum (42 :: Int))\n t (Proxy :: Proxy ())\n t (Version [1,2,3] [\"foo\", \"bar\"])\n t (1 % 3 :: Rational)\n t (Semigroup.Arg 'x' False)\n t (Semigroup.First 'a')\n t (Semigroup.Last 'z')\n t (Semigroup.Max (42 :: Int))\n t (Semigroup.Min (42 :: Int))\n#if !MIN_VERSION_ghc(9,0,0)\n t (Semigroup.Option (Just \"foo\"))\n#endif\n t (Semigroup.WrapMonoid True)\n t (42 :: Natural)\n t (Atom (aIntegral (42 :: Int)))\n t (LForm (genSrc (Atom (aIntegral (42 :: Int)))))\n t [True, False]\n t [EQ, LT, GT]\n t (Just (42 :: Int))\n t [Right True, Left \"foo\"]\n t (Just 'x', [Right False, Left \"foo\"])\n t (Just 'x', [Right False, Left \"foo\"], EQ)\n t (Just 'x', [Right False, Left \"foo\"], EQ, 42::Int)\n t (Just 'x', [Right False, Left \"foo\"], EQ, 42::Int ,False)\n t (Just 'x', [Right False, Left \"foo\"], EQ, 42::Int\n ,False, Just [Right (Just EQ), Left (3.1 :: Double)])\n\nrnfTest :: Spec\nrnfTest = do\n describe \"rnf of arbitrary form\" $\n it \"should return ()\" $\n property (rnf :: Code -> ())\n describe \"rnf of TEnd\" $\n it \"should return ()\" $\n rnf (TEnd :: Form Atom) `shouldBe` ()\n\nlistTest :: Spec\nlistTest =\n describe \"list from arbitrary form applied to arbitrary function\" $\n it \"should be a list\" $ do\n let f :: (Code -> Code) -> Code -> Bool\n f g form = isListL (toListL (g form))\n property f\n\ncInt :: Int -> Code\ncInt = toCode\n\ncDouble :: Double -> Code\ncDouble = toCode\n\nnumTest :: Spec\nnumTest =\n describe \"Num instance for Code\" $ do\n it \"should evaluate +\" $ do\n cInt 2 + cInt 40 `shouldBe` 42\n cInt 2 + cDouble 40 `shouldBe` 42.0\n cDouble 2 + cInt 40 `shouldBe` 42.0\n cDouble 2.0 + cDouble 40.0 `shouldBe` 42.0\n it \"should evaluate * for AInteger\" $ do\n cInt 6 * cInt 7 `shouldBe` 42\n cDouble 6 * cDouble 7 `shouldBe` 42.0\n it \"should evalue - for AInteger\" $ do\n cInt 50 - cInt 8 `shouldBe` 42\n cDouble 50 - cDouble 8 `shouldBe` 42.0\n it \"should evaluate abs\" $ do\n abs (cInt (-42)) `shouldBe` 42\n abs (cDouble (-42)) `shouldBe` 42.0\n it \"should evaluate signum\" $ do\n signum (cInt (-42)) `shouldBe` -1\n signum (cDouble (-42)) `shouldBe` -1.0\n it \"should evaluate fromInteger\" $\n fromInteger 42 `shouldBe` cInt 42\n it \"should result to nil with invalid values\" $ do\n 3 + toCode 'a' `shouldBe` nil\n signum (toCode 'a') `shouldBe` nil\n\nfractionalTest :: Spec\nfractionalTest =\n describe \"Fractional instance for Code\" $ do\n it \"should evaluate /\" $ do\n cInt 84 / cInt 2 `shouldBe` 42.0\n cDouble 84.0 / cDouble 2.0 `shouldBe` 42.0\n it \"should evaluate recip\" $ do\n recip (cInt 4) `shouldBe` 0.25\n recip (cDouble 4.0) `shouldBe` 0.25\n\nmonoidTest :: Spec\nmonoidTest = do\n let a = toCode 'a'\n b = toCode 'b'\n lst = toCode (List [a,b])\n hslst = toCode (HsList [a,b])\n describe \"Atom <> XXX\" $ do\n it \"should result in '(a b)\" $\n a <> b `shouldBe` lst\n it \"should result in '(a a b)\" $\n a <> lst `shouldBe` toCode (List [a,a,b])\n it \"should result in '(a a b)\" $\n a <> hslst `shouldBe` toCode (List [a,a,b])\n describe \"List <> XXX\" $ do\n it \"should result in '(a b a)\" $\n lst <> a `shouldBe` toCode (List [a,b,a])\n it \"should result in '(a b a b)\" $\n lst <> lst `shouldBe` toCode (List [a,b,a,b])\n it \"should result in '(a b a b)\" $\n lst <> hslst `shouldBe` toCode (List [a,b,a,b])\n describe \"HsList <> XXX\" $ do\n it \"should result in '(a b a)\" $\n hslst <> a `shouldBe` toCode (List [a,b,a])\n it \"should result in '(a b a b)\" $\n hslst <> lst `shouldBe` toCode (List [a,b,a,b])\n it \"should result in '(a b a b)\" $\n hslst <> hslst `shouldBe` toCode (List [a,b,a,b])\n describe \"TEnd\" $ do\n it \"should result in non-TEnd\" $ do\n let at = Atom True\n at <> TEnd `shouldBe` at\n TEnd <> at `shouldBe` at\n describe \"mempty\" $ do\n it \"should be empty list\" $\n mempty `shouldBe` (List [] :: Form Atom)\n it \"should be nil\" $\n mempty `shouldBe` nil\n\nalternativeTest :: Spec\nalternativeTest =\n describe \"Alternative\" $ do\n describe \"empty\" $ do\n it \"should be nil for Code\" $\n empty `shouldBe` nil\n it \"should be empty form for Form\" $\n empty `shouldBe` (mempty :: Form Atom)\n describe \"<|>\" $ do\n let a = toCode 'a'\n b = toCode 'b'\n c = toCode 'c'\n it \"should append elements for Code\" $\n let ab = toCode (List [a,b])\n cb = toCode (List [c,b])\n in ab <|> cb `shouldBe` toCode (List [a,b,c,b])\n it \"should append elements for Form Atom\" $\n let ab = List [a,b]\n cb = List [c,b]\n in ab <|> cb `shouldBe` List [a,b,c,b]\n\ndata Foo = Foo deriving (Eq, Show)\n\ninstance Homoiconic Foo where\n toCode foo = toCode (aSymbol (show foo))\n parseCode _ = Homoiconic.Failure \"Foo\"\n\nfromCodeTest :: Spec\nfromCodeTest = do\n describe \"default toCode implementation\" $\n it \"should return Nothing\" $\n (fromCode nil :: Maybe Foo) `shouldBe` Nothing\n\n describe \"getting Nothing from fromCode\" $ do\n let ng title x = it title $ x `shouldBe` Nothing\n q x = qSymbol x \"\" 0 0 0 0\n foo = q \"foo\"\n foo1 = qList [q \"Foo\", q \"a\"] \"\" 0 0 0 0\n foo2 = qList [q \"Foo\", q \"a\", q \"b\"] \"\" 0 0 0 0\n\n it \"should result to Nothing with explicit Nothing\" $ do\n fromCode (q \"Nothing\") `shouldBe` (Just Nothing :: Maybe (Maybe ()))\n toCode (Nothing :: Maybe ()) `shouldBe` q \"Nothing\"\n\n ng \"()\" (fromCode foo :: Maybe ())\n ng \"Int\" (fromCode foo :: Maybe Int)\n ng \"Char\" (fromCode nil :: Maybe Char)\n ng \"[Int]\" (fromCode nil :: Maybe [Int])\n ng \"[Char]\" (fromCode foo :: Maybe [Char])\n ng \"Bool\" (fromCode foo :: Maybe Bool)\n ng \"Ordering\" (fromCode foo :: Maybe Ordering)\n ng \"Maybe ()\" (fromCode foo1 :: Maybe (Maybe ()))\n ng \"Either String ()\" (fromCode foo1 :: Maybe (Either String ()))\n ng \"(,)\" (fromCode foo :: Maybe ((), ()))\n ng \"(,,)\" (fromCode foo :: Maybe ((), (), ()))\n ng \"(,,,)\" (fromCode foo :: Maybe ((), (), (), ()))\n ng \"(,,,,)\" (fromCode foo :: Maybe ((), (), (), (), ()))\n ng \"(,,,,,)\" (fromCode foo :: Maybe ((), (), (), (), (), ()))\n ng \"Data.Functor.Sum.Sum Maybe (Either String) ()\"\n (fromCode foo1 :: Maybe (Sum.Sum Maybe (Either String) ()))\n ng \"Data.Functor.Product.Product Maybe (Either String) ()\"\n (fromCode foo2 :: Maybe (Product.Product Maybe (Either String) ()))\n ng \"Sum ()\" (fromCode foo1 :: Maybe (Sum ()))\n ng \"Proxy ()\" (fromCode foo :: Maybe (Proxy ()))\n ng \"Atom\" (fromCode foo1 :: Maybe Atom)\n\nfromCodeErrorTest :: Spec\nfromCodeErrorTest = do\n let err :: Homoiconic a => a -> String -> Spec\n err a ty = it (\"should show error message containing \" ++ ty) $ do\n case parseCode x `asTypeOf` Homoiconic.Success a of\n Homoiconic.Failure e -> e `shouldSatisfy` isSubsequenceOf ty\n _ -> expectationFailure \"parser unexpectedly succeeded\"\n x = toCode (List [ toCode (aSymbol \"foo\")\n , toCode (aSymbol \"x\") ])\n describe \"Failing to parse Code\" $ do\n err (1 :: Integer) \"integral\"\n err (1 :: Double) \"fractional\"\n err () \"()\"\n err 'a' \"Char\"\n err \"string\" \"String\"\n err False \"Bool\"\n err EQ \"Ordering\"\n err (Just False) \"Maybe\"\n err (Right True `asTypeOf` Left \"foo\") \"Either\"\n err ((),()) \",\"\n err ((),(),()) \"(,,)\"\n err ((),(),(),()) \"(,,,)\"\n err ((),(),(),(),()) \"(,,,,)\"\n err ((),(),(),(),(),()) \"(,,,,,)\"\n err (Sum.InL (Just True) `asTypeOf` Sum.InR (Just False)) \"Sum\"\n err (All True) \"All\"\n err (Proxy :: Proxy Int) \"Proxy\"\n err (aSymbol \"foo\") \"Atom\"\n\ndata D1 = D1a | D1b | D1c\n deriving (Eq, Show, Data, Typeable, Generic)\n\ninstance Homoiconic D1\ninstance Arbitrary D1 where\n arbitrary = oneof (map pure [D1a, D1b, D1c])\n\ndata D2 a = D2a a | D2b a a\n deriving (Eq, Show, Data, Typeable, Generic)\n\ninstance Homoiconic a => Homoiconic (D2 a)\ninstance Arbitrary a => Arbitrary (D2 a) where\n arbitrary = oneof [D2a <$> arbitrary, D2b <$> arbitrary <*> arbitrary]\n\ndata D3 a b = D3a Int a b\n deriving (Eq, Show, Data, Typeable, Generic)\n\ninstance (Homoiconic a, Homoiconic b) => Homoiconic (D3 a b)\ninstance (Arbitrary a, Arbitrary b) => Arbitrary (D3 a b) where\n arbitrary = D3a <$> arbitrary <*> arbitrary <*> arbitrary\n\ndata D4 a = D4a (a, a, a, a)\n deriving (Eq, Show, Data, Typeable, Generic)\n\ninstance Homoiconic a => Homoiconic (D4 a)\ninstance Arbitrary a => Arbitrary (D4 a) where\n arbitrary =\n D4a <$> ((,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)\n\ndataToCodeTest :: Spec\ndataToCodeTest = do\n let s = toCode . aSymbol\n describe \"D1 to Code\" $\n it \"should match D1 values\" $ do\n let e1a = s \"D1a\"\n e1b = s \"D1b\"\n e1c = s \"D1c\"\n dataToCode D1a `shouldBe` e1a\n dataToCode D1b `shouldBe` e1b\n dataToCode D1c `shouldBe` e1c\n describe \"D2 to Code\" $\n it \"should match `D2 Char' values\"$ do\n let e2a = toCode (List [s \"D2a\", toCode 'x'])\n e2b = toCode (List [s \"D2b\", toCode 'y', toCode 'z'])\n dataToCode (D2a 'x') `shouldBe` e2a\n dataToCode (D2b 'y' 'z') `shouldBe` e2b\n describe \"D2 with D1 to Code\" $\n it \"should match `D2 D1' values\" $ do\n let e2b = toCode (List [s \"D2b\", s \"D1a\", s \"D1b\"])\n dataToCode (D2b D1a D1b) `shouldBe` e2b\n describe \"D2 with Double to Code\" $\n it \"should match `D2 Double' values\" $ do\n let e2c = toCode (List [s \"D2a\", toCode (1.23 :: Double)])\n dataToCode (D2a (1.23 :: Double)) `shouldBe` e2c\n describe \"D3 to Code\" $\n it \"should match `D3' value\" $ do\n let e3 = toCode (List [ s \"D3a\"\n , toCode (42 :: Int)\n , toCode False\n , toCode 'a' ])\n dataToCode (D3a 42 False 'a') `shouldBe` e3\n describe \"D4 to Code\" $\n it \"should match `D4' value\" $ do\n let e4 = toCode (List [ s \"D4a\"\n , toCode (List [ s \",\"\n , toCode 'w'\n , toCode 'x'\n , toCode 'y'\n , toCode 'z'])])\n dataToCode (D4a ('w', 'x', 'y', 'z')) `shouldBe` e4\n\ngenericHomoiconicTest :: Spec\ngenericHomoiconicTest = do\n describe \"Result data type for parsing\" $ do\n let s1, s2, f1 :: Homoiconic.Result Bool\n s1 = Homoiconic.Success True\n s2 = Homoiconic.Success False\n f1 = Homoiconic.Failure \"foo\"\n it \"should equal to itself\" $ do\n s1 `shouldBe` s1\n s1 `shouldNotBe` s2\n f1 `shouldNotBe` s2\n it \"should show its conteints\" $ do\n show s1 `shouldBe` \"Success True\"\n show f1 `shouldBe` \"Failure \\\"foo\\\"\"\n let isFailure (Homoiconic.Failure _) = True\n isFailure _ = False\n it \"should fail on binding Failure\" $\n ((Homoiconic.Failure \"X_X\" >>= pure) :: Homoiconic.Result Bool)\n `shouldSatisfy` isFailure\n\n describe \"parseCode failure\" $ do\n let d2a_sym = toCode $ aSymbol \"D2a\"\n d3a_sym = toCode $ aSymbol \"D3a\"\n unit_sym = toCode ()\n fail_with substring r = case r of\n Homoiconic.Failure msg -> substring `isSubsequenceOf` msg\n _ -> False\n\n it \"should fail on non list Code\" $ do\n let r = parseCode @(D2 ()) d2a_sym\n r `shouldSatisfy` fail_with \"Not a list\"\n it \"should fail on unexpected field constructor\" $ do\n let r = parseCode @(D3 (D2 Bool) Bool) x\n x = toCode (List [d3a_sym, unit_sym])\n r `shouldSatisfy` fail_with \"()\"\n it \"should fail on unexpected leftover values\" $ do\n let r = parseCode @(D2 ()) x\n x = toCode (List [d2a_sym, unit_sym, unit_sym])\n r `shouldSatisfy` fail_with \"leftover\"\n it \"should fail on invalid constructor (no arg)\" $ do\n let r = parseCode @FormTest.D1 (toCode (aSymbol \"foo\"))\n r `shouldSatisfy` fail_with \"foo\"\n it \"should fail on invalid constructor (with args)\" $ do\n let r = parseCode @(D2 Bool) (toCode (List [toCode (aSymbol \"foo\")]))\n r `shouldSatisfy` fail_with \"foo\"\n\n describe \"genericFromCode\" $ do\n it \"should result in Code value\" $ do\n let d2 :: D2 Int\n d2 = D2a 42\n genericFromCode (toCode d2) `shouldBe` Just d2\n it \"should fail with invalid value\" $ do\n genericFromCode (toCode ()) `shouldBe` (Nothing :: Maybe (D2 Int))\n\n describe \"To/from code via Generic\" $ do\n it \"should return itself\" $\n let g_to_from :: D4 (D3 (D2 Int) D1) -> Bool\n g_to_from x = Just x == fromCode (toCode x)\n in property g_to_from\n it \"should return itself with nested Maybe data type\" $\n let g_to_from :: D3 (Maybe (Maybe (Maybe Int))) (Maybe (Maybe Bool))\n -> Bool\n g_to_from x = Just x == fromCode (toCode x)\n in property g_to_from\n\n let s = toCode . aSymbol\n noParse :: (Eq a, Show a, Homoiconic a) => Maybe a -> IO ()\n noParse = (`shouldBe` Nothing)\n\n describe \"Malformed codes via Generic\" $ do\n it \"result to Nothing with invalid constructor\" $\n noParse (fromCode (s \"Foo\") :: Maybe D1)\n it \"result to Nothing with arity mismatch\" $\n noParse\n (fromCode (toCode (List [s \"D2a\", toCode False, toCode False]))\n :: Maybe (D2 Bool))\n it \"result to Nothing with invalid field value\" $\n noParse\n (fromCode (toCode (List [s \"D2a\", s \"FOO\"])) :: Maybe (D2 Bool))\n it \"result to Nothing with non list\" $\n noParse (fromCode (toCode \"FOO\") :: Maybe (D2 Bool))\n it \"result to Nothing with invalid form\" $\n noParse\n (fromCode (toCode (List [s \"D2a\", toCode (List [s \"Just\", s \"___\"])]))\n :: Maybe (D2 (Maybe Bool)))\n\nunquoteSpliceTest :: Spec\nunquoteSpliceTest =\n describe \"unquote splicing List\" $\n it \"should return list contents\" $\n property\n (\\form ->\n (isListL form || isHsListL form ||\n isStringL form || isUnitL form)\n ==> (0 <= length (unquoteSplice form)))\n\neqForm :: Code -> Code -> Bool\neqForm a b =\n case (unCode a, unCode b) of\n -- Ignoring rounding error for fractional literals.\n (Atom (AFractional x), Atom (AFractional y))\n -> abs (fl_value x - fl_value y) <= toRational epsilon\n\n -- Recursively compare with `eqForm' for 'List' and 'HsList'.\n (List [], List []) -> True\n (List (x:xs), List (y:ys)) ->\n let ql z = qList z \"\" 0 0 0 0\n in eqForm x y && eqForm (ql xs) (ql ys)\n\n (HsList [], HsList []) -> True\n (HsList (x:xs), HsList (y:ys)) ->\n let qh z = qHsList z \"\" 0 0 0 0\n in eqForm x y && eqForm (qh xs) (qh ys)\n\n -- Treating empty 'List' and Atom symbol 'nil' as same value.\n (Atom (ASymbol sym), List []) | sym == fsLit \"nil\" -> True\n (List [], Atom (ASymbol sym)) | sym == fsLit \"nil\" -> True\n\n -- Using '==' for other Atom values.\n (Atom x, Atom y) -> x == y\n\n _ -> False\n where\n epsilon :: Double\n epsilon = 1e-7\n\npprTest :: Spec\npprTest =\n describe \"ppr\" $\n it \"should return expected String\" $ do\n let str0 = \"(1 2.34 () #'a \\\"foo\\\" [foo bar buzz])\"\n str1 <- runPpr str0\n str1 `shouldBe` str0\n\nrunPpr :: String -> IO String\nrunPpr str =\n runFnk (do dflags <- getDynFlags\n return (showPpr dflags (parseE str)))\n defaultFnkEnv\n\nparseE :: String -> Code\nparseE = parseE' Nothing\n\nparseE' :: Maybe FilePath -> String -> Code\nparseE' mb_path str =\n let inp = stringToStringBuffer str\n in case runSP sexpr mb_path inp of\n Right (expr, _) -> expr\n Left err -> error (show err)\n\nisListL :: Code -> Bool\nisListL (LForm (L _ (List _))) = True\nisListL _ = False\n\nisHsListL :: Code -> Bool\nisHsListL (LForm (L _ (HsList _))) = True\nisHsListL _ = False\n\nisStringL :: Code -> Bool\nisStringL (LForm (L _ (Atom (AString _ _)))) = True\nisStringL _ = False\n\nisUnitL :: Code -> Bool\nisUnitL (LForm (L _ (Atom AUnit))) = True\nisUnitL _ = False\n" }, { "path": "finkel-kernel/test/Main.hs", "content": "-- | Tests for Finkel.\nmodule Main where\n\n-- base\nimport System.Environment (getArgs)\n\n-- hspec\nimport Test.Hspec (beforeAll, beforeAll_, describe, hspec)\n\n-- finkel-kernel\nimport Language.Finkel.Fnk (initUniqSupply')\nimport Language.Finkel.Preprocess (defaultPreprocess)\n\n-- Internal\nimport EmitTest\nimport EvalTest\nimport ExceptionTest\nimport FnkTest\nimport FormTest\nimport MainTest\nimport MakeTest\nimport PluginTest\nimport PreprocessTest\nimport SyntaxTest\nimport TestAux\n\n-- To support plugin tests, the test executable is acting as a preprocessor if\n-- specific three file paths were given. Otherwise, run the hspec tests.\nmain :: IO ()\nmain = do\n args <- getArgs\n case args of\n (orig:isrc:_opath:_rest) | orig == isrc -> defaultPreprocess\n _ -> doHspec\n\ndoHspec :: IO ()\ndoHspec =\n hspec\n (beforeAll_\n -- Initializing UniqSupply before all tests, so that the tests not using\n -- 'Language.Finkel.Main.defaultMain' can use UniqSupply, and to avoid\n -- initializing the UniqSupply multiple times.\n (initUniqSupply' 0 1)\n (do describe \"Form\" formTests\n describe \"Fnk\" fnkTests\n describe \"Emit\" emitTests\n describe \"Preprocess\" preprocessTests\n beforeAll getFnkTestResource $ do\n describe \"Eval\" evalFnkTests\n describe \"Main\" mainFnkTests\n describe \"Make\" makeFnkTests\n describe \"Plugin\" pluginTests\n describe \"Syntax\" syntaxFnkTests\n describe \"Exception\" exceptionFnkTests))\n" }, { "path": "finkel-kernel/test/MainTest.hs", "content": "{-# LANGUAGE CPP #-}\n-- | Tests for \"Language.Finkel.Main\"\nmodule MainTest\n ( mainFnkTests\n ) where\n\n-- base\nimport System.Exit (ExitCode (..))\n\n-- filepath\nimport System.FilePath (())\n\n-- hspec\nimport Test.Hspec\n\n-- Internal\nimport TestAux\n\nmainFnkTests :: FnkSpec\nmainFnkTests =\n beforeAll_ (removeArtifacts odir) $ do\n let common_flags = [\"-v0\", \"-fno-code\"]\n compileFile common_flags \"m001.hs\"\n compileFile common_flags \"m002.hs\"\n compileFile (\"-c\" : common_flags) \"m003.c\"\n compileFile (\"-main-is\" : \"MyMain.my-main\" : common_flags) \"MyMain.hs\"\n rawGhcTest\n finkelHelpTest\n finkelVersionTest\n finkelSupportedLanguagesTest\n finkelInfoTest\n finkelUnknownFlagTest\n\ncompileFile :: [String] -> FilePath -> FnkSpec\ncompileFile args file = describe (\"file \" ++ file) $\n it \"should compile successfully\" $ \\ftr ->\n ftr_main ftr (args ++ pure (odir file))\n\nrawGhcTest :: FnkSpec\nrawGhcTest =\n trivialTest \"option --version\"\n \"should show project-version\"\n [\"--version\"]\n\nfinkelHelpTest :: FnkSpec\nfinkelHelpTest =\n trivialTest \"option --fnk-help\"\n \"should show Finkel help\"\n [\"--fnk-help\"]\n\nfinkelVersionTest :: FnkSpec\nfinkelVersionTest =\n trivialTest \"option --fnk-version\"\n \"should show finkel-kernel package version\"\n [\"--fnk-version\"]\n\nfinkelSupportedLanguagesTest :: FnkSpec\nfinkelSupportedLanguagesTest =\n trivialTest \"option --fnk-languages\"\n \"should show supported language extensions\"\n [\"--fnk-languages\"]\n\nfinkelInfoTest :: FnkSpec\nfinkelInfoTest =\n trivialTest \"option --info\"\n \"should show info of DynFlags\"\n [\"--info\"]\n\nfinkelUnknownFlagTest :: FnkSpec\nfinkelUnknownFlagTest =\n describe \"invalid flag\" $ do\n it \"should exit with failure with unknown flag\" $ \\ftr ->\n ftr_main ftr [\"--fnk-foo\"] `shouldThrow` (== ExitFailure 1)\n it \"should exit with failure with invalid verbosity level\" $ \\ftr ->\n ftr_main ftr [\"--fnk-verbose=foo\"] `shouldThrow` (== ExitFailure 1)\n\ntrivialTest :: String -> String -> [String] -> FnkSpec\ntrivialTest desc label flags = describe desc $\n it label (`ftr_main` flags)\n\nodir :: FilePath\nodir = \"test\" \"data\" \"main\"\n" }, { "path": "finkel-kernel/test/MakeTest.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE MagicHash #-}\n-- | Tests for 'make'.\nmodule MakeTest\n ( makeTests\n , makeFnkTests\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Exception (SomeException (..))\nimport Control.Monad (unless, when)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.List (isPrefixOf, tails)\nimport Data.Maybe (isJust)\nimport GHC.Exts (unsafeCoerce#)\nimport System.Environment (getExecutablePath, lookupEnv)\nimport System.Info (os)\n\n-- directory\nimport System.Directory (copyFile, createDirectoryIfMissing,\n doesFileExist, getTemporaryDirectory,\n removeDirectoryRecursive)\n#if !MIN_VERSION_ghc(9,0,0)\nimport System.Directory (getDirectoryContents)\n#endif\n\n-- filepath\nimport System.FilePath ((<.>), ())\n#if !MIN_VERSION_ghc(9,0,0)\nimport System.FilePath (takeExtension)\n#endif\n\n-- ghc\nimport GHC_Data_FastString (fsLit)\nimport GHC_Driver_Monad (GhcMonad (..))\nimport GHC_Driver_Ppr (showPpr)\nimport GHC_Driver_Session (HasDynFlags (..))\nimport GHC_Types_SrcLoc (noLoc)\nimport GHC_Unit_Module (mkModuleName)\nimport GHC_Unit_State (PackageName (..))\nimport GHC_Utils_Outputable (Outputable (..))\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Env (hscInterp)\nimport GHC.Linker.Loader (unload)\n#elif MIN_VERSION_ghc(9,2,0)\nimport GHC.Linker.Loader (unload)\nimport GHC.Runtime.Interpreter (hscInterp)\n#else\nimport GHC_Runtime_Linker (unload)\n#endif\n\n#if !MIN_VERSION_ghc(9,0,0)\nimport GHC_Driver_Session (DynFlags (..))\nimport GHC_Unit_State (lookupPackageName)\nimport GHC_Utils_Outputable (showSDoc)\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC_Platform_Ways (hostIsDynamic, hostIsProfiled)\n#else\nimport DynFlags (Way (..), dynamicGhc, interpWays)\nimport Module (componentIdToInstalledUnitId)\nimport Packages (InstalledPackageInfo (..), PackageConfig,\n lookupInstalledPackage, pprPackageConfig)\n#endif\n\n-- process\nimport System.Process (readProcess)\n\n-- hspec\nimport Test.Hspec\n\n-- finkel-kernel\nimport Language.Finkel.Eval\nimport Language.Finkel.Fnk\nimport Language.Finkel.Form\nimport Language.Finkel.Make (TargetSource (..), asModuleName, buildHsSyn,\n setContextModules, simpleMake,\n withExpanderSettings)\nimport Language.Finkel.Plugin (plugin, setFinkelPluginWithArgs)\nimport Language.Finkel.Syntax\n\n-- Internal\nimport TestAux\n\nmakeTests :: Spec\nmakeTests = beforeAll getFnkTestResource makeFnkTests\n\nmakeFnkTests :: FnkSpec\nmakeFnkTests = beforeAll_ (removeArtifacts odir) $ do\n targetSourceTests\n let in_odir file = odir file\n\n -- Build bytecode\n buildByteCode (in_odir \"main1.hs\")\n buildByteCode (in_odir \"main2.hs\")\n buildByteCode (in_odir \"main3.hs\")\n buildByteCodeWith [\"--fnk-verbose=2\", \"-v2\"] (in_odir \"main4.hs\")\n buildByteCode (in_odir \"main5.hs\")\n buildByteCodeWith [ \"--fnk-dump-dflags\"\n , \"--fnk-dump-expand\"\n , \"--fnk-dump-hs\"\n , \"--fnk-trace-expand\"\n , \"--fnk-trace-make\"\n , \"--fnk-trace-spf\" ]\n (in_odir \"main9.hs\")\n\n -- Build object codes\n buildC (odir \"cbits1.c\")\n buildObj [\"-fforce-recomp\", \"-ddump-parsed\", \"-ddump-parsed-ast\"\n ,\"-dsource-stats\"]\n [in_odir \"main5.hs\"]\n buildObj [] (map in_odir [\"cbits1.c\", \"cbits2.c\", \"cbits3.c\", \"main6.hs\"])\n buildObj [] (map (odir ) [\"cbits1.o\",\"cbits2.o\",\"cbits3.o\"] ++\n [in_odir \"main6.hs\"])\n buildObj [] (map in_odir [\"main6.hs\", \"cbits1.c\", \"cbits2.c\", \"cbits3.c\"])\n buildObj [] [\"M4.A\"]\n buildObj [\"--fnk-dump-hs\", \"--fnk-hsdir=\" ++ (in_odir \"gen\")]\n [\"M5\", \"M4.A\", \"M4.B\", \"M4\", in_odir \"main7.hs\"]\n buildObj [\"-O2\"] [in_odir \"main8.hs\"]\n\n let buildObj' flags inputs =\n before_ prepare_obj (buildObj flags inputs)\n buildObjAndExist' flags inputs =\n beforeAll_ prepare_obj\n (let outputs = map (<.> \"o\") inputs\n in buildObjAndExist flags inputs outputs)\n prepare_obj = do\n mapM_ removeArtifacts [odir, in_odir \"M4\", in_odir \"M6\"]\n\n -- Compile object codes with and without optimization option\n buildObjAndExist' [] [\"P1\", \"P2\"]\n buildObjAndExist' [\"-O1\"] [\"P1\", \"P2\"]\n\n -- Recompile P1 and P2 without deleting previous results\n buildObj [] [\"P1\",\"P2\"]\n\n -- Compile object code with and without optimization, module reorderd\n buildObjAndExist' [] [\"P2\", \"P1\"]\n buildObjAndExist' [\"-O1\"] [\"P2\", \"P1\"]\n\n -- Compile object codes, P3 requires but does not import P1.\n buildObjAndExist' [] [\"P1\", \"P3\"]\n buildObjAndExist' [\"-O1\"] [\"P1\", \"P3\"]\n\n#if !defined(mingw32_HOST_OS)\n -- Compile object codes with dynamic-too and optimization option\n buildObj' [\"-O0\", \"-dynamic-too\"] [\"P1\", \"P2\"]\n buildObj' [\"-O1\", \"-dynamic-too\"] [\"P1\", \"P2\"]\n\n -- Compile object codes with dynamic-too and optimization option, reorderd\n buildObj' [\"-O0\", \"-dynamic-too\"] [\"P2\", \"P1\"]\n buildObj' [\"-O1\", \"-dynamic-too\"] [\"P2\", \"P1\"]\n#endif\n\n -- Compile object codes with profiling option\n has_profiling_obj <- runIO hasProfilingObj\n when has_profiling_obj $ do\n buildObj' [\"-O\",\"-prof\", \"-osuf\", \"p_o\", \"-hisuf\", \"p_hi\"] [\"P1\", \"P2\"]\n buildObj' [\"-O\",\"-prof\", \"-osuf\", \"p_o\", \"-hisuf\", \"p_hi\"] [\"P1\", \"P2\"]\n\n -- Reload tests\n let reload_simple t after_files after_output =\n buildReload t\n \"foo\"\n [(\"R01.hs.1\", \"R01.hs\"), (t, t)]\n after_files\n \"foo: before\"\n after_output\n\n -- Reloading without modifications.\n reload_simple \"R02.hs\" [] \"foo: before\"\n\n#if MIN_VERSION_ghc(9,0,0)\n -- Reloading with modifications. Failing with ghc 8.10 when running with nix\n -- in CI test, disabling for now.\n reload_simple \"R02.hs\" [(\"R01.hs.2\", \"R01.hs\")] \"foo: after\"\n#endif\n\n -- Reloading test for modules containing `:require' of home package modules\n -- not working well with ghc >= 8.10.\n\n -- XXX: Disabled at the moment.\n -- reload_simple \"R03.fnk\"\n\n -- Recompile tests\n let recompile_simple t extras =\n buildRecompile t\n ([(\"R01.hs.1\", \"R01.hs\"), dot_hs t] ++ map dot_hs extras)\n [(\"R01.hs.2\", \"R01.hs\")]\n \"foo: before\\n\"\n \"foo: after\\n\"\n dot_hs x = let y = x <.> \"hs\" in (y,y)\n\n recompile_simple \"R04\" []\n recompile_simple \"R05\" [\"R05a\"]\n recompile_simple \"R06\" [\"R06a\"]\n\n -- XXX: R07 and R08 contains nested require of home modules. When compiling\n -- with plugin, recompilation is not working with modification of R01.hs.\n recompile_simple \"R07\" [\"R07a\", \"R07b\"]\n recompile_simple \"R08\" [\"R08a\", \"R08b\"]\n\n recompile_simple \"R09\" [\"R09a\", \"R09b\"]\n recompile_simple \"R10\" [\"R10a\", \"R10b\"]\n recompile_simple \"R11\" [\"R11a\", \"R11b\"]\n\n -- Errors\n buildFilesNG [] [\"E01\"]\n buildFilesNG [] [\"E02\"]\n\n\n-- Action to unload package libraries\n--\n-- Until ghc 8.10, persistent linker state is stored in a global variable. The\n-- loaded package libraries are shared in \"HscEnv.hsc_dynLinker\" in every Fnk\n-- run, which may cause link time error with dynamic object on some platforms.\n-- To avoid such link time error, invoking \"Linker.unload\" before running the\n-- test containing macro expansion.\n--\n-- Persistent linker state is isolated from ghc 8.10, does nothing.\n\n-- Action to decide whether profiling objects for the \"finkel-kernel\" package\n-- are available at runtime.\nhasProfilingObj :: IO Bool\nhasProfilingObj = runFnk (hasProfilingObj1 pkg_name) fnkTestEnv\n where\n pkg_name = PackageName (fsLit \"finkel-kernel\")\n\nhasProfilingObj1 :: PackageName -> Fnk Bool\n#if MIN_VERSION_ghc(9,0,0)\nhasProfilingObj1 _ = return False\n#else\nhasProfilingObj1 pkg_name = do\n initSessionForTest\n dflags <- getDynFlags\n case lookupPackageConfig dflags pkg_name of\n Nothing -> return False\n Just cfg -> liftIO (do putStrLn (showSDoc dflags (pprPackageConfig cfg))\n lookupProfObjInDirectories (libraryDirs cfg))\n\nlookupPackageConfig :: DynFlags -> PackageName -> Maybe PackageConfig\nlookupPackageConfig dflags pkg_name = do\n cmpid <- lookupPackageName dflags pkg_name\n lookupInstalledPackage dflags (componentIdToInstalledUnitId cmpid)\n\nlookupProfObjInDirectories :: [FilePath] -> IO Bool\nlookupProfObjInDirectories =\n let go (dir:dirs) = do\n files <- getDirectoryContents dir\n if any (\\file -> \".p_o\" == takeExtension file) files\n then return True\n else go dirs\n go [] = return False\n in go\n#endif\n\nfnksrc1, hssrc1, othersrc1 :: TargetSource\nfnksrc1 = FnkSource \"path1\" (mkModuleName \"Foo\")\nhssrc1 = HsSource \"path2\" (mkModuleName \"Bar\")\nothersrc1 = OtherSource \"path3\"\n\nsubseq :: Eq a => [a] -> [a] -> Bool\nsubseq xs ys = any (isPrefixOf xs) (tails ys)\n\ntargetSourceTests :: FnkSpec\ntargetSourceTests =\n describe \"TargetSource\" $ do\n showTargetTest\n pprTargetTest\n asModuleNameTest\n\nshowTargetTest :: FnkSpec\nshowTargetTest = do\n describe \"show TargetSource\" $\n it \"should contain filepath\" $ \\_ -> do\n show fnksrc1 `shouldSatisfy` subseq \"path1\"\n show hssrc1 `shouldSatisfy` subseq \"path2\"\n show othersrc1 `shouldSatisfy` subseq \"path3\"\n\nasModuleNameTest :: FnkSpec\nasModuleNameTest =\n describe \"asModuleName\" $\n it \"should replace path separators\" $ \\_ ->\n asModuleName (\"Foo\" \"Bar\" \"Buzz.fnk\") `shouldBe` \"Foo.Bar.Buzz\"\n\nrunOutputable :: (MonadIO m, Outputable a) => a -> m String\nrunOutputable obj =\n liftIO $ runFnk (flip showPpr obj <$> getDynFlags) fnkTestEnv\n\npprTargetTest :: FnkSpec\npprTargetTest =\n describe \"ppr TargetSource\" $\n it \"should contain filepath\" $ \\_ -> do\n let t target path = do str <- runOutputable target\n str `shouldSatisfy` subseq path\n t fnksrc1 \"path1\"\n t hssrc1 \"path2\"\n t othersrc1 \"path3\"\n\nbuildByteCode :: FilePath -> FnkSpec\nbuildByteCode = buildByteCodeWith []\n\nbuildByteCodeWith :: [String] -> FilePath -> FnkSpec\nbuildByteCodeWith extra file =\n buildFiles ([\"-no-link\", \"-fbyte-code\"] ++ extra) [file]\n\nbuildC :: FilePath -> FnkSpec\nbuildC file = buildFiles [\"-no-link\"] [file]\n\nbuildObj :: [String] -> [FilePath] -> FnkSpec\nbuildObj = buildFiles\n\nbuildObjAndExist :: [String] -> [FilePath] -> [String] -> FnkSpec\nbuildObjAndExist args inputs outputs =\n describe (labelWithOptionsAndFiles args inputs) $\n it \"should write to output\" $ \\ftr ->\n pendingInputsForWindowsOr inputs $\n mapM_ (\\f ->\n do buildWork ftr args inputs\n doesFileExist (odir f) `shouldReturn` True)\n outputs\n\nbuildFiles :: [String] -> [FilePath] -> FnkSpec\nbuildFiles pre inputs =\n describe (labelWithOptionsAndFiles pre inputs) $\n it \"should compile successfully\" $ \\ftr ->\n pendingInputsForWindowsOr inputs $\n buildWork ftr pre inputs\n\npendingInputsForWindowsOr :: [String] -> Expectation -> Expectation\npendingInputsForWindowsOr inputs act =\n if os == \"mingw32\" && any (`elem` pendingInputsUnderWindows) inputs\n then pendingWith \"pending under Windows\"\n else act\n\n-- Compilation of modules containing macro expansion is not working well under\n-- Windows, pending for now.\npendingInputsUnderWindows :: [String]\npendingInputsUnderWindows = [\"main4.fnk\", \"main8.fnk\", \"main9.fnk\", \"P1\"]\n\nbuildFilesNG :: [String] -> [FilePath] -> FnkSpec\nbuildFilesNG pre inputs =\n describe (labelWithOptionsAndFiles pre inputs) $\n it \"should throw an exception\" $ \\ftr ->\n buildWork ftr pre inputs `shouldThrow` anyException\n\nlabelWithOptionsAndFiles :: [String] -> [FilePath] -> String\nlabelWithOptionsAndFiles pre inputs =\n \"file \" ++ show inputs ++\n if null pre\n then \"\"\n else \" with \" ++ unwords pre\n\nbuildWork :: FnkTestResource -> [String] -> [FilePath] -> Expectation\nbuildWork ftr pre inputs = do_work\n where\n do_work\n | isProfWay = do_prof_work\n | otherwise = do_work_with []\n -- Use dflags setttings for profile when running test executable with \"+RTS\n -- -p\" option.\n do_prof_work =\n do_work_with [ \"-prof\", \"-fprof-auto\", \"-fprof-cafs\"\n , \"-hisuf\", \"p_hi\", \"-osuf\", \"p_o\" ]\n do_work_with extra =\n ftr_main ftr (extra ++ common_args ++ pre)\n common_args =\n [\"-i.\", \"-i\" ++ odir, \"-v1\"] ++ inputs\n#if MIN_VERSION_ghc(9,0,0)\n isProfWay = hostIsProfiled\n#else\n isProfWay = WayProf `elem` interpWays\n#endif\n\nodir :: FilePath\nodir = \"test\" \"data\" \"make\"\n\n\n-- ------------------------------------------------------------------------\n--\n-- For reload and recompile tests\n--\n-- ------------------------------------------------------------------------\n\nbuildReload\n :: String -- ^ Target module name.\n -> String -- ^ Function to return a 'String' value.\n -> [(String, String)] -- ^ List of (input file, output file), before.\n -> [(String, String)] -- ^ List of (input file, output file), after.\n -> String -- ^ Expected value of before.\n -> String -- ^ Expected value for after.\n -> FnkSpec\nbuildReload the_file fname files1 files2 before_str after_str =\n beforeAllWith (\\ftr -> do\n dir <- mk_tmp_dir (\"reload_\" ++ the_file)\n return (dir, ftr))\n (afterAll (rmdir . fst) work)\n where\n work = do\n describe (unwords [\"Reload test for\", the_file , \"with\", fname]) $ do\n it \"should get expected values (bytecode)\" $ do_work False\n it \"should get expected values (objcode)\" $ do_work True\n\n do_work use_obj (tmpdir, ftr) = do\n if use_obj && not dynamicGhc\n -- XXX: Reloading with non-dynamic object code not yet working. It\n -- does work when the test executable was compiled with \"-dynamic\"\n -- option.\n then pendingWith \"non-dynamic object code not yet supported\"\n else do\n is_travis <- lookupEnv \"TRAVIS\"\n if isJust is_travis && os == \"darwin\"\n then pendingWith \"not supported under Travis OSX\"\n else do_work' use_obj tmpdir ftr\n\n do_work' use_obj tmpdir ftr = do\n let act = runFnk (fnk_work use_obj tmpdir ftr) reloadFnkEnv\n (ret1, ret2) <- quietly act\n (ret1, ret2) `shouldBe` (before_str, after_str)\n\n reloadFnkEnv = fnkTestEnv {envVerbosity = 3}\n\n fnk_work use_obj tmpdir ftr = do\n setup_reload_env use_obj tmpdir ftr\n copy_files tmpdir files1\n str1 <- make_and_eval tmpdir\n reset_env\n copy_files tmpdir files2\n str2 <- make_and_eval tmpdir\n return (str1, str2)\n\n setup_reload_env :: Bool -> FilePath -> FnkTestResource -> Fnk ()\n setup_reload_env use_obj tmpdir ftr = do\n me <- liftIO getExecutablePath\n let args0 = (\"-i\" ++ tmpdir) : [\"-fobject-code\" | use_obj]\n args1 = [\"-v0\", \"-F\", \"-pgmF\", me, \"-optF\", \"--no-warn-interp\"]\n parseAndSetDynFlags (args0 <> args1)\n ftr_init ftr\n prepareInterpreter\n setFinkelPluginWithArgs plugin []\n\n make_and_eval :: FilePath -> Fnk String\n make_and_eval tmpdir = do\n _ <- simpleMake [(noLoc (tmpdir the_file), Nothing)] False Nothing\n setContextModules [asModuleName the_file]\n hexpr <- buildHsSyn parseExpr [qSymbol fname fname 0 0 0 0]\n unsafeCoerce# <$> evalExpr hexpr\n\n reset_env = do\n hsc_env <- getSession\n#if MIN_VERSION_ghc(9,2,0)\n liftIO (unload (hscInterp hsc_env) hsc_env [])\n#else\n liftIO (unload hsc_env [])\n#endif\n\n#if MIN_VERSION_ghc(9,0,0)\n dynamicGhc = hostIsDynamic\n#endif\n\n-- | Make a test for recompilation.\nbuildRecompile\n :: String -- ^ Module containing the @main@ function.\n -> [(String, String)] -- ^ List of @(SRC_FILE, DEST_FILE)@ for first run.\n -> [(String, String)] -- ^ List of @(SRC_FILE, DEST_FILE)@ for second run.\n -> String -- ^ Expected output from the first run.\n -> String -- ^ Expected output from the second run.\n -> FnkSpec\nbuildRecompile main_mod files1 files2 before_str after_str =\n beforeAllWith (\\ftr -> do\n dir <- mk_tmp_dir (\"recompile_\" ++ main_mod)\n return (dir, ftr))\n (afterAll (rmdir . fst) work)\n where\n work =\n describe (\"Recompile \" ++ main_mod) $\n it \"should return expected result\" $ \\(tmpdir, ftr) -> do\n is_travis <- lookupEnv \"TRAVIS\"\n if isJust is_travis && os == \"darwin\"\n then pendingWith \"not supported under Travis OSX\"\n else if os == \"mingw32\"\n -- XXX: Recompile tests not working well under Windows, pending\n -- for now.\n then pendingWith \"recompile tests pending under Windows\"\n else do_work (tmpdir, ftr)\n\n do_work (tmpdir, ftr) = do\n -- Running with files1 twice to see compilation avoidance.\n compile_and_run tmpdir ftr False files1 before_str\n compile_and_run tmpdir ftr True files1 before_str\n\n -- When compiling with plugin, need to unload home unit modules from the\n -- global HscEnv used during macro expansion. Otherwise the required R01\n -- module won't recompiled.\n clearGlobalSession\n\n compile_and_run tmpdir ftr False files2 after_str\n\n compile_and_run tmpdir ftr skip_copy files expected_str = do\n let a_dot_out = tmpdir \"a.out\"\n unless skip_copy $ copy_files tmpdir files\n buildWork ftr []\n [ \"-i\" ++ tmpdir\n , \"-outputdir\", tmpdir\n , \"-main-is\", main_mod\n , \"-o\", a_dot_out\n , \"--fnk-trace-make\"\n , main_mod ]\n output1 <- readProcess a_dot_out [] \"\"\n output1 `shouldBe` expected_str\n\nclearGlobalSession :: IO ()\nclearGlobalSession = runFnk clear (fnkTestEnv {envVerbosity = 1\n ,envInvokedMode = GhcPluginMode})\n where\n clear = withExpanderSettings $ do\n -- See also 'clearHPTs' in \"ghc/GHCi/UI.hs\".\n _ <- simpleMake [] False Nothing\n pure ()\n\ncopy_files :: MonadIO m => FilePath -> [(FilePath, FilePath)] -> m ()\ncopy_files dir fs = liftIO (mapM_ copy fs)\n where\n copy (i,o) =\n let src = odir i\n dst = dir o\n in copyFile src dst\n\n-- | Create temporary directory with given name.\nmk_tmp_dir :: String -> IO FilePath\nmk_tmp_dir name = do\n tmp <- getTemporaryDirectory\n let my_tmpdir = tmp name\n catch (removeDirectoryRecursive my_tmpdir)\n (\\(SomeException _e) -> return ())\n createDirectoryIfMissing True my_tmpdir\n return my_tmpdir\n\n-- | Remove given directory.\nrmdir :: FilePath -> IO ()\nrmdir = removeDirectoryRecursive\n" }, { "path": "finkel-kernel/test/Orphan.hs", "content": "{-# LANGUAGE CPP #-}\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n-- Orphan instance definitions for Form, for QuickCheck.\n\nmodule Orphan where\n\n#include \"ghc_modules.h\"\n\n-- ghc\nimport GHC_Data_FastString (fsLit, unpackFS)\nimport GHC_Types_SrcLoc (GenLocated (..), interactiveSrcSpan, mkSrcLoc,\n mkSrcSpan, noSrcSpan, wiredInSrcSpan)\n\n-- QuickCheck\nimport Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen,\n arbitraryUnicodeChar, elements, getUnicodeString,\n listOf, oneof, scale, variant)\n\n-- Internal\nimport Language.Finkel.Form\n\ninstance Arbitrary Atom where\n -- XXX: Unicode symbols are not generated.\n arbitrary =\n oneof [ return AUnit\n , aSymbol <$> symbolG\n , AChar NoSourceText <$> arbitraryUnicodeChar\n , aString NoSourceText <$> stringG\n , aIntegral <$> (arbitrary :: Gen Integer)\n , aFractional <$> (arbitrary :: Gen Double) ]\n where\n headChars = ['A' .. 'Z'] ++ ['a' .. 'z'] ++ \"_!$&*+./<=>?@^~:\"\n tailChars = headChars ++ \"0123456789'_\"\n symbolG = (:) <$> elements headChars <*> listOf (elements tailChars)\n stringG = getUnicodeString <$> arbitrary\n\ninstance CoArbitrary Atom where\n coarbitrary x =\n case x of\n AUnit -> var 0\n ASymbol s -> var 1 . coarbitrary (unpackFS s)\n AChar _ c -> var 2 . coarbitrary c\n AString _ s -> var 3 . coarbitrary (unpackFS s)\n AInteger i -> var 4 . coarbitrary (il_value i)\n AFractional d -> var 5 . coarbitrary (fl_value d)\n where\n var :: Int -> Gen a -> Gen a\n var = variant\n\ninstance Arbitrary a => Arbitrary (Form a) where\n arbitrary =\n oneof [Atom <$> arbitrary\n ,List <$> listOf (scale (`div` 3) arbitrary)\n ,HsList <$> listOf (scale (`div` 3) arbitrary)]\n shrink x =\n case x of\n Atom _ -> []\n List xs -> map unCode xs ++ [List xs'|xs' <- shrink xs]\n HsList xs -> map unCode xs ++ [HsList xs'|xs' <- shrink xs]\n TEnd -> []\n\ninstance CoArbitrary a => CoArbitrary (Form a) where\n coarbitrary x =\n case x of\n Atom y -> var 0 . coarbitrary y\n List ys -> var 1 . coarbitrary ys\n HsList ys -> var 2 . coarbitrary ys\n TEnd -> var 3\n where\n var :: Int -> Gen a -> Gen a\n var = variant\n\ninstance Arbitrary a => Arbitrary (LForm a) where\n arbitrary = LForm <$> (L <$> aloc <*> arbitrary)\n where\n aloc = oneof [real, unhelpful]\n real = do\n file <- fsLit <$> arbitrary\n sl <- arbitrary\n sc <- arbitrary\n ec <- arbitrary\n let sloc = mkSrcLoc file sl sc\n eloc = mkSrcLoc file (sl + 1) ec\n pure (mkSrcSpan sloc eloc)\n unhelpful =\n oneof (map pure [noSrcSpan, wiredInSrcSpan, interactiveSrcSpan])\n\ninstance CoArbitrary a => CoArbitrary (LForm a) where\n coarbitrary (LForm (L _ form)) = coarbitrary form\n" }, { "path": "finkel-kernel/test/PluginTest.hs", "content": "{-# LANGUAGE CPP #-}\n\n-- Module for testing the finkel plugin.\n\nmodule PluginTest (pluginTests) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Monad (void)\nimport System.Info (os)\n\n#if MIN_VERSION_ghc(9,6,0) || !MIN_VERSION_ghc(9,4,0)\nimport Control.Exception (SomeException (..))\n#endif\n\n-- filepath\nimport System.Environment (getExecutablePath)\nimport System.FilePath (())\n\n-- ghc\nimport GHC\nimport GHC_Driver_Env (HscEnv (..))\n\n-- hspec\nimport Test.Hspec\n\n-- finkel-kernel\nimport Language.Finkel.Fnk (getLibDirFromGhc)\nimport Language.Finkel.Make (clearGlobalSession)\nimport Language.Finkel.Plugin (plugin, setFinkelPluginWithArgs)\n\n-- Internal\nimport TestAux\n\n\n-- ------------------------------------------------------------------------\n--\n-- Plugin tests\n--\n-- ------------------------------------------------------------------------\n\npluginTests :: FnkSpec\npluginTests =\n -- Clearing global session for macro expansion with `clearGlobalSession'. If\n -- not cleared, when this Plugin tests were ran after Make tests, nested\n -- required home modules (the test with p11.hs) will show a compilation error.\n beforeAll_ (removeArtifacts pdir >> clearGlobalSession) $\n describe \"run compiler as ghc plugin\" $ do\n compile [] [\"--verbose=3\"] \"p01.hs\"\n compile [] [] \"p02.hs\"\n compile [\"-optF\", \"--warn-interp=False\"] [\"--verbose=3\"] \"p03.hs\"\n#if !MIN_VERSION_ghc(9,4,0)\n compile [\"-optF\", \"--ignore\"] [\"--ignore\"] \"p04.hs\"\n#endif\n compile [\"-ddump-parsed-ast\"] [] \"p05.hs\"\n compile [\"-optF\", \"--warn-interp=False\"] [] \"p06.hs\"\n compile [] [] \"p08.hs\"\n\n compile [\"-v\", \"-optF\", \"--warn-interp=False\"] [\"--verbose=0\"] \"p09.hs\"\n compile [\"-v\", \"-optF\", \"--warn-interp=False\"] [\"--verbose=3\"] \"p09.hs\"\n compile [\"-v\", \"-optF\", \"--warn-interp=False\"] [\"--verbose=3\"] \"p10.hs\"\n compile [\"-v\", \"-optF\", \"--warn-interp=False\"] [\"--verbose=3\"] \"p11.hs\"\n\n -- Failures\n compileWithFailedFlag [] [] \"p07.hs\"\n compileAndFail [] [\"--help\"] \"p01.hs\"\n compileAndFail [] [\"--pragma\"] \"p01.hs\"\n\ncompile :: [String] -> [String] -> String -> FnkSpec\ncompile ghc_args plugin_args basename = do\n let act io = do\n success_flag <- io\n succeeded success_flag `shouldBe` True\n pending_in_win = [\"p03.hs\", \"p06.hs\", \"p09.hs\", \"p10.hs\", \"p11.hs\"]\n if os == \"mingw32\" && basename `elem` pending_in_win\n then it (\"should compile \" ++ basename) $ \\_ ->\n pendingWith \"Windows not supported yet\"\n else compile' \"successfully\" act ghc_args plugin_args basename\n\ncompileWithFailedFlag :: [String] -> [String] -> String -> FnkSpec\ncompileWithFailedFlag =\n compile' \"fail to\" (\\io -> do\n success_flag <- io\n succeeded success_flag `shouldBe` False)\n\ncompileAndFail :: [String] -> [String] -> String -> FnkSpec\ncompileAndFail =\n#if MIN_VERSION_ghc(9,6,0) || !MIN_VERSION_ghc(9,4,0)\n compile' \"fail to\" (\\io -> io `shouldThrow` \\(SomeException _) -> True)\n#else\n compileWithFailedFlag\n#endif\n\n-- Compile source code file. The test executable can act as preprocessor, used\n-- to compile Finkel source codes.\ncompile'\n :: String -> (IO SuccessFlag -> IO ()) -> [String] -> [String] -> String\n -> FnkSpec\ncompile' msg wrap ghc_args plugin_args basename =\n let title =\n \"compile \" ++ basename ++ \", ghc args: \" ++\n show ghc_args ++ \", plugin args: \" ++ show plugin_args\n in describe title $ do\n it (\"should \" ++ msg ++ \" compile \" ++ basename) $ \\ftr -> do\n libdir <- getLibDirFromGhc\n _me <- getExecutablePath\n let act = quietly $ runGhc (Just libdir) $ do\n hsc_env1 <- getSession\n\n let dflags0 = hsc_dflags hsc_env1\n fnk_args = [\"-F\", \"-pgmF\", _me, \"-i\" ++ pdir]\n args = map noLoc (ftr_pkg_args ftr ++ fnk_args ++ ghc_args)\n\n#if MIN_VERSION_ghc(9,2,0)\n logger <- getLogger\n (dflags1, _, _) <- parseDynamicFlags logger dflags0 args\n#else\n (dflags1, _, _) <- parseDynamicFlags dflags0 args\n#endif\n void (setSessionDynFlags dflags1)\n\n setFinkelPluginWithArgs plugin plugin_args\n\n#if MIN_VERSION_ghc(9,4,0)\n t <- guessTarget (pdir basename) Nothing Nothing\n#else\n t <- guessTarget (pdir basename) Nothing\n#endif\n setTargets [t]\n load LoadAllTargets\n\n wrap act\n\npdir :: FilePath\npdir = \"test\" \"data\" \"plugin\"\n\n" }, { "path": "finkel-kernel/test/PreprocessTest.hs", "content": "module PreprocessTest where\n\n-- base\nimport Control.Exception (SomeException (..), bracket)\nimport Data.List (intercalate)\nimport System.Environment (withArgs)\nimport System.Exit (ExitCode (..))\n\n-- directory\nimport System.Directory (createDirectoryIfMissing,\n getTemporaryDirectory,\n removeDirectoryRecursive)\n\n-- filepath\nimport System.FilePath (takeDirectory, ())\n\n-- hspec\nimport Test.Hspec\n\n-- finkel-kernel\nimport Language.Finkel.Preprocess (defaultPreprocess)\n\n-- Internal\nimport TestAux\n\n\n-- ------------------------------------------------------------------------\n--\n-- Preprocessor tests\n--\n-- ------------------------------------------------------------------------\n\npreprocessTests :: Spec\npreprocessTests = around withTemporaryFile $\n describe \"preprocess\" $ do\n let ul = intercalate \"\\n\"\n pp args = quietly (withArgs args defaultPreprocess)\n anyExitFailure e = case e of\n ExitFailure _ -> True\n _ -> False\n\n it \"should show help message\" $\n const (pp [\"--help\"])\n\n it \"should show result to stdout\" $\n const (pp [\"--verbose=3\", pdir \"fnk01.hs\"])\n\n it \"should write out to file\" $ \\opath ->\n pp [pdir \"fnk01.hs\", opath]\n\n it \"should fail when no files were specified\" $\n const (pp [] `shouldThrow` anyExitFailure)\n\n it \"should fail when no arg were passed to pragma option\" $\n const (pp [\"fnk01.hs\", \"--pragma\"] `shouldThrow` anyExitFailure)\n\n -- Finkel source code\n -- Parsing plugin01.hs, header only.\n doPreprocess [\"--verbose=3\"] \"fnk01.hs\"\n \"module Main where\\n\\n\"\n\n -- Parsing plugin01.hs, full module.\n doPreprocess [\"--full\", \"--warn-interp\"] \"fnk01.hs\"\n (ul [ \"module Main where\"\n , \"main :: IO ()\"\n , \"main = putStrLn \\\"preprocess/fnk01.hs\\\"\"\n , \"\\n\"\n ])\n\n doPreprocess [\"--warn-interp=False\"] \"fnk02.hs\"\n \"module Main where\\n\\n\"\n\n doPreprocess [] \"fnk03.hs\"\n \"\\n\" -- empty contents\n\n doPreprocess [] \"fnk04.hs\"\n (ul [ \"module Main (\"\n , \" foo, main\"\n , \" ) where\"\n , \"import Data.Maybe ( fromMaybe )\"\n , \"import qualified Control.Monad as M\"\n , \"\\n\" ])\n\n doPreprocess [\"--pragma=DEADBEEF\"] \"fnk05.hs\"\n (ul [ \"module Main where\"\n , \"import Control.Monad\"\n , \"\\n\"\n ])\n\n doPreprocess [\"--warn-interp=False\"] \"fnk06.hs\"\n \"module Main where\\n\\n\"\n\n -- Haskell source code\n doPreprocess [\"--verbose=3\"] \"hs01.hs\"\n (ul [ \"module Main where\"\n , \"\"\n , \"main :: IO ()\"\n , \"main = putStrLn \\\"preprocess/hs01.hs\\\"\\n\"\n ])\n\n doPreprocess [\"--ignore\"] \"hs02.hs\"\n (ul [ \"-- Haskell code containing \\\";;;\\\" in the first line.\"\n , \"\"\n , \"module Main where\"\n , \"\"\n , \"main :: IO ()\"\n , \"main = putStrLn \\\"preprocess/hs02.hs\\\"\\n\"\n ])\n\n -- Finkel source code containing `defmodule'\n doPreprocess [] \"fnk11.hs\"\n \"module Main where\\n\\n\"\n\n doPreprocess [] \"fnk12.hs\"\n (ul [ \"module Main where\"\n , \"import Control.Monad ( forM_, when )\"\n , \"import qualified Data.ByteString as BS\"\n , \"import Data.Maybe hiding ( fromJust )\"\n , \"import Control.Applicative ( liftA3 )\"\n , \"\\n\"\n ])\n\n doPreprocess [] \"fnk13.hs\"\n \"module Main where\\n\\n\"\n\n -- Failures\n doPreprocessAndFail [\"--verbose=max\"] \"fnk01.hs\"\n doPreprocessAndFail [\"--warn-interp=3\"] \"fnk01.hs\"\n doPreprocessAndFail [] \"fnk14.hs\"\n doPreprocessAndFail [] \"fnk15.hs\"\n\ndoPreprocess :: [String] -> String -> String -> SpecWith FilePath\ndoPreprocess extra_args basename expected =\n it (\"should parse module header of \" ++ basename) $ \\opath -> do\n let ipath = pdir basename\n path_args = [ipath, ipath, opath]\n args = path_args ++ extra_args\n withArgs args (quietly defaultPreprocess)\n contents <- readFile opath\n contents `shouldBe` expected\n\ndoPreprocessAndFail :: [String] -> String -> SpecWith FilePath\ndoPreprocessAndFail extra_args basename =\n it (\"should preprocess and fail with \" ++ basename) $ \\opath -> do\n let ipath = pdir basename\n path_args = [ipath, ipath, opath]\n args = path_args ++ extra_args\n withArgs args (quietly defaultPreprocess)\n `shouldThrow` (\\(SomeException _) -> True)\n\nwithTemporaryFile :: (FilePath -> IO a) -> IO a\nwithTemporaryFile = bracket acquire cleanup\n where\n acquire = do\n tmp_dir <- getTemporaryDirectory\n let dir = tmp_dir \"preprocess\"\n file = dir \"tmp.hs\"\n createDirectoryIfMissing True dir\n pure file\n cleanup =\n removeDirectoryRecursive . takeDirectory\n\npdir :: FilePath\npdir = \"test\" \"data\" \"preprocess\"\n" }, { "path": "finkel-kernel/test/SyntaxTest.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE MagicHash #-}\n{-# LANGUAGE OverloadedStrings #-}\n-- | Tests for syntax.\n--\n-- All files under \"test/data\" directory with '.fnk' extension (i.e.:\n-- \"test/data/*.fnk\") are read and compiled, then type checked.\n--\nmodule SyntaxTest\n ( syntaxTests\n , syntaxFnkTests\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Monad (unless, when)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.IORef (atomicWriteIORef, newIORef, readIORef)\nimport Data.Maybe (fromMaybe)\nimport GHC.Exts (unsafeCoerce#)\nimport System.Environment (getExecutablePath)\nimport System.Info (os)\nimport System.IO (BufferMode (..), hSetBuffering, stdout)\n\n-- directory\nimport System.Directory (createDirectoryIfMissing, doesFileExist,\n getTemporaryDirectory, removeFile)\n\n-- filepath\nimport System.FilePath (takeBaseName, (<.>), ())\n\n-- ghc\nimport GHC (setContext, setTargets)\nimport GHC_Data_StringBuffer (stringToStringBuffer)\nimport GHC_Driver_Monad (GhcMonad (..))\nimport GHC_Settings_Config (cProjectVersionInt)\nimport GHC_Types_Basic (SuccessFlag (..))\nimport GHC_Types_Target (Target (..), TargetId (..))\n\n#if MIN_VERSION_ghc(9,4,0)\nimport GHC.Driver.Env (hscActiveUnitId)\n#endif\n\n-- hspec\nimport Test.Hspec\n\n-- silently\nimport System.IO.Silently (capture_)\n\n-- finkel-kernel\nimport Language.Finkel.Eval (evalExpr)\nimport Language.Finkel.Fnk (Fnk, prepareInterpreter, runFnk)\nimport Language.Finkel.Plugin (plugin, setFinkelPluginWithArgs)\nimport Language.Finkel.Syntax (parseExpr)\n\n-- Internal\nimport TestAux\n\nsyntaxTests :: Spec\nsyntaxTests = beforeAll getFnkTestResource syntaxFnkTests\n\nsyntaxFnkTests :: FnkSpec\nsyntaxFnkTests = runIO (getTestHsFiles \"syntax\") >>= mapM_ mkTest\n\nmkTest :: FilePath -> FnkSpec\nmkTest path\n | os == \"mingw32\"\n , base_name `elem` [\"0002-lexical\", \"0004-decls\", \"1001-quote\"]\n = describe path (it \"is pending under Windows\"\n (const (pendingWith \"Unicode not supported yet\")))\n | cProjectVersionInt == \"810\"\n , os == \"mingw32\"\n , base_name `elem` [\"1002-macro\", \"1003-eval-when-compile\"]\n = describe path (it \"is pending with ghc-8.10.1 under Windows\"\n (const (pendingWith \"Macro expansion not yet supported\")))\n | base_name == \"0003-expressions-2\"\n , ghcVersion < 900\n = describe path (it \"is pending under ghc < 9.0\"\n (const (pendingWith \"Generated Haskell code not working\")))\n | base_name `elem` [\"1004-doccomment-03\", \"2005-gadts-02\"]\n , ghcVersion >= 904\n = describe path (it \"is pending under ghc >= 9.4\"\n (const (pendingWith \"Warns with unusable UNPACK\")))\n | base_name == \"0003-expressions-3\"\n , ghcVersion >= 910\n = describe path (it \"is not supported in ghc >= 9.10\"\n (const (pendingWith \"`forall' is keyword by default\")))\n | base_name == \"2028-standalonekind\"\n , ghcVersion < 810\n = describe path (it \"is not supported in ghc < 8.10.1\"\n (const (pendingWith \"Not supported\")))\n | base_name == \"2029-impredicative\"\n , ghcVersion < 902\n = describe path (it \"is not reliable in ghc < 9.2\"\n (const (pendingWith \"Not supported\")))\n | otherwise = mkTest' path\n where\n base_name = takeBaseName path\n\nghcVersion :: Int\nghcVersion = __GLASGOW_HASKELL__\n\noptsToSuppressWarnings :: [(String, [String])]\noptsToSuppressWarnings =\n let flag test opt = if test then [opt] else []\n no_forall_identifier = flag (ghcVersion >= 904) \"-Wno-forall-identifier\"\n no_star_is_type = flag (ghcVersion >= 906) \"-Wno-star-is-type\"\n no_deprecated = flag (ghcVersion >= 906) \"-Wno-deprecated-flags\"\n in [ (\"0003-expressions-3\", no_forall_identifier)\n , (\"2010-kindsig\", no_star_is_type)\n , (\"2015-typefam\", no_star_is_type)\n\n -- TypeInType is deprecated in ghc >= 9.6\n , (\"2017-polykinds\", no_deprecated)\n ]\n\nmkTest' :: FilePath -> FnkSpec\nmkTest' path = do\n let mkRef = runIO . newIORef . error\n removeWhenExist file = do\n exist <- doesFileExist file\n when exist (removeFile file)\n\n tmpdir <- runIO getTemporaryDirectory\n fnkORef <- mkRef \"fnkORef\"\n hsORef <- mkRef \"hsORef\"\n\n let odir = tmpdir \"fnk_mk_test\"\n aDotOut = odir \"a.out\"\n dotHs = odir takeBaseName path <.> \"hs\"\n dotTix = \"a.out.tix\"\n syndir = \"test\" \"data\" \"syntax\"\n prepare = do\n removeArtifacts syndir\n mapM_ removeWhenExist [dotTix, aDotOut, dotHs]\n toNativeCompile = takeBaseName path == \"0008-ffi\"\n extra_opts =\n fromMaybe [] (lookup (takeBaseName path) optsToSuppressWarnings)\n compile =\n if toNativeCompile\n then nativeCompile extra_opts\n else byteCompile extra_opts\n\n runIO (do createDirectoryIfMissing True odir\n hSetBuffering stdout NoBuffering)\n\n beforeAll_ prepare $ describe path $ do\n it \"should compile Finkel code\" $ \\ftr -> do\n io <- runFnk (compile ftr path (Just odir)) fnkTestEnv\n unless toNativeCompile $ do\n capture_ io >>= atomicWriteIORef fnkORef\n\n it \"should dump Haskell source\" $ \\_ -> do\n exist <- doesFileExist dotHs\n exist `shouldBe` True\n\n it \"should compile dumped Haskell code\" $ \\ftr -> do\n io <- runFnk (compile ftr dotHs Nothing) fnkTestEnv\n unless toNativeCompile $\n capture_ io >>= atomicWriteIORef hsORef\n\n it \"should have same output\" $ \\_ -> do\n unless toNativeCompile $ do\n fnk <- readIORef fnkORef\n hs <- readIORef hsORef\n fnk `shouldBe` hs\n\nnativeCompile\n :: [String] -> FnkTestResource -> FilePath -> Maybe FilePath -> Fnk (IO ())\nnativeCompile = compileWith False\n\nbyteCompile\n :: [String] -> FnkTestResource -> FilePath -> Maybe FilePath -> Fnk (IO ())\nbyteCompile opts = compileWith True ([\"-no-link\", \"-fbyte-code\"] ++ opts)\n\ncompileWith\n :: Bool -> [String] -> FnkTestResource -> FilePath -> Maybe FilePath\n -> Fnk (IO ())\ncompileWith is_interpreting ini_args ftr file mb_dir = do\n parseAndSetDynFlags ini_args\n ftr_init ftr\n when is_interpreting prepareInterpreter\n let plugin_opts = maybe [] (\\d -> [\"--hsdir=\" <> d]) mb_dir\n me <- liftIO getExecutablePath\n parseAndSetDynFlags [\"-v0\", \"-F\", \"-pgmF\", me, \"-optF\", \"--no-warn-interp\"]\n setFinkelPluginWithArgs plugin plugin_opts\n _hsc_env <- getSession\n let target = Target { targetId = TargetFile file Nothing\n , targetAllowObjCode = not is_interpreting\n#if MIN_VERSION_ghc(9,4,0)\n , targetUnitId = hscActiveUnitId _hsc_env\n#endif\n , targetContents = Nothing }\n setTargets [target]\n success_flag <- ftr_load ftr [file]\n case success_flag of\n Failed -> error $ \"Failed to compile: \" ++ file\n Succeeded ->\n if is_interpreting\n then do\n -- Flush the stdout used by the compiled expression to get the string\n -- output, which is captured later.\n setContext [mkIIDecl \"Main\", mkIIDecl \"System.IO\"]\n let act = fmap unsafeCoerce# . evalExpr\n buf = stringToStringBuffer \"(>> main (hFlush stdout))\"\n evalWith (file ++ \":main\") parseExpr act buf\n else return (return ())\n" }, { "path": "finkel-kernel/test/TestAux.hs", "content": "{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE CPP #-}\n{-# LANGUAGE MagicHash #-}\n{-# LANGUAGE TypeApplications #-}\n-- | Miscellaneous auxiliary codes for tests.\nmodule TestAux\n ( FnkSpec\n , FnkTestResource(..)\n , getFnkTestResource\n , initSessionForTest\n , evalWith\n , mkIIDecl\n , parseAndSetDynFlags\n , removeArtifacts\n , fnkTestEnv\n , getTestFiles\n , getTestHsFiles\n , beforeAllWith\n , quietly\n ) where\n\n#include \"ghc_modules.h\"\n\n-- base\nimport Control.Exception (catch, fromException, throw, throwIO)\nimport Control.Monad (when)\nimport Control.Monad.IO.Class (MonadIO (..))\nimport Data.List (isSubsequenceOf, sort)\nimport Data.Maybe (fromMaybe)\nimport Data.Version (showVersion)\nimport System.Environment (getExecutablePath, lookupEnv,\n withArgs)\nimport System.Exit (ExitCode (..))\nimport System.IO (stderr, stdout)\n\n#if !MIN_VERSION_hspec(2,7,6)\nimport Control.Concurrent (MVar, modifyMVar, newMVar)\nimport Control.Exception (SomeException, try)\n#endif\n\n-- directory\nimport System.Directory (doesFileExist, getDirectoryContents,\n removeFile)\n\n-- filepath\nimport System.FilePath (joinPath, takeExtension, (<.>), ())\n\n-- ghc\nimport GHC (setContext)\nimport GHC_Data_FastString (fsLit)\nimport GHC_Data_StringBuffer (StringBuffer)\nimport GHC_Driver_Session (DynFlags (..), HasDynFlags (..),\n parseDynamicFlagsCmdLine)\nimport GHC_Hs_ImpExp (simpleImportDecl)\nimport GHC_Runtime_Context (InteractiveImport (..))\nimport GHC_Runtime_Eval (getContext)\nimport GHC_Types_Basic (SuccessFlag)\nimport GHC_Types_SrcLoc (noLoc)\nimport GHC_Unit_Module (mkModuleNameFS)\n\n-- hspec\nimport Test.Hspec (SpecWith)\n\n#if MIN_VERSION_hspec(2,7,6)\nimport Test.Hspec (beforeAllWith)\n#else\nimport Test.Hspec (beforeWith, runIO)\n#endif\n\n-- process\nimport System.Process (readProcess)\n\n-- silently\nimport System.IO.Silently (hSilence)\n\n-- fnk-kernel\nimport Language.Finkel (defaultFnkEnv)\nimport Language.Finkel.Builder (Builder)\nimport Language.Finkel.Expand (expands)\nimport Language.Finkel.Fnk (Fnk, FnkEnv (..), setDynFlags)\nimport Language.Finkel.Lexer (evalSP)\nimport Language.Finkel.Main (defaultMain)\nimport Language.Finkel.Make (buildHsSyn, initSessionForMake,\n simpleMake, withExpanderSettings)\nimport Language.Finkel.Reader (sexprs)\nimport qualified Paths_finkel_kernel\n\n\n-- -----------------------------------------------------------------------\n--\n-- Configured values from setup script\n--\n-- -----------------------------------------------------------------------\n\n#include \"finkel_kernel_config.h\"\n\ndistpref :: FilePath\n#ifdef FINKEL_KERNEL_CONFIG_DISTPREF\ndistpref = FINKEL_KERNEL_CONFIG_DISTPREF\n#else\ndistpref = error \"FINKEL_KERNEL_CONFIG_DISTPREF not defined\"\n#endif\n\n\n-- -----------------------------------------------------------------------\n--\n-- Auxiliary functions\n--\n-- -----------------------------------------------------------------------\n\n-- | Type synonym for hspec test taking 'FnkTestResource'.\ntype FnkSpec = SpecWith FnkTestResource\n\n-- | Test resource for finkel-kernel package tests.\ndata FnkTestResource =\n FnkTestResource\n { ftr_main :: [String] -> IO ()\n -- ^ Function to run 'defaultMain'.\n , ftr_init :: Fnk ()\n -- ^ Initialization action inside 'Fnk'.\n , ftr_load :: [FilePath] -> Fnk SuccessFlag\n -- ^ Function to load a module.\n -- , ftr_eval :: forall a b. String -> Builder a -> (a -> Fnk b)\n -- -> StringBuffer -> Fnk b\n -- -- ^ Function to evaluate an expression string, returns a string\n -- -- representation of evaluated result.\n , ftr_pkg_args :: [String]\n -- ^ Arguments for package.\n }\n\ngetFnkTestResource :: IO FnkTestResource\ngetFnkTestResource = do\n pkg_args <- getPackageArgs\n return (FnkTestResource { ftr_main = makeMain pkg_args\n , ftr_init = makeInit pkg_args\n , ftr_load = makeLoad\n , ftr_pkg_args = pkg_args\n })\n\nmakeMain :: [String] -> [String] -> IO ()\nmakeMain pkg_args other_args =\n catch (withArgs (pkg_args ++ other_args) (quietly defaultMain))\n (\\e -> case fromException e of\n Just ExitSuccess -> return ()\n _ -> throw e)\n\n-- XXX: Ignoring all messages, including messages for reporting error.\n-- Might be better to implement an option to redirect log outputs.\nquietly :: IO a -> IO a\nquietly = hSilence [stderr, stdout]\n\nmakeInit :: [String] -> Fnk ()\nmakeInit pkg_args = resetPackageEnv pkg_args >> initSessionForMake\n\ngetPackageArgs :: IO [String]\ngetPackageArgs =\n -- To support running the test without building the package, using the package\n -- db found in \"package.conf.inplace\" directory for inplace package db.\n --\n -- There is a \"dist-newstyle/packagedb\" directory for holding package data of\n -- project local packages, but the package db file will be written only after\n -- running the \"cabal v2-build\" command once, which means that running \"cabal\n -- v2-test\" will fail if \"v2-build\" were not invoked in advance.\n --\n -- The \"inpkacepkgconf\" is to support cabal-install v2-build, which uses\n -- \"PKGNAME-X.Y.Z-inplace\" format for inplace package.\n do let inplacedb = joinPath [distpref, \"package.conf.inplace\"]\n fkv = showVersion Paths_finkel_kernel.version\n inplacepkg = \"finkel-kernel-\" ++ fkv ++ \"-inplace\"\n inplacepkgconf = inplacedb inplacepkg <.> \"conf\"\n\n has_inplacepkgconf <- doesFileExist inplacepkgconf\n snapshotdb <- getSnapshotDb\n\n let inplacedbs =\n if has_inplacepkgconf\n then [ \"-package-db\", inplacedb\n , \"-package-id\", inplacepkg ]\n else [ \"-package-db\", inplacedb ]\n args = [ \"-clear-package-db\"\n , \"-global-package-db\"\n\n -- For overloaded label test which imports `GHC.Types' module.\n , \"-package\", \"ghc-prim\"\n ] ++ inplacedbs ++ snapshotdb\n\n return args\n\n-- Note: [Snapthos package database for stack]\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n--\n-- In ghc 9.0.1, the \"exceptions\" package has been added to the bundled packages\n-- shipped with ghc, to make \"Ghc\" monad as an instance of the type classes\n-- defined in \"Control.Monad.Catch\". Finkel followed this change and made \"Fnk\"\n-- as an instance of the type classes defined in \"Control.Monad.Catch\", and back\n-- ported the change. When running the stack with ghc version prior to 9.0.1,\n-- the \"exceptions\" package is installed in non-bundled package database. Thus,\n-- getting the snapshot package database with \"stack path\n-- --snapshot-pkg-db\".\n\ngetSnapshotDb :: IO [String]\ngetSnapshotDb = do\n me <- getExecutablePath\n let is_stack = \".stack\" `isSubsequenceOf` me\n if is_stack\n then do\n mb_resolver <- lookupEnv \"RESOLVER\"\n let resolver = fromMaybe \"lts-16\" mb_resolver\n ret <- readProcess \"stack\" [\"--resolver=\" ++ resolver\n ,\"path\", \"--snapshot-pkg-db\"]\n \"\"\n let snapshot_db = filter (not . null) (lines ret)\n return (\"-package-db\" : snapshot_db)\n else return []\n\n-- | Reset package environment to support running the test with cabal-install.\nresetPackageEnv :: [String] -> Fnk ()\nresetPackageEnv pkg_args = do\n dflags0 <- getDynFlags\n let largs = map noLoc pkg_args\n dflags1 = clearPackageEnv dflags0\n (dflags2, _, _) <- parseDynamicFlagsCmdLine dflags1 largs\n setDynFlags dflags2\n\n-- | Clear 'packageEnv' field in 'DynFlags'.\nclearPackageEnv :: DynFlags -> DynFlags\n-- Use of \"-\" to reset package env is NOT supported until 8.4.4.\nclearPackageEnv dflags = dflags {packageEnv = Just \"-\"}\n\nparseAndSetDynFlags :: [String] -> Fnk ()\nparseAndSetDynFlags args = do\n dflags0 <- getDynFlags\n (dflags1,_,_) <- parseDynamicFlagsCmdLine dflags0 (map noLoc args)\n setDynFlags dflags1\n\nmakeLoad :: [FilePath] -> Fnk SuccessFlag\nmakeLoad files = simpleMake (map (\\p -> (noLoc p, Nothing)) files) False Nothing\n\nevalWith :: String -> Builder a -> (a -> Fnk b) -> StringBuffer -> Fnk b\nevalWith !label !parser !act !input = do\n case evalSP sexprs (Just label) input of\n Right form0 -> do\n !form1 <- withExpanderSettings (prepare >> expands form0)\n !hthing <- buildHsSyn parser form1\n act hthing\n Left err -> liftIO (throwIO err)\n where\n -- Adding 'Prelude' and 'Language.Finkel' to interactive context, since the\n -- codes in the file does not contain ':require' forms.\n prepare = do\n ctxt <- getContext\n setContext (mkIIDecl \"Prelude\" : mkIIDecl \"Language.Finkel\" : ctxt)\n -- mkII = IIDecl . simpleImportDecl . mkModuleNameFS . fsLit\n\nmkIIDecl :: String -> InteractiveImport\nmkIIDecl = IIDecl . simpleImportDecl . mkModuleNameFS . fsLit\n\n-- | Reset package env and initialize session with 'initSessionForMake'.\ninitSessionForTest :: Fnk ()\ninitSessionForTest = liftIO getPackageArgs >>= makeInit\n\n-- | Remove compiled artifacts, such as @.o@ and @.hi@ files.\nremoveArtifacts :: FilePath -> IO ()\nremoveArtifacts dir = do\n contents <- getDirectoryContents dir\n mapM_ removeObjAndHi contents\n where\n removeObjAndHi file =\n when (takeExtension file `elem` [ \".o\", \".hi\"\n , \".p_o\", \".p_hi\"\n , \".dyn_o\", \".dyn_hi\"\n , \".hscpp\" ])\n (removeFile (dir file))\n\n-- | The 'FnkEnv' used for test. Has 'envLibDir' field from CPP header file.\nfnkTestEnv :: FnkEnv\nfnkTestEnv = defaultFnkEnv {envLibDir = Just FINKEL_KERNEL_LIBDIR}\n\n-- | Get files with @.fnk@ extension under test data directory.\ngetTestFiles :: String -- ^ Name of the sub directory under test data directory.\n -> IO [FilePath]\ngetTestFiles = getTestFilesBy \".fnk\"\n\n-- | Get files with @.hs@ extension under test data directory.\ngetTestHsFiles :: String -> IO [FilePath]\ngetTestHsFiles = getTestFilesBy \".hs\"\n\ngetTestFilesBy :: String -- ^ File extension of interest.\n -> String -- ^ Name of the sub directory under test data directory.\n -> IO [FilePath]\ngetTestFilesBy ext name =\n let dir = \"test\" \"data\" name\n f x acc = if takeExtension x == ext\n then (dir x) : acc\n else acc\n files = getDirectoryContents dir\n in sort . foldr f [] <$> files\n\n#if !MIN_VERSION_hspec(2,7,6)\n-- \"Test.Hspec.Core.Hooks.beforeAllWith\" did not exist.\nbeforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b\nbeforeAllWith action spec = do\n mvar <- runIO (newMVar Nothing)\n beforeWith (memoize mvar . action) spec\n\nmemoize :: MVar (Maybe a) -> IO a -> IO a\nmemoize mvar action = do\n et_result <- modifyMVar mvar $ \\mb_val -> do\n case mb_val of\n Nothing -> do\n et_val <- try @ SomeException action\n case et_val of\n Left err -> return (Nothing, Left err)\n Right val -> return (Just val, Right val)\n Just val -> return (Just val, Right val)\n either throwIO return et_result\n#endif\n" }, { "path": "finkel-kernel/test/data/eval/0001-simple.fnk", "content": ";;;; -*- mode: finkel -*-\n\n(let ((:: x y Code)\n (= x '(a b c))\n (= y '(foo a b c))\n\n (:: cdr (-> Code Code))\n (= cdr (LForm (L l (List (: _ rest))))\n (LForm (L l (List rest))))\n\n (:: fib (-> Int Int))\n (= fib n\n (if (< n 2)\n n\n (+ (fib (- n 1))\n (fib (- n 2))))))\n\n (all id [(== 'foo 'foo)\n (== x (cdr y))\n (== (fib 10) 55)]))\n" }, { "path": "finkel-kernel/test/data/eval/0002-shadowing-macro.fnk", "content": ";;;; -*- mode: finkel -*-\n\n;;; Expression to test name shadowing with conflictinging names bounded\n;;; to macro with `with-macro' and locally declared function with `let'.\n\n(:with-macro ((= foo\n (Macro (\\form\n (case form\n (LForm (L _ (List [_ body])))\n (return `(++ \"with-macro: \" ,body))\n _ (error (++ \"foo: got `\" (show form) \"'\")))))))\n (all id [(== (foo \"bar\")\n \"with-macro: bar\")\n\n ;; Bind `foo' to locally declared function.\n (== (let ((= foo body\n (++ \"let: \" body)))\n (foo \"bar\"))\n \"let: bar\")\n\n ;; The macro `foo' is still in current scope.\n (== (foo \"bar\")\n \"with-macro: bar\")\n\n ;; Bind `foo' with pattern matching.\n (== (let ((= (: foo _)\n [\"local let\"\n \"local bar\"\n \"local buzz\"]))\n foo)\n \"local let\")\n (== (let ((= (@ bar (Just foo))\n (return \"let: bar\")))\n foo)\n \"let: bar\")\n (== (let ((= (@ foo (Just bar))\n (return \"let: bar\")))\n foo)\n (Just \"let: bar\"))\n (== (let ((= [foo _ _]\n [\"let: bar\" \"\" \"\"]))\n foo)\n \"let: bar\")\n\n ;; Bind `foo' to function binding argument.\n (== (let ((= f1 foo\n (foo \"bar\")))\n (f1 (++ \"let: \")))\n \"let: bar\")\n\n ;; Bind `foo' to lambda argument.\n (== (let ((= f2\n (\\foo (foo \"bar\"))))\n (f2 (++ \"let: \")))\n \"let: bar\")\n\n ;; Bind `foo' in do-notation.\n (== (do (<- foo (return (\\x (Just (++ \"do: \" x)))))\n (foo \"bar\"))\n (Just \"do: bar\"))\n\n ;; Bind `foo' in do-notation after using `foo'. The first use\n ;; of `foo' is from `with-macro', and the second use is\n ;; locally bounded function.\n (== (do (<- x (return (foo \"bar\")))\n (<- foo (return (\\x (++ \"do: \" x))))\n (return (, x (foo \"buzz\"))))\n (Just (, \"with-macro: bar\" \"do: buzz\")))\n\n ;; Pattern match in `case' expression\n (== (case (Just (++ \"let: \"))\n (Just foo) (foo \"bar\"))\n \"let: bar\")\n\n (== (case (Just (++ \"let: \"))\n (Just foo) (where bar\n (= bar (foo \"bar\"))))\n \"let: bar\")\n\n ;; Shadowing with `where'\n (== (case ()\n _ (where (foo \"bar\")\n (= foo (++ \"let: \"))))\n \"let: bar\")\n (== (case ()\n _ (where (bar \"bar\")\n (= bar foo\n (++ \"let: \" foo))))\n \"let: bar\")]))\n" }, { "path": "finkel-kernel/test/data/eval/0003-expand1.fnk", "content": "(:with-macro ((= foo\n (Macro (\\ (LForm (L _ (List [_ x])))\n (return `(do (print ,x)\n (print ,x))))))\n (= mex1\n (Macro (\\ (LForm (L _ (List [_ x])))\n (do (<- expanded (expand1 x))\n (return `',expanded))))))\n (== (mex1 (foo \"bar\"))\n '(do (print \"bar\")\n (print \"bar\"))))\n" }, { "path": "finkel-kernel/test/data/eval/0004-unquote-unquote-splice.fnk", "content": ";;;; -*- mode: finkel -*-\n\n;;; Expression containing \",,@(...)\".\n\n(:with-macro ((= m1\n (Macro\n (const\n (return\n `(let ((= foo #'a)\n (= bar 'v1)\n (= buzz 'v2))\n `(let (,,@(map (\\n ``(= ,,n #'b)) ['bar 'buzz]))\n [,foo ,bar ,buzz])))))))\n (== (m1)\n '(let ((= v1 #'b)\n (= v2 #'b))\n [#'a v1 v2])))\n" }, { "path": "finkel-kernel/test/data/exception/0001-invalid-unquote-splice.hs", "content": "(:eval-when-compile\n (import Prelude)\n (import Language.Finkel)\n (import Control.Monad.IO.Class (liftIO))\n\n (:: m Macro)\n (= m\n (Macro (\\ (LForm (L _ (List [_ arg1])))\n (return `(:a 1 :b ,@arg1))))))\n\n(:: main (IO ()))\n(= main\n (print (m foo)))\n" }, { "path": "finkel-kernel/test/data/exception/0002-invalid-string-literal.hs", "content": "(= main\n (print \"foo))\n" }, { "path": "finkel-kernel/test/data/exception/0003-malformed-qq.hs", "content": "(:: main (IO ()))\n(= main\n (print (:quasiquote foo bar buzz)))\n" }, { "path": "finkel-kernel/test/data/main/MyMain.hs", "content": ";;; -*- mode: finkel -*-\n\n(module MyMain)\n\n(:: my-main (IO ()))\n(= my-main (putStrLn \"From MyMain.my-main\"))\n" }, { "path": "finkel-kernel/test/data/main/m001.hs", "content": ";;; -*- mode: finkel -*-\n\n(= main (putStrLn \"Hello, world!\"))\n" }, { "path": "finkel-kernel/test/data/main/m002.hs", "content": "main = putStrLn \"Hello, world!\"\n" }, { "path": "finkel-kernel/test/data/main/m003.c", "content": "#include \n\nvoid hello() {\n printf(\"Hello, world!\\n\");\n}\n" }, { "path": "finkel-kernel/test/data/make/E01.hs", "content": "(module ModuleNameMismatch\n foo bar buzz)\n\n(:: foo bar buzz Int)\n(= foo 1)\n(= bar 2)\n(= buzz 3)\n" }, { "path": "finkel-kernel/test/data/make/E02.hs", "content": "(module Main)\n\n(import NoSuchModule)\n\n(:: foo Int)\n(= foo 42)\n" }, { "path": "finkel-kernel/test/data/make/M1.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M1)\n\n(:: main (IO ()))\n(= main\n (putStrLn \"From M1.main\"))\n" }, { "path": "finkel-kernel/test/data/make/M2.hs", "content": "module M2 where\n\nimport Data.List\nimport qualified M1\n\nmain :: IO ()\nmain = do\n M1.main\n putStrLn (concat (intersperse \" \" [\"From\", \"M2.main\"]))\n" }, { "path": "finkel-kernel/test/data/make/M3.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M3 greet (Greet ..) (Greetable ..))\n\n(import Language.Finkel)\n\n(newtype (Greet a) (Greet a))\n\n(class (Greetable a)\n (:: gg (-> a String)))\n\n(:: greet Macro)\n(= greet\n (Macro (\\form\n (case (unCode form)\n (List [_ body]) (return `(putStrLn ,body))\n _ (finkelSrcError form \"greet: malformed body\")))))\n" }, { "path": "finkel-kernel/test/data/make/M4/A.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M4.A m4a)\n\n(:: m4a Int)\n(= m4a 4)\n" }, { "path": "finkel-kernel/test/data/make/M4/B.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M4.B)\n\n(:: m4b String)\n(= m4b \"m4b\")\n" }, { "path": "finkel-kernel/test/data/make/M4.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M4 m4 m4a m4b)\n\n(import M4.A)\n(import M4.B)\n\n(:: m4 (IO ()))\n(= m4 (putStrLn (++ \"M4.m4: m4a=\" (show m4a) \", m4b=\" (show m4b))))\n" }, { "path": "finkel-kernel/test/data/make/M5.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M5 m5)\n\n(import M4)\n\n(:: m5 (IO ()))\n(= m5 (putStrLn (++ \"From M5.m5: m4b=\" m4b)))\n" }, { "path": "finkel-kernel/test/data/make/M6/A.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M6.A m6a1 m6a2)\n\n(import Language.Finkel)\n\n(:: m6a1 Macro)\n(= m6a1 (Macro\n (\\form\n (case (unCode form)\n (List [_]) (return `(putStrLn \"From M6.A.m6a1\"))\n _ (error \"m6a1\")))))\n\n(:: m6a2 Macro)\n(= m6a2 (Macro\n (\\form\n (case (unCode form)\n (List [_]) (return `(putStrLn \"From M6.A.m6a2\"))\n _ (error \"m6a2\")))))\n" }, { "path": "finkel-kernel/test/data/make/M6/B.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M6.B m6b1 m6b2)\n\n(import Language.Finkel)\n\n(:: m6b1 Macro)\n(= m6b1 (Macro\n (\\form\n (case (unCode form)\n (List [_]) (return `(putStrLn \"From M6.B.m6b1\"))\n _ (error \"m6b1\")))))\n\n(:: m6b2 Macro)\n(= m6b2 (Macro\n (\\form\n (case (unCode form)\n (List [_]) (return `(putStrLn \"From M6.B.m6b2\"))\n _ (error \"m6b2\")))))\n" }, { "path": "finkel-kernel/test/data/make/P1.hs", "content": ";;; -*- mode: finkel -*-\n\n%p(LANGUAGE DeriveDataTypeable\n DeriveGeneric\n OverloadedStrings)\n\n(module P1\n (D ..) define-macro)\n\n(import Language.Finkel)\n(import Data.Data)\n(import GHC.Generics ((Generic ..)))\n\n(data D D1 D2 D3\n (deriving Bounded Enum Eq Ord Show Read Data Typeable Generic))\n\n(instance (Homoiconic D))\n\n(:: dmac (-> Code (Fnk Code)))\n(= dmac form\n (let ((:: make-tsig (-> Code Code))\n (= make-tsig name `(:: ,name Macro))\n (:: macro-decl (-> Code Code Code (Fnk Code)))\n (= macro-decl name arg body\n (do (<- tmp (gensym' (show name)))\n (return `(= ,name\n (let ((:: ,tmp (-> Code (Fnk Code)))\n (= ,tmp ,arg ,body))\n (Macro ,tmp)))))))\n (case (unCode form)\n (List [_ name arg body])\n (do (<- decl (macro-decl name arg body))\n (return `(:begin\n ,(make-tsig name)\n ,decl)))\n\n (List [_ name (@ doc (LForm (L _ (Atom (AString {}))))) arg body])\n (do (<- decl (macro-decl name arg body))\n (return `(:begin\n ,(make-tsig name)\n (:doc^ ,doc)\n ,decl)))\n\n _ (finkelSrcError form (++ \"dmac: malformed macro: \" (show form))))))\n %p(INLINABLE dmac)\n\n(:: define-macro Macro)\n(= define-macro (Macro dmac))\n" }, { "path": "finkel-kernel/test/data/make/P2.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require P1)\n\n(module P2)\n\n(:eval-when-compile\n (import Prelude)\n (import Language.Finkel))\n\n(import Language.Finkel)\n(import P1)\n\n(:eval-when-compile\n (define-macro define-foo form\n (case (unCode form)\n (List [_ name]) (return `(define-macro ,name _args\n (return '(putStrLn \"foo\"))))\n _ (finkelSrcError form \"define-foo: error\")))\n\n (:: show-d-fn (-> D Code))\n (= show-d-fn d `(show ,d))\n\n (define-macro show-d form\n (case (unCode form)\n (List [_ o]) (| ((<- (Just d) (fromCode o))\n (return `(,(show-d-fn d))))\n (otherwise\n (finkelSrcError form (++ \"say-d: cannot get D from `\"\n (show o) \"'\"))))\n _ (finkelSrcError form \"say-d: error\"))))\n\n(define-foo foo)\n\n(:: print-d (-> D (IO ())))\n(= print-d d (putStrLn (show-d D2)))\n" }, { "path": "finkel-kernel/test/data/make/P3.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require P1)\n\n(module P3)\n\n(:eval-when-compile\n (import Prelude)\n (import Language.Finkel))\n\n(import Language.Finkel)\n\n(:eval-when-compile\n (define-macro define-bar form\n (case (unCode form)\n (List [_ name]) (return\n `(define-macro ,name _\n (return '(return \"bar from define-bar\")))))))\n\n(define-bar bar)\n" }, { "path": "finkel-kernel/test/data/make/R01.hs.1", "content": ";;;; -*- mode: finkel -*-\n\n(module R01)\n\n(import Language.Finkel)\n\n(:: foo-function String)\n(= foo-function \"foo: before\")\n\n(:: foo-macro Macro)\n(= foo-macro (Macro (const (return (toCode foo-function)))))\n" }, { "path": "finkel-kernel/test/data/make/R01.hs.2", "content": ";;;; -*- mode: finkel -*-\n\n(module R01)\n\n(import Language.Finkel)\n\n(:: foo-function String)\n(= foo-function \"foo: after\")\n\n(:: foo-macro Macro)\n(= foo-macro (Macro (const (return (toCode foo-function)))))\n" }, { "path": "finkel-kernel/test/data/make/R02.hs", "content": ";;; -*- mode: finkel -*-\n\n(module R02)\n\n(import R01)\n\n(:: foo String)\n(= foo foo-function)\n" }, { "path": "finkel-kernel/test/data/make/R03.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require R01)\n\n(module R03)\n\n(:: foo String)\n(= foo (foo-macro))\n" }, { "path": "finkel-kernel/test/data/make/R04.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require R01)\n\n(module R04)\n\n(:: foo String)\n(= foo (foo-macro))\n\n(:: main (IO ()))\n(= main (putStrLn (foo-macro)))\n" }, { "path": "finkel-kernel/test/data/make/R05.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require R05a)\n\n(module R05)\n\n(:: main (IO ()))\n(= main (putStrLn (r05a)))\n" }, { "path": "finkel-kernel/test/data/make/R05a.hs", "content": ";;; -*- mode: finkel -*-\n\n(module R05a)\n\n(import Language.Finkel)\n(import R01)\n\n(:: r05a Macro)\n(= r05a (Macro (const (return (toCode foo-function)))))\n" }, { "path": "finkel-kernel/test/data/make/R06.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require R06a)\n\n(module R06)\n\n(:: main (IO ()))\n(= main (putStrLn (r06a)))\n" }, { "path": "finkel-kernel/test/data/make/R06a.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require R01)\n\n(module R06a)\n\n(import Language.Finkel)\n\n(:: r06a Macro)\n(= r06a (Macro\n (const (do (let ((= x (foo-macro))))\n (return (toCode x))))))\n" }, { "path": "finkel-kernel/test/data/make/R07.hs", "content": ";;; -*- mode: finkel -*-\n\n;;; R07 --require-> R07a --require-> R07b --require-> R01\n\n(:require R07a)\n\n(module R07)\n\n(:: main (IO ()))\n(= main (putStrLn (r07a)))\n" }, { "path": "finkel-kernel/test/data/make/R07a.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require R07b)\n\n(module R07a)\n\n(import Language.Finkel)\n\n(:: r07a Macro)\n(= r07a (Macro (const (return (toCode (r07b))))))\n" }, { "path": "finkel-kernel/test/data/make/R07b.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require R01)\n\n(module R07b)\n\n(import Language.Finkel)\n\n(:: r07b Macro)\n(= r07b (Macro (const (return (toCode (foo-macro))))))\n" }, { "path": "finkel-kernel/test/data/make/R08.hs", "content": ";;; -*- mode: finkel -*-\n\n;;; R08 --require-> R08a --require-> R08b --import-> R01\n\n(:require R08a)\n\n(module R08)\n\n(:: main (IO ()))\n(= main (putStrLn (r08a)))\n" }, { "path": "finkel-kernel/test/data/make/R08a.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require R08b)\n\n(module R08a)\n\n(import Language.Finkel)\n\n(:: r08a Macro)\n(= r08a (Macro (const (return (toCode (r08b))))))\n" }, { "path": "finkel-kernel/test/data/make/R08b.hs", "content": ";;; -*- mode: finkel -*-\n\n(module R08b)\n\n(import R01)\n\n(import Language.Finkel)\n\n(:: r08b Macro)\n(= r08b (Macro (const (return (toCode foo-function)))))\n" }, { "path": "finkel-kernel/test/data/make/R09.hs", "content": ";;; -*- mode: finkel -*-\n\n;;; R09 --require-> R09a --import-> R09b --require-> R01\n\n(:require R09a)\n\n(module R09)\n\n(:: main (IO ()))\n(= main (putStrLn (r09a)))\n" }, { "path": "finkel-kernel/test/data/make/R09a.hs", "content": ";;; -*- mode: finkel -*-\n\n(module R09a)\n\n(import Language.Finkel)\n(import R09b)\n\n(:: r09a Macro)\n(= r09a (Macro (const (return (toCode r09b)))))\n" }, { "path": "finkel-kernel/test/data/make/R09b.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require R01)\n\n(module R09b)\n\n(:: r09b String)\n(= r09b (foo-macro))\n" }, { "path": "finkel-kernel/test/data/make/R10.hs", "content": ";;; -*- mode: finkel -*-\n\n;;; R10 --require-> R10a --import-> R10b --import-> R01\n\n(:require R10a)\n\n(module R10)\n\n(:: main (IO ()))\n(= main (putStrLn (r10a)))\n" }, { "path": "finkel-kernel/test/data/make/R10a.hs", "content": ";;; -*- mode: finkel -*-\n\n(module R10a)\n\n(import Language.Finkel)\n(import R10b)\n\n(:: r10a Macro)\n(= r10a (Macro (const (return (toCode r10b)))))\n" }, { "path": "finkel-kernel/test/data/make/R10b.hs", "content": ";;; -*- mode: finkel -*-\n\n(module R10b)\n\n(import R01)\n\n(:: r10b String)\n(= r10b foo-function)\n" }, { "path": "finkel-kernel/test/data/make/R11.hs", "content": ";;; -*- mode: finkel -*-\n\n;;; R11 --import-> {R11a, R11b} --import-> R01\n\n(module R11)\n\n(import R11a)\n(import R11b)\n\n(:: main (IO ()))\n(= main (r11a r11b))\n" }, { "path": "finkel-kernel/test/data/make/R11a.hs", "content": ";;; -*- mode: finkel -*-\n\n(module R11a)\n\n(import R01)\n\n(:: r11a (-> String (IO ())))\n(= r11a putStrLn)\n\n(:: r11a-run (IO ()))\n(= r11a-run (r11a foo-function))\n" }, { "path": "finkel-kernel/test/data/make/R11b.hs", "content": ";;; -*- mode: finkel -*-\n\n(module R11b)\n\n(import R01)\n\n(:: r11b String)\n(= r11b foo-function)\n" }, { "path": "finkel-kernel/test/data/make/cbits1.c", "content": "#include \n\nint f1(int x);\n\nint f1(int x)\n{\n return x + 1;\n}\n" }, { "path": "finkel-kernel/test/data/make/cbits2.c", "content": "#include \n\nint f2(int x);\n\nint f2(int x)\n{\n return x + 2;\n}\n" }, { "path": "finkel-kernel/test/data/make/cbits3.c", "content": "#include \n\nint f3(int x);\n\nint f3(int x)\n{\n return x + 3;\n}\n" }, { "path": "finkel-kernel/test/data/make/main1.hs", "content": ";;;; -*- mode: finkel -*-\n\n(module Main)\n\n(:: main (IO ()))\n(= main\n (putStrLn \"From main1.hs\"))\n" }, { "path": "finkel-kernel/test/data/make/main2.hs", "content": ";;;; -*- mode: finkel -*-\n\n(module Main)\n\n(import qualified M1)\n\n(:: main (IO ()))\n(= main\n M1.main)\n" }, { "path": "finkel-kernel/test/data/make/main3.hs", "content": ";;;; -*- mode: finkel -*-\n\n;;; Main module importing Haskell module.\n\n(import qualified M2)\n\n(:: main (IO ()))\n(= main (M2.main))\n" }, { "path": "finkel-kernel/test/data/make/main4.hs", "content": ";;; -*- mode: finkel -*-\n\n(:require M3 (greet))\n(:require Control.Monad)\n\n(module Main)\n\n(:: main (IO ()))\n(= main\n (greet \"From main4.main\"))\n" }, { "path": "finkel-kernel/test/data/make/main5.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(import qualified M1)\n(import qualified M2)\n\n(:: main (IO ()))\n(= main\n (do (putStrLn \"From main5.hs\")\n M1.main\n M2.main))\n" }, { "path": "finkel-kernel/test/data/make/main6.hs", "content": ";;; -*- mode: finkel -*-\n\n(:: main (IO ()))\n(= main\n (do (print (f1 41))\n (print (f2 40))\n (print (f3 39))))\n\n(foreign import ccall safe \"f1\" (:: f1 (-> Int Int)))\n(foreign import ccall safe \"f2\" (:: f2 (-> Int Int)))\n(foreign import ccall safe \"f3\" (:: f3 (-> Int Int)))\n" }, { "path": "finkel-kernel/test/data/make/main7.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(import M5)\n(import M4)\n\n(:: main (IO ()))\n(= main (>> m4 m5))\n" }, { "path": "finkel-kernel/test/data/make/main8.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(:eval-when-compile\n (import Prelude)\n (import Language.Finkel))\n\n(:eval-when-compile\n (:: m1 Macro)\n (= m1 (Macro (\\_ (return `(putStrLn \"From m1\"))))))\n\n(:: main (IO ()))\n(= main (m1))\n" }, { "path": "finkel-kernel/test/data/make/main9.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(:require M6.A hiding (m6a2))\n(:require M6.B (m6b1))\n\n(:: m6a2 (-> Int (IO ())))\n(= m6a2 x (putStrLn (++ \"From main9.m6a2: \" (show x))))\n\n(:: m6b2 (-> Int (IO ())))\n(= m6b2 x (putStrLn (++ \"From main9.m6b2: \" (show x))))\n\n(:: main (IO ()))\n(= main\n (do (m6a1)\n (m6a2 42)\n (m6b1)\n (m6b2 42)))\n" }, { "path": "finkel-kernel/test/data/plugin/M01.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M01)\n\n(import Language.Finkel)\n\n(:: m01 Macro)\n(= m01 (Macro (const (pure '(putStrLn \"plugin/M01.hs\"))) ))\n" }, { "path": "finkel-kernel/test/data/plugin/M02.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M02)\n\n(:require M01)\n\n(:: m02 (IO ()))\n(= m02\n (do (m01)\n (putStrLn \"plugin/M02.hs\")))\n" }, { "path": "finkel-kernel/test/data/plugin/M03.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M03)\n\n(:require M01)\n\n(:: m03 (IO ()))\n(= m03\n (do (m01)\n (putStrLn \"plugin/M03.hs\")))\n" }, { "path": "finkel-kernel/test/data/plugin/M04.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M04)\n\n(import Control.Monad.IO.Class)\n(import Language.Finkel)\n\n(:require M04b)\n\n(defmac m04 []\n '(putStrLn \"M04.m04\"))\n\n" }, { "path": "finkel-kernel/test/data/plugin/M04b.hs", "content": ";;; -*- mode: finkel -*-\n\n(module M04b)\n\n(import Language.Finkel)\n\n(:: defmac Macro)\n(= defmac\n (Macro (\\ (LForm (L _ (List (: _ forms))))\n (case forms\n [name args body] (pure `(:begin\n (:: ,name Macro)\n (= ,name\n (Macro\n (\\ (LForm (L _ (List (: _ _forms))))\n (case _forms\n ,args (pure ,body)\n _ (error \"defmac: yikes!\")))))))\n _ (error \"defmac: ahh!\")))))\n" }, { "path": "finkel-kernel/test/data/plugin/p01.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(:: main (IO ()))\n(= main (putStrLn \"plugin/p01.hs\"))\n\n" }, { "path": "finkel-kernel/test/data/plugin/p02.hs", "content": "module Main where\n\nmain :: IO ()\nmain = putStrLn \"plugin/p02.hs\"\n" }, { "path": "finkel-kernel/test/data/plugin/p03.hs", "content": ";;; -*- mode: finkel -*-\n\n(:eval-when-compile\n (import Prelude)\n (import Language.Finkel)\n (:: m1 Macro)\n (= m1\n (Macro\n (const (pure '(putStrLn \"plugin/p03.hs\"))))))\n\n(:: main (IO ()))\n(= main (m1))\n" }, { "path": "finkel-kernel/test/data/plugin/p04.hs", "content": "-- Haskell source code containing ;;; in the first line\n\nmodule Main where\n\nmain :: IO ()\nmain = putStrLn \"plugin/p04.hs\"\n" }, { "path": "finkel-kernel/test/data/plugin/p05.hs", "content": "-- File containing the magic finkel pragma in the first line.\n{-# OPTIONS_GHC -optF --ignore #-}\n{-# OPTIONS_GHC -fplugin-opt=Language.Finkel.Plugin:--ignore #-}\n\nmodule Main where\n\nmain :: IO ()\nmain = putStrLn \"plugin/p05.hs\"\n" }, { "path": "finkel-kernel/test/data/plugin/p06.hs", "content": ";;; -*- mode: finkel -*-\n\n(:eval-when-compile\n (import Prelude)\n (import Language.Finkel)\n (:: m1 Macro)\n (= m1\n (Macro\n (\\_ (do (<- tmp gensym)\n (pure `(let ((= ,tmp (not True)))\n (print ,tmp))))))))\n\n(module Main)\n\n(:: main (IO ()))\n(= main (m1))\n" }, { "path": "finkel-kernel/test/data/plugin/p07.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(:: main (IO ()))\n(== main (putStrLn \"foo\"))\n" }, { "path": "finkel-kernel/test/data/plugin/p08.hs", "content": "main = putStrLn \"plugin/p08.hs\"\n" }, { "path": "finkel-kernel/test/data/plugin/p09.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(:require M01)\n\n(:: main (IO ()))\n(= main (m01))\n" }, { "path": "finkel-kernel/test/data/plugin/p10.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(import M02)\n(import M03)\n\n(:: main (IO ()))\n(= main\n (do m02\n m03))\n" }, { "path": "finkel-kernel/test/data/plugin/p11.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(:require M04)\n\n(:: main (IO ()))\n(= main (m04))\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk01.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(:: main (IO ()))\n(= main (putStrLn \"preprocess/fnk01.hs\"))\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk02.hs", "content": ";;; -*- mode: finkel -*-\n\n(:eval-when-compile\n (import Prelude)\n (import Language.Finkel)\n (:: m1 Macro)\n (= m1 (Macro (const (pure '(putStrLn \"preprocess/fnk02.hs\"))))))\n\n(module Main)\n\n(:: main (IO ()))\n(= main (m1))\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk03.hs", "content": ";;; -*- mode: finkel -*-\n\n(:: main (IO ()))\n(= main (putStrLn \"preprocess/fnk03.hs\"))\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk04.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main\n foo\n main)\n\n(import Data.Maybe (fromMaybe))\n(import qualified Control.Monad as M)\n\n(:: main (IO ()))\n(= main\n (M.forM- print (Just foo)))\n\n(:: foo Bool)\n(= foo (fromMaybe True Nothing))\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk05.hs", "content": "; Using DEADBEEF as pragma string\n\n(module Main)\n\n(import Control.Monad)\n\n(:: main (IO ()))\n(= main (forM- (Just \"From fnk05.hs\") putStrLn))\n\n;;; Local variables:\n;;; mode: finkel\n;;; fill-columns: 72\n;;; comment-column: 0\n;;; End:\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk06.hs", "content": ";;; -*- mode: finkel -*-\n\n;;; Macro codes\n\n(:eval-when-compile\n (import Prelude)\n (import Language.Finkel)\n (:: m1 Macro)\n (= m1\n (Macro\n (const (pure '(putStr (unlines [\"=====================\"\n \"From dummy02/exe01.hs\"\n \"=====================\"])))))))\n\n;;; Module sources code\n\n(module Main)\n\n(:: main (IO ()))\n(= main (print True))\n\n\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk11.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule Main)\n\n(:: main (IO ()))\n(= main (putStrLn \"preprocess/fnk11.hs\"))\n\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk12.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule Main\n (require\n (Required.Modules.Are.Ignored.In.Downsweep))\n (import\n (Control.Monad [forM- when])\n (qualified Data.ByteString as BS)\n (Data.Maybe hiding [fromJust]))\n (import-when [:compile]\n (Compile.Time.Only.Import))\n (import-when [:compile :load]\n (Control.Applicative [liftA3])))\n\n(:: main (IO ()))\n(= main (putStrLn \"preprocess/fnk12.hs\"))\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk13.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule Main\n (invalid-form)\n (import\n Symbol_is_expanded_to_empty_form)\n (import-when invalid_phase\n (Control.Monad)))\n\n(:: main (IO ()))\n(= main (putStrLn \"preprocess/fnk13.hs\"))\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk14.hs", "content": ";;; -*- mode: finkel -*-\n\n(module)(Main)\n" }, { "path": "finkel-kernel/test/data/preprocess/fnk15.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(:: main (IO ()))\n(= main (print (:quasiquote foo bar buzz)))\n" }, { "path": "finkel-kernel/test/data/preprocess/hs01.hs", "content": "module Main where\n\nmain :: IO ()\nmain = putStrLn \"preprocess/hs01.hs\"\n" }, { "path": "finkel-kernel/test/data/preprocess/hs02.hs", "content": "-- Haskell code containing \";;;\" in the first line.\n\nmodule Main where\n\nmain :: IO ()\nmain = putStrLn \"preprocess/hs02.hs\"\n" }, { "path": "finkel-kernel/test/data/syntax/0001-hello.hs", "content": ";;; -*- mode: finkel -*-\n;;;\n;;; Simple source containing definition for module named 'Main', with\n;;; single function definition 'main'. Contains comments.\n;;;\n\n(module Main)\n\n(= main\n (putStrLn \"Hello, world!\"))\n" }, { "path": "finkel-kernel/test/data/syntax/0002-lexical.hs", "content": ";;; -*- mode: finkel -*-\n;;;\n;;; Tests for tokens and literal values. Unlike Haskell, lines starting\n;;; with `;' are comments. This file intentionally contain spaces and\n;;; tabs.\n\n(module Main)\n\n(= main\n (do\n ;; 2.5 Numeric Literals\n\n ;; Literal integers.\n (print 42)\n (print -24)\n (print 0x123abcdef)\n (print -0xdeadbeaf)\n (print 0o7654321)\n (print -0o7777)\n\n ;; Fractional number.\n (print 1.234567)\n (print -8.9)\n\n ;; 2.6 Character and String Literals.\n (print #'a) (print #'0) (print #'+) (print #'')\n (print #')) (print #'[) (print #';) (print #'\\)\n (print #'犬) (print #'Я) (print #'λ) (print #'👺)\n\n (print #'\\29356) (print #'\\1071) (print #'\\955) (print #'\\128122)\n (print #'\\o71254) (print #'\\o2057) (print #'\\o1673) (print #'\\o372172)\n (print #'\\x72ac) (print #'\\x42f) (print #'\\x3bb) (print #'\\x1f47a)\n\n (putChar #'\\a) ; alert\n (putChar #'\\SP) ; space\n (putChar #'\\b) ; backspace\n (putChar #'\\HT) ; horizontal tab\n (putChar #'\\n) ; new line\n (putChar #'\\NUL) ; \\NUL\n (putChar #'\\LF) ; line feed\n\n (putChar #'\\FF) ; form feed\n (putChar #'\\^L) ; form feed with control char\n\n ;; Single element String with escaped character.\n (putStrLn [#'\\35])\n\n (putStrLn \"string literal\") ; Simple string\n\n ;; String containing escaped `\"'.\n (putStrLn \"string with \\\"double quotes\\\".\")\n\n ;; String containing escaped newlines and tabs.\n (putStrLn \"string with newlines: \\n\\n\\nand tabs: \\t\\t\\t.\")\n\n ;; Strings with non-ASCII characters.\n (putStrLn \"᚛᚛ᚉᚑᚅᚔᚉᚉᚔᚋ ᚔᚈᚔ ᚍᚂᚐᚅᚑ ᚅᚔᚋᚌᚓᚅᚐ᚜\")\n (putStrLn \"ᛁᚳ᛫ᛗᚨᚷ᛫ᚷᛚᚨᛋ᛫ᛖᚩᛏᚪᚾ᛫ᚩᚾᛞ᛫ᚻᛁᛏ᛫ᚾᛖ᛫ᚻᛖᚪᚱᛗᛁᚪᚧ᛫ᛗᛖ᛬\")\n (putStrLn \"私はガラスを食べられます。それは私を傷つけません。\")\n\n ;; String gap\n (putStrLn \"Here is a backslant \\\\ as well as \\137, \\\n\\a numeric escape character, and \\^X, a control character.\")\n\n ;; Empty string.\n (putStrLn \"\")\n\n ;; Unit.\n (print ())\n\n ;; List literals.\n (print [1 2 3 4 5])\n (print (: True (: False [])))\n\n ;; List containing expressions.\n (print [(if (> 2 3)\n (do (<- x (return 100))\n (<- y (return 23))\n (return (+ x y)))\n (return 123))\n (Left \"foo\")])\n\n ;; Value names not starting with but containing `quote'.\n (let ((:: x x' x'' Int)\n (= x 100)\n (= x' 200)\n (= x'' 300)))\n (print x)\n (print x')\n (print x'')\n\n ;; Some tabs\n\n\n\n ;; Function names starting with `#'.\n (let ((:: # #. ## (-> Int Int))\n (= # a (+ a 1))\n (= #. a (+ a 2))\n (= ## a (+ a 3))))\n (print ((#) 41))\n (print ((#.) 40))\n (print ((##) 39))\n\n ;; Function names starting with `%'.\n (let ((:: %. %% (-> Int Int))\n (= %. a (+ a 4))\n (= %% a (+ a 5))))\n (print ((%.) 38))\n (print ((%%) 37))))\n" }, { "path": "finkel-kernel/test/data/syntax/0003-expressions-1.hs", "content": ";;; -*- mode: finkel -*-\n\n(module Main)\n\n(import Control.Monad (ap))\n\n;;; Simple expressions\n\n(= simple1 a b\n (+ (* a (simple2 (+ a b) (+ a b) a))\n (* (simple2 (* b b) (* a a) (* a b)) b)))\n\n(= simple2 x y z\n (* (+ x (* y z))\n (+ y (* x z))))\n\n(= factorial n\n (if (== n 1)\n 1\n (* n (factorial (- n 1)))))\n\n(= simples\n (>> (print (simple1 3 4))\n (print (factorial 10))))\n\n;;; 3.3 Curried Applications and Lambda Abstractions\n\n;;; This function takes single argument which is a function, and applies\n;;; 3 and 11 to it.\n(= lam1 f\n (f 3 11))\n\n;;; Calls `lam1' defined above.\n(= lam2\n (>>\n ;; Lambda WITH spaces between '\\' and the first argument.\n (print (lam1 (\\ a b\n (* a (+ a b)))))\n\n ;; Lambda WITHOUT spaces between '\\' and the first argument.\n (print (lam1 (\\a b\n (* a (+ a b)))))))\n\n(= lamexprs\n lam2)\n\n;;; 3.4 Operator Applications\n\n;;; Operator are expanded when it takes more than two literal arguments.\n;;; Partial application is supported for left hand side argument only.\n(= op1\n (do (print (+ 1 2 3 4 5))\n (print (Prelude.* 1 2 3 4 5))\n (let ((= f (. putStrLn show (+ 3) (* 13)))))\n (f (:: 3 Int))\n ($ putStrLn show not False)))\n\n;; The ':' operator expansion in pattern match.\n(= op2 xs\n (case xs\n (: a b c _) (print (+ a b c))\n _ (return ())))\n\n(= opexprs\n (do op1\n (op2 [1 2 3 4])))\n\n;;; 3.7 Lists\n\n(= lie0 (print (:: [] [Int])))\n(= lie1 (print [1]))\n(= lie2 (print [1 2]))\n(= lie3 (print [1 2 3]))\n(= lie4 (print [1 2 3 4]))\n(= lie5 (print (: 1 (: 2 (: 3 [4 5])))))\n\n(= listexprs\n (do lie0 lie1 lie2 lie3 lie4 lie5))\n\n;;; 3.8 Tuples\n\n(:: tup1 (-> a (-> b (-> c (, a b c)))))\n(= tup1 a b c\n (, a b c))\n\n(:: tup2 (-> a b (Maybe (, a b))))\n(= tup2 a b\n (ap (ap (return (,)) (return a)) (return b)))\n\n(:: tup3 (-> a b c d (Maybe (, a b c d))))\n(= tup3 a b c d\n (ap (ap (ap (ap (return (,,,))\n (return a))\n (return b))\n (return c))\n (return d)))\n\n(= tupexprs\n (do (print (tup1 #'x 1.23 \"4567\"))\n (print (tup2 True #'y))\n (print (tup3 True #'a False #'b))))\n\n;;; 3.9 Unit Expressions and Parenthesized Expressions\n\n(= upe1 (print ()))\n(= upe2 (print ((((((((((True))))))))))))\n\n(= uparenexprs\n (do upe1 upe2))\n\n;;; 3.10 Arithmetic Sequences\n\n(= ase1 (print (take 10 [1 ..])))\n(= ase2 (print (take 10 [1 3 ..])))\n(= ase3 (print [2 .. 20]))\n(= ase4 (print [2 4 .. 20]))\n\n(= aseqexprs\n (do ase1 ase2 ase3 ase4))\n\n;;; 3.11 List Comprehensions\n\n(= lcmp1 [x | (<- x [1 2 3])])\n(= lcmp2 [x | (<- x [1 2 3]) (even x)])\n(= lcmp3 [y | (<- x [1 2 3]) (even x) (let ((= y (+ x 1))))])\n(= lcmp4 [(, x y) | (<- x [1 2 3]) (even x) (let ((= y (+ x 1))))])\n\n(= lcmpexprs\n (do (print lcmp1)\n (print lcmp2)\n (print lcmp3)\n (print lcmp4)))\n\n;;; 3.12 Let Expressions\n\n;;; Expression with empty 'let'.\n(= let1 n\n (let ()\n (+ n 35)))\n\n;;; Expression with 'let'. In bindings of `let', 'a' is a integer value\n;;; 14, and `f' is a function taking two arguments.\n(= let2 n\n (let ((:: a Int)\n (= a 14)\n (:: f (-> Int Int Int))\n (= f x y\n (+ x y))\n (:: g (-> Int Int))\n (= g (\\x (* x 2))))\n (g (f n a))))\n\n;;; Using non-reserved special value names (e.g. `as', `hiding' ...).\n(= let3 n\n (let ((= as n)\n (= ccall n)\n (= hiding n)\n (= qualified n)\n (= ! a b (+ a b))\n (= ~~ a b (* a b)))\n [as ccall hiding qualified (! 19 23) (~~ 6 7)]))\n\n;;; `let' with pattern match\n(= let4 n\n (let ((:: f (-> Int Int))\n (= f 1 1)\n (= f 2 1)\n (= f k (+ (f (- k 1)) (f (- k 2))))\n (:: g (-> Int Int))\n (= g 0 0)\n (= g n n))\n (g (f n))))\n\n(= letexprs\n (do (print (let1 7))\n (print (let2 7))\n (print (let3 7))\n (print (let4 7))))\n\n;;; 3.13 Case Expressions\n\n(= case1 x\n (case x\n (Just n) (+ n 1)\n _ 0))\n\n(= case2 x\n (case x\n (Right (Just _)) 1\n (Right Nothing) 2\n (Left (Just _)) 3\n (Left Nothing) 4))\n\n(:: mbeven (-> Int (Maybe Int)))\n(= mbeven n\n (if (even n)\n (Just n)\n Nothing))\n\n(:: case3 (-> (Maybe Int) Int String))\n(= case3 x y\n (case x\n (Just n) (| ((odd n) (> n 100)\n \"small odd number\")\n ((odd n)\n \"big odd number\")\n ((<- (Just m) (mbeven n))\n (let ((:: k Int)\n (= k (+ m 1))))\n (< k 101)\n \"small even number\")\n (otherwise\n \"big even number\"))\n Nothing (| ((even y) \"y is even\")\n (otherwise \"y is odd\"))))\n\n(:: case4 (-> (Maybe Int) Int String))\n(= case4 x y\n (where (case x\n (Just n) (where (| ((even n) (show (f n y)))\n ((odd n) (++ (h n) (show (f n 1)))))\n (= f a b (+ a b)))\n Nothing \"nothing\")\n (= h i\n (replicate (+ i y) #'@))))\n\n;;; Using non-reserved special value names (e.g. `as', `hiding' ...), in\n;;; pattern.\n\n(:: case5 (-> (, Int Int Int Int) Int))\n(= case5 (, as ccall qualified hiding)\n (sum [as ccall qualified hiding]))\n\n(= caseexprs\n (do (print (case1 (Just 41)))\n (print (case1 Nothing))\n (print (case2 (Right (Just ()))))\n (print (case3 (Just 42) 12))\n (print (case4 (Just 41) 1))\n (print (case5 (, 1 1 1 1)))))\n\n;;; 3.14 Do Expressions\n\n(= showBar x\n (do (putStrLn \"String `bar' from showBar.\")\n (return x)))\n\n(= listdo\n (do (<- x [1 2 3])\n (<- y [4 5 6])\n [x y]))\n\n(= letdo\n (do (let ((= f 1 1)\n (= f 2 1)\n (= f n (+ (f (- n 1)) (f (- n 2))))))\n (print (f 10))))\n\n(= doexpres\n (do (putStrLn \"foo\")\n (<- buzz (showBar \"buzz\"))\n (let ((:: buzz3 buzz4 String)\n (= buzz3 (concat [buzz buzz buzz]))\n (= buzz4 \"buzz4\")))\n (putStrLn buzz3)\n (putStrLn buzz4)\n (print listdo)\n letdo))\n\n;;; 3.15 Datatypes with Field Labels\n\n(data R1\n (Con1 {(:: field1 Int)\n (:: field2 Bool)})\n (deriving Eq Show))\n\n(:: mkR1 (-> Int (-> Bool R1)))\n(= mkR1 a b\n (Con1 {(= field1 a) (= field2 b)}))\n\n(:: fe_01 (IO ()))\n(= fe_01\n (do (let ((:: r1 r2 R1)\n (= r1 (Con1 {(= field2 False)\n (= field1 42)}))\n (= r2 (r1 {(= field1 (* (field1 r1) 2))}))\n (= r3 ((mkR1 21 True) {(= field1 12)}))\n (= as (r1 {(= field1 (* (field1 r1) 2))}))\n (= bs (as {(= field1 (* (field1 as) 2))}))))\n (print r1)\n (print r2)\n (print r3)\n (print as)\n (print bs)))\n\n(:: fe_02 (IO ()))\n(= fe_02\n (do (let ((:: as bs R1)\n (= as (Con1 {(= field2 True)\n (= field1 3)}))\n (= bs (as {(= field1 (* (field1 as) 2))}))))\n (print as)\n (print bs)))\n\n(= fieldexprs\n (do fe_01\n fe_02))\n\n;;; 3.16 Expression Type-Signatures\n\n(= t316a n\n (if (< n (:: 2 Int))\n n\n (+ (t316a (- n 1))\n (t316a (- n 2)))))\n\n(= t316b xs\n (print (map (:: (\\x (+ x 1)) (=> (Num a) (-> a a))) xs)))\n\n(= tsigexprs\n (do (print (t316a 10))\n (t316b [1 2 3])\n (t316b [1.0 2.0 3.0])))\n\n;;; 3.17 Pattern Matching\n\n;;; Top level functions with pattern matches.\n\n(= fib 0 0)\n(= fib 1 1)\n(= fib n (+ (fib (- n 1))\n (fib (- n 2))))\n\n(= bar Nothing \"bar got nothing\")\n(= bar _ \"bar got something\")\n\n(= buzz (Just n) (putStrLn (++ \"buzz: \" (show n))))\n(= buzz _ (putStrLn \"buzz got nothing\"))\n\n(= addMaybes Nothing Nothing 0)\n(= addMaybes (Just a) Nothing a)\n(= addMaybes Nothing (Just b) b)\n(= addMaybes (Just a) (Just b) (+ a b))\n\n(= nest1 Nothing 0)\n(= nest1 (Just (Right n)) n)\n(= nest1 (Just (Left True)) 9999)\n(= nest1 (Just (Left False)) 42)\n\n(= lp1 [] 0)\n(= lp1 [a] 1)\n(= lp1 [(Just x) (Just y)] (+ x y))\n(= lp1 [a b] 2)\n(= lp1 _ 999)\n\n(= patexprs1\n (do (print (fib 10))\n (putStrLn (bar Nothing))\n (putStrLn (bar (Just undefined)))\n (buzz (Just 3))\n (print (addMaybes Nothing Nothing))\n (print (addMaybes (Just 2) Nothing))\n (print (addMaybes Nothing (Just 3)))\n (print (addMaybes (Just 2) (Just 3)))\n (print (nest1 Nothing))\n (print (nest1 (Just (Right 3))))\n (print (nest1 (Just (Left True))))\n (print (lp1 []))\n (print (lp1 [Nothing]))\n (print (lp1 [Nothing Nothing]))\n (print (lp1 [(Just 28) (Just 14)]))\n (print (lp1 [Nothing (Just 1) Nothing]))))\n\n(:: tupp1 (-> (, a b) a))\n(= tupp1 (, a _) a)\n\n(:: tupp2 (-> (, Char Char Char) Char))\n(= tupp2 x\n (case x\n (, _ _ c) c))\n\n(:: intpat (-> Int String))\n(= intpat x\n (case x\n 1 \"one\"\n 2 \"two\"\n _ \"unknown\"))\n\n(:: strpat (-> String String))\n(= strpat x\n (case x\n \"foo\" \"GOT FOO\"\n \"bar\" \"GOT BAR\"\n _ \"UNKNOWN\"))\n\n(:: charpat (-> Char String))\n(= charpat x\n (case x\n #'a \"GOT A\"\n #'b \"GOT B\"\n _ \"UNKNOWN\"))\n\n(= patexprs2\n (do (print (tupp1 (, True False)))\n (print (tupp2 (, #'a #'b #'c)))\n (print (intpat 1))\n (print (intpat 2))\n (print (intpat 3))\n (print (strpat \"foo\"))\n (print (strpat \"bar\"))\n (print (strpat \"buzz\"))\n (print (charpat #'a))\n (print (charpat #'X))))\n\n(:: aspat1 (-> (Maybe Char) String))\n(= aspat1 mbc\n (case mbc\n (@ x (Just y)) (unwords [(show x) (show y)])\n Nothing \"Nothing\"))\n\n(:: ap2a ap2b ap2c Int)\n(:: aspat2 [Int])\n(= (@ aspat2 [ap2a ap2b ap2c])\n [123 456 789])\n\n(:: ap3 [String])\n(= ap3\n (let ((:: p (Either String Int))\n (= (@ p (Right q)) (Right 42)))\n [(show p) (show q)]))\n\n(:: ap4 [String])\n(= ap4\n (let ((= (@ as (, a b)) (, #'a #'b))\n (= (@ ccall (, c d)) (, #'c #'d))\n (= (@ hiding (, e f)) (, #'e #'f))\n (= (@ qualified (, g h)) (, #'g #'h)))\n [(show as) (show ccall) (show hiding) (show qualified)]))\n\n(= patexprs3\n (do (print (aspat1 (Just #'p)))\n (print ap2a)\n (print ap2b)\n (print ap2c)\n (print aspat2)\n (print ap3)\n (print ap4)))\n\n(:: lzp1 (-> (Maybe Int) String))\n(= lzp1 (@ _mbi ~(Just _i)) \"matched\")\n\n(:: lzp2 (-> (, Int [Char] (, Char [Int])) Char))\n(= lzp2 (, x ~(: y ys) ~(, z (: w ws)))\n (| ((even x) y)\n ((odd x) z)))\n\n(:: lzp3 (-> (, a (, b c)) String))\n(= lzp3 x\n (case x\n ~(, _a ~(, _b _c)) \"lzp3\"))\n\n(:: lzp4 (-> (, a (, b c)) (IO ())))\n(= lzp4 x\n (do (<- ~(, _a ~(, _b _c)) (return x))\n (putStrLn \"lzp4\")))\n\n(:: lzp5 (-> (, a (, b c)) (IO ())))\n(= lzp5\n (\\ ~(, _a ~(, _b _c)) (putStrLn \"lzp5\")))\n\n(:: lzp6 (-> (, a (, b c)) (IO ())))\n(= lzp6 x\n (let ((= ~(, _a ~(, _b _c)) x))\n (putStrLn \"lzp6\")))\n\n(:: lzp7 (-> (, Int (, Char Bool)) (IO ())))\n(= lzp7 ~x\n (print x))\n\n(= patexprs4\n (do (print (lzp1 (Just undefined)))\n (print (lzp2 (, 3 undefined (, #'x [1 2 3]))))\n (print (lzp2 (, 4 [#'a #'b] (, undefined []))))\n (print (lzp3 undefined))\n (lzp4 undefined)\n (lzp5 undefined)\n (lzp6 undefined)\n (lzp7 (, 42 (, #'g True)))))\n\n(= lfp1 mb\n (case mb\n (Just {}) \"just\"\n _ \"nothing\"))\n\n(= lfp2 r1\n (case r1\n (Con1 {(= field1 i) (= field2 b)}) (if b (* i 7) i)))\n\n(= patexprs5\n (do (print (lfp1 Nothing))\n (print (lfp1 (Just undefined)))\n (print (lfp2 (Con1 42 False)))\n (print (lfp2 (Con1 6 True)))))\n\n(= unitp1 a\n (case a\n () (putStrLn \"unitp1: `()' pattern matched.\")))\n\n(= unitp2 ()\n (putStrLn \"unitp2: `()' pattern matched.\"))\n\n(= patexprs6\n (do (unitp1 ())\n (unitp2 ())))\n\n(= patexprs\n (do patexprs1\n patexprs2\n patexprs3\n patexprs4\n patexprs5\n patexprs6))\n\n;;; Main\n\n(= main\n (do simples\n lamexprs\n opexprs\n listexprs\n tupexprs\n uparenexprs\n aseqexprs\n lcmpexprs\n letexprs\n caseexprs\n doexpres\n fieldexprs\n tsigexprs\n patexprs))\n" }, { "path": "finkel-kernel/test/data/syntax/0003-expressions-2.hs", "content": ";;;; Module containing operator function \"@\"\n\n(= @ a b\n (* (+ a b) 2))\n\n(= main\n (print (@ 10 11)))\n" }, { "path": "finkel-kernel/test/data/syntax/0003-expressions-3.hs", "content": ";;; -*- mode: finkel -*-\n;;;\n;;; This module contains expressions using `forall' as variable idntifier, which\n;;; will show an error from ghc 9.10 in default flag settings.\n\n(module Main)\n\n(:: let1 (-> Int [Int]))\n(= let1 n\n (let ((= forall n))\n [forall]))\n\n(:: case1 (-> (, Int Int) Int))\n(= case1 (, as forall) (+ as forall))\n\n(:: main (IO ()))\n(= main\n (do (print (let1 42))\n (print (case1 (, 19 23)))))\n" }, { "path": "finkel-kernel/test/data/syntax/0004-decls.hs", "content": ";;;; Forms containing type declarations.\n\n(module Main)\n\n;;; 4.2 User-Defined Datatypes\n\n;;; 4.2.1 Algebraic Datatype Declarations\n\n(data MyData1\n (MyD1Con1 Int Bool ())\n (MyD1Con2 [(, Int Int)] Double Char)\n (deriving Eq Show))\n\n(data (MyData2 a b)\n (MyD2Con1 a b)\n (MyD2Con2 a a Bool)\n (deriving Eq Show))\n\n(data (MyData3 a)\n (MyD3Con1 {(:: d3f1 a)\n (:: d3f2 (Maybe FilePath))})\n (MyD3Con2 Int Int Int)\n ;; (MyD3Con3 {(:: (d3f1 d3f1b d3f1c) a)\n ;; (:: d3f4 (Either Bool Char))})\n (MyD3Con3 {(:: d3f1 d3f1b d3f1c a)\n (:: d3f4 (Either Bool Char))})\n (deriving Eq Show))\n\n(data MyData4\n M4A M4B M4C M4D\n (deriving Eq Show Enum))\n\n;;; Empty data declaration.\n(data MyData5)\n\n(instance (Show MyData5)\n (= show _ \"MyData5\"))\n\n;;; Strictness Flags\n(data MyData6\n (M6L Int)\n (M6S1 !Int)\n (M6S2 !(Maybe Int))\n (deriving Eq Show))\n\n(data MyData7\n (M7a {(:: m7aF1 !Int)\n (:: m7aF2 !(Maybe String))})\n (deriving Eq Show))\n\n;; Using non-reserved special names in type variable.\n;;\n;; GHC 8.8.1 introduced \"More explicit foralls\", and using \"forall\" in\n;; type variable will show a parse error.\n\n(data (MyData8 as ccall forAll hiding qualified)\n (M8a as ccall forAll hiding qualified)\n (deriving Eq Show))\n\n(:: s4_2_1 (IO ()))\n(= s4_2_1\n (do (print (MyD1Con1 123 True ()))\n (print (MyD1Con2 [(, 1 2) (, 3 4)] 1.23 #'z))\n (print [(MyD2Con1 (:: 123 Int) #'z)\n (MyD2Con2 (:: 789 Int) 0 False)])\n (print (MyD3Con1 #'x (Just \"/foo/bar\")))\n (print (:: (MyD3Con2 1 2 3) (MyData3 Double)))\n (print (MyD3Con3 #'a #'b #'c (Right #'z)))\n (print [M4A M4B M4C])\n (print (:: undefined MyData5))\n (print [(M6L 42) (M6S1 42) (M6S2 Nothing)])\n (print (M7a {(= m7aF1 100) (= m7aF2 (Just \"strict Maybe field\"))}))\n (print (M8a True True True True True))))\n\n;;; 4.2.2 Type Synonym Declarations\n\n(type (Synonym1 a) (Maybe (Either String a)))\n(type Synonym2 (Synonym1 Int))\n\n(:: syn1a (Synonym1 Bool))\n(= syn1a (Just (Left \"syn1a\")))\n\n(:: syn2a Synonym2)\n(= syn2a Nothing)\n\n(:: s4_2_2 (IO ()))\n(= s4_2_2\n (do (print syn1a)\n (print syn2a)))\n\n;;; 4.2.3 Datatype Renamings\n\n(newtype (N1 a) (N1 a))\n\n(instance (=> (Show a) (Show (N1 a)))\n (= show (N1 a)\n (++ \"N1 \" (show a))))\n\n(newtype (N2 a) (N2 a) (deriving Eq Show))\n\n(newtype (N3 a) (N3 {(:: unN3 a)}))\n\n(instance (=> (Show a) (Show (N3 a)))\n (= show (N3 a)\n (++ \"N3 \" (show a))))\n\n(newtype (N4 a) (N4 {(:: unN4 a)}) (deriving Eq Show))\n\n(:: s4_2_3 (IO ()))\n(= s4_2_3\n (do (print (N1 1))\n (print (N2 2))\n (print (N3 3))\n (print (N4 4))))\n\n(:: s4_2 (IO ()))\n(= s4_2\n (do s4_2_1\n s4_2_2\n s4_2_3))\n\n;;; 4.3 Type Classes and Overloading\n\n;;; 4.3.1 Class Declarations\n\n;;; Simple type class.\n(class (MyShow a)\n (:: myShow (-> a String)))\n\n;;; Instance declaration of `MyShow' for `Bool'.\n(instance (MyShow Bool)\n (= myShow b\n (case b\n True \"t\"\n False \"f\")))\n\n(instance (MyShow Char)\n (= myShow #'d \"dddddddddddddddddddd\")\n (= myShow c (++ \"myShow: \" (show c))))\n\n;;; Typeclass with context and default method.\n(class (=> (Show a) (MyShow2 a))\n (:: myShow2 (-> a String))\n (= myShow2 show))\n\n(instance (MyShow2 Bool))\n\n(class (Tup2 k)\n (:: tup2 (-> (k a b) String)))\n\n(instance (Tup2 (,))\n (= tup2 _ \"tup2 for (,)\"))\n\n(class (Tup3 k)\n (:: tup3 (-> (k a b c) String)))\n\n(instance (Tup3 (,,))\n (= tup3 _ \"tup3 for (,,)\"))\n\n(class (Tup4 k)\n (:: tup4 (-> (k a b c d) String)))\n\n(instance (Tup4 (,,,))\n (= tup4 _ \"tup4 for (,,,)\"))\n\n(:: s4_3_1 (IO ()))\n(= s4_3_1\n (do (print (map myShow [True False]))\n (print (map myShow [#'a #'b #'c #'d #'e]))\n (print (map myShow2 [True False]))\n (putStrLn (tup2 (, undefined undefined)))\n (putStrLn (tup3 (, undefined undefined undefined)))\n (putStrLn (tup4 (, undefined undefined undefined undefined)))))\n\n;;; 4.3.2 Instance Declarations\n\n(data (MyF a)\n (MyF {(:: unMyF a)})\n (deriving Eq Show))\n\n(instance (Functor MyF)\n (= fmap f (MyF a)\n (MyF (f a))))\n\n(data (EmptyContext a) (EmptyContext Int))\n\n(instance (=> () (Show (EmptyContext a)))\n (= show (EmptyContext n)\n (++ \"EmptyContext \" (show n))))\n\n(data (MCs a b) (MCs a b))\n\n(instance (=> (Show a) (Show b) (Show (MCs a b)))\n (= show (MCs a b)\n (concat [\"MCs \" (show a) \" \" (show b)])))\n\n(class (C1 c)\n (:: c1m1 (-> (c a) String)))\n\n(instance (C1 [])\n (= c1m1 li\n (case li\n [] \"null\"\n _ \"list\")))\n\n(class (MyFunctor f)\n (:: myFmap (-> (-> a b) (f a) (f b))))\n\n(instance (MyFunctor (-> a))\n (= myFmap f g (\\x (f (g x)))))\n\n(class (MyProfunctor pf)\n (:: myDimap (-> (-> a b) (-> c d) (pf b c) (pf a d))))\n\n(instance (MyProfunctor (->))\n (= myDimap ab cd bc\n (. cd (. bc ab))))\n\n(:: s4_3_2 (IO ()))\n(= s4_3_2\n (do (print (fmap (* 2) (MyF 21)))\n (print (EmptyContext 42))\n (print (MCs True #'a))\n (putStrLn (c1m1 []))\n (putStrLn (c1m1 [() () ()]))\n (myFmap putStrLn show (:: 42 Int))))\n\n;;; 4.3.4 Ambiguous Types, and Defaults for Overloaded Numeric Options\n\n(default Integer Double)\n\n(:: s4_3 (IO ()))\n(= s4_3\n (do s4_3_1\n s4_3_2))\n\n\n;;; 4.4 Nested Declarations\n\n;;; 4.4.1 Type signatures\n\n;; Unit type.\n(:: ts1 ())\n(= ts1 ())\n\n;;; Simple function type.\n(:: ts2 (-> String (IO ())))\n(= ts2 str\n (putStrLn (++ \"From ts2: \" str)))\n\n;;; Another function type, taking multiple arguments.\n(:: ts3 (-> Int (-> Bool (-> String (IO ())))))\n(= ts3 i b s\n (do (putStrLn (++ \"Int: \" (show i)))\n (putStrLn (++ \"Bool: \" (show b)))\n (putStrLn (++ \"String: \" (show s)))))\n\n;;; Function type operator '->' takes variable arguments, explicit\n;;; parentheses are optional.\n(:: ts3b (-> Int Bool String (IO ())))\n(= ts3b i b s\n (do (putStrLn (++ \"Int: \" (show i)))\n (putStrLn (++ \"Bool: \" (show b)))\n (putStrLn (++ \"String: \" (show s)))))\n\n;;; Function taking higher order function.\n(:: ts4 (-> (-> Int Int) Int))\n(= ts4 f\n (f 6))\n\n;;; Function taking list.\n(:: ts5 (-> [Int] (IO ())))\n(= ts5 xs\n (mapM_ print xs))\n\n;;; Function with type variables.\n(:: ts6 (-> a [b] Int))\n(= ts6 x ys\n (length ys))\n\n;;; Type signature with context.\n(:: ts7 (=> (Show a) (-> a String)))\n(= ts7 x\n (++ (show x) (++ \", \" (show x))))\n\n;;; Another type signature with context.\n(:: ts8 (=> (Functor f) (Show a) (-> (f a) (f String))))\n(= ts8 m\n (fmap ts7 m))\n\n(:: s4_4_1 (IO ()))\n(= s4_4_1\n (do (print ts1)\n (ts2 \"BAR\")\n (ts3 1 True \"buzz\")\n (ts3b 2 False \"buzzz\")\n (print (ts4 (\\n (* (+ n 1) n))))\n (ts5 [1 2 3])\n (print (ts6 True [1 2 3]))\n (putStrLn (ts7 False))\n (print (ts8 (Just True)))))\n\n;;; 4.4.2 Fixity Declarations\n\n(= $^+^$ a b (+ a b))\n(= $^-^$ a b (- a b))\n(= $^*^$ a b (* a b))\n(= $^/^$ a b (/ a b))\n\n(infixl 6 $^+^$)\n(infixl 6 $^-^$)\n(infixl 7 $^*^$ $^/^$)\n\n;; Fixity resolution with expanded operator. Without `infixr 4',\n;; expanded form \"a >*< b >*< c\" will not pass the type checker.\n(:: >*< (=> (Applicative f) (-> (f a) (f (-> a b)) (f b))))\n(= >*< (flip <*>))\n\n(infixr 4 >*<)\n\n;; Unicode operators\n(= •••• a b (* a (+ b 2)))\n(= ‣ a b (* b (+ a 2)))\n(= •-•-• a b (* a (+ b 2)))\n\n(:: s4_4_2 (IO ()))\n(= s4_4_2\n (do (print ($^*^$ ($^+^$ 3 4) ($^/^$ 48 8)))\n (print (>*< (Just []) (Just True) (Just :)))\n (print (•••• 1 2 3 4 5))\n (print (‣ 1 2 3 4 5))\n (print (•-•-• 1 2 3 4 5))))\n\n;;; 4.4.3 Function and Pattern Bindinds\n\n;;; 4.4.3.1 Function bindings\n\n;;; Function without guards.\n(:: fpb0 (-> Int String))\n(= fpb0 n\n (++ \"f0 got \" (show n)))\n\n;;; Function with guards.\n(:: fpb1 (-> Int String))\n(= fpb1 n\n (| ((even n) \"even\")\n (otherwise \"odd\")))\n\n;;; Function with pattern guards.\n(:: fpb2 (-> (Maybe Int) (Maybe Int) String))\n(= fpb2 a b\n (| ((<- (Just n) a) (<- (Just m) b) (even n) (even m)\n \"f2: got two even numbers.\")\n ((<- (Just n) a) (<- (Just m) b)\n (++ \"f2: got two numbers, sum = \" (show (+ n m))))\n ((<- (Just n) a)\n \"f2: b was nothing.\")\n ((<- (Just n) b)\n \"f2: a was nothing\")\n (otherwise\n \"f2: no numbers.\")))\n\n(:: fpb3 [String])\n(= fpb3 [\"string\" \"expression\" \"without\" \"guards\"])\n\n;;; Function with `where'\n(:: fpb4 (-> Char Int String))\n(= fpb4 c n\n (where (f n)\n (= f x\n (replicate x c))))\n\n;;; Functions with `where', with identical name.\n(:: fpb5 (-> Int Int))\n(= fpb5 k\n (where (f 0 k)\n (= f acc 0 acc)\n (= f acc n (f (+ acc n) (- n 1)))))\n\n;;; Another function with `where', with pattern match.\n(:: fpb6 (-> Int String))\n(= fpb6 n\n (where (f (lookup n names))\n (= f Nothing \"none\")\n (= f (Just n) n)\n (= names [(, 1 \"one\") (, 2 \"two\") (, 3 \"three\")])))\n\n;;; 4.4.3.2 Pattern Bindings\n\n(:: xs ys [Int])\n(= (, xs ys)\n (break (> 5) (enumFromTo 1 10)))\n\n(:: addJust (-> Int Int (Maybe Int)))\n(= addJust a b (Just (+ a b)))\n\n(:: tpb1 Int)\n(= (Just tpb1) (addJust 16 27))\n\n(:: tpb2 Int)\n(= [_ _ tpb2 _]\n (enumFromTo 40 43))\n\n(:: tpb3 Int)\n(= (: tpb3 _)\n (enumFrom 42))\n\n;;; Ignored top level bindings\n\n(= _ (:: 1 Int))\n\n(= _ (:: 2 Integer))\n\n(= _ (:: 3 Double))\n\n(:: s4_4_3 (IO ()))\n(= s4_4_3\n (do (putStrLn (fpb0 42))\n (putStrLn (fpb1 10))\n (putStrLn (fpb1 11))\n (putStrLn (fpb2 (Just 2) (Just 4)))\n (putStrLn (fpb2 (Just 2) (Just 5)))\n (putStrLn (fpb2 (Just 100) Nothing))\n (putStrLn (fpb2 (Nothing) (Just 8)))\n (putStrLn (fpb2 Nothing Nothing))\n (print fpb3)\n (putStrLn (fpb4 #'= 30))\n (print (fpb5 10))\n (print (fpb6 2))\n (putStrLn (++ \"xs: \" (show xs)))\n (putStrLn (++ \"ys: \" (show ys)))\n (putStrLn (++ \"tpb1: \" (show tpb1)))\n (putStrLn (++ \"tpb2: \" (show tpb2)))\n (putStrLn (++ \"tpb3: \" (show tpb3)))))\n\n(:: s4_4 (IO ()))\n(= s4_4\n (do s4_4_1\n s4_4_2\n s4_4_3))\n\n;;; Main.\n(:: main (IO ()))\n(= main\n (do s4_2\n s4_3\n s4_4))\n" }, { "path": "finkel-kernel/test/data/syntax/0005-modules-01.hs", "content": ";;; -*- mode: finkel -*-\n;;;\n;;; Simple example for `import'.\n\n(module Main)\n\n(import Data.Maybe)\n\n(= main\n (putStrLn (foo (Just \"bar\"))))\n\n(= foo x\n (fromMaybe \"foo\" x))\n" }, { "path": "finkel-kernel/test/data/syntax/0005-modules-02.hs", "content": ";;; -*- mode: finkel -*-\n;;;\n;;; File without module name.\n\n(:: main (IO ()))\n(= main (putStrLn \"Module without module header.\"))\n" }, { "path": "finkel-kernel/test/data/syntax/0005-modules-03.hs", "content": ";;; -*- mode: finkel -*-\n;;;\n;;; 5.2 Export Lists\n\n(module Main\n ;; Value entities\n f1 f3\n\n ;; Data constructor only ... is impossible. From section 5.2 of\n ;; Haskell 2010 report:\n ;;\n ;; ... Data cnstructros cannot be named in export lists except as\n ;; subordinate names, because they cannot otherwise be distinguished\n ;; from type constructors.\n ;;\n\n ;; D1A\n\n ;; Typeclass method only.\n c1a\n\n ;; Type constructor only.\n (D2) C2\n\n ;; Type constructor and all data constructors.\n (D3 ..) (C3 ..)\n\n ;; Type constructor and specified data constructors.\n (D4 D4a D4c) (D5 d5f1 d5f3) (C4 c4a c4c)\n\n ;; Module re-export\n (module Data.Char)\n\n ;; Re-export with qualified renamed module\n (Mb.Maybe Just Nothing)\n\n main)\n\n(import Data.Char)\n(import qualified Data.Maybe as Mb)\n\n;; Function values\n\n(:: f1 (-> Int Int))\n(= f1 (+ 1))\n\n(:: f2 (-> Int Int))\n(= f2 (* 2))\n\n(:: f3 (-> Int Int))\n(= f3 (. f1 f2))\n\n;;; Data types\n\n(data D1\n (D1A Int Int))\n\n(data (D2 a)\n (D2A a)\n (D2B a a))\n\n(data (D3 a)\n (D3a a)\n (D3b a a)\n (D3c a a a))\n\n(data (D4 a b c)\n (D4a a)\n (D4b b)\n (D4c c))\n\n(data (D5 a)\n (D5a {(:: d5f1 a) (:: d5f2 a) (:: d5f3 Int)})\n (D5b {(:: d5f1 a)})\n (D5c {(:: d5f2 a)}))\n\n;;; Typeclasses\n\n(class (C1 a)\n (:: c1a (-> a String)))\n\n(class (C2 a)\n (:: c2a (-> a String))\n (:: c2b (-> a Int)))\n\n(class (C3 a)\n (:: c3a (-> a String))\n (:: c3b (-> a Int))\n (:: c3c (-> a Bool)))\n\n(class (C4 a)\n (:: c4a (-> a String))\n (:: c4b (-> a Int))\n (:: c4c (-> a Bool)))\n\n(:: main (IO ()))\n(= main\n (putStrLn \"Module containing various exports\"))\n" }, { "path": "finkel-kernel/test/data/syntax/0005-modules-04.hs", "content": ";;; -*- mode: finkel -*-\n;;;\n;;; 5.3 Import Declarations\n\n(module Main)\n\n(import Data.Char)\n(import System.IO ())\n(import Control.Monad as M)\n(import Data.Array (! array))\n(import Data.Complex ((Complex ..) realPart imagPart mkPolar))\n(import Data.Monoid ((All All) (Any) (Alt getAlt)))\n(import Data.Ratio hiding (Ratio Rational numerator %))\n\n(import qualified Data.List)\n(import qualified Data.Functor.Identity as Id)\n(import qualified Data.Map as Map)\n(import qualified Data.Maybe as Mb)\n(import qualified Data.Bits as Bt (shiftL shiftR))\n(import qualified System.Environment as Env hiding (getArgs getEnv))\n\n(:: f1 (Map.Map String Int))\n(= f1\n (Map.fromList [(, \"k1\" 1) (, \"k2\" 2)]))\n\n(:: f2 (-> (Id.Identity a) (IO ())))\n(= f2 i\n (case i\n (Id.Identity {}) (putStrLn \"Id.Identity pattern match with {}\")))\n\n(:: main (IO ()))\n(= main\n (do (putStrLn (map toUpper \"import declarations\"))\n (print (Data.List.nub [1 2 3 2 1 2 3 2 1]))\n (print (Mb.fromMaybe 123 Nothing))\n (print (Mb.Just 42))\n (print (:: (return 42) (Id.Identity Int)))\n (case (return 42) (Id.Identity n) (print n))\n (print (case EQ\n Prelude.EQ True))\n (print (case (Id.Identity 42)\n (Id.Identity n) n))\n (let ((= i1 (Id.Identity 100))\n (= i2 (Id.Identity {(= Id.runIdentity 101)}))\n (= i3 (i2 {(= Id.runIdentity 102)}))))\n (mapM_ print [i1 i2 i3])\n (f2 i1)\n (M.when (< 3 5)\n (putStrLn \"Control Monad imported as `M'\"))\n (let ((= arr (array (, 0 15) (zip [0 .. 15] [#'a ..])))))\n (print (! arr 3))\n (let ((= c (mkPolar 1.2 3.4))))\n (print (realPart c))\n (print (imagPart c))\n (print (Bt.shiftL (:: 8 Int) 8))\n (>>= Env.getProgName putStrLn)\n (print f1)))\n" }, { "path": "finkel-kernel/test/data/syntax/0005-modules-05.hs", "content": ";;; Module without header, with imports.\n\n(import Control.Monad (foldM))\n\n(:: main (IO ()))\n(= main\n (where go\n (= go\n (do (<- n (foldM f 0 [#'a .. #'z]))\n (print n)))\n (= f n a\n (do (print a)\n (return (+ n 1))))))\n" }, { "path": "finkel-kernel/test/data/syntax/0008-ffi.hs", "content": ";;;; Forms containing FFI.\n\n(module Main)\n\n(import Foreign.C.String ((CString) peekCAString))\n\n;;; 8.4 Foreign Declarations\n\n;;; 8.4.3 Import Declarations\n\n(foreign import ccall (:: rand (IO Int)))\n\n(foreign import ccall \"sin\"\n (:: csin (-> Double Double)))\n\n(foreign import ccall safe \"cos\"\n (:: ccos (-> Double Double)))\n\n(foreign import ccall unsafe \"math.h tan\"\n (:: ctan (-> Double Double)))\n\n(:: s8_4_3 (IO ()))\n(= s8_4_3\n (do (print (csin (* pi 0.5)))\n (print (ccos (* pi 2)))\n (print (ctan pi))))\n\n;;; 8.4.4 Export Declarations\n\n(:: printSomeThing (-> CString (IO ())))\n(= printSomeThing something\n (do (putStrLn \"From printSomething\")\n (<- str (peekCAString something))\n (putStrLn str)))\n\n(foreign export ccall \"printSomeThing\"\n (:: printSomeThing (-> CString ( IO ()))))\n\n;; XXX: Not working. This code compiles with fnkc, but fails to\n;; compile the generated Haskell code. 'Outputable.ppr' for operator\n;; function in FFI export does not use parenthesis in ghc. This also\n;; happens when running ghc with \"-ddump-parsed\" option.\n;;\n;; (foreign export ccall \"addInt\"\n;; (:: + (-> Int Int Int)))\n\n;;; Main\n\n(:: main (IO ()))\n(= main\n s8_4_3)\n" }, { "path": "finkel-kernel/test/data/syntax/0012-pragmas.hs", "content": ";;; Forms containing INLINE, INLINABLE ... etc.\n\n(module Main)\n\n;;; 12.1 Inlining\n\n(:: inlineMe Int)\n(= inlineMe 42)\n%p(INLINE inlineMe)\n\n(:: inlineMe0 Int)\n(= inlineMe0 42)\n%p(INLINE [0] inlineMe0)\n\n(:: inlineMe1 Int)\n(= inlineMe1 42)\n%p(INLINE [1] inlineMe1)\n\n(:: inlineMe2 Int)\n(= inlineMe2 42)\n%p(INLINE [2] inlineMe2)\n\n(:: inlineMeT0 Int)\n(= inlineMeT0 42)\n%p(INLINE [~ 0] inlineMeT0)\n\n(:: inlineMeT0' Int)\n(= inlineMeT0' 42)\n%p(INLINE [~0] inlineMeT0')\n\n(:: dontInlineMe Int)\n(= dontInlineMe 43)\n%p(NOINLINE dontInlineMe)\n\n(:: dontInlineMe1 Int)\n(= dontInlineMe1 43)\n%p(NOINLINE [1] dontInlineMe1)\n\n(:: dontInlineMeT2 Int)\n(= dontInlineMeT2 43)\n%p(NOINLINE [~2] dontInlineMeT2)\n\n(:: iAmInlinable Int)\n(= iAmInlinable 44)\n%p(INLINABLE iAmInlinable)\n\n(:: iAmInlinable0 Int)\n(= iAmInlinable0 44)\n%p(INLINABLE [0] iAmInlinable0)\n\n(:: iAmInlinableT2 Int)\n(= iAmInlinableT2 44)\n%p(INLINABLE [~2] iAmInlinableT2)\n\n(data (I1 a) (I1 a))\n\n(instance (=> (Show a) (Show (I1 a)))\n (= showsPrec _ (I1 a) (showString (++ \"I1 \" (show a))))\n %p(INLINE showsPrec))\n\n(:: inlineprgm (IO ()))\n(= inlineprgm\n (do (print inlineMe)\n (print dontInlineMe)\n (print iAmInlinable)\n (print (show (I1 True)))))\n\n;;; 12.2 Specialization\n\n(:: specializeMe1 (=> (Num a) (Show a) (-> a String)))\n(= specializeMe1 x (show (+ x 1)))\n\n%p(SPECIALIZE (:: specializeMe1 (-> Int String)))\n%p(SPECIALIZE [0] (:: specializeMe1 (-> Integer String)))\n%p(SPECIALIZE [~1] (:: specializeMe1 (-> Float String)))\n%p(SPECIALIZE [2] (:: specializeMe1 (-> Double String)))\n\n(:: specprgm (IO ()))\n(= specprgm\n (do (putStrLn (specializeMe1 (:: 41 Int)))\n (putStrLn (specializeMe1 (:: 41 Integer)))\n (putStrLn (specializeMe1 (:: 41 Double)))\n (putStrLn (specializeMe1 (:: 41 Float)))))\n\n(:: main (IO ()))\n(= main\n (do inlineprgm\n specprgm))\n" }, { "path": "finkel-kernel/test/data/syntax/1000-comment.hs", "content": ";;; -*- mode: finkel -*-\n\n;;;; | File with documentation header comments.\n;;;;\n;;;; Some more documentation strings in consequent lines. Some more\n;;;; documentation strings in consequent lines. Some more documentation\n;;;; strings in consequent lines.\n;;;;\n;;;; Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do\n;;;; eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim\n;;;; ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut\n;;;; aliquip ex ea commodo consequat. Duis aute irure dolor in\n;;;; reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla\n;;;; pariatur. Excepteur sint occaecat cupidatat non proident, sunt in\n;;;; culpa qui officia deserunt mollit anim id est laborum.\n\n(module Main)\n\n{-\n\nSample block comment. All literals between character sequence `#' `|',\nand `|' `#' are block comment. Block comments understand UNICODE\ncharacters:\n\n- 我能吞下玻璃而不伤身体。\n- ฉันกินกระจกได้ แต่มันไม่ทำให้ฉันเจ็บ\n- მინას ვჭამ და არა მტკივა.\n\n-}\n\n;;; * The main function\n\n;;; $foo\n;;;\n;;; Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do\n;;; eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim\n;;; ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut\n;;; aliquip ex ea commodo consequat. Duis aute irure dolor in\n;;; reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla\n;;; pariatur. Excepteur sint occaecat cupidatat non proident, sunt in\n;;; culpa qui officia deserunt mollit anim id est laborum.\n\n;;; | Main entry function.\n(= main\n ;; This is not a documentation comment.\n (foo \"Module with doc comments.\"))\n\n;;; * Other functions\n;;; ** The foo function\n\n(= foo str\n (>> (foo-aux str)\n (bar 15 27)))\n;;; ^ Comment for function foo.\n\n;;; *** Auxiliary function for foo\n\n(= foo-aux putStrLn)\n\n{-onelineblockcommentwithoutspaces-}\n\n;;; ** The bar function\n\n;;; | Comment for function bar.\n;;;\n;;; This comment spans multiple lines. Bar bar bar bar bar bar bar bar\n;;; bar bar bar bar bar bar bar bar bar bar.\n;;;\n;;; Bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar\n;;; bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar\n;;; bar bar bar.\n;;;\n;;; Some unicode strings:\n;;;\n;;; - 我能吞下玻璃而不伤身体。\n;;; - ฉันกินกระจกได้ แต่มันไม่ทำให้ฉันเจ็บ\n;;; - მინას ვჭამ და არა მტკივა.\n\n(:: bar (-> Int ; ^ Arg 1.\n Int ; ^ Arg 2.\n (IO ())))\n(= bar a b\n (putStrLn {-more-}\n (++ {-block-} \"From bar: \" {-comments-} (show (+ a b)))))\n\n;;; ** The buzz function\n\n;;; | Comment for function buzz.\n;;;\n;;; This comment is written on the line above type signature of buzz.\n;;;\n(:: buzz (-> Int Int))\n(= buzz %_(codes inside this list is ignored) n\n %_this_symbol_is_ignored\n (+ n %_\"ignored string literal\" n))\n" }, { "path": "finkel-kernel/test/data/syntax/1001-quote.hs", "content": ";;; Tests for quote, quasiquote, unquote, and unquote-splice.\n\n(module Main)\n\n(import Language.Finkel)\n\n(= f1 arg\n (print ['a 'b arg 'd]))\n\n(= f2 arg\n (print `(a b ,arg d)))\n\n(= f3 arg\n (print `(a b ,@arg d)))\n\n(= f4 arg\n (print `(கிழக்கு බටහිර ,arg Βόρειος)))\n\n(:: main (IO ()))\n(= main\n (do\n ;; \"'foo\" is same as \"(:quote foo)\".\n (print 'foo)\n (print (:quote foo))\n\n ;; Quotes can nest.\n (print ''foo)\n (print '''foo)\n\n ;; Quoting literals\n (print '\"string\")\n (print '42)\n (print '1.23)\n (print '#'c)\n (print '[1 2 3])\n (print '())\n\n ;; Quoting reserved symbols\n (print 'case)\n (print 'class)\n (print 'data)\n (print 'default)\n (print 'do)\n (print 'foreign)\n (print 'infix)\n (print 'infixl)\n (print 'infixr)\n (print 'instance)\n (print 'let)\n (print 'newtype)\n (print 'type)\n (print '!)\n (print '->)\n (print '..)\n (print '::)\n (print '<-)\n (print '=)\n (print '=>)\n (print '@)\n (print '{) (print '})\n (print '|)\n (print '~)\n (print '_)\n (print 'forall)\n (print 'anyclass)\n (print 'as)\n (print 'family)\n (print 'hiding)\n (print 'stock)\n (print 'via)\n (print 'qualified)\n (print ':quote)\n (print '(deriving))\n (print '(import))\n (print '(module))\n (print '(where))\n\n ;; Quoting pragmas\n (print '(UNPACK))\n (print '(OVERLAPPABLE))\n (print '(OVERLAPPING))\n (print '(OVERLAPS))\n (print '(INCOHERENT))\n\n ;; Quoting doc comments\n (print '(:doc \"xxxx\"))\n (print '(:doc^ \"xxxx\"))\n (print '(:doc$ key \"xxxx\"))\n (print '(:dh1 \"xxxx\"))\n (print '(:dh2 \"xxxx\"))\n (print '(:dh3 \"xxxx\"))\n (print '(:dh4 \"xxxx\"))\n\n ;; Quasiquote.\n (print `foo)\n (print (:quasiquote foo))\n\n (f1 'foo)\n (f2 'foo)\n (f3 '(foo bar buzz))\n (f3 '[\\x \\y \\z])\n (f3 ['foo 'bar 'buzz])\n (f4 'みなみ)))\n" }, { "path": "finkel-kernel/test/data/syntax/1002-macro.hs", "content": ";;; Tests for macros.\n\n(module Main)\n\n(:eval-when-compile\n (import Prelude)\n (import Language.Finkel))\n\n(import Language.Finkel)\n\n(:eval-when-compile\n (:: define-macro Macro)\n (= define-macro\n (Macro (\\form\n (case (unCode form)\n (List (: _ (: name rest)))\n (let ((= __name\n (toCode (qSymbol (++ \"__\" (show name))\n \"1002-macro.fnk\"\n 0 0 0 0))))\n (return\n `(:begin\n (:: ,name Macro)\n (= ,name\n (let ((:: ,__name (-> Code (Fnk Code)))\n (= ,__name ,@rest))\n (Macro ,__name))))))\n _ (finkelSrcError form \"define-macro: invalid args\")))))\n\n (:: let-macro Macro)\n (= let-macro\n (let ((= f form\n (case (unCode form)\n (List [name arg body])\n (let ((= __name (toCode (qSymbol (++ \"__\" (show name))\n \"1002-macro.fnk\"\n 0 0 0 0))))\n (return `(= ,name\n (let ((:: ,__name (-> Code (Fnk Code)))\n (= ,__name ,arg ,body))\n (Macro ,__name)))))\n _ (finkelSrcError form \"let-macro: malformed macro\"))))\n (Macro (\\form\n (case (unCode form)\n (List (: _self (: (LForm (L _l (List ms))) rest)))\n (do (<- ms' (mapM f ms))\n (return `(:with-macro (,@ms') ,@rest)))\n _ (finkelSrcError form \"let-macro: malformed args\")))))))\n\n(:eval-when-compile\n (define-macro define-macro' form\n (case (unCode form)\n (List (: _ rest)) (return\n `(:begin\n (:eval-when-compile\n (define-macro ,@rest))\n (define-macro ,@rest)))\n _ (finkelSrcError form \"error\"))))\n\n;; Simple version of `defmacro' defined with `define-macro''\n(define-macro' defmacro form\n (case form\n (LForm (L _ (List [_self name args body])))\n (case args\n (LForm (L _ (List _)))\n (return\n `(define-macro' ,name form\n (case form\n (LForm (L l1 (List [_ ,@args]))) (return ,body)\n _ (finkelSrcError ',name \"error\"))))\n _ (return `(define-macro ,name ,args\n (return ,body))))\n _ (finkelSrcError form \"error\")))\n\n;;; Using `defmacro' defined above.\n(defmacro m1 (x y)\n `(putStrLn (concat [,x \", \" ,y])))\n\n(define-macro' m2 form\n (where (case form\n (LForm (L _ (List [_self arg1 arg2])))\n (return (mkbody arg1 arg2)))\n (= mkbody x y\n `(print (+ (:: ,x Int) (:: ,y Int))))))\n\n;; Simple `let-macro'.\n(let-macro ((m2a form\n (case form\n (LForm (L _ (List [_ a b c]))) (return `(,a (+ ,b ,c)))\n _ (finkelSrcError form \"m2a: error\")))\n (m2b form\n (case form\n (LForm (L _ (List [_ x y]))) (return `(+ ,x ,y))\n _ (finkelSrcError form \"m2b: error\"))))\n (:: f1 (-> Int Int (IO ())))\n (= f1 x y\n (m2a print x (m2b x y))))\n\n;;; Macro taking fractional value as argument.\n(let-macro ((m1 form\n (case form\n (LForm (L l (List [_ x])))\n (case (fromCode x)\n (Just d) (if (<= 1.0 (:: d Double))\n (return '\"more or eq to one\")\n (return '\"less than one\"))\n Nothing (return '\"not a double\"))\n _ (finkelSrcError form \"m1: invalid args\"))))\n (:: fracmac (IO ()))\n (= fracmac\n (do (putStrLn (m1 1.1))\n (putStrLn (m1 0.9))\n (putStrLn (m1 #'x)))))\n\n;;; Macro returning haskell list.\n(let-macro ((m2 form\n (case form\n (LForm (L l (List [_ a b c])))\n (let ((:: mbints (Maybe (, Int Int Int)))\n (= mbints\n (do (<- x (fromCode a))\n (<- y (fromCode b))\n (<- z (fromCode c))\n (return (, x y z)))))\n (case mbints\n (Just (, x y z))\n (return `[,(* x 100) ,(* y 100) ,(* z 100)])\n _ (finkelSrcError form \"m2: invalid args\")))\n _ (finkelSrcError form \"m2: invalid form\"))))\n (:: hslistmac (IO ()))\n (= hslistmac\n (print (m2 1 2 3))))\n\n(let-macro ((identity-form form\n (case (unCode form)\n (List [_ body]) (return body))))\n (identity-form\n (define-macro' m4 _\n (return `(putStrLn \"m4\")))))\n\n(:: m4run (IO ()))\n(= m4run (m4))\n\n(define-macro' m5 form\n (case (unCode form)\n (List [_ arg1 body])\n (do (<- tmp gensym)\n (return `(let ((= ,tmp (* ,arg1 2)))\n (sequence_ (replicate ,tmp ,body)))))\n\n _ (finkelSrcError form \"m5-ok\")))\n\n(:: m5run (IO ()))\n(= m5run\n (let ((= x 123))\n (m5 2 (print x))))\n\n;;; XXX: Haskell source code generated from below expression does not\n;;; compile, since the line containing `let ... in ...' get long with\n;;; temporary name generated by gensym. The `do' block cannot understand\n;;; the line starting with `in', because the line does not have\n;;; indentation clue.\n\n;; (:: m5run-v2 (IO ()))\n;; (= m5run-v2\n;; (do (let ((= x 123)))\n;; (m5 2 (print x))))\n\n(:: main (IO ()))\n(= main\n (do (m1 \"Hello\" \"macro\")\n (m2 11 31)\n (f1 11 20)\n fracmac\n hslistmac\n m4run\n m5run))\n" }, { "path": "finkel-kernel/test/data/syntax/1003-eval-when-compile.hs", "content": ";;;; -*- mode: finkel -*-\n;;;;\n;;;; Code containing `eval-when-compile'.\n\n(module Main)\n\n;;; Function declaration and macro definition done during compilation\n;;; phase. Codes inside `eval-when-compile' do won't appear in resulting\n;;; Haskell code.\n(:eval-when-compile\n (import Prelude)\n (import Language.Finkel)\n\n ;; Function called later from macro `m1'.\n (:: f1 (-> Int Int Int))\n (= f1 a b (+ a b))\n\n ;; Macro defined in compiler's interactive context.\n (:: macro-ct Macro)\n (= macro-ct\n (Macro (const (return '(putStrLn \"From `macro-ct'.\"))))))\n\n;;; Macro `m1' is calling `f1' declared above.\n(:with-macro ((= m1\n (Macro (\\_form\n (let ((= ret (* (f1 4 2) 7)))\n (return (toCode ret)))))))\n (:: main (IO ()))\n (= main\n (do (macro-ct)\n (print (m1)))))\n" }, { "path": "finkel-kernel/test/data/syntax/1004-doccomment-01.hs", "content": ";;; -*- mode: finkel -*-\n\n%p(LANGUAGE RankNTypes\n TypeFamilies)\n(:doc \"\nModule : Main\nDescription : Module for documentation comment\nCopyright : (c) someone, someyear\nLicense : GPL-3\nMaintainer : foo@bar.com\nStability : experimental\nPortability : POSIX\n\nModule header documentation.\n\nThis comment is written inside `:doc' form.\")\n\n(module Main\n (:dh1 \"The main function\")\n (:doc \"Main entry point function.\nThis function is performed from compiled executable.\")\n main\n\n (:dh1 \"Types and classes\")\n (:doc$ auxdt)\n (D1 ..) (D2 ..) (D3 ..) (D4 ..) (T1)\n (C1 ..) (C2 ..) (TF1) (DF1)\n\n (:dh1 \"Functions\")\n (:doc$ auxfn)\n f1 f2 f3 f4 f5 f6)\n\n\n;;; Functions\n\n(:doc$ auxfn \"Section documentation for auxiliary functions.\")\n\n(:doc \"Documentation of 'f1'\")\n(:: f1 (-> String (IO ())))\n(= f1 str (putStrLn (++ \"From f1: \" str)))\n\n(:doc \"Documentation of 'f2'\")\n(:: f2 (-> String (IO ())))\n(= f2 (. putStrLn (++ \"From f2: \")))\n\n(:doc \"Documentation of 'f3'\")\n(:: f3 (-> Int (:doc^ \"Single line comment\")\n String\n (:doc^ \"Multiple lines comment for the second argument.\n\nLorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod\ntempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim\nveniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea\ncommodo consequat. Duis aute irure dolor in reprehenderit in voluptate\nvelit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint\noccaecat cupidatat non proident, sunt in culpa qui officia deserunt\nmollit anim id est laborum.\")\n (IO ())\n (:doc^ \"Action to print given message for given times\")))\n(= f3 n msg\n (sequence_ (replicate n (putStrLn msg))) )\n\n(:: f4 (forall a (-> a (:doc^ \"Documentation for first argument.\")\n a (:doc^ \"Documentation for result.\"))))\n(:doc^ \"Documentation for 'f4'.\n\nThis function contains unnecessary explicit @forall@ keyword.\")\n(= f4 x x)\n\n(:: f5\n (-> (forall a (-> a a))\n (:doc^ \"Documentation for first arg.\")\n (, Char Bool)\n (:doc^ \"Documentation for result.\")))\n(:doc^ \"Documentation for 'f5'.\n\nThis function contains rank-n type function argument.\")\n\n(= f5 f (, (f #'a) (f True)))\n\n(:: f6\n (=> (Show a) (Show b)\n (-> a (:doc^ \"Documentation for first arg.\")\n b (:doc^ \"Documentation for second arg.\")\n String (:doc^ \"Documentation for result.\"))))\n(:doc^ \"Documentation for 'f6'.\n\nExample for writing documentation for argument, with a function\ncontaining type class constraints. This documentation comment includes\n@since@ metadata.\n\n@since 1.2.3.4.5.6.7\")\n\n(= f6 a b\n (++ \"f6: a=\" (show a) \", b=\" (show b)))\n\n\n;;; Types and classes\n\n(:doc$ auxdt \"Section documentation for auxiliary data and types.\")\n\n;;; Unlike haddock comment in Haskell source code, constructor\n;;; documentation comments are allowed for ':doc^' forms only.\n\n(:doc \"Documentation for data type 'D1'.\")\n(data (D1 a b)\n (D1a a)\n (:doc^ \"Documentation for 'D1a'.\n\nThis comment contains empty lines.\n\nTo add a line break in generated HTML document, need to add an empty\nline. Otherwise, line breaks in source codes will disappear.\")\n\n (D1ab a (:doc^ \"The first argument of `D1ab'.\")\n b (:doc^ \"The 2nd.\")\n Int (:doc^ \"Documentation for the 3rd argument of `D1ab'.\n\nLorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod\ntempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim\nveniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea\ncommodo consequat. Duis aute irure dolor in reprehenderit in voluptate\nvelit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint\noccaecat cupidatat non proident, sunt in culpa qui officia deserunt\nmollit anim id est laborum.\")\n Int (:doc^ \"The 4th.\"))\n (:doc^ \"Documentation for constructor 'D1ab'.\")\n (deriving Eq Show))\n\n(newtype (D2 a)\n (D2 a)\n (:doc^ \"Documentation for constructor `D2'.\"))\n(:doc^ \"Documentation for top level newtype declaration.\")\n\n(data (D3 a)\n (:doc \"Documentation for 'D3a'.\")\n (D3a {(:: d3_f1 Int) (:doc^ \"Documentation for 'd3_f1' field.\")\n\n (:: d3_f2 a) (:doc^ \"Documentation for 'd3_f2' field.\n\nLorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod\ntempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim\nveniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea\ncommodo consequat. Duis aute irure dolor in reprehenderit in voluptate\nvelit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint\noccaecat cupidatat non proident, sunt in culpa qui officia deserunt\nmollit anim id est laborum.\")\n (:: d3_f3 d3_f4 a)\n (:doc^ \"Documentation for 'd3_f3' and 'd3_f4' fields.\")})\n\n (:doc \"Documentation for 'D3b'.\")\n (D3b a a)\n\n (deriving Eq Show))\n(:doc^ \"Documentation for top level 'D3' data type declaration.\")\n\n(:doc \"Documentation for top level `D4' data type declaration.\")\n(data (D4 a)\n (:doc \"Documentation for `D4a'.\")\n (D4a {(:doc \"Documentation for `d4_f1'.\")\n (:: d4-f1 Int)\n (:doc \"Documentation for `d4_f2' and `d4_f3'.\")\n (:: d4-f2 d4-f3 a)})\n (:doc \"Documentation for `D4b'\")\n D4b\n (deriving Eq Show))\n\n(type (T1 a)\n (Maybe (, a a))\n (:doc^ \"T1 is a synonym of optional pair of __@a@__ values.\"))\n(:doc^ \"Documentation for top level 'T1' type synonym.\")\n\n(class (C1 a)\n (type (C1T1 a))\n (:doc^ \"Documentation for 'C1T1'.\")\n\n (type (C1T2 a))\n (:doc^ \"Documentation for 'C1T2'.\n\nLorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod\ntempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim\nveniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea\ncommodo consequat. Duis aute irure dolor in reprehenderit in voluptate\nvelit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint\noccaecat cupidatat non proident, sunt in culpa qui officia deserunt\nmollit anim id est laborum.\")\n\n (:: c1_m1 (-> a String))\n (:doc^ \"Documentation for `c1_m1' method in 'C1'.\")\n\n (:: c1_m2 (-> a (:doc^ \"1st arg.\")\n a (:doc^ \"2nd arg.\")\n String))\n (:doc^ \"documentation for `c1_m2' method in 'C1'.\n\nThis method takes two __@a@__ arguments. \"))\n\n(:doc^ \"Documentation for top level 'C1' type class.\")\n\n(:doc \"Documentation for top level `C2' type class.\")\n(class (C2 a)\n (:doc \"Documentation for `C2T1'.\")\n (type (C2T1 a))\n\n (:doc \"Documentation for `c2_m1'.\")\n (:: c2-m1 (-> a String))\n\n (:doc \"Documentation for `c2_m2'.\")\n (:: c2-m2 (-> (C2T1 a) (:doc^ \"1st arg.\")\n a (:doc^ \"2nd arg.\")\n String)))\n\n(:doc \"Documentation for instance declaration of `C2' for `Int'.\")\n(instance (C2 Int)\n (type (C2T1 Int) Int)\n (= c2_m1 show)\n (= c2_m2 a1 a2\n (++ \"arg1=\" (show a1) \", arg2=\" (show a2))))\n\n(type family (TF1 a))\n(:doc^ \"Documentation for top level 'TF1' type family.\")\n\n(type instance (TF1 Bool) Int)\n(:doc^ \"Documentation for top level `TF1' instance for `Bool'.\")\n\n(data family (DF1 a))\n(:doc^ \"Documentation for top level data family `DF1'.\")\n\n(data instance (DF1 Bool) (DF1B Int)\n (deriving Eq Show))\n(:doc^ \"Documentation for top level `DF1' instance for `Bool'.\")\n\n(data instance (DF1 Double)\n (DF1D1 Double)\n (DF1D2 Int)\n (deriving Eq Show))\n(:doc^ \"Documentation for top level `DF1' instance for `Double'.\")\n\n(newtype instance (DF1 Char)\n (DF1C Bool))\n(:doc^ \"Documentation for top level `DF1' instance for `Char'.\")\n\n;;; Main function\n\n(:: main (IO ()))\n(:doc^ \"Documentation of 'main'.\")\n(= main\n (do (putStrLn \"documentation comment tests.\")\n (f1 \"foo\")\n (f2 \"bar\")\n (f3 3 \"buzz\")))\n" }, { "path": "finkel-kernel/test/data/syntax/1004-doccomment-02.hs", "content": ";;; -*- mode: finkel -*-\n\n(:doc \"Module without explicit export entities.\")\n(module Main)\n\n(:dh1 \"Level 1\")\n(:dh2 \"Level 2\")\n(:dh3 \"Level 3\")\n\n(:doc \"Docmentation for 'foo'.\")\n(:: foo (-> Int Int))\n(= foo succ)\n\n(:dh1 \"Level 1\")\n(:doc$ main \"Named comment.\")\n\n(:doc \"Documentation for 'main'.\")\n(:: main (IO ()))\n(= main (print (foo 41)))\n" }, { "path": "finkel-kernel/test/data/syntax/1004-doccomment-03.hs", "content": ";;; Doccomment with unusable UNPACK pragma\n\n(module Main)\n\n(:doc \"Documentation for data type 'D1'.\")\n(data (D1 a b)\n (D1a a)\n (:doc^ \"Documentation for 'D1a'.\")\n\n (D1b %p(UNPACK) !b)\n (:doc^ \"Documentation for 'D1b', has unusable UNPACK pragma.\n\nThis comment contains empty lines.\n\nA line containing some foo: Foo foo foo foo, foo foo, and foo.\")\n\n (D1ab a (:doc^ \"The first argument 'D1ab.\")\n b (:doc^ \"The 2nd.\")\n Int (:doc^ \"The 3rd.\"))\n\n (deriving Show))\n\n(:: main (IO ()))\n(= main\n (print [(D1a True) (D1b False)]))\n" }, { "path": "finkel-kernel/test/data/syntax/1005-begin.hs", "content": ";;; Tests for begin.\n\n(:begin\n (module Main)\n (:begin\n (:: bgn01 (IO ()))\n (= bgn01\n (do (putStrLn \"=== start bgn01 ===\")\n (putStrLn \":begin\")\n (putStrLn \"in\")\n (putStrLn \"do\")\n (putStrLn \"=== end bgn01 ===\")))))\n\n(:begin\n (:: bgn02 (IO ())))\n(:begin\n (= bgn02\n (let ((= f str\n (putStrLn str))\n (= g str\n (concat [\"=== \" str \" ===\"])))\n (f (g \"bgn02\")))))\n\n(:begin\n (:begin\n (:: bgn03 (IO ())))\n (:begin\n (:begin\n (= bgn03\n (let ((= f str (++ \"f:\" str))\n (= g str (++ \"g:\" str)))\n (putStrLn (f (g \"bgn03\"))))))))\n\n(:: main (IO ()))\n(= main\n (do bgn01\n bgn02\n bgn03))\n" }, { "path": "finkel-kernel/test/data/syntax/2001-unpack.hs", "content": ";;;; \"UNPACK\" and \"SPECIALIZE INLINE\" pragma\n\n%p(LANGUAGE GADTs)\n\n(module Main)\n\n;;; UNPACK\n\n(data D1\n (C1 %p(UNPACK) (! Int)\n %p(UNPACK) !Char)\n (deriving Eq Show))\n\n(data D2\n (C2 {(:: c2field1 %p(UNPACK) !Int)\n (:: c2field2 %p(UNPACK) (! Char))})\n (deriving Eq Show))\n\n(:: unpackprgm (IO ()))\n(= unpackprgm\n (do (print (C1 42 #'x))\n (print (C2 42 #'x))))\n\n;; SPECIALIZE INLNE\n\n(data (Lst e)\n (:: LstInt (-> !Int [Int] (Lst Int)))\n (:: LstPair (-> !Int (Lst e1) (Lst e2) (Lst (, e1 e2)))))\n\n(:: !: (-> (Lst e) Int e))\n(= !: (LstInt _ xs) i (!! xs i))\n(= !: (LstPair _ l1 l2) i (, (!: l1 i) (!: l2 i)))\n\n%p(SPECIALIZE INLINE (:: !: (-> (Lst Int) Int Int)))\n%p(SPECIALIZE INLINE (:: !: (-> (Lst (, a b)) Int (, a b))))\n\n(:: main (IO ()))\n(= main unpackprgm)\n" }, { "path": "finkel-kernel/test/data/syntax/2002-bang.hs", "content": ";;;; Bang patterns\n\n%p(LANGUAGE BangPatterns)\n\n(:: bp01 (-> Int Int Int))\n(= bp01 !a !b (+ a b))\n\n(:: bp02 (-> (, Int Int) (IO ())))\n(= bp02 (, !a b)\n (print (if (even a) b a)))\n\n(:: bp03 (-> Int (IO ())))\n(= bp03 n\n (let ((= !x (* n 2))\n (= f i (, () (replicate i ())))\n (= (, !y _) (f n)))\n (>> (print x) (print y))))\n\n(:: bp04 (-> Int (IO ())))\n(= bp04 n\n (let ((:: f (-> a [a]))\n (= f x [x x x]))\n (case (f n)\n !ys (print (length ys)))))\n\n(:: bp05 (-> Int (IO ())))\n(= bp05 n\n (let ((= ![x y] (replicate 2 n))\n (= !(, a b) (, n n)))\n (do (print (+ x y))\n (print (+ a b)))))\n\n(:: bp06 (-> Int (IO ())))\n(= bp06 !name-with-hyphens\n (print name-with-hyphens))\n\n(:: non-bp01 (-> Int (IO ())))\n(= non-bp01 n\n (let ((= ! a b (+ a b)))\n (print (! n (+ n 2)))))\n\n(:: main (IO ()))\n(= main\n (do (print (bp01 10 32))\n (bp02 (, 21 42))\n (bp03 21)\n (bp04 21)\n (bp05 21)\n (non-bp01 20)))\n" }, { "path": "finkel-kernel/test/data/syntax/2003-derive.hs", "content": ";;;; DeriveXXX language extensions\n\n%p(LANGUAGE DeriveDataTypeable\n DeriveFoldable\n DeriveGeneric\n DeriveTraversable\n GeneralizedNewtypeDeriving)\n\n(module Main)\n\n(import Data.Data)\n(import GHC.Generics)\n\n;;; DeriveDataTypeable\n\n(data (D1 a)\n (D1 a a)\n (deriving Eq Show Data Typeable))\n\n;;; DeriveFunctor\n\n(data (D2 a)\n (D2 a)\n (deriving Eq Show Functor))\n\n;;; DeriveGeneric\n\n(data (D3 a)\n (D3 a)\n (deriving Eq Show Generic))\n\n;;; DeriveFoldable, DeriveTraversable\n\n(data (Lst a)\n Nil\n (Cons a (Lst a))\n (deriving Eq Show Functor Foldable Traversable))\n\n;;; GeneralizedNewtypeDeriving\n\n(newtype (N a)\n (N a)\n (deriving Eq Show Num))\n\n(:: main (IO ()))\n(= main\n (do (print (typeOf (D1 True False)))\n (print (dataTypeOf (D1 #'a #'b)))\n (print (fmap succ (D2 (:: 41 Int))))\n (print (from (D3 False)))\n (let ((:: l1 (Lst Int))\n (= l1 (Cons 1 (Cons 2 (Cons 3 Nil))))))\n (print (foldr + 0 l1))\n (sequence_ (fmap print l1))\n (let ((:: l1 (Lst Int))\n (= l1 (Cons 1 (Cons 2 (Cons 3 Nil))))))\n (print (foldr + 0 l1))\n (sequence_ (fmap print l1))\n (print (+ (N (:: 20 Int)) (N 22)))))\n" }, { "path": "finkel-kernel/test/data/syntax/2004-overloaded.hs", "content": ";;;; OverloadedXXX language extensions\n\n%p(LANGUAGE OverloadedLists\n OverloadedStrings)\n\n(module Main)\n\n(import Data.ByteString ((ByteString)))\n(import Data.Set ((Set)))\n\n;;; OverloadedString\n\n(:: f1 ByteString)\n(= f1 \"foo\")\n\n;;; OverloadedLists\n\n(:: f2 (Set Char))\n(= f2 [#'a #'e #'i #'o #'u])\n\n;;; Main\n\n(:: main (IO ()))\n(= main\n (do (print f1)\n (print f2)))\n" }, { "path": "finkel-kernel/test/data/syntax/2005-gadts-01.hs", "content": ";;; GADTs\n\n%p(LANGUAGE GADTs KindSignatures RankNTypes)\n\n(module Main)\n\n(import Data.Kind)\n\n(data (Expr a)\n (:: I (-> Int (Expr Int)))\n (:: B (-> Bool (Expr Bool)))\n (:: Add (-> (Expr Int) (Expr Int) (Expr Int)))\n (:: Mul (-> (Expr Int) (Expr Int) (Expr Int)))\n (:: Eq (=> (Eq a) (-> (Expr a) (Expr a) (Expr Bool)))))\n\n(:: eval (-> (Expr a) a))\n(= eval e\n (case e\n (I n) n\n (B b) b\n (Add x y) (+ (eval x) (eval y))\n (Mul x y) (* (eval x) (eval y))\n (Eq x y) (== (eval x) (eval y))))\n\n(:: gadt1 (IO ()))\n(= gadt1\n (print (eval (Eq (Mul (Add (I 10) (I 11)) (I 2))\n (I 42)))))\n\n;; GADTs with UNPACK pragmas.\n\n(data (G2 a)\n (:: G2a (-> !(Maybe a) (G2 a)))\n (:: G2b (-> %p(UNPACK) !Int (G2 Int)))\n (:: G2c (-> !a %p(UNPACK) !Int (G2 a))))\n\n(instance (=> (Show a) (Show (G2 a)))\n (= show (G2a a) (concat [\"G2a (\" (show a) \")\"]))\n (= show (G2b a) (concat [\"G2b (\" (show a) \")\"]))\n (= show (G2c a b) (concat [\"G2c (\" (show a) \" \" (show b) \")\"])))\n\n(:: gadt2 (-> Int (IO ())))\n(= gadt2 n\n (do (print (G2a (Just #'x)))\n (print (G2b n))\n (print (G2c n 43))))\n\n;; GADTs with documentation comments.\n\n(:doc \"Documentation for top level `G3' data type declaration.\")\n(data (G3 a)\n (:doc \"Documentation for `G3a'.\")\n (:: G3a (-> a (G3 a)))\n (:doc \"Documentation for `G3Int'\")\n (:: G3Int (-> Int (:doc^ \"An integer number.\")\n (G3 Int))))\n\n(:doc \"Documentation for `Show' instance of `G3'.\")\n(instance (=> (Show a) (Show (G3 a)))\n (= show g3\n (case g3\n (G3a a) (++ \"G3a\" (show a))\n (G3Int n) (++ \"G3Int \" (show n)))))\n\n(:: gadt3 (-> Int (IO ())))\n(= gadt3 n\n (do (print (G3a True))\n (print (G3Int n))))\n\n;;; GADTs with `deriving'\n\n(data (Maybe1 a)\n (:: Nothing1 (Maybe1 a))\n (:: Just1 (-> a (Maybe1 a)))\n (deriving Eq Show))\n\n(:: gadt4 (-> Int (IO ())))\n(= gadt4 n\n (print [Nothing1 (Just1 n)]))\n\n;;; XXX: GADTs with multiple constructors with single signature\n\n;; (data Multi\n;; (:: (MA MB) Multi)\n;; (:: MC (-> Int Multi)))\n\n;;; XXX: GADTs with record syntax\n\n;; (data Person\n;; (:: Adult (-> {name String children [Person]} Person))\n;; (:: Child (=> (Show a) (-> {name !String funny a} Person))))\n\n;; (:: gadt5 (-> Int (IO ())))\n;; (= gadt5 n\n;; (do (let ((= adult (Adult {name \"foo\" children [child]}))\n;; (= child (Chilc [name \"bar\" funny n]))))\n;; (putStrLn (name adult))\n;; (putStrLn (name child))\n;; (mapM_ (. print funny) (children adult))))\n\n;;; GADTs with kind signature\n\n(data Ze)\n(data (Su n))\n\n(data (:: Vec (-> Type Type Type))\n (:: Nil (Vec a Ze))\n (:: Cons (-> a (Vec a n) (Vec a (Su n)))))\n\n;;; GADT and RankNTypes\n\n(data (Equal a b)\n (:: Refl (Equal a a)))\n\n(:: subst (-> (Equal a b) (=> (~ a b) r) r))\n(= subst Refl r r)\n\n;;; Main function\n\n(:: main (IO ()))\n(= main\n (do gadt1\n (gadt2 42)\n (gadt3 42)\n (gadt4 42)))\n" }, { "path": "finkel-kernel/test/data/syntax/2005-gadts-02.hs", "content": ";;; GADTs with unusable UNPACK pragmas.\n\n%p(LANGUAGE GADTs)\n\n(module Main)\n\n(data (G2 a)\n (:: G2a (-> %p(UNPACK) !(Maybe a) (G2 a)))\n (:: G2b (-> %p(UNPACK) !Int (G2 Int)))\n (:: G2c (-> %p(UNPACK) !a %p(UNPACK) !Int (G2 a))))\n\n(instance (=> (Show a) (Show (G2 a)))\n (= show (G2a a) (concat [\"G2a (\" (show a) \")\"]))\n (= show (G2b a) (concat [\"G2b (\" (show a) \")\"]))\n (= show (G2c a b) (concat [\"G2c (\" (show a) \" \" (show b) \")\"])))\n\n(:: gadt2 (-> Int (IO ())))\n(= gadt2 n\n (do (print (G2a (Just #'x)))\n (print (G2b n))\n (print (G2c n 43))))\n\n(:: main (IO ()))\n(= main (gadt2 42))\n" }, { "path": "finkel-kernel/test/data/syntax/2006-existential.hs", "content": ";;;; Existential Quantification language extension\n\n%p(LANGUAGE ExistentialQuantification)\n\n(module Main)\n\n(data AnyShow1\n (forall a (=> (Show a) (AnyShow1 a))))\n\n(instance (Show AnyShow1)\n (= show (AnyShow1 a)\n (concat [\"(AnyShow \" (show a) \")\"])))\n\n(data AnyShow2\n (forall a b (=> (Show a) (Show b)\n (AnyShow2 {(:: as2a a) (:: as2b b)}))))\n\n(instance (Show AnyShow2)\n (= show (AnyShow2 {(= as2a a) (= as2b b)})\n (concat [\"(AnyShow2 \" (show a) \" \" (show b) \")\"])))\n\n(data (AnyShow3 a)\n (=> (Show a) AnyShow3))\n\n(:: show3 (-> (AnyShow3 a) a String))\n(= show3 AnyShow3 a (show a))\n\n(:: main (IO ()))\n(= main\n (do (print [(AnyShow1 (:: 42 Int))\n (AnyShow1 False)\n (AnyShow1 #'x)])\n (print [(AnyShow2 (:: 42 Int) (:: 43 Integer))\n (AnyShow2 False (Just #'x))\n (AnyShow2 #'x \"bar\")])\n (print (show3 AnyShow3 True))))\n" }, { "path": "finkel-kernel/test/data/syntax/2007-rankn.hs", "content": ";;;; RankNTypes\n\n%p(LANGUAGE RankNTypes)\n\n(module Main)\n\n(:: f3 (-> (forall a (-> a a)) (, Char Bool)))\n(= f3 f (, (f #'a) (f True)))\n\n(:: main (IO ()))\n(= main\n (print (f3 id)))\n" }, { "path": "finkel-kernel/test/data/syntax/2008-options.hs", "content": ";;;; OPTIONS_GHC and OPTIONS_HADDOCK pragma.\n\n%p(LANGUAGE DeriveFoldable)\n%p(OPTIONS_GHC -Wall)\n%p(LANGUAGE DeriveFunctor)\n%p(OPTIONS_HADDOCK prune)\n%p(OPTIONS_GHC -fspec-constr-keen)\n%p(LANGUAGE GeneralizedNewtypeDeriving)\n\n(module Main)\n\n(:: main (IO ()))\n(= main\n (putStrLn \"File with OPTIONS_GHC\"))\n" }, { "path": "finkel-kernel/test/data/syntax/2009-flexible.hs", "content": ";;;; Flexible instance related language extension and overlap pragmas\n\n%p(LANGUAGE FlexibleContexts\n FlexibleInstances\n MultiParamTypeClasses\n NoMonomorphismRestriction\n TypeSynonymInstances)\n\n(module Main)\n\n;;; Multi param type classes\n\n(class (C1 m a b)\n (:: c1 (-> (m a) (m b) (IO ()))))\n\n(instance (C1 IO Bool Char)\n (= c1 a b\n (do (<- a' a)\n (<- b' b)\n (putStrLn (concat [\"c1: \" (show a') \", \" (show b')])))))\n\n;;; Flexible instances\n\n;; Use of `Either String' requires `FlexibleInstances'.\n(instance (C1 (Either String) Bool Char)\n (= c1 a b\n (where (f a b)\n (= f (Right b1) (Right b2) (pr (show b1) (show b2)))\n (= f (Right b1) (Left s2) (pr (show b1) s2))\n (= f (Left s1) (Right b2) (pr s1 (show b2)))\n (= f (Left s1) (Left s2) (pr s1 s2))\n (= pr x y\n (putStrLn (concat [\"c1: \" x \", \" y]))))))\n\n;;; Flexible contexts\n\n(class (C2 a b)\n (:: c2 (-> a b)))\n\n(instance (C2 Bool String)\n (= c2 bool (++ \"bool: \" (show bool))))\n\n(:: c2str (=> (C2 a String) (-> a String)))\n(= c2str c2)\n\n;;; GHC Extension: overlap mode\n\n(instance %p(OVERLAPS) (=> (Show a) (C2 a String))\n (= c2 show))\n\n(class (C2b a b)\n (:: c2b (-> a b)))\n\n(instance (C2b Bool String)\n (= c2b bool (++ \"[c2b] bool:\" (show bool))))\n\n(instance %p(OVERLAPPABLE) (=> (Show a) (C2b a String))\n (= c2b (. (++ \"[c2b] \") show)))\n\n(class (C2c a b)\n (:: c2c (-> a b)))\n\n(instance %p(OVERLAPPING) (C2c Bool String)\n (= c2c bool (++ \"[c2c] bool:\" (show bool))))\n\n(instance (=> (Show a) (C2c a String))\n (= c2c (. (++ \"[c2c] \") show)))\n\n(class (C2d a b)\n (:: c2d (-> a b)))\n\n(instance (C2d Bool String)\n (= c2d bool (++ \"[c2d] bool:\" (show bool))))\n\n(instance %p(INCOHERENT) (=> (Show a) (C2d a String))\n (= c2d (. (++ \"[c2d] \") show)))\n\n;;;; NoMonomorphismRestriction and TypeSynonymInstances\n\n(class (C3 a)\n (:: int (-> Int a))\n (:: add (-> a a a)))\n\n(instance (C3 String)\n (= int show)\n (= add a b (concat [\"(\" a \" + \" b \")\"])))\n\n(= c3-f1 (add (int 1) (add (int 2) (int 3))))\n\n;;; Main\n\n(:: main (IO ()))\n(= main\n (do (c1 (:: (return False) (IO Bool)) (return #'x))\n (c1 (:: (return True) (Either String Bool)) (return #'y))\n (let ((:: n Int)\n (= n 42)))\n (putStrLn (c2str True))\n (putStrLn (c2str n))\n (putStrLn (c2b True))\n (putStrLn (c2b n))\n (putStrLn (c2c True))\n (putStrLn (c2c n))\n (putStrLn (c2d True))\n (putStrLn (c2d n))\n (putStrLn c3-f1)\n (putStrLn (add (add (int 1) (int 2))\n (add (int 3) (int 4))))))\n" }, { "path": "finkel-kernel/test/data/syntax/2010-kindsig.hs", "content": ";;;; Kind signatues\n\n%p(LANGUAGE ExplicitForAll\n KindSignatures\n MultiParamTypeClasses)\n\n(module Main)\n\n(import Data.Kind ((Type)))\n\n(data (KS1 (:: m (-> Type Type)) a)\n (KS1 [a]))\n\n(data (KS2 (:: m (-> * *)) a)\n (KS2 [a]))\n\n(newtype (KS3 (:: m (-> Type Type)) a)\n (KS3 [a])\n (deriving Show))\n\n(type (KS4 (:: f (-> Type Type)))\n (f Int))\n\n(class (KS5 (:: f (-> Type Type)) a)\n (:: ks5 (-> (f Int) a)))\n\n(:: f_ks1 (-> (:: Int Type) Int))\n(= f_ks1 (+ 1))\n\n(:: f_ks2 (forall (:: a *) (-> a a)))\n(= f_ks2 x x)\n\n(:: f_ks3 (forall a (-> a (:: a Type))))\n(= f_ks3 x x)\n\n(:: f_ks4 (forall (:: a *) (:: b *) (-> a b a)))\n(= f_ks4 x _ x)\n\n(:: main (IO ()))\n(= main\n (do (case (KS1 [(:: 1 Int) 2 3])\n (KS1 xs) (print xs))\n (case (KS2 [(:: 4 Int) 5 6])\n (KS2 xs) (print xs))\n (print (KS3 [(:: 7 Int) 8 9]))\n (print (:: (Just 42) (KS4 Maybe)))\n (print (f_ks1 41))\n (print (f_ks2 \"f_ks2\"))\n (print (f_ks3 \"f_ks3\"))\n (print (f_ks4 \"f_ks4\" undefined))))\n" }, { "path": "finkel-kernel/test/data/syntax/2011-scoped.hs", "content": ";;;; Scoped Type Variable\n\n%p(LANGUAGE ScopedTypeVariables)\n\n(data Zero)\n(data (Succ n))\n\n(type One (Succ Zero))\n(type Two (Succ One))\n(type Four (Succ (Succ Two)))\n(type Six (Succ (Succ Four)))\n(type Eight (Succ (Succ Six)))\n\n(class (Nat n)\n (:: toInt (-> n Int)))\n\n(instance (Nat Zero)\n (= toInt _ 0))\n\n(instance (=> (Nat n) (Nat (Succ n)))\n (= toInt _ (+ 1 (toInt (:: undefined n)))))\n\n(:: f_stv01 (IO ()))\n(= f_stv01\n (print (map (\\ (:: x Int) (+ x 1)) [1 2 3])))\n\n(:: f_stv02 (forall a (-> [a] [a])))\n(= f_stv02 xs\n (where ys\n (:: ys [a])\n (= ys (reverse xs))))\n\n(class (STVC a)\n (:: stv_op (-> [a] (Maybe a)))\n (= stv_op xs\n (case (reverse xs)\n (: x _) (Just x)\n [] Nothing)))\n\n(instance (=> (STVC b) (STVC [b]))\n (= stv_op xs\n (case (:: xs [[b]])\n (: ys _) (Just (reverse ys))\n [] Nothing)))\n\n(instance (STVC Bool))\n\n(:: main (IO ()))\n(= main\n (do (print (toInt (:: undefined Four)))\n (print (toInt (:: undefined Eight)))\n f_stv01\n (print (f_stv02 \"abc\"))\n (print (stv_op [True False False]))))\n" }, { "path": "finkel-kernel/test/data/syntax/2012-typeop.hs", "content": ";;;; Type operatos\n\n%p(LANGUAGE TypeOperators)\n\n;;; Type operators, with and without operator expansions\n\n(data (:.+ a b) (:.+ a b)\n (deriving Eq Show))\n\n(infixl 6 :.+)\n\n(:: to01a (-> (:.+ (:.+ Int Int) Int) (IO ())))\n(= to01a (:.+ a b c) (print (+ a b c)))\n\n(:: to01b (-> (:.+ Int Int Int) (IO ())))\n(= to01b (:.+ a b c) (print (+ a b c)))\n\n(:: to01c (-> (:.+ Int (:.+ Int Int)) (IO ())))\n(= to01c (:.+ a (:.+ b c)) (print (+ a b c)))\n\n(data (:+. a b) (:+. a b)\n (deriving Eq Show))\n\n(infixr 6 :+.)\n\n(:: to02a (-> (:+. Int (:+. Int Int)) (IO ())))\n(= to02a (:+. a b c) (print (+ a b c)))\n\n(:: to02b (-> (:+. Int Int Int) (IO ())))\n(= to02b (:+. a b c) (print (+ a b c)))\n\n(:: to02c (-> (:+. (:+. Int Int) Int) (IO ())))\n(= to02c (:+. (:+. a b) c) (print (+ a b c)))\n\n(data (:++ a b c) (:++ a b c)\n (deriving Eq Show))\n\n;; `:++' constructor takes three arguments, so surrounding with\n;; parenthesis to avoid operator expansion. If no parenthesis,\n;; below line would be expanded to: True :++ 'x' :++ \"foo\"\n(:: to03 (-> ((:++) Int Int Int) (IO ())))\n(= to03 ((:++) a b c) (print (+ a b c)))\n\n(:: main (IO ()))\n(= main\n (do (to01a (:.+ 1 2 3))\n (to01b (:.+ 1 2 3))\n (to01c (:.+ 1 (:.+ 2 3)))\n (to02a (:+. 1 2 3))\n (to02b (:+. 1 2 3))\n (to02c (:+. (:+. 1 2) 3))\n (to03 ((:++) 1 2 3))))\n" }, { "path": "finkel-kernel/test/data/syntax/2013-undecidable.hs", "content": ";;;; UndecidableInstances, and some others.\n\n%p(LANGUAGE FlexibleInstances\n MonoLocalBinds\n UndecidableInstances)\n\n(module Main)\n\n(class (=> (Show a) (Monoid a) (ShowMonoid a)))\n\n(instance (=> (Show a) (Monoid a) (ShowMonoid a)))\n\n(:: showMonoid (=> (ShowMonoid a) (-> a String)))\n(= showMonoid x\n (concat [(show x) \"(mempty=\" (show (asTypeOf mempty x)) \")\"]))\n\n(:: main (IO ()))\n(= main\n (do (putStrLn (showMonoid [(:: 1 Int) 2 3]))\n (putStrLn (showMonoid GT))))\n" }, { "path": "finkel-kernel/test/data/syntax/2014-noprelude.hs", "content": ";;;; File containing NoImplicitPrelude.\n\n%p(LANGUAGE NoImplicitPrelude)\n%p(OPTIONS_GHC -Wall)\n\n(module Main)\n\n(import Prelude hiding (^ read))\n\n(:: read (-> String Bool))\n(= read \"true\" True)\n(= read _ False)\n\n(:: ^ (-> [a] [a] [a]))\n(= ^ ++)\n\n(:: main (IO ()))\n(= main\n (putStrLn (^ \"(read true) ==> \" (show (read \"true\")))))\n" }, { "path": "finkel-kernel/test/data/syntax/2015-typefam.hs", "content": ";;;; File containing codes using `TypeFamiles' language extension\n\n%p(LANGUAGE TypeFamilies)\n\n(module Main)\n\n(import Data.Kind ((Type)))\n\n\f\n;;; Data families\n\n(data family (:: (Gmap k) (-> * *)))\n\n(data family (T1 a))\n\n(data instance (T1 Int) A1\n (deriving Eq Show))\n\n(newtype instance (T1 Char) (B1 Bool))\n\n(data instance (T1 Double)\n (C1 Double)\n (C2 Int)\n (deriving Eq Show))\n\n(class (T1C a)\n (:: t1c (-> (T1 a) Int)))\n\n(instance (T1C Int)\n (= t1c A1 1))\n\n(instance (T1C Char)\n (= t1c (B1 _) 2))\n\n(instance (T1C Double)\n (= t1c (C1 _) 3)\n (= t1c (C2 _) 4))\n\n(:: t1c-insts (IO ()))\n(= t1c-insts\n (do (print (t1c A1))\n (print (t1c (B1 False)))\n (print (t1c (C1 1)))\n (print (t1c (C2 1)))))\n\n\f\n;;; Synonym families\n\n(type family (Elem c))\n\n(type instance (Elem [e]) e)\n\n(type family (:: (TF1 a b) (-> Type Type)))\n\n;; Closed type synonym family.\n(type family (TF3 a)\n (= (TF3 Int) Double)\n (= (TF3 Bool) Char)\n (= (TF3 a) String))\n\n(:: ctfs1 (IO ()))\n(= ctfs1\n (do (print (:: 3 (TF3 Int)))\n (print (:: #'x (TF3 Bool)))\n (print (:: \"foo\" (TF3 Char)))))\n\n\f\n;;; Wildcards on the LHS of data and type family instances\n\n(data family (:: (DF1 a b) *))\n\n(data instance (DF1 Int _) Int)\n\n(type family (:: (TF4 a) *))\n\n(type instance (TF4 (, a _)) a)\n\n(type instance (TF4 (, a _ _)) a)\n\n(:: wc1 (IO ()))\n(= wc1\n (do (print (:: 8 (TF4 (, Int Bool Char))))\n (print (:: 9 (TF4 (, Double String))))))\n\n\f\n;;; Associated data and type familes\n\n(class (Collects1 ce)\n (type (:: (Entry1 ce) *)))\n\n(instance (=> (Eq e) (Collects1 [e]))\n (type (Entry1 [e]) e))\n\n(class (Collects2 ce)\n (data (:: (Entry2 ce) *)))\n\n(instance (=> (Eq e) (Collects2 [e]))\n (data (Entry2 [e]) (E2 e)))\n\n(class (IsBoolMap v)\n (type (Key v))\n (type instance (Key v) Int)\n (:: lookupKey (-> (Key v) v (Maybe Bool))))\n\n(newtype IBAL\n (IBAL {(:: unIBAL [(, Int Bool)])}))\n\n(instance (IsBoolMap IBAL)\n (= lookupKey k (. (lookup k) unIBAL)))\n\n(:: at1 (IO ()))\n(= at1\n (do (let ((= im (IBAL [(, 0 False) (, 1 True) (, 2 True)]))))\n (print (lookupKey 0 im))\n (print (lookupKey 2 im))\n (print (lookupKey 4 im))))\n\n\f\n;;; Equality constraint\n\n(:: ec1 (=> (IsBoolMap v1) (~ k1 (Key v1)) (IsBoolMap v2) (~ k2 (Key v2))\n (-> k1 v1 k2 v2 (Maybe Bool))))\n(= ec1 k1 v1 k2 v2\n (| ((<- (Just b1) (lookupKey k1 v1))\n (<- (Just b2) (lookupKey k2 v2))\n (Just (&& b1 b2)))\n (otherwise Nothing)))\n\n\f\n;;; Main function\n\n(:: main (IO ()))\n(= main\n (do t1c-insts\n ctfs1\n wc1\n at1))\n" }, { "path": "finkel-kernel/test/data/syntax/2016-datakinds.hs", "content": ";;;; File containing codes using `DataKinds' language extension\n\n%p(LANGUAGE DataKinds\n GADTs\n KindSignatures\n MultiParamTypeClasses\n RankNTypes\n TypeFamilies\n TypeOperators)\n\n;;; Ghc <= 8.4 need `FlexibleInstances' language extension for instance\n;;; declarations of `Has' type class.\n%p(LANGUAGE FlexibleInstances)\n\n(module Main)\n\n;; base\n(import Data.Proxy ((Proxy ..)))\n(import Data.Kind ((Type)))\n\n;;; XXX: Need \"ExplicitNamespace\" extension.\n;; (import GHC.TypeLits ((Symbol) natVal (type +))\n(import GHC.TypeLits)\n\n;; finkel-kernel\n(import Language.Finkel)\n\n;;; Value-level quoted symbols\n\n(:: quoted-1 (IO ()))\n(= quoted-1\n (do (print 'foo)\n (print 'bar)))\n\n(:: quoted-2 (IO ()))\n(= quoted-2\n (do (print '[])\n (print '(, a b c))))\n\n;;; Overview\n\n(data Na\n Ze\n (Su Na))\n\n(data (Vec (:: a Type) (:: n Na))\n (:: Nil (Vec a 'Ze))\n (:: Cons (-> a (Vec a n) (Vec a ('Su n)))))\n\n;;; Alternative syntax\n\n(data (:: Vec2 (-> Type Na Type))\n (:: Nil2 (Vec2 a 'Ze))\n (:: Cons2 (-> a (Vec2 a n) (Vec2 a ('Su n)))))\n\n;;; Another alternative syntax\n\n(data (:: (Vec3 (:: a Type)) (-> Na Type))\n (:: Nil3 (Vec3 a 'Ze))\n (:: Cons3 (-> a (Vec3 a n) (Vec3 a ('Su n)))))\n\n;;; Promoted list and tuple types\n\n;; HList\n\n(data (:: HList (-> [Type] Type))\n (:: HNil (HList '[]))\n (:: HCons (-> a (HList as) (HList (': a as)))))\n\n(:: foo0 (HList '[]))\n(= foo0 HNil)\n\n(:: foo1 (HList '[Int]))\n(= foo1 (HCons (:: 3 Int) foo0))\n\n;; Explicit quote is required for promoted list.\n(:: foo2 (HList '[Bool Int]))\n(= foo2 (HCons True foo1))\n\n(:: print-foo2 (IO ()))\n(= print-foo2\n (case foo2\n (HCons a (HCons b HNil))\n (putStrLn (++ \"foo2: [\" (show a) \" \" (show b) \"]\"))))\n\n;; Tuple\n\n(data (:: Tuple (-> (, Type Type) Type))\n (:: Tuple (-> a b (Tuple '(, a b)))))\n\n;;; Promoting existential data constructors\n\n(data (:: Ex Type)\n (:: MkEx (forall a (-> a Ex))))\n\n(type family (UnEx (:: ex Ex)))\n(type instance (UnEx ('MkEx ex)) ex)\n\n(:: print-ex (IO ()))\n(= print-ex\n (let ((:: ex (UnEx ('MkEx Bool)))\n (= ex True))\n (print ex)))\n\n;;; Type-Level literals\n\n(data (Label (:: l Symbol)) Get)\n\n(class (Has a l)\n (type (Res a l))\n (:: from (-> a (Label l) (Res a l))))\n\n(data Point\n (Point Int Int)\n (deriving (Show)))\n\n(instance (Has Point \"x\")\n (type (Res Point \"x\") Int)\n (= from (Point x _) _ x))\n\n(instance (Has Point \"y\")\n (type (Res Point \"y\") Int)\n (= from (Point _ y) _ y))\n\n(:: tylit-syms (IO ()))\n(= tylit-syms\n (do (let ((= p (Point 12 34))))\n (print (from p (:: Get (Label \"x\"))))\n (print (from p (:: Get (Label \"y\"))))))\n\n(:: tylit-nats-simple (IO ()))\n(= tylit-nats-simple\n (do (print (natVal (:: Proxy (Proxy 1))))\n (print (natVal (:: Proxy (Proxy 2))))))\n\n(:: tylit-nats-with-op (IO ()))\n(= tylit-nats-with-op\n (do (print (natVal (:: Proxy (Proxy (+ 1 2)))))\n (print (natVal (:: Proxy (Proxy (+ 3 4)))))))\n\n\n;;; Using same names in type constructor and data constructor\n\n(data Bar Bar)\n\n(type family (:: (Buzz (:: a Bool)) Bar)\n (= (Buzz 'True) 'Bar))\n\n\n;;; The main function\n\n(:: main (IO ()))\n(= main\n (do (putStrLn \";;; datakinds ;;;\")\n quoted-1\n quoted-2\n print-foo2\n print-ex\n tylit-syms\n tylit-nats-simple))\n" }, { "path": "finkel-kernel/test/data/syntax/2017-polykinds.hs", "content": ";;;; File containing codes using `PolyKinds' language extension\n\n%p(LANGUAGE DataKinds\n GADTs\n PolyKinds\n RankNTypes\n TypeFamilies\n TypeOperators)\n\n;; ghc-8.2.x and 8.4.x requires `TypeInType' extension.\n%p(LANGUAGE TypeInType)\n\n(module Main)\n\n(import Data.Kind ((Type)))\n\n(data (App f a) (MkApp (f a)))\n\n(:: a1 (App Maybe Int))\n(= a1 (MkApp (Just 42)))\n\n(data (T a) (MkT (a Int)))\n\n(:: a2 (App T Maybe))\n(= a2 (MkApp (MkT (Just 42))))\n\n(:: print-a2 (IO ()))\n(= print-a2\n (case a2\n (MkApp (MkT ji)) (print ji)))\n\n(type family (F1 a)\n (= (F1 'True) 'False)\n (= (F1 'False) 'True)\n (= (F1 x) x))\n\n(type family (:: (F3 (:: a Bool)) Bool)\n (= (F3 'True) 'False)\n (= (F3 'False) 'True))\n\n(data (Proxy a) Proxy\n (deriving Eq Show))\n\n(:: print-f3 (IO ()))\n(= print-f3\n (let ((:: x (Proxy (F3 'True)))\n (= x Proxy))\n (print x)))\n\n(class (HTestEquality (:: t (forall k (-> k Type))))\n (:: hTestEquality (forall k1 k2 (:: a k1) (:: b k2)\n (-> (t a) (t b) (Maybe (:~~: a b))))))\n\n(data (:: :~~: (forall k1 (-> k1 (forall k2 (-> k2 Type)))))\n (:: HRefl (:~~: a a)))\n\n(instance (HTestEquality ((:~~:) a))\n (= hTestEquality HRefl HRefl (Just HRefl)))\n\n;;; Requires `PolyKinds' language extension.\n(type family (:: (TF2 a) k))\n\n(type family (:: TF3 (-> k Type)))\n\n(:: main (IO ()))\n(= main\n (do (print-a2)\n (print-f3)))\n" }, { "path": "finkel-kernel/test/data/syntax/2018-typeapp.hs", "content": ";;;; File containing codes using `TypeApplications' language extension\n\n%p(LANGUAGE TypeApplications)\n\n(module Main)\n\n(:: main (IO ()))\n(= main\n (do (print (read @ Int \"42\"))\n (print (read @Double \"1.23\")) ; Without space after '@'\n (print (read @ (Maybe Bool) \"Just True\"))\n (print (foldr @ Maybe @ Int @ Int + 1 (Just 41)))))\n" }, { "path": "finkel-kernel/test/data/syntax/2019-overlabel.hs", "content": ";;;; File containing codes using `OverloadedLabels' language extension\n\n%p(LANGUAGE OverloadedLabels)\n\n;;; ... and many other extensions too.\n%p(LANGUAGE DataKinds\n FlexibleContexts\n FlexibleInstances\n GADTs\n MultiParamTypeClasses\n PolyKinds\n ScopedTypeVariables\n TypeApplications\n UndecidableInstances)\n\n(module Main)\n\n(import Data.Proxy ((Proxy ..)))\n(import GHC.OverloadedLabels ((IsLabel ..)))\n(import GHC.Records ((HasField ..)))\n(import GHC.Types ((Type)))\n\n(data Person (Person {(:: person-name String)}))\n\n(instance %p(OVERLAPPABLE) (IsLabel \"name\" (-> Person String))\n (= fromLabel person-name))\n\n(data Item (Item {(:: item-name String)}))\n\n(instance %p(OVERLAPPABLE) (IsLabel \"name\" (-> Item String))\n (= fromLabel item-name))\n\n(:: ol01 (IO ()))\n(= ol01\n (do (putStrLn (#name (Person \"Alice\")))\n (putStrLn (#name (Item \"Banana\")))))\n\n(data (Record (:: xs [(, k Type)]))\n (:: Nil (Record '[]))\n (:: Cons (-> (Proxy x) a (Record xs) (Record (': '(, x a) xs)))))\n\n(instance\n %p(OVERLAPPABLE) (HasField x (Record (': '(, x a) xs)) a)\n (= getField (Cons _ v _) v))\n\n(instance\n %p(OVERLAPPABLE) (=> (HasField x (Record xs) a)\n (HasField x (Record (': '(, y b) xs)) a))\n (= getField (Cons _ _ r) (getField @ x r)))\n\n(instance %p(OVERLAPPABLE) (=> (HasField x r a) (IsLabel x (-> r a)))\n (= fromLabel (getField @ x)))\n\n(:: r1 (Record '[ '(, \"personId\" Int) '(, \"name\" String)]))\n(= r1 (Cons Proxy 42 (Cons Proxy \"R\" Nil)))\n\n(:: i1 Int)\n(= i1 (getField @ \"personId\" r1))\n\n(:: i2 Int)\n(= i2 (#personId r1))\n\n(:: r2 (Record '[ '(, True Char) '(, False Char)]))\n(= r2 (Cons Proxy #'a (Cons Proxy #'b Nil)))\n\n(:: j1 Char)\n(= j1 (getField @ True r2))\n\n(:: j2 Char)\n(= j2 (getField @ False r2))\n\n(:: ol02 (IO ()))\n(= ol02\n (putStrLn (++ \"i1=\" (show i1) \", i2=\" (show i2) \"\\n\"\n \"j1=\" (show j1) \", j2=\" (show j1))))\n\n(:: main (IO ()))\n(= main\n (do ol01\n ol02))\n" }, { "path": "finkel-kernel/test/data/syntax/2020-emptyderiv.hs", "content": ";;;; `EmptyDataDeriving' language extension\n\n%p(LANGUAGE EmptyDataDeriving)\n\n(module Main)\n\n(data Empty\n (deriving Eq Ord Show Read))\n\n(:: main (IO ()))\n(= main (return ()))\n" }, { "path": "finkel-kernel/test/data/syntax/2021-dfltsig.hs", "content": ";;;; File containing codes using `DefaultSignatures' language extension\n\n%p(LANGUAGE DefaultSignatures)\n\n(module Main)\n\n(class (SPretty a)\n (:: sPpr (-> a String))\n (default (:: sPpr (=> (Show a) (-> a String))))\n (= sPpr show))\n\n(instance (SPretty Bool))\n\n(:: main (IO ()))\n(= main (putStrLn (sPpr False)))\n" }, { "path": "finkel-kernel/test/data/syntax/2022-drvstrat.hs", "content": ";;;; File containing codes using `DerivingStrategies' language extension\n\n%p(LANGUAGE DeriveAnyClass\n DerivingStrategies\n GeneralizedNewtypeDeriving)\n\n(module Main)\n\n(class (C a))\n\n(newtype Buzz (Buzz Double)\n (deriving Eq Ord)\n (deriving stock Read Show)\n (deriving newtype Num Fractional Floating)\n (deriving anyclass C))\n\n(:: main (IO ()))\n(= main (print (:: 42 Buzz)))\n" }, { "path": "finkel-kernel/test/data/syntax/2023-standalone.hs", "content": ";;;; File containing codes using `StandaloneDeriving' language extension\n\n%p(LANGUAGE DeriveAnyClass\n DerivingStrategies\n GeneralizedNewtypeDeriving\n StandaloneDeriving)\n\n(module Main)\n\n(class (C a))\n\n(newtype (Foo a) (MkFoo Int))\n\n(deriving instance (Eq (Foo a)))\n(deriving instance %p(OVERLAPPING) (Ord (Foo a)))\n(deriving stock instance (Show (Foo a)))\n(deriving stock instance %p(OVERLAPPABLE) (Read (Foo a)))\n(deriving newtype instance (Enum (Foo a)))\n(deriving newtype instance (Real (Foo a)))\n(deriving newtype instance %p(OVERLAPS) (Integral (Foo a)))\n(deriving newtype instance %p(INCOHERENT) (Num (Foo a)))\n(deriving anyclass instance (C (Foo a)))\n\n(:: main (IO ()))\n(= main (print (== (succ (:: 3 (Foo Char))) 4)))\n" }, { "path": "finkel-kernel/test/data/syntax/2024-derivingvia.hs", "content": ";;;; File containing codes using `DerivingVia' language extension\n\n%p(LANGUAGE DerivingVia\n DeriveFunctor\n GeneralizedNewtypeDeriving\n StandaloneDeriving)\n\n(module Main)\n\n(import Control.Applicative (liftA2))\n(import Numeric (showHex))\n\n(newtype (Hex a) (Hex a))\n\n(instance (=> (Integral a) (Show a) (Show (Hex a)))\n (= show (Hex a) (++ \"0x\" (showHex a \"\"))))\n\n(newtype Unicode (U Int)\n (deriving Num via Int)\n (deriving Show via (Hex Int)))\n\n(:: euroSign Unicode)\n(= euroSign 0x20ac)\n\n(newtype (App f a) (App (f a))\n (deriving newtype Functor Applicative))\n\n(instance (=> (Applicative f) (Semigroup a)\n (Semigroup (App f a)))\n (= <> (liftA2 <>)))\n\n(instance (=> (Applicative f) (Monoid a)\n (Monoid (App f a)))\n (= mempty (pure mempty)))\n\n(data (Pair a) (MkPair a a)\n (deriving stock Functor)\n (deriving Semigroup Monoid via (App Pair a)))\n\n(instance (Applicative Pair)\n (= pure a (MkPair a a))\n (= <*> (MkPair f g) (MkPair a b) (MkPair (f a) (g b))))\n\n;;; XXX: Following `Kleisli1' and `Kleisli2' examples are taken from ghc user\n;;; guide documentation. It is shown in ghc 9.2.1 version of the documentation,\n;;; but getting errors, not only in Finkel codes but in Haskell codes too.\n\n;; (newtype (Kleisli m a b) (Kleisli (-> a (m b)))\n;; (deriving Semigroup Monoid via (-> a (App m b))))\n;;\n;; (newtype (Kleisli2 m a b) (Klsisli2 (-> a (m b))))\n;;\n;; (deriving via (-> a (App m b)) instance\n;; (=> (Applicative m) (Semigroup b)\n;; (Semigroup (Kleisli2 m a b))))\n;;\n;; (deriving via (-> a (App m b)) instance\n;; (=> (Applicative m) (Monoid b)\n;; (Monoid (Kleisli2 m a b))))\n\n(:: main (IO ()))\n(= main (print euroSign))\n" }, { "path": "finkel-kernel/test/data/syntax/2025-namedfieldpuns.hs", "content": ";;;; File containing code using `NamedFieldPuns' language extension\n\n%p(LANGUAGE NamedFieldPuns)\n\n(import Data.Monoid ((All All)))\n(import qualified Data.Monoid as M)\n\n(data C1\n (C1 {(:: a Int)}))\n\n(data C2\n (C2 {(:: b Int)\n (:: c Int)\n (:: d Int)}))\n\n(:: f1 (-> C1 (IO ())))\n(= f1 (C1 {a}) (print a))\n\n(:: f2 C1)\n(= f2\n (let ((= a 100))\n (C1 {a})))\n\n(:: f3 (-> C2 Int))\n(= f3 (C2 {b (= c 4)}) b)\n(= f3 _ 0)\n\n(:: f4 (-> All Bool))\n(= f4 (All {M.getAll}) getAll)\n\n(:: main (IO ()))\n(= main\n (do (f1 f2)))\n" }, { "path": "finkel-kernel/test/data/syntax/2026-recordwildcards.hs", "content": ";;;; File containing code using `RecordWildCards' language extension\n\n%p(LANGUAGE RecordWildCards\n NamedFieldPuns)\n\n(import Data.Monoid ((All getAll)))\n\n(data C\n (C {(:: a b c d Int)})\n (deriving Eq Show))\n\n(= f1 (C {(= a 1) ..})\n (+ b c d))\n(= f1 _ 0)\n\n(= f2 (C {(= a 1) b ..})\n (+ b c d))\n(= f2 _ 1)\n\n(= e\n (C {(= a 111) (= b 222) (= c 333) (= d 444)}))\n\n(= f3\n (let ((= (C {(= a 111) ..}) e))\n [b c d]))\n\n(= f4\n (let ((= a 12) (= b 34) (= c 56) (= d 78))\n (C {..})))\n\n(:: main (IO ()))\n(= main\n (do (let ((= c1 (C 1 2 3 4))))\n (print (f1 c1))\n (print (f2 c1))\n (print f3)\n (print f4)))\n" }, { "path": "finkel-kernel/test/data/syntax/2027-emptycase-1.hs", "content": ";;;; File containing code using `EmptyCase' language extension\n\n%p(LANGUAGE EmptyCase)\n\n(data Void)\n\n(:: absurd (-> Void a))\n(= absurd a (case a))\n\n(:: main (IO ()))\n(= main\n (putStrLn \"EmptyCase language extension\"))\n" }, { "path": "finkel-kernel/test/data/syntax/2027-emptycase-2.hs", "content": ";;; -*- mode: finkel -*-\n\n%p(LANGUAGE EmptyCase\n DataKinds\n KindSignatures\n GADTs)\n%p(OPTIONS_GHC -Werror=incomplete-patterns)\n\n(import Data.Kind (Type))\n\n;; Types\n\n(data D O C L)\n\n(data (:: SD (-> D Type))\n (:: SO (SD 'O))\n (:: SC (SD 'C))\n (:: SL (SD 'L)))\n\n(data (:: K (-> D Type))\n (:: KC (K 'C))\n (:: KL (K 'L)))\n\n(data Void)\n\n(data (Decision a)\n (Proved a)\n (Disproved (-> a Void)))\n\n;; Function\n\n(:: isA (-> (SD s) (Decision (K s))))\n(= isA s\n (case s\n SO (Disproved (\\x (case x)))\n SC (Proved KC)\n SL (Proved KL)))\n\n(:: main (IO ()))\n(= main\n (let ((= f s\n (putStrLn (case (isA s)\n (Proved _) \"Proved\"\n (Disproved _) \"Disproved\"))))\n (do (f SO)\n (f SC)\n (f SL))))\n" }, { "path": "finkel-kernel/test/data/syntax/2028-standalonekind.hs", "content": ";;;; File containing codes using `Standalonekindsignatures' language extension\n\n%p(LANGUAGE StandaloneKindSignatures)\n\n(module Main)\n\n(import Data.Kind)\n\n(type (:: MyMaybe (-> Type Type)))\n\n(data (MyMaybe a)\n MyNothing\n (MyJust a)\n (deriving Eq Show))\n\n(:: main (IO ()))\n(= main\n (do (print (MyJust False))\n (print (:: MyNothing (MyMaybe Int)))))\n" }, { "path": "finkel-kernel/test/data/syntax/2029-impredicative.hs", "content": ";;; -*- mode: finkel -*-\n\n;;; File containing codes using `ImpredicativeTypes' language extension.\n;;; According to the ghc documentation, the `ImpredicativeTypes' extension did\n;;; exist since ghc 6.10, but was unreliable until ghc 9.2.\n\n%p(LANGUAGE ImpredicativeTypes)\n\n(module Main)\n\n(:: f (-> (Maybe (forall a (-> [a] [a]))) (Maybe (, [Int] [Char]))))\n(= f (Just g) (Just (, (g [1 2 3]) (g \"hello\"))))\n(= f Nothing Nothing)\n\n(= main\n (print (f (Just reverse))))\n" }, { "path": "finkel-setup/LICENSE", "content": "Copyright (c) 2017-2022, 8c6794b6\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "finkel-setup/README.md", "content": "# finkel-setup\n\nAuxiliary package containing `Setup.hs` related functions for building\ncabal packages with Finkel.\n\nSee the [documentation][doc] for more details.\n\n[doc]: https://finkel.readthedocs.io/en/latest/\n" }, { "path": "finkel-setup/Setup.hs", "content": "import Distribution.Simple\nmain = defaultMain\n" }, { "path": "finkel-setup/finkel-setup.cabal", "content": "cabal-version: 2.0\nname: finkel-setup\nversion: 0.0.0\nsynopsis: Cabal setup script helper for Finkel\ndescription:\n Cabal setup script helper for Finkel\n .\n See the for more info.\n\nhomepage: https://github.com/finkel-lang/finkel#readme\nlicense: BSD3\nlicense-file: LICENSE\nauthor: 8c6794b6\nmaintainer: 8c6794b6@gmail.com\ncopyright: 2017-2022 8c6794b6\ncategory: Language\nbuild-type: Simple\nextra-source-files: README.md\n --\n test/data/p01/LICENSE\n test/data/p01/p01.cabal\n test/data/p01/Setup.hs\n test/data/p01/exec/p01.hs\n test/data/p01/src/P01/*.fnk\n test/data/p01/src/P01/*.hs\n test/data/p01/test/*.fnk\n test/data/p01/test/*.hs\n --\n test/data/p02/LICENSE\n test/data/p02/CHANGELOG.md\n test/data/p02/p02.cabal\n test/data/p02/Setup.hs\n test/data/p02/app/Main.hs\n test/data/p02/src/MyLib.hs\n test/data/p02/test/Main.hs\n\ntested-with: GHC == 8.10.7\n , GHC == 9.0.1\n , GHC == 9.2.8\n , GHC == 9.4.6\n , GHC == 9.6.5\n , GHC == 9.8.2\n , GHC == 9.10.1\n\nlibrary\n hs-source-dirs: src\n exposed-modules: Distribution.Simple.Finkel\n build-depends: Cabal >= 3.2 && < 3.13\n , base >= 4.14 && < 5\n , directory >= 1.3.0 && < 1.4\n , filepath >= 1.4.1 && < 1.6\n default-language: Haskell2010\n ghc-options: -Wall\n\ntest-suite finkel-setup-test\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Main.hs\n build-depends: base\n , directory\n , filepath\n , finkel-kernel\n , finkel-setup\n --\n , ghc >= 8.10.0 && < 9.11\n , hspec >= 2.4.8 && < 2.12\n build-tool-depends: fkc:fkc\n , fnkpp:fnkpp\n ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N\n default-language: Haskell2010\n -- Skipping this test under Windows, since it's too slow.\n if os(windows)\n buildable: False\n\nsource-repository head\n type: git\n location: https://github.com/finkel-lang/finkel.git\n subdir: finkel-setup\n" }, { "path": "finkel-setup/src/Distribution/Simple/Finkel.hs", "content": "-- | Module exporting utilities to work with cabal's @Setup.hs@ script.\n{-# LANGUAGE CPP #-}\nmodule Distribution.Simple.Finkel\n (\n -- * Main functions\n fnkMain\n , finkelMakeMain\n , fnkMainWith\n\n -- * Haddock for plugin\n , fnkPluginMainForHaddock\n\n -- * UserHooks\n , fnkHooksWith\n\n -- * Suffix handler\n , finkelPPHandler\n\n -- * Reexport from Cabal\n , UserHooks\n , defaultMainWithHooks\n ) where\n\n-- base\nimport Control.Exception (bracket_)\nimport Control.Monad (foldM, mapAndUnzipM, when)\nimport Data.Foldable (toList)\nimport Data.Function (on)\nimport Data.List (unionBy)\n\n-- filepath\nimport System.FilePath ((<.>), ())\n\n-- Cabal\nimport Distribution.ModuleName (toFilePath)\nimport Distribution.PackageDescription\nimport Distribution.Simple\nimport Distribution.Simple.BuildPaths (autogenComponentModulesDir)\nimport Distribution.Simple.Configure (configure,\n findDistPrefOrDefault)\nimport Distribution.Simple.Haddock (haddock)\nimport Distribution.Simple.LocalBuildInfo\nimport Distribution.Simple.PreProcess\nimport Distribution.Simple.Program\nimport Distribution.Simple.Program.GHC\nimport Distribution.Simple.Program.Types\nimport Distribution.Simple.Register (internalPackageDBPath)\nimport Distribution.Simple.Setup\nimport Distribution.Simple.Utils (installDirectoryContents)\nimport Distribution.Utils.NubList\n\n#if MIN_VERSION_Cabal(3,5,0)\nimport Distribution.Utils.Path (getSymbolicPath)\n#endif\n\n#if MIN_VERSION_Cabal(2,4,0)\nimport Distribution.Types.ExposedModule\n#else\nimport Distribution.InstalledPackageInfo\n#endif\n\nimport qualified Distribution.Simple.Setup as Setup\nimport qualified Distribution.Verbosity as Verbosity\n\n-- directory\nimport System.Directory (createDirectoryIfMissing,\n doesDirectoryExist,\n doesFileExist, findFile,\n getTemporaryDirectory,\n removeDirectoryRecursive,\n removeFile)\n\n\n-- --------------------------------------------------------------------\n--\n-- Main functions\n--\n-- ------------------------------------------------------------------------\n\n-- | Main function using /fkc/ executable.\n--\n-- This acton uses the /fkc/ executable found on system when building\n-- a package.\nfnkMain :: IO ()\nfnkMain = rawFnkMain \"fkc\" [] False\n\n-- | Main function using /finkel/ executable with /make/ subcommand.\n--\n-- This action uses the /finkel/ executable found on system when\n-- building a package.\nfinkelMakeMain :: IO ()\nfinkelMakeMain = rawFnkMain \"finkel\" [\"make\"] False\n\n-- | Main function with given executable name and arguments passed to\n-- the executable.\nfnkMainWith :: String -- ^ Executable name.\n -> [String] -- ^ Args passed to the executable.\n -> IO ()\nfnkMainWith exe args = rawFnkMain exe args False\n\n-- | Run main using 'fnkHooksWith' and given executable.\nrawFnkMain :: String -- ^ Executable\n -> [String] -- ^ Argument passed to the executable.\n -> Bool -- ^ Debug flag\n -> IO ()\nrawFnkMain exec args debug =\n defaultMainWithHooks (fnkHooksWith exec args debug)\n\n-- | Main function for generating haddock when building with finkel plugin.\nfnkPluginMainForHaddock :: IO ()\nfnkPluginMainForHaddock = defaultMainWithHooks my_hooks\n where\n my_hooks = simpleUserHooks {haddockHook = my_haddock_hook}\n\n my_haddock_hook pd lbi _user_hooks flags = do\n let search_path = getProgramSearchPath (withPrograms lbi)\n mb_fnkpp <- findProgramOnSearchPath Verbosity.verbose search_path \"fnkpp\"\n let fnkpp_path = maybe \"fnkpp\" fst mb_fnkpp\n flags' = append_args fnkpp_path flags\n haddock pd lbi knownSuffixHandlers flags'\n\n append_args fnkpp flags =\n let orig_args = filter ((== \"ghc\") . fst) $ haddockProgramArgs flags\n my_args = [\"-F\", \"-pgmF\", fnkpp, \"-optF\", \"--no-warn-interp\"]\n merged_args = case orig_args of\n (_, args):_ -> args <> my_args\n [] -> my_args\n in flags {haddockProgramArgs = [(\"ghc\", merged_args)]}\n\n\n-- ---------------------------------------------------------------------\n--\n-- UserHooks\n--\n-----------------------------------------------------------------------\n\n-- | Make user hooks from compiler executable and extra arguments to the\n-- executable.\nfnkHooksWith :: FilePath -- ^ Compiler executable.\n -> [String] -- ^ Extra arguments to the executable.\n -> Bool -- ^ Debug flag.\n -> UserHooks\nfnkHooksWith exec args debug = simpleUserHooks\n { hookedPreProcessors = finkelPPHandler : knownSuffixHandlers\n , confHook = fnkConfHookWith exec args debug\n , haddockHook = fnkHaddockHooks\n }\n\n\n-- ---------------------------------------------------------------------\n--\n-- Auxiliary\n--\n-- ---------------------------------------------------------------------\n\n-- | Preprocessor suffix handler to merely register files with @\"*.fnk\"@\n-- files.\nfinkelPPHandler :: PPSuffixHandler\nfinkelPPHandler = (suffix, doNothingPP)\n where\n#if MIN_VERSION_Cabal(3,12,0)\n suffix = Suffix \"fnk\"\n#else\n suffix = \"fnk\"\n#endif\n doNothingPP _ _ _ = PreProcessor\n { platformIndependent = True\n#if MIN_VERSION_Cabal(3,8,0)\n , ppOrdering = unsorted\n#endif\n , runPreProcessor = mkSimplePreProcessor (\\_ _ _ -> return ())\n }\n\nfnkConfHookWith :: FilePath -- ^ Path to Finkel compiler.\n -> [String] -- ^ Extra default args to the Finkel\n -- compiler.\n -> Bool -- ^ Flag for debug.\n -> (GenericPackageDescription, HookedBuildInfo)\n -> ConfigFlags\n -> IO LocalBuildInfo\nfnkConfHookWith fnk extra_args debug (pkg_descr, hbi) cflags = do\n lbi <- configure (pkg_descr, hbi) cflags\n return (overrideGhcAsFnk fnk extra_args debug lbi)\n\n-- | Update @ghc@ program in 'LocalBuildInfo'.\noverrideGhcAsFnk :: FilePath -- ^ Path to Finkel compiler.\n -> [String] -- ^ Extra default args.\n -> Bool -- ^ Debug flag.\n -> LocalBuildInfo\n -> LocalBuildInfo\noverrideGhcAsFnk fnk extra_args debug lbi = lbi'\n where\n lbi' = lbi {withPrograms = updateProgram ghc (withPrograms lbi)}\n ghc =\n case lookupProgram (simpleProgram \"ghc\") (withPrograms lbi) of\n Just ghc_orig ->\n ghc_orig {\n programLocation = FoundOnSystem fnk,\n programDefaultArgs =\n extra_args ++ programDefaultArgs ghc_orig,\n programOverrideArgs =\n programOverrideArgs ghc_orig ++ finkelflags\n }\n Nothing ->\n (simpleConfiguredProgram \"ghc\" (FoundOnSystem fnk)) {\n programDefaultArgs = extra_args,\n programOverrideArgs = finkelflags\n }\n finkelflags = debugs\n debugs = [\"--fnk-debug\"|debug]\n\n-- | Haddock hooks for Finkel. Generates and cleans up Haskell source\n-- codes from Finkel files during documentation generation.\nfnkHaddockHooks :: PackageDescription\n -> LocalBuildInfo\n -> UserHooks\n -> HaddockFlags\n -> IO ()\nfnkHaddockHooks pd lbi hooks flags = do\n (acquires, cleanups) <- mapAndUnzipM gen_hs_sources clbis\n bracket_ (sequence_ acquires)\n (sequence_ cleanups)\n (haddock pd lbi pps flags)\n where\n pps = allSuffixHandlers hooks\n clbis = toList (componentGraph lbi)\n gen_hs_sources clbi = do\n let name = componentLocalName clbi\n comp = getComponent pd name\n bi = componentBuildInfo comp\n cflags = configFlags lbi\n verbosity = case configVerbosity cflags of\n Setup.Flag v -> v\n NoFlag -> Verbosity.normal\n autogen_dir = autogenComponentModulesDir lbi clbi\n pkg_dbs = withPackageDB lbi\n pkgs = componentIncludes clbi\n hs_src_dirs = hsSourceDirs bi\n other_mods = otherModules bi\n\n distPref <- findDistPrefOrDefault (configDistPref cflags)\n\n let internal_pkg_db =\n SpecificPackageDB (internalPackageDBPath lbi distPref)\n\n (hs_mods, hs_insts, hs_files) <-\n case comp of\n CLib {} -> do\n let ms = componentExposedModules clbi\n is = componentInstantiatedWith clbi\n ms' = foldr f [] ms\n where\n f em acc =\n case exposedReexport em of\n Nothing -> exposedName em : acc\n Just _ -> acc\n return (ms' ++ other_mods, is, [])\n CExe exe -> do\n let path = modulePath exe\n return (other_mods, [], [path])\n _ -> return (other_mods, [], [])\n\n let opts dir = mempty\n { ghcOptMode = flag GhcModeMake\n , ghcOptExtra = optExtras dir\n , ghcOptInputFiles = toNubListR hs_files\n , ghcOptInputModules = toNubListR hs_mods\n , ghcOptSourcePathClear = flag True\n , ghcOptSourcePath = toNubListR hs_src_dirs'\n , ghcOptInstantiatedWith = hs_insts\n , ghcOptPackageDBs = pkg_dbs ++ [internal_pkg_db]\n , ghcOptPackages = toNubListR pkgs\n , ghcOptHideAllPackages = flag True\n , ghcOptNoLink = flag True\n }\n hs_src_dirs' = map getSymbolicPath hs_src_dirs ++ [autogen_dir]\n flag = Setup.Flag\n cmpl = compiler lbi\n platform = hostPlatform lbi\n accumulateGeneratedFile acc m = do\n let p = toFilePath m\n hs_src_dir_paths = map getSymbolicPath hs_src_dirs\n mb_found <- findFile hs_src_dir_paths (p <.> \"fnk\")\n case mb_found of\n Just _found -> do\n let dest = autogen_dir p <.> \"hs\"\n return (dest:acc)\n Nothing -> return acc\n\n -- Using package name as prefix of temporary directory, to support\n -- concurrent build of packages.\n makeTemporaryDirectory = do\n tmpdir <- getTemporaryDirectory\n let dir = tmpdir pre cmp_name\n cmp_name =\n remove_quotes $ replace_spaces (showComponentName name)\n replace_spaces = map space_to_underscore\n space_to_underscore c =\n case c of\n ' ' -> '_'\n _ -> c\n remove_quotes = filter (/= '\\'')\n pre = \"fnk_haddock_hooks\" pkg_name\n pkg_name = unPackageName (pkgName (package pd))\n createDirectoryIfMissing True dir\n return dir\n\n gen_files <- foldM accumulateGeneratedFile [] hs_mods\n tmpdir <- makeTemporaryDirectory\n\n let ghc = simpleProgram \"ghc\"\n acquire =\n case lookupProgram ghc (withPrograms lbi) of\n Just prog | not (null gen_files) -> do\n runGHC verbosity prog cmpl platform (opts tmpdir)\n installDirectoryContents verbosity tmpdir autogen_dir\n _ -> return ()\n clean path = do\n exist <- doesFileExist path\n when exist (do when (Verbosity.normal < verbosity)\n (putStrLn (\"Removing: \" ++ path))\n removeFile path)\n exist_dir <- doesDirectoryExist tmpdir\n when exist_dir $\n removeDirectoryRecursive tmpdir\n cleanup = mapM_ clean gen_files\n\n return (acquire, cleanup)\n\n-- | Optional arguments passed to ghc, for writing Haskell source code\n-- files from Finkel source code files.\n#if MIN_VERSION_Cabal(2,4,0)\noptExtras :: FilePath -> [String]\noptExtras = optExtras'\n#else\noptExtras :: FilePath -> NubListR String\noptExtras = toNubListR . optExtras'\n#endif\n where\n optExtras' :: FilePath -> [String]\n#if MIN_TOOL_VERSION_ghc(9,2,0)\n -- In ghc >= 9.2, \"-fbyte-code\" creates '*.o' object files. Using\n -- \"-fno-code\" instead of bytecode.\n optExtras' odir = [\"-v0\", \"-fno-code\", \"--fnk-hsdir=\" ++ odir]\n#else\n optExtras' odir = [\"-v0\", \"-fbyte-code\", \"--fnk-hsdir=\" ++ odir]\n#endif\n\n-- | Same as the one used in \"Distribution.Simple\".\nallSuffixHandlers :: UserHooks -> [PPSuffixHandler]\nallSuffixHandlers hooks =\n overridesPP (hookedPreProcessors hooks) knownSuffixHandlers\n where overridesPP = unionBy ((==) `on` fst)\n\n#if !MIN_VERSION_Cabal(3,5,0)\ngetSymbolicPath :: a -> a\ngetSymbolicPath = id\n#endif\n" }, { "path": "finkel-setup/test/Main.hs", "content": "{-# LANGUAGE CPP #-}\nmodule Main where\n\n-- base\nimport Control.Exception (catch, throw)\nimport Data.List (isSubsequenceOf)\nimport System.Environment (getExecutablePath, lookupEnv, setEnv,\n unsetEnv, withArgs)\n\n-- ghc\n#if MIN_VERSION_ghc(9,0,0)\nimport GHC.Settings.Config (cProjectVersion)\n#else\nimport Config (cProjectVersion)\n#endif\n\n-- directory\nimport System.Directory (doesDirectoryExist,\n getCurrentDirectory,\n removeDirectoryRecursive,\n setCurrentDirectory)\nimport System.Directory.Internal.Prelude (isDoesNotExistError)\n\n-- filepath\nimport System.FilePath (isSearchPathSeparator, joinPath,\n splitDirectories, takeDirectory,\n ())\n\n-- hspec\nimport Test.Hspec\n\n-- Internal\nimport Distribution.Simple.Finkel\n\nmain :: IO ()\nmain = do\n executable <- getExecutablePath\n pkgdbs <- getPackageDbs executable\n cwd <- getCurrentDirectory\n\n putChar '\\n'\n putStrLn (\"executable: \" ++ executable)\n putStrLn (unlines (\"pkgdbs:\" : map (\" - \" ++) pkgdbs))\n putStrLn (\"cwd: \" ++ cwd)\n\n -- Required to unset \"GHC_PACKAGE_PATH\" environment variable before\n -- invoking setup script, otherwise the setup script will complain.\n unsetEnv \"GHC_PACKAGE_PATH\"\n\n -- Setting the `null' package environment for ghc >= 8.4.0, to support\n -- building executable in test packages. In ghc 8.2.x, the use of \"-\"\n -- in GHC_ENVIRONMENT will show \"No such package environment\" error,\n -- so \"executable\" and \"test\" stanzas in \".cabal\" file are disabled.\n setEnv \"GHC_ENVIRONMENT\" \"-\"\n\n hspec (afterAll_ (setCurrentDirectory cwd)\n (beforeAll_ (removeDistIfExist cwd)\n (do buildPackage cwd pkgdbs \"p01\"\n buildPluginPackage cwd pkgdbs \"p02\")))\n\nbuildPackage :: String -> [String] -> String -> Spec\nbuildPackage = buildPackageWith setup\n where\n setup args = do\n putStrLn (unwords (\"running:\" : args))\n withArgs args fnkMain\n\nbuildPluginPackage :: String -> [String] -> String -> Spec\nbuildPluginPackage = buildPackageWith plugin_setup\n where\n plugin_setup args = do\n putStrLn (unwords (\"running:\" : args))\n withArgs args fnkPluginMainForHaddock\n\nbuildPackageWith :: ([String] -> IO ()) -> String -> [String] -> String -> Spec\nbuildPackageWith my_main cwd pkgdbs name =\n describe (\"package \" ++ name) $\n it \"should compile and pass the tests\" $ do\n let pkgdir = joinPath [cwd, \"test\", \"data\", name]\n pkgdb_flags =\n [ \"--package-db=clear\"\n , \"--package-db=global\"\n ] ++ fmap (\"--package-db=\" ++) pkgdbs\n configure_args =\n \"configure\" : pkgdb_flags ++ [\"--enable-tests\", \"-v2\"]\n run act = act `shouldReturn` ()\n mapM_ run\n [ setCurrentDirectory pkgdir\n , my_main configure_args\n , my_main [\"build\"]\n , my_main [\"test\"]\n , my_main [\"haddock\"]\n ]\n\ngetPackageDbs :: String -> IO [String]\ngetPackageDbs executable_path\n | \".stack-work\" `isSubsequenceOf` executable_path\n = getStackPackageDbs\n | \"dist-newstyle\" `isSubsequenceOf` executable_path\n = getCabalPackageDbs executable_path\n | otherwise\n = getPackageConfD executable_path\n\ngetStackPackageDbs :: IO [String]\ngetStackPackageDbs = do\n -- Getting package database paths from \"GHC_PACKAGE_PATH\" environment\n -- variable, so that we can get the package database paths without\n -- knowing which \"stack.yaml\" file were used.\n mb_paths <- lookupEnv \"GHC_PACKAGE_PATH\"\n case mb_paths of\n Just paths -> return (reverse (sepBySearchPathSeparator paths))\n Nothing -> return []\n\nsepBySearchPathSeparator :: String -> [String]\nsepBySearchPathSeparator xs =\n case dropWhile isSearchPathSeparator xs of\n \"\" -> []\n ys -> case break isSearchPathSeparator ys of\n (w, ys') -> w : sepBySearchPathSeparator ys'\n\ngetCabalPackageDbs :: String -> IO [String]\ngetCabalPackageDbs executable_path = do\n let dirs = splitDirectories executable_path\n distdir = takeWhile (/= \"dist-newstyle\") dirs\n ghc_ver = \"ghc-\" ++ cProjectVersion\n localdb = joinPath distdir \n joinPath [\"dist-newstyle\", \"packagedb\", ghc_ver]\n return [localdb]\n\ngetPackageConfD :: FilePath -> IO [FilePath]\ngetPackageConfD path = go path (takeDirectory path)\n where\n go prev current =\n if prev == current\n then return []\n else do\n let pkg_conf_d = current \"package.conf.d\"\n found <- doesDirectoryExist pkg_conf_d\n if found\n then return [pkg_conf_d]\n else go current (takeDirectory current)\n\nremoveDistIfExist :: FilePath -> IO ()\nremoveDistIfExist cwd = mapM_ remove_dir [\"p01\", \"p02\"]\n where\n remove_dir pkg =\n catch (let dir = cwd \"test\" \"data\" pkg \"dist\"\n in removeDirectoryRecursive dir)\n (\\e -> if isDoesNotExistError e\n then return ()\n else throw e)\n" }, { "path": "finkel-setup/test/data/p01/LICENSE", "content": "Copyright Author name here (c) 2017\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of Author name here nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "finkel-setup/test/data/p01/Setup.hs", "content": "import Distribution.Simple.Finkel\nmain = fnkMain\n" }, { "path": "finkel-setup/test/data/p01/exec/p01.hs", "content": "module Main where\n\nimport P01.A\n\nmain :: IO ()\nmain = print p01a\n" }, { "path": "finkel-setup/test/data/p01/p01.cabal", "content": "cabal-version: 2.0\nname: p01\nversion: 0.1.0.0\nsynopsis: Test package\ndescription: Test package\nhomepage: https://github.com/githubuser/p01#readme\nlicense: BSD3\nlicense-file: LICENSE\nauthor: Author name here\nmaintainer: example@example.com\ncopyright: 2022 Author name here\ncategory: Test\nbuild-type: Custom\nextra-source-files: src/P01/*.fnk\n\ncustom-setup\n setup-depends: base >= 4.7 && < 5\n , Cabal >= 2.0\n , finkel-setup\n\nlibrary\n hs-source-dirs: src\n exposed-modules: P01.A\n P01.B\n P01.C\n P01.D\n P01.E\n P01.F\n P01.G1\n P01.G2\n P01.H\n P01.I\n P01.J\n Paths_p01\n autogen-modules: Paths_p01\n build-depends: base >= 4.7 && < 5\n , finkel-kernel\n build-tool-depends: fkc:fkc >= 0.1 && < 1\n default-language: Haskell2010\n\nexecutable p01\n if impl(ghc >= 8.4.0)\n buildable: True\n else\n buildable: False\n hs-source-dirs: exec\n main-is: p01.hs\n ghc-options: -Wall -threaded -rtsopts\n build-depends: base\n , p01\n default-language: Haskell2010\n\ntest-suite p01-test\n if impl(ghc >= 8.4.0)\n buildable: True\n else\n buildable: False\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Spec.hs\n other-modules: TestAll\n build-depends: base\n , finkel-kernel\n , p01\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n default-language: Haskell2010\n\nsource-repository head\n type: git\n location: https://github.com/githubuser/p01\n" }, { "path": "finkel-setup/test/data/p01/src/P01/A.fnk", "content": "(module P01.A)\n\n(import P01.B)\n(import P01.C)\n(import P01.D)\n(import P01.H)\n(import P01.J)\n\n(:: p01a [String])\n(= p01a\n (concat [[\"p01a\" p01b p01c] p01d p01h [p01j]]))\n" }, { "path": "finkel-setup/test/data/p01/src/P01/B.fnk", "content": "(module P01.B)\n\n(:: p01b String)\n(= p01b \"p01b\")\n" }, { "path": "finkel-setup/test/data/p01/src/P01/C.fnk", "content": "(:require P01.G2)\n\n(module P01.C)\n\n(m1 p01c \"p01c\")\n" }, { "path": "finkel-setup/test/data/p01/src/P01/D.hs", "content": "module P01.D where\n\nimport P01.E\nimport P01.F\n\np01d :: [String]\np01d = \"p01d\": p01e\n" }, { "path": "finkel-setup/test/data/p01/src/P01/E.hs", "content": "{-# LANGUAGE CPP #-}\nmodule P01.E where\n\nimport P01.F\n\np01e :: [String]\n#ifdef DEBUG\np01e = [\"debug is defined\"]\n#else\np01e = \"p01e\" : p01f\n#endif\n" }, { "path": "finkel-setup/test/data/p01/src/P01/F.fnk", "content": "(module P01.F)\n\n(:: p01f [String])\n(= p01f [\"p01f\"])\n" }, { "path": "finkel-setup/test/data/p01/src/P01/G1.fnk", "content": "(module P01.G1)\n\n(import Language.Finkel)\n\n;; Simple definition of `define-macro' used in `p01' package.\n(:: define-macro Macro)\n(= define-macro\n (Macro (\\ form\n (case (unCode form)\n (List [_ name arg body])\n (let ((= __name\n (toCode (qSymbol (++ \"__\" (show name))\n \"G1.fnk\" 0 0 0 0))))\n (return\n `(:begin\n (:: ,name Macro)\n (= ,name\n (let ((:: ,__name (-> Code (Fnk Code)))\n (= ,__name ,arg ,body))\n (Macro ,__name))))))\n _ (finkelSrcError form \"define-macro: invalid args\")))))\n\n;;; Simple definition of `defmacro' used in `p01' package.\n(:: defmacro Macro)\n(= defmacro\n (Macro (\\ form\n (case (unLForm form)\n (L _ (List [_ name args body]))\n (case (unLForm args)\n (L l1 (List _))\n (let ((= body'\n `(define-macro ,name form\n (case (unLForm form)\n (L l2 (List [_ ,@args])) (return ,body)\n _ (finkelSrcError ',name \": error\")))))\n (return body'))\n\n (L l1 (Atom _))\n (let ((= body'\n `(define-macro ,name ,args\n (return ,body))))\n (return body')))\n\n _ (finkelSrcError form \"defmacro: error\")))))\n" }, { "path": "finkel-setup/test/data/p01/src/P01/G2.fnk", "content": "(:require P01.G1)\n\n(module P01.G2)\n\n(import Language.Finkel)\n\n(defmacro m1 (name str)\n `(:begin\n (:: ,name String)\n (= ,name ,str)))\n\n(defmacro define-p01-module (name imp)\n `(:begin\n (module ,name)\n (import ,imp)))\n\n(defmacro define-p01-function (name typ val)\n `(:begin\n (:: ,name ,typ)\n (= ,name ,val)))\n" }, { "path": "finkel-setup/test/data/p01/src/P01/H.fnk", "content": ";;;; Module using macros defined in `P01.G2'.\n\n;;; [Requiring Home Package Module]\n;;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n;;;\n;;; This module contains `require' special form which adds `P01.G2'\n;;; module to the context during macro expansion phase in skc.\n\n(:require P01.G2)\n\n(define-p01-module P01.H P01.I)\n\n(define-p01-function p01h [String]\n [\"p01h\" p01i])\n" }, { "path": "finkel-setup/test/data/p01/src/P01/I.fnk", "content": "(module P01.I)\n\n(:: p01i String)\n(= p01i \"p01i\")\n" }, { "path": "finkel-setup/test/data/p01/src/P01/J.fnk", "content": ";;;; This module test refershing context modules and macros modified by\n;;;; `require' keyword.\n\n(module P01.J)\n\n;;; Exported entities in P01.C is not used, the `import' declaration is\n;;; fore controlling the dependency analysis of `make' function.\n(import P01.C)\n\n(:: p01j String)\n(= p01j (m1 blah \"j\"))\n\n;;; In module P01.C, there is a top-level `require' of P01.G2. In\n;;; P01.G2, there is a macro named `m1'. Desired behaviour is that the\n;;; indirectly required macros should not affect the code in this\n;;; module.\n(:: m1 (-> String String String))\n(= m1 ++)\n\n(:: blah String)\n(= blah \"p01\")\n" }, { "path": "finkel-setup/test/data/p01/test/Spec.hs", "content": "module Main where\nimport System.Exit\n\nimport P01.A (p01a)\nimport TestAll (expected)\n\nmain :: IO ()\nmain =\n if p01a == expected\n then exitSuccess\n else exitFailure\n" }, { "path": "finkel-setup/test/data/p01/test/TestAll.fnk", "content": "(:require P01.G1)\n\n(module TestAll)\n\n(:: expected [String])\n(= expected\n [\"p01a\" \"p01b\" \"p01c\" \"p01d\" \"p01e\" \"p01f\" \"p01h\" \"p01i\" \"p01j\"])\n" }, { "path": "finkel-setup/test/data/p02/CHANGELOG.md", "content": "# Revision history for p02\n\n## 0.1.0.0 -- YYYY-mm-dd\n\n* First version. Released on an unsuspecting world.\n" }, { "path": "finkel-setup/test/data/p02/LICENSE", "content": "Copyright (c) 2024 8c6794b6\n\nPermission is hereby granted, free of charge, to any person obtaining\na copy of this software and associated documentation files (the\n\"Software\"), to deal in the Software without restriction, including\nwithout limitation the rights to use, copy, modify, merge, publish,\ndistribute, sublicense, and/or sell copies of the Software, and to\npermit persons to whom the Software is furnished to do so, subject to\nthe following conditions:\n\nThe above copyright notice and this permission notice shall be included\nin all copies or substantial portions of the Software.\n\nTHE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,\nEXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF\nMERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.\nIN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY\nCLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,\nTORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE\nSOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.\n" }, { "path": "finkel-setup/test/data/p02/Setup.hs", "content": "{-# LANGUAGE CPP #-}\n\n#if 906 <= __GLASGOW_HASKELL__\nimport Distribution.Simple.Finkel\nmain = fnkPluginMainForHaddock\n#else\nimport Distribution.Simple (defaultMain)\nmain = defaultMain\n#endif\n" }, { "path": "finkel-setup/test/data/p02/app/Main.hs", "content": "module Main where\n\nimport qualified MyLib (someFunc)\n\nmain :: IO ()\nmain = do\n putStrLn \"Hello, Haskell!\"\n MyLib.someFunc\n" }, { "path": "finkel-setup/test/data/p02/p02.cabal", "content": "cabal-version: 3.0\nname: p02\nversion: 0.1.0.0\nlicense: MIT\nlicense-file: LICENSE\nauthor: Author name here\nmaintainer: example@example.com\ncategory: Development\nbuild-type: Custom\nextra-doc-files: CHANGELOG.md\n\ncustom-setup\n setup-depends: base >= 4.14 && < 5\n , Cabal >= 3.2\n , finkel-setup\n\ncommon warnings\n ghc-options: -Wall\n\ncommon finkel\n build-depends: finkel-kernel\n build-tool-depends: fnkpp:fnkpp\n ghc-options: -fplugin Language.Finkel.Plugin\n -F -pgmF fnkpp -optF --no-warn-interp\n if impl (ghc >= 9.6.0)\n ghc-options: -keep-hscpp-files\n\nlibrary\n import: warnings, finkel\n exposed-modules: MyLib\n build-depends: base >= 4.14 && < 5\n hs-source-dirs: src\n default-language: Haskell2010\n\nexecutable p02\n import: warnings\n main-is: Main.hs\n build-depends: base >= 4.14 && < 5\n , p02\n hs-source-dirs: app\n default-language: Haskell2010\n\ntest-suite p02-test\n import: warnings\n default-language: Haskell2010\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Main.hs\n build-depends: base >= 4.14 && < 5\n , p02\n" }, { "path": "finkel-setup/test/data/p02/src/MyLib.hs", "content": ";;; -*- mode: finkel -*-\n\n(:doc \"Header documentation for MyLib\")\n\n(module MyLib someFunc)\n\n(:doc \"Documentation for 'someFunc'.\")\n(:: someFunc (IO ()))\n(= someFunc (putStrLn \"someFunc\"))\n" }, { "path": "finkel-setup/test/data/p02/test/Main.hs", "content": "module Main (main) where\n\nmain :: IO ()\nmain = putStrLn \"Test suite not yet implemented.\"\n" }, { "path": "finkel-tool/LICENSE", "content": "Copyright (c) 2017-2022, 8c6794b6\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "finkel-tool/README.md", "content": "# finkel-tool\n\nPackage containing a command line executable tool and library\nfunctions for building Finkel package.\n\nSee the [documentation][doc] for more details.\n\n[doc]: https://finkel.readthedocs.io/en/latest/\n" }, { "path": "finkel-tool/Setup.hs", "content": "import Distribution.Simple (defaultMain)\nmain = defaultMain\n" }, { "path": "finkel-tool/finkel-tool.cabal", "content": "cabal-version: 2.0\nname: finkel-tool\nversion: 0.0.0\nsynopsis: Finkel tool\ndescription:\n Finkel tool\n .\n See the for more info.\n\nhomepage: https://github.com/finkel-lang/finkel#readme\nlicense: BSD3\nlicense-file: LICENSE\nauthor: 8c6794b6\nmaintainer: 8c6794b6@gmail.com\ncopyright: 2017-2022 8c6794b6\ncategory: Language\nbuild-type: Simple\nextra-source-files: README.md\n finkel.hsfiles\n test/data/*.fnk\n test/data/input01.txt\n test/data/p02/LICENSE\n test/data/p02/Setup.hs\n test/data/p02/p02.cabal\n test/data/p02/README.md\n test/data/p02/stack.yaml\n test/data/p02/app/Main.hs\n test/data/p02/src/Lib.fnk\n test/data/p02/test/Spec.hs\n\ntested-with: GHC == 8.10.7\n , GHC == 9.0.2\n , GHC == 9.2.8\n , GHC == 9.4.7\n , GHC == 9.6.5\n , GHC == 9.8.2\n , GHC == 9.10.1\n\nflag dynamic\n description: Dynamically link executables (except Windows)\n default: True\n manual: True\n\nlibrary\n hs-source-dirs: src\n exposed-modules: Finkel.Tool.Command\n Finkel.Tool.Command.Eval\n Finkel.Tool.Command.Help\n Finkel.Tool.Command.Make\n Finkel.Tool.Command.Repl\n Finkel.Tool.Command.Run\n Finkel.Tool.Command.Sdist\n Finkel.Tool.Command.Version\n Finkel.Tool.Internal.CLI\n Finkel.Tool.Internal.Commit\n Finkel.Tool.Internal.Compat\n Finkel.Tool.Internal.Eval\n Finkel.Tool.Internal.Exception\n Finkel.Tool.Internal.IO\n Finkel.Tool.Internal.Listen\n Finkel.Tool.Internal.Loop\n Finkel.Tool.Internal.Macro.Ghc\n Finkel.Tool.Internal.Macro.Repl\n Finkel.Tool.Internal.Types\n Finkel.Tool.Main\n Paths_finkel_tool\n autogen-modules: Paths_finkel_tool\n build-depends: base >= 4.14 && < 5\n , bytestring >= 0.10 && < 0.13\n , Cabal >= 3.2 && < 3.13\n , deepseq >= 1.4 && < 1.6\n , directory >= 1.3 && < 1.4\n , exceptions >= 0.10 && < 0.11\n , filepath >= 1.4.1 && < 1.6\n , haskeline >= 0.8 && < 0.9\n , ghc >= 8.10.0 && < 9.11.0\n , ghc-boot >= 8.10.0 && < 9.11.0\n , ghci >= 8.10.0 && < 9.11.0\n , network >= 2.6.3 && < 3.3\n , process >= 1.6 && < 1.7\n , transformers >= 0.5 && < 0.7\n --\n , finkel-kernel == 0.0.0\n , finkel-core == 0.0.0\n\n default-language: Haskell2010\n\n build-tool-depends: fnkpp:fnkpp == 0.0.0\n ghc-options: -Wall\n -F -pgmF fnkpp -optF --no-warn-interp\n -fplugin Finkel.Core.Plugin\n if impl (ghc >= 9.6.0)\n ghc-options: -keep-hscpp-files\n\ntest-suite finkel-tool-test\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Spec.hs\n build-depends: base\n , directory\n , exceptions\n , filepath\n , ghc\n , haskeline\n , network\n , process\n , finkel-core\n , finkel-kernel\n , finkel-tool\n --\n , hspec >= 2.4.8 && < 2.12\n , silently >= 1.2 && < 1.3\n , QuickCheck >= 2.10.1 && < 2.16\n other-modules: CLITest\n GhcTest\n MainTest\n ReplTest\n ReplMacroTest\n TestAux\n default-language: Haskell2010\n\n build-tool-depends: fnkpp:fnkpp == 0.0.0\n ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N\n -F -pgmF fnkpp -optF --no-warn-interp\n -fplugin Finkel.Core.Plugin\n if !os(windows) && flag(dynamic)\n ghc-options: -dynamic\n if impl (ghc >= 9.6.0)\n ghc-options: -keep-hscpp-files\n\nsource-repository head\n type: git\n location: https://github.com/finkel-lang/finkel.git\n subdir: finkel-tool\n" }, { "path": "finkel-tool/finkel.hsfiles", "content": "{-# START_FILE {{name}}.cabal #-}\ncabal-version: 3.0\nname: {{name}}\nversion: 0.1.0.0\n-- synopsis:\n-- description:\nhomepage: http://www.example.org\nlicense: BSD-3-Clause\nlicense-file: LICENSE\nauthor: {{author-name}}{{^author-name}}Author name here{{/author-name}}\nmaintainer: {{author-email}}{{^author-email}}example@example.com{{/author-email}}\ncopyright: {{copyright}}{{^copyright}}{{year}}{{^year}}2022{{/year}} {{author-name}}{{^author-name}}Author name here{{/author-name}}{{/copyright}}\ncategory: Data\nbuild-type: Simple\nextra-source-files: README.md\n\ncommon finkel\n build-depends: finkel-core\n build-tool-depends: fnkpp:fnkpp\n ghc-options: -F -pgmF fnkpp -optF --no-warn-interp\n -fplugin Finkel.Core.Plugin\n\nlibrary\n import: finkel\n hs-source-dirs: src\n exposed-modules: Lib\n build-depends: base >= 4.7 && < 5\n default-language: Haskell2010\n\nexecutable {{name}}\n hs-source-dirs: app\n main-is: Main.hs\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n build-depends: base\n , {{name}}\n default-language: Haskell2010\n\ntest-suite {{name}}-test\n import: finkel\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Spec.hs\n build-depends: base\n , {{name}}\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n default-language: Haskell2010\n\n-- source-repository head\n-- type: git\n-- location: https://github.com/{{github-username}}{{^github-username}}githubuser{{/github-username}}/{{name}}\n\n{-# START_FILE Setup.hs #-}\nimport Distribution.Simple (defaultMain)\nmain = defaultMain\n\n{-# START_FILE test/Spec.hs #-}\nmain :: IO ()\nmain = putStrLn \"Test suite not yet implemented\"\n\n{-# START_FILE src/Lib.hs #-}\n;;; -*- mode: finkel -*-\n(defmodule Lib\n (export someFunc))\n\n(defn (:: someFunc (IO ()))\n (putStrLn \"Hello from {{name}}\"))\n\n{-# START_FILE app/Main.hs #-}\nmodule Main where\n\nimport Lib\n\nmain :: IO ()\nmain = someFunc\n\n{-# START_FILE README.md #-}\n# {{name}}\n\n{-# START_FILE LICENSE #-}\nCopyright {{author-name}}{{^author-name}}Author name here{{/author-name}} (c) {{year}}{{^year}}2022{{/year}}\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" }, { "path": "finkel-tool/src/Finkel/Tool/Command/Eval.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Eval sub command\n\n(defmodule Finkel.Tool.Command.Eval\n (export evalMain\n eval-and-exit\n eval-and-exit-with-args)\n (require\n ;; finkel-core\n (Finkel.Tool.Internal.Macro.Ghc))\n (import\n ;; base\n (Control.Concurrent [MVar newEmptyMVar newMVar takeMVar])\n (Control.Exception [displayException throwIO])\n (Control.Monad.IO.Class [(MonadIO ..)])\n (System.Console.GetOpt\n [(ArgDescr ..) (ArgOrder ..) (OptDescr ..) getOpt usageInfo])\n (System.Environment [getProgName])\n\n ;; finkel-kernel\n (Language.Finkel.Fnk [(Fnk) FnkEnv runFnk])\n (Language.Finkel.Form [Code])\n (Language.Finkel.Lexer [evalSP])\n (Language.Finkel.Options [fromFnkEnvOptions fnkEnvOptionsUsage])\n (Language.Finkel.Reader [sexpr])\n\n ;; Internal\n (Finkel.Tool.Command.Repl [repl-env])\n (Finkel.Tool.Internal.CLI)\n (Finkel.Tool.Internal.Eval)\n (Finkel.Tool.Internal.Exception)\n (Finkel.Tool.Internal.Types)))\n\n(imports-from-ghc\n (GHC.Data.StringBuffer [stringToStringBuffer]))\n\n\n\f\n;;; Exported\n\n(defn (:: evalMain (=> (CLI m) (-> [String] (m ()))))\n [args]\n (lept [all-opts (++ eval-opts eval-fnk-env-opts)\n (, os gs) (partition-descrs all-opts args)\n mk-opt (foldl (flip id) initial-eval-option)\n (, o _ es) (getOpt Permute all-opts os)]\n (case es\n [] (do-eval (mk-opt o) gs)\n _ (liftIO (throwIO (ArgumentErrors \"eval\" es))))))\n\n\f\n;;; Internal\n\n(data EvalOption\n (EvalOption {(:: eo-help Bool)\n (:: eo-fnk-env FnkEnv)}))\n\n(defn (:: initial-eval-option EvalOption)\n (EvalOption {(= eo-help False)\n (= eo-fnk-env repl-env)}))\n\n(defn (:: eval-opts [(OptDescr (-> EvalOption EvalOption))])\n [(Option [] [\"help\"]\n (NoArg (\\o (o {(= eo-help True)})))\n \"Show this help and exit\")])\n\n(defn (:: eval-fnk-env-opts [(OptDescr (-> EvalOption EvalOption))])\n (fromFnkEnvOptions (\\f o (o {(= eo-fnk-env (f (eo-fnk-env o)))}))))\n\n(defn (:: print-eval-help (=> (CLI m) (m ())))\n (do (<- me (liftIO getProgName))\n (putString\n (unlines\n [(concat [\"USAGE: \" me \" eval [OPTIONS] FORM\"])\n \"\"\n \"Evaluate given FORM expression.\"\n \"\"\n (usageInfo \"OPTIONS:\\n\" eval-opts)\n (fnkEnvOptionsUsage \"DEBUG OPTIONS:\\n\")\n others-passed-to-ghc]))))\n\n(defn (:: do-eval (=> (CLI m) (-> EvalOption [String] (m ()))))\n [eo args]\n (if (eo-help eo)\n print-eval-help\n (lept [(, ghc-args mb-str) (separate-args args)\n parse (. (evalSP sexpr (Just \"\")) stringToStringBuffer)]\n (liftIO\n (case (fmap parse mb-str)\n (Just (Right form)) (eval-and-exit ghc-args (eo-fnk-env eo) form)\n (Just (Left err)) ($ throwIO FinkelToolException displayException err)\n Nothing (throwIO NoEvalInput))))))\n\n(defn (:: separate-args (-> [String] (, [String] (Maybe String))))\n [args]\n (case args\n [] (, [] Nothing)\n [x] (, [] (Just x))\n (: x xs) (lept [(, ghc-opts mb-form) (separate-args xs)]\n (, (: x ghc-opts) mb-form))))\n\n(defn (:: eval-and-exit (-> [String] FnkEnv Code (IO ())))\n (eval-and-exit-with-args []))\n\n(defn (:: eval-and-exit-with-args (-> [String] [String] FnkEnv Code (IO ())))\n [wrapper-args ghc-args-0 fnk-env form]\n ;; Adding \"-v0\" to front of ghc arguments, to suppress module compilation\n ;; messages.\n (lept [hdl (error \"eval-and-exit: uninitialized handle\")\n ghc-args-1 (: \"-v0\" ghc-args-0)]\n (runFnk\n (do (<- (, in-mv out-mv) (make-in-and-out form))\n (eval-once wrapper-args ghc-args-1 hdl in-mv)\n (liftIO (case-do (takeMVar out-mv)\n (Right msg) (putStr msg)\n (Left errs) ($ throwIO FinkelToolException errs))))\n fnk-env)))\n\n(defn (:: make-in-and-out (-> Code (Fnk (, (MVar Input) (MVar Result)))))\n [form]\n (liftIO\n (do (<- out-mv newEmptyMVar)\n (<- in-mv (newMVar (Input Prompt form out-mv)))\n (return (, in-mv out-mv)))))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Command/Help.hs", "content": ";;; -*- mode: finkel -*-\n;;; Help utility for Finkel tool.\n\n(defmodule Finkel.Tool.Command.Help\n (export\n ;; Help command\n helpMain\n show-usage)\n (import\n ;; base\n (Control.Monad.IO.Class [(MonadIO ..)])\n (Data.Foldable [maximumBy])\n (Data.Function [on])\n (System.Environment [getProgName])\n\n ;; Internal\n (Finkel.Tool.Internal.CLI)))\n\n(defn (:: helpMain (=> (CLI m) (-> [Command] [String] (m ()))))\n \"Main function for help command.\"\n [cmds args]\n (case args\n (: name _ ) (| ((<- (Just cmd) (find-command cmds name))\n (liftIO (cmd-act cmd [\"--help\"]))))\n _ (show-usage cmds)))\n\n(defn (:: show-usage (=> (CLI m) (-> [Command] (m ()))))\n \"Show usage message generated from given commands.\"\n [cmds]\n (lefn [(max-len\n (length (maximumBy (on compare length) (fmap cmd-name cmds))))\n (pad [n str]\n (++ str (replicate (- n (length str)) #'\\SP)))\n (descr [n cmd]\n (concat [\" \" (pad n (cmd-name cmd))\n \" \" (cmd-descr cmd)]))]\n (do (<- name (liftIO getProgName))\n (putString\n (unlines\n (++ [(concat [\"USAGE:\\n\\n \" name \" [arguments]\"])\n \"\"\n (concat [\"Run \\\"\" name \" help \\\"\"\n \" for more information.\"])\n \"\"\n \"COMMANDS:\"\n \"\"]\n (fmap (descr max-len) cmds)))))))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Command/Make.hs", "content": ";;; -*- mode: finkel -*-\n;;; Module for make sub command.\n\n(defmodule Finkel.Tool.Command.Make\n (export makeMain)\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (System.Console.GetOpt [(OptDescr ..) (ArgDescr ..) (ArgOrder ..) getOpt])\n (System.Environment [getProgName withArgs withProgName])\n\n ;; finkel-kernel\n (Language.Finkel.Main [defaultMainWith])\n\n ;; finkel-core\n (Finkel.Core)))\n\n(data MakeOption\n (MakeOption {(:: mo-help Bool)}))\n\n(defn (:: initial-make-option MakeOption)\n (MakeOption {(= mo-help False)}))\n\n(defn (:: make-options [(OptDescr (-> MakeOption MakeOption))])\n [(Option [] [\"help\"]\n (NoArg (\\o (o {(= mo-help True)})))\n \"Show this help and exit\")])\n\n(defn (:: runMain (-> [String] (IO ())))\n \"Main function for compiler with macros from `Finkel.Prelude'.\"\n [args]\n (macrolet ((preloaded ()\n `[,@(map (\\mac (, mac (make-symbol mac)))\n (exported-macros Finkel.Core))]))\n (do (<- me (fmap (flip ++ \" make\") getProgName))\n (withArgs args (withProgName me (defaultMainWith (preloaded)))))))\n\n(defn (:: makeMain (-> [String] (IO ())))\n [args]\n (lept [(, o _ _) (getOpt Permute make-options args)\n mo (foldl (flip id) initial-make-option o)]\n (if (mo-help mo)\n (runMain [\"--fnk-help\"])\n (runMain args))))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Command/Repl.hs", "content": ";;; -*- mode: finkel -*-\n;;;; | Simple Finkel REPL.\n;;;;\n;;;; This implementation uses two threads: one for reading and printing,\n;;;; and another for evaluating and modifying the FnkEnv. Using `MVar'\n;;;; containing `Code' to communicate between the threads. This design\n;;;; shall be easier to support reading forms from other sources than\n;;;; line oriented user input, e.g. network sockets.\n\n(defmodule Finkel.Tool.Command.Repl\n (export replMain repl-env)\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Exception [throwIO])\n (Control.Monad [mplus])\n (Control.Monad.IO.Class [(MonadIO ..)])\n (System.Console.GetOpt\n [(ArgDescr ..) (ArgOrder ..) (OptDescr ..) getOpt usageInfo])\n (System.Environment [getProgName])\n\n ;; finkel-kernel\n (Language.Finkel)\n (Language.Finkel.Fnk [(FnkEnv ..) EnvMacros makeEnvMacros mergeMacros])\n (Language.Finkel.Options [fromFnkEnvOptions fnkEnvOptionsUsage])\n (Language.Finkel.SpecialForms [specialForms])\n\n ;; finkel-core\n (Finkel.Core)\n\n ;; Internal\n (Finkel.Tool.Internal.CLI)\n (Finkel.Tool.Internal.Exception)\n (Finkel.Tool.Internal.Loop)\n (Finkel.Tool.Internal.Macro.Repl)\n (Finkel.Tool.Internal.Types)))\n\n\n\f\n;;; Exported\n\n(defn (:: replMain (=> (CLI m) (-> [String] (m ()))))\n \"Main entry point function for REPL.\"\n [args]\n (lept [all-descrs (++ repl-options repl-fnk-env-options)\n (, repl-opts ghc-opts) (partition-descrs all-descrs args)\n initial-option (make-initial-option ghc-opts)]\n (case (getOpt Permute all-descrs repl-opts)\n (, o _other []) (do-repl (foldl (flip id) initial-option o))\n (, _ _ es) (liftIO (throwIO (ArgumentErrors \"repl\" es))))))\n\n(defn (:: repl-env FnkEnv)\n \"Environment value used by the Finkel REPL.\"\n (lept [macros (mergeMacros specialForms replMacros)]\n (defaultFnkEnv {(= envContextModules [\"Prelude\"])\n (= envMacros macros)\n (= envDefaultMacros macros)\n (= envQualifyQuotePrimitives True)})))\n\n\f\n;;; Internal\n\n(data ReplMode\n Help\n Run)\n\n(data ReplOption\n (ReplOption {(:: repl-mode ReplMode)\n (:: repl-listen-port (Maybe Int))\n (:: repl-input-path (Maybe FilePath))\n (:: repl-prompt (Maybe String))\n (:: repl-quiet Bool)\n (:: repl-init-form Code)\n (:: repl-ghc-options [String])\n (:: repl-fnk-env FnkEnv)}))\n\n(defn (:: make-initial-option (-> [String] ReplOption))\n [ghc-options]\n (ReplOption {(= repl-mode Run)\n (= repl-listen-port Nothing)\n (= repl-input-path Nothing)\n (= repl-prompt Nothing)\n (= repl-quiet False)\n (= repl-init-form greet)\n (= repl-ghc-options ghc-options)\n (= repl-fnk-env repl-env)}))\n\n(defn (:: repl-options [OptDescr (-> ReplOption ReplOption)])\n [(Option [] [\"help\"]\n (NoArg (\\o (o {(= repl-mode Help)})))\n \"Show this help and exit\")\n (Option [] [\"listen\"]\n (OptArg (\\mb-port o\n (lept [port (mplus (fmap read mb-port) (Just 50321))]\n (o {(= repl-mode Run)\n (= repl-listen-port port)})))\n \"PORT\")\n \"Listen to port (default: 50321)\")\n (Option [] [\"file\"]\n (ReqArg (\\file o (o {(= repl-input-path (Just file))}))\n \"FILE\")\n \"File to get input from\")\n (Option [] [\"prompt\"]\n (ReqArg (\\str o (o {(= repl-prompt (Just str))}))\n \"TEXT\")\n \"Prompt for input (default: '> ')\")\n (Option [] [\"quiet\"]\n (NoArg (\\o (o {(= repl-quiet True)\n (= repl-prompt (Just \"\"))\n (= repl-init-form '(:begin))})))\n \"Suppress message from REPL\")])\n\n(defn (:: repl-fnk-env-options [(OptDescr (-> ReplOption ReplOption))])\n (fromFnkEnvOptions (\\f o\n (o {(= repl-fnk-env (f (repl-fnk-env o)))}))))\n\n(defn (:: do-repl (=> (CLI m) (-> ReplOption (m ()))))\n [ro]\n (case (repl-mode ro)\n Help print-usage\n Run (liftIO (start-repl (repl-ghc-options ro)\n (repl-input-path ro)\n (repl-listen-port ro)\n (repl-fnk-env ro)\n (maybe mempty (\\p (mempty {(= prompt-string p)}))\n (repl-prompt ro))\n (repl-init-form ro)))))\n\n(defn (:: greet Code)\n \"Form containing initial message for the REPL.\"\n '(System.IO.putStrLn\n \"Hit `Ctrl-d' or type ,q to quit, type ,? for help.\"))\n\n(defn (:: print-usage (=> (CLI m) (m ())))\n (do (<- name (liftIO getProgName))\n (putString\n (unlines\n [(concat [\"USAGE: \" name \" repl [OPTIONS]\"])\n \"\"\n \"Start interactive REPL.\"\n \"\"\n (usageInfo \"OPTIONS:\\n\" repl-options)\n (fnkEnvOptionsUsage \"DEBUG OPTIONS:\\n\")\n \" Other options are passed to ghc.\"]))))\n\n(defn (:: replMacros EnvMacros)\n \"Default macros imported in REPL. These macros always get imported after\nloading compiled modules.\"\n (macrolet [(the-macros ()\n `[,@(map (\\mac `(, ,mac ,(make-symbol mac)))\n (: \"repl_macro\" (exported-macros Finkel.Core)))])]\n (makeEnvMacros (the-macros))))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Command/Run.hs", "content": ";;; -*- mode: finkel -*-\n;;; Module for run sub command\n\n(defmodule Finkel.Tool.Command.Run\n (export runMain)\n (import\n ;; base\n (Control.Exception [throwIO])\n (Control.Monad.IO.Class [(MonadIO ..)])\n (System.Console.GetOpt\n [(ArgDescr ..) (ArgOrder ..) (OptDescr ..) getOpt usageInfo])\n (System.Environment [getProgName])\n\n ;; finkel-kernel\n (Language.Finkel.Fnk [FnkEnv])\n (Language.Finkel.Options [fromFnkEnvOptions fnkEnvOptionsUsage])\n\n ;; finkel-core\n (Finkel.Core.Functions [make-symbol])\n\n ;; Internal\n (Finkel.Tool.Command.Eval [eval-and-exit-with-args])\n (Finkel.Tool.Command.Repl [repl-env])\n (Finkel.Tool.Internal.CLI)\n (Finkel.Tool.Internal.Exception)))\n\n(defn (:: runMain (=> (CLI m) (-> [String] (m ()))))\n [args0]\n (lept [(, args1 prog-args) (split-program-args args0)\n all-opts (++ run-opts run-fnk-env-opts)\n (, rargs ghc-args) (partition-descrs all-opts args1)\n (, o _ es) (getOpt Permute all-opts rargs)\n ro (foldl (flip id) initial-run-option o)\n main-fn (make-symbol (mangle-name (ro-main ro)))]\n (if (ro-help ro)\n print-run-help\n (liftIO\n (case es\n [] (eval-and-exit-with-args prog-args\n ghc-args\n (ro-fnk-env ro)\n main-fn)\n _ (throwIO (ArgumentErrors \"run\" es)))))))\n\n(data RunOption\n (RunOption {(:: ro-help Bool)\n (:: ro-main String)\n (:: ro-fnk-env FnkEnv)}))\n\n(defn (:: initial-run-option RunOption)\n (RunOption {(= ro-help False)\n (= ro-main \"main\")\n (= ro-fnk-env repl-env)}))\n\n(defn (:: run-opts [(OptDescr (-> RunOption RunOption))])\n [(Option [] [\"help\"]\n (NoArg (\\o (o {(= ro-help True)})))\n \"Show this help and exit\")\n (Option [] [\"main\"]\n (ReqArg (\\name o (o {(= ro-main name)}))\n \"NAME\")\n \"Name of the function to run (default: main)\")])\n\n(defn (:: run-fnk-env-opts [(OptDescr (-> RunOption RunOption))])\n (fromFnkEnvOptions (\\f o (o {(= ro-fnk-env (f (ro-fnk-env o)))}))))\n\n(defn (:: print-run-help (=> (CLI m) (m ())))\n (do (<- me (liftIO getProgName))\n (putString\n (unlines\n [(concat [\"USAGE: \" me \" run [OPTIONS] FILE [-- ARGS]\"])\n \"\"\n \"Compile and run given FILE.\"\n \"\"\n \"Arguments after `--' are passed to the given FILE.\"\n \"\"\n (usageInfo \"OPTIONS:\\n\" run-opts)\n (fnkEnvOptionsUsage \"DEBUG OPTIONS:\\n\")\n others-passed-to-ghc]))))\n\n(defn (:: split-program-args (-> [String] (, [String] [String])))\n [xs]\n (case (break (== \"--\") xs)\n (, pre (: \"--\" post)) (, pre post)\n (, pre _) (, pre [])))\n\n(defn (:: mangle-name (-> String String))\n (lefn [(replace [c]\n (if (== c #'-) #'_ c))]\n (map replace)))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Command/Sdist.hs", "content": ";;; -*- mode: finkel -*-\n\n;;; Finkel sdist command, to create tar.gz of cabal package\n;;;\n;;; XXX: Consider removing this command when the support for \"*.fnk\" file\n;;; extension is dropped.\n\n(defmodule Finkel.Tool.Command.Sdist\n (export sdistMain)\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Exception [throwIO])\n (Control.Monad [>=>])\n (Control.Monad.IO.Class [liftIO])\n (System.Environment [getProgName])\n\n ;; Cabal\n (Distribution.PackageDescription.Configuration [flattenPackageDescription])\n\n (Distribution.Simple.BuildPaths [srcPref])\n (Distribution.Simple.Command [(CommandParse ..) (CommandUI ..)\n commandParseArgs])\n (Distribution.Simple.PreProcess [knownSuffixHandlers])\n (Distribution.Simple.Setup [(SDistFlags ..) defaultSDistFlags sdistCommand])\n (Distribution.Simple.SrcDist [sdist])\n (Distribution.Simple.Utils [findPackageDesc])\n\n (Distribution.Simple.PreProcess [PPSuffixHandler (PreProcessor ..)\n mkSimplePreProcessor])\n\n ;; directory\n (System.Directory [withCurrentDirectory])\n\n ;; Internal\n (Finkel.Tool.Internal.CLI)\n (Finkel.Tool.Internal.Exception)))\n\n\n;;; Extra imports for version compatibility\n\n(cond-expand\n [(:min-version \"Cabal\" 3 12 0)\n (:begin\n (import Distribution.Simple.Errors (exceptionMessage))\n (import Distribution.Simple.PreProcess ((Suffix ..))))]\n [otherwise\n (:begin)])\n\n(cond-expand\n [(:min-version \"Cabal\" 3 8 0)\n (import Distribution.Simple.PreProcess (unsorted))]\n [otherwise\n (:begin)])\n\n(cond-expand\n [(:min-version \"Cabal\" 3 0 1)\n (:begin)]\n [otherwise\n (import Distribution.Simple.Configure (findDistPrefOrDefault))])\n\n(cond-expand\n [(:min-version \"Cabal\" 3 0 1)\n (import Distribution.Simple.Flag (fromFlag))]\n [(:min-version \"Cabal\" 2 4 0)\n (import Distribution.Simple.Flag (fromFlag toFlag))]\n [otherwise\n (import Distribution.Simple.Setup (fromFlag toFlag))])\n\n(cond-expand\n [(:min-version \"Cabal\" 3 8 0)\n (import Distribution.Simple.PackageDescription\n (readGenericPackageDescription))]\n [(:min-version \"Cabal\" 2 2 0)\n (import Distribution.PackageDescription.Parsec\n (readGenericPackageDescription))]\n [otherwise\n (import Distribution.PackageDescription.Parse\n (readGenericPackageDescription))])\n\n;;; Main action\n\n(defn (:: sdistMain (=> (CLI m) (-> [String] (m ()))))\n [args]\n (lefn [(write-tgzs [parsed]\n (do (lept [(, update-flags non-opts) parsed\n flags1 (update-flags defaultSDistFlags)])\n (<- flags2 (update-dist-pref flags1))\n (lept [verbosity (fromFlag (sDistVerbosity flags2))\n write (write-tgz verbosity flags2)])\n (if (null non-opts)\n (write \".\")\n (mapM- write non-opts))))\n (write-tgz [verbosity flags dir]\n (>>= (findPackageDesc dir)\n (either (cond-expand\n [(:min-version \"Cabal\" 3 12 0)\n (. throwIO FinkelToolException exceptionMessage)]\n [otherwise\n (. throwIO FinkelToolException)])\n (>=> (readGenericPackageDescription verbosity)\n (write-tgz-2 flags dir)))))\n (write-tgz-2 [flags dir descr]\n (lept [sd (run-sdist (flattenPackageDescription descr) flags)]\n (if (== dir \".\")\n sd\n (withCurrentDirectory dir sd))))\n (update-dist-pref [flags]\n (cond-expand\n [(:min-version \"Cabal\" 3 0 0)\n (pure flags)]\n [otherwise\n ;; Until Cabal 3.x, seems like the \"sDistDistPref\" field was set\n ;; by \"configure\" command, setting it manually.\n (do (<- pref (findDistPrefOrDefault (sDistDistPref flags)))\n (pure (flags {(= sDistDistPref (toFlag pref))})))]))\n (run-sdist [pd flags]\n (lept [sufs (: finkelPPHandler knownSuffixHandlers)]\n (cond-expand\n [(:min-version \"Cabal\" 3 4 0)\n (sdist pd flags srcPref sufs)]\n [otherwise\n (sdist pd Nothing flags srcPref sufs)])))\n (my-sdist-cmd\n (sdistCommand\n {(= commandUsage\n (\\pname\n (++ \"Usage: \" pname \" sdist [FLAGS] [DIRS]\\n\")))}))]\n (liftIO\n (case (commandParseArgs my-sdist-cmd False args)\n (CommandHelp f) (>>= getProgName (. putStrLn f))\n (CommandList os) ($ putStr unlines os)\n (CommandReadyToGo parsed) (write-tgzs parsed)\n (CommandErrors es) (throwIO (ArgumentErrors \"sdist\" es))))))\n\n;;; Preprocessor suffix handler to merely register files with @\"*.fnk\"@ files.\n(defn (:: finkelPPHandler PPSuffixHandler)\n (where (, suffix do_nothing_pp)\n (defn suffix\n (cond-expand\n [(:min-version \"Cabal\" 3 12 0) (Suffix \"fnk\")]\n [otherwise \"fnk\"]))\n (defn do_nothing_pp [_ _ _]\n (cond-expand\n [(:min-version \"Cabal\" 3 8 0)\n (PreProcessor {(= platformIndependent True)\n (= ppOrdering unsorted)\n (= runPreProcessor (mkSimplePreProcessor\n (\\ _ _ _ (pure ()))))})]\n [otherwise\n (PreProcessor {(= platformIndependent True)\n (= runPreProcessor (mkSimplePreProcessor\n (\\ _ _ _ (pure ()))))})]))))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Command/Version.hs", "content": ";;; -*- mode: finkel -*-\n;;; Module for showing versions.\n\n(defmodule Finkel.Tool.Command.Version\n (export versionMain)\n (require\n ;; finkel-core\n (Finkel.Tool.Internal.Macro.Ghc))\n (import-when [:compile :load]\n ;; base\n (Control.Monad.IO.Class [(MonadIO ..)]))\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude)\n\n ;; Internal\n (Finkel.Tool.Internal.Commit))\n (import\n ;; base\n (Data.Version [showVersion])\n (System.Console.GetOpt\n [(ArgDescr ..) (ArgOrder ..) (OptDescr ..) getOpt usageInfo])\n (System.Environment [getProgName])\n (System.Info [arch os])\n\n ;; finkel-core\n (qualified Paths_finkel_core)\n\n ;; Internal\n (Finkel.Tool.Internal.CLI)))\n\n(imports-from-ghc\n (GHC.Settings.Config [cProjectVersion]))\n\n\f\n;;; Exported\n\n(defn (:: versionMain (=> (CLI m) (-> [String] (m ()))))\n \"Main function for version sub command.\"\n [args]\n (case (getOpt Permute version-descrs args)\n (, opts _ []) (show-version (foldr const VersionMessage opts))\n (, _ _ es) (do (putString (concat es))\n print-version-help)))\n\n\f\n;;; Internal\n\n(data VersionMode\n VersionMessage\n VersionNumeric\n VersionHelp)\n\n(defn (:: version-descrs [OptDescr VersionMode])\n [(Option [#'n] [\"numeric\"]\n (NoArg VersionNumeric)\n \"show numeric version\")\n (Option [#'h] [\"help\"]\n (NoArg VersionHelp)\n \"show this help and exit\")])\n\n(defn (:: show-version (=> (CLI m) (-> VersionMode (m ()))))\n [mode]\n (case mode\n VersionMessage print-version-message\n VersionNumeric print-version-numeric\n VersionHelp print-version-help))\n\n(defn (:: print-version-message (=> (CLI m) (m ())))\n (macroletM ((get-commit-id _\n (case-do (liftIO get-git-commit)\n (Just str) (return (toCode (: #'- str)))\n Nothing (return '\"\"))))\n (do (<- name (liftIO getProgName))\n (putString\n (++ name \" \" finkel-version (get-commit-id) \" \" arch \"-\" os \"\\n\"\n \"compiled with ghc \" cProjectVersion)))))\n\n(defn (:: print-version-numeric (=> (CLI m) (m ())))\n (putString finkel-version))\n\n(defn (:: print-version-help (=> (CLI m) (m ())))\n (do (<- name (liftIO getProgName))\n (putString\n (unlines\n [(concat [\"USAGE: \" name \" version [OPTIONS]\"])\n \"\"\n \"Show version information.\"\n \"\"\n (usageInfo \"OPTIONS:\\n\" version-descrs)]))))\n\n(defn (:: finkel-version String)\n (showVersion Paths_finkel_core.version))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Command.hs", "content": ";;; -*- mode: finkel -*-\n;;; Commands\n\n(defmodule Finkel.Tool.Command\n (export commands)\n (import\n (Finkel.Tool.Command.Eval)\n (Finkel.Tool.Command.Help)\n (Finkel.Tool.Command.Make)\n (Finkel.Tool.Command.Repl)\n (Finkel.Tool.Command.Run)\n (Finkel.Tool.Command.Sdist)\n (Finkel.Tool.Command.Version)\n (Finkel.Tool.Internal.CLI)))\n\n(defn (:: commands [Command])\n \"Available commands in the `finkel' executable.\"\n [(Command \"eval\" \"evaluate given form\" evalMain)\n (Command \"help\" \"show help information\" (helpMain commands))\n (Command \"make\" \"compile source codes\" makeMain)\n (Command \"repl\" \"start interactive REPL\" replMain)\n (Command \"run\" \"run function in module\" runMain)\n (Command \"sdist\" \"create source tarballs\" sdistMain)\n (Command \"version\" \"show version\" versionMain)])\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/CLI.hs", "content": ";;; -*- mode: finkel -*-\n;;; Command line interface utilities.\n\n(defmodule Finkel.Tool.Internal.CLI\n (export\n (CLI ..)\n (Command ..)\n (ExitCode ..)\n find-command\n partition-descrs\n others-passed-to-ghc)\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Exception [throwIO])\n (Control.Monad.IO.Class [(MonadIO ..)])\n (Data.Foldable [find])\n (Data.List [isPrefixOf])\n (System.Console.GetOpt [(ArgDescr ..) (OptDescr ..)])\n (System.Exit [(ExitCode ..)])\n (System.IO.Error [isEOFError])\n (qualified Control.Exception)\n (qualified System.Exit as Exit)\n\n ;; haskeline\n (System.Console.Haskeline [InputT])\n (qualified System.Console.Haskeline as Haskeline)))\n\n(import Control.Monad.Catch\n ((MonadThrow ..) (MonadCatch ..) (MonadMask ..)))\n\n;;; Type class for command line interface, ... actually, for 'InputT' from the\n;;; haskeline package.\n(class (=> (MonadIO cl) (CLI cl))\n ;; Show prompt string, and get input line. Return Nothing for EOF\n ;; input.\n (:: getString (-> String (cl (Maybe String))))\n\n ;; Put output line.\n (:: putString (-> String (cl ())))\n\n ;; Interrupt signal handler.\n (:: handleInterrupt (-> (cl a) (cl a) (cl a)))\n\n ;; Perform computation with interrupt handler.\n (:: withInterrupt (-> (cl a) (cl a)))\n\n ;; Exit with given 'ExitCode'.\n (:: exitWith (-> ExitCode (cl ()))))\n\n(instance (CLI IO)\n (= getString prompt\n (Control.Exception.catch\n (>> (putStr prompt) (fmap Just getLine))\n (\\e (if (isEOFError e)\n (return Nothing)\n (throwIO e)))))\n (= putString putStrLn)\n (= handleInterrupt _handler act act)\n (= withInterrupt act act)\n (= exitWith Exit.exitWith))\n\n(instance (=> (MonadIO m) (MonadCatch m) (MonadMask m) (MonadThrow m)\n (CLI (InputT m)))\n (= getString Haskeline.getInputLine)\n %p(INLINE getString)\n (= putString Haskeline.outputStrLn)\n %p(INLINE putString)\n (= handleInterrupt Haskeline.handleInterrupt)\n %p(INLINE handleInterrupt)\n (= withInterrupt Haskeline.withInterrupt)\n %p(INLINE withInterrupt)\n (= exitWith (. liftIO Exit.exitWith))\n %p(INLINE exitWith))\n\n\n;;; Command data type\n\n;;; Data type to wrap an IO action taking string arguments with name and\n;;; description.\n(data Command\n (Command {(:: cmd-name String)\n (:: cmd-descr String)\n (:: cmd-act (-> [String] (IO ())))}))\n\n(defn (:: find-command (-> [Command] String (Maybe Command)))\n \"Find the command by command name.\"\n [cmds name]\n (find (. (== name) cmd-name) cmds))\n\n\n;;; Command line option helper\n\n;;; Note: [Finkel options, ghc options, and RTS options]\n;;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n;;;\n;;; The finkel executable sub commands support options specific to itself, and\n;;; some of the sub commands support options to update `DynFlags' in GhcMonad,\n;;; and the executable itself support options for RTS. To support these three\n;;; kind of options, the command line argument handling work starts with\n;;; filtering out the finkel sub command specific options with manually\n;;; separating the options defined with `OptDescr' from `System.Console.GetOpts'\n;;; module. Then, the rest of the arguments are treated as ghc options and RTS\n;;; options.\n;;;\n;;; Note that, in the C source code of the `rts' package, command line arguments\n;;; after `--' are passed to the callee program (see: \"rts/RtsFlags.c\" in the\n;;; ghc source code for detail). Once the command line parser for REPL options\n;;; tried to separate ghc options from REPL specific options with `--', however\n;;; this approach did not work well when considering RTS options.\n\n(defn (:: others-passed-to-ghc String)\n \" Other options are passed to ghc.\")\n\n(defn (:: partition-descrs\n (-> [(OptDescr a)] [String] (, [String] [String])))\n [descrs]\n (lefn [(go [xs0]\n (cond\n [(<- (: x0 x1 rest) xs0)\n (req-arg x0)\n (case (go rest)\n (, as bs) (, (: x0 x1 as) bs))]\n [(<- (: x0 rest) xs0)\n (case (go rest)\n (, as bs) (if (|| (req-arg x0) (no-arg x0) (opt-arg x0)\n (req-arg-short-no-space x0))\n (, (: x0 as) bs)\n (, as (: x0 bs))))]\n [(<- [] xs0)\n (, [] [])]))\n (no-arg\n [(: #'- #'- cs)] (elem cs long-nos)\n [(: #'- [c])] (elem c short-nos)\n [_] False)\n (req-arg\n [(: #'- #'- cs)] (elem cs long-reqs)\n [(: #'- [c])] (elem c short-reqs)\n [_] False)\n (req-arg-short-no-space\n [(: #'- c _)] (elem c short-reqs)\n [_] False)\n (opt-arg\n [(: #'- #'- cs)] (any (flip isPrefixOf cs) long-eqs)\n [_] False)\n ((, short-nos long-nos short-reqs long-reqs long-eqs)\n (group-descrs descrs))]\n go))\n\n(defn (:: group-descrs\n (-> [(OptDescr a)] (, String [String] String [String] [String])))\n [descrs]\n (lefn [(long-eq [cs]\n (++ cs \"=\"))\n (oflags [cs acc]\n (++ (map long-eq cs) acc))\n (f [(Option ss ls adescr _) (, sns lns srs lrs les)]\n (case adescr\n (NoArg {}) (, (++ ss sns) (++ ls lns) srs lrs les)\n (ReqArg {}) (lefn [(srs' (++ ss srs))\n (lrs' (++ ls lrs))\n (les' (oflags ls les))]\n (, sns lns srs' lrs' les'))\n (OptArg {}) (, sns lns srs lrs (oflags ls les))))]\n (foldr f (, [] [] [] [] []) descrs)))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/Commit.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Module containing function to get git commit ID\n\n(defmodule Finkel.Tool.Internal.Commit\n (export get-git-commit)\n (import\n ;; base\n (Control.Exception [(SomeException ..) catch])\n (System.Exit [(ExitCode ..)])\n\n ;; process\n (System.Process [readProcess readProcessWithExitCode])))\n\n(defn (:: is-dirty (IO Bool))\n (case-do (readProcessWithExitCode \"git\" [\"diff\" \"--quiet\"] [])\n (, ExitSuccess _ _) (return False)\n _ (return True)))\n\n(defn (:: get-git-commit (IO (Maybe String)))\n (catch (case-do (fmap lines (readProcess \"git\"\n [\"rev-parse\" \"--short=7\" \"HEAD\"]\n []))\n (: hash _) (do (<- dirty is-dirty)\n (return (Just (++ hash (if dirty \"-dirty\" \"\")))))\n _ (return Nothing))\n (\\ (SomeException _) (return Nothing))))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/Compat.hs", "content": ";;; -*- mode: finkel -*-\n\n%p(LANGUAGE TypeApplications\n TypeFamilies)\n\n;;;; Some commonly used version compatibility type and functions\n\n(defmodule Finkel.Tool.Internal.Compat\n (export WARNINGs NamePprCtx print-or-throw-diagnostics\n ppr-wrapped-msg-bag-with-loc get-name-ppr-ctx)\n (require\n (Finkel.Tool.Internal.Macro.Ghc))\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; finkel-kernel\n (Language.Finkel.Error [WARNINGs printOrThrowDiagnostics'])))\n\n;;; ghc\n\n(imports-from-ghc\n (GHC.Driver.Env [(HscEnv ..)])\n (GHC.Driver.Monad [(GhcMonad ..)])\n (GHC.Driver.Session [(DynFlags ..)])\n (GHC.Utils.Outputable [SDoc]))\n\n(cond-expand\n [(<= 906 :ghc)\n (import GHC (NamePprCtx getNamePprCtx))]\n [otherwise\n (import GHC (PrintUnqualified getPrintUnqual))])\n\n(cond-expand\n [(<= 906 :ghc)\n (:begin\n (import GHC.Driver.Errors.Types ((GhcMessage ..) GhcMessageOpts))\n (import GHC.Types.Error ((Messages ..) (Diagnostic ..)\n defaultDiagnosticOpts)))]\n [(<= 904 :ghc)\n (import GHC.Types.Error (Diagnostic Messages getMessages))]\n [otherwise\n (:begin\n (import Language.Finkel.Error (WrappedMsg))\n (imports-from-ghc\n (GHC.Data.Bag [Bag])))])\n\n(cond-expand\n [(<= 902 :ghc)\n (import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc))]\n [otherwise\n (imports-from-ghc\n (GHC.Utils.Error [pprErrMsgBagWithLoc]))])\n\n;;; Functions\n\n(:: get-name-ppr-ctx (=> (GhcMonad m) (m NamePprCtx)))\n\n(cond-expand\n [(<= 906 :ghc)\n (defn get-name-ppr-ctx getNamePprCtx)]\n [otherwise\n (:begin\n (type NamePprCtx PrintUnqualified)\n (defn get-name-ppr-ctx getPrintUnqual))])\n\n(defn (:: print-or-throw-diagnostics (-> HscEnv DynFlags WARNINGs (IO ())))\n [_hsc-env dflags warns]\n (cond-expand\n [(<= 902 :ghc)\n (printOrThrowDiagnostics' (hsc-logger _hsc-env) dflags warns)]\n [otherwise\n (printOrThrowDiagnostics' (error \"no logger\") dflags warns)]))\n\n(cond-expand\n [(<= 906 :ghc)\n (defn (:: ppr-wrapped-msg-bag-with-loc\n (=> (Diagnostic e) (~ (DiagnosticOpts e) GhcMessageOpts)\n (-> (Messages e) [SDoc])))\n [msg]\n (pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @GhcMessage)\n (getMessages msg)))]\n [(<= 904 :ghc)\n (defn (:: ppr-wrapped-msg-bag-with-loc\n (=> (Diagnostic e) (-> (Messages e) [SDoc])))\n (. pprMsgEnvelopeBagWithLoc getMessages))]\n [otherwise\n (defn (:: ppr-wrapped-msg-bag-with-loc (-> (Bag WrappedMsg) [SDoc]))\n (cond-expand\n [(<= 902 :ghc) pprMsgEnvelopeBagWithLoc]\n [otherwise pprErrMsgBagWithLoc]))])\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/Eval.hs", "content": ";;; -*- mode: finkel -*-\n\n;;; Eval loop in REPL.\n\n(defmodule Finkel.Tool.Internal.Eval\n (export eval-loop eval-once fork-eval-loop)\n (require\n ;; Internal\n (Finkel.Tool.Internal.Macro.Ghc))\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Concurrent [MVar ThreadId forkIOWithUnmask putMVar takeMVar])\n (Control.Exception\n [(AsyncException ..) (Exception ..) SomeException\n fromException throwIO throwTo])\n (Control.Monad (unless))\n (Control.Monad.IO.Class [(MonadIO ..)])\n (Data.Foldable [toList])\n (Data.List [intercalate])\n (GHC.Conc [myThreadId])\n (System.IO [Handle])\n\n ;; exceptions\n (Control.Monad.Catch [catch])\n\n ;; ghc-boot\n (GHC.LanguageExtensions [(Extension ..)])\n\n ;; ghci\n (GHCi.Message [(EvalExpr ..)])\n (GHCi.RemoteTypes (ForeignHValue))\n\n ;; finkel-kernel\n (Language.Finkel)\n (Language.Finkel.Builder [HDecl HImportDecl HStmt\n syntaxErrCode syntaxErrMsg evalBuilder])\n (Language.Finkel.Error [mkWrappedMsg])\n (Language.Finkel.Eval [evalDecls])\n (Language.Finkel.Exception [finkelExceptionLoc])\n (Language.Finkel.Make [initSessionForMake isFnkFile isHsFile])\n (Language.Finkel.Fnk\n [(FnkEnv ..) failFnk modifyFnkEnv prepareInterpreter setDynFlags\n useInterpreter withTmpDynFlags])\n (Language.Finkel.Syntax [parseExpr parseImports parseStmt parseTopDecls])\n\n (Language.Finkel.Plugin [setFinkelPluginWithArgs])\n (Finkel.Core.Plugin [plugin])\n\n ;; internal\n (Finkel.Tool.Internal.Compat)\n (Finkel.Tool.Internal.Exception)\n (Finkel.Tool.Internal.IO)\n (Finkel.Tool.Internal.Macro.Repl)\n (Finkel.Tool.Internal.Types)))\n\n(imports-from-ghc\n (GHC\n [(Target ..) (TargetId ..) parseDynamicFlags setTargets])\n\n (GHC.Data.Bag [unitBag])\n (GHC.Data.OrdList [toOL])\n\n (GHC.Driver.Env [(HscEnv ..)])\n (GHC.Driver.Monad [(GhcMonad ..) modifySession withTempSession])\n (GHC.Driver.Ppr [showSDoc showPpr])\n (GHC.Driver.Session\n [(DynFlags ..) (GeneralFlag ..) (HasDynFlags ..) (Option ..)\n gopt-set xopt-unset])\n\n (GHC.Parser.PostProcess [cvTopDecls])\n\n (GHC.Runtime.Context [(InteractiveImport ..) setInteractivePrintName])\n (GHC.Runtime.Eval [(ExecOptions ..) (ExecResult ..) compileParsedExprRemote\n getContext parseName setContext execStmt' execOptions])\n\n (GHC.Types.Basic [(SuccessFlag ..)])\n\n (GHC.Types.Name [(Name) getName nameOccName occNameString])\n (GHC.Types.SourceError [SourceError srcErrorMessages])\n (GHC.Types.SrcLoc [mkGeneralLocated unLoc])\n (GHC.Types.TyThing [(TyThing ..)])\n (GHC.Types.Var [Var varType])\n\n (GHC.Unit.Module [mkModuleName])\n\n (GHC.Utils.Misc [looksLikeModuleName])\n (GHC.Utils.Outputable\n [SDoc ppr mkErrStyle setStyleColoured text vcat]))\n\n\n;;; Extra imports\n\n(import GHC.Hs.ImpExp ((ImportDecl ..) isImportDeclQualified))\n\n(cond-expand\n [(<= 906 :ghc)\n (import Language.Haskell.Syntax.ImpExp ((ImportListInterpretation ..)))]\n [otherwise\n (:begin)])\n\n(cond-expand\n [(<= 904 :ghc)\n (:begin\n (import GHC.Driver.Env (hscActiveUnitId))\n (import GHC.Types.Error (mkMessages)))]\n [otherwise\n (:begin)])\n\n(cond-expand\n [(<= 902 :ghc)\n (import GHC.Utils.Outputable (renderWithContext))]\n [otherwise\n (imports-from-ghc\n (GHC.Utils.Outputable [renderWithStyle]))])\n\n(cond-expand\n [(<= 902 :ghc)\n (import GHC.Driver.Session (initSDocContext))]\n [(<= 900 :ghc)\n (import GHC.Utils.Outputable (initSDocContext))]\n [otherwise\n (:begin)])\n\n;;; Version compatibility function\n\n(defn (:: optional-dynflags [GeneralFlag])\n \"Optional 'GeneralFlag' set for REPL.\n\nSee \\\"GHCi.UI\\\", \\\"GHCi.UI.Monad\\\", and \\\"ghc/Main.hs\\\".\"\n (cond-expand\n [(<= 906 :ghc)\n [Opt-ImplicitImportQualified\n Opt-IgnoreOptimChanges\n Opt-IgnoreHpcChanges\n Opt-UseBytecodeRatherThanObjects]]\n [otherwise\n [Opt-ImplicitImportQualified\n Opt-IgnoreOptimChanges\n Opt-IgnoreHpcChanges]]))\n\n(defn (:: parse-dynamic-flags\n (=> (MonadIO m)\n (-> HscEnv [Located String]\n (m (, DynFlags [Located String] WARNINGs)))))\n [hsc-env]\n (cond-expand\n [(<= 902 :ghc)\n (parseDynamicFlags (hsc-logger hsc-env) (hsc-dflags hsc-env))]\n [otherwise\n (parseDynamicFlags (hsc-dflags hsc-env))]))\n\n(defn (:: render-with-err-style (-> DynFlags NamePprCtx SDoc String))\n [dflags unqual sdoc]\n (lept [style0 (cond-expand\n [(<= 900 :ghc) (mkErrStyle unqual)]\n [otherwise (mkErrStyle dflags unqual)])\n style1 (setStyleColoured True style0)]\n (cond-expand\n [(<= 902 :ghc)\n (renderWithContext (initSDocContext dflags style1) sdoc)]\n [(<= 900 :ghc)\n (renderWithStyle (initSDocContext dflags style1) sdoc)]\n [otherwise\n (renderWithStyle dflags sdoc style1)])))\n\n\f\n;;; Eval loop\n\n(defn (:: fork-eval-loop\n (-> [String] Handle (MVar Input) FnkEnv (IO ThreadId)))\n [ghc-args hdl in-mv fnk-env]\n (do (<- me myThreadId)\n (forkIOWithUnmask\n (\\unmask\n (catch (unmask (runFnk (eval-loop ghc-args hdl in-mv) fnk-env))\n (\\e (throwTo me (:: e SomeException))))))))\n\n(defn (:: init-eval-loop (-> [String] [String] (Fnk ForeignHValue)))\n \"Initialization works for evaluation loop.\"\n [eval-wrapper-opts ghc-opts]\n (do prepareInterpreter\n\n ;; Parse the ghc options from argument, assuming that the arguments are\n ;; passed from the command line.\n (<- hsc-env0 getSession)\n (lept [on-the-commandline (mkGeneralLocated \"on the commandline\")\n ghc-opts2 (<> [\"-F\" \"-pgmF\" \"fnkpp\" \"-optF\" \"--no-warn-interp\"]\n ghc-opts)\n ;; XXX: Get plugin options from command line\n plugin-args []\n lghc-opts (map on-the-commandline ghc-opts2)])\n (<- (, dflags0 fileish warns) (parse-dynamic-flags hsc-env0 lghc-opts))\n (liftIO (print-or-throw-diagnostics hsc-env0 dflags0 warns))\n\n ;; As done in the Main.hs in \"ghc-bin\" package, updating the `ldInputs'\n ;; field o the `DynFlags' with `FileOption', to support linking object\n ;; files.\n (lept [dflags1 (foldl gopt-set dflags0 optional-dynflags)\n (, srcs objs) (partition-args fileish)\n dflags2 (dflags1 {(= ldInputs\n (++ (map (. (FileOption \"\") unLoc) objs)\n (ldInputs dflags1)))})])\n\n ;; Initializing plugins with dflags from updated session.\n (setDynFlags dflags2)\n initSessionForMake\n\n ;; Registring the finkel plugin.\n ;;\n ;; XXX: It is possible to pass \"-fplugin\" option and dynamically load the\n ;; plugin module. Reconsider after rewriting other commands with\n ;; plugin. If so, modify the `ghc-opts' to take the options for plugin.\n (setFinkelPluginWithArgs plugin plugin-args)\n\n ;; Setting the default `DynFlags' for macro expansion.\n (<- dflags3 getDynFlags)\n (modifyFnkEnv (\\e (e {(= envDefaultDynFlags (Just dflags3))})))\n\n ;; Load modules specified from command line, when given.\n (lept [err (=<< (. liftIO throwIO FinkelToolException))])\n (unless (null srcs)\n (catch (do (setTargets (map (guessFnkTarget hsc-env0) srcs))\n (<- sflag (compile-and-import srcs))\n (case sflag\n Failed ($ err pure (++ \"Failed loading: \")\n (intercalate \", \") (map unLoc) fileish)\n Succeeded (pure ())))\n (\\e\n (cond\n [(<- (Just se) (fromException e))\n ($ err make-src-err-message se)]\n [(<- (Just fe) (fromException e))\n ($ err make-finkel-exception-message fe)]\n [otherwise\n ($ err pure displayException e)]))))\n\n ;; XXX: Currently the printer function and the arguments returned from\n ;; \"System.Environment.getArgs\" are defined here and cannot be changed.\n (set-print-name \"System.IO.print\")\n\n ;; Pass the argument to evaluation wrapper, to set the value of `argv'\n ;; returned from `System.Environment.getArgs'.\n (make-eval-wrapper eval-wrapper-opts)))\n\n(defn (:: eval-loop (-> [String] Handle (MVar Input) (Fnk ())))\n \"Loop to evaluate expressions.\"\n (eval-loop-or-once False []))\n\n(defn (:: eval-once (-> [String] [String] Handle (MVar Input) (Fnk ())))\n \"Evalute the form once and return.\"\n (eval-loop-or-once True))\n\n(defn (:: eval-loop-or-once\n (-> Bool [String] [String] Handle (MVar Input) (Fnk ())))\n \"Evaluate expressions, and loop or return.\"\n [once-only wrapper-args ghc-opts hdl in-mvar]\n (lefn [(with-async-handler [wrapper act]\n (catch act\n (\\e\n (case (fromException e)\n (Just UserInterrupt) (loop wrapper)\n (Just ThreadKilled) (return ())\n _ (liftIO (throwIO e))))))\n (:: throw-async-io (-> AsyncException (Fnk a)))\n (throw-async-io (. liftIO throwIO))\n (withErrorHandler [act]\n (catch act\n (\\e\n (cond\n [(<- (Just se) (fromException e))\n (fmap Left (make-src-err-message se))]\n [(<- (Just ae) (fromException e))\n (throw-async-io ae)]\n [(<- (Just fe) (fromException e))\n (fmap Left (make-finkel-exception-message fe))]\n [otherwise\n ($ pure Left show e)]))))\n (eval-one [wrapper]\n (do (<- (Input itype form out-mv) (liftIO (takeMVar in-mvar)))\n (<- ret (withErrorHandler\n (do (<- expanded (expands [form]))\n (<- dflags getDynFlags)\n (eval-form hdl dflags wrapper itype expanded))))\n (liftIO (putMVar out-mv ret))))\n (loop [wrapper]\n (with-async-handler wrapper\n (>> (eval-one wrapper)\n (loop wrapper))))]\n (>>= (init-eval-loop wrapper-args ghc-opts)\n (if once-only eval-one loop))))\n\n(defn (:: set-print-name (-> String (Fnk ())))\n \"Set the name of function used for printing values in interactive\ncontext.\"\n [name]\n (case-do (fmap toList (parseName name))\n (: f _) (modifySession\n (\\he (he {(= hsc-IC (setInteractivePrintName (hsc-IC he) f))})))\n _ (failFnk \"set-print-name: parse error\")))\n\n(defn (:: eval-form\n (-> Handle DynFlags ForeignHValue InSource [Code] (Fnk Result)))\n [hdl dflags wrapper itype forms]\n (| ((null forms)\n (return (Right \"\")))\n ((<- (Right stmt) (evalBuilder dflags True parseStmt forms))\n (eval-statement hdl wrapper itype stmt))\n ((<- (Right decls) (evalBuilder dflags True parseTopDecls forms))\n (eval-decls decls))\n (otherwise\n (case (evalBuilder dflags True parseImports forms)\n (Right idecl) (eval-imports dflags idecl)\n (Left se) (finkelSrcError (syntaxErrCode se) (syntaxErrMsg se))))))\n\n(defn (:: eval-statement\n (-> Handle ForeignHValue InSource HStmt (Fnk Result)))\n [hdl wrapper itype stmt]\n (lept [wrap (case itype\n Prompt (fmap (\\r (, r \"\")))\n Connection (with-io-redirect hdl))\n err (. pure Left (++ \"*** Exception: \") show)\n ok (. pure Right)\n opts (execOptions {(= execWrap\n (\\fhv (EvalApp (EvalThis wrapper)\n (EvalThis fhv))))})]\n (case-do (wrap (execStmt' stmt \"stmt-text\" opts))\n (, (ExecComplete (Right _ns) _) r) (ok r)\n (, (ExecComplete (Left e) _) _r) (err e)\n (, (ExecBreak {}) r) (pure (Left (++ \"break: \" r))))))\n\n(defn (:: eval-imports (-> DynFlags [HImportDecl] (Fnk Result)))\n [dflags imports]\n (lefn [(mkIIDecl [(L _ idecl)]\n (IIDecl idecl))\n (imps (map (. (showSDoc dflags) ppr) imports))\n (mdls (++ \"; \" (intercalate \", \" imps)))\n (add-imports [ctx]\n (foldr (\\mdl (add-gt-ii (mkIIDecl mdl))) ctx imports))]\n (do (<- ctx0 getContext)\n (setContext (add-imports ctx0))\n (return (Right mdls)))))\n\n(defn (:: eval-decls (-> [HDecl] (Fnk Result)))\n [decls]\n (do (<- hsc-env getSession)\n (lefn [(decls' (cvTopDecls (toOL decls)))\n (dflags (hsc-dflags hsc-env))\n (pr [tt]\n (case tt\n (AnId var) (var-name-and-type dflags (getName var) var)\n _ (++ \"; \" (showSDoc dflags (ppr tt)))))\n (show-tything [tt acc]\n (lefn [(nstr (showSDoc dflags (ppr (getName tt))))]\n (if (== \"$trModule\" nstr)\n acc\n (: (pr tt) acc))))\n (tystr [tt]\n (intercalate \"\\n\" (foldr show-tything [] tt)))])\n\n ;; In \"ghc/GHCi/UI.hs\", the `runStmt' function is wrapping declarations\n ;; with `let' expression and passing to `execStmt'' as a work around for\n ;; supporting top level declaration. However, this approach seems like\n ;; not working well when multiple declarations were entered at once.\n ;;\n ;; In finkel REPL, instead of wrapping with `let', always using\n ;; `HscInterpreted' as target when evaluating declarations, to support\n ;; declaring functions and values when the REPL is using `-fobject-code'.\n (<- (, tythings ic)\n (withTmpDynFlags (useInterpreter dflags) (evalDecls decls')))\n\n (setSession (hsc-env {(= hsc-IC ic)}))\n (return (Right (tystr tythings)))))\n\n\f\n;;; Auxiliary\n\n(defn (:: guessFnkTarget (-> HscEnv (Located String) Target))\n \"Simple function to do similar work done in `GHC.guessTarget', to support\nsource code file paths with @.fnk@ extension.\"\n [_hsc_env lsrc]\n (lept [src (unLoc lsrc)\n tid (if (looksLikeModuleName src)\n (TargetModule (mkModuleName src))\n (TargetFile src Nothing))]\n (cond-expand\n [(<= 904 :ghc)\n (Target tid True (hscActiveUnitId _hsc_env) Nothing)]\n [otherwise\n (Target tid True Nothing)])))\n\n(defn (:: partition-args\n (-> [(Located String)] (, [(Located String)] [(Located String)])))\n \"Simplified version of the function with same name defined in @ghc/Main.hs@,\nto separate object files from source code files.\"\n (lefn [(f [(L l arg) (, srcs objs)]\n (if (|| (isFnkFile arg)\n (isHsFile arg)\n (looksLikeModuleName arg))\n (, (: (L l arg) srcs) objs)\n (, srcs (: (L l arg) objs))))]\n (foldr f (, [] []))))\n\n(defn (:: make-src-err-message (-> SourceError (Fnk String)))\n [src-err]\n (lept [emsgs (srcErrorMessages src-err)\n sdoc (vcat (ppr-wrapped-msg-bag-with-loc emsgs))]\n (do (<- dflags getDynFlags)\n (<- unqual get-name-ppr-ctx)\n (return (render-with-err-style dflags unqual sdoc)))))\n\n(defn (:: make-finkel-exception-message (-> FinkelException (Fnk String)))\n [fe]\n (lept [msg (displayException fe)]\n (do (<- dflags getDynFlags)\n (<- unqual get-name-ppr-ctx)\n (lefn [(lmsg [l]\n (lept [wmsg (mkWrappedMsg dflags l unqual (text msg))\n emsgs (cond-expand\n [(<= 904 :ghc) (mkMessages (unitBag wmsg))]\n [otherwise (unitBag wmsg)])\n sdoc (vcat (ppr-wrapped-msg-bag-with-loc emsgs))]\n (render-with-err-style dflags unqual sdoc)))])\n (case (finkelExceptionLoc fe)\n (Just l) ($ pure lmsg l)\n _ (pure msg)))))\n\n(defn (:: make-eval-wrapper (-> [String] (Fnk ForeignHValue)))\n [args]\n (lept [form `(\\m (do (<- r (System.Environment.withArgs ,args m))\n (System.IO.hFlush System.IO.stdout)\n (System.IO.hFlush System.IO.stderr)\n (Control.Monad.return r)))\n no-rb-hsc (\\hsc-env\n (hsc-env {(= hsc-dflags (xopt-unset (hsc-dflags hsc-env)\n RebindableSyntax))}))]\n (do (<- dflags getDynFlags)\n (case (evalBuilder dflags True parseExpr [form])\n (Right expr) (withTempSession no-rb-hsc\n (compileParsedExprRemote expr))\n (Left err) (finkelSrcError (syntaxErrCode err)\n (syntaxErrMsg err))))))\n\n(defn (:: var-name-and-type (-> DynFlags Name Var String))\n [dflags name var]\n (lept [nstr (occNameString (nameOccName name))\n typ (showPpr dflags (varType var))]\n (if (== nstr \"it\")\n \"\"\n (intercalate \"\\n\"\n (map (++ \"; \")\n (lines (++ nstr (++ \" :: \" typ))))))))\n\n(defn (:: add-gt-ii\n (-> InteractiveImport [InteractiveImport] [InteractiveImport]))\n [mdl acc]\n (if (any (subsume-ii mdl) acc)\n acc\n (: mdl acc)))\n\n(defn (:: subsume-ii (-> InteractiveImport InteractiveImport Bool))\n ;; See `GHCi.UI.iiSubsumes'.\n [(IIModule x) (IIModule y)] (== x y)\n [(IIDecl x) (IIDecl y)]\n (where (&& (== (unLoc (ideclName x)) (unLoc (ideclName y)))\n (== (ideclAs x) (ideclAs y))\n (|| (not (isImportDeclQualified (ideclQualified x)))\n (isImportDeclQualified (ideclQualified y)))\n (cond-expand\n [(<= 906 :ghc)\n (hiding-subsumes (ideclImportList x) (ideclImportList y))]\n [otherwise\n (hiding-subsumes (ideclHiding x) (ideclHiding y))]))\n (cond-expand\n [(<= 906 :ghc)\n (defn hiding-subsumes\n [_ (Just (, Exactly (L _ [])))] True\n [(Just (, Exactly (L _ xs))) (Just (, Exactly (L _ ys)))]\n (all (flip elem xs) ys)\n [a b] (== a b))]\n [otherwise\n (defn hiding-subsumes\n [_ (Just (, False (L _ [])))] True\n [(Just (, False (L _ xs))) (Just (, False (L _ ys)))]\n (all (flip elem xs) ys)\n [a b] (== a b))]))\n\n [_ _] False)\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/Exception.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule Finkel.Tool.Internal.Exception\n (export\n (FinkelToolException ..)\n finkel-tool-exception-handler)\n (import\n ;; base\n (Control.Exception [(Exception ..) handle])\n (System.Environment [getProgName])\n (System.Exit [exitFailure])\n (System.IO [hPutStrLn stderr])\n (System.IO.Unsafe [unsafePerformIO])))\n\n(data FinkelToolException\n (:doc \"Error with command line arguments.\")\n (ArgumentErrors String ; Name of the command.\n [String] ; Error messages.\n %_end)\n\n (:doc \"No input given for eval command.\")\n NoEvalInput\n\n (:doc \"Generic exception for finkel-tool package.\")\n (FinkelToolException String)\n (deriving Eq Show))\n\n(instance (Exception FinkelToolException)\n (defn displayException\n [(ArgumentErrors cmd msgs)] (++ (unlines msgs) (brief-usage cmd))\n [NoEvalInput] (++ \"eval: No input given.\\n\" (brief-usage \"eval\"))\n [(FinkelToolException msg)] msg))\n\n(defn (:: brief-usage (-> String String))\n [cmd]\n (++ \"Try `\" (unsafePerformIO getProgName) \" help \" cmd \"' for usage.\"))\n\n(defn (:: finkel-tool-exception-handler (-> (IO a) (IO a)))\n (lefn [(:: handler (-> FinkelToolException (IO a)))\n (handler [e]\n (do ($ (hPutStrLn stderr) displayException e)\n exitFailure))]\n (handle handler)))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/IO.hs", "content": ";;; -*- mode: finkel -*-\n;;;; IO related function for REPL\n\n(defmodule Finkel.Tool.Internal.IO\n (export\n read-form\n read-print-loop\n with-io-redirect)\n (require\n ;; finkel-core\n (Finkel.Tool.Internal.Macro.Ghc))\n (import\n ;; base\n (Control.Concurrent\n [MVar ThreadId killThread newEmptyMVar putMVar takeMVar throwTo])\n (Control.Exception [(AsyncException ..) catch throwIO])\n (Control.Monad.Catch [(MonadMask ..) bracket])\n (Control.Monad [when])\n (Control.Monad.IO.Class [(MonadIO ..)])\n (Data.List [intercalate isPrefixOf isSubsequenceOf])\n (GHC.IO.Handle [hDuplicate hDuplicateTo])\n (System.IO\n [Handle (SeekMode ..) hClose hFlush hGetLine hSeek hSetFileSize stdout])\n (System.IO.Error [isEOFError])\n\n ;; deepseq\n (Control.DeepSeq)\n\n ;; finkel-kernel\n (Language.Finkel)\n (Language.Finkel.Lexer [evalSP])\n (Language.Finkel.Reader [sexpr])\n\n ;; finkel-core\n (Finkel.Core.Functions [make-symbol])\n\n ;; Internal\n (Finkel.Tool.Internal.CLI)\n (Finkel.Tool.Internal.Types)))\n\n(imports-from-ghc\n (GHC.Data.StringBuffer [appendStringBuffers stringToStringBuffer]))\n\n\n;;; Read and print loop\n\n(defn (:: read-print-loop\n (=> (MonadIO cl) (CLI cl) (HasReplState cl)\n (-> Code (MVar Input) ThreadId (cl ()))))\n \"Loop for reading input and printing the output.\n\nTracks the state of intermediate S-expression from input, and continue\nreading the input until successful parse result.\"\n [init-form to-mvar eval-tid]\n (lefn [(go [result-mv]\n (do (<- st0 getReplState)\n (lefn [(prompt\n (if (null (pending-input st0)) (prompt-string st0) \"\"))\n (reset-pending [st]\n (st {(= pending-input Nothing)}))])\n (<- mb-input\n ;; Handle interrupt signals thrown while waiting for input, to\n ;; handle `Ctrl-C' key presses without valid evaluation form,\n ;; and to refresh intermediate user inputs in Repl state.\n (handleInterrupt (do (putReplState (reset-pending st0))\n (return (Just [])))\n (withInterrupt (getString prompt))))\n (maybe quit (go1 st0 result-mv) mb-input)))\n (go1 [st0 result-mv line]\n (case line\n (: h tl) (| ((== line \"(quit)\")\n quit)\n ((null (pending-input st0))\n (== #', h)\n (if (isSubsequenceOf tl \"quit\")\n quit\n (go-command result-mv tl)))\n (otherwise\n (go-line result-mv line)))\n [] (go result-mv)))\n (go-command [result-mv lin]\n ;; Using raw symbol for non-mangled REPL commands, to skip replacing\n ;; hyphens to underscores. Otherwise, command arguments like\n ;; \"ghc-boot\" will be replaced to \"ghc_boot\" by the parser.\n (if (mangled-command lin)\n (go-line result-mv (concat [\"(repl-macro \" lin \")\"]))\n (go-form result-mv (as-repl-macro lin))))\n (go-line [result-mv line]\n (do (<- mb-form (read-form line))\n (maybe (go result-mv) (go-form result-mv) mb-form)))\n (go-form [result-mv form]\n ;; Handle interrupt signals thrown while evaluation thread is\n ;; working. Give a chance to interrupt here, after parsing input and\n ;; before printing outputs.\n (do (handleInterrupt\n (do (liftIO (throwTo eval-tid UserInterrupt))\n (print-io result-mv))\n (withInterrupt\n (do (liftIO (putMVar to-mvar (Input Prompt form result-mv)))\n (print-io result-mv))))\n (go result-mv)))\n (quit\n ($ liftIO killThread eval-tid))]\n\n ;; Print the result from boot expression, then start the loop.\n (do (<- result-mv (liftIO newEmptyMVar))\n (liftIO (putMVar to-mvar (Input Prompt init-form result-mv)))\n (print-io result-mv)\n (go result-mv))))\n\n(defn (:: print-io (=> (MonadIO m) (CLI m)\n (-> (MVar Result) (m ()))))\n [result-mv]\n (lefn [(pr [str]\n (when (not (null str))\n (>> (putString str) (liftIO (hFlush stdout)))))]\n (case-do (liftIO (takeMVar result-mv))\n (Right str) (pr str)\n (Left str) (pr str))))\n\n(defn (:: read-form (=> (HasReplState repl) (MonadIO repl)\n (-> String (repl (Maybe Code)))))\n \"Read single S-expression form.\"\n [input0]\n (do (<- st getReplState)\n (lefn [(input1 (stringToStringBuffer (: #'\\n input0)))\n (put-and-return [pending ret]\n (do (putReplState (st {(= pending-input pending)}))\n (return ret)))])\n (<- input2\n (liftIO (maybe (pure input1)\n (flip appendStringBuffers input1)\n (pending-input st))))\n (case (evalSP sexpr (Just \"\") input2)\n (Right forms) (put-and-return Nothing (Just forms))\n (Left _err) (put-and-return (Just input2) Nothing))))\n\n;;; IO redirect\n\n(defn (:: with-io-redirect\n (=> (MonadIO m) (MonadMask m)\n (-> Handle (m a) (m (, a String)))))\n \"Execute given action with redirecting stdout to given 'Handle'.\"\n [hdl action]\n (bracket\n (liftIO (do (<- stdout2 (hDuplicate stdout))\n (hSetFileSize hdl 0)\n (hSeek hdl AbsoluteSeek 0)\n (hDuplicateTo hdl stdout)\n (return stdout2)))\n (\\stdout2\n (liftIO (do (hDuplicateTo stdout2 stdout)\n (hClose stdout2))))\n (\\_stdout2\n (do (<- x action)\n (liftIO (do (hFlush stdout)\n (hSeek hdl AbsoluteSeek 0)\n (<- ls (get-lines hdl))\n (lept [contents (intercalate \"\\n\" ls)])\n (deepseq contents (return (, x contents)))))))))\n\n(defn (:: get-lines (-> Handle (IO [String])))\n (lefn [(go [acc hdl]\n (catch (do (<- l (hGetLine hdl))\n (go (: l acc) hdl))\n (\\e\n (if (isEOFError e)\n (return (reverse acc))\n (throwIO e)))))]\n (go [])))\n\n\n;;; Auxiliary\n\n(defn (:: mangled-command (-> String Bool))\n [lin]\n (lept [commands [\"expand\" \"expand!\" \"info\" \"kind\" \"load\" \"type\"]]\n (case (words lin)\n (: w _) (any (isPrefixOf w) commands)\n _ False)))\n\n(defn (:: as-repl-macro (-> String Code))\n [str]\n `(repl-macro ,@(map make-symbol (words str))))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/Listen.hs", "content": ";;; -*- mode: finkel -*-\n;;; Loop for network connection.\n\n(defmodule Finkel.Tool.Internal.Listen\n (export listener accept-loop run-conn)\n (require\n ;; finkel-core\n (Finkel.Tool.Internal.Macro.Ghc))\n (import\n ;; base\n (Control.Concurrent [(MVar) forkIO newEmptyMVar putMVar takeMVar])\n (Control.Exception [(Exception ..) (SomeException ..) handle])\n (Control.Monad [void unless when])\n (Data.Char [isSpace])\n (System.IO\n [(BufferMode ..) (IOMode ..) hClose hFlush hPutStr hSetBuffering\n hSetEncoding utf8])\n\n ;; bytestring\n (Data.ByteString.Internal [toForeignPtr])\n (qualified Data.ByteString.Char8 as BS)\n\n ;; network\n (Network.Socket\n [(AddrInfo ..) (AddrInfoFlag ..) PortNumber Socket (SocketOption ..)\n (SocketType ..) accept bind defaultHints getAddrInfo listen socket\n socketToHandle setSocketOption withSocketsDo])\n\n ;; finkel-kernel\n (Language.Finkel.Lexer [evalSP])\n (Language.Finkel.Reader [sexpr])\n\n ;; internal\n (Finkel.Tool.Internal.Types)))\n\n(imports-from-ghc\n (GHC.Data.StringBuffer [(StringBuffer ..)]))\n\n(defn (:: listener (-> PortNumber (MVar Input) (IO ())))\n [pnum mvar]\n (withSocketsDo\n (lefn [(hints (defaultHints {(= addrFlags [AI_PASSIVE])\n (= addrSocketType Stream)}))\n (start-loop [addr]\n (do (<- sock (socket (addrFamily addr)\n (addrSocketType addr)\n (addrProtocol addr)))\n (setSocketOption sock ReuseAddr 1)\n (bind sock (addrAddress addr))\n (listen sock 2)\n (accept-loop sock mvar)))]\n (case-do (getAddrInfo (Just hints) Nothing (Just (show pnum)))\n (: addr _) (start-loop addr)\n _ (putStrLn \"listener: unable to open address.\")))))\n\n(defn (:: accept-loop (-> Socket (MVar Input) (IO ())))\n [sock mvar]\n (do (<- (, conn _) (accept sock))\n (<- _ (forkIO (run-conn conn mvar)))\n (accept-loop sock mvar)))\n\n(defn (:: run-conn (-> Socket (MVar Input) (IO ())))\n [sock mvar]\n (do (<- hdl (socketToHandle sock ReadWriteMode))\n (hSetBuffering hdl (BlockBuffering Nothing))\n (hSetEncoding hdl utf8)\n (hPutStr hdl \"Connected to Finkel REPL.\")\n (hFlush hdl)\n (<- my-mvar newEmptyMVar)\n (lefn [(handler [(SomeException e)]\n (do (putStrLn (++ \"run-conn: \" (show e)))\n (hClose hdl)))\n (put-input [form]\n (putMVar mvar (Input Connection form my-mvar)))\n (read-loop\n ;; `BS.hGetSome' returns empty contents when the handle is closed.\n ;; Also, empty lines could be sent as input, evaluating the form\n ;; only when it contained non-space characters.\n (do (<- bs (BS.hGetSome hdl 65535))\n (unless (BS.null bs)\n (do (when (BS.any (. not isSpace) bs)\n (lept [(, fp o l) (toForeignPtr bs)\n sbuf (StringBuffer fp l o)]\n (case (evalSP sexpr (Just \"\") sbuf)\n (Right form) (put-input form)\n (Left err) (putStrLn (displayException err)))))\n read-loop))))\n (print-loop\n (do (<- result (takeMVar my-mvar))\n (case result\n (Right r) (hPutStr hdl r)\n (Left err) (hPutStr hdl err))\n (hFlush hdl)\n print-loop))])\n (void (forkIO print-loop))\n (handle handler read-loop)))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/Loop.hs", "content": ";;; -*- mode: finkel -*-\n;;; Starting REPL\n\n(defmodule Finkel.Tool.Internal.Loop\n (export start-repl acquire-repl cleanup-repl)\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Concurrent [ThreadId forkIO])\n (Control.Concurrent.MVar [MVar newEmptyMVar])\n (Control.Exception [bracket catch throwIO])\n (System.IO [Handle hClose openTempFile])\n (System.IO.Error [isDoesNotExistError])\n\n ;; directory\n (System.Directory [getTemporaryDirectory removeFile])\n\n ;; haskeline\n (System.Console.Haskeline\n [defaultBehavior defaultSettings useFile runInputTBehavior])\n\n ;; finkel-kernel\n (Language.Finkel.Form [Code])\n (Language.Finkel.Fnk [(FnkEnv ..)])\n\n ;; internal\n (Finkel.Tool.Internal.Eval)\n (Finkel.Tool.Internal.Listen)\n (Finkel.Tool.Internal.IO)\n (Finkel.Tool.Internal.Types)))\n\n;;; Extra imports\n\n(cond-expand\n [(== :os \"mingw32\")\n (import System.IO (hSetEncoding stdin utf8))]\n [otherwise\n (:begin)])\n\n\f\n;;; Starting the REPL\n\n(defn (:: start-repl\n (-> [String]\n (Maybe FilePath)\n (Maybe Int)\n FnkEnv\n ReplState\n Code\n (IO ())))\n \"Start REPL, maybe listen to given port number when given.\"\n [ghc-opts mb-path mb-port fnk-env repl-st init-form]\n (bracket acquire-repl cleanup-repl\n (use-repl ghc-opts mb-path mb-port fnk-env repl-st init-form)))\n\n(defn (:: acquire-repl (IO (, FilePath Handle (MVar Input))))\n \"Return a file path and handle for temporary use.\"\n (do (<- dir getTemporaryDirectory)\n (<- (, path hdl) (openTempFile dir \"finkel-repl-.out\"))\n (<- mvar newEmptyMVar)\n (return (, path hdl mvar))))\n\n(defn (:: cleanup-repl (-> (, FilePath Handle a) (IO ())))\n \"Clean up temporary file.\"\n [(, path hdl _)]\n (catch (do (hClose hdl)\n (removeFile path))\n (\\e\n (if (isDoesNotExistError e)\n (return ())\n (throwIO e)))))\n\n(defn (:: use-repl (-> [String]\n (Maybe FilePath)\n (Maybe Int)\n FnkEnv\n ReplState\n Code\n (, a Handle (MVar Input))\n (IO ())))\n \"Inner work for `start-repl'.\"\n [ghc-opts mb-path mb-port fnk-env repl-st init-form (, _ hdl in-mv)]\n (do (mapM- (start-listener in-mv) mb-port)\n (<- tid (fork-eval-loop ghc-opts hdl in-mv fnk-env))\n (lept [rpl (read-print-loop init-form in-mv tid)\n behavior (maybe defaultBehavior useFile mb-path)\n run (runInputTBehavior behavior defaultSettings)])\n\n ;; Using UTF-8 for Windows. See \"GHCi.UI.interactiveUI\"\n (cond-expand\n [(== :os \"mingw32\")\n (hSetEncoding stdin utf8)]\n [otherwise\n (return ())])\n\n (run-repl (run rpl) repl-st)))\n\n(defn (:: start-listener (-> (MVar Input) Int (IO ThreadId)))\n \"Start listner in separate thread, and return temporary file for\ngetting String output from statement.\"\n [in-mv port]\n (do (putStrLn (++ \"Listening on port \" (show port)))\n (forkIO (listener (fromIntegral port) in-mv))))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/Macro/Ghc.hs", "content": ";;; -*- mode: finkel -*-\n;;; Module containing ghc version compatibililty macro.\n\n(defmodule Finkel.Tool.Internal.Macro.Ghc\n (export imports-from-ghc)\n (import\n ;; base\n (Control.Exception [throw])\n\n ;; finkel-core\n (Finkel.Prelude)\n (Finkel.Core.Internal [__glasgow_haskell__])))\n\n;;; Module name aliases\n\n(data GhcModuleName\n (Pre902 Code Code)\n (Pre900 Code))\n\n(defn (:: hscTypes GhcModuleName)\n (Pre902 'GHC.Driver.Types 'HscTypes))\n\n(defn (:: basicTypes GhcModuleName)\n (Pre902 'GHC.Types.Basic 'BasicTypes))\n\n(defn (:: ghc-module-name-aliases [(, Code GhcModuleName)])\n \"List of `Code' and `GhcModuleName' pairs, to relate module names in latest ghc\nwith module names in older versions.\"\n [(, 'GHC (Pre900 'GHC))\n\n (, 'GHC.Core.FamInstEnv (Pre900 'FamInstEnv))\n (, 'GHC.Core.InstEnv (Pre900 'InstEnv))\n (, 'GHC.Core.TyCo.Rep (Pre900 'TyCoRep))\n\n (, 'GHC.Data.Bag (Pre900 'Bag))\n (, 'GHC.Data.FastString (Pre900 'FastString))\n (, 'GHC.Data.OrdList (Pre900 'OrdList))\n (, 'GHC.Data.StringBuffer (Pre900 'StringBuffer))\n\n (, 'GHC.Driver.CmdLine (Pre900 'CmdLineParser))\n (, 'GHC.Driver.Main (Pre900 'HscMain))\n (, 'GHC.Driver.Make (Pre900 'GhcMake))\n (, 'GHC.Driver.Monad (Pre900 'GhcMonad))\n (, 'GHC.Driver.Ppr (Pre902 'GHC.Utils.Outputable 'Outputable))\n (, 'GHC.Driver.Session (Pre900 'DynFlags))\n (, 'GHC.Driver.Env hscTypes)\n (, 'GHC.Driver.Errors hscTypes)\n\n (, 'GHC.Iface.Syntax (Pre900 'IfaceSyn))\n\n (, 'GHC.Parser (Pre900 'Parser))\n (, 'GHC.Parser.Lexer (Pre900 'Lexer))\n (, 'GHC.Parser.PostProcess (Pre900 'RdrHsSyn))\n\n (, 'GHC.Runtime.Context hscTypes)\n (, 'GHC.Runtime.Debugger (Pre900 'Debugger))\n (, 'GHC.Runtime.Eval (Pre900 'InteractiveEval))\n (, 'GHC.Runtime.Interpreter (Pre900 'GHCi))\n (, 'GHC.Runtime.Linker (Pre900 'Linker))\n\n (, 'GHC.Settings.Config (Pre900 'Config))\n\n (, 'GHC.Types.Basic (Pre900 'BasicTypes))\n (, 'GHC.Types.Fixity basicTypes)\n (, 'GHC.Types.Fixity.Env hscTypes)\n (, 'GHC.Types.Name (Pre900 'Name))\n (, 'GHC.Types.Name.Set (Pre900 'NameSet))\n (, 'GHC.Types.SrcLoc (Pre900 'SrcLoc))\n (, 'GHC.Types.SourceError hscTypes)\n (, 'GHC.Types.SourceText basicTypes)\n (, 'GHC.Types.Target hscTypes)\n (, 'GHC.Types.TyThing hscTypes)\n (, 'GHC.Types.TyThing.Ppr (Pre902 'GHC.Core.Ppr.TyThing 'PprTyThing))\n (, 'GHC.Types.Var (Pre900 'Var))\n\n (, 'GHC.Unit.Finder (Pre902 'GHC.Driver.Finder 'Finder))\n (, 'GHC.Unit.Module (Pre900 'Module))\n (, 'GHC.Unit.Module.Graph hscTypes)\n (, 'GHC.Unit.Module.ModSummary hscTypes)\n (, 'GHC.Unit.Home.ModInfo hscTypes)\n\n (, 'GHC.Utils.Error (Pre900 'ErrUtils))\n (, 'GHC.Utils.IO.Unsafe (Pre900 'FastFunctions))\n (, 'GHC.Utils.Lexeme (Pre900 'Lexeme))\n (, 'GHC.Utils.Misc (Pre900 'Util))\n (, 'GHC.Utils.Outputable (Pre900 'Outputable))])\n\n;;; Auxiliary functions\n\n(defn (:: rename-ghc-module (-> Code Code))\n [name]\n (lefn [(legacy [m1 m2]\n (if (<= 900 __glasgow_haskell__) m1 m2))\n (reloc (flip asLocOf name))\n (msg (++ \"Could not find module ‘\" (show name) \"’\"))]\n (case (lookup name ghc-module-name-aliases)\n _ (| ((<= 902 __glasgow_haskell__) name))\n (Just (Pre902 m900 m8xx)) (legacy (reloc m900) (reloc m8xx))\n (Just (Pre900 m8xx)) (legacy name (reloc m8xx))\n _ (throw (FinkelSrcError name msg)))))\n\n(defn (:: make-import (-> Code Code))\n [form]\n `(import ,(rename-ghc-module (car form)) ,(curve (cadr form))))\n\n;;; Exported macro\n\n(defmacro imports-from-ghc\n \"Macro for version compatible import declaration for @ghc@.\n\nExpects module names in latest released @ghc@, returns old module name as\nnecessary. Takes multiple modules in single form.\n\nThis macro is for internal use. The covered modules are used by @finkel-core@\nand @finkel-tool@ packages.\"\n form\n `(:begin\n ,@(map1 make-import form)))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/Macro/Repl.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Macros used in REPL.\n\n;;; This module contains macros accessible only from REPL. Main purpose\n;;; of using macros for REPL is to access runtime value of\n;;; `FnkEnv'. Macro body can contain codes accessing `FnkEnv', and then\n;;; the code could be invoked from REPL via evaluating the typed in\n;;; forms.\n\n(defmodule Finkel.Tool.Internal.Macro.Repl\n (export repl-macro compile-and-import)\n (require\n ;; Internal\n (Finkel.Tool.Internal.Macro.Ghc))\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Prelude hiding [<>])\n (Control.Exception [(Exception ..) (SomeException ..) try])\n (Control.Monad [filterM unless void when])\n (Control.Monad.IO.Class [(MonadIO ..)])\n (Data.Foldable [toList])\n (Data.Function [on])\n (Data.List [find intercalate intersperse isPrefixOf partition sortBy])\n (Data.Maybe [catMaybes])\n (System.Console.GetOpt [(ArgOrder ..) getOpt])\n (Text.Printf [printf])\n (Text.Read [readMaybe])\n\n ;; directory\n (System.Directory\n [getCurrentDirectory getHomeDirectory setCurrentDirectory])\n\n ;; filepath\n (System.FilePath [normalise])\n\n ;; exceptions\n (Control.Monad.Catch [catch bracket])\n\n ;; process\n (System.Process [callProcess])\n\n ;; finkel-kernel\n (Language.Finkel)\n (Language.Finkel.Eval [evalExprType evalTypeKind])\n (Language.Finkel.Form [mkLocatedForm])\n (Language.Finkel.Make [buildHsSyn discardInteractiveContext simpleMake\n clearExpandedCodeCache])\n (Language.Finkel.Fnk [(FnkEnv ..) getFnkEnv macroNames modifyFnkEnv putFnkEnv\n setDynFlags setFnkVerbosity updateDynFlags])\n (Language.Finkel.Options [fnkEnvOptions partitionFnkEnvOptions])\n (Language.Finkel.Syntax [parseExpr parseType])\n (Language.Finkel.Make [asModuleName])\n\n ;; finkel-core\n (Finkel.Core.Functions)\n\n ;; Internal\n (Finkel.Tool.Internal.Compat)))\n\n;;; ghc\n\n(imports-from-ghc\n (GHC\n [(ModuleInfo) findModule getBindings getModSummary getModuleGraph\n getModuleInfo getTargets isLoaded lookupName lookupModule modInfoExports\n setSessionDynFlags setTargets workingDirectoryChanged])\n\n (GHC.Core.FamInstEnv [FamInst pprFamInst])\n (GHC.Core.InstEnv [ClsInst pprInstance])\n\n (GHC.Data.FastString [FastString fsLit unpackFS])\n\n (GHC.Driver.Env [(HscEnv ..)])\n (GHC.Driver.Make [(LoadHowMuch ..)])\n (GHC.Driver.Monad [(GhcMonad ..) getSessionDynFlags withTempSession])\n (GHC.Driver.Ppr [showSDoc showSDocForUser showPpr])\n (GHC.Driver.Session\n [(DynFlags ..) (GhcMode ..) (HasDynFlags ..) (Language ..)\n (PackageFlag ..) (GeneralFlag ..) defaultDynFlags\n fFlags flagSpecFlag flagSpecName gopt lang_set\n parseDynamicFlagsCmdLine settings xFlags xopt wopt wWarningFlags])\n\n (GHC.Iface.Syntax [showToHeader])\n\n (GHC.Runtime.Context [(InteractiveImport ..)])\n (GHC.Runtime.Debugger [pprTypeAndContents])\n (GHC.Runtime.Eval\n [abandonAll getContext getInfo moduleIsInterpreted parseName setContext\n showModule])\n\n (GHC.Types.Basic [(SuccessFlag ..)])\n (GHC.Types.Fixity [Fixity defaultFixity])\n (GHC.Types.Name\n [Name getName nameModule nameOccName nameSrcSpan pprInfixName])\n (GHC.Types.Name.Set [elemNameSet mkNameSet])\n (GHC.Types.SourceError [srcErrorMessages])\n (GHC.Types.SrcLoc [getLoc isGoodSrcSpan mkGeneralLocated unLoc])\n (GHC.Types.Target [(Target ..) (TargetId ..) pprTarget])\n (GHC.Types.TyThing [(TyThing ..) tyThingParent_maybe])\n (GHC.Types.TyThing.Ppr [pprTyThing pprTyThingInContextLoc])\n\n (GHC.Unit.Finder (flushFinderCaches uncacheModule))\n (GHC.Unit.Home.ModInfo [pprHPT])\n (GHC.Unit.Module [ModuleName mkModuleName mkModuleNameFS moduleNameString])\n (GHC.Unit.Module.Graph [mgModSummaries])\n (GHC.Unit.Module.ModSummary [(ModSummary ..) ms-mod-name])\n\n (GHC.Utils.Misc [looksLikeModuleName])\n (GHC.Utils.Outputable\n [SDoc $$ <+> <> empty dcolon hsep nest ppr sep text vcat]))\n\n\n;;; Extra imports\n\n(import GHC.Hs.ImpExp ((ImportDecl ..) simpleImportDecl))\n\n(cond-expand\n [(<= 904 :ghc)\n (:begin\n (import qualified GHC)\n (import GHC.Core.TyCo.Ppr (pprSigmaType))\n (import GHC.Driver.Env (hsc-HPT hsc-home-unit hscActiveUnitId))\n (import GHC.Driver.Make ((ModIfaceCache ..))))]\n [otherwise\n (imports-from-ghc\n (GHC (Type))\n (GHC.Types.SourceText [(StringLiteral ..)])\n (GHC.Types.TyThing.Ppr [pprTypeForUser]))])\n\n(cond-expand\n [(<= 906 :ghc)\n (import GHC.Driver.Backend (backendCanReuseLoadedCode))]\n [(<= 902 :ghc)\n (import GHC.Driver.Backend (backendProducesObject))]\n [otherwise\n (imports-from-ghc\n (GHC.Driver.Session [isObjectTarget]))])\n\n(cond-expand\n [(<= 902 :ghc)\n (:begin\n (import GHC.Driver.Env (hsc-units))\n (import GHC.Linker.Loader (initLoaderState showLoaderState)))]\n [otherwise\n (imports-from-ghc\n (GHC.Runtime.Linker [initDynLinker showLinkerState]))])\n\n(cond-expand\n [(<= 902 :ghc)\n (import GHC.Runtime.Interpreter ((Message ..) interpCmd))]\n [otherwise\n (imports-from-ghc\n (GHC.Runtime.Interpreter [(Message ..) iservCmd]))])\n\n(cond-expand\n [(<= 900 :ghc)\n (:begin\n (import GHC.Types.SrcLoc (leftmost-smallest))\n (import GHC.Unit.Module ((Module) moduleName))\n (import qualified GHC.Driver.Make as GhcMake))]\n [otherwise\n (:begin\n (imports-from-ghc\n (GHC.Unit.Module [(Module ..)]))\n (import qualified GhcMake))])\n\n\f\n;;; Types\n\n(type ReplAction (-> [Code] (Fnk Code)))\n\n(data ReplCmd\n (ReplCmd {(:: rc-name String)\n (:: rc-args [String])\n (:: rc-action ReplAction)\n (:: rc-help String)}))\n\n\f\n;;; Auxiliary functions\n\n(cond-expand\n [(<= 904 :ghc)\n (:begin)]\n [otherwise\n (defn (:: pprSigmaType (-> Type SDoc)) pprTypeForUser)])\n\n(defn (:: showUnitId (-> DynFlags String))\n [dflags]\n (cond-expand\n [(<= 902 :ghc)\n (showPpr dflags (homeUnitId_ dflags))]\n [(<= 900 :ghc)\n (showPpr dflags (homeUnitId dflags))]\n [otherwise\n (showPpr dflags (thisInstalledUnitId dflags))]))\n\n(defn (:: gen-default-dflags (-> DynFlags DynFlags))\n [flg]\n (cond-expand\n [(<= 906 :ghc)\n (defaultDynFlags (settings flg))]\n [otherwise\n (defaultDynFlags (settings flg) (llvmConfig flg))]))\n\n(defn (:: show-linker-state (-> HscEnv (IO ())))\n [hsc-env]\n (cond-expand\n [(<= 902 :ghc)\n (case (hsc-interp hsc-env)\n (Just interp) (do (<- sdoc (showLoaderState interp))\n (putStrLn (showPpr (hsc-dflags hsc-env) sdoc)))\n _ (pure ()))]\n [(<= 900 :ghc)\n (do (<- sdoc (showLinkerState (hsc-dynLinker hsc-env)))\n (putStrLn (showPpr (hsc-dflags hsc-env) sdoc)))]\n [otherwise\n (showLinkerState (hsc-dynLinker hsc-env) (hsc-dflags hsc-env))]))\n\n(defn (:: rts-revert-cafs (Fnk ()))\n (cond-expand\n [(<= 902 :ghc)\n (case-do (fmap hsc-interp getSession)\n (Just interp) (liftIO (interpCmd interp RtsRevertCAFs))\n _ (pure ()))]\n [otherwise\n (do (<- hsc-env getSession)\n (liftIO (iservCmd hsc-env RtsRevertCAFs)))]))\n\n(defn (:: is-interpreting (-> DynFlags Bool))\n (cond-expand\n [(<= 906 :ghc)\n (. backendCanReuseLoadedCode backend)]\n [(<= 902 :ghc)\n (. not backendProducesObject backend)]\n [otherwise\n (. not isObjectTarget hscTarget)]))\n\n(defn (:: mk-ii (-> ModuleName InteractiveImport))\n (. IIDecl simpleImportDecl))\n\n(defn (:: mk-ii-fs (-> FastString InteractiveImport))\n (. mk-ii mkModuleNameFS))\n\n(defn (:: mk-ii-str (-> String InteractiveImport))\n (. mk-ii-fs fsLit))\n\n(defn (:: code-to-mb-string (-> Code (Maybe String)))\n (. (fmap unpackFS) code-to-mb-fs))\n\n(defn (:: code-to-mb-fs (-> Code (Maybe FastString)))\n [code]\n (case (unCode code)\n (Atom (ASymbol s)) (Just s)\n (Atom (AString _ s)) (Just s)\n _ Nothing))\n\n(defn (:: located-list (-> [Code] Code))\n [xs]\n (case xs\n [] nil\n _ (LForm (L (getLoc (mkLocatedForm xs)) (List xs)))))\n\n(defn (:: show-sdoc-for-user-m (-> SDoc (Fnk String)))\n [sdoc]\n (do (<- hsc-env getSession)\n (<- unqual get-name-ppr-ctx)\n (lept [dflags (hsc-dflags hsc-env)\n str (cond-expand\n [(<= 902 :ghc)\n (showSDocForUser dflags (hsc-units hsc-env) unqual sdoc)]\n [otherwise\n (showSDocForUser dflags unqual sdoc)])])\n\n (pure str)))\n\n(defn (:: invalid-form (-> String [Code] (Fnk a)))\n [label forms]\n (lept [form (car (located-list forms))\n msg (concat [label \": invalid form `\" (show form) \"'\"])]\n (finkelSrcError form msg)))\n\n(defn (:: onTheREPL (-> a (Located a)))\n (mkGeneralLocated \"on the REPL\"))\n\n(defn (:: compile-module (-> [(Located String)] (Fnk SuccessFlag)))\n [lstrs]\n (where (bracket acquire cleanup work)\n (defn acquire\n (do (<- dflags getDynFlags)\n (<- fnk-env getFnkEnv)\n (return (, dflags fnk-env))))\n (defn cleanup [(, dflags fnk-env)]\n (do (setDynFlags dflags)\n (modifyFnkEnv (\\e (e {(= envQualifyQuotePrimitives\n (envQualifyQuotePrimitives fnk-env))})))))\n (defn work [(, dflags fnk-env)]\n (do (putFnkEnv (fnk-env {(= envQualifyQuotePrimitives False)}))\n (lept [force-recomp (gopt Opt-ForceRecomp dflags)])\n (<- success-flag\n (simpleMake (zip lstrs (repeat Nothing)) force-recomp Nothing))\n\n ;; As done in `GHCi.UI', reverting CAFs on load.\n rts-revert-cafs\n\n (return success-flag)))))\n\n(defn (:: compile-and-import (-> [(Located FilePath)] (Fnk SuccessFlag)))\n [lpaths]\n (do (<- fnk-env getFnkEnv)\n clearExpandedCodeCache\n (lefn [(imps0 (map mk-ii-str (envContextModules fnk-env)))\n (:: adjust-module (-> (Located String) (Fnk InteractiveImport)))\n (adjust-module [lpath]\n (lept [name1 (asModuleName (unLoc lpath))\n name2 (if (null name1) \"Main\" name1)\n name3 (mkModuleNameFS (fsLit name2))]\n (do (<- mdl (getModSummary name3))\n (<- is-interp (moduleIsInterpreted (ms-mod mdl)))\n (return (if is-interp\n (IIModule name3)\n (mk-ii name3))))))])\n\n ;; As done in ghci, adding `IIModule' if the module is interpreted as\n ;; bytecode, adding `IIDecl' otherwise. Safe Haskell setting in DynFlags\n ;; is ignored at the moment.\n (<- success-flag (compile-module lpaths))\n (case success-flag\n Succeeded (do (<- mdls (mapM adjust-module lpaths))\n (setContext (++ mdls imps0)))\n Failed (setContext imps0))\n (return success-flag)))\n\n(defn (:: adjust-current-target\n (-> FilePath [InteractiveImport] (Fnk [InteractiveImport])))\n \"Adjust current IIModule target to IIDecl if current HscTarget is\nobject code.\"\n [path imports]\n (do (<- dflags getDynFlags)\n (lefn [(current-module-name\n (mkModuleName (asModuleName path)))\n (iimodule-to-iidecl [ii]\n (case ii\n (IIModule mname) (| ((== mname current-module-name)\n (mk-ii mname)))\n _ ii))\n (iidecl-to-iimodule [ii]\n (case ii\n (IIDecl idecl) (| ((== (unLoc (ideclName idecl))\n current-module-name)\n (IIModule current-module-name)))\n _ ii))\n (ii-fn\n (if (not (is-interpreting dflags))\n iimodule-to-iidecl\n iidecl-to-iimodule))])\n (return (map ii-fn imports))))\n\n(defn (:: env-context-on-exception (-> (Fnk Code) (Fnk Code)))\n [action]\n (catch action\n (\\e\n (do (lefn [(print-se [se]\n (do (<- dflags getSessionDynFlags)\n (liftIO\n (putStr (unlines\n (map (showSDoc dflags) (msgs se)))))))\n (msgs [se]\n (ppr-wrapped-msg-bag-with-loc (srcErrorMessages se)))])\n (maybe (liftIO (print e)) print-se (fromException e))\n (<- mods (fmap envContextModules getFnkEnv))\n (setContext (map mk-ii-str mods))\n (return '(:begin))))))\n\n(defn (:: sort-by-name-src-span (-> [Name] [Name]))\n (cond-expand\n [(<= 900 :ghc)\n (sortBy (on leftmost-smallest nameSrcSpan))]\n [otherwise\n (sortBy (on compare nameSrcSpan))]))\n\n(defn (:: browse-module (-> Module ModuleInfo (Fnk Code)))\n \"Simplified version of `GHCi.UI.browseModule'.\"\n [mdl mod-info]\n (lefn [(loc-sort [ns]\n (| ((<- (: n _) ns) (isGoodSrcSpan (nameSrcSpan n))\n (sort-by-name-src-span ns))\n (otherwise (occ-sort ns))))\n (occ-sort\n (sortBy (on compare nameOccName)))]\n (lept [names (modInfoExports mod-info)\n (, local external) (partition (. (== mdl) nameModule) names)\n sorted-names (++ (loc-sort local) (occ-sort external))\n pretty (pprTyThing showToHeader)]\n (do (<- mb-things (mapM lookupName sorted-names))\n (lept [things (catMaybes mb-things)\n prettyThings (map pretty things)])\n (<- str (show-sdoc-for-user-m (vcat prettyThings)))\n (return `(System.IO.putStrLn ,str))))))\n\n(defn (:: expand-with (-> String (-> Code (Fnk Code)) ReplAction))\n [label f forms]\n (case forms\n [] (return '(:begin))\n [expr] (>>= (f expr) (\\x (return `(System.IO.print ',x))))\n _ (invalid-form label forms)))\n\n;;; Mostly translated from `GHCi.UI.infoThing'.\n(defn (:: info-name (-> Code (Fnk Code)))\n [thing]\n (do (<- sdoc (info-thing True (show thing)))\n (<- str (show-sdoc-for-user-m sdoc))\n (return `(System.IO.putStrLn ,str))))\n\n(defn (:: info-thing (-> Bool String (Fnk SDoc)))\n [all-info str]\n (where (do (<- names (parseName str))\n (<- mb_stuffs (mapM (getInfo all-info) names))\n (lept [filtered\n (filter-out-children child-filter\n (catMaybes (toList mb_stuffs)))])\n (return\n (vcat (intersperse (text \"\") (map ppr-info filtered)))))\n (defn child-filter [(, a _ _ _ _)] a)\n (defn ppr-info [(, thing fixity cls fam _)]\n (__ppr-info thing fixity cls fam))))\n\n(defn (:: __ppr-info (-> TyThing Fixity [ClsInst] [FamInst] SDoc))\n [thing fixity cls fam]\n (lept [show-fixity (if (== fixity defaultFixity)\n empty\n (<+> (ppr fixity) (pprInfixName (getName thing))))]\n ($$ (pprTyThingInContextLoc thing)\n show-fixity\n (vcat (map pprInstance cls))\n (vcat (map pprFamInst fam)))))\n\n(defn (:: filter-out-children (-> (-> a TyThing) [a] [a]))\n [get-thing xs]\n (lefn [(all-names\n (mkNameSet (map (. getName get-thing) xs)))\n (has-parent [x]\n (case (tyThingParent-maybe (get-thing x))\n (Just p) (elemNameSet (getName p) all-names)\n _ False))]\n (filter (. not has-parent) xs)))\n\n(defn (:: clear-all-targets (=> (GhcMonad m) (m ())))\n (do (setTargets [])\n (void (GhcMake.load LoadAllTargets))))\n\n(defn (:: clear-caches (Fnk ()))\n (cond-expand\n [(<= 904 :ghc)\n (do (<- fnk-env getFnkEnv)\n (lept [clear (. void liftIO iface-clearCache)])\n (mapM- clear (envInterpModIfaceCache fnk-env)))]\n [otherwise\n (pure ())]))\n\n\f\n;;; Functions for show command\n\n(defn (:: show-bindings (Fnk Code))\n (where (do (<- bs getBindings)\n (<- docs (mapM make-doc (reverse bs)))\n (<- str (show-sdoc-for-user-m (vcat docs)))\n (return `(System.IO.putStrLn ,str)))\n (defn (:: make-doc (-> TyThing (Fnk SDoc))) [tt]\n (case tt\n (AnId i) (pprTypeAndContents i)\n _ (do (<- mb-stuff (getInfo False (getName tt)))\n (return (maybe (text \"\") ppr-tt mb-stuff)))))\n (defn ppr-tt [(, thing _ _ _ _)]\n (pprTyThing showToHeader thing))))\n\n(defn (:: show-context (Fnk Code))\n (where (do (<- context getContext)\n (<- dflags getSessionDynFlags)\n (return `(System.IO.putStr ,(result dflags context))))\n (defn result [dflags context]\n (unlines (: \"; context\" (map (context-string dflags) context))))\n (defn context-string [dflags ctx]\n (case ctx\n (IIDecl d) (++ \"; IIDecl: \" (showSDoc dflags (ppr d)))\n (IIModule m) (++ \"; IIModule: \" (moduleNameString m))))))\n\n(defn (:: show-backend (-> DynFlags String))\n (cond-expand\n [(<= 902 :ghc)\n (. show backend)]\n [otherwise\n (. show hscTarget)]))\n\n(defn (:: show-dflags (Fnk Code))\n (lefn [(ss [dflags]\n [\"; dflags:\"\n (++ \"; ghcLink: \" (show (ghcLink dflags)))\n (++ \"; ghcMode: \" (showGhcMode (ghcMode dflags)))\n (++ \"; backend: \" (show-backend dflags))\n (++ \"; objectDir: \" (show (objectDir dflags)))\n (++ \"; homeUnitId: \" (showUnitId dflags))\n (++ \"; forceRecomp: \"\n (show (gopt Opt-ForceRecomp dflags)))])\n (showGhcMode [m]\n (case m\n CompManager \"CompManager\"\n OneShot \"OneShot\"\n MkDepend \"MkDepend\"))]\n (do (<- dflags getDynFlags)\n (return `(System.IO.putStr ,($ unlines ss dflags))))))\n\n(defn (:: show-hpt (Fnk Code))\n \"Show home package table.\"\n (do (<- hsc-env getSession)\n (<- str0 (show-sdoc-for-user-m (pprHPT (hsc-HPT hsc-env))))\n (lept [str1 (if (null str0)\n \"show: no home package table found\"\n str0)])\n (return `(System.IO.putStrLn ,str1))))\n\n;;; Mostly taken from `GHCi.UI.showLanguages''.\n(defn (:: show-language (-> Bool (Fnk Code)))\n [show-all]\n (do (<- dflags getDynFlags)\n (lefn [(setting [test flag]\n (where (| (quiet empty)\n (is-on (<> (text \"-X\") (text name)))\n (otherwise (<> (text \"-XNo\") (text name))))\n (= name (flagSpecName flag))\n (= f (flagSpecFlag flag))\n (= is-on (test f dflags))\n (= quiet (&& (not show-all)\n (== (test f default-dflags) is-on)))))\n\n (default-lang\n (cond-expand\n [(<= 902 :ghc) GHC2021]\n [otherwise Haskell2010]))\n\n (default-dflags\n (lang-set (gen-default-dflags dflags)\n (case (language dflags)\n Nothing (Just default-lang)\n other other)))])\n (<- str\n (show-sdoc-for-user-m\n (vcat [(<> (text \"base language is: \")\n (case (language dflags)\n Nothing (text (show default-lang))\n (Just lang) (ppr lang)))\n ($$ (if show-all\n (text \"all active language options:\")\n (text \"with the following modifiers:\"))\n (nest 2 (vcat (map (setting xopt) xFlags))))])))\n (return `(System.IO.putStrLn ,str))))\n\n(defn (:: show-loader-state (-> HscEnv (IO ())))\n [hsc-env]\n (cond-expand\n [(<= 902 :ghc)\n (case (hsc-interp hsc-env)\n (Just interp) (do (initLoaderState interp hsc-env)\n (show-linker-state hsc-env))\n _ (pure ()))]\n [otherwise\n ;; XXX: `Linker.showLinkerState' reads from `v_PersistentLinkerState',\n ;; which is not exposed from the module its defined ... not sure how\n ;; to get resulting output as `String' other than redirecting output\n ;; to stdout.\n (>> (initDynLinker hsc-env)\n (show-linker-state hsc-env))]))\n\n(defn (:: show-linker (Fnk Code))\n (do (<- hsc-env getSession)\n (liftIO (show-loader-state hsc-env))\n (return '(:begin))))\n\n(defn (:: show-macros (Fnk Code))\n (do (<- macros (fmap envMacros getFnkEnv))\n (lept [macro-strings (unlines\n (: \"; macros: \"\n (map (++ \"; \") (macroNames macros))))])\n (return `(System.IO.putStr ,macro-strings))))\n\n(defn (:: show-modules (Fnk Code))\n (do (<- graph0 getModuleGraph)\n (lept [graph1 (mgModSummaries graph0)])\n (<- graph2 (filterM (. isLoaded ms_mod_name) graph1))\n (<- mods (mapM showModule graph2))\n (return `(System.IO.putStr ,(unlines mods)))))\n\n(defn (:: show-options (-> Bool (Fnk Code)))\n [show-all]\n (do (<- dflags getDynFlags)\n (lefn [(setting [prefix no-prefix test flag]\n (where (| (quiet empty)\n (is-on (<> (text prefix) (text name)))\n (otherwise (<> (text no-prefix) (text name))))\n (= name (flagSpecName flag))\n (= f (flagSpecFlag flag))\n (= is-on (test f dflags))\n (= quiet (&& (not show-all)\n (== (test f default-dflags) is-on)))))\n (default-dflags\n (gen-default-dflags dflags))\n ((, ghciFlags others)\n (partition (\\f (elem (flagSpecFlag f) flgs)) fFlags))\n (flgs\n [Opt_PrintExplicitForalls\n Opt_PrintExplicitKinds\n Opt_PrintBindResult\n Opt_BreakOnException\n Opt_BreakOnError\n Opt_PrintEvldWithShow])\n (sdocs\n [($$ (text \"REPL specific dynamic flag settings:\")\n (nest 2 (vcat (map (setting \"-f\" \"-fno-\" gopt)\n ghciFlags))))\n ($$ (text \"other dynamic, non-language, flag settings:\")\n (nest 2 (vcat (map (setting \"-f\" \"-fno-\" gopt)\n others))))\n ($$ (text \"warning settings:\")\n (nest 2 (vcat (map (setting \"-W\" \"-Wno-\" wopt)\n wWarningFlags))))])\n (printOthers\n `(Data.Foldable.mapM_\n System.IO.putStrLn\n ,(map (showSDoc dflags) sdocs)))])\n (<- printLang (show-language show-all))\n (return `(>> ,printLang ,printOthers))))\n\n(defn (:: show-packages (Fnk Code))\n (do (<- dflags getDynFlags)\n (lefn [(pr (++ \"; \"))\n (pr-flag [flag]\n (case flag\n (ExposePackage n _ _) (pr n)\n (HidePackage n) (pr (++ \"hiding \" n))))\n (pkgs\n (: \"; packages\" (map pr-flag (packageFlags dflags))))])\n (return `(System.IO.putStr ,(unlines pkgs)))))\n\n(defn (:: show-paths (Fnk Code))\n (do (<- dflags getDynFlags)\n (<- cwd (liftIO getCurrentDirectory))\n (lept [ipaths (importPaths dflags)\n result (unlines (concat\n [[\"; current working directory:\"\n (++ \"; \" cwd)\n \"; module import search paths:\"]\n (if (null ipaths)\n [\"; none\"]\n (map (++ \"; \") ipaths))]))])\n (return `(System.IO.putStr ,result))))\n\n(defn (:: show-targets (Fnk Code))\n (do (<- hsc-env getSession)\n (<- strs (mapM (. show-sdoc-for-user-m pprTarget)\n (hsc-targets hsc-env)))\n (return `(System.IO.putStrLn (++ \"; targets: \"\n ,(if (null strs)\n \"none\"\n (unwords strs)))))))\n\n\f\n;;; REPL commands\n\n(defn (:: help-cmd ReplAction)\n [_form]\n (return\n `(System.IO.putStrLn ,(++ \"DESCRIPTION: \\n\\\n\\\\n\\\n\\ REPL meta macro, ARGS varies per COMMAND.\\n\\\n\\\\n\\\n\\COMMANDS:\\n\\\n\\\\n\" (unlines\n (map (\\rc\n (lept [pre (unwords (: (rc-name rc) (rc-args rc)))]\n (concat\n [\" ,\" (printf \"%-14s\" pre) \" - \" (rc-help rc)])))\n commands))))))\n\n(defn (:: system-cmd ReplAction)\n \"Invoke system command.\"\n [forms]\n ;; Using `callProces' which uses `System.Process.RawCommand' instead of\n ;; `System.Process.Shell', to support invoking commands without shell.\n (do (case (map show forms)\n [] (return ())\n (: cmd rest) (liftIO (callProcess cmd rest)))\n (return '(:begin))))\n\n;;; Mostly taken from `GHCi.UI.guessCurrentModule'.\n(defn (:: guess-current-module (-> Code (Fnk Module)))\n [form]\n (case-do getContext\n (: (IIModule m) _) (findModule m Nothing)\n (: (IIDecl d) _) (cond-expand\n [(<= 904 :ghc)\n (do (<- pq (GHC.renameRawPkgQualM (unLoc (ideclName d))\n (ideclPkgQual d)))\n (GHC.findQualifiedModule pq (unLoc (ideclName d))))]\n [otherwise\n (findModule (unLoc (ideclName d))\n (fmap sl-fs (ideclPkgQual d)))])\n _ (finkelSrcError form \"browse: no current module\")))\n\n;;; Mostly taken from `GHCi.UI.browseCmd'.\n(defn (:: browse-cmd ReplAction)\n [forms]\n (lefn [(go [mb-name]\n (case mb-name\n (Just name) (| ((looksLikeModuleName name)\n (>>= (lookupModule (mkModuleName name) Nothing)\n go')))\n _ (>>= (guess-current-module (located-list forms)) go')))\n (go' [mdl]\n (case-do (getModuleInfo mdl)\n (Just mod-info) (browse-module mdl mod-info)\n Nothing (lept [mname (moduleName mdl)\n str (moduleNameString mname)\n msg (++ \"unknown module: \" str)]\n (return `(System.IO.putStrLn ,msg)))))]\n (case (map unCode forms)\n [(Atom (ASymbol sym))] (go (Just (unpackFS sym)))\n [] (go Nothing)\n _ (invalid-form \"browse\" forms))))\n\n(defn (:: expand-path (=> (MonadIO m) (-> FilePath (m FilePath))))\n (lefn [(:: try-getHomeDirectory (IO (Either SomeException FilePath)))\n (try-getHomeDirectory (try getHomeDirectory))\n (go [path]\n (case path\n (: #'~ rest) (case-do try-getHomeDirectory\n (Right home) (pure (normalise\n (++ home (: #'/ rest))))\n (Left _) (pure path))\n _ (return path)))]\n (. liftIO go)))\n\n;;; From `GHCi.UI.changeDirectory'.\n(defn (:: cd-cmd ReplAction)\n \"Function to change current directory.\"\n [forms]\n (lefn [(work [dir0]\n (do (<- graph getModuleGraph)\n (<- mods (fmap envContextModules getFnkEnv))\n (when ($ not null mgModSummaries graph)\n (liftIO (putStrLn warn-unloading)))\n clear-all-targets\n clear-caches\n (setContext (map mk-ii-str mods))\n workingDirectoryChanged\n (liftIO (do (<- dir1 (expand-path dir0))\n (setCurrentDirectory dir1)))\n (return '(:begin))))\n (warn-unloading\n (++ \"Warning: \"\n \"changing directory causes all loaded modules to be unloaded\\n\"\n \"because the search path has changed.\"))]\n (case forms\n [] (>>= (expand-path \"~\") work)\n [arg1] (| ((<- (Just path) (code-to-mb-string arg1))\n (work path)))\n _ (invalid-form \"cd\" forms))))\n\n(defn (:: expand-cmd ReplAction)\n \"Expand given form for one layer.\"\n (expand-with \"expand\" expand1))\n\n(defn (:: expand-full-cmd ReplAction)\n \"Fully expand given form.\"\n (expand-with \"expand!\" expand))\n\n(defn (:: info-cmd ReplAction)\n [forms]\n (case (map unCode forms)\n [(@ form (Atom (ASymbol _)))] (info-name (toCode form))\n [(Atom AUnit)] (info-name (make-symbol \"()\"))\n [(HsList [])] (info-name (make-symbol \"[]\"))\n _ (invalid-form \"info\" forms)))\n\n;; From `GHCi.UI.kindOfType'\n(defn (:: kind-cmd ReplAction)\n [forms]\n (case forms\n [form] (do (<- ty0 (buildHsSyn parseType forms))\n (<- (, _ kind) (evalTypeKind ty0))\n (lept [sdoc (hsep [(text (show form))\n dcolon\n (pprSigmaType kind)])])\n (<- str (show-sdoc-for-user-m sdoc))\n (return `(System.IO.putStrLn ,str)))\n _ (invalid-form \"kind\" forms)))\n\n(defn (:: load-cmd ReplAction)\n \"Load a module source code file. Handles absolute paths and relative\npaths from import directories.\"\n [forms]\n (lefn [(clear-all\n ;; Clear the main session, then clear the macro expander session.\n (do do-clear-all\n (case-do (fmap envSessionForExpand getFnkEnv)\n (Just mex-env-1) (do-clear-mex mex-env-1)\n _ (pure ()))))\n (do-clear-mex [hsc-env-1]\n (withTempSession (const hsc-env-1)\n (do do-clear-all\n (<- hsc-env-2 getSession)\n (modifyFnkEnv\n (\\e (e {(= envSessionForExpand\n (Just hsc-env-2))}))))))\n (do-clear-all []\n ;; See `loadModule'' in \"ghc/GHCi/UI.hs\". Clearing various states:\n ;; finder cache, targets, interactive context ... etc.\n (do (<- graph0 getModuleGraph)\n (<- _ abandonAll)\n clear-all-targets\n clear-caches\n (<- hsc-env getSession)\n (lept [graph1 (mgModSummaries graph0)\n uncache (cond-expand\n [(<= 904 :ghc)\n (\\ ms (uncacheModule (hsc-FC hsc-env)\n (hsc-home-unit hsc-env)\n (ms-mod-name ms)))]\n [otherwise\n (. (uncacheModule hsc-env) ms_mod_name)])])\n (liftIO (do (mapM_ uncache graph1)\n (cond-expand\n [(<= 904 :ghc)\n (flushFinderCaches (hsc-FC hsc-env)\n (hsc-unit-env hsc-env))]\n [otherwise\n (flushFinderCaches hsc-env)])))\n (setSession (discardInteractiveContext hsc-env))))\n (make-target [path]\n (do (<- hsc-env getSession)\n (lept [allow-obj (cond-expand\n [(<= 904 :ghc)\n ;; Deciding from target name, since the\n ;; \"-fforce-recomp\" option is always turned\n ;; ON when object code was not allowed.\n (not (isPrefixOf \"*\" path))]\n [otherwise\n ($ not is-interpreting hsc-dflags hsc-env)])\n tfile (TargetFile path Nothing)])\n (pure\n (cond-expand\n [(<= 904 :ghc)\n (Target tfile allow-obj (hscActiveUnitId hsc-env) Nothing)]\n [otherwise\n (Target tfile allow-obj Nothing)]))))]\n\n (case forms\n [form] (maybe\n (finkelSrcError form (++ \"load: not a FilePath: \"\n (show form)))\n (\\path\n ;; Clear current state first. Then find the source file\n ;; path and compile, load, and link.\n (env-context-on-exception\n (do clear-all\n (<- target (make-target path))\n (<- _ (setTargets [target]))\n (<- success-flag (compile-and-import [(onTheREPL path)]))\n (case success-flag\n Succeeded (liftIO (putStrLn (++ \"; loaded \" path)))\n _ (return ()))\n (return '(:begin)))))\n (code-to-mb-string form))\n _ (invalid-form \"load\" forms))))\n\n(defn (:: pwd-cmd ReplAction)\n \"Function to show current directory.\"\n [_forms]\n (do (<- dir (liftIO getCurrentDirectory))\n (return `,dir)))\n\n(defn (:: reload-cmd ReplAction)\n \"Function to reload previously loaded module.\"\n [_forms]\n (case-do getTargets\n (cond-expand\n [(<= 904 :ghc)\n (: (Target target-id _ _ _) _)]\n [otherwise\n (: (Target target-id _ _) _)])\n (env-context-on-exception\n (lept [tstr (case target-id\n (TargetFile path _) path\n (TargetModule mdl) (moduleNameString mdl))]\n (case-do (compile-and-import [(onTheREPL tstr)])\n Succeeded (do (<- ctx0 getContext)\n (<- ctx1 (adjust-current-target tstr ctx0))\n (setContext ctx1)\n (return `(System.IO.putStrLn\n ,(++ \"; reloaded \" tstr))))\n Failed (return '(:begin)))))\n _ (return '(System.IO.putStrLn \"; reload: invalid target\"))))\n\n(defn (:: set-cmd ReplAction)\n \"Set command line flags, see `GHCi.UI.newDynFlags'.\"\n [forms]\n (case forms\n (: _ _)\n ;; Always using `setSessionDynFlags' for `set' REPL command to support\n ;; `-package' flag.\n (do (lefn [(all-flags\n (foldr (\\form acc\n (case (mb-symbol-name form)\n (Just name) (: name acc)\n _ acc))\n [] forms))\n ((, fnk-flags hs-flags)\n (partitionFnkEnvOptions all-flags))\n (update-fnk-opts [opts fnk-env]\n (foldl (flip id) fnk-env opts))])\n (when (not (null fnk-flags))\n (case (getOpt Permute fnkEnvOptions fnk-flags)\n (, o _ []) (modifyFnkEnv (update-fnk-opts o))\n (, _ _ es) (liftIO (print es))))\n (<- hsc-env getSession)\n (lept [dflags0 (hsc-dflags hsc-env)])\n (<- (, dflags1 leftovers warns)\n (parseDynamicFlagsCmdLine dflags0 (map onTheREPL hs-flags)))\n (liftIO\n (do (print-or-throw-diagnostics hsc-env dflags1 warns)\n (unless (null leftovers)\n (putStrLn\n (++ \"Some flags have not been recognized: \"\n (intercalate \", \" (map unLoc leftovers)))))))\n (<- _ (setSessionDynFlags dflags1))\n (<- dflags2 getDynFlags)\n (setDynFlags dflags2)\n ;; Updating two more `DynFlags', one is the default `DynFlags' used to\n ;; import modules during macro expansion, and another is the `DynFlags'\n ;; in the `HscEnv' used by the macro expander.\n (modifyFnkEnv\n (\\e (e {(= envDefaultDynFlags (Just dflags2))\n (= envSessionForExpand (fmap (updateDynFlags dflags2)\n (envSessionForExpand e)))})))\n (return '(:begin)))\n _ (finkelSrcError nil \"set: empty form\")))\n\n(defn (:: show-cmd ReplAction)\n [forms]\n (where go\n (defn go\n (case forms\n [form] (| ((<- (Just name) (mb-symbol-name form))\n (<- (Just act) (lookup name things))\n act))\n _ (finkelSrcError nil (++ \"show: expecting one of:\\n\"\n (intercalate \", \" (map fst things))))))\n (defn things\n [(, \"bindings\" show-bindings)\n (, \"context\" show-context)\n (, \"dflags\" show-dflags)\n (, \"hpt\" show-hpt)\n (, \"language\" (show-language False))\n (, \"linker\" show-linker)\n (, \"macros\" show-macros)\n (, \"modules\" show-modules)\n (, \"options\" (show-options False))\n (, \"options!\" (show-options True))\n (, \"packages\" show-packages)\n (, \"paths\" show-paths)\n (, \"targets\" show-targets)])))\n\n;; From `GHCi.UI.typeOfExpr'.\n(defn (:: type-cmd ReplAction)\n [forms]\n (case forms\n [form] (do (<- expanded (expand form))\n (<- expr (buildHsSyn parseExpr [expanded]))\n (<- ty (evalExprType expr))\n (lept [sdoc (sep [(text (show form))\n (nest 2 (<+> dcolon (pprSigmaType ty)))])])\n (<- str (show-sdoc-for-user-m sdoc))\n (return `(System.IO.putStrLn ,str)))\n _ (invalid-form \"type\" forms)))\n\n(defn (:: verbose-cmd ReplAction)\n \"Modify verbosity settings in REPL.\"\n [forms]\n (case forms\n [] (do (<- lvl (fmap envVerbosity getFnkEnv))\n (return\n `(System.IO.putStrLn ,(++ \"Verbosity level is \" (show lvl)))))\n [form] (| ((<- (Just n) (readMaybe (show form)))\n (do (modifyFnkEnv (setFnkVerbosity n))\n (lept [msg (++ \"Verbosity level set to \" (show n))])\n (return `(System.IO.putStrLn ,msg)))))\n _ (invalid-form \"verbose\" forms)))\n\n\f\n;;; REPL command macro\n\n(defn (:: commands [ReplCmd])\n (lept [c ReplCmd]\n [(c \"!\" [\"CMD\" \"ARGS\" \"...\"] system-cmd\n \"run system CMD with ARGS\")\n (c \"?\" [] help-cmd\n \"show this help\")\n (c \"browse\" [\"MODULE\"] browse-cmd\n \"browse contents of MODULE\")\n (c \"cd\" [\"DIR\"] cd-cmd\n \"change working directory to DIR\")\n (c \"expand\" [\"FORM\"] expand-cmd\n \"show expanded result of FORM\")\n (c \"expand!\" [\"FORM\"] expand-full-cmd\n \"show fully expanded result of FORM\")\n (c \"info\" [\"NAME\"] info-cmd\n \"show info of NAME\")\n (c \"kind\" [\"TYPE\"] kind-cmd\n \"show kind of TYPE\")\n (c \"load\" [\"FILE\"] load-cmd\n \"compile and load FILE\")\n (c \"pwd\" [] pwd-cmd\n \"show working directory\")\n (c \"reload\" [] reload-cmd\n \"reload previous module\")\n (c \"set\" [\"FLAGS\" \"...\"] set-cmd\n \"parse and set FLAGS\")\n (c \"show\" [\"ARG\"] show-cmd\n \"show information of ARG\")\n (c \"type\" [\"EXPR\"] type-cmd\n \"show type of EXPR\")\n (c \"verbose\" [\"INT\"] verbose-cmd\n \"set finkel verbosity to INT\")]))\n\n(defmacroM repl-macro form\n (case (unCode form)\n (List (: name args)) (case (do (<- name' (code-to-mb-string name))\n (find (. (isPrefixOf name') rc-name)\n commands))\n (Just rc) (rc-action rc args)\n _ (help-cmd []))\n _ (finkelSrcError form (++ \"invalid args: \" (show form)))))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Internal/Types.hs", "content": ";;; -*- mode: finkel -*-\n%p(LANGUAGE FlexibleInstances\n GeneralizedNewtypeDeriving)\n\n;;;; Types for REPL.\n\n(defmodule Finkel.Tool.Internal.Types\n (export\n ;; repl\n (Repl ..) run-repl put-repl-state get-repl-state\n\n ;; repl state\n (ReplState ..) (HasReplState ..) initial-repl-state\n\n ;; input and result\n (Input ..) (InSource ..) Result\n\n ;; re-export\n (MonadTrans ..))\n (require\n ;; finkel-core\n (Finkel.Tool.Internal.Macro.Ghc))\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Concurrent [MVar])\n (Control.Monad.IO.Class [(MonadIO ..)])\n (Data.Function [on])\n (Data.IORef [IORef atomicWriteIORef newIORef readIORef])\n\n\n ;; transformers\n (Control.Monad.Trans.Class [(MonadTrans ..)])\n\n ;; finkel-kernel\n (Language.Finkel [Code])))\n\n(imports-from-ghc\n (GHC.Data.StringBuffer [StringBuffer appendStringBuffers])\n (GHC.Utils.IO.Unsafe [inlinePerformIO]))\n\n(cond-expand\n [(:min-version \"haskeline\" 0 8 0)\n ;; exceptions\n (import Control.Monad.Catch\n ((MonadThrow ..) (MonadCatch ..) (MonadMask ..)))]\n [otherwise\n ;; haskeline\n (import System.Console.Haskeline ((MonadException ..) (RunIO ..)))])\n\n;;; REPL, REPL state, input, and result types\n\n;;; Repl state type to hold intermediate line-wise inputs.\n(data ReplState\n (ReplState {(:: pending-input (Maybe StringBuffer))\n (:: prompt-string String)})\n (deriving Show))\n\n(defn (:: append-repl-state (-> ReplState ReplState ReplState))\n [r1 r2]\n (where (ReplState {(= pending-input (on unsafeAppendStringBuffers\n pending-input r1 r2))\n (= prompt-string (prompt-string r2))})\n ;; Note the use of `inlinePerformIO'.\n (= unsafeAppendStringBuffers mb-s1 mb-s2\n (| ((<- (Just s1) mb-s1) (<- (Just s2) mb-s2)\n (Just (inlinePerformIO (appendStringBuffers s1 s2))))\n ((<- (Just _) mb-s1) mb-s1)\n ((<- (Just _) mb-s2) mb-s2)\n (otherwise Nothing)))))\n\n(instance (Eq ReplState)\n (defn ==\n (where (on eqStringBuffer pending-input)\n (= eqStringBuffer (on == show)))))\n\n(instance (Monoid ReplState)\n (defn mempty initial-repl-state)\n (cond-expand\n [(not (:min-version \"base\" 4 11 0))\n (defn mappend append-repl-state)]\n [otherwise\n (:begin)]))\n\n(cond-expand\n [(:min-version \"base\" 4 11 0)\n (instance (Semigroup ReplState)\n (= <> append-repl-state))]\n [otherwise\n (:begin)])\n\n(defn (:: initial-repl-state ReplState)\n (ReplState {(= pending-input Nothing)\n (= prompt-string \"> \")}))\n\n;;; Newtype wrapper for REPL prompt.\n(newtype (Repl a)\n (Repl {(:: unRepl (-> (IORef ReplState) (IO a)))}))\n\n(instance (Functor Repl)\n (defn fmap [f (Repl repl)]\n (Repl (. (fmap f) repl)))\n %p(INLINE fmap))\n\n(instance (Applicative Repl)\n (defn pure [x]\n (Repl (\\_ (pure x))))\n %p(INLINE pure)\n\n (defn <*> [(Repl mf) (Repl mx)]\n (Repl (\\ref (<*> (mf ref) (mx ref)))))\n %p(INLINE <*>))\n\n(instance (Monad Repl)\n (defn >>= [(Repl repl) k]\n (Repl (\\ref (>>= (repl ref) (. (flip unRepl ref) k)))))\n %p(INLINE >>=))\n\n(instance (MonadIO Repl)\n (defn liftIO [io]\n (Repl (\\_ io)))\n %p(INLINE liftIO))\n\n;;; In ghc-8.10.1, `haskeline' switched to use `MonadThrow', `MonadCatch', and\n;;; `MonadMask' type classes from the `exceptions' package instead of the\n;;; internally defined `MonadException' type class. Since the `Repl' data type\n;;; is used with codes for the `InputT' from `haskeline' package, defining\n;;; instances of type classes from `exceptions'.\n(cond-expand\n [(:min-version \"haskeline\" 0 8 0)\n (:begin\n (instance (MonadThrow Repl)\n (defn throwM (. liftIO throwM))\n %p(INLINE throwM))\n\n (instance (MonadCatch Repl)\n (defn catch [(Repl repl) f]\n (Repl (\\ref\n (catch (repl ref)\n (\\e (unRepl (f e) ref))))))\n %p(INLINE catch))\n\n (instance (MonadMask Repl)\n (defn mask [a]\n (lefn [(:: q (-> (-> (IO a) (IO a)) (Repl a) (Repl a)))\n (q [unmask (Repl repl)]\n (Repl (. unmask repl)))]\n (Repl (\\ref\n (mask\n (\\unmask (unRepl (a (q unmask)) ref)))))))\n %p(INLINE mask)\n (defn uninterruptibleMask [a]\n (lefn [(:: q (-> (-> (IO a) (IO a)) (Repl a) (Repl a)))\n (q [unmask (Repl repl)]\n (Repl (. unmask repl)))]\n (Repl (\\ref\n (uninterruptibleMask\n (\\unmask\n (unRepl (a (q unmask)) ref)))))))\n %p(INLINE uninterruptibleMask)\n (defn generalBracket [acquire release use]\n (Repl (\\ref\n (generalBracket\n (unRepl acquire ref)\n (\\resource exit-case\n (unRepl (release resource exit-case) ref))\n (\\resource\n (unRepl (use resource) ref))))))\n %p(INLINE generalBracket)))]\n\n [otherwise\n (instance (MonadException Repl)\n (defn controlIO [f]\n (Repl (\\ref\n (controlIO\n (\\ (RunIO run)\n (lept [run' (RunIO (. (fmap (. Repl const))\n (. run (flip unRepl ref))))]\n (fmap (flip unRepl ref) (f run'))))))))\n %p(INLINE controlIO))])\n\n(defn (:: run-repl (-> (Repl a) ReplState (IO a)))\n [(Repl repl) st]\n (>>= (newIORef st) repl))\n\n(defn (:: get-repl-state (Repl ReplState))\n (Repl readIORef))\n\n(defn (:: put-repl-state (-> ReplState (Repl ())))\n [st]\n (Repl (flip atomicWriteIORef st)))\n\n;;; Type class for getting and putting 'ReplState'.\n(class (HasReplState r)\n (:: getReplState (r ReplState))\n (:: putReplState (-> ReplState (r ()))))\n\n(instance (HasReplState Repl)\n (= getReplState get-repl-state)\n %p(INLINE getReplState)\n (= putReplState put-repl-state)\n %p(INLINE putReplState))\n\n(instance (=> (MonadTrans t) (Monad m) (HasReplState m)\n (HasReplState (t m)))\n (= getReplState (lift getReplState))\n %p(INLINE getReplState)\n (= putReplState (. lift putReplState))\n %p(INLINE putReplState))\n\n;;; Input data type to hold form to evaluate, and MVar to receive\n;;; result from evaluation thread.\n(data Input\n (Input InSource Code (MVar Result)))\n\n;;; Type for input, to distinguish prompt from network connections to\n;;; REPL server.\n(data InSource\n Prompt\n Connection)\n\n;;; Synonym for evaluation result.\n(type Result\n (Either String String))\n" }, { "path": "finkel-tool/src/Finkel/Tool/Main.hs", "content": ";;; -*- mode: finkel -*-\n;;; Main entry point\n\n(defmodule Finkel.Tool.Main\n (export defaultMain)\n (import\n ;; base\n (System.Environment [getArgs])\n\n ;; Internal\n (Finkel.Tool.Command)\n (Finkel.Tool.Command.Help)\n (Finkel.Tool.Internal.CLI)\n (Finkel.Tool.Internal.Exception)))\n\n(defn (:: defaultMain (IO ()))\n \"Main entry point function for the executable.\"\n (finkel-tool-exception-handler\n (lefn [(go [name rest]\n (maybe (show-usage commands)\n (flip cmd-act rest)\n (find-command commands name)))]\n (case-do getArgs\n [] (go \"repl\" [])\n (: name rest) (go name rest)))))\n" }, { "path": "finkel-tool/test/CLITest.hs", "content": ";;; -*- mode: finkel -*-\n;;; Tests for CLI type class and its instances\n\n%p(language RankNTypes)\n\n(defmodule CLITest\n (export cliTests)\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Exception [bracket])\n (Control.Monad [replicateM])\n (GHC.IO.Handle [hDuplicate hDuplicateTo])\n (System.IO\n [(IOMode ..) hClose hSetNewlineMode noNewlineTranslation openFile stdin])\n\n ;; filepath\n (System.FilePath [])\n\n ;; haskeline\n (System.Console.Haskeline [defaultSettings runInputT])\n\n ;; hspec\n (Test.Hspec)\n\n ;; Internal\n (Finkel.Tool.Internal.CLI)\n (TestAux)))\n\n(defn (:: cliTests Spec)\n (do (describe \"IO instance\" io-tests)\n (describe \"InputT instance\" inputT-tests)))\n\n(defn (:: io-tests Spec)\n (make-cli-tests id))\n\n(defn (:: inputT-tests Spec)\n (make-cli-tests (runInputT defaultSettings)))\n\n(defn (:: make-cli-tests\n (=> (CLI m) (-> (forall a (-> (m a) (IO a))) Spec)))\n [toIO]\n (do (describe \"getString\"\n (lept [expected\n (cond-expand\n [(== :os \"mingw32\")\n [(Just \"First line\\r\") (Just \"Second line\\r\") Nothing]]\n [otherwise\n [(Just \"First line\") (Just \"Second line\") Nothing]])]\n (it \"should end with Nothing\"\n (shouldReturn (with-test-stdin \"input01.txt\"\n (toIO (replicateM 3 (getString \"\"))))\n expected))))\n (describe \"putString\"\n (it \"should run successfully\"\n (quietly (toIO (putString \"foo\")))))\n (describe \"handleInterrupt\"\n (it \"should run the given action\"\n (toIO (handleInterrupt (return ()) (return ())))))\n (describe \"withInterrupt\"\n (it \"should run the given action\"\n (toIO (withInterrupt (return ())))))\n (describe \"exitWith\"\n (it \"should throw exit failure\"\n (shouldThrow (toIO (exitWith (ExitFailure 1)))\n (== (ExitFailure 1)))))))\n\n(defn (:: with-test-stdin (-> String (IO a) (IO a)))\n [path act]\n (bracket\n (do (<- stdin2 (hDuplicate stdin))\n (<- hdl (openFile (datafile path) ReadMode))\n (hSetNewlineMode hdl noNewlineTranslation)\n (hDuplicateTo hdl stdin)\n (return (, hdl stdin2)))\n (\\ (, hdl stdin2)\n (do (hDuplicateTo stdin2 stdin)\n (hClose hdl)\n (hClose stdin2)))\n (const act)))\n\n(defn (:: datafile (-> String FilePath))\n [name]\n ( \"test\" ( \"data\" name)))\n" }, { "path": "finkel-tool/test/GhcTest.hs", "content": ";;; -*- mode: finkel -*-\n%p(LANGUAGE TypeApplications)\n\n(defmodule GhcTest\n (export ghcTests)\n (import-when [:compile]\n ;; Internal\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Exception [(SomeException ..) try])\n\n ;; hspec\n (Test.Hspec)\n\n ;; finkel-kernel\n (Language.Finkel)\n (Language.Finkel.Fnk [FnkEnv])\n\n ;; finkel-tool\n (Finkel.Tool.Internal.Macro.Ghc)))\n\n(defn (:: ghcTests Spec)\n imports-from-ghc-test)\n\n(defn (:: expand-form (-> Macro Code Code Expectation))\n (expand-form-with-env defaultFnkEnv shouldBe))\n\n(defn (:: expand-form-with-env (-> FnkEnv\n (-> Code Code Expectation)\n Macro Code Code Expectation))\n [fnk-env test macro in-form out-form]\n (>>= (try (runFnk (macroFunction macro in-form) fnk-env))\n (either (. expectationFailure (show @ SomeException))\n (flip test out-form))))\n\n(defn (:: imports-from-ghc-test Spec)\n (describe \"imports-from-ghc-test\"\n (it \"should return import declarations\"\n (expand-form\n imports-from-ghc\n '(imports-from-ghc\n (GHC.Driver.Env [(HscEnv ..)])\n (GHC.Types.SourceText [(SourceText ..)])\n (GHC.Utils.Outputable [SDoc]))\n (cond-expand\n [(<= 902 :ghc)\n '(:begin\n (import GHC.Driver.Env ((HscEnv ..)))\n (import GHC.Types.SourceText ((SourceText ..)))\n (import GHC.Utils.Outputable (SDoc)))]\n [(<= 900 :ghc)\n '(:begin\n (import GHC.Driver.Types ((HscEnv ..)))\n (import GHC.Types.Basic ((SourceText ..)))\n (import GHC.Utils.Outputable (SDoc)))]\n [otherwise\n '(:begin\n (import HscTypes ((HscEnv ..)))\n (import BasicTypes ((SourceText ..)))\n (import Outputable (SDoc)))])))))\n" }, { "path": "finkel-tool/test/MainTest.hs", "content": ";;; -*- mode: finkel -*-\n;;; Tests for main function\n\n(defmodule MainTest\n (export mainTests)\n (import-when [:compile]\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Concurrent [forkIO killThread threadDelay])\n (Control.Exception [bracket])\n (Control.Monad.IO.Class [(MonadIO ..)])\n (Data.Version [showVersion])\n (System.Environment [getEnvironment setEnv withArgs])\n\n ;; directory\n (System.Directory [makeAbsolute withCurrentDirectory])\n\n ;; filepath\n (System.FilePath [])\n\n ;; finkel-core\n (qualified Paths_finkel_core)\n\n ;; hspec\n (Test.Hspec)\n\n ;; Internal\n (Finkel.Tool.Command)\n (Finkel.Tool.Command.Help)\n (Finkel.Tool.Command.Version)\n (Finkel.Tool.Internal.CLI)\n (Finkel.Tool.Internal.Commit)\n (Finkel.Tool.Main)\n (TestAux)))\n\n;;; Tests\n\n(defn (:: mainTests Spec)\n (do cliTests\n helpTests\n evalTests\n replTests\n runTests\n sdistTests\n versionTests))\n\n(defn (:: cliTests Spec)\n (do (describe \"main with no argument\"\n (it \"should start repl\"\n (do (<- tid (forkIO (main' [])))\n (threadDelay 20000)\n (killThread tid))))\n (describe \"main with invalid command\"\n (it \"should show usage\"\n (main' [\"no-such-command\"])))\n (describe \"main with help command\"\n (do (it \"should show usage\"\n (main' [\"help\"]))\n (it \"should show help of repl command\"\n (main' [\"help\" \"repl\"]))\n (it \"should show help of make command\"\n (main' [\"help\" \"make\"]))))\n (describe \"main with make command\"\n (it \"should show help on --fnk-help\"\n (main' [\"make\" \"--fnk-help\"])))\n (describe \"main with version command\"\n (it \"should show version message by default\"\n (main' [\"version\"])))))\n\n(defn (:: helpTests Spec)\n (describe \"help command\"\n (it \"should contain command names in usage message\"\n (do (<- (, _ lns) (runTestIO (show-usage commands) []))\n (lept [messageShouldContain (shouldContain\n (unlines (tst-outputs lns)))])\n (messageShouldContain \"eval\")\n (messageShouldContain \"repl\")\n (messageShouldContain \"make\")\n (messageShouldContain \"version\")))))\n\n(defn (:: evalTests Spec)\n (describe \"eval command\"\n (do (lefn [(failure [args]\n (shouldThrow (main' args) anyExitFailure))])\n (it \"should show help with --help\"\n (main' [\"eval\" \"--help\"]))\n (it \"should understand debug option\"\n (main' [\"eval\" \"--fnk-verbosity=3\" \"(not False)\"]))\n (it \"should evaluate '(+ 1 2 3 4 5)'\"\n (main' [\"eval\" \"(+ 1 2 3 4 5)\"]))\n (it \"should load module and evaluate given form\"\n (main' [\"eval\" (++ \"-i\" test-data-dir) \"LoadMe\"\n \"(from-load-me \\\"LOADED\\\")\"]))\n (it \"should show error message when invoked without form\"\n (failure [\"eval\"]))\n (it \"should exit with non-zero on compile error\"\n (failure [\"eval\" \"(+ 1 True)\"]))\n (it \"should exit with non-zero on parse error\"\n (failure [\"eval\" \"(+ 1 True)))\"])))))\n\n(defn (:: replTests Spec)\n (lept [print-int (test-data \"print-int.hs\")\n print-load-me (test-data \"print-load-me.hs\")\n err001 (test-data \"Err001.fnk\")]\n (describe \"repl command\"\n (do (it \"should show help on --help\"\n (main' [\"repl\" \"--help\"]))\n (it \"should show warning messages\"\n (main' [\"repl\" (++ \"--file=\" print-int) \"-v2\" \"-O\"]))\n (it \"should evaluate file contents after loading module\"\n (main' [\"repl\" \"--quiet\" (++ \"--file=\" print-load-me)\n (test-data \"LoadMe.hs\")]))\n (it \"should show compilation error when loading invalid module\"\n (shouldThrow\n (main' [\"repl\" \"--quiet\" (++ \"--file=\" print-int) print-int])\n anyExitFailure))\n (it \"should show load failure with type error on load\"\n (shouldThrow\n (main' [\"repl\" \"--quiet\" (++ \"--file=\" print-int) err001])\n anyExitFailure))\n (it \"should compilain missing argument\"\n (shouldThrow\n (main' [\"repl\" (++ \"--file=\" print-int) \"--prompt\"])\n anyExitFailure))))))\n\n(defn (:: runTests Spec)\n (lefn [(run [args]\n (main' (: \"run\" args)))\n (failure [args]\n (shouldThrow (run args) anyExitFailure))]\n (describe \"run command\"\n (do (it \"should show help on --help\"\n (run [\"--help\"]))\n (it \"should run run-me.hs\"\n (run [\"-v0\" (test-data \"run-me.hs\")]))\n (it \"should search directory with ghc option\"\n (pendingWith \"needs full path\"))\n (it \"should run given function\"\n (run [\"-v0\" \"--main\" \"main-two\" (test-data \"RunMeToo.hs\")]))\n (it \"should pass arguments after `--'\"\n (run [\"-v0\" \"--main\" \"main-three\" (test-data \"RunMeToo.hs\")\n \"--\" \"dog\"]))\n (it \"should complain with malformed argument\"\n (failure [\"-v0\" \"--main\"]))\n (it \"should fail when input file does not exist\"\n (failure [\"-v0\" \"no-such-file.fnk\"]))\n (it \"should exit with status from given script\"\n (failure [\"-v0\" \"--main\" \"main-three\" (test-data \"RunMeToo.hs\")\n \"--\" \"elephant\"]))))))\n\n(defn (:: sdistTests Spec)\n (describe \"sdist command\"\n (do (lept [sdist (. main' (: \"sdist\"))\n failure (. (flip shouldThrow anyExitFailure) sdist)])\n (it \"should show help message\"\n (sdist [\"--help\"]))\n (it \"should list options\"\n (sdist [\"--list-options\"]))\n (it \"should list sources\"\n (sdist [\"--list-sources=sources\" (test-data \"p02\")]))\n (it \"should make tarball with .cabal in current directory\"\n (sdist []))\n (it \"should make tarball with .cabal in given directory\"\n (do (<- builddir (makeAbsolute (test-data \"sdist\")))\n (sdist [\"--verbose=2\"\n (++ \"--builddir=\" builddir)\n (test-data \"p02\")])))\n (it \"should fail without .cabal file in current directory\"\n (withCurrentDirectory \"..\" (failure [])))\n (it \"should show error on invalid argument\"\n (failure [\"--foo\"])))))\n\n(defn (:: versionTests Spec)\n (describe \"version command\"\n (do (lefn [(version [args]\n (fmap (. unlines (. tst-outputs snd))\n (liftIO (runTestIO (versionMain args) []))))])\n (it \"should not throw exceptions with git command\"\n (do (<- commit-id (liftIO get-git-commit))\n (quietly (print commit-id))))\n (it \"should not throw exception when git command is not found\"\n (cond-expand\n ;; The use of `setEnv' may have problem under Windows ...\n [(/= :os \"mingw32\")\n (do (<- mb-commit-id (liftIO (with-tmp-env [(, \"PATH\" \".\")]\n get-git-commit)))\n (shouldBe mb-commit-id Nothing))]\n [otherwise\n (pendingWith \"problem with `setEnv'\")]))\n (it \"should show ghc version in default message\"\n (do (<- msg (version []))\n (shouldContain msg \"ghc\")))\n (it \"should show \\\"--help\\\" in help message\"\n (do (<- msg (version [\"--help\"]))\n (shouldContain msg \"--help\")))\n (it \"should show numeric version with \\\"--numeric\\\" option\"\n (do (<- msg (version [\"--numeric\"]))\n (shouldContain msg (showVersion Paths_finkel_core.version))))\n (it \"should complain unrecognized option\"\n (do (<- msg (version [\"--no-such-option\"]))\n (shouldContain msg \"--no-such-option\"))))))\n\n;;; Auxiliary\n\n(defn (:: with-tmp-env (-> [(, String String)] (IO a) (IO a)))\n [envvars act]\n (bracket getEnvironment\n (mapM_ (uncurry setEnv))\n (const (>> (mapM_ (uncurry setEnv) envvars) act))))\n\n(defn (:: main' (-> [String] (IO ())))\n (. quietly (flip withArgs defaultMain)))\n\n(defn (:: anyExitFailure (Selector ExitCode))\n [(ExitFailure _)] True\n [_] False)\n\n(defn (:: test-data-dir FilePath)\n ( \"test\" \"data\"))\n\n(defn (:: test-data (-> FilePath FilePath))\n ( test-data-dir))\n\n" }, { "path": "finkel-tool/test/ReplMacroTest.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Tests for REPL macros\n\n(defmodule ReplMacroTest\n (export replMacroTests)\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Exception [catch throw])\n (Data.List [intercalate isSubsequenceOf])\n (System.IO.Error [isDoesNotExistError])\n\n ;; filepath\n (System.FilePath [])\n\n ;; directory\n (System.Directory [getCurrentDirectory getTemporaryDirectory removeFile])\n\n ;; hspec\n (Test.Hspec)\n\n ;; finkel-core\n (Finkel.Prelude)\n\n ;; Internal\n (TestAux)))\n\n(defn (:: replMacroTests (-> EvalTestFns Spec))\n [etf]\n (cond-expand\n [(== :os \"mingw32\")\n (it \"should skip under Windows\"\n (pendingWith \"Windows not yet supported\"))]\n [otherwise (replMacroTests-1 etf)]))\n\n(defn (:: replMacroTests-1 (-> EvalTestFns Spec))\n [(EvalTestFns {(= etf-ok ok) (= etf-ng ng) (= etf-satisfy satisfy)})]\n (do (<- current-dir (runIO getCurrentDirectory))\n (<- tmp-dir (runIO getTemporaryDirectory))\n (lefn [(testdata [name]\n ( \"test\" \"data\" name))\n (delines (intercalate \"\\n\"))\n (m02-dot-hs ( tmp-dir \"m02.hs\"))\n (m02-dot-hi ( tmp-dir \"m02.hi\"))\n (main-dot-o ( tmp-dir \"Main.o\"))\n (clear-m02-files\n (mapM_ remove-if-exist [m02-dot-hs m02-dot-hi main-dot-o]))\n (with-right [form test]\n (satisfy form (either (const False) test)))\n (with-left [form test]\n (satisfy form (either test (const False))))\n (with-left-subseq [form str0]\n (satisfy form (either (isSubsequenceOf str0) (const False))))])\n (beforeAll_\n clear-m02-files\n (afterAll_\n clear-m02-files\n (do\n ;; !\n (ok '(repl-macro ! echo foo) \"\")\n\n ;; ?, help\n (with-right '(repl-macro ?)\n (isSubsequenceOf \",type EXPR\"))\n (with-right '(repl-macro help)\n (isSubsequenceOf \"show this help\"))\n\n ;; browse\n (with-right '(repl-macro browse Unsafe.Coerce)\n (isSubsequenceOf \"Unsafe.Coerce.unsafeCoerce :: a -> b\"))\n (with-left-subseq '(repl-macro browse foo bar)\n \"browse: invalid form `foo'\")\n\n ;; cd\n (ok `(repl-macro cd ,current-dir) \"\")\n (ok `(repl-macro cd ,(testdata \"\")) \"\")\n (ok '(repl-macro cd ../../) \"\")\n (with-left `(repl-macro cd (foo bar) buzz)\n (isSubsequenceOf \"invalid form\"))\n\n ;; expand\n (ok '(repl-macro expand\n (defn f (where g (defn g [x] (print (++ \"g: \" x))))))\n \"(= f (where g (defn g [x] (print (++ \\\"g: \\\" x)))))\")\n (ok '(repl-macro expand) \"\")\n (with-left-subseq '(repl-macro expand foo bar)\n \"expand: invalid form `foo'\")\n\n ;; expand!\n (ok '(repl-macro expand!\n (defn f (where g (defn g [x] (print (++ \"g: \" x))))))\n \"(= f (where g (= g x (print (++ \\\"g: \\\" x)))))\")\n\n ;; info\n (ok '(repl-macro info putStr)\n (cond-expand\n [(<= 910 :ghc)\n \"putStr :: String -> IO () \\t-- Defined in ‘GHC.Internal.System.IO’\"]\n [otherwise\n \"putStr :: String -> IO () \\t-- Defined in ‘System.IO’\"]))\n (ok '(repl-macro info ++)\n (cond-expand\n [(<= 910 :ghc)\n \"(++) :: [a] -> [a] -> [a] \\t-- Defined in ‘GHC.Internal.Base’\\n\\\n \\infixr 5 ++\"]\n [otherwise\n \"(++) :: [a] -> [a] -> [a] \\t-- Defined in ‘GHC.Base’\\n\\\n \\infixr 5 ++\"]))\n (with-right '(repl-macro info ())\n (isSubsequenceOf \"instance Show ()\"))\n (with-right '(repl-macro info [])\n (isSubsequenceOf\n (cond-expand\n [(<= 906 :ghc)\n \"data List a = [] | a : [a]\"]\n [otherwise\n \"data [] a = [] | a : [a]\"])))\n\n ;; kind\n (ok '(repl-macro kind Maybe)\n \"Maybe :: * -> *\")\n (with-left-subseq '(repl-macro kind (foo bar) buzz)\n \"kind: invalid form `(foo bar)'\")\n\n ;; pwd\n (ok '(repl-macro pwd) (show current-dir))\n\n ;; set\n (ok '(repl-macro set -foo -bar -buzz) \"\")\n (ok '(repl-macro set --fnk-verbose=3) \"\")\n (ok '(repl-macro set --fnk-verbose=1) \"\")\n (ng '(repl-macro set)\n \": error: set: empty form\")\n\n ;; show\n (ok '(defn (:: f1 (-> Int Int)) [n] (+ n 1))\n \"; f1 :: Int -> Int\")\n (with-right '(repl-macro show bindings)\n (. (elem \"f1 :: Int -> Int = _\") lines))\n (with-right '(class (C a) (:: cm1 (-> a Int)))\n (. (elem \"; Class ‘C’\") lines))\n (with-right '(repl-macro show bindings)\n (. (elem \"class C a\") lines))\n (lept [interpreter-backend-line\n (cond-expand\n [(<= 906 :ghc)\n \"; backend: byte-code interpreter\"]\n [(<= 902 :ghc)\n \"; backend: Interpreter\"]\n [otherwise\n \"; backend: HscInterpreted\"])])\n (ok '(repl-macro show context)\n (delines\n [\"; context\"\n \"; IIDecl: import Prelude\"]))\n (ok '(repl-macro show dflags)\n (delines\n [\"; dflags:\"\n \"; ghcLink: LinkInMemory\"\n \"; ghcMode: CompManager\"\n interpreter-backend-line\n \"; objectDir: Nothing\"\n \"; homeUnitId: main\"\n \"; forceRecomp: False\"]))\n (ok '(:begin\n (repl-macro set -odir /tmp)\n (repl-macro show dflags))\n (delines\n [\"; dflags:\"\n \"; ghcLink: LinkInMemory\"\n \"; ghcMode: CompManager\"\n interpreter-backend-line\n \"; objectDir: Just \\\"/tmp\\\"\"\n \"; homeUnitId: main\"\n \"; forceRecomp: False\"]))\n (ok '(repl-macro show hpt)\n \"show: no home package table found\")\n (ok '(repl-macro show language)\n (delines\n (cond-expand\n [(<= 902 :ghc)\n [\"base language is: GHC2021\"\n \"with the following modifiers:\"]]\n [otherwise\n [\"base language is: Haskell2010\"\n \"with the following modifiers:\"\n \" -XNoDatatypeContexts\"\n \" -XNondecreasingIndentation\"]])))\n ;; show linker command uses 'showLinkerState' from ghc package,\n ;; which does printing action, so not returning 'String' value.\n (ok '(repl-macro show linker) \"\")\n (with-right '(repl-macro show macros)\n (. (elem \"; defmacroM'\") lines))\n (ok '(repl-macro show modules) \"\")\n (with-right '(repl-macro show options)\n (isSubsequenceOf \"-fimplicit-import-qualified\"))\n (with-right '(repl-macro show options!)\n (isSubsequenceOf \"-Wno-orphans\"))\n (with-right '(repl-macro show packages)\n (isSubsequenceOf \"; packages\"))\n (with-right '(:begin\n (repl-macro set -hide-package bytestring)\n (repl-macro show packages))\n (isSubsequenceOf \"hiding\"))\n (ok '(repl-macro show paths)\n (concat\n [\"; current working directory:\\n\"\n \"; \" current-dir \"\\n\"\n \"; module import search paths:\\n\"\n \"; .\"]))\n (ok '(repl-macro show targets)\n \"; targets: none\")\n (with-left '(repl-macro show (foo bar) buzz)\n (isSubsequenceOf \"targets\"))\n\n ;; type\n (ok '(repl-macro type putStrLn)\n \"putStrLn :: String -> IO ()\")\n (ok '(repl-macro type (foldr + (:: 0 Int)))\n \"(foldr + (:: 0 Int)) :: Foldable t => t Int -> Int\")\n (ok '(repl-macro type 'x)\n \"(:quote x) :: Language.Finkel.Form.Code\")\n (with-left-subseq '(repl-macro type (foo bar) buzz)\n \"type: invalid form `(foo bar)'\")\n\n ;; verbose\n (ok '(repl-macro verbose) \"Verbosity level is 1\")\n (ok '(repl-macro verbose 2)\n \"Verbosity level set to 2\")\n (ok '(repl-macro verbose 1)\n \"Verbosity level set to 1\")\n\n ;; load and reload\n (lept [m01-dot-hs (testdata \"m01.hs\")])\n (ok `(:begin\n (repl-macro load ,(make-symbol m01-dot-hs))\n main)\n \"=== m01.fnk ===\")\n (ok '(repl-macro reload)\n \"; reloaded test/data/m01.hs\")\n (ok '(repl-macro browse)\n (delines\n [\"main :: IO ()\"\n \"foo :: String\"\n \"bar :: Int -> Int\"]))\n\n (ok '(repl-macro show targets)\n (cond-expand\n [(<= 904 :ghc) \"; targets: main:test/data/m01.hs\"]\n [(<= 902 :ghc) \"; targets: test/data/m01.hs\"]\n [otherwise \"; targets: *test/data/m01.hs\"]))\n (with-right '(repl-macro show context)\n (isSubsequenceOf \"IIModule: Main\"))\n\n (ok `(writeFile ,m02-dot-hs \";;; m02.hs\\n(defn main (print True))\")\n \"\")\n (cond-expand\n [(== :os \"darwin\")\n (describe \"evaluate (repl-macro load m02.fnk)\"\n (it \"should skip under darwin\"\n (pendingWith \"OSX not supported yet\")))]\n [otherwise\n (ok `(:begin\n (repl-macro load ,(make-symbol m02-dot-hs))\n main)\n \"True\")])\n (ok `(writeFile ,m02-dot-hs \";;; m02.hs\\n(defn main (print False))\")\n \"\")\n\n (cond-expand\n [(== :os \"darwin\")\n (describe \"evaluate (repl-macro reload)\"\n (it \"should skip under darwin\"\n (pendingWith \"OSX not supported yet\")))]\n [otherwise\n (ok '(repl-macro reload)\n (++ \"; reloaded \" m02-dot-hs))])\n (cond-expand\n [(== :os \"darwin\")\n (describe \"evaluate main\"\n (it \"should skip under darwin\"\n (pendingWith \"OSX not supported yet\")))]\n [otherwise\n (ok 'main \"False\")])\n\n ;; Compiling object code\n (cond-expand\n [(== :os \"darwin\")\n (describe \"Compiling object code\"\n (it \"should be skipped under darwin\"\n (pendingWith \"OSX not supported yet\")))]\n [otherwise\n (do\n (ok `(writeFile ,m02-dot-hs \";;; m02.hs\\n(defn main (print True))\") \"\")\n (ok `(:begin\n (repl-macro set -fobject-code)\n (repl-macro load ,m02-dot-hs)\n main)\n \"True\")\n (ok '(repl-macro reload)\n (++ \"; reloaded \" m02-dot-hs)))])\n\n ;; Errors\n (with-left-subseq '(repl-macro load (foo bar))\n \"load: not a FilePath: (foo bar)\")\n (with-left-subseq '(repl-macro load (foo bar) buzz)\n \"load: invalid form `(foo bar)'\")\n\n ;; Calling functions from Prelude after load error:\n (ok '(:begin\n (repl-macro load /no/such/file.fnk)\n (print (not False)))\n \"True\")\n\n ;; Errors\n (with-left-subseq '(repl-macro info (foo bar))\n \"info: invalid form `(foo bar)'\")\n (with-left-subseq '(repl-macro)\n \"invalid args: nil\"))))))\n\n(defn (:: remove-if-exist (-> FilePath (IO ())))\n [path]\n (catch (removeFile path)\n (\\e (if (isDoesNotExistError e)\n (return ())\n (throw e)))))\n" }, { "path": "finkel-tool/test/ReplTest.hs", "content": ";;; -*- mode: finkel -*-\n;;; Tests for REPL.\n\n%p(LANGUAGE OverloadedStrings)\n%p(OPTIONS_GHC -Wno-orphans)\n\n(defmodule ReplTest\n (export replTests listenTests)\n (require\n ;; finkel-tool\n (Finkel.Tool.Internal.Macro.Ghc))\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Concurrent\n [forkIO newEmptyMVar killThread putMVar takeMVar threadDelay yield])\n (Control.Exception [IOException finally throwIO])\n (qualified Control.Exception as ControlException)\n (Control.Monad [forever replicateM_ when])\n (Data.List [isSubsequenceOf])\n (Data.String [(IsString ..)])\n (GHC.Conc [(ThreadStatus ..) threadStatus])\n (GHC.IO.Exception [(AsyncException ..)])\n\n ;; filepath\n (System.FilePath [])\n\n ;; haskeline\n (System.Console.Haskeline [defaultSettings runInputT])\n\n ;; hspec\n (Test.Hspec)\n\n ;; network\n (Network.Socket\n [(AddrInfo ..) (SocketType ..) close connect defaultHints getAddrInfo\n socket])\n (Network.Socket.ByteString [sendAll recv])\n\n ;; finkel-kernel\n (Language.Finkel)\n\n ;; Internal\n (Finkel.Tool.Command.Repl)\n (Finkel.Tool.Internal.IO)\n (Finkel.Tool.Internal.Types)\n (TestAux)))\n\n(imports-from-ghc\n (GHC.Data.StringBuffer (StringBuffer stringToStringBuffer)))\n\n\n;;; Extra imports\n\n(cond-expand\n [(<= 810 :ghc)\n (import Control.Monad.Catch\n ((MonadThrow ..) (MonadCatch ..) (MonadMask ..)))]\n [otherwise\n (:begin)])\n\n(cond-expand\n [(:min-version \"base\" 4 11 0)\n (:begin)]\n [otherwise\n (import Data.Monoid (<>))])\n\n;;; Exported test\n\n(defn (:: replTests (-> EvalTestFns Spec))\n [etf]\n (do (describe \"ReplState\" replStateTests)\n (describe \"Exception\" exceptionTests)\n (describe \"Read\" readTests)\n (describe \"ReadPrint\" readPrintTests)\n (describe \"Eval\"\n (cond-expand\n [(== :os \"mingw32\")\n (it \"should be skipped under Windows\"\n (pendingWith \"Windows not supported yet\"))]\n [otherwise (evalTests etf)]))))\n\n(defn (:: listenTests (-> EvalTestFns Spec))\n [etf]\n (describe \"Listen\"\n (cond-expand\n [(== :os \"mingw32\")\n (it \"should be skipped under Windows\"\n (pendingWith \"Windows not supported yet\"))]\n [otherwise (listenTests1 etf)])))\n\n;;; Orphan\n\n(instance (IsString StringBuffer)\n (= fromString stringToStringBuffer))\n\n;;; Internal\n\n(defn (:: replStateTests Spec)\n (do (lept [rs1 (mempty {(= pending-input (Just \"(foo\"))})\n rs2 (mempty {(= pending-input (Just \" bar)\"))})])\n (describe \"Show instance\"\n (it \"should show pending inputs\"\n (shouldBe\n (show rs1)\n \"ReplState {pending_input = Just , \\\n\\prompt_string = \\\"> \\\"}\")))\n (describe \"Eq instance\"\n (do (it \"should be itself\" (shouldBe rs1 rs1))\n (it \"should not be different pending input\"\n (shouldNotBe rs1 rs2))))\n (describe \"Monoid laws for ReplState\"\n (do (it \"should have an identity element\"\n (shouldBe (<> mempty rs1) rs1))\n (it \"should satisfy associativity law\"\n (shouldBe (<> (<> rs1 mempty) rs2)\n (<> rs1 (<> mempty rs2))))))\n (describe \"get and put ReplState for InputT\"\n (do (lept [act (run-repl (runInputT defaultSettings work) mempty)\n work (>> (putReplState mempty) getReplState)])\n (it \"should return the given ReplState\"\n (shouldReturn act mempty))))\n (lept [run-repl' (flip run-repl mempty)\n repl1 (pure True)])\n (describe \"Functor instance of Repl\"\n (do (it \"should satisfy identity law\"\n (shouldReturn (run-repl' (fmap id repl1)) True))\n (it \"should satisfy composition law\"\n (shouldReturn\n (run-repl' (fmap show (fmap not repl1)))\n (show (not True))))\n (it \"should return second arg with <$\"\n (shouldReturn\n (run-repl' (<$ True (pure False)))\n True))))\n (describe \"Applicative instance of Repl\"\n (it \"should satisfy applicative law\"\n (shouldReturn\n (run-repl' (<*> (pure not) repl1))\n False)))))\n\n(defn (:: do-repl (-> (Repl a) (IO a)))\n (flip run-repl initial-repl-state))\n\n(defn (:: exceptionTests Spec)\n (describe \"exceptions instances for REPL\"\n (cond-expand\n [(<= 810 :ghc)\n (do (lept [throw-sof-on-no-input\n (>>= getReplState\n (. (maybe (throwM StackOverflow)\n (const (return 42)))\n pending-input))])\n (it \"should throw exception\"\n (shouldThrow (do-repl (throwM StackOverflow)) anyException))\n (it \"should catch exception\"\n (lefn [(act (catch throw-sof-on-no-input handler))\n (:: handler (-> AsyncException (Repl Int)))\n (handler [ae]\n (do (<- st getReplState)\n (case (, ae (pending-input st))\n (, StackOverflow Nothing) (return 42)\n _ (throwM ae))))]\n (shouldReturn (do-repl act) 42)))\n (it \"should throw exception from mask when unmasked\"\n (lept [act (mask (\\unmask\n (unmask throw-sof-on-no-input)))]\n (shouldThrow (do-repl act) anyException)))\n (it \"should throw exception from uninterruptibleMask when unmasked\"\n (lept [act (uninterruptibleMask\n (\\unmask\n (unmask throw-sof-on-no-input)))]\n (shouldThrow (do-repl act) anyException))))]\n [otherwise\n (it \"should throw, catch, and mask exceptions as necessary\"\n (pendingWith \"... on newer versions of ghc\"))])))\n\n(defn (:: readTests Spec)\n (do (describe \"reading single line form\"\n (it \"returns '(foo bar buzz)\"\n (do (<- form (do-repl (read-form \"(foo bar buzz)\")))\n (shouldBe form (Just '(foo bar buzz))))))\n (describe \"reading multi line form\"\n (it \"returns '(a b c)\"\n (do (<- form (do-repl (do (<- _ (read-form \"(a \"))\n (<- _ (read-form \"b \"))\n (read-form \"c)\"))))\n (shouldBe form (Just '(a b c))))))))\n\n(defn (:: readPrintTests Spec)\n (describe \"read and print loop\"\n (do (rptest \"multi line form\" [\"(print\" \"(+\" \"10\" \"32\" \"))\"])\n (rptest \"quitting with \\\"(quit)\\\"\" [\"(quit)\"])\n (rptest \"\\\",t\\\" command\" [\",t False\"])\n (rptest \"\\\",!\\\" command\" [\",! echo foo bar\"])\n (rptest \"\\\",q\\\" command\" [\",q\"]))))\n\n(defn (:: rptest (-> String [String] Spec))\n [label inputs]\n (lept [run (do (<- in-mv newEmptyMVar)\n (<- tid (forkIO (forever\n (do (<- (Input _ _ out-mv) (takeMVar in-mv))\n (putMVar out-mv (Right \"\"))))))\n (return (, in-mv tid)))]\n (describe label\n (it \"should have no pending inputs\"\n (do (<- (, in-mv tid) run)\n (<- (, _ tst) (runTestIO (read-print-loop nil in-mv tid) inputs))\n (finally\n (shouldSatisfy (pending-input (tst-replstate tst)) null)\n (killThread tid)))))))\n\n(defn (:: evalTests (-> EvalTestFns Spec))\n [(EvalTestFns {(= etf-ok ok) (= etf-satisfy satisfy)})]\n (do\n ;; Statements and declarations\n (ok '(+ 10 32) \"42\")\n (ok '(defn (:: f1 (-> Int Int))\n [n]\n (+ n 1))\n \"; f1 :: Int -> Int\")\n (ok '(f1 41) \"42\")\n (ok '(:begin\n (:: x y Int)\n (= x 1)\n (= y 2))\n \"; x :: Int\\n; y :: Int\")\n (ok '(<- z (return True)) \"\")\n (ok '(defn (:: f2 (-> (Maybe Int) Int))\n [(Just n)] (* n 2)\n [Nothing] 0)\n \"; f2 :: Maybe Int -> Int\")\n (ok '(f2 (Just 21)) \"42\")\n (ok '(data Foo (Foo Int))\n (concat [\"; $tcFoo :: TyCon\\n\"\n \"; $tc'Foo :: TyCon\\n\"\n \"; Type constructor ‘Foo’\"]))\n\n ;; Import\n (ok '(import Control.Monad)\n \"; import Control.Monad\")\n (ok '(import qualified Data.Functor as DF)\n \"; import qualified Data.Functor as DF\")\n (ok '(import Control.Monad (liftM ap))\n \"; import Control.Monad ( liftM, ap )\")\n\n ;; Eval wrapper\n (ok 'System.Environment.getArgs \"[]\")\n\n ;; Expansion quoted codes in REPL\n (ok '(macroexpand ''foo)\n \"(:quote foo)\")\n\n ;; Exported macros\n (satisfy '(exported-macros Finkel.Core)\n (lcase\n (Right str) (isSubsequenceOf \"defmacro\" str)\n _ False))\n\n ;; Errors\n (satisfy 'buzz\n (lcase\n (Left str) (isSubsequenceOf \"Variable not in scope: buzz\" str)\n _ False))\n (satisfy '(= f a (+ a 1) (+ a 2))\n (lcase\n (Left str) (isSubsequenceOf \"syntax error on input\" str)\n _ False))\n\n (satisfy '(head [])\n (lcase\n (Left str) (isSubsequenceOf \"*** Exception: Prelude.head: empty list\"\n str)\n _ False))))\n\n(defn (:: listenTests1 (-> EvalTestFns Spec))\n [(EvalTestFns {(= etf-tid etid)})]\n (lefn [(short-pause\n (threadDelay 50000))\n (wait-until-killed [tid]\n (do (<- st (threadStatus tid))\n (putStrLn (++ \"listenTests1: \" (show st)))\n (when (notElem st [ThreadFinished ThreadDied])\n (do short-pause\n (wait-until-killed tid)))))\n (acquire\n (do (wait-until-killed etid)\n (<- tid (forkIO\n ;; Passing a file to work for, so that the REPL thread\n ;; will not terminate before the testing client connect.\n (replMain [(++ \"--listen=\" port)\n (++ \"--file=\" input-file)\n \"--prompt=\"\n \"--quiet\"])))\n ;; Pause for a bit after forking the server action.\n (replicateM_ 5 short-pause)\n (<- addr (resolve \"127.0.0.1\" port))\n (<- conn (socket (addrFamily addr)\n (addrSocketType addr)\n (addrProtocol addr)))\n (with-retry (:: 20 Int)\n (connect conn (addrAddress addr)))\n (return (, conn tid))))\n (with-retry [n act]\n (ControlException.catch act\n (\\e\n (if (< 0 n)\n (do yield\n short-pause\n (with-retry (- n 1) act))\n (throwIO (:: e IOException))))))\n (release [(, conn tid)]\n (do (sendAll conn \",quit\")\n (<- _msg (recv conn 1024))\n (close conn)\n (killThread tid)))\n (port \"50322\")\n (input-file ( \"test\" \"data\" \"sleep-for-while.fnk\"))\n (resolve [host portnum]\n (lefn [(hints (defaultHints {(= addrSocketType Stream)}))]\n (case-do (getAddrInfo (Just hints) (Just host) (Just portnum))\n (: addr _) (return addr)\n _ (error \"REPL client: address error\"))))\n (work [(, conn _)]\n (do (<- _msg1 (recv conn 1024))\n (sendAll conn \"(* 7 (+ 4 2))\")\n (recv conn 1024)))\n (listener-test\n (describe \"listener\"\n (it \"evaluates a form sent from connected client\"\n (\\args (shouldReturn (work args) \"42\")))))]\n (before acquire (after release listener-test))))\n" }, { "path": "finkel-tool/test/Spec.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule Main\n (import\n ;; hspec\n (Test.Hspec)\n\n ;; Internal\n (CLITest)\n (GhcTest)\n (MainTest)\n (ReplMacroTest)\n (ReplTest)\n (TestAux)))\n\n(defn (:: main (IO ()))\n (do (<- etf makeEvalTestFns)\n (hspec (do (afterAll-\n (etf-cleanup etf)\n (do (describe \"CLITest\" cliTests)\n (describe \"GhcTest\" ghcTests)\n (describe \"MainTest\" mainTests)\n (describe \"ReplTest\" (replTests etf))\n (describe \"ReplMacroTest\" (replMacroTests etf))))\n (listenTests etf)))))\n\n" }, { "path": "finkel-tool/test/TestAux.hs", "content": ";;; -*- mode: finkel -*-\n;;;; Auxiliary codes for tests\n\n(defmodule TestAux\n (export (TestIO ..) (TestIOState ..) runTestIO\n (EvalTestFns ..) makeEvalTestFns quietly)\n (require\n ;; finkel-core\n (Finkel.Tool.Internal.Macro.Ghc))\n (import-when [:compile]\n ;; finkel-core\n (Finkel.Prelude))\n (import\n ;; base\n (Control.Concurrent\n [ThreadId newEmptyMVar killThread putMVar takeMVar])\n (Control.Monad [mplus])\n (Control.Monad.IO.Class [(MonadIO ..)])\n (Data.Function [on])\n (System.Environment [lookupEnv])\n (System.IO [stderr stdout])\n\n ;; filepath\n (System.FilePath [])\n\n ;; hspec\n (Test.Hspec)\n\n ;; silently\n (System.IO.Silently [hSilence])\n\n ;; finkel-kernel\n (Language.Finkel)\n\n ;; Internal\n (Finkel.Tool.Command.Repl)\n (Finkel.Tool.Internal.CLI)\n (Finkel.Tool.Internal.Eval)\n (Finkel.Tool.Internal.Loop)\n (Finkel.Tool.Internal.Types)))\n\n(imports-from-ghc\n (GHC.Settings.Config (cProjectVersion)))\n\n\n;;; Extra imports\n\n(cond-expand\n [(:min-version \"base\" 4 11 0)\n (:begin)]\n [otherwise\n (import Data.Monoid (<>))])\n\n;;; Test IO\n\n(data TestIOState\n (TestIOState {(:: tst-inputs [String])\n (:: tst-outputs [String])\n (:: tst-exitcode (Maybe ExitCode))\n (:: tst-replstate ReplState)}))\n\n(instance (Monoid TestIOState)\n (= mempty emptyTestIOState)\n (cond-expand\n [(:min-version \"base\" 4 16 0)\n (:begin)]\n [otherwise\n (= mappend appendTestIOState)]))\n\n(cond-expand\n [(:min-version \"base\" 4 11 0)\n (instance (Semigroup TestIOState)\n (= <> appendTestIOState))]\n [otherwise\n (:begin)])\n\n(defn (:: appendTestIOState (-> TestIOState TestIOState TestIOState))\n [s1 s2]\n (TestIOState\n {(= tst-inputs (on mappend tst-inputs s1 s2))\n (= tst-outputs (on mappend tst-outputs s1 s2))\n (= tst-exitcode (mplus (tst-exitcode s2) (tst-exitcode s1)))\n (= tst-replstate (on mappend tst-replstate s1 s2))}))\n\n(defn (:: emptyTestIOState TestIOState)\n (TestIOState {(= tst-inputs [])\n (= tst-outputs [])\n (= tst-exitcode Nothing)\n (= tst-replstate initial-repl-state)}))\n\n;;; Newtype wrapper to test IO actions, combination of TestIOState state\n;;; monad and IO.\n(newtype (TestIO a)\n (TestIO {(:: unTestIO (-> TestIOState (IO (, a TestIOState))))}))\n\n(defn (:: runTestIO (-> (TestIO a) [String] (IO (, a TestIOState))))\n [test-io inputs]\n (unTestIO test-io (mempty {(= tst-inputs inputs)})))\n\n(instance (Functor TestIO)\n (= fmap f (TestIO m)\n (TestIO (\\st0 (fmap (\\ (, a st) (, (f a) st)) (m st0))))))\n\n(instance (Applicative TestIO)\n (= pure x\n (TestIO (\\st (pure (, x st)))))\n (= <*> (TestIO ft) (TestIO xt)\n (TestIO (\\st0 (do (<- (, f st1) (ft st0))\n (<- (, x st2) (xt st1))\n (return (, (f x) st2)))))))\n\n(instance (Monad TestIO)\n (= return pure)\n (= >>= (TestIO m) k\n (TestIO (\\st0 (do (<- (, a st1) (m st0))\n (unTestIO (k a) st1))))))\n\n(instance (MonadIO TestIO)\n (= liftIO io\n (TestIO (\\st (fmap (\\x (, x st)) io)))))\n\n(instance (CLI TestIO)\n (= getString _prompt\n (TestIO (\\tst\n (case (tst-inputs tst)\n (: s rest) (lept [tst' (tst {(= tst-inputs rest)})]\n (pure (, (Just s) tst')))\n [] (pure (, Nothing tst))))))\n\n (= putString str\n (TestIO\n (\\st (lept [tst-outputs' (<> (tst-outputs st) [str])]\n (pure (, () (st {(= tst-outputs tst-outputs')})))))))\n\n ;;; XXX: Does nothing.\n (= handleInterrupt _handler act act)\n\n ;;; XXX: Does nothing.\n (= withInterrupt act act)\n\n (= exitWith ec\n (TestIO (\\st (pure (, () (st {(= tst-exitcode (Just ec))})))))))\n\n(instance (HasReplState TestIO)\n (= putReplState rst\n (TestIO (\\st (pure (, () (st {(= tst-replstate rst)}))))))\n (= getReplState\n (TestIO (\\st (pure (, (tst-replstate st) st))))))\n\n\n;;; Repl test environment\n\n(data EvalTestFns\n (EvalTestFns\n {(:: etf-ok (-> Code String Spec))\n (:: etf-ng (-> Code String Spec))\n (:: etf-satisfy (-> Code (-> Result Bool) Spec))\n (:: etf-cleanup (IO ()))\n (:: etf-tid ThreadId)}))\n\n(defn (:: if-ghc-package-path-is-set (=> (MonadIO m) (-> (m a) (m a) (m a))))\n \"Perform the first action if @GHC_PACKAGE_PATH@ is set in environment\n variable, otherwise perform the second.\"\n [set-act not-set-act]\n (case-do (liftIO (lookupEnv \"GHC_PACKAGE_PATH\"))\n (Just _) set-act\n Nothing not-set-act))\n\n(defn (:: init-etf-args-for-cabal (IO [String]))\n \"Initialization arguments for running eval tests with `cabal-install'.\"\n (lept [ghc-ver (++ \"ghc-\" cProjectVersion)\n inplacedb ( \"..\" \"dist-newstyle\" \"packagedb\" ghc-ver)\n args [\"-package-db\" inplacedb]]\n (pure args)))\n\n(defn (:: init-etf-args (IO [String]))\n \"Initialization arguments for `EvalTestFns'.\"\n (if-ghc-package-path-is-set (return []) init-etf-args-for-cabal))\n\n(defn (:: makeEvalTestFns (IO EvalTestFns))\n (do (<- out-mv newEmptyMVar)\n (<- (@ resources (, _tmpfile hdl in-mv)) acquire-repl)\n (<- ghc-args init-etf-args)\n (<- etid (fork-eval-loop ghc-args hdl in-mv repl-env))\n (lefn [(eval-form [right-or-left form expect]\n (describe (++ \"evaluate \" (show form))\n (it \"evaluates to expected result\"\n (quietly\n (do (putMVar in-mv (Input Connection form out-mv))\n (<- ret (takeMVar out-mv))\n (shouldBe ret (right-or-left expect)))))))\n (ok (eval-form Right))\n (ng (eval-form Left))\n (satisfy [form test]\n (describe (++ \"evaluate \" (show form))\n (it \"satisfies predicate\"\n (quietly\n (do (putMVar in-mv (Input Connection form out-mv))\n (<- ret (takeMVar out-mv))\n (shouldSatisfy ret test))))))\n (cleanup\n (do (killThread etid)\n (cleanup-repl resources)))])\n (putMVar in-mv (Input Connection '(:begin) out-mv))\n (<- _ (takeMVar out-mv))\n (return (EvalTestFns {(= etf-ok ok)\n (= etf-ng ng)\n (= etf-satisfy satisfy)\n (= etf-cleanup cleanup)\n (= etf-tid etid)}))))\n\n(defn (:: quietly (-> (IO a) (IO a)))\n (hSilence [stderr stdout]))\n" }, { "path": "finkel-tool/test/data/Err001.fnk", "content": "(defmodule Err001)\n\n(defn (:: foo (-> Int Int))\n [n]\n (+ (* n 2) 2))\n\n(defn (:: err01 (IO ()))\n (print (foo \"type error\")))\n" }, { "path": "finkel-tool/test/data/LoadMe.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule LoadMe\n (export from-load-me))\n\n(defn (:: from-load-me (-> String (IO ())))\n (. putStrLn (++ \"LoadMe.from-load-me: \")))\n" }, { "path": "finkel-tool/test/data/RunMeToo.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule RunMeToo\n (import\n (System.Environment (getArgs))\n (System.Exit (exitFailure))))\n\n(defn (:: main-one (IO ()))\n (putStrLn \"From RunMeToo.main-one\"))\n\n(defn (:: main-two (IO ()))\n (putStrLn \"From RunMeToo.main-two\"))\n\n(defn (:: main-three (IO ()))\n (do (<- args getArgs)\n (case args\n [\"dog\"] (putStrLn \"WUFF WUFF WUFF!\")\n [\"cat\"] (putStrLn \"MEOW MEOW MEOW!\")\n _ (>> (putStrLn \"I don't know what to do\")\n exitFailure))))\n\n(defn (:: main (IO ()))\n main-one)\n" }, { "path": "finkel-tool/test/data/input01.txt", "content": "First line\nSecond line\n" }, { "path": "finkel-tool/test/data/m01.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule Main\n (export main foo bar))\n\n(defn (:: main (IO ()))\n \"Main function of m01\"\n (putStrLn \"=== m01.fnk ===\"))\n\n(defn (:: foo String)\n \"A string value named foo.\"\n \"foo\")\n\n(defn (:: bar (-> Int Int))\n \"A function named bar\"\n [x]\n (* x (+ x 2)))\n" }, { "path": "finkel-tool/test/data/p02/LICENSE", "content": "Copyright Author name here (c) 2022\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "finkel-tool/test/data/p02/README.md", "content": "# p02\n" }, { "path": "finkel-tool/test/data/p02/Setup.hs", "content": "module Main where\nimport Distribution.Simple.Finkel\nmain :: IO ()\nmain = finkelMakeMain\n" }, { "path": "finkel-tool/test/data/p02/app/Main.hs", "content": "module Main where\n\nimport Lib\n\nmain :: IO ()\nmain = someFunc\n" }, { "path": "finkel-tool/test/data/p02/p02.cabal", "content": "name: p02\nversion: 0.1.0.0\n-- synopsis:\n-- description:\nhomepage: http://www.example.org\nlicense: BSD3\nlicense-file: LICENSE\nauthor: Author name here\nmaintainer: example@example.com\ncopyright: 2022 Author name here\ncategory: Data\nbuild-type: Custom\nextra-source-files: README.md\n src/*.fnk\ncabal-version: >=2.0\n\ncustom-setup\n setup-depends: base >= 4.7 && < 5\n , Cabal >= 2.0\n , finkel-setup\n\nlibrary\n hs-source-dirs: src\n exposed-modules: Lib\n build-depends: base >= 4.7 && < 5\n build-tool-depends: finkel:finkel\n default-language: Haskell2010\n\nexecutable p02\n hs-source-dirs: app\n main-is: Main.hs\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n build-depends: base\n , p02\n default-language: Haskell2010\n\ntest-suite p02-test\n type: exitcode-stdio-1.0\n hs-source-dirs: test\n main-is: Spec.hs\n build-depends: base\n , p02\n build-tool-depends: finkel:finkel\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n default-language: Haskell2010\n\n-- source-repository head\n-- type: git\n-- location: https://github.com/githubuser/p02\n" }, { "path": "finkel-tool/test/data/p02/src/Lib.fnk", "content": "(defmodule Lib\n (export someFunc))\n\n(defn (:: someFunc (IO ()))\n (putStrLn \"Hello from p02\"))\n" }, { "path": "finkel-tool/test/data/p02/stack.yaml", "content": "# This file was automatically generated by 'stack init'\n#\n# Some commonly used options have been documented as comments in this file.\n# For advanced use and comprehensive documentation of the format, please see:\n# https://docs.haskellstack.org/en/stable/yaml_configuration/\n\n# A warning or info to be displayed to the user on config load.\nuser-message: |\n 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.\n You can omit this message by removing it from stack.yaml\n\n# Resolver to choose a 'specific' stackage snapshot or a compiler version.\n# A snapshot resolver dictates the compiler version and the set of packages\n# to be used for project dependencies. For example:\n#\n# resolver: lts-3.5\n# resolver: nightly-2015-09-21\n# resolver: ghc-7.10.2\n#\n# The location of a snapshot can be provided as a file or url. Stack assumes\n# a snapshot provided as a file might change, whereas a url resource does not.\n#\n# resolver: ./custom-snapshot.yaml\n# resolver: https://example.com/snapshots/2018-01-01.yaml\nresolver:\n url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/13.yaml\n\n# User packages to be built.\n# Various formats can be used as shown in the example below.\n#\n# packages:\n# - some-directory\n# - https://example.com/foo/bar/baz-0.0.2.tar.gz\n# subdirs:\n# - auto-update\n# - wai\npackages: []\n# The following packages have been ignored due to incompatibility with the\n# resolver compiler, dependency conflicts with other packages\n# or unsatisfied dependencies.\n#- .\n\n# Dependency packages to be pulled from upstream that are not in the resolver.\n# These entries can reference officially published versions as well as\n# forks / in-progress versions pinned to a git hash. For example:\n#\n# extra-deps:\n# - acme-missiles-0.3\n# - git: https://github.com/commercialhaskell/stack.git\n# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a\n#\n# extra-deps: []\n\n# Override default flag values for local packages and extra-deps\n# flags: {}\n\n# Extra package databases containing global packages\n# extra-package-dbs: []\n\n# Control whether we use the GHC we find on the path\n# system-ghc: true\n#\n# Require a specific version of stack, using version ranges\n# require-stack-version: -any # Default\n# require-stack-version: \">=2.7\"\n#\n# Override the architecture used by stack, especially useful on Windows\n# arch: i386\n# arch: x86_64\n#\n# Extra directories used by stack for building\n# extra-include-dirs: [/path/to/dir]\n# extra-lib-dirs: [/path/to/dir]\n#\n# Allow a newer minor version of GHC than the snapshot specifies\n# compiler-check: newer-minor\n" }, { "path": "finkel-tool/test/data/p02/test/Spec.hs", "content": "main :: IO ()\nmain = putStrLn \"Test suite not yet implemented\"\n" }, { "path": "finkel-tool/test/data/print-int.hs", "content": ";;; -*- mode: finkel -*-\n(print (:: 42 Int))\n" }, { "path": "finkel-tool/test/data/print-load-me.hs", "content": ";;; -*- mode: finkel -*-\n(from-load-me \"LOADED\")\n" }, { "path": "finkel-tool/test/data/run-me.hs", "content": ";;; -*- mode: finkel -*-\n\n(defmodule Main)\n\n(defn (:: main (IO ()))\n (putStrLn \"From run-me.fnk\"))\n" }, { "path": "finkel-tool/test/data/sleep-for-while.fnk", "content": "(Control.Concurrent.threadDelay 1000000)\n(Control.Concurrent.threadDelay 1000000)\n(putStrLn \"sleep-for-while.fnk: done\")\n" }, { "path": "fkc/LICENSE", "content": "Copyright (c) 2020-2022, 8c6794b6\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "fkc/Main.hs", "content": "module Main where\n\nimport Language.Finkel.Main\n\nmain :: IO ()\nmain = defaultMain\n" }, { "path": "fkc/README.md", "content": "# fnkc\n\nPackage for @fkc@, the Finkel Kernel Compiler executable.\n\nSee the [documentation](https://finkel.readthedocs.org) for more info.\n" }, { "path": "fkc/Setup.hs", "content": "import Distribution.Simple\nmain = defaultMain\n" }, { "path": "fkc/fkc.cabal", "content": "cabal-version: 2.0\nname: fkc\nversion: 0.0.0\nsynopsis: Finkel kernel compiler\ndescription:\n Finkel kernel compiler\n .\n This package contains an executable @fkc@, which is internally used for\n compiling Finkel related packages.\n .\n See the for more info.\n\nhomepage: https://github.com/finkel-lang/finkel#readme\nlicense: BSD3\nlicense-file: LICENSE\nauthor: 8c6794b6\nmaintainer: 8c6794b6@gmail.com\ncopyright: 2017-2022 8c6794b6\ncategory: Language\nbuild-type: Simple\nextra-source-files: README.md\n\nexecutable fkc\n main-is: Main.hs\n build-depends: base > 4.10 && < 5\n , finkel-kernel\n default-language: Haskell2010\n ghc-options: -Wall -threaded\n -rtsopts=all\n \"-with-rtsopts=-K512M -H -I5 -T\"\n\nsource-repository head\n type: git\n location: https://github.com/finkel-lang/finkel.git\n subdir: fkc\n" }, { "path": "fnkpp/LICENSE", "content": "Copyright (c) 2022, 8c6794b6\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of the copyright holder nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." }, { "path": "fnkpp/Main.hs", "content": "import Language.Finkel.Preprocess\n\nmain :: IO ()\nmain = defaultPreprocess\n" }, { "path": "fnkpp/README.md", "content": "# fnkpp\n" }, { "path": "fnkpp/fnkpp.cabal", "content": "cabal-version: 2.0\nname: fnkpp\nversion: 0.0.0\nsynopsis: Finkel preprocessor\ndescription:\n Finkel preprocessor.\n .\n This package contains an executable @fnkpp@, which is used for\n preprocessing Finkel source code.\n .\n See the for more info.\n\nhomepage: https://github.com/finkel-lang/finkel#readme\nlicense: BSD3\nlicense-file: LICENSE\nauthor: 8c6794b6\nmaintainer: 8c6794b6@gmail.com\ncopyright: 2022 8c6794b6\ncategory: Language\nbuild-type: Simple\nextra-source-files: README.md\n\nexecutable fnkpp\n main-is: Main.hs\n ghc-options: -Wall -threaded\n build-depends: base > 4.10 && < 5\n , finkel-kernel\n default-language: Haskell2010\n\nsource-repository head\n type: git\n location: https://github.com/finkel-lang/finkel.git\n subdir: fnkpp\n" }, { "path": "nix/docker.nix", "content": "{\n nixpkgs ? ,\n compiler ? \"ghc8104\",\n tag ? \"latest\",\n created ? \"now\",\n stream ? true\n}:\n\nlet\n myPkgs = import ./finkel-packages.nix {\n inherit nixpkgs compiler;\n };\n myHaskellPackages = myPkgs.haskellPackages;\n myGhc = myHaskellPackages.ghcWithPackages (p: [\n p.finkel-kernel\n p.finkel-setup\n p.finkel-core\n p.finkel-tool\n ]);\n buildImage =\n if stream then\n myPkgs.dockerTools.streamLayeredImage\n else\n myPkgs.dockerTools.buildLayeredImage;\n\nin buildImage {\n name = \"finkel\";\n tag = \"${tag}\";\n created = \"${created}\";\n contents = [\n myPkgs.busybox\n myHaskellPackages.cabal-install\n # Compilation of stack is failing, commented out for now.\n # myPkgs.stack\n myGhc\n myHaskellPackages.fkc\n myHaskellPackages.fnkpp\n myHaskellPackages.finkel\n ];\n config = {\n # Cmd = [ \"/bin/finkel\" \"repl\" \"-B${myGhc}/lib/ghc-${myGhc.version}\" ];\n Cmd = [ \"/bin/sh\" ];\n Volumes = {\n \"/tmp\" = { };\n };\n };\n}\n" }, { "path": "nix/finkel-packages.nix", "content": "# Main configuration settings for finkel packages\n\n{\n nixpkgs,\n compiler\n} :\n\nlet\n\n # Separating the \"cabal2nix\" from host nixpkgs to target nixpkgs with using\n # \"pkgs.haskellPackages.haskellSrc2nix\" and\n # \"pkgs.haskellPackages.callPackage\". The resulting \".nix\" file generated from\n # cabal2nix is a plain nix script taking \"mkDerivation\" from its argument.\n\n hostNixPkgs = import {};\n\n haskellSrc2nix = hostNixPkgs.haskellPackages.haskellSrc2nix;\n\n filtPattern =\n pkgs.nix-gitignore.gitignoreFilterPure (_:_: true) ../.gitignore ../.;\n\n targets =\n pkgs.lib.mapAttrs (name: src0:\n let\n src = builtins.filterSource filtPattern src0;\n in haskellSrc2nix {\n inherit name src;\n }\n ) {\n finkel-kernel = ../finkel-kernel;\n fkc = ../fkc;\n fnkpp = ../fnkpp;\n finkel-setup = ../finkel-setup;\n finkel-core = ../finkel-core;\n finkel-tool= ../finkel-tool;\n finkel = ../finkel;\n };\n\n # To compile finkel-core and finkel-tool with ghc 8.10.3. At the moment,\n # running fkc with multiple cores not working well.\n\n # moreCabalOptions =\n # if compiler == \"ghc8103\" then\n # { maxBuildCores = 1; }\n # else\n # { };\n\n # ATM, Constantly using single build cores ....\n moreCabalOptions = { maxBuildCores = 1; };\n\n # Main configuration for finkel related packages.\n overlay = self: super: {\n haskellPackages = super.haskell.packages.${compiler}.override {\n overrides = hself: hsuper:\n (\n builtins.mapAttrs (name: drv:\n let\n reified = hsuper.callPackage drv {};\n in\n super.haskell.lib.overrideCabal reified (old: {\n # To descrease the size of executables, as done in ghc.\n enableSharedExecutables = true;\n }) // moreCabalOptions\n ) targets\n ) // {\n doc =\n # The 'doc' package contains test codes only, overwriting the\n # installPhase to skip the works done for library and executable\n # packages.\n let\n drv = haskellSrc2nix {\n name = \"doc\";\n src = ../doc;\n };\n reified = hsuper.callPackage drv {};\n in\n super.haskell.lib.overrideCabal reified (old:\n {\n doHaddock = false;\n installPhase = ''\nrunHook preInstallPhase\nmkdir -p $out\nrunHook postInstallPhase\n'';\n }\n );\n };\n };\n };\n\n pkgs = import \"${nixpkgs}\" {\n overlays = [overlay];\n };\n\n finkelPackages = with pkgs.haskellPackages; {\n inherit finkel-kernel fkc fnkpp finkel-setup finkel-core finkel-tool finkel doc;\n };\n\nin pkgs // { inherit finkelPackages; }\n" }, { "path": "scripts/travis.sh", "content": "#!/bin/sh\n\n# Functions for Travis CI\n# ------------------------\n#\n# This file is sourced in \"before_install\" section of \".travis.yml\". Environment\n# variable set by Travis (e.g.; $TRAVIS_OS_NAME) could be referred from this\n# script.\n#\n# The functions with OS name suffix are specific to each OS.\n\n\n# Auxiliary\n# ---------\n\ntravis_init () {\n case \"$TRAVIS_OS_NAME\" in\n linux | osx)\n case \"$EXEC\" in\n stack)\n export PATH=\"$HOME/.local/bin:$PATH\"\n export STACK=\"stack --no-terminal --resolver=$RESOLVER\"\n ;;\n cabal)\n export PATH=$\"HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH\"\n ;;\n esac\n ;;\n windows)\n export LOCALBIN=$HOME/AppData/Roaming/stack/local/bin\n export PATH=\"$PATH:$LOCALBIN\"\n export STACK=\"stack.exe --no-terminal --resolver=$RESOLVER\"\n ;;\n esac\n}\n\n\n# Linux\n# -----\n\ntravis_install_linux () {\n case \"$EXEC\" in\n stack)\n mkdir -p ~/.local/bin\n url=https://get.haskellstack.org/stable/linux-x86_64.tar.gz\n travis_retry curl -L $url | \\\n tar xz --wildcards --strip-components=1 \\\n -C ~/.local/bin \"*/stack\"\n ;;\n cabal)\n mkdir -p ~/.ghcup/bin\n url='https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup'\n travis_retry curl -L $url > ~/.ghcup/bin/ghcup\n chmod +x ~/.ghcup/bin/ghcup\n ghcup -c install-cabal\n ghcup -c install $GHC\n ghcup -c set $GHC\n which cabal\n which ghc\n cabal --version\n ghc --version\n travis_retry cabal v2-update\n ;;\n esac\n}\n\ntravis_script_linux () {\n case \"$EXEC\" in\n stack)\n $STACK --install-ghc test --only-dependencies\n $STACK build --fast --test --coverage --no-run-tests\n $STACK -j 1 build --fast --test --coverage\n ;;\n cabal)\n cabal v2-configure $FLAGS\n cabal v2-build all\n cabal v2-test all\n cabal v2-haddock all\n ;;\n esac\n}\n\ntravis_after_success_linux () {\n case \"$EXEC\" in\n stack)\n $STACK install hpc-codecov\n HPCROOT=$($STACK path --local-hpc-root)\n DISTDIR=$($STACK path --dist-dir)\n DOCPKG=doc/include/building-package\n TIX=$(find $HPCROOT -name 'all.tix')\n hpc-codecov \\\n --src=finkel-kernel --mix=kernel/$DISTDIR/hpc \\\n --src=finkel-setup --mix=setup/$DISTDIR/hpc \\\n --src=finkel-core --mix=core/$DISTDIR/hpc \\\n --src=finkel-tool --mix=tool/$DISTDIR/hpc \\\n --src=$DOCPKG/my-second-package \\\n --mix=$DOCPKG/my-second-package/$DISTDIR/hpc \\\n --src=$DOCPKG/my-new-package \\\n --mix=$DOCPKG/my-new-package/$DISTDIR/hpc \\\n --out=codecov.json --verbose $TIX\n curl -s https://codecov.io/bash | bash -s\n ;;\n cabal)\n echo Not taking codecov for cabal-install yet\n ;;\n esac\n}\n\n\n# OSX\n# ---\n\ntravis_install_osx () {\n mkdir -p ~/.local/bin\n url=https://get.haskellstack.org/stable/osx-x86_64.tar.gz\n travis_retry curl -L $url | \\\n tar xz -f- --strip-components=1 -C ~/.local/bin\n which stack\n stack --version\n}\n\ntravis_script_osx () {\n $STACK --install-ghc test --only-dependencies\n $STACK build --fast --test --no-run-tests\n $STACK -j 1 build --fast --test\n}\n\ntravis_after_success_osx () {\n echo \"OSX after success not yet written\"\n}\n\n\n# Windows\n# -------\n\n# See: https://docs.travis-ci.com/user/reference/windows/\n\ntravis_install_windows () {\n url=https://get.haskellstack.org/stable/windows-x86_64.zip\n travis_retry curl --silent --output stack.zip --location $url\n 7z x stack.zip stack.exe\n mkdir -p $LOCALBIN\n mv stack.exe $LOCALBIN\n echo STACK=$STACK\n $STACK --version || echo \"no stack\"\n}\n\ntravis_script_windows () {\n travis_script_osx\n}\n\ntravis_after_success_windows () {\n echo \"Windows after success not yet written\"\n}\n\n\n# Entry points for \".travis.yml\"\n# ------------------------------\n\ntravis_install () {\n travis_install_${TRAVIS_OS_NAME}\n}\n\ntravis_script () {\n travis_script_${TRAVIS_OS_NAME}\n}\n\ntravis_after_success () {\n travis_after_success_${TRAVIS_OS_NAME}\n}\n\n\nset -e\ntravis_init\n" }, { "path": "shell.nix", "content": "{\n nixpkgs ? ,\n compiler ? \"ghc8104\",\n withHoogle ? false\n}:\n\nlet\n hostPkgs = import {};\n\n pkgs = import ./nix/finkel-packages.nix {\n inherit compiler nixpkgs;\n };\n\n shell = pkgs.haskellPackages.shellFor {\n packages = _ :\n builtins.attrValues pkgs.finkelPackages;\n withHoogle = withHoogle;\n buildInputs= [\n hostPkgs.cabal-install\n hostPkgs.wget\n ];\n };\nin shell\n" }, { "path": "stack.yaml", "content": "# This file was automatically generated by 'stack init'\n#\n# For advanced use and comprehensive documentation of the format, please see:\n# http://docs.haskellstack.org/en/stable/yaml_configuration/\n\nresolver: lts-22.31\n\npackages:\n # Main components\n - finkel-kernel/\n - fkc/\n - fnkpp/\n - finkel-setup/\n - finkel-core/\n - finkel-tool/\n - finkel/\n\n # For test\n - doc\n - doc/include/building-package/my-first-package\n - doc/include/building-package/my-second-package\n - doc/include/building-package/my-new-package\n\nflags:\n finkel-kernel:\n dev: true\n\ncustom-preprocessor-extensions:\n - fnk\n\nrequire-stack-version: \">= 2.6.0\"\n" } ]