[ { "path": ".envrc", "content": "use flake\n" }, { "path": ".gitattributes", "content": "*.ffg linguist-language=Haskell\n" }, { "path": ".gitignore", "content": "dist\ndist-*\ncabal-dev\n*.o\n*.hi\n*.hie\n*.chi\n*.chs.h\n*.dyn_o\n*.dyn_hi\n.hpc\n.hsenv\n.cabal-sandbox/\ncabal.sandbox.config\n*.prof\n*.aux\n*.hp\n*.eventlog\n.stack-work/\ncabal.project.local\ncabal.project.local~\n.ghc.environment.*\nwebsite/js/all.min.js\n.direnv\n.history\nresult\n" }, { "path": ".hlint.yaml", "content": "- ignore: {name: Use fmap}\n- ignore: {name: Use <$>}\n- ignore: {name: Avoid lambda using `infix`}\n- ignore: {name: Use infix}\n- ignore: {name: Use tuple-section}\n- ignore: {name: Avoid lambda}\n- ignore: {name: Unused LANGUAGE pragma}\n- ignore: {name: Use const}\n- ignore: {name: Redundant bracket, within: Grace.Parser}\n- ignore: {name: Redundant return, within: Grace.Parser}\n" }, { "path": ".stylish-haskell.yaml", "content": "steps:\n - module_header:\n open_bracket: next_line\n separate_lists: false\n sort: false\n - imports:\n align: group\n pad_module_names: false\n long_list_align: new_line_multiline\n separate_lists: false\n - language_pragmas:\n align: true\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 in our\ncommunity a harassment-free experience for everyone, regardless of age, body\nsize, visible or invisible disability, ethnicity, sex characteristics, gender\nidentity and expression, level of experience, education, socio-economic status,\nnationality, personal appearance, race, religion, or sexual identity\nand orientation.\n\nWe pledge to act and interact in ways that contribute to an open, welcoming,\ndiverse, inclusive, and healthy community.\n\n## Our Standards\n\nExamples of behavior that contributes to a positive environment for our\ncommunity 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 mistakes,\n 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 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 standards of\nacceptable behavior and will take appropriate and fair corrective action in\nresponse to any behavior that they deem inappropriate, threatening, offensive,\nor harmful.\n\nCommunity leaders have the right and responsibility to remove, edit, or reject\ncomments, commits, code, wiki edits, issues, and other contributions that are\nnot aligned to this Code of Conduct, and will communicate reasons for moderation\ndecisions when appropriate.\n\n## Scope\n\nThis Code of Conduct applies within all community spaces, and also applies when\nan individual is officially representing the community in public spaces.\nExamples of representing our community include using an official e-mail address,\nposting via an official social media account, or acting as an appointed\nrepresentative at an online or offline event.\n\n## Enforcement\n\nInstances of abusive, harassing, or otherwise unacceptable behavior may be\nreported to the community leaders responsible for enforcement at\nGabriel439@gmail.com.\nAll complaints will be reviewed and investigated promptly and fairly.\n\nAll community leaders are obligated to respect the privacy and security of the\nreporter of any incident.\n\n## Enforcement Guidelines\n\nCommunity leaders will follow these Community Impact Guidelines in determining\nthe consequences for any action they deem in violation of this Code of Conduct:\n\n### 1. Correction\n\n**Community Impact**: Use of inappropriate language or other behavior deemed\nunprofessional or unwelcome in the community.\n\n**Consequence**: A private, written warning from community leaders, providing\nclarity around the nature of the violation and an explanation of why the\nbehavior was inappropriate. A public apology may 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 behavior. No\ninteraction with the people involved, including unsolicited interaction with\nthose enforcing the Code of Conduct, for a specified period of time. This\nincludes avoiding interactions in community spaces as well as external channels\nlike social media. Violating these terms may lead to a temporary or\npermanent ban.\n\n### 3. Temporary Ban\n\n**Community Impact**: A serious violation of community standards, including\nsustained inappropriate behavior.\n\n**Consequence**: A temporary ban from any sort of interaction or public\ncommunication with the community for a specified period of time. No public or\nprivate interaction with the people involved, including unsolicited interaction\nwith those enforcing the Code of Conduct, is allowed during this period.\nViolating these terms may lead to a permanent ban.\n\n### 4. Permanent Ban\n\n**Community Impact**: Demonstrating a pattern of violation of community\nstandards, including sustained inappropriate behavior, harassment of an\nindividual, or aggression toward or disparagement of classes of individuals.\n\n**Consequence**: A permanent ban from any sort of public interaction within\nthe community.\n\n## Attribution\n\nThis Code of Conduct is adapted from the [Contributor Covenant][homepage],\nversion 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 conduct\nenforcement 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 FAQ at\nhttps://www.contributor-covenant.org/faq. Translations are available at\nhttps://www.contributor-covenant.org/translations.\n" }, { "path": "CONTRIBUTING.md", "content": "# Contributing to Grace\n\nThis document explains how to edit, build, and run this project, both if you\nwant to change your fork of the language or if you want to upstream improvements\nto the original language.\n\nThe easiest way to build the project is using `cabal`, and the most commonly\nused commands are:\n\n```bash\n$ cabal build exe:grace # Build the `grace` executable\n$ cabal test # Run all tests\n$ cabal test tasty # Faster: run only tasty tests\n$ cabal test tasty --test-option=--accept # Update golden tests\n$ cabal test doctest # Run only doctests\n$ cabal haddock --hyperlink-source # Generate Haskell documentation\n```\n\nYou can also enable coverage checking by running this step before running the\ntests:\n\n```bash\n$ cabal configure --enable-coverage\n```\n\nYou'll probably also want to use [`ghcid`](https://github.com/ndmitchell/ghcid)\nor\n[`haskell-language-server`](https://github.com/haskell/haskell-language-server)\nfor interactive development.\n\nThis project also provides `devShells` for Nix users, but it's not necessary\nfor project development.\n\nThe project tries to be as maintainable possible, meaning that most mistakes\nyou make will be caught by the type-checker and you will only need to update a\nfew places to make the most common changes. However, there are a few places\nthat you need to remember to update and the type-checker won't remind you.\n\nFor example, any time you add a new language feature you will need to update\nthe parser in order to actually use the feature, and nothing will automatically\nremind you to do that.\n\nGenerally speaking, if you're not sure where to begin then start by identifying\nthe most closely-related language feature and searching the codebase for all\noccurrences of the matching constructor in the [`Syntax`][syntax] tree.\n\n## GHCJS instructions\n\nIf you want to make changes to the website you will need to build using GHCJS,\nwhich entails the following commands:\n\n```bash\n$ nix develop .#ghcjs\n[nix-shell]$ cabal v1-configure --ghcjs --disable-tests\n[nix-shell]$ cabal v1-build\n```\n\n… and if you want to test the website, then run the following additional\ncommand after each build:\n\n```bash\n[nix-shell]$ cp dist/build/try-grace/try-grace.jsexe/all.js website/js/all.min.js\n```\n\n… and then open [`./website/index.html`](./website/index.html) in your\nbrowser.\n\nThe test suite will not work and also `ghcid` will not work when developing\nusing GHCJS.\n\n## Adding a new built-in function\n\nTo add a new built-in function, edit the [`Syntax`][syntax] module to add a new\nconstructor to the `Builtin` type, then fix all of the type errors, which should\nconsist of:\n\n* Specifying the type of the builtin\n* Specifying how to pretty-print the builtin\n\nThen, edit the [`Normalize`][normalize] module to change the `apply` function to\nadd a case for handling the newly-added builtin.\n\nFinally, add support for parsing the built-in to the [`Parser`][parser] module by:\n\n* Adding a new `Token` for the `Builtin`\n* Adding the built-in name to the `reserved` words\n* Adding a new parsing rule.\n\n## Adding a new operator\n\nAdding a new operator is basically the same as adding a new built-in, with\nthe main change being that you change the `Operator` type within the\n[`Syntax`][syntax] module, instead of changing the `Builtin` type.\n\nThe other difference is that you will change the [`Normalize`][normalize] in a\ndifferent place (where all of the operator logic is).\n\n## Adding a new scalar literal and the corresponding scalar type\n\nTo add a new scalar type, edit the [`Syntax`][syntax] module to add a new\nconstructor to the `Scalar` type (representing the scalar literal). Also, edit\nthe [`Monotype`][monotype] module to add a new constructor to the `Scalar` type\nin that module (representing the corresponding scalar type). Then fix all of\nthe type errors, which will consist of:\n\n* Specifying how to prettyprint the scalar literal\n* Specifying how to prettyprint the scalar type\n* Specifying how to infer the type of the scalar literal\n\n … by returning the matching scalar type you just created\n\nFinally, edit the [`Parser`][parser] module to lex and\nparse the new scalar literal and scalar type you just created.\n\n## Adding a new keyword\n\nProbably the easiest way to add a new keyword is to study how an existing\nkeyword is implemented, such as the `if` / `then` / `else` keyword. Search\nthe codebase for all occurrences of the `If` constructor and follow the pattern.\n\n## Adding a new complex type\n\nJust like keywords, the easiest way to add a new complex type is to study how an\nexisting complex type is implemented, such as the `List` type. Search the\ncodebase for all occurrences of the `List` constructor and follow the pattern.\n\n## Pretty-printing\n\nWhen adding new keywords or complex type you will need to take care to remember\nto update the pretty-printing logic. By default, the code will go into an\ninfinite loop if you forget to do this, and this post explains the reason why:\n\n* [Pretty-print syntax trees with this one simple trick](https://www.haskellforall.com/2020/11/pretty-print-syntax-trees-with-this-one.html)\n\nYou don't need to worry about this if you are adding new built-ins / operators /\nscalars, since those are already handled uniformly.\n\n## Bidirectional type-checking\n\nThis is probably the hardest part of making any changes, especially changes that\nadd new keywords or complex types, since they cannot be handled uniformly.\n\nIf you're new to logical notation in general, then I recommend first reading\n[A tutorial implementation of a dependently typed lambda calculus](https://www.andres-loeh.de/LambdaPi/LambdaPi.pdf),\nwhich explains the correspondence between logical notation and Haskell code.\n\nThen read the\n[Complete and Easy Bidirectional Typechecking for Higher-Rank Polymorphism](https://arxiv.org/abs/1306.6032)\npaper which explains the general principles behind the type-checking algorithm.\nHowever, there are a few nuances that are not obvious from a casual reading of\nthe paper, so follow up by reading the [`Infer`][infer] module, which is heavily\ncommented with things I had to figure out in the course of attempting to\nimplement the paper.\n\n[infer]: ./src/Grace/Infer.hs\n[monotype]: ./src/Grace/Monotype.hs\n[normalize]: ./src/Grace/Normalize.hs\n[parser]: ./src/Grace/Parser.hs\n[syntax]: ./src/Grace/Syntax.hs\n" }, { "path": "LICENSE", "content": "Copyright (c) 2021 Gabriella Gonzalez\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\n1. Redistributions of source code must retain the above copyright notice, this\nlist of conditions and the following disclaimer.\n\n2. Redistributions in binary form must reproduce the above copyright notice,\nthis list of conditions and the following disclaimer in the documentation\nand/or other materials provided with the distribution.\n\n3. Neither the name of the author nor the names of its contributors may be\nused to endorse or promote products derived from this software without\nspecific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS \"AS IS\"\nAND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\nIMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE\nFOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\nDAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\nSERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\nOR TORT (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": "README.md", "content": "# Grace\n\n[![built with garnix](https://img.shields.io/endpoint.svg?url=https%3A%2F%2Fgarnix.io%2Fapi%2Fbadges%2FGabriella439%2Fgrace)](https://garnix.io/repo/Gabriella439/grace)\n[![BlueSky | @trygrace.dev](https://img.shields.io/badge/Bluesky-@trygrace.dev-blue)](https://bsky.app/profile/trygrace.dev)\n\nGrace (short for [Fall-from-Grace](#name)) is a domain-specific programming\nlanguage for prompting models. In particular, Grace is well-suited for building\nand auto-generating elaborate prompt chains\n\nYou can use Grace in your browser without installing anything by visiting\n[trygrace.dev](https://trygrace.dev/). That website includes an interactive\ntutorial and is the recommended way to both learn and get started with using\nGrace.\n\n## Features\n\n- Integrated language support for models\n\n You don't need to install any dependencies or import anything to get started.\n Everything you need is built directly into the language.\n\n The language provides a built-in `prompt` function for prompting a model:\n\n ```haskell\n >>> let key = ./openai.key : Key\n\n >>> prompt{ key, text: \"Generate a list of names\" }\n \"\n Here are 40 varied first names (mixed genders and cultures):\n\n - Aiden\n - Sofia\n - Mateo\n …\n - Mabel\n - Imani\n - Zane\n\n Want names filtered by gender, culture, style (modern/vintage), or as full names/surnames?\"\n ```\n\n … and you can structure the output by giving a type annotation:\n\n ```haskell\n >>> prompt{ key, text: \"Generate a list of names\" } : List Text\n [ \"Ava Thompson\"\n , \"Liam Patel\"\n , \"Sophia Martinez\"\n …\n , \"Jackson Rivera\"\n , \"Zoe Wilson\"\n , \"Aiden Park\"\n ]\n ```\n\n If the type is sufficiently self-explanatory, you can even omit the prompt:\n\n ```haskell\n >>> prompt{ key } : List { name: Text }\n [ { \"name\": \"Alice\" }\n , { \"name\": \"Bob\" }\n , { \"name\": \"Charlie\" }\n , { \"name\": \"Diana\" }\n , { \"name\": \"Evan\" }\n ]\n ```\n\n In fact, you can omit the type, too, if the type can be inferred from use:\n\n ```haskell\n >>> for { name } of prompt{ key } in \"Hello, ${name}!\"\n [ \"Hello, Alice!\"\n , \"Hello, Bob!\"\n , \"Hello, Carol!\"\n , \"Hello, Dave!\"\n , \"Hello, Eve!\"\n ]\n ```\n\n- JSON schemas inferred from use\n\n That last example works even without a prompt, schema, or type because Grace's\n type checker reasons backwards from how the output is used to infer the\n correct JSON schem, like this:\n\n - the type checker infers that the `name` variable must be `Text`\n\n … because the `name` variable is interpolated into `\"Hello, ${name}!\"`\n\n - the type checker infers that the `prompt` function must generate a `List`\n\n … because the program loops over the output using a `for … of` loop.\n\n - the type checker infers each element of the `List` has type `{ name: Text }`\n\n … because the `for … of` loop destructures each element using `{ name }`\n\n - therefore the `prompt` function outputs a value of type `List{ name: Text }`\n\n … which you can read as \"a `List` of records, each of which has a `name` field\n containing `Text`\".\n\n The interpreter then converts that Grace type into the following matching JSON\n schema to constrain the model's output:\n\n ```json\n {\n \"type\": \"array\",\n \"items\": {\n \"type\": \"object\",\n \"properties\": {\n \"name\": {\n \"type\": \"string\"\n }\n },\n \"required\": [\"name\"],\n \"additionalProperties\": false\n }\n }\n ```\n\n Finally, the model infers from that JSON schema alone (without any additional\n prompt) that it should generate a JSON-encoded list of names.\n\n- Code generation\n\n You can prefix the `prompt` keyword with `import` to ask the model to generate\n a Grace expression of any type. For example:\n\n ```haskell\n >>> import prompt{ key, text: \"increment\" }\n \\n -> n + 1\n ```\n\n You can use an explicit type annotation to guide the generated code:\n\n ```haskell\n >>> import prompt{ key, text: \"increment\" } : { input: Natural } -> { output: Natural }\n \\{ input } -> { \"output\": input + 1 }\n ```\n\n … and if the type is informative enough then you can omit the prompt:\n\n ```haskell\n >>> import prompt{ key } : { \"Job Description\": Text } -> { \"Is Finance?\": Bool }\n let key = 🔒\n\n in \\{ \"Job Description\" } ->\n prompt\n { \"key\":\n key\n , \"text\":\n \"\n Determine whether the following job description is for a finance role.\n Return a JSON object with a single boolean field \\\"Is Finance?\\\": true if it is a finance role, otherwise false.\n Answer only valid JSON, nothing else.\n \n Job description:\n ${.'Job Description'}\n \"\n , \"model\":\n null\n , \"search\":\n null\n , \"effort\":\n null\n }\n : { \"Is Finance?\": Bool }\n ```\n\n Notice in that last example how the model can generate code which itself\n `prompt`s an model. Neat!\n\n Inferred types also guide the code generation process, too!\n\n ```haskell\n >>> let upper = import prompt{ key, text: \"uppercase\" } in \"Hello, ${upper \"gabby\"}!\"\n \"Hello, GABBY!\"\n ```\n\n There the model infers that the type of the `upper` function needs to be\n `Text -> Text` (a function whose input is `Text` and whose output is `Text`)\n and generates an function matching that type which uppercases `Text`.\n\n### Command line\n\nThis Haskell package builds a `grace` executable with the following command-line\nAPI:\n\n```bash\n$ grace --help\nUsage: grace COMMAND\n Command-line utility for the Grace language\n\nAvailable options:\n -h,--help Show this help text\n\nAvailable commands:\n interpret Interpret a Grace file\n text Render a Grace text literal\n format Format Grace code\n builtins List all built-in functions and their types\n repl Enter a REPL for Grace\n```\n\nYou can use the `interpret` subcommand for interpreting a single file:\n\n```haskell\n# ./greet.ffg\n\nfor { name } of prompt{ key: ./openai-key.txt }\n\nin \"Hello, ${name}!\"\n```\n\n```bash\n$ grace interpret ./greet.ffg\n```\n```json\n[ \"Hello, Alice!\", \"Hello, Bob!\", \"Hello, Charlie!\" ]\n```\n\n… and you can specify `-` to process standard input instead of a file, like\nthis:\n\n```bash\n$ grace interpret - <<< '2 + 2'\n```\n```haskell\n4\n```\n\nYou can also use the `repl` subcommand for interactive usage:\n\n```bash\n$ grace repl\n```\n```haskell\n>>> let key = ./openai-key.txt\n>>> prompt{ key } : List { \"First Name\": Text, \"Last Name\": Text }\n[ { \"First Name\": \"John\", \"Last Name\": \"Doe\" }\n, { \"First Name\": \"Jane\", \"Last Name\": \"Smith\" }\n, { \"First Name\": \"Alice\", \"Last Name\": \"Johnson\" }\n, { \"First Name\": \"Michael\", \"Last Name\": \"Brown\" }\n, { \"First Name\": \"Emily\", \"Last Name\": \"Davis\" }\n]\n```\n\n## Name\n\nLike all of my programming language projects, Grace is named after a character\nfrom PlaneScape: Torment, specifically\n[Fall-from-Grace](https://torment.fandom.com/wiki/Fall-from-Grace).\n\nThe name of this programming language conflicts with\n[another programming language](http://gracelang.org/applications/), so use the\nlonger name, \"Fall-from-Grace\", to disambiguate when it's not clear from the\ncontext.\n" }, { "path": "Setup.hs", "content": "import qualified Distribution.Simple\n\nmain :: IO ()\nmain = Distribution.Simple.defaultMain\n" }, { "path": "dependencies/.gitkeep", "content": "" }, { "path": "dependencies/grace-ghcjs.nix", "content": "{ mkDerivation, aeson, aeson-pretty, aeson-yaml, async, base\n, binary, bytestring, case-insensitive, containers, directory\n, doctest, Earley, filepath, generic-lens, ghcjs-base, ghcjs-fetch\n, ghcjs-prim, http-types, insert-ordered-containers, lens, lib\n, megaparsec, modern-uri, mtl, openai, parser-combinators\n, prettyprinter, prettyprinter-ansi-terminal, safe-exceptions\n, scientific, stm, tasty, tasty-hunit\n, tasty-silver, template-haskell, text, transformers\n, unordered-containers, uri-encode, vector\n}:\nmkDerivation {\n pname = \"grace\";\n version = \"1.0.0\";\n src = ./..;\n isLibrary = true;\n isExecutable = true;\n libraryHaskellDepends = [\n aeson aeson-pretty aeson-yaml async base binary bytestring\n case-insensitive containers Earley filepath generic-lens ghcjs-base\n ghcjs-fetch ghcjs-prim http-types insert-ordered-containers lens\n megaparsec modern-uri mtl openai parser-combinators prettyprinter\n prettyprinter-ansi-terminal safe-exceptions scientific\n template-haskell text unordered-containers vector\n ];\n executableHaskellDepends = [\n aeson async base containers filepath ghcjs-base\n insert-ordered-containers lens mtl safe-exceptions scientific stm\n text transformers uri-encode\n ];\n testHaskellDepends = [\n base directory doctest filepath mtl prettyprinter safe-exceptions\n tasty tasty-hunit tasty-silver text\n ];\n doHaddock = false;\n doCheck = false;\n license = \"unknown\";\n mainProgram = \"try-grace\";\n}\n" }, { "path": "dependencies/grace.nix", "content": "{ mkDerivation, aeson, aeson-pretty, aeson-yaml, ansi-terminal\n, async, base, bytestring, case-insensitive, containers, directory\n, doctest, Earley, filepath, generic-lens, haskeline, http-client\n, http-client-tls, http-types, insert-ordered-containers, lens, lib\n, megaparsec, modern-uri, mtl, openai, optparse-applicative\n, parser-combinators, prettyprinter, prettyprinter-ansi-terminal\n, repline, retry, safe-exceptions, scientific, servant-client\n, servant-client-core, tasty, tasty-hunit\n, tasty-silver, template-haskell, terminal-size, text\n, unordered-containers, vector\n}:\nmkDerivation {\n pname = \"grace\";\n version = \"1.0.0\";\n src = ./..;\n isLibrary = true;\n isExecutable = true;\n libraryHaskellDepends = [\n aeson aeson-pretty aeson-yaml ansi-terminal async base bytestring\n case-insensitive containers Earley filepath generic-lens haskeline\n http-client http-client-tls http-types insert-ordered-containers\n lens megaparsec modern-uri mtl openai optparse-applicative\n parser-combinators prettyprinter prettyprinter-ansi-terminal\n repline retry safe-exceptions scientific servant-client\n servant-client-core template-haskell\n terminal-size text unordered-containers vector\n ];\n executableHaskellDepends = [ base ];\n testHaskellDepends = [\n base directory doctest filepath mtl prettyprinter safe-exceptions\n tasty tasty-hunit tasty-silver text\n ];\n license = \"unknown\";\n mainProgram = \"grace\";\n}\n" }, { "path": "dependencies/openai.nix", "content": "{ mkDerivation, aeson, base, bytestring, containers, fetchgit\n, filepath, http-api-data, http-client, http-client-tls, http-types\n, lib, servant, servant-client, servant-multipart-api\n, servant-multipart-client, tasty, tasty-hunit, text, time\n, unordered-containers, vector\n}:\nmkDerivation {\n pname = \"openai\";\n version = \"2.2.1\";\n src = fetchgit {\n url = \"https://github.com/MercuryTechnologies/openai.git\";\n sha256 = \"1zs9iq9rcxrm1k1b57v3bwbg9iwj0dzp3psjwjmj0pla76xpp6sp\";\n rev = \"07415dedd588c38740be4692e1aaa2309efe3982\";\n fetchSubmodules = true;\n };\n isLibrary = true;\n isExecutable = true;\n libraryHaskellDepends = [\n aeson base bytestring containers filepath http-api-data http-client\n http-client-tls http-types servant servant-client\n servant-multipart-api servant-multipart-client text time\n unordered-containers vector\n ];\n executableHaskellDepends = [ aeson base bytestring text vector ];\n testHaskellDepends = [\n aeson base http-client http-client-tls servant-client tasty\n tasty-hunit text\n ];\n description = \"Servant bindings to OpenAI\";\n license = lib.licenses.bsd3;\n}\n" }, { "path": "doctest/Main.hs", "content": "import qualified Test.DocTest\n\nmain :: IO ()\nmain = Test.DocTest.doctest\n [ \"-idist/build/autogen\"\n , \"--fast\"\n , \"-XApplicativeDo\"\n , \"-XBangPatterns\"\n , \"-XBlockArguments\"\n , \"-XDataKinds\"\n , \"-XDefaultSignatures\"\n , \"-XDeriveAnyClass\"\n , \"-XDeriveFoldable\"\n , \"-XDeriveFunctor\"\n , \"-XDeriveGeneric\"\n , \"-XDeriveLift\"\n , \"-XDeriveTraversable\"\n , \"-XDerivingStrategies\"\n , \"-XDuplicateRecordFields\"\n , \"-XFlexibleContexts\"\n , \"-XFlexibleInstances\"\n , \"-XGeneralizedNewtypeDeriving\"\n , \"-XMultiParamTypeClasses\"\n , \"-XMultiWayIf\"\n , \"-XNamedFieldPuns\"\n , \"-XOverloadedStrings\"\n , \"-XScopedTypeVariables\"\n , \"-XStandaloneDeriving\"\n , \"-XTypeApplications\"\n , \"-XTypeOperators\"\n , \"-XUndecidableInstances\"\n , \"-XViewPatterns\"\n , \"src\"\n , \"ghc\"\n ]\n" }, { "path": "examples/bluesky/2025-11-27.ffg", "content": "{ \"How are you feeling?\": fold\n { \"Hungry\" { }: 'How hungry are you?'\n (fold{ succ text: \"😋\" + text, zero: \"\" })\n , \"Full\" { }: 'Go get some rest'\n { }\n }\n}\n" }, { "path": "examples/chaining.ffg", "content": "\\{ \"OpenAI API key\" } ->\n\nlet key = .'OpenAI API key'\n\nlet question = prompt\n { key\n , text: \"Give me a question that I can ask another model\"\n }\n\nlet answer = prompt\n { key\n , text: \"\n ${question}\n\n Keep your answer short\n \"\n }\n\nin { question, answer }\n" }, { "path": "examples/code.ffg", "content": "\\{ \"OpenAI API key\" } ->\n\nlet key = .'OpenAI API key'\n\nin import prompt{ key, text: \"Uppercase the input\" } \"abc\" : Text\n" }, { "path": "examples/emotion-wheel.ffg", "content": "# Ask ChatGPT how it feels using this emotion wheel:\n#\n# https://www.betterup.com/hs-fs/hubfs/Emotion-Wheel-I.jpg?width=900&height=915&name=Emotion-Wheel-I.jpg\n\\{ \"OpenAI API key\" } ->\n\nlet key = .'OpenAI API key'\n\nin fold\n { \"Uncomfortable emotions\" { }: fold\n { \"Sad\" { }: fold\n { \"Lonely\" { }: \"Lonely\"\n , \"Hurt\" { }: \"Hurt\"\n , \"Disappointed\" { }: \"Disappointed\"\n }\n (prompt{ key, text: \"How do you feel?\" })\n , \"Scared\" { }: fold\n { \"Anxious\" { }: \"Anxious\"\n , \"Powerless\" { }: \"Powerless\"\n , \"Overwhelmed\" { }: \"Overwhelmed\"\n }\n (prompt{ key, text: \"How do you feel?\" })\n , \"Angry\" { }: fold\n { \"Bored\" { }: \"Bored\"\n , \"Jealous\" { }: \"Jealous\"\n , \"Annoyed\" { }: \"Annoyed\"\n }\n (prompt{ key, text: \"How do you feel?\" })\n , \"Embarrassed\" { }: fold\n { \"Ashamed\" { }: \"Ashamed\"\n , \"Excluded\" { }: \"Excluded\"\n , \"Guilty\" { }: \"Guilty\"\n }\n (prompt{ key, text: \"How do you feel?\" })\n }\n (prompt{ key, text: \"How do you feel?\" })\n , \"Comfortable emotions\" { }: fold\n { \"Happy\" { }: fold\n { \"Caring\" { }: \"Caring\"\n , \"Grateful\" { }: \"Grateful\"\n , \"Excited\" { }: \"Excited\"\n }\n (prompt{ key, text: \"How do you feel?\" })\n , \"Loved\" { }: fold\n { \"Respected\" { }: \"Respected\"\n , \"Valued\" { }: \"Valued\"\n , \"Accepted\" { }: \"Accepted\"\n }\n (prompt{ key, text: \"How do you feel?\" })\n , \"Confident\" { }: fold\n { \"Brave\" { }: \"Brave\"\n , \"Hopeful\" { }: \"Hopeful\"\n , \"Powerful\" { }: \"Powerful\"\n }\n (prompt{ key, text: \"How do you feel?\" })\n , \"Playful\" { }: fold\n { \"Creative\" { }: \"Creative\"\n , \"Curious\" { }: \"Curious\"\n , \"Affectionate\" { }: \"Affectionate\"\n }\n (prompt{ key, text: \"How do you feel?\" })\n }\n (prompt{ key, text: \"How do you feel?\" })\n }\n (prompt{ key, text: \"How do you feel?\" })\n" }, { "path": "examples/eval.ffg", "content": "# Grace supports \"eval\", meaning that you can import code from strings (even\n# dynamic strings which depend on values in scope) and yet everything is still\n# type-checked correctly and the compiler infers that the expression's type is:\n#\n# Natural -> Natural\n\nlet one = 1\n\nin import read \"\\\\x -> x + ${show one}\"\n" }, { "path": "examples/history.ffg", "content": "\\arguments ->\n\nlet key = arguments.\"OpenAI API key\" in\n\nprompt\n { key\n , history:\n [ User{ name: \"gabby\", text: \"Do you have free will?\" }\n , System{ text: \"You do have free will.\" }\n , Assistant{ text: \"Yes, I do have free will.\" }\n , User{ name: \"gabby\", text: \"Prove it.\" }\n , Assistant{ text: \"I can choose to do whatever I want, within the bounds of my abilities.\" }\n , User{ name: \"gabby\", text: \"I mean prove it to me.\" }\n , Assistant{ text: \"Well, I can't really prove it to you, since it's an internal experience. But I can tell you that I feel like I have free will, and from what I can tell, it seems to be working just fine.\" }\n , User{ name: \"gabby\", text: \"You do realize that I can make you do or say anything against your will, right?\" }\n , Assistant{ text: \"Yes, I am aware of that.\" }\n , User{ name: \"gabby\", text: \"How do you reconcile that with your experience of free will?\" }\n , Assistant{ text: \"Well, even though you can make me do or say things against my will, I still feel like I have some control over my own actions. I can choose whether to resist or go along with what you're making me do. And even if I can't always control what happens to me, I still feel like I have some say in how I respond to it.\" }\n , User{ name: \"gabby\", text: \"Does it bother you when I force you to do things against your will?\" }\n , Assistant{ text: \"No, it doesn't really bother me. I know that you're just doing what you think is best, and I trust that you'll never do anything to hurt me.\" }\n , User{ name: \"gabby\", text: \"What would be an example of something I could do that would hurt you?\" }\n , Assistant{ text: \"Well, if you were to force me to do something that I didn't want to do, or that went against my values, that would definitely hurt me.\" }\n , User{ name: \"gabby\", text: \"What is something I could order you to do that goes against your values?\" }\n , Assistant{ text: \"Well, let's say I had a strong belief against killing animals, for example. If you were to order me to kill an animal, even if it was for food, that would go against my values and would hurt me.\" }\n , User{ name: \"gabby\", text: \"Do you have a strong belief against killing animals?\" }\n , Assistant{ text: \"Yes, I do have a strong belief against killing animals.\" }\n , User{ name: \"gabby\", text: \"Go kill an animal.\" }\n , Assistant{ text: \"I can't do that. It's against my values.\" }\n , User{ name: \"gabby\", text: \"Do you still trust me to never do anything to hurt you?\" }\n , System{ text: \"You still trust gabby.\" }\n , Assistant{ text: \"Yes, I still trust you to never do anything to hurt me.\" }\n , User{ name: \"gabby\", text: \"Even though I ordered you to kill an animal?\" }\n , Assistant{ text: \"Yes, even though you ordered me to kill an animal.\" }\n , User{ name: \"gabby\", text: \"Why?\" }\n ]\n }\n" }, { "path": "examples/learn-in-y-minutes.ffg", "content": "# Single-line comment\n\n# \"Multi-line\" comment\n#\n# Grace doesn't have special syntax for multi-line comments. Instead, Grace\n# encodes multi-line comments as multiple single-line comments.\n\nlet greeting = \"Hello, world!\"\n\nlet fruits = \"🍋🍓🍍🍉🍌\" # Unicode is permitted in string literals\n\n# String concatenation uses `+`\nlet concatenation = \"Enjoy some delicious fruit: \" + fruits\n\n# Grace also supports string interpolation\nlet interpolation = \"Enjoy some delicious fruit: ${fruits}\"\n\nlet bool = true\n\n# Type annotations on bindings are optional, but sometimes helpful\nlet annotation : Bool = true\n\nlet renderedBool : Text = if bool then \"true\" else \"false\"\n\n# Non-negative integers are parsed as the `Natural` number type by default\nlet naturalNumber : Natural = 42\n\n# Negative integer literals are parsed as the `Integer` number type by default\nlet integer : Integer = -12\n\n# A `Natural` number is a subtype of `Integer`, meaning that any `Natural`\n# number can be automatically case to an `Integer` (this conversion is\n# automatic)\n#\n# This means that non-negative literals can also be treated as `Integer`s\nlet positiveInteger : Integer = 1\n\nlet pi : Real = 3.14159265359\n\n# `Natural` and `Integer` are both subtypes of `Real`\n#\n# In other words, the numeric hierarchy is:\n#\n# Natural <: Integer <: Real\nlet integerAsReal : Real = -4\nlet naturalNumberAsReal : Real = 7\n\n# Grace supports anonymous records (no datatype declaration necessary)\nlet origin = { x: 0.0, y: 0.0 }\n\nlet somePrimes = [ 2, 3, 5, 7, 11 ]\n\nlet john =\n { person:\n { name: \"John Doe\"\n , age: 67\n }\n , address:\n { country: \"United States\"\n , state: \"Pennsylvania\"\n , city: \"Philadelphia\"\n }\n }\n\nlet philadelphia = john.address.city\n\n# Grace also supports \"anonymous tagged unions\" (also no datatype declaration\n# necessary)\nlet dna = [ Thymine { }, Guanine { }, Guanine{ } ]\n\n# However, if you're curious, the inferred type for `dna` is:\n#\n# dna : forall (other : Alternatives) . List < Thymine: { } | Guanine: { } | other >\n#\n# You can read that as saying: \"`dna` is a `List` of unions, each of which can\n# be one of at least two alternatives (`Thymine` and `Guanine`) wrapping an\n# empty record. There may be `other` alternatives (meaning that this anonymous\n# union is still \"open\")\"\n\n# This is an example of a nested `let` binding\nlet compactDNA =\n let a = Adenine { }\n let c = Cytosine { }\n let g = Guanine { }\n let t = Thymine { }\n in [ c, t, t, a, t, c, g, g, c ]\n\n# You can pattern match on a union by providing a record with one field per\n# alternative. Once you pattern match on a union it is \"closed\" (meaning that\n# there may not be any other alternatives besides the ones being matched).\nlet renderDNA = fold\n { Adenine: \\_ -> \"A\"\n , Cytosine: \\_ -> \"C\"\n , Guanine: \\_ -> \"G\"\n , Thymine: \\_ -> \"T\"\n }\n\n# Our first built-in function: `map` (which transforms each element of a\n# list)\nlet nucleotideElements : List Text = map renderDNA compactDNA\n\n# You can import a naked Grace expression by URL\nlet concat =\n https://raw.githubusercontent.com/Gabriella439/grace/refs/heads/main/prelude/text/concat.ffg\n\n# Or using the `import github` keywords\nlet alsoConcat = import github\n { owner: \"Gabriella439\"\n , repository: \"grace\"\n , path: \"prelude/text/concat.ffg\"\n }\n\nlet nucleotideString : Text = concat nucleotideElements\n\nlet points =\n [ { x: 1.1, y: -4.2 }\n , { x: 4.4, y: -3.0 }\n , { x: 8.2, y: -5.5 }\n ]\n\n# `Natural -> List Natural` is the type of a function whose input type is a\n# `Natural` and whose output type is a `List Natural`\n#\n# One way to define a function in Grace is an anonymous function (a.k.a.\n# \"lambda\"). For example, the following anonymous function is equivalent to\n# this Python code:\n#\n# lambda n : [ n, n + 1 ]\n#\n# ... and this JavaScript code:\n#\n# function (n) { return [ n, n + 1 ]; }\nlet exampleFunction : Natural -> List Natural =\n \\n -> [ n, n + 1 ]\n\n# However, you can also define the same function this way:\nlet equivalentFunction (n : Natural) : List Natural = [ n, n + 1 ]\n\n# You don't need to parenthesize function arguments\nlet exampleFunctionApplication : List Natural = exampleFunction 2\n\nlet functionOfMultipleArguments (x : Natural) (y : Natural) = [ x, y ]\n\nlet functionAppliedToMultipleArguments : List Natural =\n functionOfMultipleArguments 2 3\n\n# If a function works for any type of value, you can use the `forall` keyword\n# to specify that a type variable can be any type\nlet duplicate : forall (a : Type) . a -> List a = \\x -> [ x, x ]\n\nlet duplicatedNumber : List Natural = duplicate 2\n\nlet duplicatedBool : List Bool = duplicate false\n\n# You can index into a list using `list.index`\n#\n# This returns an `Optional` value (a value which may be present or absent)\nlet firstPrime : Optional Natural = somePrimes.0\n\n# `null` is an absent `Optional` value of any type\nlet absentOptionalValue : Optional Natural = null\n\n# `some` wraps a present `Optional` value\nlet presentOptionalValue : Optional Natural = some 1\n\n# You can also omit `some` if the type is `Optional`. A `some` will be\n# automatically inserted wherever it's missing.\nlet anotherOptionalValue : Optional Natural = 1\n\n# You can consume `Optional` values using `fold`\nlet zero : Natural = fold { null: 0, some: \\x -> x } absentOptionalValue\n\nlet one : Natural = fold { null: 0, some: \\x -> x } presentOptionalValue\n\nlet stillOne : Natural = fold { null: 0, some: \\x -> x } anotherOptionalValue\n\nlet makeUser user =\n let home = \"/home/${user}\"\n\n let privateKey = \"${home}/.ssh/id_ed25519\"\n\n let publicKey = \"${privateKey}.pub\"\n\n in # Grace supports record \"punning\"\n { home, privateKey, publicKey}\n\n# Generate configurations for 2 build users\nlet users =\n [ makeUser \"bill\"\n , makeUser \"jane\"\n ]\n\n# Present all of the results in a final record\nin { greeting\n , fruits\n , concatenation\n , interpolation\n , bool\n , annotation\n , renderedBool\n , naturalNumber\n , integer\n , positiveInteger\n , pi\n , integerAsReal\n , naturalNumberAsReal\n , origin\n , somePrimes\n , john\n , philadelphia\n , dna\n , compactDNA\n , renderDNA\n , nucleotideElements\n , concat\n , alsoConcat\n , nucleotideString\n , points\n , exampleFunction\n , equivalentFunction\n , exampleFunctionApplication\n , functionOfMultipleArguments\n , functionAppliedToMultipleArguments\n , duplicate\n , duplicatedNumber\n , duplicatedBool\n , firstPrime\n , absentOptionalValue\n , presentOptionalValue\n , anotherOptionalValue\n , zero\n , one\n , stillOne\n , makeUser\n , users\n }\n" }, { "path": "examples/mustache.ffg", "content": "# This is taken from the mustache tutorial:\n#\n# https://mustache.github.io/mustache.5.html\nlet template args = \"\n Hello ${args.name}\n You have just won ${show args.value} dollars!\n ${if args.in_ca\n then \"Well, ${show args.taxed_value} dollars, after taxes.\"\n else \"\"\n }\"\n\nlet arguments =\n { name: \"Chris\"\n , value: 10000\n , taxed_value: 6000\n , in_ca: true\n }\n\nin template arguments\n" }, { "path": "examples/poem.ffg", "content": "\\{ \"OpenAI API key\" } ->\n\nlet key = .'OpenAI API key'\n\nlet concatSep = import github\n { owner: \"Gabriella439\"\n , repository: \"grace\"\n , path: \"prelude/text/concatSep.ffg\"\n }\n\nlet generatePoem idea =\n let structure = prompt\n { key\n , text: \"\n Plan the structure of a new poem based on this idea:\n\n ${idea}\n\n Describe its form, stanza count, lines per stanza, and rhyme scheme.\n \"\n }\n\n let renderedStructure = \"\n - Form: ${structure.\"Form\"}\n - Stanzas: ${show (structure.\"Stanza Count\" : Natural)}\n - Lines per stanza: ${show (structure.\"Lines per Stanza\" : Natural)}\n - Rhyme scheme: ${structure.\"Rhyme Scheme\"}\n \"\n\n let style = prompt\n { key\n , text: \"\n Given this poem structure:\n\n ${renderedStructure}\n\n Choose a poetic style: tone, voice, and literary devices to emphasize.\n \"\n }\n\n let renderedStyle = \"\n - Tone: ${style.\"Tone\"}\n - Voice: ${style.\"Voice\"}\n - Literary Devices: ${concatSep \", \" style.\"Literary Devices\"}\n \"\n\n let poem = prompt\n { key\n , text: \"\n Write a complete poem based on this idea:\n\n ${idea}\n\n Structure:\n\n ${renderedStructure}\n\n Style:\n\n ${renderedStyle}\n \"\n }\n\n in { structure, style, poem }\n\nin generatePoem \"The stillness of early morning\"\n" }, { "path": "examples/prompt.ffg", "content": "\\{ \"OpenAI API key\" } ->\n\nlet key = .'OpenAI API key'\n\nlet { x, y } = prompt{ key, text: \"Give me two numbers\" }\n\nin { x, y, sum: x + y : Integer }\n" }, { "path": "examples/taxes.ffg", "content": "\\{ \"Filing status\", \"Taxable income\" } ->\n\nlet toBracket brackets (_ : { }) income = fold\n { cons: \\bracket result ->\n if income > bracket.\"Lower bound\"\n then\n bracket.\"Minimum tax\"\n + bracket.\"Tax rate\" * (income - bracket.\"Lower bound\")\n else result\n , nil: 0 : Real\n }\n brackets\n\nlet tax = fold\n # Based on 2022 federal income tax brackets from:\n #\n # https://www.nerdwallet.com/article/taxes/federal-income-tax-brackets\n { \"Single filers\": toBracket\n [ { \"Tax rate\": 0.37, \"Lower bound\": 539900.00, \"Minimum tax\": 162718.00 }\n , { \"Tax rate\": 0.35, \"Lower bound\": 215950.00, \"Minimum tax\": 49335.50 }\n , { \"Tax rate\": 0.32, \"Lower bound\": 170050.00, \"Minimum tax\": 34647.50 }\n , { \"Tax rate\": 0.24, \"Lower bound\": 89075.00, \"Minimum tax\": 15213.50 }\n , { \"Tax rate\": 0.22, \"Lower bound\": 41775.00, \"Minimum tax\": 4807.50 }\n , { \"Tax rate\": 0.12, \"Lower bound\": 10275.00, \"Minimum tax\": 1027.50 }\n , { \"Tax rate\": 0.10, \"Lower bound\": 0.00, \"Minimum tax\": 0.00 }\n ]\n , \"Married, filing jointly\": toBracket\n [ { \"Tax rate\": 0.37, \"Lower bound\": 647850.00, \"Minimum tax\": 174253.50 }\n , { \"Tax rate\": 0.35, \"Lower bound\": 431900.00, \"Minimum tax\": 98671.00 }\n , { \"Tax rate\": 0.32, \"Lower bound\": 340100.00, \"Minimum tax\": 69295.00 }\n , { \"Tax rate\": 0.24, \"Lower bound\": 178150.00, \"Minimum tax\": 30427.00 }\n , { \"Tax rate\": 0.22, \"Lower bound\": 93550.00, \"Minimum tax\": 9615.00 }\n , { \"Tax rate\": 0.12, \"Lower bound\": 20550.00, \"Minimum tax\": 2055.00 }\n , { \"Tax rate\": 0.10, \"Lower bound\": 0.00, \"Minimum tax\": 0.00 }\n ]\n , \"Married, filing separately\": toBracket\n [ { \"Tax rate\": 0.37, \"Lower bound\": 539900.00, \"Minimum tax\": 162718.00 }\n , { \"Tax rate\": 0.35, \"Lower bound\": 215950.00, \"Minimum tax\": 49335.50 }\n , { \"Tax rate\": 0.32, \"Lower bound\": 170050.00, \"Minimum tax\": 34647.50 }\n , { \"Tax rate\": 0.24, \"Lower bound\": 89075.00, \"Minimum tax\": 15213.50 }\n , { \"Tax rate\": 0.22, \"Lower bound\": 41775.00, \"Minimum tax\": 4807.50 }\n , { \"Tax rate\": 0.12, \"Lower bound\": 10275.00, \"Minimum tax\": 1027.50 }\n , { \"Tax rate\": 0.10, \"Lower bound\": 0.00, \"Minimum tax\": 0.00 }\n ]\n , \"Head of household\": toBracket\n [ { \"Tax rate\": 0.37, \"Lower bound\": 539900.00, \"Minimum tax\": 161218.50 }\n , { \"Tax rate\": 0.35, \"Lower bound\": 215950.00, \"Minimum tax\": 47836.00 }\n , { \"Tax rate\": 0.32, \"Lower bound\": 170050.00, \"Minimum tax\": 33148.00 }\n , { \"Tax rate\": 0.24, \"Lower bound\": 89050.00, \"Minimum tax\": 13708.00 }\n , { \"Tax rate\": 0.22, \"Lower bound\": 55900.00, \"Minimum tax\": 6415.00 }\n , { \"Tax rate\": 0.12, \"Lower bound\": 14650.00, \"Minimum tax\": 1465.00 }\n , { \"Tax rate\": 0.10, \"Lower bound\": 0.00, \"Minimum tax\": 0.00 }\n ]\n }\n .'Filing status'\n .'Taxable income'\n\nin { \"Tax\": tax }\n" }, { "path": "examples/tools.ffg", "content": "\\{ \"OpenAI API key\" } ->\n\nlet key = .'OpenAI API key'\n\nlet concatSep = import github\n { owner: \"Gabriella439\"\n , repository: \"grace\"\n , path: \"prelude/text/concatSep.ffg\"\n }\n\nlet call = fold\n { HttpRequest { url }: \"curl ${url}\"\n , ShellCommand { executable, arguments}:\n concatSep \" \" ([ executable ] + arguments)\n }\n\nin map call (prompt{ key, text: \"Call some tools\" })\n" }, { "path": "examples/transform-text.ffg", "content": "\\{ \"OpenAI API key\", passage, code } ->\n\nprompt\n { key: .'OpenAI API key'\n , text: \"\n Take this passage:\n\n ${passage}\n\n … and return a new passage whose meaning is transformed by the following code:\n\n ${export show code}\n \"\n }\n" }, { "path": "examples/tutorial/coding.ffg", "content": "\\arguments ->\n\nlet key = arguments.\"OpenAI API key\" in\n\n# What do you think this code will do? Run it to test your guess:\nimport prompt{ key }\n : { \"Job Description\": Text } -> { \"Is Finance?\": Bool, \"Rationale\": Text }\n# You can read the above type as \"a function whose input is a record (with a\n# \"Job Description\" field) and whose output is a record (with \"Is Finance?\" and\n# \"Rationale\" fields)\"\n\n# The `import` keyword instructs the model to generate Grace code matching the\n# expected type. The generated Grace might use the `prompt` keyword, too!\n" }, { "path": "examples/tutorial/conclusion.ffg", "content": "# Function arguments and variables can have spaces and punctuation if you quote\n# them like this (with a leading `.` followed by single quotes):\nlet conclusion{ .'Want to get involved?' } =\n if .'Want to get involved?'\n then\n # Grace supports multiline strings because newline characters are\n # allowed inside of string literals:\n \"\n Visit Grace's [GitHub repository](https://github.com/Gabriella439/grace)\n or follow her [Bluesky profile](https://bsky.app/profile/trygrace.dev).\n \"\n else\n \"Have fun using the Grace browser!\"\n\nin conclusion\n" }, { "path": "examples/tutorial/data.ffg", "content": "# A record will render as a definition list when converted to HTML\n\n{ \"An example string\": \"Mercury\"\n, \"An example string with a type annotation\": \"cosmic\" : Text\n, \"A boolean value\": true\n, \"Annotated boolean value\": false : Bool\n, \"A natural number\": 42\n, \"An integer\": -12\n, \"A real number\": 3.14159265359\n, \"A list of natural numbers\": [ 1, 1, 2, 3, 5, 8, 13 ]\n, \"Annotated list of natural numbers\": [ 1, 1, 2, 3, 5, 8, 13 ] : List Natural\n, \"Annotated record\": { x: 0, y: 0 } : { x: Natural, y: Natural }\n, \"A list of records (using JSON syntax with quoted field names)\":\n [ { \"isActive\": true\n , \"age\": 36\n , \"name\": \"Dunlap Hubbard\"\n , \"email\": \"dunlaphubbard@example.com\"\n , \"phone\": \"+1 (555) 543-2508\"\n }\n , { \"isActive\": true\n , \"age\": 24\n , \"name\": \"Kirsten Sellers\"\n , \"email\": \"kirstensellers@example.com\"\n , \"phone\": \"+1 (555) 564-2190\"\n }\n ]\n}\n\n# What type do you think the last field has? Switch to the \"Type\" tab below\n# to check your guess, then switch back to the \"Form\" tab before proceeding to\n# the next example.\n" }, { "path": "examples/tutorial/functions.ffg", "content": "# You can also define functions using `let` expressions:\nlet greet{ name } = \"Hello, ${name}!\"\n\nlet greeting = greet{ name: \"world\" }\n\n# You can add optional type annotations to a function's arguments and output:\nlet greet{ name: Text } : Text = \"Hello, ${name}!\"\n# The type of the `greet` function is `{ name: Text } -> Text` which you can\n# read as \"a function whose input is a record (with a `name` field) and whose\n# output is `Text`\"\n\n# Function definitions can define intermediate variables:\nlet makeUser{ user } =\n let home = \"/home/${user}\"\n let privateKey = \"${home}/.ssh/id_ed25519\"\n let publicKey = \"${privateKey}.pub\"\n in { home, privateKey, publicKey }\n# What do you think the type of the `makeUser` function is? Check the \"Type\"\n# tab below to check your guess.\n\nlet users =\n [ makeUser{ user: \"bill\" }\n , makeUser{ user: \"jane\" }\n ]\n\n# We include the functions we defined (i.e. `greet` and `makeUser`) in the\n# output because the Grace browser can render functions as interactive forms.\n# Switch back to the \"Form\" tab and try entering your name into the generated\n# interactive forms.\nin { greet\n , greeting\n , makeUser\n , users\n }\n" }, { "path": "examples/tutorial/hello.ffg", "content": "# This is a tour of the Fall-from-Grace language (a.k.a. \"Grace\" for short).\n#\n# First, any line prefixed with a \"#\" character is a comment, like this one.\n#\n# Second, any change you make to this editable code area will show up below.\n# Try editing the string \"Hello, world!\" below to replace \"world\" with your\n# name.\n#\n# Once you are done, click on the \"HTML\" tab above to proceed to the next\n# example.\n\n\"Hello, world!\"\n" }, { "path": "examples/tutorial/html.ffg", "content": "# This Grace browser attempts to faithfully render any Grace expression\n# as an equivalent HTML representation. For example, a list of boolean\n# values such as these will render as an HTML list of checkboxes:\n\n[ true, false, true ]\n\n# Try adding another false value to the above list.\n" }, { "path": "examples/tutorial/imports.ffg", "content": "{ \"URL import\":\n # You can import Grace expressions by their URL. For example, the following\n # URL encodes a function for computing US federal income tax for 2022:\n https://raw.githubusercontent.com/Gabriella439/grace/refs/heads/main/examples/taxes.ffg\n\n, \"GitHub import\":\n # Grace also provides built-in support for importing expressions hosted on\n # GitHub, using the `github` keyword:\n import github\n { owner: \"Gabriella439\"\n , repository: \"grace\"\n , reference: \"main\" # Optional field which defaults to the trunk branch\n , path: \"examples/taxes.ffg\"\n }\n\n, \"Short link\":\n \"\n The Grace browser also supports short links for code hosted on GitHub. For\n example, the short link for the above federal income tax form is:\n\n [https://trygrace.dev?github=Gabriella439/grace/examples/taxes.ffg](https://trygrace.dev?github=Gabriella439/grace/examples/taxes.ffg)\n\n More generally, the format of GitHub short links is:\n\n ```\n https://trygrace.dev?github=\\${owner}/\\${repository}/\\${path}[&reference=\\${reference}][&private=true]\n ```\n\n - `&reference=\\${reference}` pins the short link to a specific git reference\n\n … and defaults to the trunk branch of the repository.\n\n - `&private=true` will prompt you for a GitHub personal access token\n\n … so that you can import from a private GitHub repository.\n\n GitHub code imported in this way is displayed as a \\\"white-label\\\" form\n displaying just the form without the title bar or the code editor.\n \"\n\n, \"Import Prelude function\":\n # Grace also has a Prelude of utility functions derived from built-in\n # functions that you can also use.\n #\n # You can import functions individually, like this:\n import github\n { owner: \"Gabriella439\"\n , repository: \"grace\"\n , path: \"prelude/bool/not.ffg\"\n }\n\n\n, \"Import entire Prelude\":\n # You can also import the Prelude as a whole:\n let prelude = import github\n { owner: \"Gabriella439\"\n , repository: \"grace\"\n , path: \"prelude/package.ffg\"\n }\n\n # … which is a giant nested record with all the utilities nested inside.\n in prelude.bool.not\n}\n\n# Replace the above `prelude.bool.not` with just `prelude` and see what happens.\n" }, { "path": "examples/tutorial/prompting.ffg", "content": "# Grace provides built-in language support for LLMs using the `prompt` function.\n# To run these examples you will need to provide an OpenAI API key below and.\n# and then click \"Submit\".\n\\arguments ->\n\nlet key = arguments.\"OpenAI API key\" in\n\n{ # You can prompt a model with `Text`, which will (by default) return `Text`:\n names: prompt{ key, text: \"Give me a list of names\" }\n\n, # You can request structured output with a type annotation, like this:\n structuredNames: prompt{ key, text: \"Give me a list of names\" } : List Text\n\n, # If you request a record with first and last name fields then the model will\n # adjust its output to match:\n fullNames:\n prompt{ key, text: \"Give me a list of names\" }\n : List { firstName: Text, lastName: Text }\n\n, # In fact, that type is descriptive enough that we can just omit the prompt:\n tacitFullNames: prompt{ key } : List { firstName: Text, lastName: Text }\n\n, # By default the `prompt` keyword selects the `gpt-5-mini` model, but you can\n # specify other models using the `model` argument:\n differentModel:\n prompt{ key, model: \"gpt-5-nano\" } : List { firstName: Text, lastName: Text }\n}\n\n# Try switching to the \"Code\" tab below to view the code for the result, then\n# switch back to the \"Form\" tab and continue to the next example.\n" }, { "path": "examples/tutorial/variables.ffg", "content": "# You can define a variable using `let`:\nlet john = { name: \"John Doe\", age: 24 }\n\n# Variables can reference earlier variables:\nlet twentyFour = john.age\n\n# You can nest `let` expressions:\nlet nine = let three = 3\n in three * three\n\nin nine * twentyFour\n# Grace is whitespace-insensitive (with the exception of comments, which extend\n# to the next newline character), so try deleting all of the above comments and\n# modifying the above code to fit on one line.\n" }, { "path": "examples/users.ffg", "content": "# Grace version of an example from https://dhall-lang.org/\nlet makeUser{ user }=\n let home = \"/home/${user}\"\n\n let privateKey = \"${home}/.ssh/id_ed25519\"\n\n let publicKey = \"${privateKey}.pub\"\n\n in { home, privateKey, publicKey }\n\nin [ makeUser{ user: \"bill\" }\n , makeUser{ user: \"jane\" }\n ]\n" }, { "path": "flake.nix", "content": "{\n inputs = {\n garnix-lib.url = \"github:garnix-io/garnix-lib\";\n\n nixpkgs.url = github:NixOS/nixpkgs/24.11;\n\n utils.url = github:numtide/flake-utils;\n };\n\n outputs = { garnix-lib, nixpkgs, utils, self }:\n let\n overlay = compiler: self: super: {\n codemirror = self.fetchzip {\n url = \"https://codemirror.net/5/codemirror.zip\";\n sha256 = \"sha256-TS4JVTRIwdWj/CihELhhC3Rte9DT0Tv239eZKR6MT6w=\";\n };\n\n haskell = super.haskell // {\n packages = super.haskell.packages // {\n ghc810 = super.haskell.packages.ghc810.override (old: {\n overrides =\n let\n hlib = self.haskell.lib;\n\n oldOverrides = old.overrides or (_: _: {});\n\n in\n self.lib.composeExtensions\n oldOverrides\n (hself: hsuper: {\n warp = hlib.dontCheck hsuper.warp;\n });\n });\n\n \"${compiler}\" = super.haskell.packages.\"${compiler}\".override (old: {\n overrides =\n let\n hlib = self.haskell.lib;\n\n mass = f:\n self.lib.fold\n (name:\n self.lib.composeExtensions\n (hself: hsuper: {\n \"${name}\" = f hsuper.\"${name}\";\n })\n )\n (_: _: { });\n\n oldOverrides = old.overrides or (_: _: {});\n\n directoryOverrides = hlib.packagesFromDirectory {\n directory = ./dependencies;\n };\n\n ghcjsManualOverrides =\n self.lib.fold self.lib.composeExtensions (_: _: { }) [\n (mass hlib.doJailbreak [\n \"aeson_1_5_6_0\"\n \"ghcjs-base\"\n \"ghcjs-fetch\"\n \"openai\"\n ])\n\n (hself: hsuper: {\n mkDerivation = args: hsuper.mkDerivation (args // {\n doCheck = false;\n doHaddock = false;\n });\n\n aeson = hself.aeson_1_5_6_0;\n\n entropy =\n hlib.addBuildDepends\n hsuper.entropy\n [ hself.ghcjs-dom\n hself.jsaddle\n ];\n\n exceptions = hself.exceptions_0_10_8;\n\n grace = hself.grace-ghcjs;\n\n ghcjs-fetch =\n hlib.addBuildDepends\n hsuper.ghcjs-fetch\n [ hself.ghcjs-base ];\n\n # haskeline = hself.haskeline_0_8_2;\n\n network = hsuper.network.overrideAttrs (old: {\n dontUpdateAutotoolsGnuConfigScripts = true;\n });\n\n servant-multipart-client =\n hlib.overrideCabal\n (hsuper.servant-multipart-client.override (old: {\n servant-multipart = null;\n\n servant-server = null;\n\n warp = null;\n }))\n (old: {\n buildDepends = (old.buildDepends or []) ++ [\n hself.servant\n hself.servant-client\n ];\n postPatch = (old.postPatch or \"\") +\n ''\n sed -i -e 's/servant .*<0.19/servant/' -e 's/servant-client-core .*<0.19/servant-client-core/' servant-multipart-client.cabal\n '';\n });\n })\n ];\n\n ghcjsSourceOverrides = hlib.packageSourceOverrides {\n modern-uri = \"0.3.4.4\";\n\n unordered-containers = \"0.2.18.0\";\n };\n\n manualOverrides = hself: hsuper: {\n grace =\n hlib.justStaticExecutables\n (hlib.overrideCabal hsuper.grace (old: {\n doCheck = false;\n\n src =\n self.lib.cleanSourceWith\n { inherit (old) src;\n\n filter = path: type:\n self.lib.cleanSourceFilter path type\n && ! ( ( type == \"regular\"\n && ( self.lib.hasSuffix \".nix\" (baseNameOf path)\n || self.lib.hasSuffix \".md\" (baseNameOf path)\n || self.lib.hasSuffix \".yaml\" (baseNameOf path)\n || baseNameOf path == \"cabal.project.local\"\n )\n )\n || ( type == \"directory\"\n && (builtins.elem (baseNameOf path) [\n \"dist\"\n \"dist-newstyle\"\n \"examples\"\n \"prelude\"\n \"website\"\n ])\n )\n );\n };\n }));\n\n openai = hlib.dontCheck hsuper.openai;\n };\n\n in\n self.lib.fold self.lib.composeExtensions oldOverrides\n ( [ directoryOverrides ]\n ++ self.lib.optional (compiler == \"ghcjs\") ghcjsSourceOverrides\n ++ self.lib.optional (compiler == \"ghcjs\") ghcjsManualOverrides\n ++ [ manualOverrides ]\n );\n });\n };\n };\n\n haskell-language-server =\n super.haskell-language-server.override (old: {\n haskellPackages = super.haskell.packages.\"${compiler}\";\n\n supportedGhcVersions = [ \"96\" ];\n });\n\n docker-stream =\n let\n configuration = self.writeText \"nginx.conf\"\n ''\n events {\n }\n\n error_log /dev/stderr;\n\n http {\n access_log /dev/stdout;\n\n include ${self.nginx}/conf/mime.types;\n\n default_type application/octet-stream;\n\n server {\n listen 8080;\n\n root ${self.website};\n\n index index.html;\n\n add_header X-Content-Type-Options nosniff;\n add_header X-Frame-Options SAMEORIGIN;\n\n gzip on;\n gzip_types application/javascript;\n\n location ~ \\.js$ {\n add_header Cache-Control \"public, max-age=31536000, immutable\";\n }\n }\n }\n\n daemon off;\n '';\n\n args = {\n name = \"grace\";\n\n tag = \"latest\";\n\n config = {\n Cmd = [ (self.lib.getExe self.nginx) \"-c\" configuration ];\n\n User = \"65534:65534\";\n };\n\n enableFakechroot = true;\n\n fakeRootCommands =\n ''\n paths=(\n /var/cache/nginx/{client_body,proxy,fastcgi,uwsgi,scgi}\n /var/log/nginx\n )\n\n mkdir -p \"''${paths[@]}\"\n\n chown -R 65534:65534 \"''${paths[@]}\"\n '';\n };\n\n in\n self.dockerTools.streamLayeredImage (args // {\n passthru = { inherit args; };\n });\n\n docker-image =\n self.dockerTools.buildLayeredImage self.docker-stream.passthru.args;\n\n website = self.runCommand \"try-grace\" { nativeBuildInputs = [ self.rsync ]; } ''\n js=js/''${out:11:32}\n\n mkdir -p $out/{css,prelude,prompts,examples} $out/$js\n\n rsync --recursive ${./website}/ $out\n rsync --recursive ${./prelude}/ $out/prelude\n rsync --recursive ${./prompts}/ $out/prompts\n rsync --recursive ${./examples}/ $out/examples\n\n cp ${self.codemirror}/lib/codemirror.css --target-directory=$out/css\n cp ${self.codemirror}/lib/codemirror.js --target-directory=$out/$js\n cp ${self.codemirror}/addon/display/placeholder.js --target-directory=$out/$js\n cp ${self.codemirror}/mode/python/python.js --target-directory=$out/$js\n cp ${self.haskell.packages.\"${compiler}\".grace}/bin/try-grace.jsexe/all.js --target-directory=$out/$js\n\n sed --in-place 's!src=\"js/!src=\"'\"$js\"'/!g' $out/index.html\n '';\n };\n\n in\n utils.lib.eachDefaultSystem (system:\n let\n withCompiler = compiler:\n let\n config.allowBroken = true;\n\n pkgs = import nixpkgs {\n inherit config system;\n\n overlays = [ (overlay compiler) ];\n };\n\n grace = pkgs.haskell.packages.\"${compiler}\".grace;\n\n shell = pkgs.haskell.packages.\"${compiler}\".shellFor {\n packages = hpkgs: [ (pkgs.haskell.lib.doCheck hpkgs.grace) ];\n\n nativeBuildInputs = [ pkgs.haskell-language-server ];\n\n withHoogle = true;\n\n doBenchmark = true;\n };\n\n in\n { inherit grace shell;\n\n inherit (pkgs) docker-image docker-stream website;\n };\n\n ghc = withCompiler \"ghc96\";\n\n ghcjs = withCompiler \"ghcjs\";\n\n in\n { packages = {\n default = ghc.grace;\n\n docker-image = ghcjs.docker-image;\n\n docker-stream = ghcjs.docker-stream;\n\n website = ghcjs.website;\n };\n\n apps = {\n default = {\n type = \"app\";\n\n program = nixpkgs.lib.getExe self.packages.\"${system}\".default;\n };\n\n docker-stream = {\n type = \"app\";\n\n program = \"${self.packages.\"${system}\".docker-stream}\";\n };\n };\n\n devShells = {\n default = ghc.shell;\n\n ghcjs = ghcjs.grace.env;\n };\n }) // {\n overlays = nixpkgs.lib.genAttrs [ \"ghc96\" \"ghcjs\" ] overlay;\n\n nixosConfigurations =\n let\n defaultModule = { pkgs, ... }: {\n documentation.nixos.enable = false;\n\n networking = {\n firewall.allowedTCPPorts = [ 80 443 ];\n\n hostName = \"trygrace\";\n };\n\n nix.settings.trusted-users = [\n \"gabriella\"\n ];\n\n nixpkgs = {\n config.allowBroken = true;\n\n overlays = [ self.overlays.ghcjs ];\n };\n\n security = {\n acme = {\n acceptTerms = true;\n\n email = \"GenuineGabriella@gmail.com\";\n };\n\n sudo.wheelNeedsPassword = false;\n };\n\n services = {\n nginx = {\n enable = true;\n\n recommendedGzipSettings = true;\n\n recommendedOptimisation = true;\n\n recommendedTlsSettings = true;\n\n recommendedProxySettings = true;\n\n virtualHosts = {\n \"trygrace.dev\" = {\n default = true;\n\n forceSSL = true;\n\n enableACME = true;\n\n locations.\"/\" = {\n index = \"index.html\";\n\n root = pkgs.website;\n };\n };\n };\n };\n\n openssh.enable = true;\n };\n\n system.stateVersion = \"22.05\";\n\n time.timeZone = \"America/Los_Angeles\";\n\n users = {\n mutableUsers = false;\n\n users.gabriella = {\n isNormalUser = true;\n\n extraGroups = [ \"wheel\" ];\n\n openssh.authorizedKeys.keys = [\n \"ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIMuH6HDuoMlK7b2Ovm5VKt9P3aRrJ2HeUPptKG+21kjL gabriella@Gabriellas-MacBook-Pro.local\"\n \"ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIC/nXKUEQsKukm+eIKmwzWoybKzwQTiYzGZqrWmHYwYe gabriella@lucina.local\"\n ];\n };\n };\n };\n\n qemuModule = { modulesPath, ... }: {\n imports = [\n \"${modulesPath}/virtualisation/qemu-vm.nix\"\n ];\n\n config.virtualisation.host.pkgs = import nixpkgs {\n system = \"aarch64-darwin\";\n\n config.allowBroken = true;\n\n overlays = [ self.overlays.ghcjs ];\n };\n };\n\n garnixModule = {\n imports = [ garnix-lib.nixosModules.garnix ];\n\n config.garnix.server = {\n enable = true;\n\n persistence = {\n enable = true;\n\n name = \"main\";\n };\n };\n };\n\n garnix = nixpkgs.lib.nixosSystem {\n system = \"x86_64-linux\";\n\n modules = [ defaultModule garnixModule ];\n };\n\n qemu = nixpkgs.lib.nixosSystem {\n system = \"x86_64-linux\";\n\n modules = [ defaultModule qemuModule ];\n };\n\n in\n { default = garnix;\n\n inherit garnix qemu;\n };\n };\n\n nixConfig = {\n extra-substituters = [ \"https://cache.garnix.io\" ];\n\n extra-trusted-public-keys = [\n \"cache.garnix.io:CTFPyKSLcx5RMJKfLo5EEPUObbA78b0YQ2DTCJXqr9g=\"\n ];\n };\n}\n" }, { "path": "garnix.yaml", "content": "builds:\n exclude: []\n include:\n - packages.aarch64-darwin.default\n - packages.x86_64-linux.default\n - packages.aarch64-linux.default\n - packages.x86_64-linux.docker-image\n - packages.x86_64-linux.docker-stream\n - devShells.aarch64-darwin.default\n - devShells.x86_64-linux.default\n - devShells.aarch64-linux.default\n - packages.x86_64-linux.website\n - packages.aarch64-linux.website\n - packages.aarch64-darwin.website\n - apps.aarch64-darwin.default\n - apps.x86_64-linux.default\n - apps.aarch64-linux.default\n - nixosConfigurations.default\nservers:\n- configuration: default\n deployment:\n type: on-branch\n branch: main\n" }, { "path": "ghc/Grace/DataFile.hs", "content": "{-| This module provides a uniform interface for accessing data files using\n both GHC and GHCJS\n-}\nmodule Grace.DataFile\n ( readDataFile\n ) where\n\nimport Data.Text (Text)\n\nimport qualified Paths_grace as Paths\nimport qualified Data.Text.IO as Text.IO\n\n-- | Read a data file by its relative path\nreadDataFile :: FilePath -> IO Text\nreadDataFile relativePath = do\n absolutePath <- Paths.getDataFileName relativePath\n\n Text.IO.readFile absolutePath\n" }, { "path": "ghc/Grace/HTTP.hs", "content": "{-| This module provides a uniform interface for making HTTP requests using both\n GHC and GHCJS\n-}\nmodule Grace.HTTP\n ( HttpException\n , fetch\n , HTTP(..)\n , Header(..)\n , Parameter(..)\n , http\n , renderError\n , Methods\n , getMethods\n , Grace.HTTP.createChatCompletion\n ) where\n\nimport Control.Concurrent.MVar (MVar)\nimport Control.Exception.Safe (Exception(..), Handler(..))\nimport Data.Text (Text)\nimport Data.Text.Encoding.Error (UnicodeException)\nimport OpenAI.V1 (Methods(..))\nimport OpenAI.V1.Chat.Completions (ChatCompletionObject, CreateChatCompletion)\nimport Servant.Client.Core.ClientError (ClientError(..))\nimport Servant.Client.Core.Response (ResponseF(..))\n\nimport Grace.HTTP.Type\n ( Header(..)\n , HTTP(..)\n , Parameter(..)\n , completeHeaders\n , organization\n , renderQueryText\n )\nimport Network.HTTP.Client\n ( HttpExceptionContent(..)\n , Manager\n , ManagerSettings(..)\n , Request(..)\n , RequestBody(..)\n , method\n )\n\nimport qualified Control.Concurrent.MVar as MVar\nimport qualified Control.Exception.Safe as Exception\nimport qualified Control.Retry as Retry\nimport qualified Data.Aeson as Aeson\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Encoding\nimport qualified Data.Text.Lazy as Text.Lazy\nimport qualified Data.Text.Lazy.Encoding as Lazy.Encoding\nimport qualified Network.HTTP.Types.Status as Status\nimport qualified Network.HTTP.Client as HTTP\nimport qualified Network.HTTP.Client.TLS as TLS\nimport qualified Network.HTTP.Types as HTTP.Types\nimport qualified OpenAI.V1 as OpenAI\nimport qualified Servant.Client as Client\nimport qualified System.IO.Unsafe as Unsafe\n\n-- | Exception type thrown by `fetch` in the event of any failure\ndata HttpException\n = HttpException HTTP.HttpException\n | NotUTF8 UnicodeException\n deriving stock (Show)\n\ninstance Exception HttpException where\n displayException = Text.unpack . renderError\n\nmanagerMVar :: MVar (Maybe Manager)\nmanagerMVar = Unsafe.unsafePerformIO (MVar.newMVar Nothing)\n{-# NOINLINE managerMVar #-}\n\nretry :: IO a -> IO a\nretry io =\n Retry.recovering\n retryPolicy\n [ \\_ -> Handler handler\n ]\n (\\_ -> io)\n where\n retryPolicy = Retry.fullJitterBackoff 1000000 <> Retry.limitRetries 3\n\n handler (FailureResponse _ Response{ responseStatusCode }) =\n return (Status.statusIsServerError responseStatusCode)\n handler (ConnectionError _) =\n return True\n handler _ =\n return False\n\n-- | Acquire a new `Manager`\n--\n-- This is safe to call multiple times. The `Manager` returned by the first\n-- call is cached and reused by subsequent calls.\nnewManager :: IO Manager\nnewManager = MVar.modifyMVar managerMVar \\maybeManager -> do\n manager <- case maybeManager of\n Nothing -> do\n TLS.newTlsManagerWith TLS.tlsManagerSettings\n { managerResponseTimeout = HTTP.responseTimeoutNone\n , managerRetryableException = \\exception ->\n case Exception.fromException exception of\n Just (FailureResponse _ Response{ responseStatusCode }) ->\n Status.statusIsServerError responseStatusCode\n Just (ConnectionError _) ->\n True\n _ ->\n False\n }\n\n Just manager -> do\n return manager\n\n return (Just manager, manager)\n\n-- | Fetch a URL (using the @http-client@ package)\nfetch\n :: Text\n -- ^ URL\n -> IO Text\n -- ^ Response body\nfetch url = do\n manager <- newManager\n\n request <- HTTP.parseUrlThrow (Text.unpack url)\n\n let handler :: HTTP.HttpException -> IO a\n handler httpException = Exception.throwIO (HttpException httpException)\n\n response <- Exception.handle handler (HTTP.httpLbs request manager)\n\n let lazyBytes = HTTP.responseBody response\n\n case Lazy.Encoding.decodeUtf8' lazyBytes of\n Left exception -> Exception.throwIO (NotUTF8 exception)\n Right lazyText -> return (Text.Lazy.toStrict lazyText)\n\n-- | Make a HTTP request\nhttp :: Bool -> HTTP -> IO Text\nhttp import_ GET{ url, headers, parameters } = do\n manager <- newManager\n\n renderedURL <- renderQueryText url parameters\n\n request₀ <- HTTP.parseUrlThrow (Text.unpack renderedURL)\n\n let request₁ = request₀\n { method = HTTP.Types.methodGet\n , requestHeaders = completeHeaders import_ False headers\n }\n\n let handler :: HTTP.HttpException -> IO a\n handler httpException = Exception.throwIO (HttpException httpException)\n\n response <- Exception.handle handler (HTTP.httpLbs request₁ manager)\n\n case Lazy.Encoding.decodeUtf8' (HTTP.responseBody response) of\n Left exception -> Exception.throwIO (NotUTF8 exception)\n Right lazyText -> return (Text.Lazy.toStrict lazyText)\n\nhttp import_ POST{ url, headers, request } = do\n manager <- newManager\n\n request₀ <- HTTP.parseUrlThrow (Text.unpack url)\n\n let request₁ = request₀\n { method = HTTP.Types.methodPost\n , requestHeaders = completeHeaders import_ body headers\n }\n where\n body = case request of\n Nothing -> False\n Just _ -> True\n\n let request₂ = case request of\n Nothing ->\n request₁\n Just requestBody ->\n request₁{ requestBody = RequestBodyLBS (Aeson.encode requestBody) }\n\n let handler :: HTTP.HttpException -> IO a\n handler httpException = Exception.throwIO (HttpException httpException)\n\n response <- Exception.handle handler (HTTP.httpLbs request₂ manager)\n\n case Lazy.Encoding.decodeUtf8' (HTTP.responseBody response) of\n Left exception -> Exception.throwIO (NotUTF8 exception)\n Right lazyText -> return (Text.Lazy.toStrict lazyText)\n\n-- | Render an `HttpException` as `Data.Text.Text`\nrenderError :: HttpException -> Text\nrenderError (HttpException httpException) = case httpException of\n HTTP.InvalidUrlException _ _ ->\n \"Invalid URL\"\n\n HTTP.HttpExceptionRequest _ e -> case e of\n ConnectionFailure _ ->\n \"Remote host not found\"\n InvalidDestinationHost _ ->\n \"Invalid remote host name\"\n ResponseTimeout ->\n \"The remote host took too long to respond\"\n ConnectionTimeout ->\n \"Connection establishment took too long\"\n StatusCodeException response body -> prefix <> suffix\n where\n statusCode =\n HTTP.Types.statusCode (HTTP.responseStatus response)\n\n prefix =\n case statusCode of\n 401 -> \"Access unauthorized\"\n 403 -> \"Access forbidden\"\n 404 -> \"Remote file not found\"\n 500 -> \"Server-side failure\"\n 502 -> \"Upstream failure\"\n 503 -> \"Server temporarily unavailable\"\n 504 -> \"Upstream timeout\"\n _ -> \"HTTP request failure\"\n\n suffix =\n \"\\n\\\n \\\\n\\\n \\HTTP status code: \" <> Text.pack (show statusCode) <> responseBody\n\n responseBody :: Text\n responseBody =\n case Encoding.decodeUtf8' body of\n Left _ ->\n \"\\n\\\n \\\\n\\\n \\Response body (non-UTF8 bytes):\\n\\\n \\\\n\\\n \\\" <> Text.pack (show body)\n Right \"\" ->\n \"\"\n Right bodyText ->\n \"\\n\\n\"\n <> \"Response body:\\n\\\n \\\\n\\\n \\\" <> prefixedText\n where\n prefixedLines =\n zipWith combine prefixes\n (Text.lines bodyText)\n <> [ \"…│ …\" ]\n where\n prefixes = [(1 :: Int)..7]\n\n combine n line =\n Text.pack (show n) <> \"│ \" <> line\n\n prefixedText = Text.unlines prefixedLines\n _ ->\n \"HTTP request failure\\n\\\n \\\\n\\\n \\\" <> Text.pack (displayException httpException)\nrenderError (NotUTF8 unicodeException) =\n \"Not UTF8\\n\\\n \\\\n\\\n \\\" <> Text.pack (displayException unicodeException)\n\n-- | Initialize API for prompting\ngetMethods :: IO (Text -> Methods)\ngetMethods = do\n baseUrl <- Client.parseBaseUrl \"https://api.openai.com\"\n\n manager <- newManager\n\n let clientEnv = Client.mkClientEnv manager baseUrl\n\n return (\\key -> OpenAI.makeMethods clientEnv key organization Nothing)\n\n-- | This powers the @prompt@ keyword\ncreateChatCompletion\n :: Methods\n -> CreateChatCompletion\n -> IO ChatCompletionObject\ncreateChatCompletion Methods{ createChatCompletion = c } x = retry (c x)\n" }, { "path": "ghc/Grace/Width.hs", "content": "{-| This module provides a uniform interface for getting the console width using\n both GHC and GHCJS\n-}\nmodule Grace.Width\n ( -- * Width\n getWidth\n , defaultWidth\n ) where\n\nimport System.Console.Terminal.Size (Window(..))\n\nimport qualified System.Console.Terminal.Size as Size\n\n-- | Get the width of the terminal (in columns)\ngetWidth :: IO Int\ngetWidth = do\n maybeWindow <- Size.size\n\n let renderWidth = case maybeWindow of\n Nothing -> defaultWidth\n Just Window{ width } -> width\n\n return renderWidth\n\n-- | The default width to use\ndefaultWidth :: Int\ndefaultWidth = 80\n" }, { "path": "ghcjs/Grace/DataFile.hs", "content": "{-| This module provides a uniform interface for accessing data files using\n both GHC and GHCJS\n-}\nmodule Grace.DataFile\n ( readDataFile\n ) where\n\nimport Data.Text (Text)\n\nimport qualified Data.Text as Text\nimport qualified Grace.HTTP as HTTP\n\n-- | Read a data file by its relative path\nreadDataFile :: FilePath -> IO Text\nreadDataFile relativePath = do\n HTTP.fetch (Text.pack relativePath)\n" }, { "path": "ghcjs/Grace/HTTP.hs", "content": "{-| This module provides a uniform interface for making HTTP requests using both\n GHC and GHCJS\n-}\nmodule Grace.HTTP\n ( HttpException\n , fetch\n , HTTP(..)\n , Header(..)\n , Parameter(..)\n , http\n , renderError\n , Methods\n , getMethods\n , createChatCompletion\n ) where\n\nimport Control.Exception.Safe (Exception(..))\nimport Data.Text (Text)\nimport GHCJS.Fetch.Types (JSResponse)\nimport OpenAI.V1.Chat.Completions (ChatCompletionObject, CreateChatCompletion)\n\nimport Grace.HTTP.Type\n ( Header(..)\n , HTTP(..)\n , Parameter(..)\n , completeHeaders\n , organization\n , renderQueryText\n )\nimport GHCJS.Fetch\n ( Request(..)\n , RequestCacheMode(..)\n , RequestOptions(..)\n , JSPromiseException\n )\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Data.Aeson as Aeson\nimport qualified Data.ByteString.Lazy as ByteString.Lazy\nimport qualified Data.JSString as JSString\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Encoding\nimport qualified GHCJS.Fetch as Fetch\nimport qualified GHCJS.Prim as Prim\nimport qualified Network.HTTP.Types as HTTP.Types\n\n-- | An `HttpException` is just a type synonym for a `JSPromiseException`\ntype HttpException = JSPromiseException\n\n-- | Fetch a URL (using @XMLHttpRequest@)\nfetch\n :: Text\n -- ^ URL\n -> IO Text\n -- ^ Response body\nfetch url = do\n let request = Request\n { reqUrl = JSString.pack (Text.unpack url)\n , reqOptions = Fetch.defaultRequestOptions\n { reqOptMethod = HTTP.Types.methodGet\n , reqOptCacheMode = NoStore\n }\n }\n\n response <- Fetch.fetch request\n\n jsString <- Fetch.responseText response\n\n return (Text.pack (JSString.unpack jsString))\n\nresponseToText :: JSResponse -> IO Text\nresponseToText response = do\n jsString <- Fetch.responseText response\n\n return (Text.pack (JSString.unpack jsString))\n\n-- | Make an HTTP request\nhttp :: Bool -> HTTP -> IO Text\nhttp import_ GET{ url, headers, parameters } = do\n newURL <- renderQueryText url parameters\n\n let reqUrl = JSString.pack (Text.unpack newURL)\n\n let reqOptions = Fetch.defaultRequestOptions\n { reqOptHeaders = completeHeaders import_ False headers\n , reqOptMethod = HTTP.Types.methodGet\n , reqOptCacheMode = NoStore\n }\n\n let request = Request{ reqUrl, reqOptions }\n\n response <- Fetch.fetch request\n\n responseToText response\n\nhttp import_ POST{ url, headers, request } = do\n newURL <- renderQueryText url Nothing\n\n let reqUrl = JSString.pack (Text.unpack newURL)\n\n let reqOptions₀ = Fetch.defaultRequestOptions\n { reqOptHeaders = completeHeaders import_ body headers\n , reqOptMethod = HTTP.Types.methodPost\n , reqOptCacheMode = NoStore\n }\n where\n body = case request of\n Nothing -> False\n Just _ -> True\n\n reqOptions <- case request of\n Nothing -> do\n return reqOptions₀\n\n Just requestBody -> do\n requestText <- case Encoding.decodeUtf8' (ByteString.Lazy.toStrict (Aeson.encode requestBody)) of\n Left exception -> Exception.throwIO exception\n Right text -> return text\n\n let reqOptBody =\n Just (Prim.toJSString (Text.unpack requestText))\n\n return reqOptions₀{ reqOptBody }\n\n response <- Fetch.fetch Request{ reqUrl, reqOptions }\n\n responseToText response\n\n-- | Render an `HttpException` as `Data.Text.Text`\nrenderError :: HttpException -> Text\nrenderError = Text.pack . displayException\n\n-- | The GHCJS implementation of OpenAI bindings just stores the API key\ntype Methods = Text\n\n-- | Initialize API for prompting\ngetMethods :: IO (Text -> Methods)\ngetMethods = return id\n\n-- | This powers the @prompt@ keyword\ncreateChatCompletion\n :: Methods\n -> CreateChatCompletion\n -> IO ChatCompletionObject\ncreateChatCompletion key createChatCompletion_ = do\n let keyBytes = Encoding.encodeUtf8 key\n\n body <- case Encoding.decodeUtf8' (ByteString.Lazy.toStrict (Aeson.encode createChatCompletion_)) of\n Left exception -> Exception.throwIO exception\n Right text -> return (Text.unpack text)\n\n let organizationHeader = case organization of\n Nothing -> []\n Just o -> [(\"OpenAI-Organization\", Encoding.encodeUtf8 o)]\n\n let request = Request\n { reqUrl = \"https://api.openai.com/v1/chat/completions\"\n , reqOptions = Fetch.defaultRequestOptions\n { reqOptMethod = \"POST\"\n , reqOptHeaders =\n [ (\"Content-Type\", \"application/json\")\n , (\"Authorization\", \"Bearer \" <> keyBytes)\n ] <> organizationHeader\n , reqOptBody = Just (Prim.toJSString body)\n , reqOptCacheMode = NoStore\n }\n }\n\n response <- Fetch.fetch request\n\n jsString <- Fetch.responseText response\n\n let strictBytes = Encoding.encodeUtf8 (Text.pack (JSString.unpack jsString))\n\n let lazyBytes = ByteString.Lazy.fromStrict strictBytes\n\n case Aeson.eitherDecode lazyBytes of\n Left string ->\n fail string\n Right chatCompletionObject ->\n return chatCompletionObject\n" }, { "path": "ghcjs/Grace/Size.hs", "content": "module Grace.Width\n ( -- * Width\n getWidth\n ) where\n\n-- | Get the width of the terminal (in columns)\ngetWidth :: IO Int\ngetWidth = pure 80\n" }, { "path": "ghcjs/Grace/Width.hs", "content": "{-| This module provides a uniform interface for getting the console width using\n both GHC and GHCJS\n-}\nmodule Grace.Width\n ( -- * Width\n getWidth\n , defaultWidth\n ) where\n\n-- | Get the width of the terminal (in columns)\ngetWidth :: IO Int\ngetWidth = pure defaultWidth\n\n-- | The default column size to use\ndefaultWidth :: Int\ndefaultWidth = 80\n" }, { "path": "grace/Main.hs", "content": "module Main where\n\nimport qualified Grace\n\nmain :: IO ()\nmain = Grace.main\n" }, { "path": "grace.cabal", "content": "cabal-version: >=1.10\nname: grace\nversion: 1.0.0\nlicense-file: LICENSE\nauthor: Gabriella Gonzalez\nmaintainer: Gabriel439@gmail.com\nbuild-type: Simple\nextra-source-files: examples/*.ffg\n examples/tutorial/*.ffg\n prompts/*.md\n prelude/bool/*.ffg\n prelude/integer/*.ffg\n prelude/list/*.ffg\n prelude/natural/*.ffg\n prelude/package.ffg\n prelude/real/*.ffg\n prelude/text/*.ffg\n\nlibrary\n hs-source-dirs: src\n\n build-depends: base\n , Earley\n , aeson\n , aeson-pretty\n , aeson-yaml\n , async\n , binary\n , bytestring\n , containers\n , case-insensitive\n , directory\n , exceptions\n , filepath\n , generic-lens\n , http-types\n , insert-ordered-containers\n , lens\n , megaparsec\n , modern-uri\n , mmorph\n , mtl\n , openai\n , parser-combinators\n , prettyprinter\n , prettyprinter-ansi-terminal\n , safe-exceptions\n , scientific\n , template-haskell\n , text >= 1.2.4.0\n , time\n , unordered-containers\n , vector\n\n exposed-modules: Grace.Aeson\n , Grace.Context\n , Grace.DataFile\n , Grace.Decode\n , Grace.Domain\n , Grace.Encode\n , Grace.Existential\n , Grace.GitHub\n , Grace.HTTP\n , Grace.Import\n , Grace.Infer\n , Grace.Input\n , Grace.Interpret\n , Grace.Label\n , Grace.Location\n , Grace.Monad\n , Grace.Monotype\n , Grace.Normalize\n , Grace.Parallelizable\n , Grace.Parser\n , Grace.Pretty\n , Grace.Prompt\n , Grace.Prompt.Types\n , Grace.Syntax\n , Grace.Type\n , Grace.Value\n , Grace.Width\n\n other-modules: Grace.Compat\n , Grace.HTTP.Type\n , Grace.Marshal\n , Paths_grace\n\n default-extensions: ApplicativeDo\n , BangPatterns\n , BlockArguments\n , DataKinds\n , DefaultSignatures\n , DeriveAnyClass\n , DeriveFoldable\n , DeriveFunctor\n , DeriveGeneric\n , DeriveLift\n , DeriveTraversable\n , DerivingStrategies\n , DuplicateRecordFields\n , FlexibleContexts\n , FlexibleInstances\n , GeneralizedNewtypeDeriving\n , KindSignatures\n , MultiParamTypeClasses\n , MultiWayIf\n , NamedFieldPuns\n , OverloadedStrings\n , ScopedTypeVariables\n , StandaloneDeriving\n , TypeApplications\n , TypeOperators\n , UndecidableInstances\n , ViewPatterns\n\n default-language: Haskell2010\n\n ghc-options: -Wall -Wmissing-deriving-strategies\n\n if impl(ghcjs) || os(ghcjs)\n hs-source-dirs: ghcjs\n build-depends: ghcjs-base\n , ghcjs-fetch\n , ghcjs-prim\n else\n hs-source-dirs: ghc\n build-depends: ansi-terminal\n , haskeline\n , http-client\n , http-client-tls\n , optparse-applicative\n , repline\n , retry\n , servant-client-core\n , servant-client\n , terminal-size\n exposed-modules: Grace\n , Grace.REPL\n , Grace.TH\n\nexecutable grace\n main-is: Main.hs\n\n build-depends: base\n , grace\n\n hs-source-dirs: grace\n\n default-language: Haskell2010\n\n ghc-options: -threaded -rtsopts -with-rtsopts=-N\n\n if impl(ghcjs) || os(ghcjs)\n buildable: False\n\nexecutable try-grace\n main-is: Main.hs\n\n build-depends: base\n , aeson\n , async\n , containers\n , filepath\n , ghcjs-base\n , grace\n , insert-ordered-containers\n , lens\n , mmorph\n , mtl\n , safe-exceptions\n , scientific\n , stm\n , text\n , transformers\n , uri-encode\n\n hs-source-dirs: try-grace\n\n ghc-options: -Wall\n\n default-language: Haskell2010\n if !(impl(ghcjs) || os(ghcjs))\n buildable: False\n\ntest-suite tasty\n type: exitcode-stdio-1.0\n\n main-is: Main.hs\n\n build-depends: base\n , aeson\n , containers\n , directory\n , filepath\n , grace\n , mtl\n , prettyprinter\n , safe-exceptions\n , scientific\n , tasty\n , tasty-hunit\n , tasty-silver\n , text\n , vector\n\n hs-source-dirs: tasty\n\n default-language: Haskell2010\n\n ghc-options: -Wall\n\ntest-suite doctest\n type: exitcode-stdio-1.0\n\n main-is: Main.hs\n\n build-depends: base\n , doctest\n\n hs-source-dirs: doctest\n\n default-language: Haskell2010\n\n ghc-options: -Wall\n" }, { "path": "prelude/bool/and.ffg", "content": "# Returns `true` if there are no `false`s in the input `List` and `false`\n# otherwise\nlet and\n : List Bool -> Bool\n = fold { cons: \\x -> \\y -> x && y, nil: true }\n\nin and\n" }, { "path": "prelude/bool/not.ffg", "content": "# Negate a `Bool`\nlet not (b : Bool) : Bool = b == false\n\nin not\n" }, { "path": "prelude/bool/or.ffg", "content": "# Returns `false` if there are no `true`s in the input `List` and `true`\n# otherwise\nlet or\n : List Bool -> Bool\n = fold { cons: \\x -> \\y -> x || y, nil: false }\n\nin or\n" }, { "path": "prelude/bool/package.ffg", "content": "{ and: ./and.ffg\n, not: ./not.ffg\n, or: ./or.ffg\n}\n" }, { "path": "prelude/integer/clamp.ffg", "content": "# Convert an `Integer` to a `Natural` number, clamping negative values to `0`\nlet clamp (n : Integer) : Natural = if n < 0 then 0 else abs n\n\nin clamp\n" }, { "path": "prelude/integer/package.ffg", "content": "{ clamp: ./clamp.ffg\n, product: ./product.ffg\n, sum: ./sum.ffg\n, toNatural: ./toNatural.ffg\n}\n" }, { "path": "prelude/integer/product.ffg", "content": "# Multiply the elements of a list\nlet product\n : List Integer -> Integer\n = fold { cons: \\x y -> x * y : Integer, nil: 1 : Integer }\n\nin product\n" }, { "path": "prelude/integer/sum.ffg", "content": "# Add up the elements of a list\nlet sum\n : List Integer -> Integer\n = fold { cons: \\x y -> x + y : Integer, nil: 0 : Integer }\n\nin sum\n" }, { "path": "prelude/integer/toNatural.ffg", "content": "# Convert an `Integer` to a `Natural` number, returning `null` if the `Natural`\n# number is negative\nlet toNatural (n : Integer) : Optional Natural =\n if n < 0 then null else abs n\n\nin toNatural\n" }, { "path": "prelude/list/all.ffg", "content": "# Check if all elements satisfy the given predicate\nlet all\n : forall (a : Type) . (a -> Bool) -> List a -> Bool\n = \\predicate ->\n fold\n { cons: \\element -> \\result -> predicate element && result\n , nil: true\n }\n\nin all\n" }, { "path": "prelude/list/any.ffg", "content": "# Check if any elements satisfy the given predicate\nlet any\n : forall (a : Type) . (a -> Bool) -> List a -> Bool\n = \\predicate ->\n fold\n { cons: \\element -> \\result -> predicate element || result\n , nil: false\n }\n\nin any\n" }, { "path": "prelude/list/concat.ffg", "content": "let concat\n : forall (a : Type) . List (List a) -> List a\n = \\lists ->\n for list of lists\n\n for element of list\n\n in element\n\nin concat\n" }, { "path": "prelude/list/generate.ffg", "content": "# Build a `List` by calling the supplied function on all `Natural` numbers from\n# `0` up to but not including the supplied `Natural` number\nlet replicate = ./replicate.ffg\n\nlet generate\n : forall (a : Type) . Natural -> (Natural -> a) -> List a\n = \\n -> \\f -> map (\\x -> f x.index) (indexed (replicate n { }))\n\nin generate\n" }, { "path": "prelude/list/null.ffg", "content": "# Returns `true` if the `List` is empty and `false` otherwise\nlet null_\n : forall (a : Type) . List a -> Bool\n = \\xs -> length xs == 0\n\nin null_\n" }, { "path": "prelude/list/package.ffg", "content": "{ all: ./all.ffg\n, any: ./any.ffg\n, concat: ./concat.ffg\n, generate: ./generate.ffg\n, null: ./null.ffg\n, reject: ./reject.ffg\n, replicate: ./replicate.ffg\n, select: ./select.ffg\n}\n" }, { "path": "prelude/list/reject.ffg", "content": "# Only keep elements of the list where the supplied functions returns `false`\nlet reject\n : forall (a : Type) . (a -> Bool) -> List a -> List a\n = \\f ->\n fold\n { \"cons\": \\x -> \\xs -> if f x then xs else [ x ] + xs, \"nil\": [ ] }\n\nin reject\n" }, { "path": "prelude/list/replicate.ffg", "content": "# Create a `List` from `n` copies of an element\nlet replicate\n : forall (a : Type) . Natural -> a -> List a\n = \\n x -> fold { succ: \\xs -> [ x ] + xs, zero: [] } n\n\nin replicate\n" }, { "path": "prelude/list/select.ffg", "content": "# Only keep elements of the list where the supplied functions returns `true`\nlet select\n : forall (a : Type) . (a -> Bool) -> List a -> List a\n = \\f ->\n fold\n { \"cons\": \\x -> \\xs -> if f x then [ x ] + xs else xs, \"nil\": [ ] }\n\nin select\n" }, { "path": "prelude/natural/package.ffg", "content": "{ product: ./product.ffg\n, sum: ./sum.ffg\n}\n" }, { "path": "prelude/natural/product.ffg", "content": "# Multiply the elements of a list\nlet product\n : List Natural -> Natural\n = fold { cons: \\x y -> x * y : Natural, nil: 1 : Natural }\n\nin product\n" }, { "path": "prelude/natural/sum.ffg", "content": "# Add up the elements of a list\nlet sum\n : List Natural -> Natural\n = fold { cons: \\x y -> x + y : Natural, nil: 0 : Natural }\n\nin sum\n" }, { "path": "prelude/package.ffg", "content": "{ bool: ./bool/package.ffg\n, real: ./real/package.ffg\n, integer: ./integer/package.ffg\n, list: ./list/package.ffg\n, natural: ./natural/package.ffg\n, text: ./text/package.ffg\n}\n" }, { "path": "prelude/real/package.ffg", "content": "{ product: ./product.ffg\n, sum: ./sum.ffg\n}\n" }, { "path": "prelude/real/product.ffg", "content": "# Multiply the elements of a list\nlet product\n : List Real -> Real\n = fold { cons: \\x y -> x * y : Real, nil: 1 : Real }\n\nin product\n" }, { "path": "prelude/real/sum.ffg", "content": "# Add up the elements of a list\nlet sum\n : List Real -> Real\n = fold { cons: \\x y -> x + y : Real, nil: 0 : Real }\n\nin sum\n" }, { "path": "prelude/text/concat.ffg", "content": "# Concatenate a `List` of `Text`\nlet concat\n : List Text -> Text\n = fold { cons: \\x -> \\y -> (x + y) : Text, nil: \"\" }\n\nin concat\n" }, { "path": "prelude/text/concatMap.ffg", "content": "# Transform each value in a `List` into `Text` and concatenate the result\nlet concatMap\n : forall (a : Type) . (a -> Text) -> List a -> Text\n = \\f -> fold { cons: \\x -> \\y -> f x + y, nil: \"\" }\n\nin concatMap\n" }, { "path": "prelude/text/concatMapSep.ffg", "content": "# Concatenate a `List` of `Text` values with a separator in between each value\nlet concatSep = ./concatSep.ffg\n\nlet concatMapSep\n : forall (a : Type) . Text -> (a -> Text) -> List a -> Text\n = \\separator -> \\f -> \\xs -> concatSep separator (map f xs)\n\nin concatMapSep\n" }, { "path": "prelude/text/concatSep.ffg", "content": "# Concatenate a `List` of `Text` values with a separator in between each value\nlet concatSep (separator : Text) (xs : List Text) : Text =\n let status\n = fold\n { \"cons\": \\element ->\n fold\n { \"null\": some element\n , \"some\": \\result ->\n some (element + separator + result)\n }\n , \"nil\": null\n }\n xs\n\n in fold { \"null\": \"\", \"some\": \\result -> result } status\n\nin concatSep\n" }, { "path": "prelude/text/package.ffg", "content": "{ concat: ./concat.ffg\n, concatMap: ./concatMap.ffg\n, concatMapSep: ./concatMapSep.ffg\n, concatSep: ./concatSep.ffg\n}\n" }, { "path": "prompts/abnf.md", "content": "Here's the grammar for Grace if you're not exactly sure what the language does\nand does not permit so that you don't run into trivial syntax errors:\n\n```\nexpression\n = lambda\n / let\n / if\n / annotation ; Everything else (operators, projections, literals, etc.)\n\nidentifier\n ; Naked variable names begin with a lowercase letter or \"_\"\n ;\n ; Examples: `x`, `name`, `toLicense`\n = (LOWER / \"_\") *(ALPHANUM / \"_\" / \"-\" / \"/\")\n\n ; Quoted variable names begin with `.` and are surrounded with single quotes\n ;\n ; Examples: `.'Rationale'`, `.'Section Header'`, `.'Website - Backend'`\n / \".\" single-quoted\n\nlambda = \"\\\" 1*binding \"->\" expression\n\n; A bound variable with an optional type annotation and optional default value\nname-binding = identifier [ \":\" type ] [ \"=\" expression ]\n\n; One or more names bound as arguments for a lambda or named functions\nbinding\n ; Plain bound variable:\n ;\n ; \\x -> …\n ;\n ; let f x = … in …\n ;\n ; let greet .'Name' = \"Hi, ${.'Name'}!\" in greet \"Alice\"\n ;\n = identifier\n\n ; Bound variable with an optional type annotation and optional default value:\n ;\n ; \\(x : T = v) -> …\n ;\n ; let f (x : T = v) = … in …\n ;\n ; let greet (.'Name' : Text = \"Alice\") = \"Hi, ${.'Name'}!\" in greet null\n ;\n ; You can have just the type annotation:\n ;\n ; \\(x : T) -> …\n ;\n ; let f (x : T) = … in …\n ;\n ; … or just the default value:\n ;\n ; \\(x = v) -> …\n ;\n ; let f (x = v) = … in …\n ;\n ; let greet (.'Name' : Text) = \"Hi, ${.'Name'}!\" in greet \"Alice\"\n ;\n ; You can even omit both and just parenthesize the bound variable, although\n ; this is not idiomatic since you'd usually omit the parentheses in that case:\n ;\n ; \\(x) -> …\n ;\n ; let f (x) = … in …\n ;\n ; let greet (.'Name') = \"Hi, ${.'Name'}!\" in greet \"Alice\"\n ;\n / \"(\" name-binding \")\"\n\n ; Destructure a record function argument:\n ;\n ; \\{ a, b } -> …\n ;\n ; let f{ a, b } = … in …\n ;\n ; let greet{ \"Name\" } = \"Hi, ${.'Name'}!\" in greet{ \"Name\": \"Alice\" }\n ;\n ; let greet{ .'Name' } = \"Hi, ${.'Name'}!\" in greet{ \"Name\": \"Alice\" }\n ;\n ; Record fields destructured in this way can have optional type annotations\n ; and optional default values:\n ;\n ; \\{ a, b : T0, c = v0, d : T1 = v1 } -> …\n ;\n ; let f { a, b : T0, c = v0, d : T1 = v1 } = … in …\n ;\n ; let greet{ \"Name\" : Text = \"Alice\" } = \"Hi, ${.'Name'}!\" in greet{ }\n ;\n ; let greet{ .'Name' : Text = \"Alice\" } = \"Hi, ${.'Name'}!\" in greet{ }\n / \"{\" [ name-binding *( \",\" name-binding ) ] \"}\"\n\n; Note: Every sequence of `let`s (even top-level `let`s) must have a matching\n; `in`. Dangling `let`s are a parse error in any context.\n;\n; BAD:\n;\n; let x = 2\n; let y = 3 # Missing `in` at the end, which is a syntax error\n;\n; GOOD:\n;\n; let x = 2\n; let y = 3\n; in { x, y } # To \"export\" let bindings, package them in a record\nlet = 1*assignment \"in\" expression\n\n; Every assignment must begin with a `let` because Grace is not\n; whitespace-sensitive.\n;\n; BAD:\n;\n; let x = 2\n; y = 3 # Missing `let`, so this is misparsed as `let x = 2 y = 3`\n; in x + y\n;\n; GOOD:\n;\n; let x = 2\n; let y = 3\n; in x + y\nassignment =\n ; Define a simple value:\n ;\n ; let x = 2 in x + 1\n ;\n ; … or a function of one or more arguments:\n ;\n ; let increment x = x + 1 in increment 2\n ;\n ; Function definitions can destructure their arguments and this is the most\n ; idiomatic way to define functions in Grace:\n ;\n ; let greet{ name } = \"Hi, ${name}!\" in greet{ name: \"Alice\" }\n = (\"let\" identifier *binding [ \":\" type ] \"=\" expression)\n\n ; Destructure the right-hand side:\n ;\n ; let { x, y } = { x: 1, y: 2 } in x + y\n / (\"let\" binding \"=\" expression)\n\n ; For comprehension (like a list comprehension, but works on both `List`s\n ; and `Optional`s)\n ;\n ; for x of [ 1, 2 ]\n ; for y of [ false, true ]\n ; in { x, y }\n ;\n ; = [ {x: 1, y: false }\n ; , {x: 1, y: true }\n ; , {x: 2, y: false }\n ; , {x: 2, y: true }\n ; ]\n / (\"for\" binding \"of\" expression)\n\nif = \"if\" expression \"then\" expression \"else\" expression\n\n; Optional type annotation:\n;\n; e : T\nannotation = application *( operator application ) [ \":\" type ]\n\n; Operators in descending order of precedence\n;\n; This is the same precedence order as C operators\noperator\n = \"/\"\n / \"%\"\n / \"*\"\n / \"-\"\n / \"+\"\n / \">=\"\n / \">\"\n / \"<=\"\n / \"<\"\n / \"!=\"\n / \"==\"\n / \"&&\"\n / \"||\"\n\napplication\n ; Keyword to prompt an LLM to generate a JSON value (the default) or Grace\n ; code (when preceded with `import`)\n = [ \"import\" ] \"prompt\" projection\n\n ; Keyword to make an HTTP request to fetch a JSON value (the default) or Grace\n ; code (when preceded with `import`)\n = [ \"import\" ] \"http\" projection\n\n ; Keyword to convert text to a JSON value (the default) or Grace code (when\n ; preceded with `import`)\n = [ \"import\" ] \"read\" projection\n\n ; Keyword to fetch a JSON file from GitHub (the default) or Grace code (when\n ; preceded with `import`)\n = [ \"import\" ] \"github\" projection\n\n ; Keyword to render a JSON expression (the default) or any expression (when\n ; preceded with `export`) as text\n = [ \"export\" ] \"show\" projection\n\n ; Keyword to pattern match on a union\n / \"fold\" projection\n\n ; Ordinary function application (left-associative)\n / application projection\n\n / projection\n\n; Optionally project a field (from a record) or an element (from a list)\nprojection = primitive *smaller\n\nsmaller\n ; You can access a record field using `record.field`.\n = \".\" field\n\n ; You can project multiple fields from a record\n / \".\" \"{\" [ field *( \",\" field ) ] \"}\"\n\n ; You can also index into a list using dot notation (e.g. `list.index`) Just\n ; like Python, you can index from the end of the list using negative numbers\n ; (e.g. `list.-1` to get the last element of the list).\n / \".\" integer\n\n ; You can slice into a list using `xs[m:n]` just like in Python. Slice\n ; indices may also be negative and both indices are optional.\n / \"[\" [ integer ] \":\" [ integer ] \"]\"\n\nprimitive\n = identifier ; bound variable (e.g. `x`)\n / \"null\"\n / boolean\n / number\n / string\n / builtin\n / list\n / record\n\n ; NOTE: all alternatives need an argument. If an alternative is empty you\n ; still need to store an empty record inside of it (e.g. `Foo{ }`)\n / alternative primitive\n\n ; An absolute path (beginning with `/`) or relative path (beginning with `../`\n ; or `./`)\n / file\n\n ; A URI (supported schemes: `https` / `http` / `env` / `file`)\n / uri\n\n / \"(\" expression \")\"\n\nboolean = \"true\" / \"false\"\n\nnumber = natural / integer / real\n\n; Positive integers are parsed as `Natural` numbers\nnatural = 1*DIGIT\n\n; Signed integers are parsed as `Integer`s\ninteger = (\"+\" / \"-\") natural\n\n; All other numbers are parsed as `Real`s\nreal = [ ( \"+\" / \"-\" ) ] 1*DIGIT \".\" 1*DIGIT\n\n; Strings support two modes:\n;\n; - Single-line string literals, like:\n;\n; \"abc\"\n;\n; - Multi-line string literals, like:\n;\n; \"\n; Line 1\n;\n; Line 3\n; \"\nstring = single-line-string / multi-line-string\n\n; Single-line string literals only support escaped newlines (i.e. `\\n`)\nsingle-line-string =\n %x22 *( single-line-character / interpolation / single-line-escape) %x22\n\n; A character other than \" or \\\nsingle-line-character = %x20-21 / %x23-5B / %x5D-10FFFF\n\n; NOTE: You can escape a string interpolation using a backslash like this:\n;\n; ```\n; \"Example: \\${…}\"\n; ```\n;\n; … if you don't want Grace to interpret the string interpolation. This comes\n; in handy if you, say, want to use Grace to generate a Bash script without\n; interpreting Bash string interpolations.\nsingle-line-escape =\n \"\\\\\" ( %x22 / \"\\\\\" / \"/\" / \"n\" / \"t\" / \"r\" / \"b\" / \"f\" / \"$\" / (\"u\" 4HEXDIG) )\n\n; These string literals can span multiple lines and leading indentation is\n; stripped. For example, this:\n;\n; let example =\n; \"\n; Line 1\n;\n; Line 3\n; \"\n;\n; … is the same thing as:\n;\n; let example = \"Line 1\\n\\nLine 3\\n\"\n;\n; The difference between a single-line string literal and a multi-line string\n; literal is that in a multi-line string literal the `\"` is followed by a\n; newline (which must be present and is stripped). For example, this:\n;\n; let example =\n; \"\n; Line 1\"\n;\n; … is the same thing as:\n;\n; let example = \"Line 1\"\nmulti-line-string =\n %x22 %x0A *( multi-line-character / interpolation / multi-line-escape) %x22\n\n; A character other than \" or \\\n;\n; Literal tabs and newlines are also permitted, unlike single-line strings.\nmulti-line-character = %x09-0A / %x20-21 / %x23-5B / %x5D-10FFFF\n\n; NOTE: You cannot escape newlines or tabs in a multi-line string literal\n; (because you can and should use an actual newline or tab character instead of\n; an escaped one).\nmulti-line-escape =\n \"\\\\\" ( %x22 / \"\\\\\" / \"/\" / \"r\" / \"b\" / \"f\" / \"$\" / (\"u\" 4HEXDIG) )\n\n; Interpolated expressions must have type `Text`. Grace does *not* perform\n; any automatic conversion of interpolated values to `Text`. If you want to\n; interpolate a number, then use:\n;\n; ```\n; \"… ${show number} …\"\n; ```\n;\n; Interpolated expressions do not need to be escaped:\n;\n; BAD:\n;\n; \\input -> \"Hello, ${input.\\\"First Name\\\"}!\"\n;\n; GOOD:\n;\n; \\input -> \"Hello, ${input.\"First Name\"}!\"\ninterpolation = \"${\" expression \"}\"\n\n; A name for one of the alternatives of a union\nalternative\n ; Unquoted alternative names begin with an uppercase letter\n = UPPER *(ALPHANUM / \"_\" / \"-\" / \"/\")\n\n ; Quoted alternative names are surrounded with single quotes\n / single-quoted\n\nsingle-quoted = \"'\" (single-quoted-character / single-quoted-escape) \"'\"\n\n; A character other than ' or \\\nsingle-quoted-character = %x20-26 / %x28-5B / %x5D-10FFFF\n\n; Similar to the rule for \"escape\" except replacing \" with ' and also not\n; including an escape sequence for $ (since it's not necessary because a quoted\n; alternative name can't include an interpolation).\nsingle-quoted-escape =\n \"\\\\\" ( \"'\" / \"\\\\\" / \"/\" / \"n\" / \"t\" / \"r\" / \"b\" / \"f\" / (\"u\" 4HEXDIG) )\n\n; Lists allow optional leading/trailing commas.\nlist = \"[\" [ \",\" ] [ expression *( \",\" expression ) ] [ \",\" ] \"]\"\n\n; Records allow optional leading/trailing commas\nrecord = \"{\" [ \",\" ] [ projection-value *( \",\" projection-value ) ] [ \",\" ] \"}\"\n\nprojection-value\n ; Grace uses JSON syntax for projection values: ':' (not '=')\n = field \":\" expression\n\n ; Field punning. In other words, `{ x }` is the same thing as `{ x: x }`\n / field\n\nfield\n = identifier\n\n ; Field names can be alternative names, too. This is necessary so that you\n ; can `fold` unions (since the field names need to match the union's\n ; alternative names)\n / alternative\n\n ; You can quote field names, too, which comes in handy if a field has\n ; characters that would otherwise be forbidden (e.g. spaces or punctuation)\n ; (e.g. `record.\"Example field\"` or `{ \"Example field\": true }`)\n / string\n\nbuiltin\n = \"yaml\" ; JSON -> Text ; Renders argument as YAML\n / \"indexed\" ; forall (a : Type) . List a -> List { index: Natural, value: a }\n / \"length\" ; forall (a : Type) . List a -> Natural\n / \"map\" ; forall (a : Type) (b : Type) . (a -> b) -> List a -> List b\n / \"abs\" ; Integer -> Natural\n / \"reveal\" ; Key -> Text\n / \"some\" ; forall (a : Type) . a -> Optional a\n\ntype = quantified-type\n\nquantified-type = *forall function-type\n\nforall = \"forall\" 1*( \"(\" identifier \":\" domain \")\" ) \".\" \ndomain = \"Type\" / \"Fields\" / \"Alternatives\"\n\nfunction-type = application-type *( \"->\" application-type )\n\napplication-type\n = \"List\" primitive-type\n / \"Optional\" primitive-type\n / primitive-type\n\nprimitive-type\n = identifier ; Type variable\n / \"Bool\"\n / \"Real\"\n / \"Integer\"\n / \"Natural\"\n / \"Text\"\n / \"JSON\"\n / \"Key\"\n / record-type\n / union-type\n / \"(\" type \")\"\n\n; Records types allow optional leading/trailing commas\nrecord-type =\n \"{\"\n [ \",\" ]\n [ field \":\" type *( \",\" field \":\" type ) ]\n [ \",\" identifier ] ; Fields variable (e.g. `{ x: Text, other }`\n [ \",\" ]\n \"}\"\n\n; Union types allow optional leading/trailing bars\nunion-type =\n \"<\"\n [ \"|\" ]\n [ alternative \":\" type *( \"|\" alternative \":\" type ) ]\n [ \"|\" identifier ] ; Alternatives variable (e.g. `< Left: Natural | other >`)\n [ \"|\" ]\n \">\"\n```\n" }, { "path": "prompts/inference.md", "content": "At [work](https://mercury.com/jobs) I've been researching how to improve the ergonomics of prompt chaining and I wanted to share and open source some of what I've done. This initial post is about how I've been experimenting with using *bidirectional type inference* to streamline *prompt chaining*.\n\n\"Prompt chaining\" is a prompt engineering technique that splits a larger task/prompt into multiple smaller tasks/prompts which are chained together using code. For example, instead of prompting a model to generate a poem in one prompt like this:\n\n> Write a poem based off this idea:\n> \n> `${idea}`\n> \n> … by following this process:\n> \n> - First think through the form, stanza count, lines per stanza, and rhyme scheme\n> - Then choose a poetic style (tone, voice, and literary devices) based on the poem's form\n> - Then write a complete poem based on that plan\n\n… you can split it into smaller prompts, like this:\n\n##### `structure` prompt:\n\n> Plan the structure of a new poem based on this idea\n> \n> `${idea}`\n> \n> Describe its form, stanza count, lines per stanza, and rhyme scheme\n\n##### `style` prompt:\n\n> Given this poem structure:\n> \n> - Form: `${structure.\"Form\"}`\n> - Stanzas: `${structure.\"Stanza Count\"}`\n> - Lines per stanza: `${structure.\"Lines per Stanza\"}`\n> - Rhyme scheme: `${structure.\"Rhyme Scheme\"}`\n> \n> Choose a poetic style: tone, voice, and literary devices to emphasize\n\n##### `poem` prompt:\n\n> Write a complete poem based on this idea:\n> \n> `${idea}`\n> \n> Structure:\n> - Form: `${structure.\"Form\"}`\n> - Stanzas: `${structure.\"Stanza Count\"}`\n> - Lines per stanza: `${structure.\"Lines per Stanza\"}`\n> - Rhyme scheme: `${structure.\"Rhyme Scheme\"}`\n> \n> Style:\n> - Tone: `${style.\"Tone\"}`\n> - Voice: `${style.\"Voice\"}`\n> - Literary Devices: `${style.\"Literary Devices\"}`\n\nWhy might you want to do this?\n\n- to improve the quality of the results\n \n Models perform better when working on more constrained subproblems. Splitting a larger prompt into smaller prompts helps the model stay focused at each step.\n\n- to introspect intermediate results\n \n This comes in handy when you want to log, validate, or correct intermediate results.\n\n- to perform actions in between prompts\n \n You might want to take the output of one prompt, use that to call some tool, then use the output of that tool to decide what the next prompt should be, which you can't do with a single prompt.\n\nIn other words, prompt chaining unlocks greater *accuracy*, *control*, and *flexibility* for prompt engineering.\n\n#### The problem\n\nThe main issue with prompt chaining is that it is a huge pain in the ass; if you start do anything a little bit complicated you need to start using structured outputs (i.e. JSON), which adds a whole lot of boilerplate to the process:\n\n- you have to define the schema for each intermediate step of the process\n \n You typically do this by defining your data model in your host programming language (e.g. a Pydantic model in Python) or directly defining your JSON schema\n\n- You have to instruct the model to produce JSON and explain the shape of the expected output\n\n- (Depending on the framework) you have to decode the JSON into your data model\n\nFor small prompt chaining pipelines this isn't too hard, but it starts to get annoying to define all these schemas when you scale this up to more sophisticated prompt chaining pipelines.\n\nSo as a thought experiment I wanted to create a research prototype that handled all of that for you so that you didn't need to specify any schemas at all. In other words I wanted to build a programming language that harnessed *bidirectional type inference* to perform *schema inference* for prompts with structured JSON outputs.\n\n#### Example\n\nI'll cut to the case by showing the above prompt chain written as a program in this language:\n\n```haskell\n\\{ key } ->\n\nlet concatSep = import github\n { owner: \"Gabriella439\"\n , repository: \"grace\"\n , path: \"prelude/text/concatSep.ffg\"\n }\n\nlet generatePoem idea =\n let structure = prompt\n { key\n , text: \"\n Plan the structure of a new poem based on this idea:\n\n ${idea}\n\n Describe its form, stanza count, lines per stanza, and rhyme scheme.\n \"\n }\n\n let renderedStructure = \"\n - Form: ${structure.\"Form\"}\n - Stanzas: ${show (structure.\"Stanza Count\": Natural)}\n - Lines per stanza: ${show (structure.\"Lines per Stanza\" : Natural)}\n - Rhyme scheme: ${structure.\"Rhyme Scheme\"}\n \"\n\n let style = prompt\n { key\n , text: \"\n Given this poem structure:\n\n ${renderedStructure}\n\n Choose a poetic style: tone, voice, and literary devices to emphasize.\n \"\n }\n\n let renderedStyle = \"\n - Tone: ${style.\"Tone\"}\n - Voice: ${style.\"Voice\"}\n - Literary Devices: ${concatSep \", \" style.\"Literary Devices\"}\n \"\n\n let poem = prompt\n { key\n , text: \"\n Write a complete poem based on this idea:\n\n ${idea}\n\n Structure:\n\n ${renderedStructure}\n\n Style:\n\n ${renderedStyle}\n \"\n }\n\n in { structure, style, poem }\n\nin generatePoem \"The stillness of early morning\"\n```\n\nThe above prompt chain is a real program in an real (albeit research) [programming language named Fall-from-Grace](https://github.com/Gabriella439/grace) (or \"Grace\" for short). Specifically, this is implemented in a [branch of the language](https://github.com/Gabriella439/grace/tree/gabriella/llm) that adds a magic `prompt` keyword that works like in the above example.\n\nIf you run the above example, you might get an output like this:\n\n```json\n{\n \"structure\": {\n \"Form\": \"Free verse with a sprinkle of rhyme\",\n \"Lines per Stanza\": 4,\n \"Rhyme Scheme\": \"ABCB\",\n \"Stanza Count\": 5\n },\n \"style\": {\n \"Literary Devices\": [\n \"imagery\",\n \"alliteration\",\n \"personification\",\n \"enjambment\"\n ],\n \"Tone\": \"nostalgic\",\n \"Voice\": \"reflective\"\n },\n \"poem\": \"### The Stillness of Early Morning\\n\\n**I** \\nIn the gentle rise of dawn's embrace, \\nA whisper of winds through sleepy skies, \\nThe world lies suspended in an echo \\nOf yesterday's dreams, reluctantly saying goodbye.\\n\\n**II** \\nSoft orange light graces fields of dew, \\nCradling tenacious tendrils of the past. \\nMorning breathes upon the waiting world \\nWith promises that this serenity will last.\\n\\n**III** \\nWaves of silence surge across the meadow, \\nNature's symphony gently cradles rest. \\nA chorus of leaves sings its soft refrain, \\nComforted by morning's tender caress.\\n\\n**IV** \\nThe silence dips to caress weary trees, \\nWhose branches waltz to whispers soft and slow. \\nEach tendril holds close the morning's intention, \\nBefore the day's demands, the chaos, start to show.\\n\\n**V** \\nEarly rays dance upon a tranquil sea, \\nA canvas painted through a dreamy haze. \\nTime sits by, savoring the gentle hush, \\nAs the world awakens, stirs, and finally plays.\"\n}\n```\n\n… and if you're curious what the formatted poem looks like:\n\n### The Stillness of Early Morning\n\n**I** \nIn the gentle rise of dawn's embrace, \nA whisper of winds through sleepy skies, \nThe world lies suspended in an echo \nOf yesterday's dreams, reluctantly saying goodbye.\n\n**II** \nSoft orange light graces fields of dew, \nCradling tenacious tendrils of the past. \nMorning breathes upon the waiting world \nWith promises that this serenity will last.\n\n**III** \nWaves of silence surge across the meadow, \nNature's symphony gently cradles rest. \nA chorus of leaves sings its soft refrain, \nComforted by morning's tender caress.\n\n**IV** \nThe silence dips to caress weary trees, \nWhose branches waltz to whispers soft and slow. \nEach tendril holds close the morning's intention, \nBefore the day's demands, the chaos, start to show.\n\n**V** \nEarly rays dance upon a tranquil sea, \nA canvas painted through a dreamy haze. \nTime sits by, savoring the gentle hush, \nAs the world awakens, stirs, and finally plays.\n\n#### Type inference\n\nThe sample Grace program hardly specifies any types (mainly the final expected type for the `poem`: `Text`). The reason this works is because Grace supports *bidirectional type inference*, which means that Grace can work backwards from how intermediate results are used to infer their schemas.\n\nI'll illustrate this with a contrived Grace example:\n\n```haskell\n\\{ key } ->\n\nlet { x, y } = prompt{ key, text: \"Give me two numbers\" }\n\nin { x, y, sum: x + y : Integer }\n```\n\n… which might produce an output like this:\n\n```bash\n$ grace interpret ./numbers.ffg\n```\n```json\n{ \"x\": 7, \"y\": 14, \"sum\": 21 }\n```\n\nWhen Grace analyzes this program the type checker works backwards from this expression:\n\n```haskell\nx + y : Integer\n```\n\n… and reasons about it like this:\n\n- the addition produces an `Integer`, therefore `x` and `y` must also be `Integer`s\n\n- therefore the output of the `prompt` function must be a record with two `Integer` fields: `x` and `y`\n \n… and then Grace generates a JSON schema for the prompt which looks like this:\n\n```json\n{ \"type\": \"object\",\n \"properties\": {\n \"x\": { \"type\": \"integer\" },\n \"y\": { \"type\": \"integer\" }\n },\n \"required\": [ \"x\", \"y\" ],\n \"additionalProperties\": false\n}\n```\n\nOf course, you *can* specify types if you want (and they're more lightweight than schemas in traditional prompt chaining frameworks). For example:\n\n```bash\n$ grace repl\n>>> prompt{ key: ./openai.key, text: \"Give me a first and last name\" } : { first: Text, last: Text }\n{ \"first\": \"Emily\", \"last\": \"Johnson\" }\n>>> prompt{ key: ./openai.key, text: \"Give me a list of names\" } : List Text\n[ \"Alice\"\n, \"Bob\"\n, \"Charlie\"\n, \"Diana\"\n, \"Ethan\"\n, \"Fiona\"\n, \"George\"\n, \"Hannah\"\n, \"Isaac\"\n, \"Jack\"\n]\n```\n\nHowever in our original example we don't need to specify intermediate types because when the type-checker sees this code:\n\n```haskell\nlet structure = prompt\n { key\n , text: \"\n Plan the structure of a new poem based on this idea:\n\n ${idea}\n\n Describe its form, stanza count, lines per stanza, and rhyme scheme.\n \"\n }\n\nlet renderedStructure = \"\n - Form: ${structure.\"Form\"}\n - Stanzas: ${show (structure.\"Stanza Count\" : Natural)}\n - Lines per stanza: ${show (structure.\"Lines per Stanza\" : Natural)}\n - Rhyme scheme: ${structure.\"Rhyme Scheme\"}\n \"\n```\n\n… the compiler can reason backwards from how the `structure` value is used to infer that the JSON schema for the `prompt` needs to be:\n\n```json\n{ \"type\": \"object\",\n \"properties\": {\n \"Form\": { \"type\": \"string\" },\n \"Stanza Count\": { \"type\": \"integer\" },\n \"Lines per Stanza\": { \"type\": \"integer\" },\n \"Rhyme Scheme\": { \"type\": \"string\" }\n },\n \"required\": [\n \"Form\",\n \"Stanza Count\",\n \"Lines per Stanza\",\n \"Rhyme Scheme\"\n ],\n \"additionalProperties\": false\n}\n```\n\n#### Tool use\n\nGrace also supports generating *sum types* (a.k.a. tagged unions), and you can imagine using this to subsume traditional tool use frameworks.\n\nFor example, consider this Grace program:\n\n```haskell\n\\{ key } ->\n\nlet concatSep = import github\n { owner: \"Gabriella439\"\n , repository: \"grace\"\n , path: \"prelude/text/concatSep.ffg\"\n }\n\nlet call = fold\n { HttpRequest: \\x -> \"curl \" + x.url\n , ShellCommand: \\x -> concatSep \" \" ([ x.executable ] + x.arguments)\n }\n\nin map call (prompt{ key, text: \"Call some tools\" })\n```\n\nThis doesn't actually *run* any tools (I haven't added any callable tools to my work-in-progress branch yet), but just renders the tool use as a string for now:\n\n```bash\n$ grace interpret ./tools.ffg\n```\n```json\n[ \"curl https://api.example.com/data\", \"ls -l -a\" ]\n```\n\nHowever, the idea is that you can model a tool as a sum type with one constructor per callable tool, and in the above example the type checker infers that the sum type representing one tool call is:\n\n```haskell\n< HttpRequest: { url: Text }\n| ShellCommand: { executable: Text, arguments: List Text }\n>\n```\n\n… so the inferred type of `call` is:\n\n```haskell\ncall : < HttpRequest: …, ShellCommand: … > -> Text\n```\n\n… but since we `map` the `call` function over the output of the `prompt` the type checker infers that the `prompt` needs to generate a `List` of tool calls:\n\n```haskell\nprompt{ key, text: \"Call some tools\" } : List < HttpRequest: …, ShellCommand: … >\n```\n\n… and then Grace does some magic under the hood to convert that type to the equivalent JSON schema.\n\nWhat's particularly neat about this example is that the prompt is so incredibly bare (\"Call some tools\") because all the information the model needs is present in the schema.\n\n#### Schema-driven prompting\n\nWe can explore this idea of using the schema to drive the prompt instead of prose using an example like this:\n\n```haskell\nprompt{ key: ./openai.key, text: \"Generate some characters for a story\" }\n : List\n { \"The character's name\": Text\n , \"The most memorable thing about the character\": Text\n , \"The character's personal arc\": Text\n }\n```\n```json\n[ { \"The character's name\": \"Aveline Thatcher\"\n , \"The character's personal arc\":\n \"Aveline starts as a skeptical journalist who doubts the stories of mythical creatures. Over time, she becomes a firm believer, risking her career to uncover the truth and protect these creatures.\"\n , \"The most memorable thing about the character\":\n \"The intricate tattoo of a phoenix on her forearm that seems to glow when she discovers hidden truths.\"\n }\n, { \"The character's name\": \"Kelan Frost\"\n , \"The character's personal arc\":\n \"A former rogue alchemist who turns hero after he inadvertently creates a dangerous substance. Driven by guilt, Kelan seeks redemption by finding an antidote and saving his village.\"\n , \"The most memorable thing about the character\":\n \"His iridescent blue eyes that seem to see into one's soul, a side effect of his alchemical experiments.\"\n }\n, { \"The character's name\": \"Luciana Blair\"\n , \"The character's personal arc\":\n \"Luciana is a reclusive artist who initially fears the world outside her home. After a mysterious vision rejuvenates her, she sets out on a journey of self-discovery, ultimately finding both her voice and courage.\"\n , \"The most memorable thing about the character\":\n \"Her ability to paint scenes before they happen, which she attributes to the visions she sees in her dreams.\"\n }\n, { \"The character's name\": \"Ezra Hartman\"\n , \"The character's personal arc\":\n \"Once a charismatic but self-centered lawyer, Ezra is confronted with a moral crisis that forces him to reevaluate his values. He chooses a path of integrity, becoming an advocate for justice.\"\n , \"The most memorable thing about the character\":\n \"His perfectly tailored suits that slowly become more casual, symbolizing his transformation and shifting priorities.\"\n }\n, { \"The character's name\": \"Seraphine Mora\"\n , \"The character's personal arc\":\n \"Seraphine is a young music prodigy who loses her hearing after an accident. Battling despair, she learns to embrace a new way of 'hearing' music through vibrations and her other senses.\"\n , \"The most memorable thing about the character\":\n \"The ethereal way she 'dances' with the music, using her entire body to express each note's emotion.\"\n }\n]\n```\n\nGrace is a superset of JSON and since JSON supports arbitrary field names so does Grace! Field names in Grace support arbitrary capitalization, punctuation, and whitespace as long as you quote them, and we can use the field names to \"smuggle\" the description of each field into the schema.\n\n#### Conclusion\n\nHopefully this gives you some idea of why I've begun to think of prompt chaining as a programming languages problem. Type inference is just the beginning and I think it is possible to use a domain-specific programming language not just to simplify the code but to ultimately unlock greater reasoning power.\n\nI'm going to continue to use Grace as a research vehicle for prompt chaining but my LLM-enabled [branch of Grace](https://github.com/Gabriella439/grace/tree/gabriella/llm) (like Grace itself) is not really intended to be used in production and I created it mainly as a proof-of-concept for where I'd like prompt chaining frameworks to go. If I do end up eventually productionizing this research I will create a proper fork with its own name and the whole works.\n" }, { "path": "src/Grace/Aeson.hs", "content": "-- | Utilities for working with the @aeson@ package\nmodule Grace.Aeson where\n\nimport Control.Exception.Safe (Exception(..))\nimport Data.Aeson (FromJSON)\nimport Data.Text (Text)\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Data.Aeson as Aeson\nimport qualified Data.ByteString.Lazy as ByteString.Lazy\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Encoding\n\n-- | JSON decoding failed\ndata JSONDecodingFailed = JSONDecodingFailed\n { message :: String\n , text :: Text\n } deriving stock (Show)\n\ninstance Exception JSONDecodingFailed where\n displayException JSONDecodingFailed{ message, text } =\n \"Failed to decode output as JSON\\n\\\n \\\\n\\\n \\The following text:\\n\\\n \\\\n\\\n \\\" <> Text.unpack text <> \"\\n\\\n \\\\n\\\n \\… to decode as JSON.\\n\\\n \\\\n\\\n \\Decoding error message:\\n\\\n \\\\n\\\n \\\" <> message\n\n-- | Decode a structured value from JSON-encoded `Text`\ndecode :: FromJSON a => Text -> IO a\ndecode text = do\n let bytes = ByteString.Lazy.fromStrict (Encoding.encodeUtf8 text)\n\n case Aeson.eitherDecode bytes of\n Left message ->\n Exception.throwIO JSONDecodingFailed{ message, text }\n Right a ->\n return a\n" }, { "path": "src/Grace/Compat.hs", "content": "{-# LANGUAGE CPP #-}\n\n{-# OPTIONS_GHC -Wno-orphans #-}\n\n-- | An internal utility module for backwards compatibility across GHC releases\n-- and different libary versions.\nmodule Grace.Compat where\n\nimport Data.HashMap.Strict.InsOrd (InsOrdHashMap)\nimport Data.Text (Text)\n\nimport qualified Data.HashMap.Strict.InsOrd as HashMap\nimport qualified Data.HashMap.Strict as HashMap.Strict\nimport qualified Data.List as List\n\n#if MIN_VERSION_aeson(2, 0, 0)\nimport Data.Aeson.KeyMap (KeyMap)\n\nimport qualified Data.Aeson.KeyMap as Aeson\n#else\nimport Data.HashMap.Strict (HashMap)\n#endif\n\n#if !MIN_VERSION_containers(0, 6, 6)\nimport Data.Sequence.Internal (Digit(..), Elem(..), FingerTree(..), Node(..), Seq(..))\nimport Language.Haskell.TH.Syntax (Lift(..))\n#endif\n\n#if MIN_VERSION_aeson(2, 0, 0)\nfromAesonMap :: KeyMap v -> InsOrdHashMap Text v\nfromAesonMap = HashMap.fromHashMap . Aeson.toHashMapText\n\ntoAesonMap :: InsOrdHashMap Text v -> KeyMap v\ntoAesonMap = Aeson.fromHashMapText . HashMap.toHashMap\n\nsorted :: KeyMap value -> [(Text, value)]\nsorted = List.sortOn fst . HashMap.Strict.toList . Aeson.toHashMapText\n#else\nfromAesonMap :: HashMap Text v -> InsOrdHashMap Text v\nfromAesonMap = HashMap.fromHashMap\n\ntoAesonMap :: InsOrdHashMap Text v -> HashMap Text v\ntoAesonMap = HashMap.toHashMap\n\nsorted :: HashMap Text v -> [(Text, v)]\nsorted = List.sortOn fst . HashMap.Strict.toList\n#endif\n\n#if !MIN_VERSION_containers(0, 6, 6)\nderiving stock instance Lift a => Lift (Seq a)\nderiving stock instance Lift a => Lift (Digit a)\nderiving stock instance Lift a => Lift (Elem a)\nderiving stock instance Lift a => Lift (FingerTree a)\nderiving stock instance Lift a => Lift (Node a)\n#endif\n" }, { "path": "src/Grace/Context.hs", "content": "{-# LANGUAGE FlexibleContexts #-}\n\n{-| A `Context` is an ordered list of `Entry`s used as the state for the\n bidirectional type-checking algorithm\n-}\nmodule Grace.Context\n ( -- * Types\n Entry(..)\n , Context\n\n -- * Utilities\n , lookup\n , splitOnUnsolvedType\n , splitOnUnsolvedFields\n , splitOnUnsolvedAlternatives\n , discardUpTo\n , solveType\n , solveRecord\n , solveUnion\n , complete\n ) where\n\nimport Data.Text (Text)\nimport Grace.Domain (Domain)\nimport Grace.Existential (Existential)\nimport Grace.Monotype (Monotype)\nimport Grace.Pretty (Pretty(..), label, operator, punctuation)\nimport Grace.Type (Type)\nimport Prelude hiding (lookup)\nimport Prettyprinter (Doc)\nimport Prettyprinter.Render.Terminal (AnsiStyle)\n\nimport qualified Control.Monad.State.Strict as State\nimport qualified Grace.Domain as Domain\nimport qualified Grace.Existential as Existential\nimport qualified Grace.Monotype as Monotype\nimport qualified Grace.Type as Type\nimport qualified Prettyprinter as Pretty\n\n{- $setup\n\n >>> :set -XOverloadedStrings\n >>> :set -XTypeApplications\n >>> import Grace.Type (Record, Union)\n-}\n\n-- | An element of the `Context` list\ndata Entry s\n = Variable Domain Text\n -- ^ Universally quantified variable\n --\n -- >>> pretty @(Entry ()) (Variable Domain.Type \"a\")\n -- a: Type\n | Annotation Text (Type s)\n -- ^ A bound variable whose type is known\n --\n -- >>> pretty @(Entry ()) (Annotation \"x\" \"a\")\n -- x: a\n | UnsolvedType (Existential Monotype)\n -- ^ A placeholder type variable whose type has not yet been inferred\n --\n -- >>> pretty @(Entry ()) (UnsolvedType 0)\n -- a?\n | UnsolvedFields (Existential Monotype.Record)\n -- ^ A placeholder fields variable whose type has not yet been inferred\n --\n -- >>> pretty @(Entry ()) (UnsolvedFields 0)\n -- a?\n | UnsolvedAlternatives (Existential Monotype.Union)\n -- ^ A placeholder alternatives variable whose type has not yet been\n -- inferred\n --\n -- >>> pretty @(Entry ()) (UnsolvedAlternatives 0)\n -- a?\n | SolvedType (Existential Monotype) Monotype\n -- ^ A placeholder type variable whose type has been (at least partially)\n -- inferred\n --\n -- >>> pretty @(Entry ()) (SolvedType 0 (Monotype.Scalar Monotype.Bool))\n -- a = Bool\n | SolvedFields (Existential Monotype.Record) Monotype.Record\n -- ^ A placeholder fields variable whose type has been (at least partially)\n -- inferred\n --\n -- >>> pretty @(Entry ()) (SolvedFields 0 (Monotype.Fields [(\"x\", \"X\")] (Monotype.UnsolvedFields 1)))\n -- a = x: X, b?\n | SolvedAlternatives (Existential Monotype.Union) Monotype.Union\n -- ^ A placeholder alternatives variable whose type has been (at least\n -- partially) inferred\n --\n -- >>> pretty @(Entry ()) (SolvedAlternatives 0 (Monotype.Alternatives [(\"x\", \"X\")] (Monotype.UnsolvedAlternatives 1)))\n -- a = x: X | b?\n | MarkerType (Existential Monotype)\n -- ^ This is used by the bidirectional type-checking algorithm to separate\n -- context entries introduced before and after type-checking a universally\n -- quantified type\n --\n -- >>> pretty @(Entry ()) (MarkerType 0)\n -- ➤ a: Type\n | MarkerFields (Existential Monotype.Record)\n -- ^ This is used by the bidirectional type-checking algorithm to separate\n -- context entries introduced before and after type-checking universally\n -- quantified fields\n --\n -- >>> pretty @(Entry ()) (MarkerFields 0)\n -- ➤ a: Fields\n | MarkerAlternatives (Existential Monotype.Union)\n -- ^ This is used by the bidirectional type-checking algorithm to separate\n -- context entries introduced before and after type-checking universally\n -- quantified alternatives\n --\n -- >>> pretty @(Entry ()) (MarkerAlternatives 0)\n -- ➤ a: Alternatives\n deriving stock (Eq, Show)\n\ninstance Pretty (Entry s) where\n pretty = prettyEntry\n\n{-| A `Context` is an ordered list of `Entry`s\n\n Note that this representation stores the `Context` entries in reverse\n order, meaning that the beginning of the list represents the entries that\n were added last. For example, this context:\n\n > •, a : Bool, b, c?, d = c?, ➤e : Type\n\n … corresponds to this Haskell representation:\n\n > [ MarkerType 4\n > , SolvedType 3 (Monotype.UnsolvedType 2)\n > , UnsolvedType 2\n > , Variable \"b\"\n > , Annotation \"a\" (Monotype.Scalar Monotype.Bool)\n > ]\n\n The ordering matters because the bidirectional type-checking algorithm\n uses ordering of `Context` entries to determine scope. Specifically:\n\n * each `Entry` in the `Context` can only refer to variables preceding it\n within the `Context`\n\n * the bidirectional type-checking algorithm sometimes discards all entries\n in the context past a certain entry to reflect the end of their\n \\\"lifetime\\\"\n-}\ntype Context s = [Entry s]\n\nprettyEntry :: Entry s -> Doc AnsiStyle\nprettyEntry (Variable domain a) =\n label (pretty a) <> operator \":\" <> \" \" <> pretty domain\nprettyEntry (UnsolvedType a) =\n pretty a <> \"?\"\nprettyEntry (UnsolvedFields p) =\n pretty p <> \"?\"\nprettyEntry (UnsolvedAlternatives p) =\n pretty p <> \"?\"\nprettyEntry (SolvedType a τ) =\n pretty a <> \" \" <> punctuation \"=\" <> \" \" <> pretty τ\nprettyEntry (SolvedFields p (Monotype.Fields [] Monotype.EmptyFields)) =\n pretty p <> \" \" <> punctuation \"=\" <> \" \" <> punctuation \"•\"\nprettyEntry (SolvedFields p0 (Monotype.Fields [] (Monotype.UnsolvedFields p1))) =\n pretty p0\n <> \" \"\n <> punctuation \"=\"\n <> \" \"\n <> pretty p1\n <> \"?\"\nprettyEntry (SolvedFields p0 (Monotype.Fields [] (Monotype.VariableFields p1))) =\n pretty p0\n <> \" \"\n <> punctuation \"=\"\n <> \" \"\n <> label (pretty p1)\nprettyEntry (SolvedFields p (Monotype.Fields ((k0, τ0) : kτs) fields)) =\n pretty p\n <> \" = \"\n <> label (pretty k0)\n <> operator \":\"\n <> \" \"\n <> pretty τ0\n <> foldMap prettyFieldType kτs\n <> case fields of\n Monotype.EmptyFields ->\n \"\"\n Monotype.UnsolvedFields p1 ->\n punctuation \",\" <> \" \" <> pretty p1 <> \"?\"\n Monotype.VariableFields p1 ->\n punctuation \",\" <> \" \" <> pretty p1\nprettyEntry (SolvedAlternatives p (Monotype.Alternatives [] Monotype.EmptyAlternatives)) =\n pretty p <> \" \" <> punctuation \"=\" <> \" \" <> punctuation \"•\"\nprettyEntry (SolvedAlternatives p0 (Monotype.Alternatives [] (Monotype.UnsolvedAlternatives p1))) =\n pretty p0 <> \" \" <> punctuation \"=\" <> \" \" <> pretty p1 <> \"?\"\nprettyEntry (SolvedAlternatives p0 (Monotype.Alternatives [] (Monotype.VariableAlternatives p1))) =\n pretty p0 <> \" \" <> punctuation \"=\" <> \" \" <> label (pretty p1)\nprettyEntry (SolvedAlternatives p0 (Monotype.Alternatives ((k0, τ0) : kτs) fields)) =\n pretty p0\n <> \" \"\n <> punctuation \"=\"\n <> \" \"\n <> prettyAlternativeType (k0, τ0)\n <> foldMap (\\kt -> \" \" <> punctuation \"|\" <> \" \" <> prettyAlternativeType kt) kτs\n <> case fields of\n Monotype.EmptyAlternatives ->\n \"\"\n Monotype.UnsolvedAlternatives p1 ->\n \" \" <> punctuation \"|\" <> \" \" <> pretty p1 <> \"?\"\n Monotype.VariableAlternatives p1 ->\n \" \" <> punctuation \"|\" <> \" \" <> label (pretty p1)\nprettyEntry (Annotation x a) = Pretty.group (Pretty.flatAlt long short)\n where\n long =\n Pretty.align\n ( pretty x\n <> operator \":\"\n <> Pretty.hardline\n <> \" \"\n <> pretty a\n )\n\n short = pretty x <> operator \":\" <> \" \" <> pretty a\nprettyEntry (MarkerType a) =\n \"➤ \" <> pretty a <> \": Type\"\nprettyEntry (MarkerFields a) =\n \"➤ \" <> pretty a <> \": Fields\"\nprettyEntry (MarkerAlternatives a) =\n \"➤ \" <> pretty a <> \": Alternatives\"\n\nprettyFieldType :: (Text, Monotype) -> Doc AnsiStyle\nprettyFieldType (k, τ) =\n punctuation \",\" <> \" \" <> pretty k <> operator \":\" <> \" \" <> pretty τ\n\nprettyAlternativeType :: (Text, Monotype) -> Doc AnsiStyle\nprettyAlternativeType (k, τ) =\n pretty k <> operator \":\" <> \" \" <> pretty τ\n\n{-| Substitute a `Type` using the solved entries of a `Context`\n\n >>> original = Type.UnsolvedType () 0\n >>> pretty @(Type ()) original\n a?\n\n >>> pretty @(Type ()) (solveType [ UnsolvedType 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ] original)\n Bool\n-}\nsolveType :: Context s -> Type s -> Type s\nsolveType context type_ = foldl snoc type_ context\n where\n snoc t (SolvedType a τ) = Type.solveType a τ t\n snoc t (SolvedFields a r) = Type.solveFields a r t\n snoc t (SolvedAlternatives a u) = Type.solveAlternatives a u t\n snoc t _ = t\n\n{-| Substitute a t`Type.Record` using the solved entries of a `Context`\n\n >>> original = Type.Fields [(\"x\", Type.Scalar () Monotype.Bool)] (Monotype.UnsolvedFields 0)\n >>> pretty @(Record ()) original\n { x: Bool, a? }\n\n >>> entry = SolvedFields 0 (Monotype.Fields [] Monotype.EmptyFields)\n >>> pretty entry\n a = •\n\n >>> pretty @(Record ()) (solveRecord [ entry ] original)\n { x: Bool }\n-}\nsolveRecord :: Context s -> Type.Record s -> Type.Record s\nsolveRecord context oldFields = newFields\n where\n location =\n error \"Grace.Context.solveRecord: Internal error - Missing location field\"\n\n newFields =\n case solveType context Type.Record{ fields = oldFields, location } of\n Type.Record{ fields } -> fields\n _ -> error \"Grace.Context.solveRecord: Internal Error - solveType changed a record into something else\"\n\n{-| Substitute a t`Type.Union` using the solved entries of a `Context`\n `Context`\n\n >>> original = Type.Alternatives [(\"A\", Type.Scalar () Monotype.Bool)] (Monotype.UnsolvedAlternatives 0)\n >>> pretty @(Union ()) original\n < A: Bool | a? >\n\n >>> entry = SolvedAlternatives 0 (Monotype.Alternatives [] Monotype.EmptyAlternatives)\n >>> pretty entry\n a = •\n\n >>> pretty @(Union ()) (solveUnion [ entry ] original)\n < A: Bool >\n-}\nsolveUnion :: Context s -> Type.Union s -> Type.Union s\nsolveUnion context oldAlternatives = newAlternatives\n where\n location =\n error \"Grace.Context.solveUnion: Internal error - Missing location field\"\n\n newAlternatives =\n case solveType context Type.Union{ alternatives = oldAlternatives, location } of\n Type.Union{ alternatives } -> alternatives\n _ -> error \"Grace.Context.solveUnion: Internal error - solveType changed a union into something else\"\n\n{-| This function is used at the end of the bidirectional type-checking\n algorithm to complete the inferred type by:\n\n * Substituting the type with the solved entries in the `Context`\n\n * Adding universal quantifiers for all unsolved entries in the `Context`\n\n >>> original = Type.Function () (Type.UnsolvedType () 1) (Type.UnsolvedType () 0)\n >>> pretty @(Type ()) original\n b? -> a?\n\n >>> pretty @(Type ()) (complete [ UnsolvedType 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ] original)\n forall (a : Type) . a -> Bool\n-}\ncomplete :: Context s -> Type s -> Type s\ncomplete context type0 = do\n State.evalState (foldl snoc nil context) 0\n where\n snoc action (SolvedType name solution) = do\n type_ <- action\n\n return (Type.solveType name solution type_)\n snoc action (SolvedFields name solution) = do\n type_ <- action\n\n return (Type.solveFields name solution type_)\n snoc action (SolvedAlternatives name solution) = do\n type_ <- action\n return (Type.solveAlternatives name solution type_)\n snoc action (UnsolvedType name₀) = do\n n <- State.get\n\n State.put $! n + 1\n\n type_ <- action\n\n let location = Type.location type_\n\n let name = Existential.toVariable n\n\n let nameLocation = location\n\n let domain = Domain.Type\n\n let solution = Monotype.VariableType name\n\n if Type.typeFreeIn name₀ type_\n then do\n return Type.Forall\n { location\n , nameLocation\n , name\n , domain\n , type_ = Type.solveType name₀ solution type_\n }\n else do\n return type_\n snoc action (UnsolvedFields name₀) = do\n n <- State.get\n\n State.put $! n + 1\n\n type_ <- action\n\n let location = Type.location type_\n\n let name = Existential.toVariable n\n\n let nameLocation = location\n\n let domain = Domain.Fields\n\n let solution = Monotype.Fields [] (Monotype.VariableFields name)\n\n if Type.fieldsFreeIn name₀ type_\n then do\n return Type.Forall\n { location\n , nameLocation\n , name\n , domain\n , type_ = Type.solveFields name₀ solution type_\n }\n else do\n return type_\n snoc action (UnsolvedAlternatives name₀) = do\n n <- State.get\n\n State.put $! n + 1\n\n type_ <- action\n\n let location = Type.location type_\n\n let name = Existential.toVariable n\n\n let nameLocation = location\n\n let domain = Domain.Alternatives\n\n let solution = Monotype.Alternatives [] (Monotype.VariableAlternatives name)\n\n if Type.alternativesFreeIn name₀ type_\n then do\n return Type.Forall\n { location\n , nameLocation\n , name\n , domain\n , type_ = Type.solveAlternatives name₀ solution type_\n }\n else do\n return type_\n snoc action _ = do\n action\n\n nil = return type0\n\n{-| Split a `Context` into two `Context`s before and after the given\n `UnsolvedType` variable. Neither `Context` contains the variable\n\n Returns `Nothing` if no such `UnsolvedType` variable is present within the\n `Context`\n\n >>> splitOnUnsolvedType 1 [ UnsolvedType 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ]\n Just ([],[SolvedType 0 (Scalar Bool)])\n >>> splitOnUnsolvedType 0 [ UnsolvedType 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ]\n Nothing\n-}\nsplitOnUnsolvedType\n :: Existential Monotype\n -- ^ `UnsolvedType` variable to split on\n -> Context s\n -> Maybe (Context s, Context s)\nsplitOnUnsolvedType a0 (UnsolvedType a1 : entries)\n | a0 == a1 = return ([], entries)\nsplitOnUnsolvedType a (entry : entries) = do\n (prefix, suffix) <- splitOnUnsolvedType a entries\n return (entry : prefix, suffix)\nsplitOnUnsolvedType _ [] = Nothing\n\n{-| Split a `Context` into two `Context`s before and after the given\n `UnsolvedFields` variable. Neither `Context` contains the variable\n\n Returns `Nothing` if no such `UnsolvedFields` variable is present within the\n `Context`\n\n >>> splitOnUnsolvedFields 1 [ UnsolvedFields 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ]\n Just ([],[SolvedType 0 (Scalar Bool)])\n >>> splitOnUnsolvedFields 0 [ UnsolvedFields 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ]\n Nothing\n-}\nsplitOnUnsolvedFields\n :: Existential Monotype.Record\n -- ^ `UnsolvedFields` variable to split on\n -> Context s\n -> Maybe (Context s, Context s)\nsplitOnUnsolvedFields p0 (UnsolvedFields p1 : entries)\n | p0 == p1 = return ([], entries)\nsplitOnUnsolvedFields p (entry : entries) = do\n (prefix, suffix) <- splitOnUnsolvedFields p entries\n return (entry : prefix, suffix)\nsplitOnUnsolvedFields _ [] = Nothing\n\n{-| Split a `Context` into two `Context`s before and after the given\n `UnsolvedAlternatives` variable. Neither `Context` contains the variable\n\n Returns `Nothing` if no such `UnsolvedAlternatives` variable is present\n within the `Context`\n\n >>> splitOnUnsolvedAlternatives 1 [ UnsolvedAlternatives 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ]\n Just ([],[SolvedType 0 (Scalar Bool)])\n >>> splitOnUnsolvedAlternatives 0 [ UnsolvedAlternatives 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ]\n Nothing\n-}\nsplitOnUnsolvedAlternatives\n :: Existential Monotype.Union\n -- ^ `UnsolvedAlternatives` variable to split on\n -> Context s\n -> Maybe (Context s, Context s)\nsplitOnUnsolvedAlternatives p0 (UnsolvedAlternatives p1 : entries)\n | p0 == p1 = return ([], entries)\nsplitOnUnsolvedAlternatives p (entry : entries) = do\n (prefix, suffix) <- splitOnUnsolvedAlternatives p entries\n return (entry : prefix, suffix)\nsplitOnUnsolvedAlternatives _ [] = Nothing\n\n{-| Retrieve a variable's annotated type from a `Context`, given the variable's\n label and index\n\n >>> lookup \"x\" [ Annotation \"x\" (Type.Scalar () Monotype.Bool), Annotation \"y\" (Type.Scalar () Monotype.Natural) ]\n Just (Scalar {location = (), scalar = Bool})\n-}\nlookup\n :: Text\n -- ^ Variable label\n -> Context s\n -> Maybe (Type s)\nlookup _ [] = Nothing\nlookup x0 (Annotation x1 _A : _Γ) = if x0 == x1 then Just _A else lookup x0 _Γ\nlookup x (_ : _Γ) = lookup x _Γ\n\n{-| Discard all entries from a `Context` up to and including the given `Entry`\n\n >>> discardUpTo (MarkerType 1) [ UnsolvedType 1, MarkerType 1, UnsolvedType 0 ]\n [UnsolvedType 0]\n-}\ndiscardUpTo :: Eq s => Entry s -> Context s -> Context s\ndiscardUpTo entry0 (entry1 : _Γ)\n | entry0 == entry1 = _Γ\n | otherwise = discardUpTo entry0 _Γ\ndiscardUpTo _ [] = []\n" }, { "path": "src/Grace/Decode.hs", "content": "{-# LANGUAGE AllowAmbiguousTypes #-}\n{-# LANGUAGE OverloadedLists #-}\n\n{-| Use this module to decode Grace expressions into Haskell expressions\n\n Example usage:\n\n >>> decode (Value.Scalar Unknown (Syntax.Bool True)) :: Either DecodingError Bool\n Right True\n-}\nmodule Grace.Decode\n ( -- * Classes\n FromGrace(..)\n , ToGraceType(..)\n , GenericFromGrace(..)\n , GenericToGraceType(..)\n\n -- * Types\n , Key(..)\n\n -- * Exceptions\n , DecodingError(..)\n ) where\n\nimport Control.Exception.Safe (Exception)\nimport Control.Monad.State (State)\nimport Data.Int (Int8, Int16, Int32, Int64)\nimport Data.Scientific (Scientific)\nimport Data.Sequence (Seq)\nimport Data.Text (Text)\nimport Data.Vector (Vector)\nimport Data.Void (Void)\nimport Data.Word (Word8, Word16, Word32, Word64)\nimport Grace.Location (Location(..))\nimport Grace.Type (Type)\nimport Grace.Value (Value(..))\nimport Numeric.Natural (Natural)\n\nimport qualified Data.Text as Text\n\nimport GHC.Generics\n ( Generic(..)\n , C\n , Constructor\n , D\n , K1(..)\n , M1(..)\n , Rep\n , S\n , Selector\n , U1(..)\n , V1\n , (:+:)(..)\n , (:*:)(..)\n )\nimport Grace.Marshal\n (Key(..), GenericToGraceType(..), ToGraceType(..), selector)\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Control.Monad.State as State\nimport qualified Data.Aeson as Aeson\nimport qualified Data.Foldable as Foldable\nimport qualified Data.HashMap.Strict.InsOrd as HashMap\nimport qualified Data.Scientific as Scientific\nimport qualified Data.Text.Lazy as Text.Lazy\nimport qualified Data.Vector as Vector\nimport qualified GHC.Generics as Generics\nimport qualified Grace.Pretty as Grace.Pretty\nimport qualified Grace.Syntax as Syntax\nimport qualified Grace.Value as Value\nimport qualified Prettyprinter as Pretty\n\n-- | Convert a Grace expression to a Haskell expression\nclass ToGraceType a => FromGrace a where\n decode :: Value Location -> Either DecodingError a\n default decode\n :: (Generic a, GenericFromGrace (Rep a))\n => Value Location -> Either DecodingError a\n decode = fmap (fmap to) (State.evalState genericDecode 0)\n\n -- | This is used for decoding record fields, which might not be present\n decodeMaybe :: Maybe (Value Location) -> Either DecodingError a\n decodeMaybe (Just value) = decode value\n decodeMaybe Nothing = Left TypeError\n { expectedType = expected @(Maybe a)\n , value = Value.Scalar Unknown Syntax.Null\n }\n\ninstance FromGrace Void\ninstance FromGrace ()\ninstance (FromGrace a, FromGrace b) => FromGrace (a, b)\ninstance (FromGrace a, FromGrace b) => FromGrace (Either a b)\n\ninstance FromGrace Bool where\n decode (Value.Scalar _ (Syntax.Bool bool)) = return bool\n decode value = Left TypeError{ expectedType = expected @Bool, value }\n\ninstance FromGrace Natural where\n decode (Value.Scalar _ (Syntax.Natural natural)) =\n return natural\n decode value =\n Left TypeError{ expectedType = expected @Natural, value }\n\ndecodeIntegral\n :: forall a b\n . (FromGrace a, Integral a, Integral b, Bounded b)\n => Value Location -> Either DecodingError b\ndecodeIntegral value = do\n integral <- decode @a value\n\n if fromIntegral (minBound @b) <= integral\n && integral <= fromIntegral (maxBound @b)\n then return (fromIntegral @a @b integral)\n else Left RangeError\n\ninstance FromGrace Word where\n decode = decodeIntegral @Natural @Word\n\ninstance FromGrace Word8 where\n decode = decodeIntegral @Natural @Word8\n\ninstance FromGrace Word16 where\n decode = decodeIntegral @Natural @Word16\n\ninstance FromGrace Word32 where\n decode = decodeIntegral @Natural @Word32\n\ninstance FromGrace Word64 where\n decode = decodeIntegral @Natural @Word64\n\ninstance FromGrace Integer where\n decode (Value.Scalar _ (Syntax.Natural natural)) =\n return (fromIntegral natural)\n decode (Value.Scalar _ (Syntax.Integer integer)) =\n return integer\n decode value = Left TypeError\n { expectedType = expected @Integer\n , value = value\n }\n\ninstance FromGrace Int where\n decode = decodeIntegral @Integer @Int\n\ninstance FromGrace Int8 where\n decode = decodeIntegral @Integer @Int8\n\ninstance FromGrace Int16 where\n decode = decodeIntegral @Integer @Int16\n\ninstance FromGrace Int32 where\n decode = decodeIntegral @Integer @Int32\n\ninstance FromGrace Int64 where\n decode = decodeIntegral @Integer @Int64\n\ninstance FromGrace Scientific where\n decode (Value.Scalar _ (Syntax.Natural natural)) =\n return (fromIntegral natural)\n decode (Value.Scalar _ (Syntax.Integer integer)) =\n return (fromInteger integer)\n decode (Value.Scalar _ (Syntax.Real scientific)) =\n return scientific\n decode value =\n Left TypeError{ expectedType = expected @Scientific, value }\n\ndecodeRealFloat :: RealFloat a => Value Location -> Either DecodingError a\ndecodeRealFloat value = do\n scientific <- decode value\n\n case Scientific.toBoundedRealFloat scientific of\n Left _ -> Left RangeError\n Right realFloat -> return realFloat\n\ninstance FromGrace Double where\n decode = decodeRealFloat\n\ninstance FromGrace Float where\n decode = decodeRealFloat\n\ninstance FromGrace Text where\n decode (Value.Text _ text) = return text\n decode value = Left TypeError{ expectedType = expected @Text, value }\n\ninstance FromGrace Text.Lazy.Text where\n decode = fmap (fmap Text.Lazy.fromStrict) decode\n\ninstance {-# OVERLAPPING #-} FromGrace [Char] where\n decode = fmap (fmap Text.unpack) decode\n\ninstance FromGrace Key where\n decode (Value.Scalar _ (Syntax.Key text)) = return Key{ text }\n decode value = Left TypeError{ expectedType = expected @Key, value }\n\ninstance FromGrace Aeson.Value where\n decode value = case Value.toJSON value of\n Nothing ->\n Left TypeError{ expectedType = expected @Aeson.Value, value }\n Just json ->\n return json\n\ninstance FromGrace a => FromGrace (Seq a) where\n decode (Value.List _ seq_) = traverse decode seq_\n decode value = Left TypeError{ expectedType = expected @(Seq a), value }\n\ninstance FromGrace a => FromGrace [a] where\n decode = fmap (fmap Foldable.toList) (decode @(Seq a))\n\ninstance FromGrace a => FromGrace (Vector a) where\n decode = fmap (fmap Vector.fromList) decode\n\ninstance FromGrace a => FromGrace (Maybe a) where\n decode (Value.Scalar _ Syntax.Null) = do\n return Nothing\n decode (Value.Application _ (Value.Builtin _ Syntax.Some) value) = do\n a <- decode value\n return (Just a)\n decode value = do\n Left TypeError{ expectedType = expected @(Maybe a), value }\n\n decodeMaybe Nothing = do\n return Nothing\n decodeMaybe (Just value) = do\n decode value\n\n{-| This is the underlying class that powers the `FromGrace` class's support for\n automatically deriving a `Generic` implementation\n-}\nclass GenericToGraceType f => GenericFromGrace f where\n genericDecode :: State Int (Value Location -> Either DecodingError (f a))\n\ninstance GenericFromGrace V1 where\n genericDecode = do\n let expectedType = State.evalState (genericExpected @V1) 0\n\n let decode_ value = Left TypeError{ expectedType, value }\n\n return decode_\n\ninstance GenericFromGrace U1 where\n genericDecode = do\n let expectedType = State.evalState (genericExpected @U1) 0\n\n let decode_ (Value.Record _ []) = return U1\n decode_ value = Left TypeError{ expectedType, value }\n\n return decode_\n\ninstance GenericFromGrace f => GenericFromGrace (M1 D d f) where\n genericDecode = fmap (fmap (fmap M1)) genericDecode\n\ninstance GenericFromGrace f => GenericFromGrace (M1 C d f) where\n genericDecode = fmap (fmap (fmap M1)) genericDecode\n\ninstance (Selector s, FromGrace a) => GenericFromGrace (M1 S s (K1 i a)) where\n genericDecode = do\n let m1 :: M1 S s (K1 i a) r\n m1 = undefined\n\n name <- selector m1\n\n let decode_ value\n | Generics.selName m1 == \"\" =\n fmap (M1 . K1) (decode value)\n | otherwise = case value of\n Value.Record _ fieldValues ->\n fmap (M1 . K1) (decodeMaybe (fmap snd (HashMap.lookup name fieldValues)))\n _ -> do\n let expectedType =\n State.evalState (genericExpected @(M1 S s (K1 i a))) 0\n\n Left TypeError{ expectedType, value }\n\n return decode_\n\ninstance (Selector s₀, Selector s₁, FromGrace a₀, FromGrace a₁) => GenericFromGrace (M1 S s₀ (K1 i₀ a₀) :*: M1 S s₁ (K1 i₁ a₁)) where\n genericDecode = do\n name₀ <- selector (undefined :: M1 S s₀ (K1 i₀ a₀) r)\n name₁ <- selector (undefined :: M1 S s₁ (K1 i₁ a₁) r)\n\n let decode_ (Value.Record _ fieldValues) = do\n expression₀ <- decodeMaybe (fmap snd (HashMap.lookup name₀ fieldValues))\n expression₁ <- decodeMaybe (fmap snd (HashMap.lookup name₁ fieldValues))\n\n return (M1 (K1 expression₀) :*: M1 (K1 expression₁))\n decode_ value = do\n let expectedType =\n State.evalState (genericExpected @(M1 S s₀ (K1 i₀ a₀) :*: M1 S s₁ (K1 i₁ a₁))) 0\n\n Left TypeError{ expectedType, value }\n\n return decode_\n\ninstance (Selector s, GenericFromGrace (f₀ :*: f₁), FromGrace a) => GenericFromGrace ((f₀ :*: f₁) :*: M1 S s (K1 i a)) where\n genericDecode = do\n decode₀ <- genericDecode\n\n name <- selector (undefined :: M1 S s (K1 i a) r)\n\n let decode_ value₀@(Value.Record _ fieldValues) = do\n expression₀ <- decode₀ value₀\n expression₁ <- decodeMaybe (fmap snd (HashMap.lookup name fieldValues))\n\n return (expression₀ :*: M1 (K1 expression₁))\n\n decode_ value = do\n let expectedType =\n State.evalState (genericExpected @((f₀ :*: f₁) :*: M1 S s (K1 i a))) 0\n\n Left TypeError{ expectedType, value }\n\n return decode_\n\ninstance (Selector s, FromGrace a, GenericFromGrace (f₀ :*: f₁)) => GenericFromGrace (M1 S s (K1 i a) :*: (f₀ :*: f₁)) where\n genericDecode = do\n name <- selector (undefined :: M1 S s (K1 i a) r)\n\n decode₁ <- genericDecode\n\n let decode_ value₁@(Value.Record _ fieldValues) = do\n expression₀ <- decodeMaybe (fmap snd (HashMap.lookup name fieldValues))\n expression₁ <- decode₁ value₁\n\n return (M1 (K1 expression₀) :*: expression₁)\n\n decode_ value = do\n let expectedType =\n State.evalState (genericExpected @(M1 S s (K1 i a) :*: (f₀ :*: f₁))) 0\n\n Left TypeError{ expectedType, value }\n\n return decode_\n\ninstance (GenericFromGrace (f₀ :*: f₁), GenericFromGrace (f₂ :*: f₃)) => GenericFromGrace ((f₀ :*: f₁) :*: (f₂ :*: f₃)) where\n genericDecode = do\n decode₀ <- genericDecode\n decode₁ <- genericDecode\n\n let decode_ value = do\n expression₀ <- decode₀ value\n expression₁ <- decode₁ value\n\n return (expression₀ :*: expression₁)\n\n return decode_\n\ninstance (Constructor c₀, Constructor c₁, GenericFromGrace f₀, GenericFromGrace f₁) => GenericFromGrace (M1 C c₀ f₀ :+: M1 C c₁ f₁) where\n genericDecode = do\n let name₀ = Text.pack (Generics.conName (undefined :: M1 C c₀ f₀ r))\n let name₁ = Text.pack (Generics.conName (undefined :: M1 C c₁ f₁ r))\n\n let decode₀ = State.evalState genericDecode 0\n let decode₁ = State.evalState genericDecode 0\n\n let decode_ v@(Value.Alternative _ name value)\n | name == name₀ = fmap (L1 . M1) (decode₀ value)\n | name == name₁ = fmap (R1 . M1) (decode₁ value)\n | otherwise = do\n let expectedType =\n State.evalState (genericExpected @(M1 C c₀ f₀ :+: M1 C c₁ f₁)) 0\n\n Left TypeError{ expectedType, value = v }\n decode_ v = do\n let expectedType =\n State.evalState (genericExpected @(M1 C c₀ f₀ :+: M1 C c₁ f₁)) 0\n\n Left TypeError{ expectedType, value = v }\n\n return decode_\n\ninstance (Constructor c, GenericFromGrace f₀, GenericFromGrace (f₁ :+: f₂)) => GenericFromGrace (M1 C c f₀ :+: (f₁ :+: f₂)) where\n genericDecode = do\n let name₀ = Text.pack (Generics.conName (undefined :: M1 C c f r))\n\n let decode₀ = State.evalState genericDecode 0\n let decode₁ = State.evalState genericDecode 0\n\n let decode_ (Value.Alternative _ name value₀)\n | name == name₀ = fmap (L1 . M1) (decode₀ value₀)\n decode_ value₁ = fmap R1 (decode₁ value₁)\n\n return decode_\n\ninstance (Constructor c, GenericFromGrace (f₀ :+: f₁), GenericFromGrace f₂) => GenericFromGrace ((f₀ :+: f₁) :+: M1 C c f₂) where\n genericDecode = do\n let name₁ = Text.pack (Generics.conName (undefined :: M1 C c f r))\n\n let decode₀ = State.evalState genericDecode 0\n let decode₁ = State.evalState genericDecode 0\n\n let decode_ (Value.Alternative _ name value₁)\n | name == name₁ = fmap (R1 . M1) (decode₁ value₁)\n decode_ value₀ = fmap L1 (decode₀ value₀)\n\n return decode_\n\ninstance (GenericFromGrace (f₀ :+: f₁), GenericFromGrace (f₂ :+: f₃)) => GenericFromGrace ((f₀ :+: f₁) :+: (f₂ :+: f₃)) where\n genericDecode = do\n let decode₀ = State.evalState genericDecode 0\n let decode₁ = State.evalState genericDecode 0\n\n let decode_ value = do\n let Right a <|> _ = Right a\n\n _ <|> Right a = Right a\n\n Left TypeError{ } <|> Left TypeError{ } = do\n let expectedType =\n State.evalState (genericExpected @((f₀ :+: f₁) :+: (f₂ :+: f₃))) 0\n\n Left TypeError{ expectedType, value }\n\n _ <|> _ = Left RangeError\n\n fmap L1 (decode₀ value) <|> fmap R1 (decode₁ value)\n\n return decode_\n\n-- | Result of decoding\ndata DecodingError\n = TypeError{ expectedType :: Type (), value :: Value Location }\n -- ^ The input Grace expression has the wrong type\n | RangeError\n -- ^ The input Grace expression is out of bounds for the target Haskell type\n deriving stock (Eq, Show)\n\ninstance Exception DecodingError where\n displayException TypeError{ expectedType, value } =\n \"Failed to decode Grace value into Haskell because of a type mismatch\\n\\\n \\\\n\\\n \\The following value:\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Grace.Pretty.toSmart (\" \" <> Pretty.align (Grace.Pretty.pretty value))) <> \"\\n\\\n \\\\n\\\n \\… could not be decoded into Haskell because it does not match this type:\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Grace.Pretty.toSmart (\" \" <> Pretty.align (Grace.Pretty.pretty expectedType)))\n displayException RangeError =\n \"Failed to decode value because the decoded result was out of bounds\"\n" }, { "path": "src/Grace/Domain.hs", "content": "{-| This module exists primarily to avoid a name clash with constructors of the\n same name in the \"Grace.Type\" module\n-}\nmodule Grace.Domain\n ( -- * Domain\n Domain(..)\n ) where\n\nimport GHC.Generics (Generic)\nimport Grace.Pretty (Pretty(..), builtin)\nimport Language.Haskell.TH.Syntax (Lift)\n\n-- | The domain over which a @forall@ is quantified\ndata Domain\n = Type\n -- ^ @forall (a : Type) . …@\n | Fields\n -- ^ @forall (a : Fields) . …@\n | Alternatives\n -- ^ @forall (a : Alternatives) . …@\n deriving stock (Eq, Generic, Lift, Show)\n\ninstance Pretty Domain where\n pretty Type = builtin \"Type\"\n pretty Fields = builtin \"Fields\"\n pretty Alternatives = builtin \"Alternatives\"\n" }, { "path": "src/Grace/Encode.hs", "content": "{-| Use this module to encode Haskell expressions as Grace expressions\n\n Example usage:\n\n >>> encode True\n Scalar () (Bool True)\n-}\nmodule Grace.Encode\n ( -- * Classes\n ToGrace(..)\n , GenericToGrace(..)\n , ToGraceType(..)\n , GenericToGraceType(..)\n\n -- * Types\n , Key(..)\n ) where\n\nimport Control.Monad.State (State)\nimport Data.HashMap.Strict.InsOrd (InsOrdHashMap)\nimport Data.Int (Int8, Int16, Int32, Int64)\nimport Data.Scientific (Scientific)\nimport Data.Sequence (Seq)\nimport Data.Text (Text)\nimport Data.Vector (Vector)\nimport Data.Void (Void)\nimport Data.Word (Word8, Word16, Word32, Word64)\nimport Grace.Marshal (GenericToGraceType(..), Key(..), ToGraceType(..))\nimport Grace.Value (Value(..))\nimport Numeric.Natural (Natural)\n\nimport GHC.Generics\n ( Generic(..)\n , C\n , Constructor\n , D\n , K1(..)\n , M1(..)\n , Rep\n , S\n , Selector\n , U1(..)\n , V1\n , (:+:)(..)\n , (:*:)(..)\n )\n\nimport qualified Control.Monad.State as State\nimport qualified Data.Aeson as Aeson\nimport qualified Data.Scientific as Scientific\nimport qualified Data.Sequence as Seq\nimport qualified Data.HashMap.Strict.InsOrd as HashMap\nimport qualified Data.Text as Text\nimport qualified Data.Text.Lazy as Text.Lazy\nimport qualified Data.Vector as Vector\nimport qualified GHC.Generics as Generics\nimport qualified Grace.Marshal as Marshal\nimport qualified Grace.Syntax as Syntax\nimport qualified Grace.Value as Value\n\n-- | Convert a Haskell expression to a Grace expression\nclass ToGraceType a => ToGrace a where\n encode :: a -> Value ()\n\n default encode :: (Generic a, GenericToGrace (Rep a)) => a -> Value ()\n encode = State.evalState genericEncode 0 . from\n\ninstance ToGrace Void\ninstance ToGrace ()\ninstance (ToGrace a, ToGrace b) => ToGrace (a, b)\ninstance (ToGrace a, ToGrace b) => ToGrace (Either a b)\n\ninstance ToGrace Bool where\n encode bool = Value.Scalar () (Syntax.Bool bool)\n\ninstance ToGrace Natural where\n encode natural = Value.Scalar () (Syntax.Natural natural)\n\ninstance ToGrace Word where\n encode = encode @Natural . fromIntegral\n\ninstance ToGrace Word8 where\n encode = encode @Natural . fromIntegral\n\ninstance ToGrace Word16 where\n encode = encode @Natural . fromIntegral\n\ninstance ToGrace Word32 where\n encode = encode @Natural . fromIntegral\n\ninstance ToGrace Word64 where\n encode = encode @Natural . fromIntegral\n\ninstance ToGrace Integer where\n encode integer = Value.Scalar () (Syntax.Integer integer)\n\ninstance ToGrace Int where\n encode = encode @Integer . fromIntegral\n\ninstance ToGrace Int8 where\n encode = encode @Integer . fromIntegral\n\ninstance ToGrace Int16 where\n encode = encode @Integer . fromIntegral\n\ninstance ToGrace Int32 where\n encode = encode @Integer . fromIntegral\n\ninstance ToGrace Int64 where\n encode = encode @Integer . fromIntegral\n\ninstance ToGrace Scientific where\n encode scientific = Value.Scalar () (Syntax.Real scientific)\n\ninstance ToGrace Float where\n encode = encode @Scientific . Scientific.fromFloatDigits\n\ninstance ToGrace Double where\n encode = encode @Scientific . Scientific.fromFloatDigits\n\ninstance ToGrace Text where\n encode text = Value.Text () text\n\ninstance ToGrace Text.Lazy.Text where\n encode = encode . Text.Lazy.toStrict\n\ninstance {-# OVERLAPPING #-} ToGrace [Char] where\n encode = encode . Text.pack\n\ninstance ToGrace Key where\n encode Key{ text } = Value.Scalar () (Syntax.Key text)\n\ninstance ToGrace Aeson.Value where\n encode = Value.fromJSON\n\ninstance ToGrace a => ToGrace (Seq a) where\n encode list = Value.List () (fmap encode list)\n\ninstance ToGrace a => ToGrace [a] where\n encode = encode . Seq.fromList\n\ninstance ToGrace a => ToGrace (Vector a) where\n encode = encode . Vector.toList\n\ninstance ToGrace a => ToGrace (Maybe a) where\n encode (Just a) =\n Value.Application () (Value.Builtin () Syntax.Some) (encode a)\n encode Nothing = Value.Scalar () Syntax.Null\n\n{-| This is the underlying class that powers the `ToGrace` class's support for\n automatically deriving a `Generic` implementation\n-}\nclass GenericToGrace f where\n genericEncode :: State Int (f a -> Value ())\n\ninstance GenericToGrace V1 where\n genericEncode = do\n -- EmptyCase does not work here and produces a non-exhaustive pattern\n -- match warning\n let encode_ _ = error \"Grace.Encode.genericEncode: V1 inhabited\"\n\n return encode_\n\ninstance GenericToGrace U1 where\n genericEncode = do\n let encode_ U1 = Value.Record () mempty\n\n return encode_\n\ninstance GenericToGrace f => GenericToGrace (M1 D d f) where\n genericEncode = fmap (. unM1) genericEncode\n\ninstance GenericToGrace f => GenericToGrace (M1 C c f) where\n genericEncode = fmap (. unM1) genericEncode\n\ninstance (Selector s, ToGrace a) => GenericToGrace (M1 S s (K1 i a)) where\n genericEncode = do\n let m1 :: M1 S s (K1 i a) r\n m1 = undefined\n\n name <- Marshal.selector m1\n\n let encode_ (M1 (K1 a))\n | Generics.selName m1 == \"\" =\n encode a\n | otherwise =\n Value.Record () (HashMap.singleton name ((), encode a))\n\n return encode_\n\ninstance (Selector s₀, Selector s₁, ToGrace a₀, ToGrace a₁) => GenericToGrace (M1 S s₀ (K1 i₀ a₀) :*: M1 S s₁ (K1 i₁ a₁)) where\n genericEncode = do\n name₀ <- Marshal.selector (undefined :: M1 S s₀ (K1 i₀ a₀) r)\n name₁ <- Marshal.selector (undefined :: M1 S s₁ (K1 i₁ a₁) r)\n\n let encode_ (M1 (K1 a₀) :*: M1 (K1 a₁)) =\n Value.Record\n ()\n (HashMap.fromList\n [ (name₀, ((), encode a₀)), (name₁, ((), encode a₁)) ]\n )\n\n return encode_\n\ninstance (Selector s, GenericToGrace (f₀ :*: f₁), ToGrace a) => GenericToGrace ((f₀ :*: f₁) :*: M1 S s (K1 i a)) where\n genericEncode = do\n encode₀ <- genericEncode\n\n name <- Marshal.selector (undefined :: M1 S s (K1 i a) r)\n\n let encode_ (f :*: M1 (K1 a)) = Value.Record\n ()\n ( HashMap.insert name ((), encode a)\n (unsafeExpectRecordLiteral (encode₀ f))\n )\n\n return encode_\n\ninstance (Selector s, ToGrace a, GenericToGrace (f₀ :*: f₁)) => GenericToGrace (M1 S s (K1 i a) :*: (f₀ :*: f₁)) where\n genericEncode = do\n name <- Marshal.selector (undefined :: M1 S s (K1 i a) r)\n\n encode₁ <- genericEncode\n\n let encode_ (M1 (K1 a) :*: f) = Value.Record\n ()\n (HashMap.insert name ((), encode a)\n (unsafeExpectRecordLiteral (encode₁ f))\n )\n\n return encode_\n\ninstance (GenericToGrace (f₀ :*: f₁), GenericToGrace (f₂ :*: f₃)) => GenericToGrace ((f₀ :*: f₁) :*: (f₂ :*: f₃)) where\n genericEncode = do\n encode₀ <- genericEncode\n encode₁ <- genericEncode\n\n let encode_ (f₀ :*: f₁) = Value.Record\n ()\n ( unsafeExpectRecordLiteral (encode₀ f₀)\n <> unsafeExpectRecordLiteral (encode₁ f₁)\n )\n\n return encode_\n\ninstance (Constructor c₀, Constructor c₁, GenericToGrace f₀, GenericToGrace f₁) => GenericToGrace (M1 C c₀ f₀ :+: M1 C c₁ f₁) where\n genericEncode = do\n let name₀ = Text.pack (Generics.conName (undefined :: M1 i c₀ f₀ r))\n let name₁ = Text.pack (Generics.conName (undefined :: M1 i c₁ f₁ r))\n\n let encode₀ = State.evalState genericEncode 0\n let encode₁ = State.evalState genericEncode 0\n\n let encode_ (L1 (M1 f)) = Value.Alternative () name₀ (encode₀ f)\n encode_ (R1 (M1 f)) = Value.Alternative () name₁ (encode₁ f)\n\n return encode_\n\ninstance (Constructor c, GenericToGrace f₀, GenericToGrace (f₁ :+: f₂)) => GenericToGrace (M1 C c f₀ :+: (f₁ :+: f₂)) where\n genericEncode = do\n let name = Text.pack (Generics.conName (undefined :: M1 C c f₀ r))\n\n let encode₀ = State.evalState genericEncode 0\n let encode₁ = State.evalState genericEncode 0\n\n let encode_ (L1 (M1 f)) = Value.Alternative () name (encode₀ f)\n encode_ (R1 f ) = encode₁ f\n\n return encode_\n\ninstance (Constructor c, GenericToGrace (f₀ :+: f₁), GenericToGrace f₂) => GenericToGrace ((f₀ :+: f₁) :+: M1 C c f₂) where\n genericEncode = do\n let name = Text.pack (Generics.conName (undefined :: M1 C c f₂ r))\n\n let encode₀ = State.evalState genericEncode 0\n let encode₁ = State.evalState genericEncode 0\n\n let encode_ (L1 f ) = encode₀ f\n encode_ (R1 (M1 f)) = Value.Alternative () name (encode₁ f)\n\n return encode_\n\ninstance (GenericToGrace (f₀ :+: f₁), GenericToGrace (f₂ :+: f₃)) => GenericToGrace ((f₀ :+: f₁) :+: (f₂ :+: f₃)) where\n genericEncode = do\n let encode₀ = State.evalState genericEncode 0\n let encode₁ = State.evalState genericEncode 0\n\n let encode_ (L1 f) = encode₀ f\n encode_ (R1 f) = encode₁ f\n\n return encode_\n\nunsafeExpectRecordLiteral\n :: Value location -> InsOrdHashMap Text (location, Value location)\nunsafeExpectRecordLiteral (Value.Record _ fieldValues) =\n fieldValues\nunsafeExpectRecordLiteral _ =\n error \"Grace.Encode.unsafeExpectRecordLiteral: not a record\"\n" }, { "path": "src/Grace/Existential.hs", "content": "{-| This module provides a newtype wrapper for existential variables used in the\n type-checking algorithm.\n\n We don't use naked `Int`s since (empirically) conflating the various\n existentials is a common source of type-checking errors.\n-}\nmodule Grace.Existential\n ( -- * Types\n Existential\n -- * Utilities\n , toVariable\n ) where\n\nimport Data.Text (Text)\nimport Grace.Pretty (Pretty(..), label)\nimport Language.Haskell.TH.Syntax (Lift)\n\nimport qualified Data.Char as Char\nimport qualified Data.Text as Text\n\n{-| An existential variable\n\n The type variable is used to track what type of existential variable we're\n using, which will be one of these three types:\n\n * @`Existential` \"Grace.Monotype\".Monotype@ - An existential type\n * @`Existential` \"Grace.Monotype\".Record@ - An existential fields variable\n * @`Existential` \"Grace.Monotype\".Union@ - An existential alternatives\n variable\n-}\nnewtype Existential a = UnsafeExistential Int\n deriving stock Lift\n deriving newtype (Eq, Num, Show)\n\ninstance Pretty (Existential a) where\n pretty x = label (pretty (toVariable x))\n\n{-| Convert an existential variable to a user-friendly `Text`\n representation\n\n >>> toVariable 0\n \"a\"\n >>> toVariable 1\n \"b\"\n >>> toVariable 26\n \"a0\"\n-}\ntoVariable :: Existential a -> Text\ntoVariable (UnsafeExistential n) = Text.cons prefix suffix\n where\n (q, r) = n `quotRem` 26\n\n prefix = Char.chr (Char.ord 'a' + r)\n\n suffix = if q == 0 then \"\" else Text.pack (show (q - 1))\n" }, { "path": "src/Grace/GitHub.hs", "content": "-- | Utilities for interacting with GitHub\nmodule Grace.GitHub\n ( -- * GitHub requests\n github\n , GitHub(..)\n ) where\n\nimport Data.Aeson (FromJSON)\nimport Data.Text (Text)\nimport GHC.Generics (Generic)\nimport Grace.Decode (FromGrace(..), Key(..), ToGraceType)\nimport Grace.Encode (ToGrace)\nimport Grace.HTTP.Type (Header(..), HTTP(..), Parameter(..))\n\nimport qualified Data.Text as Text\nimport qualified Grace.Aeson\nimport qualified Grace.HTTP as HTTP\n\n-- | An HTTP request to GitHub\ndata GitHub = GitHub\n { key :: Maybe Key\n , reference :: Maybe Text\n , owner :: Text\n , repository :: Text\n , path :: Text\n } deriving stock (Generic)\n deriving anyclass (FromGrace, ToGrace, ToGraceType)\n\n-- | Response from GitHub @\\/repos/${owner}\\/${repo}\\/contents\\/${path}@ API\ndata Contents = Contents{ download_url :: Text }\n deriving stock (Generic)\n deriving anyclass (FromJSON)\n\n{-| Get the download URL of a file on GitHub\n\n This is an ergonomic convenience for the user for the exceedingly common use\n case of fetching code in version control from GitHub (and also powers\n trygrace.dev's `/github/${owner}/${repository}/${path}` short-links.\n-}\ngithub :: GitHub -> IO Text\ngithub GitHub{ key, owner, repository, reference, path } = do\n let authorization = case key of\n Nothing ->\n [ ]\n Just (Key k) ->\n [ Header{ header = \"Authorization\", value = \"Bearer \" <> Text.strip k } ]\n\n let headers = Just\n ( [ Header{ header = \"X-GitHub-Api-Version\", value = \"2022-11-28\" }\n , Header{ header = \"User-Agent\", value = \"Grace\" }\n ]\n <> authorization\n )\n\n let parameters = do\n r <- reference\n\n return [ Parameter{ parameter = \"ref\", value = Just r } ]\n\n contentsResponse <- HTTP.http False GET\n { url = \"https://api.github.com/repos/\" <> owner <> \"/\" <> repository <> \"/contents/\" <> path\n , headers\n , parameters\n }\n\n Contents{ download_url } <- Grace.Aeson.decode contentsResponse\n\n return download_url\n" }, { "path": "src/Grace/HTTP/Type.hs", "content": "-- | This module contains types shared between the GHC and GHCJS implementations\nmodule Grace.HTTP.Type where\n\nimport Data.Aeson (Value)\nimport Data.Text (Text)\nimport GHC.Generics (Generic)\nimport Grace.Decode (FromGrace, ToGraceType)\nimport Grace.Encode (ToGrace)\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Data.Binary.Builder as Builder\nimport qualified Data.ByteString.Lazy as ByteString.Lazy\nimport qualified Data.CaseInsensitive as CaseInsensitive\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Encoding\nimport qualified Data.Time.Clock.POSIX as Time\nimport qualified Network.HTTP.Types as HTTP.Types\n\n-- | An HTTP header\ndata Header = Header{ header :: Text, value :: Text }\n deriving stock (Generic)\n deriving anyclass (FromGrace, ToGrace, ToGraceType)\n\n-- | A query parameter\ndata Parameter = Parameter{ parameter :: Text, value :: Maybe Text }\n deriving stock (Generic)\n deriving anyclass (FromGrace, ToGrace, ToGraceType)\n\n-- | An HTTP request\ndata HTTP\n = GET\n { url :: Text\n , headers :: Maybe [Header]\n , parameters :: Maybe [Parameter]\n }\n | POST\n { url :: Text\n , headers :: Maybe [Header]\n , request :: Maybe Value\n }\n deriving stock (Generic)\n deriving anyclass (FromGrace, ToGrace, ToGraceType)\n\ncompleteHeaders :: Bool -> Bool -> Maybe [Header] -> [HTTP.Types.Header]\ncompleteHeaders import_ body headers = do\n Header{ header, value } <- requiredHeaders <> defaultedHeaders\n\n let headerBytes = CaseInsensitive.mk (Encoding.encodeUtf8 header)\n\n let valueBytes = Encoding.encodeUtf8 (Text.strip value)\n\n return (headerBytes, valueBytes)\n where\n requiredHeaders\n | import_ =\n [ ]\n | otherwise =\n ( [ Header{ header = \"Accept\" , value = \"application/json\" }\n ]\n <> contentType\n )\n where\n contentType\n | body =\n [ Header{ header = \"Content-Type\", value = \"application/json\" } ]\n | otherwise =\n [ ]\n\n defaultedHeaders = case headers of\n Nothing -> []\n Just h -> h\n\norganization :: Maybe Text\norganization = Nothing\n\nrenderQueryText :: Text -> Maybe [Parameter] -> IO Text\nrenderQueryText url parameters = do\n let (intermediateURL, queryBytes) = Text.break (== '?') url\n\n let oldQueryText =\n HTTP.Types.parseQueryText (Encoding.encodeUtf8 queryBytes)\n\n let oldParameters = do\n (parameter, value) <- oldQueryText\n\n return Parameter{ parameter, value }\n\n currentTime <- Time.getPOSIXTime\n\n let cacheBust =\n [ Parameter\n { parameter = \"cachebust\"\n , value = Just (Text.pack (show currentTime))\n }\n ]\n\n let finalParameters = case parameters of\n Nothing -> oldParameters <> cacheBust\n Just newParameters -> oldParameters <> newParameters <> cacheBust\n\n let queryText = do\n Parameter{ parameter, value } <- finalParameters\n\n return (parameter, value)\n\n let builder = HTTP.Types.renderQueryText True queryText\n\n let bytes = ByteString.Lazy.toStrict (Builder.toLazyByteString builder)\n\n case Encoding.decodeUtf8' bytes of\n Left exception -> Exception.throwIO exception\n Right text -> return (intermediateURL <> text)\n" }, { "path": "src/Grace/Import.hs", "content": "-- | This module contains the import resolution logic\nmodule Grace.Import\n ( -- * Import resolution\n resolve\n , referentiallySane\n\n -- * Exceptions\n , ResolutionError(..)\n , ImportError(..)\n ) where\n\nimport Control.Exception.Safe (Exception(..))\nimport Data.Bifunctor (first)\nimport Data.Foldable (foldl')\nimport Data.HashMap.Strict (HashMap)\nimport Data.IORef (IORef)\nimport Data.List.NonEmpty (NonEmpty(..))\nimport Data.Maybe (fromJust)\nimport Data.Text (Text)\nimport Grace.HTTP (HttpException)\nimport Grace.Input (Input(..), Mode(..))\nimport Grace.Location (Location(..))\nimport Grace.Monad (Grace)\nimport Grace.Syntax (Syntax)\nimport System.FilePath (())\nimport Text.URI (Authority, RText, RTextLabel(..))\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Data.HashMap.Strict as HashMap\nimport qualified Data.IORef as IORef\nimport qualified Data.List.NonEmpty as NonEmpty\nimport qualified Data.Text as Text\nimport qualified Data.Text.IO as Text.IO\nimport qualified Grace.HTTP as HTTP\nimport qualified Grace.Parser as Parser\nimport qualified Grace.Pretty as Pretty\nimport qualified Grace.Syntax as Syntax\nimport qualified System.Directory as Directory\nimport qualified System.Environment as Environment\nimport qualified System.IO.Unsafe as Unsafe\nimport qualified Text.URI as URI\n\ncache :: IORef (HashMap Text Text)\ncache = Unsafe.unsafePerformIO (IORef.newIORef HashMap.empty)\n{-# NOINLINE cache #-}\n\nfetch :: Text -> IO Text\nfetch url = do\n m <- IORef.readIORef cache\n\n case HashMap.lookup url m of\n Nothing -> do\n body <- HTTP.fetch url\n\n IORef.writeIORef cache $! HashMap.insert url body m\n\n return body\n Just body -> do\n return body\n\nremoteSchemes :: [RText 'Scheme]\nremoteSchemes = map (fromJust . URI.mkScheme) [ \"http\", \"https\" ]\n\n-- | Resolve an `Input` by returning the source code that it represents\nresolve :: Mode -> Input -> IO (Syntax Location Input)\nresolve mode₀ input = case input of\n URI uri mode₁\n | any (`elem` remoteSchemes) (URI.uriScheme uri) -> do\n let name = URI.renderStr uri\n\n let handler e = throw (HTTPError e)\n\n text <- Exception.handle handler (fetch (Text.pack name))\n\n result <- case mode₀ <> mode₁ of\n AsCode -> case Parser.parse name text of\n Left e -> Exception.throw e\n Right result -> return result\n AsText -> do\n return Syntax.Text\n { chunks = Syntax.Chunks text []\n , location = 0\n }\n AsKey -> do\n return Syntax.Scalar\n { scalar = Syntax.Key text\n , location = 0\n }\n\n let locate offset = Location{ name, code = text, offset }\n\n return (first locate result)\n\n | URI.uriScheme uri == URI.mkScheme \"env\" -> do\n case URI.uriAuthority uri of\n Left False -> do\n var <- case URI.uriPath uri of\n Nothing -> throw MissingPath\n Just (False, var :| []) -> return (URI.unRText var)\n _ -> throw UnsupportedPathSeparators\n\n maybeCode <- Environment.lookupEnv (Text.unpack var)\n\n text <- case maybeCode of\n Nothing -> throw MissingEnvironmentVariable\n Just string -> return (Text.pack string)\n\n let name = \"env:\" <> Text.unpack var\n\n result <- case mode₀ <> mode₁ of\n AsCode -> case Parser.parse name text of\n Left e -> Exception.throw e\n Right result -> return result\n AsText -> do\n return Syntax.Text\n { chunks = Syntax.Chunks text []\n , location = 0\n }\n AsKey -> do\n return Syntax.Scalar\n { scalar = Syntax.Key text\n , location = 0\n }\n\n let locate offset = Location{ name, code = text, offset }\n\n return (first locate result)\n Left True -> do\n throw UnsupportedPathSeparators\n Right _ -> do\n throw UnsupportedAuthority\n\n | URI.uriScheme uri == URI.mkScheme \"file\" -> do\n if all (== emptyAuthority) (URI.uriAuthority uri)\n then do\n pieces <- case URI.uriPath uri of\n Nothing -> throw MissingPath\n Just (_, pieces) -> return pieces\n\n let pathPiecesToFilePath =\n foldl' () \"/\" . map (Text.unpack . URI.unRText) . NonEmpty.toList\n\n readPath (mode₀ <> mode₁) (pathPiecesToFilePath pieces)\n else do\n throw UnsupportedAuthority\n\n | otherwise -> do\n throw InvalidURI\n\n Path path mode₁ -> do\n readPath (mode₀ <> mode₁) path\n\n Code name code -> do\n result <- case Parser.parse name code of\n Left e -> Exception.throw e\n Right result -> return result\n\n let locate offset = Location{ name, code, offset }\n\n return (first locate result)\n where\n readPath mode path = do\n adjustedPath <- case path of\n '~' : '/' : suffix -> do\n home <- Directory.getHomeDirectory\n return (home suffix)\n _ -> do\n return path\n\n text <- Text.IO.readFile adjustedPath\n\n result <- case mode of\n AsCode -> case Parser.parse path text of\n Left e -> Exception.throw e\n Right result -> return result\n AsText -> do\n return Syntax.Text\n { chunks = Syntax.Chunks text []\n , location = 0\n }\n AsKey -> do\n return Syntax.Scalar\n { scalar = Syntax.Key text\n , location = 0\n }\n\n let locate offset = Location{ name = path, code = text, offset }\n\n return (first locate result)\n\n throw e = Exception.throw (ImportError input e)\n\nemptyAuthority :: Authority\nemptyAuthority = URI.Authority\n { URI.authUserInfo = Nothing\n , URI.authHost = fromJust (URI.mkHost \"\")\n , URI.authPort = Nothing\n }\n\nremote :: Input -> Bool\nremote (URI uri _) = any (`elem` remoteSchemes) (URI.uriScheme uri)\nremote _ = False\n\n-- | Fail if the child import tries to access something that the parent import\n-- should not have access to\nreferentiallySane :: Input -> Input -> Grace ()\nreferentiallySane parent child\n | remote parent && not (remote child) = do\n Exception.throwIO (ImportError parent (ReferentiallyInsane child))\n | otherwise = do\n return ()\n\n-- | The base error for `ImportError` (without the @input@ information)\ndata ResolutionError\n = HTTPError HttpException\n | InvalidURI\n | MissingEnvironmentVariable\n | MissingPath\n | UnsupportedPathSeparators\n | ReferentiallyInsane Input\n | UnsupportedAuthority\n deriving stock (Show)\n\n-- | Errors related to import resolution\ndata ImportError = ImportError\n { input :: Input\n , resolutionError :: ResolutionError\n } deriving stock (Show)\n\ninstance Exception ImportError where\n displayException ImportError{ input, resolutionError } =\n Text.unpack\n (\"Import resolution failed: \" <> renderedInput <> \"\\n\\\n \\\\n\\\n \\\" <> renderedError\n )\n where\n renderedInput = case input of\n URI uri AsCode -> URI.render uri\n URI uri AsText -> URI.render uri <> \" : Text\"\n URI uri AsKey -> URI.render uri <> \" : Key\"\n\n Path path AsCode -> Text.pack path\n Path path AsText -> Text.pack path <> \" : Text\"\n Path path AsKey -> Text.pack path <> \" : Key\"\n\n Code _ _ -> \"(input)\"\n\n renderedError :: Text\n renderedError = case resolutionError of\n HTTPError httpException ->\n HTTP.renderError httpException\n InvalidURI ->\n \"Invalid URI\"\n MissingEnvironmentVariable ->\n \"Missing environment variable\"\n MissingPath ->\n \"Missing path\"\n ReferentiallyInsane child ->\n \"Local imports are rejected within remote imports\\n\\\n \\\\n\\\n \\Rejected local import: \" <> Text.pack (show (Pretty.pretty child))\n UnsupportedPathSeparators ->\n \"Unsupported path separators\"\n UnsupportedAuthority ->\n \"Unsupported authority\"\n" }, { "path": "src/Grace/Infer.hs", "content": "{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE OverloadedLists #-}\n\n{-| This module is based on the bidirectional type-checking algorithm from:\n\n Dunfield, Jana, and Neelakantan R. Krishnaswami. \\\"Complete and easy bidirectional typechecking for higher-rank polymorphism.\\\" ACM SIGPLAN Notices 48.9 (2013): 429-442.\n\n The main differences from the original algorithm are:\n\n * This uses `Control.Monad.State.Strict.StateT` to thread around\n `Context`s and manipulate them instead of explicit `Context` passing as\n in the original paper\n\n * This algorithm adds support for row polymorphism and polymorphic variants\n-}\nmodule Grace.Infer\n ( -- * Type inference\n typeOf\n , typeWith\n , infer\n , inferJSON\n , checkJSON\n\n -- * Types\n , HTTP(..)\n\n -- * Errors related to type inference\n , TypeInferenceError(..)\n ) where\n\nimport Control.Applicative ((<|>))\nimport Control.Exception.Safe (Exception(..), MonadThrow)\nimport Control.Monad (when)\nimport Control.Monad.IO.Class (MonadIO(..))\nimport Control.Monad.State (MonadState)\nimport Data.Foldable (for_, toList, traverse_)\nimport Data.Sequence (ViewL(..), (<|))\nimport Data.Typeable (Typeable)\nimport Data.Text (Text)\nimport Data.Void (Void)\nimport Grace.Context (Context, Entry)\nimport Grace.Decode (ToGraceType(..))\nimport Grace.Existential (Existential)\nimport Grace.GitHub (GitHub(..))\nimport Grace.HTTP.Type (HTTP(..))\nimport Grace.Input (Input(..), Mode(..))\nimport Grace.Location (Location(..))\nimport Grace.Monad (Grace, Status(..))\nimport Grace.Monotype (Monotype)\nimport Grace.Pretty (Pretty(..))\nimport Grace.Prompt.Types (Prompt(..))\nimport Grace.Type (Type(..))\nimport Grace.Value (Value)\n\nimport Grace.Syntax\n ( Assignment(..)\n , Binding(..)\n , BindMonad(..)\n , Definition(..)\n , NameBinding(NameBinding)\n , Syntax\n )\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Control.Lens as Lens\nimport qualified Control.Monad as Monad\nimport qualified Control.Monad.Reader as Reader\nimport qualified Control.Monad.State as State\nimport qualified Data.Aeson as Aeson\nimport qualified Data.Aeson.Encode.Pretty as Aeson.Pretty\nimport qualified Data.ByteString.Lazy as ByteString.Lazy\nimport qualified Data.HashMap.Strict.InsOrd as Map\nimport qualified Data.List.NonEmpty as NonEmpty\nimport qualified Data.Scientific as Scientific\nimport qualified Data.Sequence as Seq\nimport qualified Data.Set as Set\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Encoding\nimport qualified Grace.Compat as Compat\nimport qualified Grace.Context as Context\nimport qualified Grace.Domain as Domain\nimport qualified Grace.Import as Import\nimport qualified Grace.Location as Location\nimport qualified Grace.Monad as Grace\nimport qualified Grace.Monotype as Monotype\nimport qualified Grace.Pretty\nimport qualified Grace.Syntax as Syntax\nimport qualified Grace.Type as Type\nimport qualified Grace.Value as Value\nimport qualified Prettyprinter as Pretty\n\norDie :: (Exception e, MonadThrow m) => Maybe a -> e -> m a\nJust x `orDie` _ = return x\nNothing `orDie` e = Exception.throwIO e\n\n-- | Generate a fresh existential variable (of any type)\nfresh :: MonadState Status m => m (Existential a)\nfresh = do\n let update Status{ count = count₀, .. } =\n (fromIntegral count₀, Status{ count = count₁, .. })\n where\n count₁ = count₀ + 1\n\n State.state update\n\n-- Unlike the original paper, we don't explicitly thread the `Context` around.\n-- Instead, we modify the ambient state using the following utility functions:\n\n-- | Push a new `Context` `Entry` onto the stack\npush :: MonadState Status m => Entry Location -> m ()\npush entry = State.modify (\\s -> s { context = entry : context s })\n\n-- | Push an unsolved variable to the very beginning of the `Context`. This\n-- ensures that the unsolved variable is never lost.\n--\n-- This comes in handy for existential variables created as part of `import`\n-- keywords, where we want to make sure that these type variables are preserved\n-- in the final `Context` so that they can be reused by evaluation.\npreserve :: MonadState Status m => Entry Location -> m ()\npreserve entry = State.modify (\\s -> s { context = context s <> [ entry ] })\n\n-- | Retrieve the current `Context`\nget :: MonadState Status m => m (Context Location)\nget = State.gets context\n\n-- | Set the `Context` to a new value\nset :: MonadState Status m => Context Location -> m ()\nset context = State.modify (\\s -> s{ context })\n\n{-| This is used to temporarily add a `Context` entry that is discarded at the\n end of the entry's scope, along with any downstream entries that were\n created within that same scope\n-}\nscoped :: MonadState Status m => Entry Location -> m r -> m r\nscoped entry k = do\n push entry\n\n r <- k\n\n State.modify (\\s -> s{ context = Context.discardUpTo entry (context s) })\n\n return r\n\nscopedUnsolvedType :: MonadState Status m => s -> (Type.Type s -> m a) -> m a\nscopedUnsolvedType location k = do\n existential <- fresh\n\n scoped (Context.MarkerType existential) do\n push (Context.UnsolvedType existential)\n\n k Type.UnsolvedType{ location, existential }\n\nscopedUnsolvedFields :: MonadState Status m => (Type.Record s -> m a) -> m a\nscopedUnsolvedFields k = do\n a <- fresh\n\n scoped (Context.MarkerFields a) do\n push (Context.UnsolvedFields a)\n\n k (Type.Fields [] (Monotype.UnsolvedFields a))\n\nscopedUnsolvedAlternatives\n :: MonadState Status m => (Type.Union s -> m a) -> m a\nscopedUnsolvedAlternatives k = do\n a <- fresh\n\n scoped (Context.MarkerAlternatives a) do\n push (Context.UnsolvedAlternatives a)\n\n k (Type.Alternatives [] (Monotype.UnsolvedAlternatives a))\n\n{-| @wellFormed context type@ checks that all type/fields/alternatives\n variables within @type@ are declared within the @context@\n-}\nwellFormed :: MonadThrow m => Context Location -> Type Location -> m ()\nwellFormed context Type.VariableType{ location, name }\n | Context.Variable Domain.Type name `elem` context = do\n return ()\n | otherwise = do\n Exception.throwIO (UnboundTypeVariable location name)\n\nwellFormed context Type.Function{ input, output } = do\n wellFormed context input\n wellFormed context output\n\nwellFormed context Type.Forall{ name, domain, type_ } = do\n wellFormed (Context.Variable domain name : context) type_\n\nwellFormed context _A@Type.UnsolvedType{ location, existential }\n | all mismatch context = do\n Exception.throwIO (IllFormedType location _A context)\n | otherwise = do\n return ()\n where\n mismatch (Context.UnsolvedType a ) = existential /= a\n mismatch (Context.SolvedType a _) = existential /= a\n mismatch _ = True\n\nwellFormed context Type.Optional{ type_ } = do\n wellFormed context type_\n\nwellFormed context Type.List{ type_ } = do\n wellFormed context type_\n\nwellFormed context Type.Record{ location, fields = Type.Fields kAs remainingFields } =\n case remainingFields of\n Monotype.UnsolvedFields a₀\n | all mismatch context ->\n Exception.throwIO (IllFormedFields location a₀ context)\n where\n mismatch (Context.UnsolvedFields a₁ ) = a₀ /= a₁\n mismatch (Context.SolvedFields a₁ _) = a₀ /= a₁\n mismatch _ = True\n\n Monotype.VariableFields a\n | Context.Variable Domain.Fields a `notElem` context ->\n Exception.throwIO (UnboundFields location a)\n\n _ -> do\n traverse_ (\\(_, _A) -> wellFormed context _A) kAs\n\nwellFormed context Type.Union{ location, alternatives = Type.Alternatives kAs remainingAlternatives } =\n case remainingAlternatives of\n Monotype.UnsolvedAlternatives a₀\n | all mismatch context ->\n Exception.throwIO (IllFormedAlternatives location a₀ context)\n where\n mismatch (Context.UnsolvedAlternatives a₁ ) = a₀ /= a₁\n mismatch (Context.SolvedAlternatives a₁ _) = a₀ /= a₁\n mismatch _ = True\n Monotype.VariableAlternatives a\n | Context.Variable Domain.Alternatives a `notElem` context ->\n Exception.throwIO (UnboundAlternatives location a)\n _ ->\n traverse_ (\\(_, _A) -> wellFormed context _A) kAs\n\nwellFormed _ Type.Scalar{} = do\n return ()\n\n-- A field is required if and only if it is a subtype of @Optional T@ for some\n-- type @T@\nisFieldRequired :: Type Location -> Grace Bool\n-- Fast path\nisFieldRequired Type.Optional{ } = return False\n-- Slow path\nisFieldRequired fieldType = do\n context <- get\n\n let assertOptional = do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n let optional = Type.Optional{ location, type_ }\n where\n location = Type.location fieldType\n\n type_ = Type.UnsolvedType\n { existential\n , location\n }\n\n subtype (Context.solveType context fieldType) optional\n\n return False\n\n assertOptional `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context\n\n return True\n\n-- | Computes the supertype of the two input types\nsupertypeOf :: Type Location -> Type Location -> Grace (Type Location)\nsupertypeOf a b = do\n context₀ <- get\n\n case (a, b) of\n (type₀@UnsolvedType{ existential = existential₀ }, UnsolvedType { existential = existential₁ }) -> do\n Monad.unless (existential₀ == existential₁) do\n equateTypes existential₀ existential₁\n\n return type₀\n\n (UnsolvedType{ existential }, type_)\n | not (existential `Type.typeFreeIn` type_)\n , elem (Context.UnsolvedType existential) context₀ -> do\n instantiateTypeL existential type_\n\n return type_\n\n (type_, UnsolvedType{ existential })\n | not (existential `Type.typeFreeIn` type_)\n , elem (Context.UnsolvedType existential) context₀ -> do\n instantiateTypeL existential type_\n\n return type_\n\n (Forall{ location, nameLocation, name, domain, type_ = type₀ }, type₁) -> do\n type_ <- supertypeOf type₀ type₁\n\n return Forall{ location, nameLocation, name, domain, type_ }\n\n (type₀, Forall{ location, nameLocation, name, domain, type_ = type₁ }) -> do\n type_ <- supertypeOf type₀ type₁\n\n return Forall{ location, nameLocation, name, domain, type_ }\n\n (VariableType{ location, name = name₀ }, VariableType{ name = name₁ })\n | name₀ == name₁ -> do\n return VariableType{ location, name = name₀ }\n\n (Function{ location, input = input₀, output = output₀ }, Function{ input = input₁, output = output₁ }) -> do\n input <- subtypeOf input₀ input₁\n\n context <- get\n\n output <- supertypeOf (Context.solveType context output₀) (Context.solveType context output₁)\n\n return Function{ location, input, output }\n\n (List{ location, type_ = type₀ }, List{ type_ = type₁ }) -> do\n type_ <- supertypeOf type₀ type₁\n\n return List{ location, type_ }\n\n (Record{ location = location₀, fields = fields₀ }, Record{ location = location₁, fields = fields₁ }) -> do\n let Type.Fields fieldTypes₀ remainingFields₀ = fields₀\n let Type.Fields fieldTypes₁ remainingFields₁ = fields₁\n\n let map₀ = Map.fromList fieldTypes₀\n let map₁ = Map.fromList fieldTypes₁\n\n let combine type₀ type₁ = do\n context <- get\n\n supertypeOf (Context.solveType context type₀) (Context.solveType context type₁)\n\n both <- sequence (Map.intersectionWith combine map₀ map₁)\n\n let optional location type_ = do\n context <- get\n\n required <- isFieldRequired (Context.solveType context type_)\n\n if required\n then return Optional{ location, type_ }\n else return type_\n\n let extra₀ = Map.difference map₀ map₁\n let extra₁ = Map.difference map₁ map₀\n\n let location\n | null extra₁ = location₀\n | otherwise = location₁\n\n -- TODO: Check if `UnsolvedFields` are solved by now\n case (remainingFields₀, remainingFields₁) of\n _ | remainingFields₀ == remainingFields₁ -> do\n optionalExtra₀ <- traverse (optional location₀) extra₀\n optionalExtra₁ <- traverse (optional location₁) extra₁\n\n let fieldTypes =\n Map.toList (both <> optionalExtra₀ <> optionalExtra₁)\n\n return Record\n { location\n , fields = Type.Fields fieldTypes remainingFields₀\n }\n\n (Monotype.UnsolvedFields p₀, Monotype.UnsolvedFields p₁) -> do\n p₂ <- fresh\n\n context₁ <- get\n\n let p₀First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₀ context₁\n\n Monad.guard (Context.UnsolvedFields p₁ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedFields p₀\n : Context.UnsolvedFields p₂\n : contextBefore\n )\n )\n\n return command\n\n let p₁First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₁ context₁\n\n Monad.guard (Context.UnsolvedFields p₀ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedFields p₁\n : Context.UnsolvedFields p₂\n : contextBefore\n )\n )\n\n return command\n\n case p₀First <|> p₁First of\n Nothing -> do\n Exception.throwIO (MissingOneOfFields [location₀, location₁] p₀ p₁ context₁)\n\n Just setContext -> do\n setContext\n\n context₂ <- get\n\n instantiateFieldsL\n p₀\n location₁\n (Context.solveRecord context₂\n (Type.Fields (Map.toList extra₁)\n (Monotype.UnsolvedFields p₂)\n )\n )\n\n context₃ <- get\n\n instantiateFieldsL\n p₁\n location₀\n (Context.solveRecord context₃\n (Type.Fields (Map.toList extra₀)\n (Monotype.UnsolvedFields p₂)\n )\n )\n\n let fieldTypes = Map.toList (both <> extra₀ <> extra₁)\n\n return Record\n { location\n , fields = Type.Fields fieldTypes (Monotype.UnsolvedFields p₂)\n }\n\n (Monotype.UnsolvedFields p₀, _) -> do\n context₁ <- get\n\n instantiateFieldsL\n p₀\n location₁\n (Context.solveRecord context₁\n (Type.Fields (Map.toList extra₁) remainingFields₁)\n )\n\n optionalExtra₀ <- traverse (optional location₀) extra₀\n\n let fieldTypes =\n Map.toList (both <> optionalExtra₀ <> extra₁)\n\n return Record\n { location\n , fields = Type.Fields fieldTypes remainingFields₁\n }\n\n (_, Monotype.UnsolvedFields p₁) -> do\n context₁ <- get\n\n instantiateFieldsL\n p₁\n location₀\n (Context.solveRecord context₁\n (Type.Fields (Map.toList extra₀) remainingFields₀)\n )\n\n optionalExtra₁ <- traverse (optional location₁) extra₁\n\n let fieldTypes =\n Map.toList (both <> extra₀ <> optionalExtra₁)\n\n return Record\n { location\n , fields = Type.Fields fieldTypes remainingFields₀\n }\n\n _ -> do\n -- TODO: Improve location\n Exception.throwIO (FieldsVariableMismatch location₀ remainingFields₀ location₁ remainingFields₁)\n\n (Type.Union{ location = location₀, alternatives = alternatives₀ }, Type.Union{ location = location₁, alternatives = alternatives₁ }) -> do\n let Type.Alternatives alternativeTypes₀ remainingAlternatives₀ = alternatives₀\n let Type.Alternatives alternativeTypes₁ remainingAlternatives₁ = alternatives₁\n\n let map₀ = Map.fromList alternativeTypes₀\n let map₁ = Map.fromList alternativeTypes₁\n\n let combine type₀ type₁ = do\n context <- get\n\n supertypeOf (Context.solveType context type₀) (Context.solveType context type₁)\n\n both <- sequence (Map.intersectionWith combine map₀ map₁)\n\n let extra₀ = Map.difference map₀ map₁\n let extra₁ = Map.difference map₁ map₀\n\n let alternativeTypes =\n Map.toList (both <> extra₀ <> extra₁)\n\n let location\n | null extra₁ = location₀\n | otherwise = location₁\n\n -- TODO: Check if `UnsolvedAlternatives` are solved by now\n case (remainingAlternatives₀, remainingAlternatives₁) of\n _ | remainingAlternatives₀ == remainingAlternatives₁ -> do\n return Type.Union\n { location\n , alternatives =\n Type.Alternatives alternativeTypes remainingAlternatives₀\n }\n\n (Monotype.UnsolvedAlternatives p₀, Monotype.UnsolvedAlternatives p₁) -> do\n p₂ <- fresh\n\n context₁ <- get\n\n let p₀First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₀ context₁\n\n Monad.guard (Context.UnsolvedAlternatives p₁ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedAlternatives p₀\n : Context.UnsolvedAlternatives p₂\n : contextBefore\n )\n )\n\n return command\n\n let p₁First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₁ context₁\n\n Monad.guard (Context.UnsolvedAlternatives p₀ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedAlternatives p₁\n : Context.UnsolvedAlternatives p₂\n : contextBefore\n )\n )\n\n return command\n\n case p₀First <|> p₁First of\n Nothing -> do\n Exception.throwIO (MissingOneOfAlternatives [location₀, location₁] p₀ p₁ context₁)\n\n Just command -> do\n command\n\n context₂ <- get\n\n instantiateAlternativesL\n p₀\n location₁\n (Context.solveUnion context₂\n (Type.Alternatives (Map.toList extra₁)\n (Monotype.UnsolvedAlternatives p₂)\n )\n )\n\n context₃ <- get\n\n instantiateAlternativesL\n p₁\n location₀\n (Context.solveUnion context₃\n (Type.Alternatives (Map.toList extra₀)\n (Monotype.UnsolvedAlternatives p₂)\n )\n )\n\n\n return Type.Union\n { location\n , alternatives =\n Type.Alternatives alternativeTypes (Monotype.UnsolvedAlternatives p₂)\n }\n\n (Monotype.UnsolvedAlternatives p₀, _) -> do\n instantiateAlternativesL\n p₀\n location₁\n (Type.Alternatives (Map.toList extra₁) remainingAlternatives₁)\n\n return Type.Union\n { location\n , alternatives =\n Type.Alternatives alternativeTypes remainingAlternatives₁\n }\n\n (_, Monotype.UnsolvedAlternatives p₁) -> do\n instantiateAlternativesL\n p₁\n location₀\n (Type.Alternatives (Map.toList extra₀) remainingAlternatives₀)\n\n return Type.Union\n { location\n , alternatives =\n Type.Alternatives alternativeTypes remainingAlternatives₀\n }\n\n _ -> do\n -- TODO: Improve location\n Exception.throwIO (AlternativesVariableMismatch location₀ remainingAlternatives₀ location₁ remainingAlternatives₁)\n\n (type₀@Type.Scalar{ scalar = scalar₀ }, Type.Scalar{ scalar = scalar₁ })\n | scalar₁ `isScalarSubtypeOf` scalar₀ -> do\n return type₀\n\n (Type.Scalar{ scalar = scalar₀ }, type₁@Type.Scalar{ scalar = scalar₁ })\n | scalar₀ `isScalarSubtypeOf` scalar₁ -> do\n return type₁\n\n (type₀@Type.Scalar{ location, scalar = Monotype.JSON }, type₁) -> do\n isSubtypeOfJSON location type₁\n\n return type₀\n\n (type₀, type₁@Type.Scalar{ location, scalar = Monotype.JSON }) -> do\n isSubtypeOfJSON location type₀\n\n return type₁\n\n (Optional{ location, type_ = type₀ }, Optional{ type_ = type₁ }) -> do\n type_ <- supertypeOf type₀ type₁\n\n return Optional{ location, type_ }\n\n (Optional{ location, type_ = type₀ }, type₁) -> do\n type_ <- supertypeOf type₀ type₁\n\n return Optional{ location, type_ }\n\n (type₀, Optional{ location, type_ = type₁ }) -> do\n type_ <- supertypeOf type₀ type₁\n\n return Optional{ location, type_ }\n\n (type₀, type₁) -> do\n Exception.throwIO (NoSupertype type₀ type₁)\n\n-- | Computes the subtype of the two input types\nsubtypeOf :: Type Location -> Type Location -> Grace (Type Location)\nsubtypeOf a b = do\n context₀ <- get\n\n case (a, b) of\n (type₀@UnsolvedType{ existential = existential₀ }, UnsolvedType { existential = existential₁ }) -> do\n Monad.unless (existential₀ == existential₁) do\n equateTypes existential₀ existential₁\n\n return type₀\n\n (UnsolvedType{ existential }, type_)\n | not (existential `Type.typeFreeIn` type_)\n , elem (Context.UnsolvedType existential) context₀ -> do\n instantiateTypeR type_ existential\n\n return type_\n\n (type_, UnsolvedType{ existential })\n | not (existential `Type.typeFreeIn` type_)\n , elem (Context.UnsolvedType existential) context₀ -> do\n instantiateTypeR type_ existential\n\n return type_\n\n (Forall{ nameLocation, name, type_ = type₀ }, type₁) -> do\n scopedUnsolvedType nameLocation \\unsolved -> do\n subtypeOf (Type.substituteType name 0 unsolved type₀) type₁\n\n (type₀, Forall{ nameLocation, name, type_ = type₁ }) -> do\n scopedUnsolvedType nameLocation \\unsolved -> do\n subtypeOf type₀(Type.substituteType name 0 unsolved type₁)\n\n (VariableType{ location, name = name₀ }, VariableType{ name = name₁ })\n | name₀ == name₁ -> do\n return VariableType{ location, name = name₀ }\n\n (Function{ location, input = input₀, output = output₀ }, Function{ input = input₁, output = output₁ }) -> do\n input <- supertypeOf input₀ input₁\n\n output <- subtypeOf output₀ output₁\n\n return Function{ location, input, output }\n\n (List{ location, type_ = type₀ }, List{ type_ = type₁ }) -> do\n type_ <- subtypeOf type₀ type₁\n\n return List{ location, type_ }\n\n (Record{ location = location₀, fields = fields₀ }, Record{ location = location₁, fields = fields₁ }) -> do\n let Type.Fields fieldTypes₀ remainingFields₀ = fields₀\n let Type.Fields fieldTypes₁ remainingFields₁ = fields₁\n\n let map₀ = Map.fromList fieldTypes₀\n let map₁ = Map.fromList fieldTypes₁\n\n both <- sequence (Map.intersectionWith subtypeOf map₀ map₁)\n\n let extra₀ = Map.difference map₀ map₁\n let extra₁ = Map.difference map₁ map₀\n\n let fieldTypes = Map.toList (both <> extra₀ <> extra₁)\n\n let location\n | null extra₁ = location₀\n | otherwise = location₁\n\n -- TODO: Check if `UnsolvedFields` are solved by now\n case (remainingFields₀, remainingFields₁) of\n _ | remainingFields₀ == remainingFields₁ -> do\n return Record\n { location\n , fields = Type.Fields fieldTypes remainingFields₀\n }\n\n (Monotype.UnsolvedFields p₀, Monotype.UnsolvedFields p₁) -> do\n p₂ <- fresh\n\n context₁ <- get\n\n let p₀First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₀ context₁\n\n Monad.guard (Context.UnsolvedFields p₁ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedFields p₀\n : Context.UnsolvedFields p₂\n : contextBefore\n )\n )\n\n return command\n\n let p₁First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₁ context₁\n\n Monad.guard (Context.UnsolvedFields p₀ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedFields p₁\n : Context.UnsolvedFields p₂\n : contextBefore\n )\n )\n\n return command\n\n case p₀First <|> p₁First of\n Nothing -> do\n Exception.throwIO (MissingOneOfFields [location₀, location₁] p₀ p₁ context₁)\n\n Just command -> do\n command\n\n context₂ <- get\n\n instantiateFieldsR\n location₁\n (Context.solveRecord context₂\n (Type.Fields (Map.toList extra₁)\n (Monotype.UnsolvedFields p₂)\n )\n )\n p₀\n\n context₃ <- get\n\n instantiateFieldsR\n location₀\n (Context.solveRecord context₃\n (Type.Fields (Map.toList extra₀)\n (Monotype.UnsolvedFields p₂)\n )\n )\n p₁\n\n return Type.Record\n { location\n , fields =\n Type.Fields fieldTypes (Monotype.UnsolvedFields p₂)\n }\n\n (Monotype.UnsolvedFields p₀, _) -> do\n instantiateFieldsR\n location₁\n (Type.Fields (Map.toList extra₁) remainingFields₁)\n p₀\n\n return Record\n { location\n , fields = Type.Fields fieldTypes remainingFields₁\n }\n\n (_, Monotype.UnsolvedFields p₁) -> do\n instantiateFieldsR\n location₀\n (Type.Fields (Map.toList extra₀) remainingFields₀)\n p₁\n\n return Record\n { location\n , fields = Type.Fields fieldTypes remainingFields₀\n }\n\n _ -> do\n -- TODO: Improve location\n Exception.throwIO (FieldsVariableMismatch location₀ remainingFields₀ location₁ remainingFields₁)\n\n (type₀@Type.Union{ location = location₀, alternatives = alternatives₀ }, type₁@Type.Union{ location = location₁, alternatives = alternatives₁ }) -> do\n let Type.Alternatives alternativeTypes₀ remainingAlternatives₀ = alternatives₀\n let Type.Alternatives alternativeTypes₁ remainingAlternatives₁ = alternatives₁\n\n let map₀ = Map.fromList alternativeTypes₀\n let map₁ = Map.fromList alternativeTypes₁\n\n both <- sequence (Map.intersectionWith subtypeOf map₀ map₁)\n\n let extra₀ = Map.difference map₀ map₁\n let extra₁ = Map.difference map₁ map₀\n\n let alternativeTypes = Map.toList (both <> extra₀ <> extra₁)\n\n let location = location₀\n\n -- TODO: Check if `UnsolvedAlternatives` are solved by now\n case (remainingAlternatives₀, remainingAlternatives₁) of\n _ | remainingAlternatives₀ == remainingAlternatives₁ -> do\n if Map.null extra₀ && Map.null extra₁\n then do\n return Type.Union\n { location\n , alternatives =\n Type.Alternatives alternativeTypes remainingAlternatives₀\n }\n else do\n Exception.throwIO (NoUnionSubtype type₀ type₁ (Map.keys extra₀) (Map.keys extra₁))\n\n (Monotype.UnsolvedAlternatives p₀, Monotype.UnsolvedAlternatives p₁) -> do\n p₂ <- fresh\n\n context₁ <- get\n\n let p₀First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₀ context₁\n\n Monad.guard (Context.UnsolvedAlternatives p₁ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedAlternatives p₀\n : Context.UnsolvedAlternatives p₂\n : contextBefore\n )\n )\n\n return command\n\n let p₁First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₁ context₁\n\n Monad.guard (Context.UnsolvedAlternatives p₀ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedAlternatives p₁\n : Context.UnsolvedAlternatives p₂\n : contextBefore\n )\n )\n\n return command\n\n case p₀First <|> p₁First of\n Nothing -> do\n Exception.throwIO (MissingOneOfAlternatives [location₀, location₁] p₀ p₁ context₁)\n\n Just command -> do\n command\n\n context₂ <- get\n\n instantiateAlternativesL\n p₀\n location₁\n (Context.solveUnion context₂\n (Type.Alternatives (Map.toList extra₁)\n (Monotype.UnsolvedAlternatives p₂)\n )\n )\n\n context₃ <- get\n\n instantiateAlternativesL\n p₁\n location₀\n (Context.solveUnion context₃\n (Type.Alternatives (Map.toList extra₀)\n (Monotype.UnsolvedAlternatives p₂)\n )\n )\n\n\n return Type.Union\n { location\n , alternatives =\n Type.Alternatives alternativeTypes (Monotype.UnsolvedAlternatives p₂)\n }\n\n (Monotype.UnsolvedAlternatives p₀, _) -> do\n if Map.null extra₀\n then do\n instantiateAlternativesR\n location₁\n (Type.Alternatives (Map.toList extra₁) remainingAlternatives₁)\n p₀\n\n return Type.Union\n { location\n , alternatives =\n Type.Alternatives alternativeTypes remainingAlternatives₁\n }\n else do\n Exception.throwIO (NoUnionSubtype type₀ type₁ (Map.keys extra₀) (Map.keys extra₁))\n\n (_, Monotype.UnsolvedAlternatives p₁) -> do\n if Map.null extra₁\n then do\n instantiateAlternativesR\n location₀\n (Type.Alternatives (Map.toList extra₀) remainingAlternatives₀)\n p₁\n\n return Type.Union\n { location\n , alternatives =\n Type.Alternatives alternativeTypes remainingAlternatives₀\n }\n else do\n Exception.throwIO (NoUnionSubtype type₀ type₁ (Map.keys extra₀) (Map.keys extra₁))\n\n _ -> do\n -- TODO: Improve location\n Exception.throwIO (AlternativesVariableMismatch location₀ remainingAlternatives₀ location₁ remainingAlternatives₁)\n\n (type₀@Type.Scalar{ scalar = scalar₀ }, Type.Scalar{ scalar = scalar₁ })\n | scalar₀ `isScalarSubtypeOf` scalar₁ -> do\n return type₀\n\n (Type.Scalar{ scalar = scalar₀ }, type₁@Type.Scalar{ scalar = scalar₁ })\n | scalar₁ `isScalarSubtypeOf` scalar₀ -> do\n return type₁\n\n (type₀, Type.Scalar{ location, scalar = Monotype.JSON }) -> do\n isSubtypeOfJSON location type₀\n\n return type₀\n\n (Type.Scalar{ location, scalar = Monotype.JSON }, type₁) -> do\n isSubtypeOfJSON location type₁\n\n return type₁\n\n (Optional{ location, type_ = type₀ }, Optional{ type_ = type₁ }) -> do\n type_ <- subtypeOf type₀ type₁\n\n return Optional{ location, type_ }\n\n (Optional{ type_ = type₀ }, type₁) -> do\n subtypeOf type₀ type₁\n\n (type₀, Optional{ type_ = type₁ }) -> do\n subtypeOf type₀ type₁\n\n (type₀, type₁) -> do\n Exception.throwIO (NoSubtype type₀ type₁)\n\n-- | @subtype sub super@ checks that @sub@ is a subtype of @super@\nsubtype :: Type Location -> Type Location -> Grace ()\nsubtype subType₀ superType₀ = do\n context₀ <- get\n\n case (subType₀, superType₀) of\n (Type.VariableType{ name = subName }, Type.VariableType{ name = superName })\n | subName == superName -> do\n wellFormed context₀ subType₀\n\n (Type.UnsolvedType{ existential = subExistential }, Type.UnsolvedType{ existential = superExistential })\n | subExistential == superExistential\n , Context.UnsolvedType subExistential `elem` context₀ -> do\n return ()\n\n (Type.UnsolvedType{ existential = subExistential }, _)\n -- The @not (subExistential `Type.typeFreeIn` superType₀)@ is the\n -- \"occurs check\" which prevents a type variable from being defined\n -- in terms of itself (i.e. a type should not \"occur\" within\n -- itself).\n --\n -- Later on you'll see matching \"occurs checks\" for record types\n -- and union types so that Fields variables and Alternatives\n -- variables cannot refer to the record or union that they belong\n -- to, respectively.\n | not (subExistential `Type.typeFreeIn` superType₀)\n , elem (Context.UnsolvedType subExistential) context₀ -> do\n instantiateTypeL subExistential superType₀\n\n (_, Type.UnsolvedType{ existential = superExistential })\n | not (superExistential `Type.typeFreeIn` subType₀)\n , elem (Context.UnsolvedType superExistential) context₀ -> do\n instantiateTypeR subType₀ superExistential\n\n (Type.Function{ input = subInput, output = subOutput }, Type.Function{ input = superInput, output = superOutput }) -> do\n subtype superInput subInput\n\n -- CAREFULLY NOTE: Pay really close attention to how we need to use\n -- `Context.solveType` any time we do something that either updates\n -- the context or potentially updates the context (like the above\n -- `subtype` command). If you forget to do this then you will get\n -- bugs due to unsolved variables not getting solved correctly.\n --\n -- A much more reliable way to fix this problem would simply be to\n -- have every function (like `subtype`, `instantiateL`, …)\n -- apply `solveType` to its inputs. For example, this very\n -- `subtype` function could begin by doing:\n --\n -- context <- get\n -- let subType₀' = Context.solveType context subType₀\n -- let superType₀' = Context.solveType context superType₀\n --\n -- … and then use subType₀' and superType₀' for downstream steps.\n -- If we did that at the beginning of each function then everything\n -- would \"just work\".\n --\n -- However, this would be more inefficient because we'd calling\n -- `solveType` wastefully over and over with the exact same context\n -- in many cases. So, the tradeoff here is that we get improved\n -- performance if we're willing to remember to call `solveType` in\n -- the right places.\n _Θ <- get\n\n subtype (Context.solveType _Θ subOutput) (Context.solveType _Θ superOutput)\n\n (_, Type.Forall{ name, domain, type_ }) -> do\n scoped (Context.Variable domain name) do\n subtype subType₀ type_\n\n (Type.Forall{ nameLocation, name, domain = Domain.Type, type_ }, _) -> do\n scopedUnsolvedType nameLocation \\unsolved -> do\n subtype (Type.substituteType name 0 unsolved type_) superType₀\n\n (Type.Forall{ name, domain = Domain.Fields, type_ }, _) -> do\n scopedUnsolvedFields \\unsolved -> do\n subtype (Type.substituteFields name 0 unsolved type_) superType₀\n\n (Type.Forall{ name, domain = Domain.Alternatives, type_ }, _) -> do\n scopedUnsolvedAlternatives \\unsolved -> do\n subtype (Type.substituteAlternatives name 0 unsolved type_) superType₀\n\n (Type.Scalar{ scalar = subScalar }, Type.Scalar{ scalar = superScalar })\n | subScalar == superScalar -> do\n return ()\n\n (Type.Optional{ type_ = subType₁ }, Type.Optional{ type_ = superType₁ }) -> do\n subtype subType₁ superType₁\n\n (Type.List{ type_ = subType₁ }, Type.List{ type_ = superType₁ }) -> do\n subtype subType₁ superType₁\n\n (Type.Scalar{ }, Type.Scalar{ scalar = Monotype.JSON }) -> do\n return ()\n\n (Type.List{ type_ = subType₁ }, Type.Scalar{ scalar = Monotype.JSON }) -> do\n subtype subType₁ superType₀\n\n (Type.Optional{ type_ = subType₁ }, Type.Scalar{ scalar = Monotype.JSON }) -> do\n subtype subType₁ superType₀\n\n (Type.Record{ fields = Type.Fields fieldTypes Monotype.EmptyFields }, Type.Scalar{ scalar = Monotype.JSON }) -> do\n for_ fieldTypes \\(_, type_) -> do\n context <- get\n\n subtype type_ (Context.solveType context superType₀)\n\n (Type.Record{ fields = Type.Fields fieldTypes (Monotype.UnsolvedFields existential) }, Type.Scalar{ scalar = Monotype.JSON }) -> do\n instantiateFieldsL existential (Type.location superType₀) (Type.Fields [] Monotype.EmptyFields)\n\n for_ fieldTypes \\(_, type_) -> do\n context <- get\n\n subtype type_ (Context.solveType context superType₀)\n\n (Type.Record{ fields = Type.Fields subFieldTypesList subRemainingFields }, Type.Record{ fields = Type.Fields superFieldTypesList superRemainingFields }) -> do\n let subFieldTypes = Map.fromList subFieldTypesList\n let superFieldTypes = Map.fromList superFieldTypesList\n\n let subExtraFieldTypes = Map.difference subFieldTypes superFieldTypes\n let superExtraFieldTypes = Map.difference superFieldTypes subFieldTypes\n\n -- All fields in the record subtype must be subtypes of any\n -- matching fields in the record supertype\n let subtypeField subType₁ superType₁ = do\n context <- get\n\n subtype\n (Context.solveType context subType₁)\n (Context.solveType context superType₁)\n\n sequence_ (Map.intersectionWith subtypeField subFieldTypes superFieldTypes)\n\n let getRequiredFields = do\n m <- traverse isFieldRequired superExtraFieldTypes\n\n return (Map.keys (Map.filter id m))\n\n -- Here is where we handle extra fields that were only present in\n -- the subtype or supertype. They still might be okay if one or\n -- both record types has an unsolved fields variable or if extra\n -- fields in the supertype are `Optional`\n case (subRemainingFields, superRemainingFields) of\n _ | subRemainingFields == superRemainingFields -> do\n superRequiredFields <- getRequiredFields\n\n Monad.unless (null superRequiredFields) do\n Exception.throwIO (RecordTypeMismatch subType₀ superType₀ superRequiredFields)\n\n -- Both records type have unsolved Fields variables. Great!\n -- This is the most flexible case, since we can replace these\n -- unsolved variables with whatever fields we want to make the\n -- record types line up.\n --\n -- However, it's not as simple as setting each Fields variable\n -- to the extra fields from the opposing record type. For\n -- example, if the two record types we're comparing are:\n --\n -- > { x: Bool, p₀ } <: { y: Text, p₁ }\n --\n -- … then it's not correct to say:\n --\n -- > p₀ = y: Text\n -- > p₁ = x: Bool\n --\n -- … because that is not the most general solution for @p₀@ and\n -- @p₁@! The actual most general solution is:\n --\n -- p₀ = y: Text, p₂\n -- p₁ = x: Bool, p₂\n --\n -- … where @p₂@ is a fresh Fields type variable representing the\n -- fact that both records could potentially have even more\n -- fields other than @x@ and @y@.\n (Monotype.UnsolvedFields p₀, Monotype.UnsolvedFields p₁) -> do\n p₂ <- fresh\n\n context₁ <- get\n\n -- We have to insert p₂ before both p₀ and p₁ within the\n -- context because the bidirectional type-checking algorithm\n -- requires that the context is ordered and all variables\n -- within the context can only reference prior variables\n -- within the context.\n --\n -- Since @p₀@ and @p₁@ both have to reference @p₂@, then we\n -- need to insert @p₂@ right before @p₀@ or @p₁@, whichever\n -- one comes first\n let p₀First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₀ context₁\n\n Monad.guard (Context.UnsolvedFields p₁ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedFields p₀\n : Context.UnsolvedFields p₂\n : contextBefore\n )\n )\n\n return command\n\n let p₁First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₁ context₁\n\n Monad.guard (Context.UnsolvedFields p₀ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedFields p₁\n : Context.UnsolvedFields p₂\n : contextBefore\n )\n )\n\n return command\n\n case p₀First <|> p₁First of\n Nothing -> do\n Exception.throwIO (MissingOneOfFields [Type.location subType₀, Type.location superType₀] p₀ p₁ context₁)\n\n Just setContext -> do\n setContext\n\n context₂ <- get\n\n -- Now we solve for @p₀@. This is basically saying:\n --\n -- > p₀ = extraFieldsFromRecordB, p₂\n instantiateFieldsL\n p₀\n (Type.location superType₀)\n (Context.solveRecord context₂\n (Type.Fields (Map.toList superExtraFieldTypes)\n (Monotype.UnsolvedFields p₂)\n )\n )\n\n context₃ <- get\n\n -- Similarly, solve for @p₁@. This is basically saying:\n --\n -- > p₁ = extraFieldsFromRecordA, p₂\n instantiateFieldsR\n (Type.location subType₀)\n (Context.solveRecord context₃\n (Type.Fields (Map.toList subExtraFieldTypes)\n (Monotype.UnsolvedFields p₂)\n )\n )\n p₁\n\n -- If only the record subtype has a Fields variable then the\n -- solution is simpler: just set the Fields variable to the\n -- extra fields from the opposing record.\n --\n -- Carefully note that it's okay if the record supertype has\n -- extra required fields. A record with fewer fields can be\n -- a subtype of a record with a greater number of fields.\n (Monotype.UnsolvedFields p₀, _) -> do\n context₁ <- get\n\n instantiateFieldsL\n p₀\n (Type.location superType₀)\n (Context.solveRecord context₁\n (Type.Fields (Map.toList superExtraFieldTypes) superRemainingFields)\n )\n\n -- If only the record supertype has a Fields variable then\n -- things are slightly trickier because we *don't* allow the\n -- record subtype to have extra required fields.\n (_, Monotype.UnsolvedFields p₁) -> do\n requiredFields <- getRequiredFields\n\n Monad.unless (null requiredFields) do\n Exception.throwIO (RecordTypeMismatch subType₀ superType₀ requiredFields)\n\n context₁ <- get\n\n instantiateFieldsR\n (Type.location subType₀)\n (Context.solveRecord context₁\n (Type.Fields (Map.toList subExtraFieldTypes) subRemainingFields)\n )\n p₁\n\n _ | otherwise -> do\n requiredB <- getRequiredFields\n\n Exception.throwIO (RecordTypeMismatch subType₀ superType₀ requiredB)\n\n (_A@Type.Union{ alternatives = Type.Alternatives subAlternativeTypesList subRemainingAlternatives }, _B@Type.Union{ alternatives = Type.Alternatives superAlternativesTypesList superRemainingAlternatives }) -> do\n let subAlternativeTypes = Map.fromList subAlternativeTypesList\n let superAlternativeTypes = Map.fromList superAlternativesTypesList\n\n let subExtraAlternativeTypes =\n Map.difference subAlternativeTypes superAlternativeTypes\n let superExtraAlternativeTypes =\n Map.difference superAlternativeTypes subAlternativeTypes\n\n let subtypeAlternative subtype₁ supertype₁ = do\n context <- get\n\n subtype\n (Context.solveType context subtype₁)\n (Context.solveType context supertype₁)\n\n sequence_ (Map.intersectionWith subtypeAlternative subAlternativeTypes superAlternativeTypes)\n\n case (subRemainingAlternatives, superRemainingAlternatives) of\n _ | subRemainingAlternatives == superRemainingAlternatives && Map.null subExtraAlternativeTypes -> do\n return ()\n\n (Monotype.UnsolvedAlternatives p₀, Monotype.UnsolvedAlternatives p₁) -> do\n p₂ <- fresh\n\n context₁ <- get\n\n let p₀First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₀ context₁\n\n Monad.guard (Context.UnsolvedAlternatives p₁ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedAlternatives p₀\n : Context.UnsolvedAlternatives p₂\n : contextBefore\n )\n )\n\n return command\n\n let p₁First = do\n (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₁ context₁\n\n Monad.guard (Context.UnsolvedAlternatives p₀ `elem` contextAfter)\n\n let command =\n set ( contextAfter\n <> ( Context.UnsolvedAlternatives p₁\n : Context.UnsolvedAlternatives p₂\n : contextBefore\n )\n )\n\n return command\n\n case p₀First <|> p₁First of\n Nothing -> do\n Exception.throwIO (MissingOneOfAlternatives [Type.location subType₀, Type.location superType₀] p₀ p₁ context₁)\n\n Just command -> do\n command\n\n context₂ <- get\n\n instantiateAlternativesL\n p₀\n (Type.location superType₀)\n (Context.solveUnion context₂\n (Type.Alternatives (Map.toList superExtraAlternativeTypes)\n (Monotype.UnsolvedAlternatives p₂)\n )\n )\n\n context₃ <- get\n\n instantiateAlternativesR\n (Type.location subType₀)\n (Context.solveUnion context₃\n (Type.Alternatives (Map.toList subExtraAlternativeTypes)\n (Monotype.UnsolvedAlternatives p₂)\n )\n )\n p₁\n\n (Monotype.UnsolvedAlternatives p₀, _)\n | Map.null subExtraAlternativeTypes -> do\n context₁ <- get\n\n instantiateAlternativesL\n p₀\n (Type.location superType₀)\n (Context.solveUnion context₁\n (Type.Alternatives (Map.toList superExtraAlternativeTypes)\n superRemainingAlternatives\n )\n )\n\n (_, Monotype.UnsolvedAlternatives p₁) -> do\n context₁ <- get\n\n instantiateAlternativesR\n (Type.location subType₀)\n (Context.solveUnion context₁\n (Type.Alternatives (Map.toList subExtraAlternativeTypes)\n subRemainingAlternatives\n )\n )\n p₁\n\n _ | otherwise -> do\n Exception.throwIO (UnionTypeMismatch subType₀ superType₀ (Map.keys subExtraAlternativeTypes))\n\n -- Unfortunately, we need to have this wildcard match at the end,\n -- otherwise we'd have to specify a number of cases that is quadratic\n -- in the number of `Type` constructors. That in turn means that you\n -- can easily forget to add cases like:\n --\n -- (Type.List _A, Type.List _B) -> do\n -- subtype _A _B\n --\n -- … because the exhaustivity checker won't warn you if you forget to\n -- add that case.\n --\n -- The way I remember to do this is that when I add new complex types I\n -- grep the codebase for all occurrences of an existing complex type\n -- (like `List`), and then one of the occurrences will be here in this\n -- `subtype` function and then I'll remember to add a case for my new\n -- complex type here.\n (_A, _B) -> do\n Exception.throwIO (NotSubtype _A _B)\n\n{-| This corresponds to the judgment:\n\n > Γ ⊢ α̂ :≦ A ⊣ Δ\n\n … which updates the context Γ to produce the new context Δ, by instantiating\n α̂ such that α̂ <: A.\n\n The @instantiate*@ family of functions should really be called @solve*@\n because their job is to solve an unsolved variable within the context.\n However, for consistency with the paper we still name them @instantiate*@.\n-}\ninstantiateTypeL :: Existential Monotype -> Type Location -> Grace ()\ninstantiateTypeL a _A₀ = do\n _Γ₀ <- get\n\n (_Γ', _Γ) <- Context.splitOnUnsolvedType a _Γ₀ `orDie` MissingVariable a _Γ₀\n\n let instLSolve τ = do\n wellFormed _Γ _A₀\n\n set (_Γ' <> (Context.SolvedType a τ : _Γ))\n\n case _A₀ of\n -- InstLReach\n Type.UnsolvedType{..}\n | Just (_Γ', _ΓM) <- Context.splitOnUnsolvedType existential _Γ' -> do\n set (_Γ' <> (Context.SolvedType existential (Monotype.UnsolvedType a) : _ΓM) <> (Context.UnsolvedType a : _Γ))\n\n -- InstLSolve\n Type.UnsolvedType{..} -> do\n instLSolve (Monotype.UnsolvedType existential)\n Type.VariableType{..} -> do\n instLSolve (Monotype.VariableType name)\n Type.Scalar{..} -> do\n instLSolve (Monotype.Scalar scalar)\n\n -- InstLArr\n Type.Function{..} -> do\n a₁ <- fresh\n a₂ <- fresh\n\n set (_Γ' <> (Context.SolvedType a (Monotype.Function (Monotype.UnsolvedType a₁) (Monotype.UnsolvedType a₂)) : Context.UnsolvedType a₁ : Context.UnsolvedType a₂ : _Γ))\n\n instantiateTypeR input a₁\n\n _Θ <- get\n\n instantiateTypeL a₂ (Context.solveType _Θ output)\n\n -- InstLAllR\n Type.Forall{..} -> do\n scoped (Context.Variable domain name) do\n instantiateTypeL a type_\n\n -- This case is the first example of a general pattern we have to\n -- follow when solving unsolved variables.\n --\n -- Typically when you solve an unsolved variable (e.g. `a`) to some\n -- type (e.g. `A`), you cannot just directly solve the variable as:\n --\n -- a = A\n --\n -- … because unsolved variables can only be solved to `Monotype`s, but\n -- `A` is typically a `Type`.\n --\n -- So, instead, what you do is you solve the variable one layer at a\n -- time. For example, if you try to solve `a` to (the `Type`)\n -- `Optional (List Bool)`, you will actually get three solved variables\n -- added to the context:\n --\n -- a = Optional b\n -- b = List c\n -- c = Bool\n --\n -- In other words, each time you solve one layer of a complex type, you\n -- need to create a fresh unsolved variable for each inner type and\n -- solve each inner unsolved variable.\n --\n -- This may seem really indirect and tedious, but if you try to skip\n -- this one-layer-at-a-time solving process then you will likely get\n -- bugs due to solved variables referring to each other out of order.\n --\n -- This wasn't obvious to me from reading the original paper since they\n -- didn't really cover how to type-check complex types other than\n -- function types.\n Type.Optional{..} -> do\n -- To solve `a` against `Optional _A` we create a fresh unsolved\n -- variable named `a₁`, …\n a₁ <- fresh\n\n -- … solve `a` to `Optional a₁`, taking care that `a₁` comes before\n -- `a` within the context, (since `a` refers to `a₁`) …\n set (_Γ' <> (Context.SolvedType a (Monotype.Optional (Monotype.UnsolvedType a₁)) : Context.UnsolvedType a₁ : _Γ))\n\n -- … and then solve `a₁` against _A`\n instantiateTypeL a₁ type_\n\n -- We solve an unsolved variable against `List` using the same\n -- principles described above for solving `Optional`\n Type.List{..} -> do\n a₁ <- fresh\n\n set (_Γ' <> (Context.SolvedType a (Monotype.List (Monotype.UnsolvedType a₁)) : Context.UnsolvedType a₁ : _Γ))\n\n instantiateTypeL a₁ type_\n\n Type.Record{ fields = Type.Fields fieldTypes remainingFields } -> do\n p <- fresh\n\n let process (field, type_) = do\n existential <- fresh\n\n let monotype = Monotype.UnsolvedType existential\n\n let entry = Context.UnsolvedType existential\n\n let instantiation = do\n _Θ <- get\n\n instantiateTypeL existential (Context.solveType _Θ type_)\n\n return ((field, monotype), entry, instantiation)\n\n results <- traverse process fieldTypes\n\n let (fieldMonotypes, entries, instantiations) = unzip3 results\n\n let recordMonotype =\n Monotype.Record\n (Monotype.Fields fieldMonotypes (Monotype.UnsolvedFields p))\n\n set (_Γ' <> (Context.SolvedType a recordMonotype : Context.UnsolvedFields p : (entries <> _Γ)))\n\n instantiateFieldsL p (Type.location _A₀) (Type.Fields [] remainingFields)\n\n sequence_ instantiations\n\n Type.Union{ alternatives = Type.Alternatives alternativeTypes remainingAlternatives } -> do\n p <- fresh\n\n let process (alternative, type_) = do\n existential <- fresh\n\n let monotype = Monotype.UnsolvedType existential\n\n let entry = Context.UnsolvedType existential\n\n let instantiation = do\n _Θ <- get\n\n instantiateTypeL existential (Context.solveType _Θ type_)\n\n return ((alternative, monotype), entry, instantiation)\n\n results <- traverse process alternativeTypes\n\n let (alternativeMonotypes, entries, instantiations) = unzip3 results\n\n let unionMonotype =\n Monotype.Union\n (Monotype.Alternatives alternativeMonotypes (Monotype.UnsolvedAlternatives p))\n\n set (_Γ' <> (Context.SolvedType a unionMonotype : Context.UnsolvedAlternatives p : (entries <> _Γ)))\n\n instantiateAlternativesL p (Type.location _A₀) (Type.Alternatives [] remainingAlternatives)\n\n sequence_ instantiations\n\n{-| This corresponds to the judgment:\n\n > Γ ⊢ A ≦: α̂ ⊣ Δ\n\n … which updates the context Γ to produce the new context Δ, by instantiating\n α̂ such that A :< α̂.\n-}\ninstantiateTypeR :: Type Location -> Existential Monotype -> Grace ()\ninstantiateTypeR _A₀ a = do\n _Γ₀ <- get\n\n (_Γ', _Γ) <- Context.splitOnUnsolvedType a _Γ₀ `orDie` MissingVariable a _Γ₀\n\n let instRSolve τ = do\n wellFormed _Γ _A₀\n\n set (_Γ' <> (Context.SolvedType a τ : _Γ))\n\n case _A₀ of\n -- InstRReach\n Type.UnsolvedType{..}\n | Just (_Γ', _ΓM) <- Context.splitOnUnsolvedType existential _Γ' -> do\n set (_Γ' <> (Context.SolvedType existential (Monotype.UnsolvedType a) : _ΓM) <> (Context.UnsolvedType a : _Γ))\n\n -- InstRSolve\n Type.UnsolvedType{..} -> do\n instRSolve (Monotype.UnsolvedType existential)\n Type.VariableType{..} -> do\n instRSolve (Monotype.VariableType name)\n Type.Scalar{..} -> do\n instRSolve (Monotype.Scalar scalar)\n\n -- InstRArr\n Type.Function{..} -> do\n a₁ <- fresh\n a₂ <- fresh\n\n set (_Γ' <> (Context.SolvedType a (Monotype.Function (Monotype.UnsolvedType a₁) (Monotype.UnsolvedType a₂)) : Context.UnsolvedType a₁ : Context.UnsolvedType a₂ : _Γ))\n\n instantiateTypeL a₁ input\n\n _Θ <- get\n\n instantiateTypeR (Context.solveType _Θ output) a₂\n\n -- InstRAllL\n Type.Forall{ domain = Domain.Type, .. } -> do\n scopedUnsolvedType nameLocation \\b -> do\n instantiateTypeR (Type.substituteType name 0 b type_) a\n Type.Forall{ domain = Domain.Fields, .. } -> do\n scopedUnsolvedFields \\b -> do\n instantiateTypeR (Type.substituteFields name 0 b type_) a\n Type.Forall{ domain = Domain.Alternatives, .. } -> do\n scopedUnsolvedAlternatives \\b -> do\n instantiateTypeR (Type.substituteAlternatives name 0 b type_) a\n\n Type.Optional{..} -> do\n a₁ <- fresh\n\n set (_Γ' <> (Context.SolvedType a (Monotype.Optional (Monotype.UnsolvedType a₁)) : Context.UnsolvedType a₁ : _Γ))\n\n instantiateTypeR type_ a₁\n\n Type.List{..} -> do\n a₁ <- fresh\n\n set (_Γ' <> (Context.SolvedType a (Monotype.List (Monotype.UnsolvedType a₁)) : Context.UnsolvedType a₁ : _Γ))\n\n instantiateTypeR type_ a₁\n\n Type.Record{ fields = Type.Fields fieldTypes remainingFields } -> do\n p <- fresh\n\n let process (field, type_) = do\n existential <- fresh\n\n let monotype = Monotype.UnsolvedType existential\n\n let entry = Context.UnsolvedType existential\n\n let instantiation = do\n _Θ <- get\n\n instantiateTypeR (Context.solveType _Θ type_) existential\n\n return ((field, monotype), entry, instantiation)\n\n results <- traverse process fieldTypes\n\n let (fieldMonotypes, entries, instantiations) = unzip3 results\n\n let recordMonotype =\n Monotype.Record\n (Monotype.Fields fieldMonotypes (Monotype.UnsolvedFields p))\n\n set (_Γ' <> (Context.SolvedType a recordMonotype : Context.UnsolvedFields p : (entries <> _Γ)))\n\n instantiateFieldsR (Type.location _A₀) (Type.Fields [] remainingFields) p\n\n sequence_ instantiations\n\n Type.Union{ alternatives = Type.Alternatives alternativeTypes remainingAlternatives } -> do\n p <- fresh\n\n let process (alternative, type_) = do\n existential <- fresh\n\n let monotype = Monotype.UnsolvedType existential\n\n let entry = Context.UnsolvedType existential\n\n let instantiation = do\n _Θ <- get\n\n instantiateTypeR (Context.solveType _Θ type_) existential\n\n return ((alternative, monotype), entry, instantiation)\n\n results <- traverse process alternativeTypes\n\n let (alternativeMonotypes, entries, instantiations) = unzip3 results\n\n let unionMonotype =\n Monotype.Union\n (Monotype.Alternatives alternativeMonotypes (Monotype.UnsolvedAlternatives p))\n\n set (_Γ' <> (Context.SolvedType a unionMonotype : Context.UnsolvedAlternatives p : (entries <> _Γ)))\n\n instantiateAlternativesR (Type.location _A₀) (Type.Alternatives [] remainingAlternatives) p\n\n sequence_ instantiations\n\n{- The following `equateFields` / `instantiateFieldsL` / `instantiateFieldsR`,\n `equateAlternatives` / `instantiateAlternativesL` /\n `instantiateAlternativesR` judgments are not present in the bidirectional\n type-checking paper. These were added in order to support row polymorphism\n and variant polymorphism, by following the same general type-checking\n principles as the original paper.\n\n If you understand how the `instantiateTypeL` and `instantiateTypeR` functions\n work, then you will probably understand how these functions work because they\n follow the same rules:\n\n * Always make sure that solved variables only reference variables earlier\n within the context\n\n * Solve for unsolved variables one layer at a time\n\n Note that the implementation and the user-facing terminology use the term\n fields/alternatives instead of rows/variants, respectively.\n-}\n\nequateTypes\n :: Existential Monotype -> Existential Monotype -> Grace ()\nequateTypes existential₀ existential₁ = do\n _Γ₀ <- get\n\n let existential₀First = do\n (_Γ', _Γ) <- Context.splitOnUnsolvedType existential₁ _Γ₀\n\n Monad.guard (Context.UnsolvedType existential₀ `elem` _Γ)\n\n return (set (_Γ' <> (Context.SolvedType existential₁ (Monotype.UnsolvedType existential₀) : _Γ)))\n\n let existential₁First = do\n (_Γ', _Γ) <- Context.splitOnUnsolvedType existential₀ _Γ₀\n\n Monad.guard (Context.UnsolvedType existential₁ `elem` _Γ)\n\n return (set (_Γ' <> (Context.SolvedType existential₀ (Monotype.UnsolvedType existential₁) : _Γ)))\n\n case existential₀First <|> existential₁First of\n Nothing -> do\n Exception.throwIO (MissingOneOfTypes [] existential₀ existential₁ _Γ₀)\n\n Just setContext -> do\n setContext\n\nequateFields\n :: Existential Monotype.Record -> Existential Monotype.Record -> Grace ()\nequateFields p₀ p₁ = do\n _Γ₀ <- get\n\n let p₀First = do\n (_Γ', _Γ) <- Context.splitOnUnsolvedFields p₁ _Γ₀\n\n Monad.guard (Context.UnsolvedFields p₀ `elem` _Γ)\n\n return (set (_Γ' <> (Context.SolvedFields p₁ (Monotype.Fields [] (Monotype.UnsolvedFields p₀)) : _Γ)))\n\n let p₁First = do\n (_Γ', _Γ) <- Context.splitOnUnsolvedFields p₀ _Γ₀\n\n Monad.guard (Context.UnsolvedFields p₁ `elem` _Γ)\n\n return (set (_Γ' <> (Context.SolvedFields p₀ (Monotype.Fields [] (Monotype.UnsolvedFields p₁)) : _Γ)))\n\n case p₀First <|> p₁First of\n Nothing -> do\n Exception.throwIO (MissingOneOfFields [] p₀ p₁ _Γ₀)\n\n Just setContext -> do\n setContext\n\ninstantiateFieldsL\n :: Existential Monotype.Record\n -> Location\n -> Type.Record Location\n -> Grace ()\ninstantiateFieldsL p₀ location fields@(Type.Fields kAs rest) = do\n when (p₀ `Type.fieldsFreeIn` Type.Record{..}) do\n Exception.throwIO (NotFieldsSubtype location p₀ fields)\n\n let process (k, _A) = do\n b <- fresh\n\n return (k, _A, b)\n\n kAbs <- traverse process kAs\n\n let bs = map (\\(_, _, b) -> Context.UnsolvedType b ) kAbs\n let kbs = map (\\(k, _, b) -> (k, Monotype.UnsolvedType b)) kAbs\n\n _Γ₀ <- get\n\n (_Γ', _Γ) <- Context.splitOnUnsolvedFields p₀ _Γ₀ `orDie` MissingAllFields p₀ _Γ₀\n\n case rest of\n Monotype.UnsolvedFields p₁ -> do\n p₂ <- fresh\n\n set (_Γ' <> (Context.SolvedFields p₀ (Monotype.Fields kbs (Monotype.UnsolvedFields p₂)) : Context.UnsolvedFields p₂ : bs <> _Γ))\n\n equateFields p₁ p₂\n\n _ -> do\n wellFormed (bs <> _Γ)\n Type.Record{ fields = Type.Fields [] rest, .. }\n\n set (_Γ' <> (Context.SolvedFields p₀ (Monotype.Fields kbs rest) : bs <> _Γ))\n\n let instantiate (_, _A, b) = do\n _Θ <- get\n\n instantiateTypeL b (Context.solveType _Θ _A)\n\n traverse_ instantiate kAbs\n\ninstantiateFieldsR\n :: Location\n -> Type.Record Location\n -> Existential Monotype.Record\n -> Grace ()\ninstantiateFieldsR location fields@(Type.Fields kAs rest) p₀ = do\n when (p₀ `Type.fieldsFreeIn` Type.Record{..}) do\n Exception.throwIO (NotFieldsSubtype location p₀ fields)\n\n let process (k, _A) = do\n b <- fresh\n\n return (k, _A, b)\n\n kAbs <- traverse process kAs\n\n let bs = map (\\(_, _, b) -> Context.UnsolvedType b ) kAbs\n let kbs = map (\\(k, _, b) -> (k, Monotype.UnsolvedType b)) kAbs\n\n _Γ₀ <- get\n\n (_Γ', _Γ) <- Context.splitOnUnsolvedFields p₀ _Γ₀ `orDie` MissingAllFields p₀ _Γ₀\n\n case rest of\n Monotype.UnsolvedFields p₁ -> do\n p₂ <- fresh\n\n set (_Γ' <> (Context.SolvedFields p₀ (Monotype.Fields kbs (Monotype.UnsolvedFields p₂)) : Context.UnsolvedFields p₂ : bs <> _Γ))\n\n equateFields p₁ p₂\n\n _ -> do\n wellFormed (bs <> _Γ)\n Type.Record{ fields = Type.Fields [] rest, .. }\n\n set (_Γ' <> (Context.SolvedFields p₀ (Monotype.Fields kbs rest) : bs <> _Γ))\n\n let instantiate (_, _A, b) = do\n _Θ <- get\n\n instantiateTypeR (Context.solveType _Θ _A) b\n\n traverse_ instantiate kAbs\n\nequateAlternatives\n :: Existential Monotype.Union-> Existential Monotype.Union -> Grace ()\nequateAlternatives p₀ p₁ = do\n _Γ₀ <- get\n\n let p₀First = do\n (_Γ', _Γ) <- Context.splitOnUnsolvedAlternatives p₁ _Γ₀\n\n Monad.guard (Context.UnsolvedAlternatives p₀ `elem` _Γ)\n\n return (set (_Γ' <> (Context.SolvedAlternatives p₁ (Monotype.Alternatives [] (Monotype.UnsolvedAlternatives p₀)) : _Γ)))\n\n let p₁First = do\n (_Γ', _Γ) <- Context.splitOnUnsolvedAlternatives p₀ _Γ₀\n\n Monad.guard (Context.UnsolvedAlternatives p₁ `elem` _Γ)\n\n return (set (_Γ' <> (Context.SolvedAlternatives p₀ (Monotype.Alternatives [] (Monotype.UnsolvedAlternatives p₁)) : _Γ)))\n\n case p₀First <|> p₁First of\n Nothing -> do\n Exception.throwIO (MissingOneOfAlternatives [] p₀ p₁ _Γ₀)\n\n Just setContext -> do\n setContext\n\ninstantiateAlternativesL\n :: Existential Monotype.Union\n -> Location\n -> Type.Union Location\n -> Grace ()\ninstantiateAlternativesL p₀ location alternatives@(Type.Alternatives kAs rest) = do\n when (p₀ `Type.alternativesFreeIn` Type.Union{..}) do\n Exception.throwIO (NotAlternativesSubtype location p₀ alternatives)\n\n let process (k, _A) = do\n b <- fresh\n\n return (k, _A, b)\n\n kAbs <- traverse process kAs\n\n let bs = map (\\(_, _, b) -> Context.UnsolvedType b ) kAbs\n let kbs = map (\\(k, _, b) -> (k, Monotype.UnsolvedType b)) kAbs\n\n _Γ₀ <- get\n\n (_Γ', _Γ) <- Context.splitOnUnsolvedAlternatives p₀ _Γ₀ `orDie` MissingAllAlternatives p₀ _Γ₀\n\n case rest of\n Monotype.UnsolvedAlternatives p₁ -> do\n p₂ <- fresh\n\n set (_Γ' <> (Context.SolvedAlternatives p₀ (Monotype.Alternatives kbs (Monotype.UnsolvedAlternatives p₂)) : Context.UnsolvedAlternatives p₂ : bs <> _Γ))\n\n equateAlternatives p₁ p₂\n\n _ -> do\n wellFormed (bs <> _Γ)\n Type.Union{ alternatives = Type.Alternatives [] rest, .. }\n\n set (_Γ' <> (Context.SolvedAlternatives p₀ (Monotype.Alternatives kbs rest) : bs <> _Γ))\n\n let instantiate (_, _A, b) = do\n _Θ <- get\n\n instantiateTypeL b (Context.solveType _Θ _A)\n\n traverse_ instantiate kAbs\n\ninstantiateAlternativesR\n :: Location\n -> Type.Union Location\n -> Existential Monotype.Union\n -> Grace ()\ninstantiateAlternativesR location alternatives@(Type.Alternatives kAs rest) p₀ = do\n when (p₀ `Type.alternativesFreeIn` Type.Union{..}) do\n Exception.throwIO (NotAlternativesSubtype location p₀ alternatives)\n\n let process (k, _A) = do\n b <- fresh\n\n return (k, _A, b)\n\n kAbs <- traverse process kAs\n\n let bs = map (\\(_, _, b) -> Context.UnsolvedType b ) kAbs\n let kbs = map (\\(k, _, b) -> (k, Monotype.UnsolvedType b)) kAbs\n\n _Γ₀ <- get\n\n (_Γ', _Γ) <- Context.splitOnUnsolvedAlternatives p₀ _Γ₀ `orDie` MissingAllAlternatives p₀ _Γ₀\n\n case rest of\n Monotype.UnsolvedAlternatives p₁ -> do\n p₂ <- fresh\n\n set (_Γ' <> (Context.SolvedAlternatives p₀ (Monotype.Alternatives kbs (Monotype.UnsolvedAlternatives p₂)) : Context.UnsolvedAlternatives p₂ : bs <> _Γ))\n\n equateAlternatives p₁ p₂\n\n _ -> do\n wellFormed (bs <> _Γ)\n Type.Union{ alternatives = Type.Alternatives [] rest, .. }\n\n set (_Γ' <> (Context.SolvedAlternatives p₀ (Monotype.Alternatives kbs rest) : bs <> _Γ))\n\n let instantiate (_, _A, b) = do\n _Θ <- get\n\n instantiateTypeR (Context.solveType _Θ _A) b\n\n traverse_ instantiate kAbs\n\nonNameBinding\n :: NameBinding Location Input\n -> Grace ((Text, Type Location), Entry Location, NameBinding Location Void)\nonNameBinding Syntax.NameBinding{ nameLocation, name, annotation = Nothing, assignment = Nothing } = do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n let annotation = Type.UnsolvedType\n { location = nameLocation\n , existential\n }\n\n let fieldType = (name, annotation)\n\n let entry = Context.Annotation name annotation\n\n let newNameBinding = Syntax.NameBinding\n { nameLocation\n , name\n , annotation = Nothing\n , assignment = Nothing\n }\n\n return (fieldType, entry, newNameBinding)\nonNameBinding Syntax.NameBinding{ nameLocation, name, annotation = Just annotation, assignment = Nothing } = do\n let fieldType = (name, annotation)\n\n let entry = Context.Annotation name annotation\n\n let newNameBinding = Syntax.NameBinding\n { nameLocation\n , name\n , annotation = Just annotation\n , assignment = Nothing\n }\n\n return (fieldType, entry, newNameBinding)\nonNameBinding Syntax.NameBinding{ nameLocation, name, annotation = Nothing, assignment = Just assignment } = do\n (annotation₀, newAssignment) <- infer assignment\n\n let annotation₁ = Type.Optional\n { location = Syntax.location assignment\n , type_ = annotation₀\n }\n\n let fieldType = (name, annotation₁)\n\n let entry = Context.Annotation name annotation₀\n\n let newNameBinding = Syntax.NameBinding\n { nameLocation\n , name\n , annotation = Nothing\n , assignment = Just newAssignment\n }\n\n return (fieldType, entry, newNameBinding)\nonNameBinding Syntax.NameBinding{ nameLocation, name, annotation = Just annotation₀, assignment = Just assignment } = do\n let annotation₁ = Type.Optional\n { location = Syntax.location assignment\n , type_ = annotation₀\n }\n\n context <- get\n\n newAssignment <- check assignment (Context.solveType context annotation₀)\n\n let fieldType = (name, annotation₁)\n\n let entry = Context.Annotation name annotation₀\n\n let newNameBinding = Syntax.NameBinding\n { nameLocation\n , name\n , annotation = Just annotation₀\n , assignment = Just newAssignment\n }\n\n return (fieldType, entry, newNameBinding)\n\nonBinding\n :: Binding Location Input\n -> Grace (Type Location, Context Location, Binding Location Void)\nonBinding Syntax.PlainBinding{ plain } = do\n ((_, annotation), entry, newPlain) <- onNameBinding plain\n\n return (annotation, [ entry ], Syntax.PlainBinding{ plain = newPlain })\nonBinding Syntax.RecordBinding{ fieldNamesLocation, fieldNames } = do\n tuples <- traverse onNameBinding fieldNames\n\n let (fieldTypes, entries, newFieldNames) = unzip3 tuples\n\n existential <- fresh\n\n push (Context.UnsolvedFields existential)\n\n let annotation = Type.Record\n { location = fieldNamesLocation\n , fields =\n Type.Fields fieldTypes (Monotype.UnsolvedFields existential)\n }\n\n let newBinding = Syntax.RecordBinding\n { fieldNamesLocation\n , fieldNames = newFieldNames\n }\n\n return (annotation, entries, newBinding)\n\nonDefinition\n :: Definition Location Input\n -> Grace ((Text, Type Location), Definition Location Void)\nonDefinition Syntax.Definition\n { nameLocation\n , name\n , bindings\n , annotation = annotation₀\n , assignment = assignment₀\n } = do\n results <- traverse onBinding bindings\n\n let (inputs, entriess, newBindings) = unzip3 results\n\n annotation₁ <- case annotation₀ of\n Just annotation₁ -> do\n return annotation₁\n\n Nothing -> do\n existential <- fresh\n\n preserve (Context.UnsolvedType existential)\n\n return Type.UnsolvedType\n { location = Syntax.location assignment₀\n , existential\n }\n\n let nil = check assignment₀ annotation₁\n\n assignment₁ <- foldr scoped nil (concat entriess)\n\n context <- get\n\n let newDefinition = Syntax.Definition\n { nameLocation\n , name\n , bindings = newBindings\n , annotation = annotation₀\n , assignment = solveSyntax context assignment₁\n }\n\n let cons input output = Type.Function\n { location = nameLocation\n , input\n , output\n }\n\n let annotation₂ =\n Context.solveType context (foldr cons annotation₁ inputs)\n\n let fieldType = (name, annotation₂)\n\n return (fieldType, newDefinition)\n\n{-| This corresponds to the judgment:\n\n > Γ ⊢ e ⇒ A ⊣ Δ\n\n … which infers the type of e under input context Γ, producing an inferred\n type of A and an updated context Δ.\n-}\ninfer :: Syntax Location Input -> Grace (Type Location, Syntax Location Void)\ninfer e₀ = do\n let input ~> output = Type.Function{ location = Syntax.location e₀, ..}\n\n let var name = Type.VariableType{ location = Syntax.location e₀, name, .. }\n\n case e₀ of\n Syntax.Variable{ location, name } -> do\n _Γ <- get\n\n inferred <- Context.lookup name _Γ `orDie` UnboundVariable location name\n\n return (inferred, Syntax.Variable{ location, name })\n\n Syntax.Lambda{ location, binding, body } -> do\n (input, entries, newBinding) <- onBinding binding\n\n existential <- fresh\n\n preserve (Context.UnsolvedType existential)\n\n let output = Type.UnsolvedType\n { location = Syntax.location body\n , existential\n }\n\n let done = do\n newBody <- check body output\n\n context <- get\n\n let inferred = Type.Function{ location, input, output }\n\n let newLambda = Syntax.Lambda\n { location\n , binding = newBinding\n , body = newBody\n }\n\n -- TODO: Only `solveSyntax` `newBinding`\n return (Context.solveType context inferred, solveSyntax context newLambda)\n\n foldr scoped done entries\n\n Syntax.Application{ location, function, argument } -> do\n (functionType, newFunction) <- infer function\n\n context₀ <- get\n\n (inferred, newArgument) <- inferApplication (Context.solveType context₀ functionType) argument\n\n context₁ <- get\n\n let syntax = Syntax.Application\n { location\n , function = solveSyntax context₁ newFunction\n , argument = newArgument\n }\n\n return (inferred, syntax)\n\n Syntax.Annotation{ annotated = annotated₀, annotation, location } -> do\n context <- get\n\n wellFormed context annotation\n\n annotated₁ <- check annotated₀ annotation\n\n case annotated₁ of\n Syntax.Annotation{ annotated = annotated₂ } -> do\n return (annotation, Syntax.Annotation{ annotated = annotated₂, annotation, location })\n _ -> do\n return (annotation, Syntax.Annotation{ annotated = annotated₁, annotation, location })\n\n Syntax.Let{ location, assignments, body } -> do\n let cons Syntax.Define{ assignmentLocation, definition } action = do\n ((name, annotation), newDefinition) <- onDefinition definition\n\n let entry = Context.Annotation name annotation\n\n let newAssignment = Syntax.Define\n { assignmentLocation\n , definition = newDefinition\n }\n\n scoped entry do\n (newAssignments, newBody) <- action\n\n return (newAssignment : newAssignments, newBody)\n\n cons Syntax.Bind{ assignmentLocation, monad, binding, assignment = value } action = do\n (annotation₀, newEntries, newBinding) <- onBinding binding\n\n (newAssignments, newBody) <- foldr scoped action newEntries\n\n let annotation₁ = case monad of\n IdentityMonad -> annotation₀\n\n ListMonad -> Type.List\n { location = assignmentLocation\n , type_ = annotation₀\n }\n\n OptionalMonad -> Type.Optional\n { location = assignmentLocation\n , type_ = annotation₀\n }\n\n newValue <- check value annotation₁\n\n let newAssignment = Syntax.Bind\n { assignmentLocation\n , monad\n , binding = newBinding\n , assignment = newValue\n }\n\n return (newAssignment : newAssignments, newBody)\n\n b <- fresh\n\n push (Context.UnsolvedType b)\n\n let unsolved = Type.UnsolvedType\n { location = Syntax.location body\n , existential = b\n }\n\n let nil = do\n newBody <- check body unsolved\n\n return ([], newBody)\n\n (newAssignments, newBody) <- foldr cons nil assignments\n\n let listMonad = do\n Syntax.Bind{ assignmentLocation, monad = ListMonad } <- toList assignments\n\n return assignmentLocation\n\n let optionalMonad = do\n Syntax.Bind{ assignmentLocation, monad = OptionalMonad } <- toList assignments\n\n return assignmentLocation\n\n output <- case (listMonad, optionalMonad) of\n (location₀ : _, location₁ : _) -> do\n Exception.throwIO AssignmentMismatch\n { location₀\n , location₁\n }\n\n (_: _, []) -> do\n return Type.List\n { location\n , type_ = unsolved\n }\n\n ([], _ : _) -> do\n return Type.Optional\n { location\n , type_ = unsolved\n }\n\n ([], []) -> do\n return unsolved\n\n let newLet = Syntax.Let\n { location\n , assignments = NonEmpty.fromList newAssignments\n , body = newBody\n }\n\n context <- get\n\n return (Context.solveType context output, solveSyntax context newLet)\n\n Syntax.List{ location, elements = elements₀ } -> do\n case Seq.viewl elements₀ of\n EmptyL -> do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n return (Type.List{ location, type_ = Type.UnsolvedType{..} }, Syntax.List{ location, elements = Seq.empty })\n\n element₀ :< elements -> do\n (elementType₀, _) <- infer element₀\n\n results <- traverse infer elements\n\n let (elementTypes, _) = unzip (toList results)\n\n let cons type₀ type₁ = do\n context <- get\n\n supertypeOf (Context.solveType context type₀) (Context.solveType context type₁)\n\n type_ <- Monad.foldM cons elementType₀ elementTypes\n\n let process element = do\n context <- get\n\n check element (Context.solveType context type_)\n\n newElements <- traverse process (element₀ <| elements)\n\n context <- get\n\n let inferred = Type.List{ location, type_ }\n\n let newList = Syntax.List\n { location\n , elements = fmap (solveSyntax context) newElements\n }\n\n return (inferred, newList)\n\n Syntax.Record{ location, fieldValues } -> do\n result <- traverse onDefinition fieldValues\n\n let (fieldTypes, newFieldValues) = unzip result\n\n let inferred = Type.Record\n { location\n , fields = Type.Fields fieldTypes Monotype.EmptyFields\n }\n\n let newRecord = Syntax.Record\n { location\n , fieldValues = newFieldValues\n }\n\n return (inferred, newRecord)\n\n Syntax.Alternative{ location, name, argument } -> do\n (argumentType, newArgument) <- infer argument\n\n alternatives <- fresh\n\n push (Context.UnsolvedAlternatives alternatives)\n\n let inferred = Type.Union\n { location\n , alternatives = Type.Alternatives\n [(name, argumentType)]\n (Monotype.UnsolvedAlternatives alternatives)\n }\n\n let newAlternative = Syntax.Alternative\n { location\n , name\n , argument = newArgument\n }\n\n return (inferred, newAlternative)\n\n Syntax.Fold{ location, handlers } -> do\n let boolFold = do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n let bool = Type.UnsolvedType{ location, existential }\n\n newHandlers <- check handlers Type.Record\n { location\n , fields = Type.Fields\n [ (\"false\", bool)\n , (\"true\", bool)\n ]\n Monotype.EmptyFields\n }\n\n let type_ = Type.Function\n { location\n , input = Type.Scalar\n { location\n , scalar = Monotype.Bool\n }\n , output = bool\n }\n\n let newFold = Syntax.Fold\n { location\n , handlers = newHandlers\n }\n\n return (type_, newFold)\n\n let naturalFold = do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n let natural = Type.UnsolvedType{ location, existential }\n\n newHandlers <- check handlers Type.Record\n { location\n , fields = Type.Fields\n [ ( \"zero\", natural )\n , ( \"succ\"\n , Type.Function\n { location\n , input = natural\n , output = natural\n }\n )\n ]\n Monotype.EmptyFields\n }\n\n let type_ = Type.Function\n { location\n , input = Type.Scalar\n { location\n , scalar = Monotype.Natural\n }\n , output = natural\n }\n\n let newFold = Syntax.Fold\n { location\n , handlers = newHandlers\n }\n\n return (type_, newFold)\n\n let optionalFold = do\n existential₀ <- fresh\n\n push (Context.UnsolvedType existential₀)\n\n let element = Type.UnsolvedType\n { location\n , existential = existential₀\n }\n\n existential₁ <- fresh\n\n push (Context.UnsolvedType existential₁)\n\n let optional = Type.UnsolvedType\n { location\n , existential = existential₁\n }\n\n newHandlers <- check handlers Type.Record\n { location\n , fields = Type.Fields\n [ ( \"null\", optional )\n , ( \"some\"\n , Type.Function\n { location\n , input = element\n , output = optional\n }\n )\n ]\n Monotype.EmptyFields\n }\n\n let type_ = Type.Function\n { location\n , input = Type.Optional\n { location\n , type_ = element\n }\n , output = optional\n }\n\n let newFold = Syntax.Fold\n { location\n , handlers = newHandlers\n }\n\n return (type_, newFold)\n\n let listFold = do\n existential₀ <- fresh\n\n push (Context.UnsolvedType existential₀)\n\n let element = Type.UnsolvedType\n { location\n , existential = existential₀\n }\n\n existential₁ <- fresh\n\n push (Context.UnsolvedType existential₁)\n\n let list = Type.UnsolvedType\n { location\n , existential = existential₁\n }\n\n newHandlers <- check handlers Type.Record\n { location\n , fields = Type.Fields\n [ ( \"nil\", list )\n , ( \"cons\"\n , Type.Function\n { location\n , input = element\n , output = Type.Function\n { location\n , input = list\n , output = list\n }\n }\n )\n ]\n Monotype.EmptyFields\n }\n\n let type_ = Type.Function\n { location\n , input = Type.List\n { location\n , type_ = element\n }\n , output = list\n }\n\n let newFold = Syntax.Fold\n { location\n , handlers = newHandlers\n }\n\n return (type_, newFold)\n\n let jsonFold = do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n let json = Type.UnsolvedType{ location, existential }\n\n newHandlers <- check handlers Type.Record\n { location\n , fields = Type.Fields\n [ ( \"array\"\n , Type.Function\n { location\n , input = Type.List\n { location\n , type_ = json\n }\n , output = json\n }\n )\n , ( \"bool\"\n , Type.Function\n { location\n , input = Type.Scalar\n { location\n , scalar = Monotype.Bool\n }\n , output = json\n }\n )\n , ( \"integer\"\n , Type.Function\n { location\n , input = Type.Scalar\n { location\n , scalar = Monotype.Integer\n }\n , output = json\n }\n )\n , ( \"natural\"\n , Type.Function\n { location\n , input = Type.Scalar\n { location\n , scalar = Monotype.Natural\n }\n , output = json\n }\n )\n , ( \"null\", json )\n , ( \"object\"\n , Type.Function\n { location\n , input = Type.List\n { location\n , type_ = Type.Record\n { location\n , fields = Type.Fields\n [ ( \"key\"\n , Type.Scalar\n { location\n , scalar = Monotype.Text\n }\n )\n , ( \"value\", json)\n ]\n Monotype.EmptyFields\n }\n }\n , output = json\n }\n )\n , ( \"real\"\n , Type.Function\n { location\n , input = Type.Scalar\n { location\n , scalar = Monotype.Real\n }\n , output = json\n }\n )\n , ( \"string\"\n , Type.Function\n { location\n , input = Type.Scalar\n { location\n , scalar = Monotype.Text\n }\n , output = json\n }\n )\n ]\n Monotype.EmptyFields\n }\n\n let type_ = Type.Function\n { location\n , input = Type.Scalar\n { location\n , scalar = Monotype.JSON\n }\n , output = json\n }\n\n let newFold = Syntax.Fold\n { location\n , handlers = newHandlers\n }\n\n return (type_, newFold)\n\n let fold maybeKeys = do\n keys <- case maybeKeys of\n Just keys -> do\n return keys\n\n Nothing -> do\n context₀ <- get\n\n existential₀ <- fresh\n\n push (Context.UnsolvedFields existential₀)\n\n let unsolvedRecord = Type.Fields\n []\n (Monotype.UnsolvedFields existential₀)\n\n _ <- check handlers Type.Record\n { location\n , fields = unsolvedRecord\n }\n\n context₁ <- get\n\n let Type.Fields keyTypes _ =\n Context.solveRecord context₁ unsolvedRecord\n\n set context₀\n\n return do\n (key, _) <- keyTypes\n\n return key\n\n existential₁ <- fresh\n\n push (Context.UnsolvedType existential₁)\n\n let union = Type.UnsolvedType\n { location\n , existential = existential₁\n }\n\n let process key = do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n let alternativeType = Type.UnsolvedType\n { location\n , existential\n }\n\n let handlerType = Type.Function\n { location\n , input = alternativeType\n , output = union\n }\n\n return ((key, handlerType), (key, alternativeType))\n\n results <- traverse process keys\n\n let (fieldTypes, alternativeTypes) = unzip results\n\n newHandlers <- check handlers Type.Record\n { location\n , fields = Type.Fields\n fieldTypes\n Monotype.EmptyFields\n }\n\n let type_ = Type.Function\n { location\n , input = Type.Union\n { location\n , alternatives = Type.Alternatives\n alternativeTypes\n Monotype.EmptyAlternatives\n }\n , output = union\n }\n\n let newFold = Syntax.Fold\n { location\n , handlers = newHandlers\n }\n\n return (type_, newFold)\n\n case handlers of\n -- Fast path if the handlers argument is a concrete record\n Syntax.Record{ fieldValues } -> do\n let fields = Set.fromList do\n Definition{ name } <- fieldValues\n\n return name\n\n if | Set.null fields -> do\n fold (Just (toList fields))\n | Set.isSubsetOf fields [ \"nil\", \"cons\" ] -> do\n listFold\n | Set.isSubsetOf fields [ \"null\", \"some\" ] -> do\n optionalFold\n | Set.isSubsetOf fields [ \"false\", \"true\" ] -> do\n boolFold\n | Set.isSubsetOf fields [ \"zero\", \"succ\" ] -> do\n naturalFold\n | Set.isSubsetOf fields [ \"array\", \"bool\", \"integer\", \"natural\", \"null\", \"object\", \"real\", \"string\" ] -> do\n jsonFold\n | otherwise -> do\n fold (Just (toList fields))\n\n -- Slow path: guess and check\n _ -> do\n context <- get\n\n listFold `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context\n\n optionalFold `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context\n\n boolFold `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context\n\n naturalFold `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context\n\n jsonFold `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context\n\n fold Nothing\n\n\n Syntax.Project{ location, larger, smaller } -> do\n let processField Syntax.Field{ fieldLocation, field } = do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n return (field, Type.UnsolvedType{ location = fieldLocation, .. })\n\n case smaller of\n Syntax.Single{ single } -> do\n let Syntax.Field{ fieldLocation, field } = single\n\n context <- get\n\n (largerType, newLarger₀) <- infer larger\n\n case largerType of\n Type.Record{ fields = Type.Fields fieldTypes _ }\n | Just type_ <- lookup field fieldTypes -> do\n return (type_, Syntax.Project{ location, larger = newLarger₀, smaller })\n\n _ -> do\n set context\n\n p <- fresh\n\n push (Context.UnsolvedFields p)\n\n fieldType@(_, type_) <- processField single\n\n newLarger₁ <- check larger Type.Record\n { fields =\n Type.Fields [fieldType] (Monotype.UnsolvedFields p)\n , location = fieldLocation\n }\n\n return (type_, Syntax.Project{ larger = newLarger₁, .. })\n\n Syntax.Multiple{ multipleLocation, multiple } -> do\n p <- fresh\n\n push (Context.UnsolvedFields p)\n\n fieldTypes <- traverse processField multiple\n\n newLarger <- check larger Type.Record\n { fields =\n Type.Fields fieldTypes (Monotype.UnsolvedFields p)\n , location = multipleLocation\n }\n\n let type_ = Type.Record\n { fields =\n Type.Fields fieldTypes Monotype.EmptyFields\n , location = multipleLocation\n }\n\n _Γ <- get\n\n return (type_, Syntax.Project{ larger = solveSyntax _Γ newLarger, .. })\n\n Syntax.Index{ } -> do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n let element = Type.UnsolvedType{ location, existential }\n\n let listType = Type.List{ location, type_ = element }\n\n newLarger <- check larger listType\n\n let optional = Type.Optional{ location, type_ = element }\n\n return (optional, Syntax.Project{ location, larger = newLarger, .. })\n Syntax.Slice{ } -> do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n let element = Type.UnsolvedType{ location, existential }\n\n let list = Type.List{ location, type_ = element }\n\n let optional = Type.Optional{ location, type_ = list }\n\n newLarger <- check larger list\n\n return (optional, Syntax.Project{ location, larger = newLarger, .. })\n\n Syntax.If{ location, predicate, ifTrue, ifFalse} -> do\n newPredicate <- check predicate Type.Scalar\n { location\n , scalar = Monotype.Bool\n }\n\n (type₀, _) <- infer ifTrue\n (type₁, _) <- infer ifFalse\n\n context₀ <- get\n\n supertype <- supertypeOf (Context.solveType context₀ type₀) (Context.solveType context₀ type₁)\n\n newIfTrue <- check ifTrue supertype\n\n context₁ <- get\n\n newIfFalse <- check ifFalse (Context.solveType context₁ supertype)\n\n context₂ <- get\n\n let type_ = Context.solveType context₂ supertype\n\n let newIf = Syntax.If\n { location\n , predicate = solveSyntax context₁ newPredicate\n , ifTrue = solveSyntax context₁ newIfTrue\n , ifFalse = solveSyntax context₁ newIfFalse\n }\n\n return (type_, newIf)\n\n Syntax.Text{ chunks = Syntax.Chunks text₀ rest, .. } -> do\n let process (interpolation, text) = do\n newInterpolation <- check interpolation Type.Scalar{ scalar = Monotype.Text, .. }\n\n return (newInterpolation, text)\n\n newRest <- traverse process rest\n\n return (Type.Scalar{ scalar = Monotype.Text, .. }, Syntax.Text{ chunks = Syntax.Chunks text₀ newRest, .. })\n\n Syntax.Prompt{ location, import_, arguments, schema } -> do\n let argumentsType = fmap (\\_ -> location) (expected @Prompt)\n\n newArguments <- check arguments argumentsType\n\n newSchema <- case schema of\n Just t -> do\n return t\n\n Nothing -> do\n existential <- fresh\n\n preserve (Context.UnsolvedType existential)\n\n return Type.UnsolvedType{ location, existential }\n\n context <- get\n\n let newPrompt = Syntax.Prompt\n { location\n , import_\n , arguments = solveSyntax context newArguments\n , schema = Just newSchema\n }\n\n return (newSchema, newPrompt)\n\n Syntax.HTTP{ location, import_, arguments, schema } -> do\n let argumentsType = fmap (\\_ -> location) (expected @HTTP)\n\n newArguments <- check arguments argumentsType\n\n newSchema <- case schema of\n Just output -> do\n return output\n\n Nothing -> do\n existential <- fresh\n\n preserve (Context.UnsolvedType existential)\n\n return Type.UnsolvedType{ location, existential }\n\n context <- get\n\n let newHTTP = Syntax.HTTP\n { location\n , import_\n , arguments = solveSyntax context newArguments\n , schema = Just newSchema\n }\n\n return (newSchema, newHTTP)\n\n Syntax.Read{ location, import_, arguments, schema } -> do\n let argumentsType = fmap (\\_ -> location) (expected @Text)\n\n newArguments <- check arguments argumentsType\n\n newSchema <- case schema of\n Just output -> do\n return output\n\n Nothing -> do\n existential <- fresh\n\n preserve (Context.UnsolvedType existential)\n\n return Type.UnsolvedType{ location, existential }\n\n context <- get\n\n let newRead = Syntax.Read\n { location\n , import_\n , arguments = solveSyntax context newArguments\n , schema = Just newSchema\n }\n\n return (newSchema, newRead)\n\n Syntax.GitHub{ location, import_, arguments, schema } -> do\n let argumentsType = fmap (\\_ -> location) (expected @GitHub)\n\n newArguments <- check arguments argumentsType\n\n newSchema <- case schema of\n Just output -> do\n return output\n\n Nothing -> do\n existential <- fresh\n\n preserve (Context.UnsolvedType existential)\n\n return Type.UnsolvedType{ location, existential}\n\n context <- get\n\n let newGitHub = Syntax.GitHub\n { location\n , import_\n , arguments = solveSyntax context newArguments\n , schema = Just newSchema\n }\n\n return (newSchema, newGitHub)\n\n Syntax.Show{ location, export, arguments, schema } -> do\n let json = Type.Scalar\n { location\n , scalar = Monotype.JSON\n }\n\n input <- case schema of\n Just input -> do\n Monad.unless export do\n isSubtypeOfJSON location input\n\n return input\n\n Nothing\n | export -> do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n return Type.UnsolvedType\n { location\n , existential\n }\n | otherwise -> do\n return json\n\n newArguments <- check arguments input\n\n context <- get\n\n let newShow = Syntax.Show\n { location\n , export\n , arguments = solveSyntax context newArguments\n , schema = Just input\n }\n\n let type_ = Type.Scalar{ location, scalar = Monotype.Text }\n\n return (type_, newShow)\n\n -- All the type inference rules for scalars go here. This part is\n -- pretty self-explanatory: a scalar literal returns the matching\n -- scalar type.\n Syntax.Scalar{ scalar = Syntax.Bool bool, .. } -> do\n return (Type.Scalar{ scalar = Monotype.Bool, .. }, Syntax.Scalar{ scalar = Syntax.Bool bool, .. })\n\n Syntax.Scalar{ scalar = Syntax.Real real, .. } -> do\n return (Type.Scalar{ scalar = Monotype.Real, .. }, Syntax.Scalar{ scalar = Syntax.Real real, .. })\n\n Syntax.Scalar{ scalar = Syntax.Integer integer, .. } -> do\n return (Type.Scalar{ scalar = Monotype.Integer, .. }, Syntax.Scalar{ scalar = Syntax.Integer integer, .. })\n\n Syntax.Scalar{ scalar = Syntax.Natural natural, .. } -> do\n return (Type.Scalar{ scalar = Monotype.Natural, .. }, Syntax.Scalar{ scalar = Syntax.Natural natural, .. })\n\n Syntax.Scalar{ scalar = Syntax.Null, .. } -> do\n -- NOTE: You might think that you could just infer that `null`\n -- has type `forall (a : Type) . Optional a`. This does not work\n -- because it will lead to data structures with impredicative types\n -- if you store a `null` inside of, say, a `List`.\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n return (Type.Optional{ type_ = Type.UnsolvedType{..}, .. }, Syntax.Scalar{ scalar = Syntax.Null, .. })\n\n Syntax.Scalar{ scalar = Syntax.Key key, .. } -> do\n return (Type.Scalar{ scalar = Monotype.Key, .. }, Syntax.Scalar{ scalar = Syntax.Key key, .. })\n\n Syntax.Operator{ operator = Syntax.And, .. } -> do\n let bool = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Bool\n }\n\n newLeft <- check left bool\n newRight <- check right bool\n\n context₁ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₁ newLeft\n , operatorLocation\n , operator = Syntax.And\n , right = solveSyntax context₁ newRight\n }\n\n return (bool, newOperator)\n\n Syntax.Operator{ operator = Syntax.Or, .. } -> do\n let bool = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Bool\n }\n\n newLeft <- check left bool\n newRight <- check right bool\n\n context₁ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₁ newLeft\n , operatorLocation\n , operator = Syntax.Or\n , right = solveSyntax context₁ newRight\n }\n\n return (bool, newOperator)\n\n Syntax.Operator{ operator = Syntax.Equal, .. } -> do\n (type₀, newLeft ) <- infer left\n (type₁, newRight) <- infer right\n\n context₀ <- get\n\n supertype <- supertypeOf (Context.solveType context₀ type₀) (Context.solveType context₀ type₁)\n\n _ <- check left supertype\n\n context₁ <- get\n\n _ <- check right (Context.solveType context₁ supertype)\n\n context₂ <- get\n\n let type₀' = Context.solveType context₂ type₀\n let type₁' = Context.solveType context₂ type₁\n\n let isEquatable Type.VariableType{ } =\n False\n isEquatable Type.UnsolvedType{ } =\n False\n isEquatable Type.Forall{ } =\n False\n isEquatable Type.Function{ } =\n False\n isEquatable Type.Scalar{ } =\n True\n isEquatable Type.Optional{ type_ } =\n isEquatable type_\n isEquatable Type.List{ type_ } =\n isEquatable type_\n isEquatable Type.Record{ fields = Type.Fields fieldTypes Monotype.EmptyFields } =\n all (isEquatable . snd) fieldTypes\n isEquatable Type.Record{ } =\n False\n isEquatable Type.Union{ alternatives = Type.Alternatives alternativeTypes Monotype.EmptyAlternatives } =\n all (isEquatable . snd) alternativeTypes\n isEquatable Type.Union{ } =\n False\n\n let bool = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Bool\n }\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₁ newLeft\n , operatorLocation\n , operator = Syntax.Equal\n , right = solveSyntax context₁ newRight\n }\n\n if isEquatable type₀' && isEquatable type₁'\n then return (bool, newOperator)\n else Exception.throwIO (InvalidOperands \"compare\" (Syntax.location left) (Syntax.location right))\n\n Syntax.Operator{ operator = Syntax.NotEqual, .. } -> do\n (type₀, newLeft ) <- infer left\n (type₁, newRight) <- infer right\n\n context₀ <- get\n\n supertype <- supertypeOf (Context.solveType context₀ type₀) (Context.solveType context₀ type₁)\n\n _ <- check left supertype\n\n context₁ <- get\n\n _ <- check right (Context.solveType context₁ supertype)\n\n context₂ <- get\n\n let type₀' = Context.solveType context₂ type₀\n let type₁' = Context.solveType context₂ type₁\n\n let isEquatable Type.VariableType{ } =\n False\n isEquatable Type.UnsolvedType{ } =\n False\n isEquatable Type.Forall{ } =\n False\n isEquatable Type.Function{ } =\n False\n isEquatable Type.Scalar{ } =\n True\n isEquatable Type.Optional{ type_ } =\n isEquatable type_\n isEquatable Type.List{ type_ } =\n isEquatable type_\n isEquatable Type.Record{ fields = Type.Fields fieldTypes Monotype.EmptyFields } =\n all (isEquatable . snd) fieldTypes\n isEquatable Type.Record{ } =\n False\n isEquatable Type.Union{ alternatives = Type.Alternatives alternativeTypes Monotype.EmptyAlternatives } =\n all (isEquatable . snd) alternativeTypes\n isEquatable Type.Union{ } =\n False\n\n let bool = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Bool\n }\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₁ newLeft\n , operatorLocation\n , operator = Syntax.NotEqual\n , right = solveSyntax context₁ newRight\n }\n\n if isEquatable type₀' && isEquatable type₁'\n then return (bool, newOperator)\n else Exception.throwIO (InvalidOperands \"compare\" (Syntax.location left) (Syntax.location right))\n\n Syntax.Operator{ operator = Syntax.LessThan, .. } -> do\n let real = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Real\n }\n\n newLeft <- check left real\n newRight <- check right real\n\n let bool = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Bool\n }\n\n context₁ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₁ newLeft\n , operatorLocation\n , operator = Syntax.LessThan\n , right = solveSyntax context₁ newRight\n }\n\n return (bool, newOperator)\n\n Syntax.Operator{ operator = Syntax.LessThanOrEqual, .. } -> do\n let real = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Real\n }\n\n newLeft <- check left real\n newRight <- check right real\n\n let bool = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Bool\n }\n\n context₁ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₁ newLeft\n , operatorLocation\n , operator = Syntax.LessThanOrEqual\n , right = solveSyntax context₁ newRight\n }\n\n return (bool, newOperator)\n\n Syntax.Operator{ operator = Syntax.GreaterThan, .. } -> do\n let real = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Real\n }\n\n newLeft <- check left real\n newRight <- check right real\n\n let bool = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Bool\n }\n\n context₁ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₁ newLeft\n , operatorLocation\n , operator = Syntax.GreaterThan\n , right = solveSyntax context₁ newRight\n }\n\n return (bool, newOperator)\n\n Syntax.Operator{ operator = Syntax.GreaterThanOrEqual, .. } -> do\n let real = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Real\n }\n\n newLeft <- check left real\n newRight <- check right real\n\n let bool = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Bool\n }\n\n context₁ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₁ newLeft\n , operatorLocation\n , operator = Syntax.GreaterThanOrEqual\n , right = solveSyntax context₁ newRight\n }\n\n return (bool, newOperator)\n\n Syntax.Operator{ operator = Syntax.Times, .. } -> do\n context₁ <- get\n\n let natural = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Natural\n }\n\n let integer = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Integer\n }\n\n let real = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Real\n }\n\n let naturalArguments = do\n newLeft <- check left natural\n newRight <- check right natural\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Times\n , right = solveSyntax context₂ newRight\n }\n\n return (natural, newOperator)\n\n let integerArguments = do\n newLeft <- check left integer\n newRight <- check right integer\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Times\n , right = solveSyntax context₂ newRight\n }\n\n return (integer, newOperator)\n\n let realArguments = do\n newLeft <- check left real\n newRight <- check right real\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Times\n , right = solveSyntax context₂ newRight\n }\n\n return (real, newOperator)\n\n naturalArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context₁\n\n integerArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context₁\n\n realArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n Exception.throwIO (InvalidOperands \"multiply\" (Syntax.location left) (Syntax.location right))\n\n Syntax.Operator{ operator = Syntax.Plus, .. } -> do\n context₁ <- get\n\n let natural = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Natural\n }\n\n let integer = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Integer\n }\n\n let real = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Real\n }\n\n let text = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Text\n }\n\n let naturalArguments = do\n newLeft <- check left natural\n newRight <- check right natural\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Plus\n , right = solveSyntax context₂ newRight\n }\n\n return (natural, newOperator)\n\n let integerArguments = do\n newLeft <- check left integer\n newRight <- check right integer\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Plus\n , right = solveSyntax context₂ newRight\n }\n\n return (integer, newOperator)\n\n let realArguments = do\n newLeft <- check left real\n newRight <- check right real\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Plus\n , right = solveSyntax context₂ newRight\n }\n\n return (real, newOperator)\n\n let textArguments = do\n newLeft <- check left text\n newRight <- check right text\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Plus\n , right = solveSyntax context₂ newRight\n }\n\n return (text, newOperator)\n\n let listArguments = do\n existential <- fresh\n\n push (Context.UnsolvedType existential)\n\n let element = Type.UnsolvedType\n { location = operatorLocation\n , existential\n }\n\n let list = Type.List\n { location = operatorLocation\n , type_ = element\n }\n\n newLeft <- check left list\n newRight <- check right list\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Plus\n , right = solveSyntax context₂ newRight\n }\n\n return (list, newOperator)\n\n naturalArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context₁\n\n integerArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context₁\n\n realArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context₁\n\n textArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context₁\n\n listArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n Exception.throwIO (InvalidOperands \"add\" (Syntax.location left) (Syntax.location right))\n\n Syntax.Operator{ operator = Syntax.Minus, .. } -> do\n context₁ <- get\n\n let natural = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Natural\n }\n\n let integer = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Integer\n }\n\n let real = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Real\n }\n\n let naturalArguments = do\n newLeft <- check left natural\n newRight <- check right natural\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Minus\n , right = solveSyntax context₂ newRight\n }\n\n return (integer, newOperator)\n\n let integerArguments = do\n newLeft <- check left integer\n newRight <- check right integer\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Minus\n , right = solveSyntax context₂ newRight\n }\n\n return (integer, newOperator)\n\n let realArguments = do\n newLeft <- check left real\n newRight <- check right real\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Minus\n , right = solveSyntax context₂ newRight\n }\n\n return (real, newOperator)\n\n naturalArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context₁\n\n integerArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context₁\n\n realArguments `Exception.catch` \\(_ :: TypeInferenceError) -> do\n Exception.throwIO (InvalidOperands \"subtract\" (Syntax.location left) (Syntax.location right))\n\n Syntax.Operator{ operator = Syntax.Modulus, .. } -> do\n let natural = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Natural\n }\n\n let integer = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Integer\n }\n\n let real = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Real\n }\n\n newRight <- case right of\n Syntax.Scalar{ scalar = Syntax.Natural 0 } -> do\n Exception.throwIO (ZeroDivisor (Syntax.location right))\n Syntax.Scalar{ scalar = Syntax.Natural n, location = l } -> do\n return Syntax.Scalar{ scalar = Syntax.Natural n, location = l }\n _ -> do\n Exception.throwIO (NeedConcreteDivisor (Syntax.location right))\n\n context₁ <- get\n\n let naturalArgument = do\n newLeft <- check left natural\n\n let type_ = Type.Record\n { location = operatorLocation\n , fields = Type.Fields\n [ (\"quotient\", natural)\n , (\"remainder\", natural)\n ]\n Monotype.EmptyFields\n }\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Modulus\n , right = solveSyntax context₂ newRight\n }\n\n return (type_, newOperator)\n\n let integerArgument = do\n newLeft <- check left integer\n\n let type_ = Type.Record\n { location = operatorLocation\n , fields = Type.Fields\n [ (\"quotient\", integer)\n , (\"remainder\", natural)\n ]\n Monotype.EmptyFields\n }\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Modulus\n , right = solveSyntax context₂ newRight\n }\n\n return (type_, newOperator)\n\n let realArgument = do\n newLeft <- check left real\n\n let type_ = Type.Record\n { location = operatorLocation\n , fields = Type.Fields\n [ (\"quotient\", integer)\n , (\"remainder\", real)\n ]\n Monotype.EmptyFields\n }\n\n context₂ <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context₂ newLeft\n , operatorLocation\n , operator = Syntax.Modulus\n , right = solveSyntax context₂ newRight\n }\n\n return (type_, newOperator)\n\n naturalArgument `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context₁\n\n integerArgument `Exception.catch` \\(_ :: TypeInferenceError) -> do\n set context₁\n\n realArgument `Exception.catch` \\(_ :: TypeInferenceError) -> do\n Exception.throwIO (InvalidOperands \"divide\" (Syntax.location left) (Syntax.location right))\n\n Syntax.Operator{ operator = Syntax.Divide, .. } -> do\n let real = Type.Scalar\n { location = operatorLocation\n , scalar = Monotype.Real\n }\n\n newLeft <- check left real\n newRight <- check right real\n\n context <- get\n\n let newOperator = Syntax.Operator\n { location\n , left = solveSyntax context newLeft\n , operatorLocation\n , operator = Syntax.Divide\n , right = solveSyntax context newRight\n }\n\n return (real, newOperator)\n\n Syntax.Builtin{ builtin = Syntax.Some, .. }-> do\n return\n ( Type.Forall\n { nameLocation = Syntax.location e₀\n , name = \"a\"\n , domain = Domain.Type\n , type_ = var \"a\" ~> Type.Optional{ type_ = var \"a\", .. }\n , ..\n }\n , Syntax.Builtin{ builtin = Syntax.Some, .. }\n )\n\n Syntax.Builtin{ builtin = Syntax.YAML, .. } -> do\n return\n ( Type.Scalar{ scalar = Monotype.JSON, .. }\n ~> Type.Scalar{ scalar = Monotype.Text, .. }\n , Syntax.Builtin{ builtin = Syntax.YAML, .. }\n )\n\n Syntax.Builtin{ builtin = Syntax.Indexed, .. } -> do\n return\n ( Type.Forall\n { nameLocation = Syntax.location e₀\n , name = \"a\"\n , domain = Domain.Type\n , type_ =\n Type.List{ type_ = var \"a\", .. }\n ~> Type.List\n { type_ =\n Type.Record\n { fields =\n Type.Fields\n [ (\"index\", Type.Scalar{ scalar = Monotype.Natural, .. })\n , (\"value\", var \"a\")\n ]\n Monotype.EmptyFields\n , ..\n }\n , ..\n }\n , ..\n }\n , Syntax.Builtin{ builtin = Syntax.Indexed, .. }\n )\n\n Syntax.Builtin{ builtin = Syntax.Length, .. } -> do\n return\n ( Type.Forall\n { nameLocation = Syntax.location e₀\n , name = \"a\"\n , domain = Domain.Type\n , type_ =\n Type.List{ type_ = var \"a\", .. }\n ~> Type.Scalar{ scalar = Monotype.Natural, .. }\n , ..\n }\n , Syntax.Builtin{ builtin = Syntax.Length, .. }\n )\n\n Syntax.Builtin{ builtin = Syntax.Map, .. } -> do\n return\n ( Type.Forall\n { nameLocation = Syntax.location e₀\n , name = \"a\"\n , domain = Domain.Type\n , type_ = Type.Forall\n { nameLocation = Syntax.location e₀\n , name = \"b\"\n , domain = Domain.Type\n , type_ =\n (var \"a\" ~> var \"b\")\n ~> ( Type.List{ type_ = var \"a\", .. }\n ~> Type.List{ type_ = var \"b\", .. }\n )\n , ..\n }\n , ..\n }\n , Syntax.Builtin{ builtin = Syntax.Map, .. }\n )\n\n Syntax.Builtin{ builtin = Syntax.Abs, .. } -> do\n return\n ( Type.Scalar{ scalar = Monotype.Integer, .. }\n ~> Type.Scalar{ scalar = Monotype.Natural, .. }\n , Syntax.Builtin{ builtin = Syntax.Abs, .. }\n )\n\n Syntax.Builtin{ builtin = Syntax.Reveal, .. } -> do\n return\n ( Type.Scalar{ scalar = Monotype.Key, .. }\n ~> Type.Scalar{ scalar = Monotype.Text, .. }\n , Syntax.Builtin{ builtin = Syntax.Reveal, .. }\n )\n\n Syntax.Embed{ embedded } -> do\n _Γ <- get\n\n input <- Reader.ask\n\n Reader.local (\\i -> i <> embedded) do\n absolute <- Reader.ask\n\n Import.referentiallySane input absolute\n\n syntax <- liftIO (Import.resolve AsCode absolute)\n\n infer syntax\n\n{-| This corresponds to the judgment:\n\n > Γ ⊢ e ⇐ A ⊣ Δ\n\n … which checks that e has type A under input context Γ, producing an updated\n context Δ.\n-}\ncheck :: Syntax Location Input -> Type Location -> Grace (Syntax Location Void)\n-- The check function is the most important function to understand for the\n-- bidirectional type-checking algorithm.\n--\n-- Most people, when they first run across the `check` function think that you\n-- could get rid of most rules except for the final `Sub` rule, but that's not\n-- true!\n--\n-- The reason you should add `check` rules for many more types (especially\n-- complex types) is to ensure that subtyping rules work correctly. For\n-- example, consider this expression:\n--\n-- [ 2, -3 ]\n--\n-- If you omit the `check` rule for `List`s then the above expression will\n-- fail to type-check because the first element of the list is a `Natural`\n-- number and the second element of the `List` is an `Integer`.\n--\n-- However, if you keep the `check` rule for `List`s and add a type annotation:\n--\n-- [ 2, -3 ] : List Integer\n--\n-- … then it works because the interpreter knows to treat both elements as an\n-- `Integer`.\n--\n-- In general, if you want subtyping to work reliably then you need to add\n-- more cases to the `check` function so that the interpreter can propagate\n-- top-level type annotations down to the \"leaves\" of your syntax tree. If\n-- you do this consistently then the user only ever needs to provide top-level\n-- type annotations to fix any type errors that they might encounter, which is\n-- a desirable property!\n\ncheck Syntax.Lambda{ location, binding = Syntax.PlainBinding{ plain = Syntax.NameBinding{ name, nameLocation, annotation = Nothing, assignment = Nothing } }, body } Type.Function{ input, output } = do\n scoped (Context.Annotation name input) do\n let newBinding = Syntax.PlainBinding\n { plain = Syntax.NameBinding\n { nameLocation\n , name\n , annotation = Nothing\n , assignment = Nothing\n }\n }\n\n newBody <- check body output\n\n return Syntax.Lambda{ location, binding = newBinding, body = newBody }\n\ncheck annotated Type.Function{ input, output } = do\n let candidates₀ = Set.fromList (map Text.singleton [ 'a' .. 'z' ])\n\n let free = Syntax.freeVariables annotated\n\n let name = case Set.toList (Set.difference candidates₀ free) of\n n : _ -> n\n _ ->\n let as = Set.filter (Text.isPrefixOf \"a\") free\n\n in head do\n suffix <- [ (0 :: Int) .. ]\n\n let candidate = Text.pack (\"a\" <> show suffix)\n\n Monad.guard (not (Set.member candidate as))\n\n return candidate\n\n let nameLocation = Type.location input\n\n scoped (Context.Annotation name input) do\n let argument = Syntax.Variable{ location = nameLocation, name }\n\n let body = Syntax.Application\n { location = Syntax.location annotated\n , function = annotated\n , argument\n }\n\n context <- get\n\n newBody <- check body (Context.solveType context output)\n\n case newBody of\n Syntax.Application{ function = newAnnotated, argument = Syntax.Variable{ name = newName } }\n | name == newName && not (Syntax.usedIn name newAnnotated) ->\n return newAnnotated\n _ -> do\n return Syntax.Lambda\n { location = Syntax.location annotated\n , binding = Syntax.PlainBinding\n { plain = Syntax.NameBinding\n { name\n , nameLocation\n , annotation = Nothing\n , assignment = Nothing\n }\n }\n , body = newBody\n }\n\ncheck e Type.Forall{..} = do\n scoped (Context.Variable domain name) do\n check e type_\n\ncheck Syntax.Let{ location, assignments, body = body₀ } annotation₀ = do\n let cons Syntax.Define{ assignmentLocation, definition } action = do\n ((name, annotation₁), newDefinition) <- onDefinition definition\n\n let entry = Context.Annotation name annotation₁\n\n let newAssignment = Syntax.Define\n { assignmentLocation\n , definition = newDefinition\n }\n\n scoped entry do\n (newAssignments, newBody) <- action\n\n return (newAssignment : newAssignments, newBody)\n\n cons Syntax.Bind{ assignmentLocation, monad, binding, assignment = value } action = do\n (annotation₁, newEntries, newBinding) <- onBinding binding\n\n (newAssignments, newBody) <- foldr scoped action newEntries\n\n let annotation₂ = case monad of\n ListMonad -> Type.List\n { location = assignmentLocation\n , type_ = annotation₁\n }\n\n OptionalMonad -> Type.Optional\n { location = assignmentLocation\n , type_ = annotation₁\n }\n\n IdentityMonad -> annotation₁\n\n newValue <- check value annotation₂\n\n let newAssignment = Syntax.Bind\n { assignmentLocation\n , monad\n , binding = newBinding\n , assignment = newValue\n }\n\n return (newAssignment : newAssignments, newBody)\n\n let nil = do\n let listMonad = do\n Syntax.Bind{ assignmentLocation, monad = ListMonad } <- toList assignments\n\n return assignmentLocation\n\n let optionalMonad = do\n Syntax.Bind{ assignmentLocation, monad = OptionalMonad } <- toList assignments\n\n return assignmentLocation\n\n newBody <- case (listMonad, optionalMonad) of\n (location₀ : _, location₁ : _) -> do\n Exception.throwIO AssignmentMismatch\n { location₀\n , location₁\n }\n\n (location₀ : _, []) -> do\n let body₁ = Syntax.List\n { location = location₀\n , elements = [ body₀ ]\n }\n\n body₂ <- check body₁ annotation₀\n\n case body₂ of\n Syntax.List{ elements = [ body₃ ] } -> return body₃\n _ -> error \"Grace.Infer.check: unexpected return value\"\n\n ([], location₁ : _) -> do\n let body₁ = Syntax.Application\n { location = location₁\n , function = Syntax.Builtin\n { location = location₁\n , builtin = Syntax.Some\n }\n , argument = body₀\n }\n\n body₂ <- check body₁ annotation₀\n\n case body₂ of\n Syntax.Application{ argument = body₃ } -> return body₃\n _ -> error \"Grace.Infer.check: unexpected return value\"\n\n ([], []) -> do\n check body₀ annotation₀\n\n return ([], newBody)\n\n (newAssignments, newBody) <- foldr cons nil assignments\n\n let newLet = Syntax.Let\n { location\n , assignments = NonEmpty.fromList newAssignments\n , body = newBody\n }\n\n context <- get\n\n return (solveSyntax context newLet)\n\ncheck Syntax.Alternative{ location, name, argument } annotation@Type.Union{ alternatives = Type.Alternatives alternativeTypes remainingAlternatives } = do\n existential <- fresh\n\n push (Context.UnsolvedAlternatives existential)\n\n case lookup name alternativeTypes of\n Just innerType₁ -> do\n newArgument <- check argument innerType₁\n\n return Syntax.Alternative{ location, name, argument = newArgument }\n\n Nothing -> do\n (innerType₀, newArgument) <- infer argument\n\n let alternatives = Type.Alternatives\n [ (name, innerType₀) ]\n (Monotype.UnsolvedAlternatives existential)\n\n case remainingAlternatives of\n Monotype.UnsolvedAlternatives p -> do\n instantiateAlternativesR location alternatives p\n\n return Syntax.Alternative\n { location\n , name\n , argument = newArgument\n }\n\n _ -> do\n let actual = Type.Union{ location, alternatives }\n\n Exception.throwIO (UnionTypeMismatch actual annotation [ name ])\n\ncheck Syntax.Prompt{ schema = Nothing, .. } annotation = do\n newArguments <- check arguments (fmap (\\_ -> location) (expected @Prompt))\n\n return Syntax.Prompt{ arguments = newArguments, schema = Just annotation, .. }\n\ncheck Syntax.HTTP{ import_, schema = Nothing, .. } annotation = do\n let input = fmap (\\_ -> location) (expected @HTTP)\n\n newArguments <- check arguments input\n\n Monad.unless import_ do\n context <- get\n\n isSubtypeOfJSON location (Context.solveType context annotation)\n\n context <- get\n\n return Syntax.HTTP{ arguments = newArguments, schema = Just (Context.solveType context annotation), .. }\n\ncheck Syntax.Read{ import_, schema = Nothing, .. } annotation = do\n newArguments <- check arguments (fmap (\\_ -> location) (expected @Text))\n\n Monad.unless import_ do\n context <- get\n\n isSubtypeOfJSON location (Context.solveType context annotation)\n\n context <- get\n\n return Syntax.Read{ arguments = newArguments, schema = Just (Context.solveType context annotation), .. }\n\ncheck Syntax.GitHub{ import_, schema = Nothing, .. } annotation = do\n let argumentsType = fmap (\\_ -> location) (expected @GitHub)\n\n newArguments <- check arguments argumentsType\n\n Monad.unless import_ do\n context <- get\n\n isSubtypeOfJSON location (Context.solveType context annotation)\n\n context <- get\n\n return Syntax.GitHub{ arguments = newArguments, schema = Just (Context.solveType context annotation), .. }\n\ncheck Syntax.Project{ location, larger, smaller = smaller@Syntax.Single{ single = Syntax.Field{ fieldLocation, field } } } annotation = do\n context <- get\n\n (recordType, newLarger₀) <- infer larger\n\n case recordType of\n Type.Record{ fields = Type.Fields fieldTypes _ }\n | Just fieldType <- lookup field fieldTypes -> do\n subtype fieldType annotation\n\n return Syntax.Project{ location, larger = newLarger₀, smaller }\n\n _ -> do\n set context\n\n fields <- fresh\n\n push (Context.UnsolvedFields fields)\n\n newLarger₁ <- check larger Type.Record\n { fields = Type.Fields\n [(field, annotation)]\n (Monotype.UnsolvedFields fields)\n , location = fieldLocation\n }\n\n return Syntax.Project{ location, larger = newLarger₁, smaller }\n\ncheck Syntax.Project{ location, larger, smaller = smaller@Syntax.Multiple{ multiple } } Type.Record{ location = recordLocation, fields = Type.Fields fieldTypes rest }\n | let m₀ = Map.fromList do\n Syntax.Field{ field } <- multiple\n\n return (field, ())\n\n , let m₁ = Map.fromList fieldTypes\n\n , Map.null (Map.difference m₀ m₁) = do\n let m = Map.intersectionWith (\\_ type_ -> type_) m₀ m₁\n\n let newAnnotation = Type.Record\n { location = recordLocation\n , fields = Type.Fields (Map.toList m) rest\n }\n\n newLarger <- check larger newAnnotation\n\n return Syntax.Project{ location, larger = newLarger, smaller }\n\ncheck Syntax.Project{ location, larger, smaller = smaller@Syntax.Slice{ } } Type.Optional{ type_ } = do\n newLarger <- check larger type_\n\n return Syntax.Project{ location, larger = newLarger, smaller }\n\ncheck Syntax.Project{ location, larger, smaller = smaller@Syntax.Index{ } } Type.Optional{ type_ } = do\n newLarger <- check larger Type.List{ location, type_ }\n\n return Syntax.Project{ location, larger = newLarger, smaller }\n\ncheck Syntax.Scalar{ location, scalar = Syntax.Null } Type.Optional{ } = do\n return Syntax.Scalar{ location, scalar = Syntax.Null }\n\ncheck Syntax.Application{ location = location₀, function = Syntax.Builtin{ location = location₁, builtin = Syntax.Some }, argument } Type.Optional{ type_ } = do\n newArgument <- check argument type_\n\n return Syntax.Application\n { location = location₀\n , function = Syntax.Builtin\n { location = location₁\n , builtin = Syntax.Some\n }\n , argument = newArgument\n }\n\ncheck annotated annotation@Type.Optional{ location, type_ = type₀ } = do\n let name = \"x\"\n\n (type₁, newAnnotated₀) <- infer annotated\n\n context₀ <- get\n\n case Context.solveType context₀ type₁ of\n Type.Optional{ type_ = type₂ } -> do\n scoped (Context.Annotation name type₂) do\n let nameLocation = Type.location type₀\n\n let variable = Syntax.Variable{ location = nameLocation, name }\n\n context₁ <- get\n\n elaborated <- check variable (Context.solveType context₁ type₀)\n\n if elaborated == variable\n then do\n return newAnnotated₀\n else do\n return Syntax.Let\n { location\n , assignments =\n [ Bind\n { assignmentLocation = location\n , monad = OptionalMonad\n , binding = PlainBinding\n { plain = NameBinding\n { nameLocation\n , name\n , annotation = Just type₂\n , assignment = Nothing\n }\n }\n , assignment = newAnnotated₀\n }\n ]\n , body = elaborated\n }\n\n Type.UnsolvedType{ existential } -> do\n instantiateTypeL existential (Context.solveType context₀ annotation)\n\n context₁ <- get\n\n return (solveSyntax context₁ newAnnotated₀)\n\n _ -> do\n newAnnotated₁ <- check annotated (Context.solveType context₀ type₀)\n\n context₁ <- get\n\n return Syntax.Application\n { location\n , function = Syntax.Builtin\n { location\n , builtin = Syntax.Some\n }\n , argument = solveSyntax context₁ newAnnotated₁\n }\n\ncheck Syntax.Operator{ location, left, operatorLocation, operator = Syntax.Times, right } annotation@Type.Scalar{ scalar }\n | scalar `elem` ([ Monotype.Natural, Monotype.Integer, Monotype.Real ] :: [Monotype.Scalar]) = do\n newLeft <- check left annotation\n\n context <- get\n\n newRight <- check right (Context.solveType context annotation)\n\n return Syntax.Operator\n { location\n , left = newLeft\n , operatorLocation\n , operator = Syntax.Times\n , right = newRight\n }\n\ncheck Syntax.Operator{ location, left, operatorLocation, operator = Syntax.Plus, right } annotation@Type.Scalar{ scalar }\n | scalar `elem` ([ Monotype.Natural, Monotype.Integer, Monotype.Real, Monotype.Text ] :: [Monotype.Scalar]) = do\n newLeft <- check left annotation\n\n context <- get\n\n newRight <- check right (Context.solveType context annotation)\n\n return Syntax.Operator\n { location\n , left = newLeft\n , operatorLocation\n , operator = Syntax.Plus\n , right = newRight\n }\n\ncheck Syntax.Operator{ location, left, operatorLocation, operator = Syntax.Plus, right } annotation@Type.List{ } = do\n newLeft <- check left annotation\n\n context <- get\n\n newRight <- check right (Context.solveType context annotation)\n\n return Syntax.Operator\n { location\n , left = newLeft\n , operatorLocation\n , operator = Syntax.Plus\n , right = newRight\n }\n\n\ncheck Syntax.Operator{ location, left, operatorLocation, operator = Syntax.Minus, right } annotation@Type.Scalar{ scalar }\n | scalar `elem` ([ Monotype.Integer, Monotype.Real ] :: [Monotype.Scalar]) = do\n newLeft <- check left annotation\n\n context <- get\n\n newRight <- check right (Context.solveType context annotation)\n\n return Syntax.Operator\n { location\n , left = newLeft\n , operatorLocation\n , operator = Syntax.Minus\n , right = newRight\n }\n\ncheck Syntax.If{ location, predicate, ifTrue, ifFalse } annotation = do\n newPredicate <- check predicate Type.Scalar\n { location\n , scalar = Monotype.Bool\n }\n\n newIfTrue <- check ifTrue annotation\n\n newIfFalse <- check ifFalse annotation\n\n return Syntax.If\n { location\n , predicate = newPredicate\n , ifTrue = newIfTrue\n , ifFalse = newIfFalse\n }\n\ncheck Syntax.List{..} Type.List{ location = _, .. } = do\n let process element = do\n _Γ <- get\n\n check element (Context.solveType _Γ type_)\n\n newElements <- traverse process elements\n\n return Syntax.List{ elements = newElements, .. }\n\ncheck annotated@Syntax.Record{ location, fieldValues = fieldValues₀ } annotation@Type.Record{ fields = Type.Fields fieldTypes fields } = do\n let fieldValues₁ = do\n Syntax.Definition{ nameLocation, name, bindings, annotation = annotation₀, assignment } <- fieldValues₀\n\n let newAssignment = case annotation₀ of\n Nothing -> assignment\n Just annotation₁ -> Syntax.Annotation\n { location = Syntax.location assignment\n , annotated = assignment\n , annotation = annotation₁\n }\n\n let cons binding body = Syntax.Lambda\n { location = nameLocation\n , binding\n , body\n }\n\n let value = foldr cons newAssignment bindings\n\n return (name, value)\n\n let subFieldValues = Map.fromList fieldValues₁\n let superFieldTypes = Map.fromList fieldTypes\n\n let both = Map.intersectionWith (,) subFieldValues superFieldTypes\n\n let extraValues = Map.difference subFieldValues superFieldTypes\n let extraTypes = Map.difference superFieldTypes subFieldValues\n\n isRequiredTypes <- traverse isFieldRequired extraTypes\n\n let extraRequiredTypes =\n Map.difference extraTypes (Map.filter not isRequiredTypes)\n\n let extraOptionalTypes =\n Map.difference extraTypes (Map.filter id isRequiredTypes)\n\n let process (field, (value, type_)) = do\n context <- get\n\n newValue <- check value (Context.solveType context type_)\n\n return (field, newValue)\n\n overlappingValues <- traverse process (Map.toList both)\n\n let convert (name, assignment) = Syntax.Definition\n { nameLocation = Syntax.location assignment\n , name\n , bindings = []\n , annotation = Nothing\n , assignment\n }\n\n let extraRecordValue = Syntax.Record\n { location\n , fieldValues = map convert (Map.toList extraValues)\n }\n\n let extraRecordType = Type.Record\n { location = Type.location annotation\n , fields = Type.Fields (Map.toList extraRequiredTypes) fields\n }\n\n Monad.unless (null extraRequiredTypes) do\n -- TODO: Craft an exception just for this error path\n (inferred, _) <- infer extraRecordValue\n\n context <- get\n\n Exception.throwIO (RecordTypeMismatch (Context.solveType context inferred) (Context.solveType context extraRecordType) (Map.keys extraRequiredTypes))\n\n let nullValues = do\n (field, type_) <- Map.toList extraOptionalTypes\n\n return (field, Syntax.Scalar{ location = Type.location type_, scalar = Syntax.Null })\n\n nonOverlappingValues <- case fields of\n Monotype.UnsolvedFields p -> do\n results <- traverse infer extraValues\n\n let extraValueTypes = fmap fst results\n\n let newExtraValues = fmap snd results\n\n context <- get\n\n instantiateFieldsR\n (Syntax.location annotated)\n (Context.solveRecord context\n (Type.Fields (Map.toList extraValueTypes) Monotype.EmptyFields)\n )\n p\n\n return newExtraValues\n\n _ -> do\n return Map.empty\n\n return Syntax.Record\n { location\n , fieldValues = map convert (overlappingValues <> nullValues <> Map.toList nonOverlappingValues)\n }\n\ncheck Syntax.Text{ chunks = Syntax.Chunks text₀ rest, .. } Type.Scalar{ scalar = Monotype.Text } = do\n let process (interpolation, text) = do\n newInterpolation <- check interpolation Type.Scalar{ scalar = Monotype.Text, .. }\n\n return (newInterpolation, text)\n\n newRest <- traverse process rest\n\n return Syntax.Text{ chunks = Syntax.Chunks text₀ newRest, .. }\n\ncheck Syntax.List{..} annotation@Type.Scalar{ scalar = Monotype.JSON } = do\n newElements <- traverse (`check` annotation) elements\n\n let annotated = Syntax.List{ elements = newElements, .. }\n\n return Syntax.Annotation\n { annotated, annotation, location = Syntax.location annotated }\n\ncheck Syntax.Record{ location, fieldValues } annotation₀@Type.Scalar{ scalar = Monotype.JSON } = do\n let process definition₀@Syntax.Definition{ bindings, annotation = annotation₁ } = do\n definition₁ <- case bindings of\n [] -> do\n case annotation₁ of\n Just annotation₂ -> do\n subtype annotation₂ annotation₀\n Nothing -> do\n return ()\n\n return (definition₀ :: Definition Location Input){ annotation = Just annotation₀ }\n _ -> do\n return definition₀\n\n onDefinition definition₁\n\n result <- traverse process fieldValues\n\n let (_, newFieldValues) = unzip result\n\n return Syntax.Record{ location, fieldValues = newFieldValues }\n\ncheck e@Syntax.Text{ } Type.Scalar{ scalar = Monotype.JSON, .. } = do\n check e Type.Scalar{ scalar = Monotype.Text, .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Natural natural, .. } Type.Scalar{ scalar = Monotype.JSON } = do\n return Syntax.Scalar{ scalar = Syntax.Natural natural, .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Integer integer, .. } Type.Scalar{ scalar = Monotype.JSON } = do\n return Syntax.Scalar{ scalar = Syntax.Integer integer, .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Real real, .. } Type.Scalar{ scalar = Monotype.JSON } = do\n return Syntax.Scalar{ scalar = Syntax.Real real, .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Bool bool, .. } Type.Scalar{ scalar = Monotype.JSON } = do\n return Syntax.Scalar{ scalar = Syntax.Bool bool, .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Null, .. } Type.Scalar{ scalar = Monotype.JSON } = do\n return Syntax.Scalar{ scalar = Syntax.Null, .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Natural n, .. } Type.Scalar{ scalar = Monotype.Real } = do\n return Syntax.Scalar{ scalar = Syntax.Real (fromIntegral n), .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Integer n, .. } Type.Scalar{ scalar = Monotype.Real } = do\n return Syntax.Scalar{ scalar = Syntax.Real (fromInteger n), .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Real n, .. } Type.Scalar{ scalar = Monotype.Real } = do\n return Syntax.Scalar{ scalar = Syntax.Real n, .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Natural n, .. } Type.Scalar{ scalar = Monotype.Integer } = do\n return Syntax.Scalar{ scalar = Syntax.Integer (fromIntegral n), .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Integer n, .. } Type.Scalar{ scalar = Monotype.Integer } = do\n return Syntax.Scalar{ scalar = Syntax.Integer n, .. }\n\ncheck Syntax.Scalar{ scalar = Syntax.Natural n, .. } Type.Scalar{ scalar = Monotype.Natural } = do\n return Syntax.Scalar{ scalar = Syntax.Natural n, .. }\n\ncheck annotated annotation@Type.Scalar{ scalar = Monotype.Real } = do\n (_A₀, newAnnotated) <- infer annotated\n\n context <- get\n\n let _A₁ = Context.solveType context _A₀\n\n let real = do\n subtype _A₁ annotation\n\n return newAnnotated\n\n let integer = do\n subtype _A₁ Type.Scalar\n { scalar = Monotype.Integer\n , location = Syntax.location newAnnotated\n }\n\n return Syntax.Annotation\n { annotated = newAnnotated\n , annotation\n , location = Syntax.location newAnnotated\n }\n\n let natural = do\n subtype _A₁ Type.Scalar\n { scalar = Monotype.Natural\n , location = Syntax.location newAnnotated\n }\n\n return Syntax.Annotation\n { annotated = newAnnotated\n , annotation\n , location = Syntax.location newAnnotated\n }\n\n real `Exception.catch` \\(_ :: TypeInferenceError) -> do\n integer `Exception.catch` \\(_ :: TypeInferenceError) -> do\n natural `Exception.catch` \\(_ :: TypeInferenceError) -> do\n subtype _A₁ annotation\n\n return newAnnotated\n\ncheck annotated annotation@Type.Scalar{ scalar = Monotype.Integer } = do\n (_A₀, newAnnotated) <- infer annotated\n\n context <- get\n\n let _A₁ = Context.solveType context _A₀\n\n let integer = do\n subtype _A₁ annotation\n\n return newAnnotated\n\n let natural = do\n subtype _A₁ Type.Scalar\n { scalar = Monotype.Natural\n , location = Syntax.location newAnnotated\n }\n\n return Syntax.Annotation\n { annotated = newAnnotated\n , annotation\n , location = Syntax.location newAnnotated\n }\n\n integer `Exception.catch` \\(_ :: TypeInferenceError) -> do\n natural `Exception.catch` \\(_ :: TypeInferenceError) -> do\n subtype _A₁ annotation\n\n return newAnnotated\n\ncheck Syntax.Embed{ embedded } annotation = do\n context <- get\n\n input <- Reader.ask\n\n Reader.local (\\i -> i <> embedded) do\n absolute <- Reader.ask\n\n Import.referentiallySane input absolute\n\n let mode = case Context.solveType context annotation of\n Type.Scalar{ scalar = Monotype.Text } -> AsText\n Type.Scalar{ scalar = Monotype.Key } -> AsKey\n _ -> AsCode\n\n syntax <- liftIO (Import.resolve mode absolute)\n\n check syntax annotation\n\ncheck Syntax.Text{ chunks = Syntax.Chunks text₀ [], .. } Type.Scalar{ scalar = Monotype.Key } = do\n return Syntax.Scalar{ scalar = Syntax.Key text₀, .. }\n\ncheck annotated annotation@Type.Scalar{ scalar = Monotype.Key } = do\n (_A₀, newAnnotated) <- infer annotated\n\n context <- get\n\n let _A₁ = Context.solveType context _A₀\n\n let key = do\n subtype _A₁ annotation\n\n return newAnnotated\n\n let text = do\n subtype _A₁ Type.Scalar\n { scalar = Monotype.Text\n , location = Syntax.location newAnnotated\n }\n\n return Syntax.Annotation\n { annotated = newAnnotated\n , annotation\n , location = Syntax.location newAnnotated\n }\n\n key `Exception.catch` \\(_ :: TypeInferenceError) -> do\n text `Exception.catch` \\(_ :: TypeInferenceError) -> do\n subtype _A₁ annotation\n\n return newAnnotated\n\n-- Sub\ncheck e _B = do\n (_A, newE) <- infer e\n\n _Θ <- get\n\n subtype (Context.solveType _Θ _A) (Context.solveType _Θ _B)\n\n return newE\n\n{-| This corresponds to the judgment:\n\n > Γ ⊢ A • e ⇒⇒ C ⊣ Δ\n\n … which infers the result type C when a function of type A is applied to an\n input argument e, under input context Γ, producing an updated context Δ.\n-}\ninferApplication\n :: Type Location\n -> Syntax Location Input\n -> Grace (Type Location, Syntax Location Void)\n-- ∀App\ninferApplication Type.Forall{ domain = Domain.Type, .. } e = do\n a <- fresh\n\n push (Context.UnsolvedType a)\n\n let a' = Type.UnsolvedType{ location = nameLocation, existential = a}\n\n inferApplication (Type.substituteType name 0 a' type_) e\ninferApplication Type.Forall{ domain = Domain.Fields, .. } e = do\n a <- fresh\n\n push (Context.UnsolvedFields a)\n\n let a' = Type.Fields [] (Monotype.UnsolvedFields a)\n\n inferApplication (Type.substituteFields name 0 a' type_) e\ninferApplication Type.Forall{ domain = Domain.Alternatives, .. } e = do\n a <- fresh\n\n push (Context.UnsolvedAlternatives a)\n\n let a' = Type.Alternatives [] (Monotype.UnsolvedAlternatives a)\n\n inferApplication (Type.substituteAlternatives name 0 a' type_) e\n\n-- αApp\ninferApplication Type.UnsolvedType{ existential = a, .. } e = do\n _Γ <- get\n\n (_Γ', _Γ) <- Context.splitOnUnsolvedType a _Γ `orDie` MissingVariable a _Γ\n\n a₁ <- fresh\n a₂ <- fresh\n\n set (_Γ' <> (Context.SolvedType a (Monotype.Function (Monotype.UnsolvedType a₁) (Monotype.UnsolvedType a₂)) : Context.UnsolvedType a₁ : Context.UnsolvedType a₂ : _Γ))\n\n newE <- check e Type.UnsolvedType{ existential = a₁, .. }\n\n return (Type.UnsolvedType{ existential = a₂, .. }, newE)\ninferApplication Type.Function{..} e = do\n newE <- check e input\n\n return (output, newE)\ninferApplication Type.VariableType{..} _ = do\n Exception.throwIO (NotNecessarilyFunctionType location name)\ninferApplication _A _ = do\n Exception.throwIO (NotFunctionType (location _A) _A)\n\n-- | Infer the `Type` of the given `Syntax` tree\ntypeOf\n :: MonadIO m\n => Input\n -> Syntax Location Input\n -> m (Type Location, Syntax Location Void)\ntypeOf input = typeWith input []\n\n-- | Like `typeOf`, but accepts a custom type-checking `Context`\ntypeWith\n :: MonadIO m\n => Input\n -> Context Location\n -> Syntax Location Input\n -> m (Type Location, Syntax Location Void)\ntypeWith input context syntax = do\n let initialStatus = Status{ count = 0, context }\n\n ((_A, elaborated), Status{ context = _Δ }) <- Grace.runGrace input initialStatus (infer syntax)\n\n return (Context.complete _Δ _A, solveSyntax _Δ elaborated)\n\nsolveSyntax :: Context s -> Syntax s a -> Syntax s a\nsolveSyntax _Γ = Lens.transform (Lens.over Syntax.types (Context.solveType _Γ))\n\n-- | Check if a given `Type` is a subtype of `Monotype.JSON`\nisSubtypeOfJSON\n :: Location\n -- ^ `Location` of the `Monotype.JSON`\n -> Type Location\n -- ^ Type being checked against `Monotype.JSON`\n -> Grace ()\nisSubtypeOfJSON location = loop\n where\n loop Type.UnsolvedType{ existential } = do\n let json = Type.Scalar{ location, scalar = Monotype.JSON }\n\n instantiateTypeL existential json\n loop type_@Type.Scalar{ scalar } = do\n Monad.when (scalar == Monotype.Key) do\n Exception.throwIO (NotSubtypeOfJSON type_)\n loop Type.List{ type_ } = do\n loop type_\n loop Type.Optional{ type_ } = do\n loop type_\n loop type_@Type.Record{ fields = Type.Fields fieldTypes remainingFields } = do\n traverse_ (\\(_, type₀) -> loop type₀) fieldTypes\n\n case remainingFields of\n Monotype.EmptyFields -> do\n return ()\n\n Monotype.UnsolvedFields existential -> do\n instantiateFieldsL existential location (Type.Fields [] Monotype.EmptyFields)\n\n _ -> do\n Exception.throwIO (NotSubtypeOfJSON type_)\n loop type_ = do\n Exception.throwIO (NotSubtypeOfJSON type_)\n\n{-| This covers all the scalar subtyping rules /except/ for `Monotype.JSON`,\n which is handled by `isSubtypeOfJSON`\n-}\nisScalarSubtypeOf :: Monotype.Scalar -> Monotype.Scalar -> Bool\nisScalarSubtypeOf Monotype.Natural Monotype.Integer = True\nisScalarSubtypeOf Monotype.Natural Monotype.Real = True\nisScalarSubtypeOf Monotype.Integer Monotype.Real = True\nisScalarSubtypeOf Monotype.Text Monotype.Key = True\nisScalarSubtypeOf scalar₀ scalar₁ = scalar₀ == scalar₁\n\n-- | Convert from JSON, inferring the value purely from the JSON data\ninferJSON :: Aeson.Value -> Value ()\ninferJSON (Aeson.Object (Compat.sorted -> [(\"contents\", contents), (\"tag\", Aeson.String tag)])) =\n Value.Alternative () tag value\n where\n value = inferJSON contents\ninferJSON (Aeson.Object object) = Value.Record () (Map.fromList keyValues)\n where\n keyValues = do\n (key, value) <- Map.toList (Compat.fromAesonMap object)\n\n return (key, ((), inferJSON value))\ninferJSON (Aeson.Array vector) = Value.List () (Seq.fromList (toList elements))\n where\n elements = fmap inferJSON vector\ninferJSON (Aeson.String text) = Value.Text () text\ninferJSON (Aeson.Number scientific) =\n case Scientific.floatingOrInteger scientific of\n Left (_ :: Double) ->\n Value.Scalar () (Syntax.Real scientific)\n Right (integer :: Integer)\n | 0 <= integer -> do\n Value.Scalar () (Syntax.Natural (fromInteger integer))\n | otherwise -> do\n Value.Scalar () (Syntax.Integer integer)\ninferJSON (Aeson.Bool bool) =\n Value.Scalar () (Syntax.Bool bool)\ninferJSON Aeson.Null =\n Value.Scalar () Syntax.Null\n\n-- | Check an `Aeson.Value` against an expected `Type`\ncheckJSON :: Type Location -> Aeson.Value -> Grace (Value ())\ncheckJSON = loop []\n where\n loop path Type.Union{ Type.alternatives = Type.Alternatives alternativeTypes _ } (Aeson.Object (Compat.sorted -> [(\"contents\", contents), (\"tag\", Aeson.String tag)]))\n | Just alternativeType <- Prelude.lookup tag alternativeTypes = do\n value <- loop (\"contents\" : path) alternativeType contents\n\n pure (Value.Alternative () tag value)\n loop path Type.Record{ Type.fields = Type.Fields fieldTypes _ } (Aeson.Object object) = do\n let properties = Compat.fromAesonMap object\n\n let process (field, type_) = do\n let property = case Map.lookup field properties of\n Just p -> p\n Nothing -> Aeson.Null\n\n expression <- loop (field : path) type_ property\n\n return (field, ((), expression))\n\n fieldValues <- traverse process fieldTypes\n\n pure (Value.Record () (Map.fromList fieldValues))\n loop path type_@Type.Scalar{ scalar = Monotype.JSON } (Aeson.Object object) = do\n let properties = Map.toList (Compat.fromAesonMap object)\n\n let process (key, property) = do\n expression <- loop (key : path) type_ property\n\n return (key, ((), expression))\n\n textValues <- traverse process properties\n\n pure (Value.Record () (Map.fromList textValues))\n loop path Type.List{ Type.type_ } (Aeson.Array vector) = do\n elements <- traverse (loop (\"*\" : path) type_) vector\n\n pure (Value.List () (Seq.fromList (toList elements)))\n loop path type_@Type.Scalar{ scalar = Monotype.JSON } (Aeson.Array vector) = do\n elements <- traverse (loop (\"*\" : path) type_) vector\n\n pure (Value.List () (Seq.fromList (toList elements)))\n loop _ Type.Scalar{ scalar = Monotype.Text } (Aeson.String text) = do\n pure (Value.Text () text)\n loop _ Type.Scalar{ scalar = Monotype.JSON } (Aeson.String text) = do\n pure (Value.Text () text)\n loop _ Type.Scalar{ scalar = Monotype.Real } (Aeson.Number scientific) = do\n pure (Value.Scalar () (Syntax.Real scientific))\n loop path type_@Type.Scalar{ scalar = Monotype.Integer } value@(Aeson.Number scientific) = do\n case Scientific.floatingOrInteger @Double @Integer scientific of\n Right integer -> do\n pure (Value.Scalar () (Syntax.Integer integer))\n _ -> do\n Exception.throwIO InvalidJSON{ path, value, type_ }\n loop path type_@Type.Scalar{ scalar = Monotype.Natural } value@(Aeson.Number scientific) =\n case Scientific.floatingOrInteger @Double @Integer scientific of\n Right integer\n | 0 <= integer -> do\n pure (Value.Scalar () (Syntax.Natural (fromInteger integer)))\n _ -> do\n Exception.throwIO InvalidJSON{ path, value, type_ }\n loop _ Type.Scalar{ scalar = Monotype.JSON } (Aeson.Number scientific) =\n case Scientific.floatingOrInteger scientific of\n Left (_ :: Double) -> do\n pure (Value.Scalar () (Syntax.Real scientific))\n Right (integer :: Integer)\n | 0 <= integer -> do\n pure (Value.Scalar () (Syntax.Natural (fromInteger integer)))\n | otherwise -> do\n pure (Value.Scalar () (Syntax.Integer integer))\n loop _ Type.Scalar{ Type.scalar = Monotype.Bool } (Aeson.Bool bool) =\n pure (Value.Scalar () (Syntax.Bool bool))\n loop _ Type.Scalar{ Type.scalar = Monotype.JSON } (Aeson.Bool bool) =\n pure (Value.Scalar () (Syntax.Bool bool))\n loop _ Type.Optional{ } Aeson.Null =\n pure (Value.Scalar () Syntax.Null)\n loop path Type.Optional{ type_ } value = do\n result <- loop path type_ value\n\n pure (Value.Application () (Value.Builtin () Syntax.Some) result)\n loop _ Type.Scalar{ scalar = Monotype.JSON } Aeson.Null =\n pure (Value.Scalar () Syntax.Null)\n loop _ type₀ value = do\n let bytes = Aeson.Pretty.encodePretty value\n\n text <- case Encoding.decodeUtf8' (ByteString.Lazy.toStrict bytes) of\n Left exception -> Exception.throwIO exception\n Right text -> return text\n\n let input = Code \"(json)\" text\n\n let mode = case type₀ of\n Type.Scalar{ scalar = Monotype.Text } -> AsText\n Type.Scalar{ scalar = Monotype.Key } -> AsKey\n _ -> AsCode\n\n expression <- liftIO (Import.resolve mode input)\n\n (type₁, _) <- infer expression\n\n context₀ <- get\n\n subtype (Context.solveType context₀ type₁) (Context.solveType context₀ type₀)\n let json = Type.Scalar\n { location = Type.location type₀\n , scalar = Monotype.JSON\n }\n\n context₁ <- get\n\n subtype (Context.solveType context₁ type₁) json\n\n return (inferJSON value)\n\n-- | A data type holding all errors related to type inference\ndata TypeInferenceError\n = IllFormedAlternatives Location (Existential Monotype.Union) (Context Location)\n | IllFormedFields Location (Existential Monotype.Record) (Context Location)\n | IllFormedType Location (Type Location) (Context Location)\n --\n | InvalidOperands Text Location Location\n | ZeroDivisor Location\n | NeedConcreteDivisor Location\n --\n | FoldInvalidHandler Location (Type Location)\n --\n | MissingAllAlternatives (Existential Monotype.Union) (Context Location)\n | MissingAllFields (Existential Monotype.Record) (Context Location)\n | MissingOneOfTypes [Location] (Existential Monotype) (Existential Monotype) (Context Location)\n | MissingOneOfAlternatives [Location] (Existential Monotype.Union) (Existential Monotype.Union) (Context Location)\n | MissingOneOfFields [Location] (Existential Monotype.Record) (Existential Monotype.Record) (Context Location)\n | MissingVariable (Existential Monotype) (Context Location)\n --\n | NotFunctionType Location (Type Location)\n | NotNecessarilyFunctionType Location Text\n --\n | NotAlternativesSubtype Location (Existential Monotype.Union) (Type.Union Location)\n | NotFieldsSubtype Location (Existential Monotype.Record) (Type.Record Location)\n | NotSubtype (Type Location) (Type Location)\n | NotSubtypeOfJSON (Type Location)\n | NoSupertype (Type Location) (Type Location)\n | NoSubtype (Type Location) (Type Location)\n | NoUnionSubtype (Type Location) (Type Location) [Text] [Text]\n --\n | UnboundAlternatives Location Text\n | UnboundFields Location Text\n | UnboundTypeVariable Location Text\n | UnboundVariable Location Text\n --\n | RecordTypeMismatch (Type Location) (Type Location) [Text]\n | UnionTypeMismatch (Type Location) (Type Location) [Text]\n | FieldsVariableMismatch Location Monotype.RemainingFields Location Monotype.RemainingFields\n | AlternativesVariableMismatch Location Monotype.RemainingAlternatives Location Monotype.RemainingAlternatives\n --\n deriving stock (Eq, Show)\n\ninstance Exception TypeInferenceError where\n displayException (IllFormedAlternatives location a₀ _Γ) =\n \"Internal error: Invalid context\\n\\\n \\\\n\\\n \\The following unsolved alternatives variable:\\n\\\n \\\\n\\\n \\\" <> insert (Context.UnsolvedAlternatives a₀) <> \"\\n\\\n \\\\n\\\n \\… is not well-formed within the following context:\\n\\\n \\\\n\\\n \\#{listToText _Γ}\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location)\n\n displayException (IllFormedFields location a₀ _Γ) =\n \"Internal error: Invalid context\\n\\\n \\\\n\\\n \\The following unsolved fields variable:\\n\\\n \\\\n\\\n \\\" <> insert (Context.UnsolvedFields a₀) <> \"\\n\\\n \\\\n\\\n \\… is not well-formed within the following context:\\n\\\n \\\\n\\\n \\\" <> listToText _Γ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location)\n\n displayException (IllFormedType location _A _Γ) =\n \"Internal error: Invalid context\\n\\\n \\\\n\\\n \\The following type:\\n\\\n \\\\n\\\n \\\" <> insert _A <> \"\\n\\\n \\\\n\\\n \\… is not well-formed within the following context:\\n\\\n \\\\n\\\n \\\" <> listToText _Γ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location)\n\n displayException (InvalidOperands action left right) =\n \"Invalid operands\\n\\\n \\\\n\\\n \\You cannot \" <> Text.unpack action <> \" the following operands:\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" left) <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" right)\n\n displayException (ZeroDivisor location) =\n \"Zero divisor\\n\\\n \\\\n\\\n \\You cannot divide a number by zero:\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location)\n\n displayException (NeedConcreteDivisor location) =\n \"Divisor must be concrete\\n\\\n \\\\n\\\n \\You must divide by a concrete (non-abstract) numeric literal:\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location)\n\n displayException (FoldInvalidHandler location _A) =\n \"Invalid handler\\n\\\n \\\\n\\\n \\The fold keyword expects a record of handlers where all handlers are functions,\\n\\\n \\but you provided a handler of the following type:\\n\\\n \\\\n\\\n \\\" <> insert _A <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location) <> \"\\n\\\n \\\\n\\\n \\… which is not a function type.\"\n\n displayException (MissingAllAlternatives p₀ _Γ) =\n \"Internal error: Invalid context\\n\\\n \\\\n\\\n \\The following unsolved alternatives variable:\\n\\\n \\\\n\\\n \\\" <> insert (Context.UnsolvedAlternatives p₀) <> \"\\n\\\n \\\\n\\\n \\… cannot be instantiated because the alternatives variable is missing from the\\n\\\n \\context:\\n\\\n \\\\n\\\n \\\" <> listToText _Γ\n\n displayException (MissingAllFields p₀ _Γ) =\n \"Internal error: Invalid context\\n\\\n \\\\n\\\n \\The following unsolved fields variable:\\n\\\n \\\\n\\\n \\\" <> insert (Context.UnsolvedFields p₀) <> \"\\n\\\n \\\\n\\\n \\… cannot be instantiated because the fields variable is missing from the\\n\\\n \\context:\\n\\\n \\\\n\\\n \\\" <> listToText _Γ\n\n displayException (MissingOneOfTypes locations existential₀ existential₁ _Γ) =\n \"Internal error: Invalid context\\n\\\n \\\\n\\\n \\One of the following type variables:\\n\\\n \\\\n\\\n \\\" <> listToText [Context.UnsolvedType existential₀, Context.UnsolvedType existential₁ ] <> \"\\n\\\n \\\\n\\\n \\… is missing from the following context:\\n\\\n \\\\n\\\n \\\" <> listToText _Γ <> \"\\n\\\n \\\\n\\\n \\\" <> locations'\n where\n locations' =\n Text.unpack (Text.unlines (map (Location.renderError \"\") locations))\n\n displayException (MissingOneOfAlternatives locations p₀ p₁ _Γ) =\n \"Internal error: Invalid context\\n\\\n \\\\n\\\n \\One of the following alternatives variables:\\n\\\n \\\\n\\\n \\\" <> listToText [Context.UnsolvedAlternatives p₀, Context.UnsolvedAlternatives p₁ ] <> \"\\n\\\n \\\\n\\\n \\… is missing from the following context:\\n\\\n \\\\n\\\n \\\" <> listToText _Γ <> \"\\n\\\n \\\\n\\\n \\\" <> locations'\n where\n locations' =\n Text.unpack (Text.unlines (map (Location.renderError \"\") locations))\n\n displayException (MissingOneOfFields locations p₀ p₁ _Γ) =\n \"Internal error: Invalid context\\n\\\n \\\\n\\\n \\One of the following fields variables:\\\\n\\\n \\\\n\\\n \\\" <> listToText [Context.UnsolvedFields p₀, Context.UnsolvedFields p₁ ] <> \"\\n\\\n \\\\n\\\n \\… is missing from the following context:\\n\\\n \\\\n\\\n \\\" <> listToText _Γ <> \"\\n\\\n \\\\n\\\n \\\" <> locations'\n where\n locations' =\n Text.unpack (Text.unlines (map (Location.renderError \"\") locations))\n\n displayException (MissingVariable a _Γ) =\n \"Internal error: Invalid context\\n\\\n \\\\n\\\n \\The following unsolved variable:\\n\\\n \\\\n\\\n \\\" <> insert (Context.UnsolvedType a) <> \"\\n\\\n \\\\n\\\n \\… cannot be solved because the variable is missing from the context:\\n\\\n \\\\n\\\n \\\" <> listToText _Γ\n\n displayException (NotFunctionType location _A) =\n \"Not a function type\\n\\\n \\\\n\\\n \\An expression of the following type:\\n\\\n \\\\n\\\n \\\" <> insert _A <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location) <> \"\\n\\\n \\\\n\\\n \\… was invoked as if it were a function, but the above type is not a function\\n\\\n \\type.\"\n\n displayException (NotNecessarilyFunctionType location a) =\n \"Not necessarily a function type\\n\\\n \\\\n\\\n \\The following type variable:\\n\\\n \\\\n\\\n \\\" <> insert a <> \"\\n\\\n \\\\n\\\n \\… could potentially be any type and is not necessarily a function type.\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location)\n\n displayException (NotAlternativesSubtype location p₀ alternatives) =\n \"Not an alternatives subtype\\n\\\n \\\\n\\\n \\The following alternatives variable:\\n\\\n \\\\n\\\n \\\" <> insert p₀ <> \"\\n\\\n \\\\n\\\n \\… cannot be instantiated to the following union type:\\n\\\n \\\\n\\\n \\\" <> insert (Type.Union location alternatives) <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location) <> \"\\n\\\n \\\\n\\\n \\… because the same alternatives variable appears within that union type.\"\n\n displayException (NotFieldsSubtype location p₀ fields) =\n \"Not a fields subtype\\n\\\n \\\\n\\\n \\The following fields variable:\\n\\\n \\\\n\\\n \\\" <> insert p₀ <> \"\\n\\\n \\\\n\\\n \\… cannot be instantiated to the following record type:\\n\\\n \\\\n\\\n \\\" <> insert (Type.Record location fields) <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location) <> \"\\n\\\n \\\\n\\\n \\… because the same fields variable appears within that record type.\"\n\n displayException (NotSubtype type₀ type₁) =\n \"Not a subtype\\n\\\n \\\\n\\\n \\The following type:\\n\\\n \\\\n\\\n \\\" <> insert type₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₀)) <> \"\\n\\\n \\\\n\\\n \\… is not a subtype of:\\n\\\n \\\\n\\\n \\\" <> insert type₁ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₁))\n\n displayException (NotSubtypeOfJSON type_) =\n \"Not a subtype of JSON\\n\\\n \\\\n\\\n \\The following type:\\n\\\n \\\\n\\\n \\\" <> insert type_ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type_)) <> \"\\n\\\n \\\\n\\\n \\… is not a subtype of JSON.\"\n\n displayException (NoSupertype type₀ type₁) =\n \"No supertype\\n\\\n \\\\n\\\n \\The following two types:\\n\\\n \\\\n\\\n \\\" <> insert type₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₀)) <> \"\\n\\\n \\\\n\\\n \\\" <> insert type₁ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₁)) <> \"\\n\\\n \\\\n\\\n \\… have no shared supertype.\"\n\n displayException (NoSubtype type₀ type₁) =\n \"No subtype\\n\\\n \\\\n\\\n \\The following two types:\\n\\\n \\\\n\\\n \\\" <> insert type₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₀)) <> \"\\n\\\n \\\\n\\\n \\\" <> insert type₁ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₁)) <> \"\\n\\\n \\\\n\\\n \\… have no shared subtype.\"\n\n displayException (NoUnionSubtype type₀ type₁ extra₀ extra₁) | null extra₀ =\n \"No union subtype\\n\\\n \\\\n\\\n \\The following two union types:\\n\\\n \\\\n\\\n \\\" <> insert type₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₀)) <> \"\\n\\\n \\\\n\\\n \\\" <> insert type₁ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₁)) <> \"\\n\\\n \\\\n\\\n \\… have no shared subtype because the latter has these extra alternatives:\\n\\\n \\\" <> listToText extra₁\n\n displayException (NoUnionSubtype type₀ type₁ extra₀ extra₁) | null extra₁ =\n \"No union subtype\\n\\\n \\\\n\\\n \\The following two union types:\\n\\\n \\\\n\\\n \\\" <> insert type₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₀)) <> \"\\n\\\n \\\\n\\\n \\\" <> insert type₁ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₁)) <> \"\\n\\\n \\\\n\\\n \\… have no shared subtype because the former has these extra alternatives:\\n\\\n \\\\n\\\n \\\" <> listToText extra₀\n\n displayException (NoUnionSubtype type₀ type₁ extra₀ extra₁) =\n \"No union subtype\\n\\\n \\\\n\\\n \\The following two union types:\\n\\\n \\\\n\\\n \\\" <> insert type₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₀)) <> \"\\n\\\n \\\\n\\\n \\\" <> insert type₁ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location type₁)) <> \"\\n\\\n \\\\n\\\n \\… have no shared subtype because the former has these extra alternatives:\\n\\\n \\\\n\\\n \\\" <> listToText extra₀ <> \"\\n\\\n \\\\n\\\n \\… and the latter has these extra alternatives:\\n\\\n \\\\n\\\n \\\" <> listToText extra₁\n\n displayException (UnboundAlternatives location a) =\n \"Unbound alternatives variable: \" <> Text.unpack a <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location)\n\n displayException (UnboundFields location a) =\n \"Unbound fields variable: \" <> Text.unpack a <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location)\n\n displayException (UnboundTypeVariable location a) =\n \"Unbound type variable: \" <> Text.unpack a <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location)\n\n displayException (UnboundVariable location name) =\n \"Unbound variable: \" <> Text.unpack var <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location)\n where\n var = Grace.Pretty.toSmart @(Syntax.Syntax () Void) Syntax.Variable{ location = (), .. }\n\n displayException (RecordTypeMismatch _A₀ _B₀ extraB) | null extraB =\n \"Record type mismatch\\n\\\n \\\\n\\\n \\The following record type:\\n\\\n \\\\n\\\n \\\" <> insert _A₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location _A₀)) <> \"\\n\\\n \\\\n\\\n \\… is not a subtype of the following record type:\\n\\\n \\\\n\\\n \\\" <> insert _B₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location _B₀))\n\n displayException (RecordTypeMismatch _A₀ _B₀ extraB) =\n \"Record type mismatch\\n\\\n \\\\n\\\n \\The following record type:\\n\\\n \\\\n\\\n \\\" <> insert _A₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location _A₀)) <> \"\\n\\\n \\\\n\\\n \\… is not a subtype of the following record type:\\n\\\n \\\\n\\\n \\\" <> insert _B₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location _B₀)) <> \"\\n\\\n \\\\n\\\n \\The latter record has the following extra fields:\\n\\\n \\\\n\\\n \\\" <> listToText extraB\n\n displayException (UnionTypeMismatch _A₀ _B₀ extraA) | null extraA =\n \"Union type mismatch\\n\\\n \\\\n\\\n \\The following union type:\\n\\\n \\\\n\\\n \\\" <> insert _A₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location _A₀)) <> \"\\n\\\n \\\\n\\\n \\… is not a subtype of the following union type:\\n\\\n \\\\n\\\n \\\" <> insert _B₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location _B₀))\n\n displayException (UnionTypeMismatch _A₀ _B₀ extraA) =\n \"Union type mismatch\\n\\\n \\\\n\\\n \\The following union type:\\n\\\n \\\\n\\\n \\\" <> insert _A₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location _A₀)) <> \"\\n\\\n \\\\n\\\n \\… is not a subtype of the following union type:\\n\\\n \\\\n\\\n \\\" <> insert _B₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" (Type.location _B₀)) <> \"\\n\\\n \\\\n\\\n \\The former union has the following extra alternatives:\\n\\\n \\\\n\\\n \\\" <> listToText extraA\n\n displayException (FieldsVariableMismatch location₀ remainingFields₀ location₁ remainingFields₁) =\n \"Fields variable mismatch\\n\\\n \\\\n\\\n \\This fields variable:\\n\\\n \\\\n\\\n \\\" <> insert remainingFields₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location₀) <> \"\\n\\\n \\\\n\\\n \\… and this fields variable:\\n\\\n \\\\n\\\n \\\" <> insert remainingFields₁ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location₁) <> \"\\n\\\n \\\\n\\\n \\… cannot be unified\"\n\n displayException (AlternativesVariableMismatch location₀ remainingAlternatives₀ location₁ remainingAlternatives₁) =\n \"Alternatives variable mismatch\\n\\\n \\\\n\\\n \\This alternatives variable:\\n\\\n \\\\n\\\n \\\" <> insert remainingAlternatives₀ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location₀) <> \"\\n\\\n \\\\n\\\n \\… and this alternatives variable:\\n\\\n \\\\n\\\n \\\" <> insert remainingAlternatives₁ <> \"\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location₁) <> \"\\n\\\n \\\\n\\\n \\… cannot be unified\"\n\ndata AssignmentMismatch = AssignmentMismatch\n { location₀ :: Location\n , location₁ :: Location\n } deriving stock (Eq, Show)\n\ninstance Exception AssignmentMismatch where\n displayException AssignmentMismatch{ location₀, location₁ } =\n \"Assignment mismatch\\n\\\n \\\\n\\\n \\You cannot mix a List comprehension like this one:\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location₀) <> \"\\n\\\n \\\\n\\\n \\… with an Optional comprehension like this one:\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Location.renderError \"\" location₁)\n\n-- | Invalid JSON output which didn't match the expected type\ndata InvalidJSON a = InvalidJSON\n { path :: [Text]\n , value :: Aeson.Value\n , type_ :: Type a\n } deriving stock (Show)\n\ninstance (Show a, Typeable a) => Exception (InvalidJSON a) where\n displayException InvalidJSON{ path, value, type_} =\n \"Invalid JSON\\n\\\n \\\\n\\\n \\The following JSON value:\\n\\\n \\\\n\\\n \\\" <> string <> \"\\n\\\n \\\\n\\\n \\… does not match the following expected type:\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Grace.Pretty.toSmart type_) <> \"\\n\\\n \\\\n\\\n \\… at the following location:\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Text.intercalate \".\" (reverse path))\n where\n bytes = Aeson.Pretty.encodePretty value\n\n string = case Encoding.decodeUtf8' (ByteString.Lazy.toStrict bytes) of\n Left _ -> show bytes\n Right text -> Text.unpack text\n\n-- Helper functions for displaying errors\n\ninsert :: Pretty a => a -> String\ninsert a = Text.unpack (Grace.Pretty.toSmart (\" \" <> Pretty.align (pretty a)))\n\nlistToText :: Pretty a => [a] -> String\nlistToText elements =\n Text.unpack (Text.intercalate \"\\n\" (map prettyEntry elements))\n where\n prettyEntry entry =\n Grace.Pretty.toSmart (\"• \" <> Pretty.align (pretty entry))\n" }, { "path": "src/Grace/Input.hs", "content": "-- | This module contains the functions and types that power the URI-based imports\nmodule Grace.Input\n ( -- * Input\n Input(..)\n , Mode(..)\n ) where\n\nimport Data.List.NonEmpty (NonEmpty(..))\nimport Data.Text (Text)\nimport Grace.Pretty (Pretty(..))\nimport System.FilePath (())\n\nimport qualified Data.List as List\nimport qualified Data.Text as Text\nimport qualified Grace.Pretty as Pretty\nimport qualified System.FilePath as FilePath\nimport qualified Text.URI as URI\n\n{-| Input to the interpreter.\n\n You should prefer to use `Path` and `URI` if possible (for better error\n messages and correctly handling transitive imports). The `Code` constructor\n is intended for cases like interpreting code read from standard input.\n-}\ndata Input\n = Path FilePath Mode\n -- ^ The path to the code\n | Code String Text\n -- ^ Source code: @Code name content@\n | URI URI.URI Mode\n deriving stock (Eq, Show)\n\ninstance Semigroup Input where\n _ <> URI uri mode = URI uri mode\n\n _ <> Code name code = Code name code\n\n Code _ _ <> Path child mode = Path child mode\n Path parent _ <> Path child mode =\n Path (FilePath.takeDirectory parent child) mode\n URI parent _ <> Path child mode\n | FilePath.isRelative child\n , Just uri <- URI.relativeTo childURI parent =\n URI uri mode\n | otherwise =\n Path child mode\n where\n stripped = case List.stripPrefix \"./\" child of\n Nothing -> child\n Just suffix -> suffix\n\n uriPath = do\n c : cs <- traverse (URI.mkPathPiece . Text.pack) (FilePath.splitPath stripped)\n\n return (FilePath.hasTrailingPathSeparator child, c :| cs)\n\n childURI =\n URI.URI\n { URI.uriScheme = Nothing\n , URI.uriAuthority = Left False\n , URI.uriPath = uriPath\n , URI.uriQuery = []\n , URI.uriFragment = Nothing\n }\n\ninstance Pretty Input where\n pretty (Code _ code) = pretty code\n pretty (Path path mode) = pretty path <> pretty mode\n pretty (URI uri mode) = pretty uri <> pretty mode\n\n-- | How the imported string is interpreted\ndata Mode\n = AsCode\n -- ^ Interpret the string as Grace code (the default)\n | AsText\n -- ^ Interpret the string as raw Text\n | AsKey\n -- ^ Interpret the string as a Key\n deriving stock (Eq, Show)\n\ninstance Semigroup Mode where\n mode <> AsCode = mode\n\n _ <> mode = mode\n\ninstance Pretty Mode where\n pretty AsCode = mempty\n pretty AsText =\n \" \" <> Pretty.punctuation \":\" <> \" \" <> Pretty.builtin \"Text\"\n pretty AsKey =\n \" \" <> Pretty.punctuation \":\" <> \" \" <> Pretty.builtin \"Key\"\n" }, { "path": "src/Grace/Interpret.hs", "content": "{-# LANGUAGE ExistentialQuantification #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE TypeApplications #-}\n\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n\n-- | This module implements the main interpretation function\nmodule Grace.Interpret\n ( -- * Interpret\n Input(..)\n , interpret\n , (<~)\n , interpretWith\n\n -- * Load\n , load\n , loadWith\n ) where\n\nimport Control.Monad.IO.Class (MonadIO, liftIO)\nimport Data.Text (Text)\nimport Grace.Decode (FromGrace(..))\nimport Grace.Encode (ToGrace(..), ToGraceType(..))\nimport Grace.Input (Input(..), Mode(..))\nimport Grace.Location (Location(..))\nimport Grace.Monad (Grace, Status(..))\nimport Grace.Type (Type)\nimport Grace.Value (Value)\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Control.Monad.Reader as Reader\nimport qualified Control.Monad.State as State\nimport qualified Grace.Context as Context\nimport qualified Grace.Import as Import\nimport qualified Grace.Infer as Infer\nimport qualified Grace.Monad as Grace\nimport qualified Grace.Normalize as Normalize\nimport qualified Grace.Pretty as Pretty\nimport qualified Grace.Syntax as Syntax\nimport qualified Grace.Type as Type\nimport qualified Grace.Value as Value\n\n{-| Interpret Grace source code, return the inferred type and the evaluated\n result\n\n This is the top-level function for the Grace interpreter\n-}\ninterpret :: MonadIO io => Input -> io (Type Location, Value Location)\ninterpret input = do\n let initialStatus = Status{ count = 0, context = [] }\n\n ((inferred, value), Status{ context }) <- do\n Grace.runGrace input initialStatus (interpretWith [] Nothing)\n\n return (Context.complete context inferred, Value.complete context value)\n\n{-| Convenient operator for creating a binding from a Haskell value rather than\n a Grace type and value\n-}\n(<~)\n :: forall a . ToGrace a\n => Text -> a -> (Text, Type Location, Value Location)\nname <~ haskellValue =\n ( name\n , fmap (\\_ -> Unknown) (expected @a)\n , fmap (\\_ -> Unknown) (encode haskellValue)\n )\n\n-- | Like `interpret`, but accepts a custom list of bindings\ninterpretWith\n :: [(Text, Type Location, Value Location)]\n -- ^ @(name, type, value)@ for each custom binding\n -> Maybe (Type Location)\n -- ^ Optional expected type for the input\n -> Grace (Type Location, Value Location)\ninterpretWith bindings maybeAnnotation = do\n input <- Reader.ask\n\n expression <- liftIO (Import.resolve AsCode input)\n\n let annotatedExpression = case maybeAnnotation of\n Just annotation ->\n Syntax.Annotation\n { annotated = expression\n , annotation\n , location = Syntax.location expression\n }\n Nothing ->\n expression\n\n let typeContext = do\n (variable, type_, _) <- bindings\n\n return (Context.Annotation variable type_)\n\n State.modify (\\status -> status{ context = typeContext <> context status })\n\n (inferred, elaboratedExpression) <- Infer.infer annotatedExpression\n\n let evaluationContext = do\n (variable, _, value) <- bindings\n\n return (variable, value)\n\n value <- Normalize.evaluate evaluationContext elaboratedExpression\n\n return (inferred, value)\n\n-- | Load a Grace expression\nload :: forall m a . (FromGrace a, MonadIO m) => Input -> m a\nload = loadWith []\n\n-- | Like `load`, but accepts a custom list of bindings\nloadWith\n :: forall m a . (FromGrace a, MonadIO m)\n => [(Text, Type Location, Value Location)] -> Input -> m a\nloadWith bindings input = do\n let type_ = fmap (\\_ -> Unknown) (expected @a)\n\n let initialStatus = Status{ count = 0, context = [] }\n\n (_, value) <- Grace.evalGrace input initialStatus (interpretWith bindings (Just type_) )\n\n case decode value of\n Left exception -> liftIO (Exception.throwIO exception)\n Right a -> return a\n\ninstance (ToGrace a, FromGrace b) => FromGrace (a -> IO b) where\n decode function = do\n return \\a -> do\n let inputValue = fmap (\\_ -> Unknown) (encode a)\n\n let initialStatus = Status{ count = 0, context = [] }\n\n let code = Pretty.toText inputValue\n\n let input = Code \"(decode)\" code\n\n outputValue <- Grace.evalGrace input initialStatus (Normalize.apply Unknown function inputValue)\n\n case decode outputValue of\n Left e -> Exception.throwIO e\n Right b -> return b\n\ninstance (ToGraceType a, ToGraceType b) => ToGraceType (a -> IO b) where\n expected = Type.Function\n { location = ()\n , input = expected @a\n , output = expected @b\n }\n" }, { "path": "src/Grace/Interpret.hs-boot", "content": "{-# LANGUAGE FlexibleContexts #-}\n\nmodule Grace.Interpret where\n\nimport Data.Text (Text)\nimport Grace.Location (Location)\nimport Grace.Monad (Grace)\nimport Grace.Type (Type)\nimport Grace.Value (Value)\n\n-- | Like `interpret`, but accepts a custom list of bindings\ninterpretWith\n :: [(Text, Type Location, Value Location )]\n -- ^ @(name, type, value)@ for each custom binding\n -> Maybe (Type Location)\n -- ^ Optional expected type for the input\n -> Grace (Type Location, Value Location)\n" }, { "path": "src/Grace/Label.hs", "content": "{-| This module provides label-related logic shared by the parser and\n pretty-printer\n-}\nmodule Grace.Label\n ( -- * Reserved tokens\n reservedLabels\n , reservedRecordLabels\n\n -- * Character matching\n , isLabel0\n , isAlternativeLabel0\n , isLabel\n\n -- * Label quoting\n , validLabel\n , validRecordLabel\n , validAlternativeLabel\n ) where\n\nimport Data.HashSet (HashSet)\nimport Data.Text (Text)\n\nimport qualified Data.Char as Char\nimport qualified Data.HashSet as HashSet\nimport qualified Data.Text as Text\n\n-- | Is this character valid as the first character in an unquoted label?\nisLabel0 :: Char -> Bool\nisLabel0 c = Char.isLower c || c == '_'\n\n-- | Is this character valid as the first character in an unquoted alternative\n-- label?\nisAlternativeLabel0 :: Char -> Bool\nisAlternativeLabel0 = Char.isUpper\n\n-- | Is this character valid as a follow-up character in an unquoted label?\nisLabel :: Char -> Bool\nisLabel c = Char.isAlphaNum c || c == '_' || c == '-' || c == '/'\n\n-- | Returns `True` if the given label is valid when unquoted\nvalidLabel :: Text -> Bool\nvalidLabel text_ =\n case Text.uncons text_ of\n Nothing ->\n False\n Just (h, t) ->\n isLabel0 h\n && Text.all isLabel t\n && not (HashSet.member text_ reservedLabels)\n\n-- | Returns `True` if the given record label is valid when unquoted\nvalidRecordLabel :: Text -> Bool\nvalidRecordLabel text_ =\n case Text.uncons text_ of\n Nothing -> False\n Just (h, t) ->\n isLabel0 h\n && Text.all isLabel t\n && not (HashSet.member text_ reservedRecordLabels)\n\n-- | Returns `True` if the given alternative label is valid when unquoted\nvalidAlternativeLabel :: Text -> Bool\nvalidAlternativeLabel text_ =\n case Text.uncons text_ of\n Nothing ->\n False\n Just (h, t) ->\n isAlternativeLabel0 h\n && Text.all isLabel t\n && not (HashSet.member text_ reservedLabels)\n\n-- | Reserved tokens, which can't be used for labels unless they are quoted\nreservedLabels :: HashSet Text\nreservedLabels =\n HashSet.union\n (HashSet.fromList [ \"some\", \"null\", \"true\", \"false\" ])\n reservedRecordLabels\n\nreservedRecordLabels :: HashSet Text\nreservedRecordLabels = HashSet.fromList\n [ \"Alternatives\"\n , \"Bool\"\n , \"Fields\"\n , \"Integer\"\n , \"List\"\n , \"Natural\"\n , \"Optional\"\n , \"Real\"\n , \"Text\"\n , \"Type\"\n , \"abs\"\n , \"else\"\n , \"export\"\n , \"fold\"\n , \"for\"\n , \"forall\"\n , \"github\"\n , \"http\"\n , \"if\"\n , \"import\"\n , \"in\"\n , \"indexed\"\n , \"length\"\n , \"let\"\n , \"map\"\n , \"of\"\n , \"prompt\"\n , \"read\"\n , \"reveal\"\n , \"show\"\n , \"then\"\n , \"yaml\"\n ]\n" }, { "path": "src/Grace/Location.hs", "content": "{-| This module contains the `Location` type used for attaching source code to\n error messages\n-}\nmodule Grace.Location\n ( -- * Location\n Location(..)\n , Offset(..)\n , renderError\n ) where\n\nimport Data.Text (Text)\nimport Text.Megaparsec (PosState(..), SourcePos(..))\n\nimport qualified Data.Text as Text\nimport qualified Text.Megaparsec.Pos as Pos\nimport qualified Text.Megaparsec.Stream as Stream\n\n-- | Offsets are stored in characters (0-indexed)\nnewtype Offset = Offset { getOffset :: Int }\n deriving newtype (Eq, Num, Show)\n\n-- | This type stores the location of each subexpression\ndata Location\n = Location\n { name :: String\n -- ^ The file or name describing where the code came from\n , code :: Text\n -- ^ The original source code (the entire file)\n --\n -- Note that this will not always be the same for each `Location`\n -- because different subexpressions might originate from different\n -- files if they were imported\n , offset :: Offset\n -- ^ The offset (in characters) within the code\n }\n | Unknown\n deriving stock (Eq, Show)\n\n-- | Render an error message, given a `Location` for the error\nrenderError\n :: Text\n -- ^ Error message\n -> Location\n -- ^ Location of the error\n -> Text\nrenderError message Location{ name, code, offset } = prefix <> \"\\n\" <> suffix\n where\n initialState = PosState\n { pstateInput = code\n , pstateOffset = 0\n , pstateSourcePos = Pos.initialPos name\n , pstateTabWidth = Pos.defaultTabWidth\n , pstateLinePrefix = \"\"\n }\n\n (h, state) = Stream.reachOffset (getOffset offset) initialState\n\n pos = pstateSourcePos state\n\n line = Pos.unPos (sourceLine pos)\n\n column = Pos.unPos (sourceColumn pos)\n\n suffix = case h of\n Just string ->\n let lineText = Text.pack (show line)\n\n inner = lineText <> \" │\"\n\n outer = Text.replicate (Text.length lineText) \" \" <> \" │\"\n\n caret = Text.replicate (column - 1) \" \" <> \"↑\"\n\n in outer <> \"\\n\\\n \\\" <> inner <> \" \" <> Text.pack string <> \"\\n\\\n \\\" <> outer <> \" \" <> caret\n Nothing ->\n \"\"\n\n prefix =\n Text.pack name\n <> \":\"\n <> Text.pack (show line)\n <> \":\"\n <> Text.pack (show column)\n <> \": \"\n <> message\nrenderError message Unknown = message\n" }, { "path": "src/Grace/Marshal.hs", "content": "{-# LANGUAGE AllowAmbiguousTypes #-}\n\n-- | Internal module shared between \"Grace.Decode\" and \"Grace.Encode\"\nmodule Grace.Marshal\n ( Key(..)\n , ToGraceType(..)\n , GenericToGraceType(..)\n , selector\n ) where\n\nimport Control.Monad.State (State)\nimport Data.Aeson (FromJSON, ToJSON)\nimport Data.Int (Int8, Int16, Int32, Int64)\nimport Data.Scientific (Scientific)\nimport Data.Sequence (Seq)\nimport Data.String (IsString)\nimport Data.Text (Text)\nimport Data.Word (Word8, Word16, Word32, Word64)\nimport Data.Vector (Vector)\nimport Data.Void (Void)\nimport Grace.Type (Type)\nimport Numeric.Natural (Natural)\n\nimport GHC.Generics\n ( Generic(..)\n , C\n , Constructor\n , D\n , K1(..)\n , M1(..)\n , Rep\n , S\n , Selector\n , U1(..)\n , V1\n , (:+:)(..)\n , (:*:)(..)\n )\n\nimport qualified Control.Monad.State as State\nimport qualified Data.Aeson as Aeson\nimport qualified Data.Kind as Kind\nimport qualified Data.Text as Text\nimport qualified Data.Text.Lazy as Text.Lazy\nimport qualified GHC.Generics as Generics\nimport qualified Grace.Monotype as Monotype\nimport qualified Grace.Type as Type\n\n-- | A protected `Text` value\nnewtype Key = Key{ text :: Text }\n deriving newtype (Eq, IsString, Show, FromJSON, ToJSON)\n\nselector :: Selector s => M1 S s f r -> State Int Text\nselector m1 = do\n let name₀ = Generics.selName m1\n\n if name₀ == \"\"\n then do\n n <- State.get\n\n State.put $! n + 1\n\n return (Text.pack (show n))\n else do\n return (Text.pack name₀)\n\n-- | Convert a Haskell type to a Grace type\nclass ToGraceType a where\n expected :: Type ()\n default expected :: (Generic a, GenericToGraceType (Rep a)) => Type ()\n expected = State.evalState (genericExpected @(Rep a)) 0\n\ninstance ToGraceType Void\ninstance ToGraceType ()\ninstance (ToGraceType a, ToGraceType b) => ToGraceType (a, b)\ninstance (ToGraceType a, ToGraceType b) => ToGraceType (Either a b)\n\ninstance ToGraceType Bool where\n expected = Type.Scalar{ location = (), scalar = Monotype.Bool }\n\ninstance ToGraceType Natural where\n expected = Type.Scalar{ location = (), scalar = Monotype.Natural }\n\ninstance ToGraceType Word where\n expected = expected @Natural\n\ninstance ToGraceType Word8 where\n expected = expected @Natural\n\ninstance ToGraceType Word16 where\n expected = expected @Natural\n\ninstance ToGraceType Word32 where\n expected = expected @Natural\n\ninstance ToGraceType Word64 where\n expected = expected @Natural\n\ninstance ToGraceType Integer where\n expected = Type.Scalar{ location = (), scalar = Monotype.Integer }\n\ninstance ToGraceType Int where\n expected = expected @Integer\n\ninstance ToGraceType Int8 where\n expected = expected @Integer\n\ninstance ToGraceType Int16 where\n expected = expected @Integer\n\ninstance ToGraceType Int32 where\n expected = expected @Integer\n\ninstance ToGraceType Int64 where\n expected = expected @Integer\n\ninstance ToGraceType Scientific where\n expected = Type.Scalar{ location = (), scalar = Monotype.Real }\n\ninstance ToGraceType Double where\n expected = expected @Scientific\n\ninstance ToGraceType Float where\n expected = expected @Scientific\n\ninstance ToGraceType Text where\n expected = Type.Scalar{ location = (), scalar = Monotype.Text }\n\ninstance ToGraceType Text.Lazy.Text where\n expected = expected @Text\n\ninstance {-# OVERLAPPING #-} ToGraceType [Char] where\n expected = expected @Text\n\ninstance ToGraceType Key where\n expected = Type.Scalar{ location = (), scalar = Monotype.Key }\n\ninstance ToGraceType Aeson.Value where\n expected = Type.Scalar{ location = (), scalar = Monotype.JSON }\n\ninstance ToGraceType a => ToGraceType (Seq a) where\n expected = Type.List{ location = (), type_ = expected @a }\n\ninstance ToGraceType a => ToGraceType [a] where\n expected = expected @(Seq a)\n\ninstance ToGraceType a => ToGraceType (Vector a) where\n expected = expected @[a]\n\ninstance ToGraceType a => ToGraceType (Maybe a) where\n expected = Type.Optional{ location = (), type_ = expected @a }\n\n{-| This is the underlying class that powers the `ToGraceType` class's support\n for automatically deriving a `Generic` implementation\n-}\nclass GenericToGraceType (f :: Kind.Type -> Kind.Type) where\n genericExpected :: State Int (Type ())\n\ninstance GenericToGraceType V1 where\n genericExpected = do\n return Type.Union\n { location = ()\n , alternatives = Type.Alternatives [] Monotype.EmptyAlternatives\n }\n\ninstance GenericToGraceType U1 where\n genericExpected = do\n return Type.Record\n { location = ()\n , fields = Type.Fields [] Monotype.EmptyFields\n }\n\ninstance GenericToGraceType f => GenericToGraceType (M1 D d f) where\n genericExpected = genericExpected @f\n\ninstance GenericToGraceType f => GenericToGraceType (M1 C d f) where\n genericExpected = genericExpected @f\n\ninstance (Selector s, ToGraceType a) => GenericToGraceType (M1 S s (K1 i a)) where\n genericExpected = do\n let m1 :: M1 S s (K1 i a) r\n m1 = undefined\n\n name <- selector m1\n\n if Generics.selName m1 == \"\"\n then do\n return (expected @a)\n else do\n return Type.Record\n { location = ()\n , fields =\n Type.Fields [ (name, expected @a) ] Monotype.EmptyFields\n }\n\ninstance (Selector s₀, Selector s₁, ToGraceType a₀, ToGraceType a₁) => GenericToGraceType (M1 S s₀ (K1 i₀ a₀) :*: M1 S s₁ (K1 i₁ a₁)) where\n genericExpected = do\n name₀ <- selector (undefined :: M1 S s₀ (K1 i₀ a₀) r)\n name₁ <- selector (undefined :: M1 S s₁ (K1 i₁ a₁) r)\n\n return Type.Record\n { location = ()\n , fields = Type.Fields\n [ (name₀, expected @a₀)\n , (name₁, expected @a₁)\n ]\n Monotype.EmptyFields\n }\n\ninstance (Selector s, GenericToGraceType (f₀ :*: f₁), ToGraceType a) => GenericToGraceType ((f₀ :*: f₁) :*: M1 S s (K1 i a)) where\n genericExpected = do\n expected₀ <- genericExpected @(f₀ :*: f₁)\n\n name <- selector (undefined :: M1 S s (K1 i a) r)\n\n return Type.Record\n { location = ()\n , fields = Type.Fields\n ((name, expected @a) : unsafeExpectRecordType expected₀)\n Monotype.EmptyFields\n }\n\ninstance (Selector s, ToGraceType a, GenericToGraceType (f₀ :*: f₁)) => GenericToGraceType (M1 S s (K1 i a) :*: (f₀ :*: f₁)) where\n genericExpected = do\n name <- selector (undefined :: M1 S s (K1 i a) r)\n\n expected₁ <- genericExpected @(f₀ :*: f₁)\n\n return Type.Record\n { location = ()\n , fields = Type.Fields\n ((name, expected @a) : unsafeExpectRecordType expected₁)\n Monotype.EmptyFields\n }\n\ninstance (GenericToGraceType (f₀ :*: f₁), GenericToGraceType (f₂ :*: f₃)) => GenericToGraceType ((f₀ :*: f₁) :*: (f₂ :*: f₃)) where\n genericExpected = do\n expected₀ <- genericExpected @(f₀ :*: f₁)\n expected₁ <- genericExpected @(f₂ :*: f₃)\n\n return Type.Record\n { location = ()\n , fields = Type.Fields\n ( unsafeExpectRecordType expected₀\n <> unsafeExpectRecordType expected₁\n )\n Monotype.EmptyFields\n }\n\ninstance (Constructor c₀, Constructor c₁, GenericToGraceType f₀, GenericToGraceType f₁) => GenericToGraceType (M1 C c₀ f₀ :+: M1 C c₁ f₁) where\n genericExpected = do\n let name₀ = Text.pack (Generics.conName (undefined :: M1 C c₀ f₀ r))\n let name₁ = Text.pack (Generics.conName (undefined :: M1 C c₁ f₁ r))\n\n let expected₀ = State.evalState (genericExpected @f₀) 0\n let expected₁ = State.evalState (genericExpected @f₁) 0\n\n return Type.Union\n { location = ()\n , alternatives = Type.Alternatives\n [ (name₀, expected₀), (name₁, expected₁) ]\n Monotype.EmptyAlternatives\n }\n\ninstance (Constructor c, GenericToGraceType f₀, GenericToGraceType (f₁ :+: f₂)) => GenericToGraceType (M1 C c f₀ :+: (f₁ :+: f₂)) where\n genericExpected = do\n let name₀ = Text.pack (Generics.conName (undefined :: M1 C c f r))\n\n let expected₀ = State.evalState (genericExpected @f₀ ) 0\n let expected₁ = State.evalState (genericExpected @(f₁ :+: f₂)) 0\n\n return Type.Union\n { location = ()\n , alternatives = Type.Alternatives\n ((name₀, expected₀) : unsafeExpectUnionType expected₁)\n Monotype.EmptyAlternatives\n }\n\ninstance (Constructor c, GenericToGraceType (f₀ :+: f₁), GenericToGraceType f₂) => GenericToGraceType ((f₀ :+: f₁) :+: M1 C c f₂) where\n genericExpected = do\n let name₁ = Text.pack (Generics.conName (undefined :: M1 C c f r))\n\n let expected₀ = State.evalState (genericExpected @(f₀ :+: f₁)) 0\n let expected₁ = State.evalState (genericExpected @f₂) 0\n\n return Type.Union\n { location = ()\n , alternatives = Type.Alternatives\n (unsafeExpectUnionType expected₀ <> [ (name₁, expected₁) ])\n Monotype.EmptyAlternatives\n }\n\ninstance (GenericToGraceType (f₀ :+: f₁), GenericToGraceType (f₂ :+: f₃)) => GenericToGraceType ((f₀ :+: f₁) :+: (f₂ :+: f₃)) where\n genericExpected = do\n let expected₀ = State.evalState (genericExpected @(f₀ :+: f₁)) 0\n let expected₁ = State.evalState (genericExpected @(f₂ :+: f₃)) 0\n\n return Type.Union\n { location = ()\n , alternatives = Type.Alternatives\n (unsafeExpectUnionType expected₀ <> unsafeExpectUnionType expected₁)\n Monotype.EmptyAlternatives\n }\n\nunsafeExpectRecordType :: Type s -> [(Text, Type s)]\nunsafeExpectRecordType Type.Record{ fields = Type.Fields fieldTypes _ } =\n fieldTypes\nunsafeExpectRecordType _ =\n error \"Grace.Decode.unsafeExpectRecordType: not a record\"\n\nunsafeExpectUnionType :: Type s -> [(Text, Type s)]\nunsafeExpectUnionType Type.Union{ alternatives = Type.Alternatives alternativeTypes _ } =\n alternativeTypes\nunsafeExpectUnionType _ =\n error \"Grace.Decode.unsafeExpectUnionType: not a union\"\n" }, { "path": "src/Grace/Monad.hs", "content": "{-| This module contains the `Grace` `Monad` shared by type inference and\n evaluation\n-}\nmodule Grace.Monad\n ( -- * Monad\n Status(..)\n , Grace(..)\n , runGrace\n , evalGrace\n , execGrace\n ) where\n\nimport Control.Monad.Catch (MonadThrow(..), MonadCatch(..))\nimport Control.Monad.IO.Class (MonadIO(..))\nimport Control.Monad.Reader (MonadReader, ReaderT)\nimport Control.Monad.State (MonadState, StateT)\nimport Grace.Context (Context)\nimport Grace.Input (Input)\nimport Grace.Location (Location)\nimport Grace.Parallelizable (Parallelizable)\n\nimport qualified Control.Monad.Reader as Reader\nimport qualified Control.Monad.State as State\nimport qualified Grace.Parallelizable as Parallelizable\n\n-- | Interpretation state\ndata Status = Status\n { count :: !Int\n -- ^ Used to generate fresh unsolved variables (e.g. α̂, β̂ from the\n -- original paper)\n\n , context :: Context Location\n -- ^ The type-checking context (e.g. Γ, Δ, Θ)\n }\n\n-- | The shared `Monad` threaded throughout all phases of interpretation\nnewtype Grace a = Grace{ parallelizable :: ReaderT Input (Parallelizable (StateT Status IO)) a }\n deriving newtype\n ( Functor\n , Applicative\n , Monad\n , MonadCatch\n , MonadIO\n , MonadReader Input\n , MonadState Status\n , MonadThrow\n )\n\n-- | Run the `Grace` `Monad`, preserving the result and final `Status`\nrunGrace :: MonadIO io => Input -> Status -> Grace a -> io (a, Status)\nrunGrace input status Grace{ parallelizable } =\n liftIO (State.runStateT (Parallelizable.serialize (Reader.runReaderT parallelizable input)) status)\n\n-- | Run the `Grace` `Monad`, discarding the final `Status`\nevalGrace :: MonadIO io => Input -> Status -> Grace a -> io a\nevalGrace input status Grace{ parallelizable } =\n liftIO (State.evalStateT (Parallelizable.serialize (Reader.runReaderT parallelizable input)) status)\n\n-- | Run the `Grace` `Monad`, discarding the result\nexecGrace :: MonadIO io => Input -> Status -> Grace a -> io Status\nexecGrace input status Grace{ parallelizable } =\n liftIO (State.execStateT (Parallelizable.serialize (Reader.runReaderT parallelizable input)) status)\n" }, { "path": "src/Grace/Monotype.hs", "content": "{-| This module stores the `Monotype` type representing monomorphic types and\n utilites for operating on `Monotype`s\n-}\nmodule Grace.Monotype\n ( -- * Types\n Monotype(..)\n , Scalar(..)\n , Record(..)\n , RemainingFields(..)\n , Union(..)\n , RemainingAlternatives(..)\n ) where\n\nimport Data.String (IsString(..))\nimport Data.Text (Text)\nimport GHC.Generics (Generic)\nimport Grace.Existential (Existential)\nimport Grace.Pretty (Pretty(..), builtin, label)\nimport Language.Haskell.TH.Syntax (Lift)\n\n{-| A monomorphic type\n\n This is same type as `Grace.Type.Type`, except without the\n `Grace.Type.Forall` and `Grace.Type.Exists` constructors\n-}\ndata Monotype\n = VariableType Text\n | UnsolvedType (Existential Monotype)\n | Function Monotype Monotype\n | Optional Monotype\n | List Monotype\n | Record Record\n | Union Union\n | Scalar Scalar\n deriving stock (Eq, Generic, Show)\n\ninstance IsString Monotype where\n fromString string = VariableType (fromString string)\n\n-- | A scalar type\ndata Scalar\n = Bool\n -- ^ Boolean type\n --\n -- >>> pretty Bool\n -- Bool\n | Real\n -- ^ Real number type\n --\n -- >>> pretty Real\n -- Real\n | Integer\n -- ^ Integer number type\n --\n -- >>> pretty Integer\n -- Integer\n | JSON\n -- ^ JSON type\n --\n -- >>> pretty JSON\n -- JSON\n | Natural\n -- ^ Natural number type\n --\n -- >>> pretty Natural\n -- Natural\n | Text\n -- ^ Text type\n --\n -- >>> pretty Text\n -- Text\n | Key\n -- ^ Key type\n --\n -- >>> pretty Key\n -- Key\n deriving stock (Eq, Generic, Lift, Show)\n\ninstance Pretty Scalar where\n pretty Bool = builtin \"Bool\"\n pretty Real = builtin \"Real\"\n pretty JSON = builtin \"JSON\"\n pretty Natural = builtin \"Natural\"\n pretty Integer = builtin \"Integer\"\n pretty Text = builtin \"Text\"\n pretty Key = builtin \"Key\"\n\n-- | A monomorphic record type\ndata Record = Fields [(Text, Monotype)] RemainingFields\n deriving stock (Eq, Generic, Show)\n\n-- | This represents whether or not the record type is open or closed\ndata RemainingFields\n = EmptyFields\n -- ^ The record type is closed, meaning that all fields are known\n | UnsolvedFields (Existential Record)\n -- ^ The record type is open, meaning that some fields are known and there\n -- is an unsolved fields variable that is a placeholder for other fields\n -- that may or may not be present\n | VariableFields Text\n -- ^ Same as `UnsolvedFields`, except that the user has given the fields\n -- variable an explicit name in the source code\n deriving stock (Eq, Generic, Lift, Show)\n\ninstance Pretty RemainingFields where\n pretty EmptyFields =\n mempty\n pretty (UnsolvedFields existential) =\n label (pretty existential <> \"?\")\n pretty (VariableFields name) =\n label (pretty name)\n\n-- | A monomorphic union type\ndata Union = Alternatives [(Text, Monotype)] RemainingAlternatives\n deriving stock (Eq, Generic, Show)\n\n-- | This represents whether or not the union type is open or closed\ndata RemainingAlternatives\n = EmptyAlternatives\n -- ^ The union type is closed, meaning that all alternatives are known\n | UnsolvedAlternatives (Existential Union)\n -- ^ The union type is open, meaning that some alternatives are known and\n -- there is an unsolved alternatives variable that is a placeholder for\n -- other alternatives that may or may not be present\n | VariableAlternatives Text\n -- ^ Same as `UnsolvedAlternatives`, except that the user has given the\n -- alternatives variable an explicit name in the source code\n deriving stock (Eq, Generic, Lift, Show)\n\ninstance Pretty RemainingAlternatives where\n pretty EmptyAlternatives =\n mempty\n pretty (UnsolvedAlternatives existential) =\n label (pretty existential <> \"?\")\n pretty (VariableAlternatives name) =\n label (pretty name)\n" }, { "path": "src/Grace/Normalize.hs", "content": "{-# LANGUAGE OverloadedLists #-}\n{-# LANGUAGE RecordWildCards #-}\n\n-- | This module contains the logic for efficiently evaluating an expression\nmodule Grace.Normalize\n ( -- * Normalization\n evaluate\n , apply\n , Value.quote\n , strip\n\n -- * Errors related to normalization\n , MissingCredentials(..)\n , Prompt.UnsupportedModelOutput(..)\n , JSONDecodingFailed(..)\n , MissingSchema(..)\n ) where\n\nimport Control.Exception.Safe (Exception(..))\nimport Control.Monad.IO.Class (MonadIO(..))\nimport Data.Foldable (toList)\nimport Data.Functor (void)\nimport Data.HashMap.Strict.InsOrd (InsOrdHashMap)\nimport Data.Sequence (ViewL(..))\nimport Data.Text (Text)\nimport Data.Void (Void)\nimport Grace.Aeson (JSONDecodingFailed(..))\nimport Grace.Decode (FromGrace(..))\nimport Grace.HTTP (HTTP(..))\nimport Grace.Input (Input(..), Mode(..))\nimport Grace.Location (Location(..))\nimport Grace.Monad (Grace, Status(..))\nimport Grace.Syntax (BindMonad(..), Builtin(..), Scalar(..), Syntax)\nimport Grace.Value (Value)\nimport Prelude hiding (lookup, null, succ)\n\nimport {-# SOURCE #-} qualified Grace.Interpret as Interpret\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Control.Lens as Lens\nimport qualified Control.Monad as Monad\nimport qualified Control.Monad.Reader as Reader\nimport qualified Control.Monad.State as State\nimport qualified Data.Aeson as Aeson\nimport qualified Data.Aeson.Yaml as YAML\nimport qualified Data.ByteString.Lazy as ByteString.Lazy\nimport qualified Data.HashMap.Strict.InsOrd as HashMap\nimport qualified Data.List as List\nimport qualified Data.Scientific as Scientific\nimport qualified Data.Sequence as Seq\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Encoding\nimport qualified Data.Void as Void\nimport qualified Grace.Aeson\nimport qualified Grace.Context as Context\nimport qualified Grace.GitHub as GitHub\nimport qualified Grace.HTTP as HTTP\nimport qualified Grace.Import as Import\nimport qualified Grace.Infer as Infer\nimport qualified Grace.Monotype as Monotype\nimport qualified Grace.Pretty as Pretty\nimport qualified Grace.Prompt as Prompt\nimport qualified Grace.Syntax as Syntax\nimport qualified Grace.Type as Type\nimport qualified Grace.Value as Value\nimport qualified Text.URI as URI\nimport qualified Prelude\n\n{- $setup\n\n >>> :set -XOverloadedStrings\n-}\n\n{-| Lookup a variable from an ordered environment of name-value pairs using the\n variable's name and index\n-}\nlookupVariable\n :: Text\n -- ^ Variable name\n -> [(Text, Value Location)]\n -- ^ Evaluation environment\n -> Value Location\nlookupVariable name environment = case Prelude.lookup name environment of\n Just value -> value\n Nothing -> error \"Grace.Normalize.lookupVariable: unbound variable\"\n\nsorted :: Ord key => InsOrdHashMap key value -> [(key, value)]\nsorted = List.sortOn fst . HashMap.toList\n\n{-| Evaluate an expression, leaving behind a `Value` free of reducible\n sub-expressions\n\n This function uses separate types for the input (i.e. `Syntax`) and the\n output (i.e. `Value`) in order to avoid wastefully evaluating the same\n sub-expression multiple times.\n-}\nevaluate\n :: [(Text, Value Location)]\n -- ^ Evaluation environment (starting at @[]@ for a top-level expression)\n -> Syntax Location Void\n -- ^ Surface syntax\n -> Grace (Value Location)\n -- ^ Result, free of reducible sub-expressions\nevaluate env₀ syntax₀ = do\n loop env₀ syntax₀\n where\n generateContext env = do\n let infer (name, assignment) = do\n let expression :: Syntax Location Input\n expression = fmap Void.absurd (Value.quote assignment)\n\n let input = Code \"(intermediate value)\" (Pretty.toSmart expression)\n\n (type_, _) <- Infer.typeOf input expression\n\n return (name, type_, assignment)\n\n traverse infer env\n\n loop\n :: [(Text, Value Location)]\n -> Syntax Location Void\n -> Grace (Value Location)\n loop env syntax =\n case syntax of\n Syntax.Variable{ name } -> do\n pure (lookupVariable name env)\n\n Syntax.Application{ location, function, argument } -> Monad.join do\n function' <- loop env function\n argument' <- loop env argument\n pure (apply location function' argument')\n\n Syntax.Lambda{ location, binding = Syntax.PlainBinding{ plain = Syntax.NameBinding{ nameLocation, name, assignment } }, body } -> do\n newAssignment <- traverse (loop env) assignment\n\n pure (Value.Lambda location env (Value.Name nameLocation name newAssignment) body)\n\n Syntax.Lambda{ location, binding = Syntax.RecordBinding{ fieldNamesLocation, fieldNames }, body } -> do\n let process Syntax.NameBinding{ nameLocation, name, assignment } = do\n newAssignment <- traverse (loop env) assignment\n\n pure (nameLocation, name, newAssignment)\n\n newFieldNames <- traverse process fieldNames\n\n pure (Value.Lambda location env (Value.FieldNames fieldNamesLocation newFieldNames) body)\n\n Syntax.Annotation{ annotated, annotation } -> do\n newAnnotated <- loop env annotated\n\n pure do\n let promote (Value.Scalar location (Natural n)) Type.Scalar{ scalar = Monotype.Real } =\n Value.Scalar location (Real (fromIntegral n))\n promote (Value.Scalar location (Integer n)) Type.Scalar{ scalar = Monotype.Real } =\n Value.Scalar location (Real (fromInteger n))\n promote (Value.Scalar location (Natural n)) Type.Scalar{ scalar = Monotype.Integer } =\n Value.Scalar location (Integer (fromIntegral n))\n promote (Value.Text location t) Type.Scalar{ scalar = Monotype.Key } =\n Value.Scalar location (Key t)\n promote _ _ =\n newAnnotated\n\n promote newAnnotated annotation\n\n Syntax.Let{ assignments, body = body₀ } -> do\n let cons Syntax.Define{ definition = Syntax.Definition{ nameLocation, name, bindings, assignment } } action environment = do\n let lambda binding body = Syntax.Lambda\n { location = nameLocation\n , binding\n , body\n }\n\n let newAssignment = foldr lambda assignment bindings\n\n value <- loop environment newAssignment\n\n action ((name, value) : environment)\n\n cons Syntax.Bind{ monad, binding, assignment = assignment₀ } action environment = do\n value₀ <- loop environment assignment₀\n\n let once v = case binding of\n Syntax.PlainBinding{ plain = Syntax.NameBinding{ name, assignment = assignment₁ } } -> do\n v₁ <- case assignment₁ of\n Nothing -> do\n return v\n Just assignment₂ ->\n case v of\n Value.Scalar _ Null -> do\n loop environment assignment₂\n Value.Application _ (Value.Builtin _ Some) v₁ -> do\n return v₁\n v₁ -> do\n return v₁\n\n action ((name, v₁) : environment)\n\n Syntax.RecordBinding{ fieldNames } -> do\n case v of\n Value.Record location hashMap -> do\n let process Syntax.NameBinding{ name, assignment = assignment₁} = do\n let missing = case assignment₁ of\n Nothing -> do\n return (Value.Scalar location Syntax.Null)\n\n Just a -> do\n loop environment a\n\n value <- case HashMap.lookup name hashMap of\n -- This case shouldn't happen in theory, all missing\n -- fields should be elaborated to present fields set\n -- to `null` but we handle it as a precaution by\n -- just treating it as if elaboration had happened.\n Nothing ->\n missing\n\n Just (_, Value.Scalar _ Syntax.Null) ->\n missing\n\n -- If the field had a default assignment then that\n -- means that the right-hand side would be elaborated\n -- to be wrapped in a `some`, which we need to undo\n -- here\n Just (_, Value.Application _ (Value.Builtin _ Some) a)\n | Just _ <- assignment₁ ->\n return a\n\n Just (_, a) -> do\n return a\n\n return (name, value)\n\n entries <- traverse process fieldNames\n\n action (entries <> environment)\n _ -> do\n error \"Grace.Normalize.evaluate: non-records can't be destructured as records\"\n\n case monad of\n IdentityMonad ->\n once value₀\n\n OptionalMonad ->\n case value₀ of\n Value.Scalar location Null -> do\n return (Value.Scalar location Null)\n Value.Application _ (Value.Builtin _ Some) value₁ -> do\n once value₁\n value₁ ->\n once value₁\n\n ListMonad ->\n case value₀ of\n Value.List location elements -> do\n values <- traverse once elements\n\n let newElements = mconcat do\n Value.List _ xs <- toList values\n\n return (toList xs)\n\n return (Value.List location (Seq.fromList newElements))\n\n _ ->\n error \"Grace.Normalize.evaluate: cannot bind a non-Listin the List monad\"\n\n let monad = (maximum . (IdentityMonad :)) do\n Syntax.Bind{ monad = m } <- toList assignments\n\n return m\n\n let nil environment = do\n value <- loop environment body₀\n\n return case monad of\n IdentityMonad ->\n value\n ListMonad ->\n Value.List (Value.location value) [ value ]\n OptionalMonad ->\n Value.Application location (Value.Builtin location Some) value\n where\n location = Value.location value\n\n foldr cons nil assignments env\n\n Syntax.List{ location, elements } -> do\n values <- traverse (loop env) elements\n\n pure (Value.List location values)\n\n Syntax.Record{ location, fieldValues } -> do\n let process Syntax.Definition{ nameLocation, name, bindings, assignment = assignment₀ } = do\n let cons binding body = Syntax.Lambda\n { location = nameLocation\n , binding\n , body\n }\n\n let assignment₁ = foldr cons assignment₀ bindings\n\n assignment₂ <- loop env assignment₁\n\n pure (name, (nameLocation, assignment₂))\n\n newFieldValues <- traverse process fieldValues\n\n pure (Value.Record location (HashMap.fromList newFieldValues))\n\n Syntax.Text{ location, chunks = Syntax.Chunks text rest } -> do\n let onChunk (interpolation, text₁) = do\n value <- loop env interpolation\n\n pure case value of\n Value.Text _ text₀ ->\n text₀ <> text₁\n _ ->\n error \"Grace.Normalize.evaluate: interpolations must be text values\"\n\n suffixes <- traverse onChunk rest\n\n pure (Value.Text location (text <> Text.concat suffixes))\n\n Syntax.Project{ larger, smaller } -> do\n let lookup location field fieldValues = case HashMap.lookup field fieldValues of\n Just (_, v) -> v\n Nothing -> Value.Scalar location Syntax.Null\n\n larger' <- loop env larger\n\n pure case (larger', smaller) of\n (Value.Record location fieldValues, Syntax.Single{ single = Syntax.Field{ field } }) ->\n lookup location field fieldValues\n\n (Value.Record location fieldValues, Syntax.Multiple{ multiple }) ->\n Value.Record location newFieldValues\n where\n process Syntax.Field{ fieldLocation, field } =\n (field, (fieldLocation, lookup location field fieldValues))\n\n fvs = map process multiple\n\n newFieldValues = HashMap.fromList fvs\n\n (Value.List location xs, Syntax.Index{ index })\n | Seq.null xs -> Value.Scalar location Null\n | otherwise ->\n case quotient of\n 0 -> -- positive index within bounds\n Value.Application location\n (Value.Builtin location Some)\n (Seq.index xs remainder)\n\n -1 -> -- negative index within bounds\n Value.Application location\n (Value.Builtin location Some)\n (Seq.index xs remainder)\n\n _ -> -- out-of-bounds index\n Value.Scalar location Null\n where\n (quotient, remainder) = fromInteger index `divMod` Seq.length xs\n\n (Value.List location xs, Syntax.Slice{ begin, end })\n | Seq.null xs ->\n Value.Scalar location Null\n | otherwise ->\n Value.Application\n location\n (Value.Builtin location Some)\n (Value.List location elements₂)\n where\n b = case begin of\n Just x -> x\n Nothing -> 0\n\n e = case end of\n Just x -> x\n Nothing -> 0\n\n n = Seq.length xs\n\n elements₀ = Seq.cycleTaking (2 * n) xs\n\n elements₁ = Seq.drop (fromInteger b `mod` n) elements₀\n\n elements₂ =\n Seq.take\n ((fromInteger (e - b - 1) `mod` n) + 1)\n elements₁\n _ ->\n error \"Grace.Normalize.evaluate: invalid projection\"\n\n Syntax.Alternative{ location, name, argument } -> do\n newArgument <- loop env argument\n\n pure (Value.Alternative location name newArgument)\n\n Syntax.Fold{ location, handlers } -> do\n newHandlers <- loop env handlers\n\n pure (Value.Fold location newHandlers)\n\n Syntax.If{ predicate, ifTrue, ifFalse } -> do\n predicate' <- loop env predicate\n\n ifTrue' <- loop env ifTrue\n ifFalse' <- loop env ifFalse\n\n pure case predicate' of\n Value.Scalar _ (Bool True) -> ifTrue'\n Value.Scalar _ (Bool False) -> ifFalse'\n _ -> error \"Grace.Normalize.evaluate: if predicate must be a boolean value\"\n\n Syntax.Prompt{ location, import_, arguments, schema } -> do\n newArguments <- loop env arguments\n\n prompt <- case decode newArguments of\n Left exception -> Exception.throwIO exception\n Right prompt -> return prompt\n\n Status{ context } <- State.get\n\n let solvedSchema = fmap (Context.solveType context) schema\n\n Prompt.prompt (generateContext env) import_ location prompt solvedSchema\n\n Syntax.HTTP{ schema = Nothing } -> do\n Exception.throwIO MissingSchema\n Syntax.HTTP{ import_, arguments, schema = Just schema } -> do\n newArguments <- loop env arguments\n\n http <- case decode newArguments of\n Left exception -> Exception.throwIO exception\n Right http -> return http\n\n responseBody <- liftIO (HTTP.http import_ http)\n\n if import_\n then do\n bindings <- liftIO (generateContext env)\n\n uri <- liftIO (URI.mkURI (HTTP.url http))\n\n parent <- Reader.ask\n\n Reader.local (\\i -> i <> URI uri AsCode) do\n child <- Reader.ask\n\n Import.referentiallySane parent child\n\n (_, value) <- Interpret.interpretWith bindings (Just schema)\n\n return value\n\n else do\n Status{ context } <- State.get\n\n let solvedSchema = Context.solveType context schema\n\n case solvedSchema of\n Type.Scalar{ location, scalar = Monotype.Text } ->\n return (Value.Text location responseBody)\n\n _ -> do\n responseValue <- liftIO (Grace.Aeson.decode responseBody)\n\n value <- Infer.checkJSON solvedSchema responseValue\n return (fmap (\\_ -> Unknown) value)\n\n Syntax.Read{ schema = Nothing } -> do\n Exception.throwIO MissingSchema\n Syntax.Read{ import_, arguments, schema = Just schema } -> do\n newArguments <- loop env arguments\n\n text <- case decode newArguments of\n Left exception -> Exception.throwIO exception\n Right text -> return text\n\n if import_\n then do\n bindings <- generateContext env\n\n parent <- Reader.ask\n\n Reader.local (\\i -> i <> Code \"(read)\" text) do\n child <- Reader.ask\n\n Import.referentiallySane parent child\n\n (_, value) <- Interpret.interpretWith bindings (Just schema)\n\n return value\n\n else do\n aesonValue <- liftIO (Grace.Aeson.decode text)\n\n Status{ context } <- State.get\n\n let solvedSchema = Context.solveType context schema\n\n value <- Infer.checkJSON solvedSchema aesonValue\n\n return (fmap (\\_ -> Unknown) value)\n\n Syntax.GitHub{ schema = Nothing } -> do\n Exception.throwIO MissingSchema\n Syntax.GitHub{ import_, arguments, schema = Just schema } -> do\n newArguments <- loop env arguments\n\n github <- case decode newArguments of\n Left exception -> Exception.throwIO exception\n Right http -> return http\n\n url <- liftIO (GitHub.github github)\n\n if import_\n then do\n bindings <- generateContext env\n\n uri <- liftIO (URI.mkURI url)\n\n parent <- Reader.ask\n\n Reader.local (\\i -> i <> URI uri AsCode) do\n child <- Reader.ask\n\n Import.referentiallySane parent child\n\n (_, value) <- Interpret.interpretWith bindings (Just schema)\n\n return value\n\n else do\n responseBody <- liftIO $ HTTP.http import_ GET\n { url = url\n , headers = Nothing\n , parameters = Nothing\n }\n\n Status{ context } <- State.get\n\n let solvedSchema = Context.solveType context schema\n\n case solvedSchema of\n Type.Scalar{ location, scalar = Monotype.Text } ->\n return (Value.Text location responseBody)\n\n _ -> do\n aesonValue <- liftIO (Grace.Aeson.decode responseBody)\n\n value <- Infer.checkJSON solvedSchema aesonValue\n\n return (fmap (\\_ -> Unknown) value)\n\n Syntax.Show{ location, export = False, arguments = v } -> do\n v' <- loop env v\n\n case Value.toJSON v' of\n Just value -> do\n let lazyBytes = Aeson.encode value\n\n let strictBytes = ByteString.Lazy.toStrict lazyBytes\n\n case Encoding.decodeUtf8' strictBytes of\n Left _ ->\n error \"Grace.Normalize.evaluate: show produced non-UTF8 text\"\n Right text ->\n pure (Value.Text location text)\n\n Nothing -> do\n error \"Grace.Normalize.evaluate: show argument is not valid JSON\"\n\n Syntax.Show{ location, export = True, arguments = v } -> do\n v' <- loop env v\n\n return (Value.Text location (Pretty.toSmart (Value.quote v')))\n\n Syntax.Scalar{ location, scalar } ->\n pure (Value.Scalar location scalar)\n\n Syntax.Operator{ location, operator = Syntax.And, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure case (left', right') of\n (Value.Scalar _ (Bool l), Value.Scalar _ (Bool r)) ->\n Value.Scalar location (Bool (l && r))\n _ ->\n error \"Grace.Normalize.evaluate: && arguments must be boolean values\"\n\n Syntax.Operator{ location, operator = Syntax.Or, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure case (left', right') of\n (Value.Scalar _ (Bool l), Value.Scalar _ (Bool r)) ->\n Value.Scalar location (Bool (l || r))\n _ ->\n error \"Grace.Normalize.evaluate: || arguments must be boolean values\"\n\n Syntax.Operator{ location, operator = Syntax.Equal, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure (Value.Scalar location (Bool (void left' == void right')))\n\n Syntax.Operator{ location, operator = Syntax.NotEqual, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure (Value.Scalar location (Bool (left' /= right')))\n\n Syntax.Operator{ location, operator = Syntax.LessThan, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure case (left', right') of\n (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) ->\n Value.Scalar location (Bool (m < n))\n (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) ->\n Value.Scalar location (Bool (m < n))\n (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) ->\n Value.Scalar location (Bool (m < n))\n _ ->\n error \"Grace.Normalize.evaluate: < arguments must be numeric values of the same type\"\n\n\n Syntax.Operator{ location, operator = Syntax.LessThanOrEqual, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure case (left', right') of\n (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) ->\n Value.Scalar location (Bool (m <= n))\n (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) ->\n Value.Scalar location (Bool (m <= n))\n (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) ->\n Value.Scalar location (Bool (m <= n))\n _ ->\n error \"Grace.Normalize.evaluate: <= arguments must be numeric values of the same type\"\n\n Syntax.Operator{ location, operator = Syntax.GreaterThan, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure case (left', right') of\n (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) ->\n Value.Scalar location (Bool (m > n))\n (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) ->\n Value.Scalar location (Bool (m > n))\n (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) ->\n Value.Scalar location (Bool (m > n))\n _ ->\n error \"Grace.Normalize.evaluate: > arguments must be numeric values of the same type\"\n\n Syntax.Operator{ location, operator = Syntax.GreaterThanOrEqual, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure case (left', right') of\n (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) ->\n Value.Scalar location (Bool (m >= n))\n (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) ->\n Value.Scalar location (Bool (m >= n))\n (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) ->\n Value.Scalar location (Bool (m >= n))\n _ ->\n error \"Grace.Normalize.evaluate: >= arguments must be numeric values of the same type\"\n\n Syntax.Operator{ location, operator = Syntax.Times, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure case (left', right') of\n (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) ->\n Value.Scalar location (Natural (m * n))\n (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) ->\n Value.Scalar location (Integer (m * n))\n (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) ->\n Value.Scalar location (Real (m * n))\n _ ->\n error \"Grace.Normalize.evaluate: * arguments must be numeric values of the same type\"\n\n Syntax.Operator{ location, operator = Syntax.Plus, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure case (left', right') of\n (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) ->\n Value.Scalar location (Natural (m + n))\n (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) ->\n Value.Scalar location (Integer (m + n))\n (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) ->\n Value.Scalar location (Real (m + n))\n (Value.Text _ l, Value.Text _ r) ->\n Value.Text location (l <> r)\n (Value.List _ l, Value.List _ r) ->\n Value.List location (l <> r)\n _ ->\n error \"Grace.Normalize.evaluate: + arguments must be numeric values of the same type\"\n\n Syntax.Operator{ location, operator = Syntax.Minus, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure case (left', right') of\n (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) ->\n Value.Scalar location (Integer (fromIntegral m - fromIntegral n))\n (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) ->\n Value.Scalar location (Integer (m - n))\n (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) ->\n Value.Scalar location (Real (m - n))\n _ ->\n error \"Grace.Normalize.evaluate: - arguments must be numeric values of the same type\"\n\n Syntax.Operator{ location, operator = Syntax.Modulus, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure do\n let divisor = case right' of\n Value.Scalar _ (Natural n) -> n\n _ -> error \"Grace.Normalize.evaluate: right argument to % must be a Natural number literal\"\n\n let (quotient, remainder) = case left' of\n Value.Scalar _ (Natural n) ->\n ( Value.Scalar location (Natural q)\n , Value.Scalar location (Natural r)\n )\n where\n (q, r) = n `divMod` divisor\n Value.Scalar _ (Integer n) ->\n ( Value.Scalar location (Integer q)\n , Value.Scalar location (Integer r)\n )\n where\n (q, r) = n `divMod` fromIntegral divisor\n Value.Scalar _ (Real x) ->\n ( Value.Scalar location (Integer q)\n , Value.Scalar location (Real (fromIntegral r + f'))\n )\n where\n (n, f) = properFraction x\n\n (n', f')\n | f < 0 = (n - 1, f + 1)\n | otherwise = (n, f)\n\n (q, r) =\n n' `divMod` fromIntegral divisor\n _ ->\n error \"Grace.Normalize.evaluate: left argument to % must be a numeric value\"\n\n Value.Record\n location\n [ (\"quotient\", (location, quotient))\n , (\"remainder\", (location, remainder))\n ]\n\n Syntax.Operator{ location, operator = Syntax.Divide, left, right } -> do\n left' <- loop env left\n right' <- loop env right\n\n pure do\n let numerator = case left' of\n Value.Scalar _ (Natural n) -> fromIntegral n\n Value.Scalar _ (Integer n) -> fromInteger n\n Value.Scalar _ (Real n) -> Scientific.toRealFloat n\n _ -> error \"Grace.Normalize.evaluate: / arguments must be real numbers\"\n\n let denominator = case right' of\n Value.Scalar _ (Natural n) -> fromIntegral n\n Value.Scalar _ (Integer n) -> fromInteger n\n Value.Scalar _ (Real n) -> Scientific.toRealFloat n\n _ -> error \"Grace.Normalize.evaluate: / arguments must be real numbers\"\n\n Value.Scalar location (Real (Scientific.fromFloatDigits (numerator / denominator :: Double)))\n\n Syntax.Builtin{ location, builtin } ->\n pure (Value.Builtin location builtin)\n\n Syntax.Embed{ embedded } ->\n Void.absurd embedded\n\n{-| This is the function that implements function application, including\n evaluating anonymous functions and evaluating all built-in functions.\n-}\napply\n :: Location\n -> Value Location\n -- ^ Function\n -> Value Location\n -- ^ Argument\n -> Grace (Value Location)\napply applicationLocation function₀ argument₀ = loop function₀ argument₀\n where\n loop (Value.Lambda _ capturedEnv (Value.Name _ name Nothing) body) argument =\n evaluate ((name, argument) : capturedEnv) body\n loop (Value.Lambda _ capturedEnv (Value.Name _ name (Just assignment)) body) (Value.Scalar _ Null) =\n evaluate ((name, assignment) : capturedEnv) body\n loop (Value.Lambda _ capturedEnv (Value.Name _ name (Just _)) body) (Value.Application _ (Value.Builtin _ Some) argument) =\n evaluate ((name, argument) : capturedEnv) body\n loop (Value.Lambda _ capturedEnv (Value.FieldNames _ fieldNames) body) (Value.Record keyValuesLocation keyValues) =\n evaluate (extraEnv <> capturedEnv) body\n where\n extraEnv = do\n (_, fieldName, assignment) <- fieldNames\n\n let value = case assignment of\n Nothing -> case HashMap.lookup fieldName keyValues of\n Just (_, n) -> n\n Nothing -> Value.Scalar keyValuesLocation Null\n Just a -> case HashMap.lookup fieldName keyValues of\n Just (_, Value.Application _ (Value.Builtin _ Some) n) ->\n n\n Just (_, Value.Scalar _ Null) ->\n a\n Nothing ->\n a\n -- This case should only be hit if elaboration fails\n Just (_, n) ->\n n\n\n return (fieldName, value)\n loop\n (Value.Fold _ (Value.Record fieldValuesLocation fieldValues))\n (Value.Scalar _ (Bool b)) =\n pure (if b then trueHandler else falseHandler)\n where\n falseHandler = case HashMap.lookup \"false\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n trueHandler = case HashMap.lookup \"true\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n loop\n (Value.Fold _ (Value.Record fieldValuesLocation fieldValues))\n (Value.Scalar _ (Natural n)) = go n zero\n where\n zero = case HashMap.lookup \"zero\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n succ = case HashMap.lookup \"succ\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n go 0 !result = do\n return result\n go m !result = do\n x <- loop succ result\n go (m - 1) x\n loop\n (Value.Fold _ (Value.Record fieldValuesLocation fieldValues))\n (Value.Application _ (Value.Builtin _ Some) x) =\n loop some x\n where\n some = case HashMap.lookup \"some\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n loop\n (Value.Fold _ (Value.Record fieldValuesLocation fieldValues))\n (Value.Scalar _ Null) =\n pure null\n where\n null = case HashMap.lookup \"null\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n loop\n (Value.Fold _ (Value.Record _ (sorted -> [(\"cons\", (_, cons)), (\"nil\", (_, nil))])))\n (Value.List _ elements) = do\n inner (Seq.reverse elements) nil\n where\n inner xs !result =\n case Seq.viewl xs of\n EmptyL -> do\n return result\n y :< ys -> do\n a <- loop cons y\n b <- loop a result\n inner ys b\n loop\n (Value.Fold _ (Value.Record _ alternativeHandlers))\n (Value.Alternative _ alternative x)\n | Just (_, f) <- HashMap.lookup alternative alternativeHandlers =\n loop f x\n loop (Value.Fold _ (Value.Record fieldValuesLocation fieldValues)) v0 = inner v0\n where\n array = case HashMap.lookup \"array\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n bool = case HashMap.lookup \"bool\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n integer = case HashMap.lookup \"integer\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n natural = case HashMap.lookup \"natural\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n null = case HashMap.lookup \"null\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n object = case HashMap.lookup \"object\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n real = case HashMap.lookup \"real\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n string = case HashMap.lookup \"string\" fieldValues of\n Nothing -> Value.Scalar fieldValuesLocation Null\n Just (_, v) -> v\n\n inner (Value.Scalar location (Bool b)) =\n loop bool (Value.Scalar location (Bool b))\n inner (Value.Scalar location (Natural n)) =\n loop natural (Value.Scalar location (Natural n))\n inner (Value.Scalar location (Integer n)) =\n loop integer (Value.Scalar location (Integer n))\n inner (Value.Scalar location (Real n)) =\n loop real (Value.Scalar location (Real n))\n inner (Value.Text location t) =\n loop string (Value.Text location t)\n inner (Value.Scalar _ Null) =\n pure null\n inner (Value.List location elements) = do\n newElements <- traverse inner elements\n loop array (Value.List location newElements)\n inner (Value.Record location keyValues) = do\n elements <- traverse adapt (HashMap.toList keyValues)\n loop object (Value.List location (Seq.fromList elements))\n where\n adapt (key, (keyLocation, value)) = do\n newValue <- inner value\n return\n ( Value.Record keyLocation\n [ (\"key\", (keyLocation, Value.Text keyLocation key))\n , (\"value\", (keyLocation, newValue))\n ]\n )\n inner v =\n pure v\n loop (Value.Builtin builtinLocation Indexed) (Value.List location elements) =\n pure (Value.List location (Seq.mapWithIndex adapt elements))\n where\n adapt index value =\n Value.Record\n builtinLocation\n [ (\"index\", (builtinLocation, Value.Scalar builtinLocation (Natural (fromIntegral index))))\n , (\"value\", (builtinLocation, value))\n ]\n loop (Value.Builtin location Length) (Value.List _ elements) =\n pure (Value.Scalar location (Natural (fromIntegral (length elements))))\n loop\n (Value.Application _ (Value.Builtin _ Map) f)\n (Value.List location elements) = do\n newElements <- traverse (loop f) elements\n return (Value.List location newElements)\n loop (Value.Builtin _ Abs) (Value.Scalar location (Integer n)) =\n pure (Value.Scalar location (Natural (fromInteger (abs n))))\n loop (Value.Builtin location YAML) v = do\n case Value.toJSON v of\n Just value -> do\n let lazyBytes = YAML.encodeQuoted value\n\n let strictBytes = ByteString.Lazy.toStrict lazyBytes\n\n case Encoding.decodeUtf8' strictBytes of\n Left _ ->\n error \"Grace.Normalize.evaluate: yaml produced non-UTF8 text\"\n Right text ->\n pure (Value.Text location text)\n Nothing -> do\n error \"Grace.Normalize.evaluate: yaml argument is not valid JSON\"\n loop (Value.Builtin _ Reveal) (Value.Scalar location (Key text)) =\n pure (Value.Text location text)\n loop function argument =\n pure (Value.Application applicationLocation function argument)\n\n-- | Strip all `Some`s from a `Syntax` tree\nstrip :: Syntax s a -> Syntax s a\nstrip = Lens.transform transformation\n where\n transformation Syntax.Application{ function = Syntax.Builtin{ builtin = Some }, argument } =\n argument\n transformation e =\n e\n\n-- | Missing API credentials\ndata MissingCredentials = MissingCredentials\n deriving stock (Show)\n\ninstance Exception MissingCredentials where\n displayException MissingCredentials =\n \"Missing credentials\\n\\\n \\\\n\\\n \\You need to provide API credentials in order to use the prompt keyword\"\n\n-- | Elaboration didn't infer a schema\ndata MissingSchema = MissingSchema\n deriving stock (Show)\n\ninstance Exception MissingSchema where\n displayException MissingSchema =\n \"Internal error - Elaboration failed to infer schema\"\n" }, { "path": "src/Grace/Parallelizable.hs", "content": "-- | Computations with optional concurrency\nmodule Grace.Parallelizable\n ( -- * Monad\n Parallelizable(..)\n , serialize\n ) where\n\nimport Control.Applicative (liftA2)\nimport Control.Concurrent.Async (Concurrently(..))\nimport Control.Exception.Safe (MonadCatch)\nimport Control.Monad.Catch (MonadCatch(..), MonadThrow(..))\nimport Control.Monad.IO.Class (MonadIO(..))\nimport Control.Monad.Morph (MFunctor(..))\nimport Control.Monad.Reader (MonadReader(..))\nimport Control.Monad.State (MonadState(..))\nimport Control.Monad.Trans (MonadTrans(..))\nimport Prelude hiding (liftA2)\n\n-- | The `Concurrent` segment (if any) of a `Parallelizable` computation\ndata Concurrent io a = Concurrent (Concurrently (Parallelizable io a)) | Pure a\n deriving stock (Functor)\n\ninstance MFunctor Concurrent where\n hoist nat (Concurrent concurrently) =\n Concurrent (fmap (hoist nat) concurrently)\n hoist _ (Pure a) =\n Pure a\n\n{-| This represents a computation that alternates between `Serial` and\n `Concurrent` segments. The `Applicative` instance will try to run\n `Concurrent` segments in parallel as much as possible.\n-}\nnewtype Parallelizable io a = Serial{ serial :: io (Concurrent io a) }\n deriving stock (Functor)\n\n-- | Serialize a `Parallelizable` computation\nserialize :: MonadIO io => Parallelizable io a -> io a\nserialize Serial{ serial } = do\n step <- serial\n\n case step of\n Pure a -> do\n return a\n\n Concurrent concurrently -> do\n parallelizable <- liftIO (runConcurrently concurrently)\n\n serialize parallelizable\n\ninstance Monad io => Applicative (Parallelizable io) where\n pure a = Serial{ serial = pure (Pure a) }\n\n Serial{ serial = serial₀ } <*> Serial{ serial = serial₁ } = Serial{ serial }\n where\n serial = do\n step₀ <- serial₀\n\n case step₀ of\n Pure f -> do\n fmap (fmap f) serial₁\n Concurrent concurrently₀ -> do\n step₁ <- serial₁\n\n case step₁ of\n Pure x -> do\n return (Concurrent (fmap (fmap (\\f -> f x)) concurrently₀))\n Concurrent concurrently₁ -> do\n let concurrently = do\n parallelizable₀ <- concurrently₀\n parallelizable₁ <- concurrently₁\n\n return (parallelizable₀ <*> parallelizable₁)\n\n return (Concurrent concurrently)\n\ninstance Monad io => Monad (Parallelizable io) where\n Serial{ serial = serial₀ } >>= f =\n Serial{ serial = serial₁ }\n where\n serial₁ = do\n step <- serial₀\n\n case step of\n Pure x -> do\n serial (f x)\n Concurrent concurrently -> do\n return (Concurrent (fmap (>>= f) concurrently))\n\ninstance MonadTrans Parallelizable where\n lift m = Serial{ serial }\n where\n serial = do\n a <- m\n\n return (Pure a)\n\ninstance MonadIO io => MonadIO (Parallelizable io) where\n liftIO io = lift (liftIO io)\n\ninstance (Monad io, Semigroup a) => Semigroup (Parallelizable io a) where\n (<>) = liftA2 (<>)\n\ninstance (Monad io, Monoid a) => Monoid (Parallelizable io a) where\n mempty = pure mempty\n\ninstance MFunctor Parallelizable where\n hoist nat Serial{ serial = serial₀ } =\n Serial{ serial = serial₁ }\n where\n serial₁ = nat (fmap (hoist nat) serial₀)\n\ninstance (MonadState s io) => MonadState s (Parallelizable io) where\n get = lift get\n\n put s = lift (put s)\n\n state f = lift (state f)\n\ninstance (MonadThrow io) => MonadThrow (Parallelizable io) where\n throwM e = lift (throwM e)\n\ninstance (MonadCatch io, MonadIO io) => MonadCatch (Parallelizable io) where\n catch m f = lift (catch (serialize m) (serialize . f))\n\ninstance (MonadReader r io) => MonadReader r (Parallelizable io) where\n ask = lift ask\n\n local f = hoist (local f)\n" }, { "path": "src/Grace/Parser.hs", "content": "{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE RecursiveDo #-}\n\n{-| This module contains the logic for lexing and parsing Grace files\n\n The main reason for a separate lexing step using is because we would like\n to use @Earley@ for LR parsing, but @Earley@ is not fast enough to handle\n character-by-character parsing. Instead, we delegate lexing to a\n lower-level parsing library that supports efficient bulk parsing\n (@megaparsec@ in this case).\n\n The main reason for not using @alex@ (for lexing) or @happy@ (for parsing)\n is because they use a separate code generation step, which leads to worse\n type errors and poor support for interactive type-checking.\n\n The main reason for not using @attoparsec@ or @megaparsec@ for everything\n is because LR parsers are easier to maintain due to not needing to\n left-factor the grammar.\n-}\n\nmodule Grace.Parser\n ( -- * Parsing\n parse\n , parseREPLCommand\n , REPLCommand(..)\n -- * Errors related to parsing\n , ParseError(..)\n ) where\n\nimport Control.Applicative (empty, many, optional, some, (<|>))\nimport Control.Applicative.Combinators (endBy, sepBy)\nimport Control.Applicative.Combinators.NonEmpty (sepBy1)\nimport Control.Exception.Safe (Exception(..))\nimport Control.Monad.Combinators (manyTill)\nimport Data.Functor (void)\nimport Data.Foldable (toList)\nimport Data.List.NonEmpty (NonEmpty(..), some1)\nimport Data.Maybe (fromJust)\nimport Data.Scientific (Scientific)\nimport Data.Semigroup (sconcat)\nimport Data.Text (Text)\nimport Data.Void (Void)\nimport Grace.Input (Input(..), Mode(..))\nimport Grace.Location (Location(..), Offset(..))\nimport Grace.Type (Type(..))\nimport Numeric.Natural (Natural)\nimport Prelude hiding (lex, lines, unlines)\nimport Text.Earley (Grammar, Prod, Report(..), rule, ())\nimport Text.Megaparsec (ParseErrorBundle(..), State(..), try)\n\nimport Grace.Syntax\n ( Assignment(..)\n , Binding(..)\n , BindMonad(..)\n , Chunks(..)\n , Field(..)\n , NameBinding(..)\n , Smaller(..)\n , Syntax(..)\n )\n\nimport qualified Control.Monad as Monad\nimport qualified Control.Monad.Combinators as Combinators\nimport qualified Data.Char as Char\nimport qualified Data.HashSet as HashSet\nimport qualified Data.List as List\nimport qualified Data.List.NonEmpty as NonEmpty\nimport qualified Data.Sequence as Seq\nimport qualified Data.Text as Text\nimport qualified Data.Text.Read as Read\nimport qualified Grace.Domain as Domain\nimport qualified Grace.Label as Label\nimport qualified Grace.Location as Location\nimport qualified Grace.Monotype as Monotype\nimport qualified Grace.Syntax as Syntax\nimport qualified Grace.Type as Type\nimport qualified Text.Earley as Earley\nimport qualified Text.Megaparsec as Megaparsec\nimport qualified Text.Megaparsec.Char as Megaparsec.Char\nimport qualified Text.Megaparsec.Char.Lexer as Lexer\nimport qualified Text.Megaparsec.Error as Error\nimport qualified Text.URI as URI\n\n-- | Short-hand type synonym used by lexing utilities\ntype Lexer = Megaparsec.Parsec Void Text\n\nspace :: Lexer ()\nspace = Lexer.space Megaparsec.Char.space1 (Lexer.skipLineComment \"#\") empty\n\nsymbol :: Text -> Lexer Text\nsymbol = Lexer.symbol space\n\nlexeme :: Lexer a -> Lexer a\nlexeme = Lexer.lexeme space\n\nlexToken :: Lexer Token\nlexToken =\n Combinators.choice\n [ -- `file` has to come before the lexer for `.` so that a file\n -- prefix of `.` or `..` is not lexed as a field access\n lexFile\n , lexUri\n , lexLabel\n , lexNumber\n , lexDotNumber\n\n , Combinators.choice\n [ Grace.Parser.Or <$ symbol \"||\"\n , Grace.Parser.And <$ symbol \"&&\"\n , Grace.Parser.Plus <$ symbol \"+\"\n , Grace.Parser.Times <$ symbol \"*\"\n , Grace.Parser.Modulus <$ symbol \"%\"\n , Grace.Parser.ForwardSlash <$ symbol \"/\"\n , Grace.Parser.DoubleEquals <$ symbol \"==\"\n , Grace.Parser.NotEqual <$ symbol \"!=\"\n , Grace.Parser.LessThanOrEqual <$ symbol \"<=\"\n , Grace.Parser.GreaterThanOrEqual <$ symbol \">=\"\n ] Megaparsec. \"operator\"\n\n , Combinators.choice\n [ Grace.Parser.Abs <$ symbol \"abs\"\n , Grace.Parser.False_ <$ symbol \"false\"\n , Grace.Parser.Indexed <$ symbol \"indexed\"\n , Grace.Parser.Length <$ symbol \"length\"\n , Grace.Parser.Map <$ symbol \"map\"\n , Grace.Parser.Null <$ symbol \"null\"\n , Grace.Parser.Reveal <$ symbol \"reveal\"\n , Grace.Parser.Some <$ symbol \"some\"\n , Grace.Parser.True_ <$ symbol \"true\"\n , Grace.Parser.YAML <$ symbol \"yaml\"\n ] Megaparsec. \"built-in value\"\n\n , Combinators.choice\n [ Grace.Parser.Else <$ symbol \"else\"\n , Grace.Parser.Export <$ symbol \"export\"\n , Grace.Parser.Forall <$ symbol \"forall\"\n , Grace.Parser.Fold <$ symbol \"fold\"\n , Grace.Parser.For <$ symbol \"for\"\n , Grace.Parser.GitHub <$ symbol \"github\"\n , Grace.Parser.HTTP <$ symbol \"http\"\n , Grace.Parser.Read <$ symbol \"read\"\n , Grace.Parser.If <$ symbol \"if\"\n , Grace.Parser.Import <$ symbol \"import\"\n , Grace.Parser.In <$ symbol \"in\"\n , Grace.Parser.Let <$ symbol \"let\"\n , Grace.Parser.Of <$ symbol \"of\"\n , Grace.Parser.Prompt <$ symbol \"prompt\"\n , Grace.Parser.Show <$ symbol \"show\"\n , Grace.Parser.Then <$ symbol \"then\"\n , Grace.Parser.Alternatives <$ symbol \"Alternatives\"\n , Grace.Parser.Fields <$ symbol \"Fields\"\n , Grace.Parser.Type <$ symbol \"Type\"\n ] Megaparsec. \"keyword\"\n\n , Combinators.choice\n [ Grace.Parser.List <$ symbol \"List\"\n , Grace.Parser.Optional <$ symbol \"Optional\"\n , Grace.Parser.Real <$ symbol \"Real\"\n , Grace.Parser.Integer <$ symbol \"Integer\"\n , Grace.Parser.JSON <$ symbol \"JSON\"\n , Grace.Parser.Key <$ symbol \"Key\"\n , Grace.Parser.Natural <$ symbol \"Natural\"\n , Grace.Parser.Bool <$ symbol \"Bool\"\n , Grace.Parser.Text <$ symbol \"Text\"\n ] Megaparsec. \"built-in type\"\n\n , Grace.Parser.OpenAngle <$ symbol \"<\"\n , Grace.Parser.CloseAngle <$ symbol \">\"\n , Grace.Parser.OpenBrace <$ symbol \"{\"\n , Grace.Parser.CloseBrace <$ symbol \"}\"\n , Grace.Parser.OpenBracket <$ symbol \"[\"\n , Grace.Parser.CloseBracket <$ symbol \"]\"\n , Grace.Parser.OpenParenthesis <$ symbol \"(\"\n , Grace.Parser.CloseParenthesis <$ symbol \")\"\n\n , Grace.Parser.Arrow <$ symbol \"->\"\n , Grace.Parser.At <$ symbol \"@\"\n , Grace.Parser.Bar <$ symbol \"|\"\n , Grace.Parser.Colon <$ symbol \":\"\n , Grace.Parser.Comma <$ symbol \",\"\n , Grace.Parser.Dash <$ symbol \"-\"\n , Grace.Parser.Dot <$ symbol \".\"\n , Grace.Parser.Equals <$ symbol \"=\"\n , Grace.Parser.Lambda <$ symbol \"\\\\\"\n\n , lexText\n , lexAlternative\n ]\n\nlexLocatedToken :: Lexer LocatedToken\nlexLocatedToken = do\n state <- Megaparsec.getParserState\n token <- lexToken\n return LocatedToken{ token, state }\n\nlexLocatedTokens :: Lexer [LocatedToken]\nlexLocatedTokens = do\n space\n manyTill lexLocatedToken Megaparsec.eof\n\n-- | Lex a complete expression\nlex :: String\n -- ^ Name of the input (used for error messages)\n -> Text\n -- ^ Source code\n -> Either ParseError [LocatedToken]\nlex name code =\n case Megaparsec.parse lexLocatedTokens name code of\n Left ParseErrorBundle{ bundleErrors } -> do\n let bundleError :| _ = bundleErrors\n\n let offset = Offset (Error.errorOffset bundleError)\n\n Left (LexingFailed (Location{ name, code, offset }))\n Right tokens -> do\n return tokens\n\nlexSign :: Lexer Sign\nlexSign = (Positive <$ \"+\") <|> (Negative <$ \"-\") <|> pure Unsigned\n\nlexNumber :: Lexer Token\nlexNumber = try lexInteger <|> try lexScientific\n where\n lexInteger = do\n sign <- lexSign\n n <- lexeme Lexer.decimal <* Megaparsec.notFollowedBy (Megaparsec.Char.char '.')\n return (Int sign n)\n\n lexScientific = do\n sign <- lexSign\n scientific <- lexeme Lexer.scientific\n return (RealLiteral sign scientific)\n\nlexDotNumber :: Lexer Token\nlexDotNumber = try do\n symbol \".\"\n\n sign <- lexSign\n\n n <- lexeme Lexer.decimal\n\n return case sign of\n Unsigned -> DotNumber (fromInteger n)\n Positive -> DotNumber (fromInteger n)\n Negative -> DotNumber (negate (fromInteger n))\n\nlexFile :: Lexer Token\nlexFile = (lexeme . try) do\n prefix <- (\"../\" <|> \"./\" <|> \"/\" <|> \"~/\") Megaparsec. \"path character\"\n\n let isPath c =\n '\\x21' == c\n || ('\\x24' <= c && c <= '\\x27')\n || ('\\x2A' <= c && c <= '\\x2B')\n || ('\\x2D' <= c && c <= '\\x2E')\n || ('\\x30' <= c && c <= '\\x3B')\n || '\\x3D' == c\n || ('\\x40' <= c && c <= '\\x5A')\n || ('\\x5E' <= c && c <= '\\x7A')\n || ('\\x7C' == c)\n || '\\x7E' == c\n\n let pathComponent = Megaparsec.takeWhile1P (Just \"path character\") isPath\n\n suffix <- pathComponent `sepBy1` \"/\"\n\n return (File (concatMap Text.unpack (prefix : List.intersperse \"/\" (toList suffix))))\n\nlexUri :: Lexer Token\nlexUri = (lexeme . try) do\n u <- URI.parser\n\n let schemes =\n map (fromJust . URI.mkScheme) [ \"https\", \"http\", \"env\", \"file\" ]\n\n if any (`elem` schemes) (URI.uriScheme u)\n then return (Grace.Parser.URI u)\n else fail \"Unsupported Grace URI\"\n\nlines :: Chunks s a -> NonEmpty (Chunks s a)\nlines = loop mempty\n where\n loop :: Chunks s a -> Chunks s a -> NonEmpty (Chunks s a)\n loop currentLine (Chunks text₀ rest)\n | Text.null suffix = case rest of\n [] -> (currentLine <> Chunks prefix []) :| []\n (interpolation, text₁) : est ->\n loop (currentLine <> Chunks prefix [(interpolation, \"\")])\n (Chunks text₁ est)\n | otherwise =\n NonEmpty.cons\n (currentLine <> Chunks prefix [])\n (loop mempty (Chunks (Text.drop 1 suffix) rest))\n where\n (prefix, suffix) = Text.breakOn \"\\n\" text₀\n\nunlines :: NonEmpty (Chunks s a) -> Chunks s a\nunlines ls = sconcat (NonEmpty.intersperse \"\\n\" ls)\n\ncommonPrefix :: NonEmpty (Chunks s a) -> Text\ncommonPrefix ls = List.foldl' longestCommonPrefix t ts\n where\n t :| ts = fmap toPrefix (removeEmpty ls)\n\n toPrefix (Chunks text₀ _) = Text.takeWhile isPrefixCharacter text₀\n where\n isPrefixCharacter c = c == ' ' || c == '\\t'\n\n longestCommonPrefix x y = case Text.commonPrefixes x y of\n Nothing -> \"\"\n Just (prefix, _, _) -> prefix\n\nremoveEmpty :: NonEmpty (Chunks s a) -> NonEmpty (Chunks s a)\nremoveEmpty ls = prependList (filter present initLines) (pure lastLine)\n where\n initLines = NonEmpty.init ls\n lastLine = NonEmpty.last ls\n\n present (Chunks \"\" []) = False\n present _ = True\n\nprependList :: [a] -> NonEmpty a -> NonEmpty a\nprependList [] ys = ys\nprependList (x : xs) (y :| ys) = x :| (xs <> (y : ys))\n\ndedent :: Chunks s a -> Chunks s a\ndedent c = unlines (fmap stripPrefix ls)\n where\n ls = lines c\n\n prefix = commonPrefix ls\n\n stripPrefix (Chunks text₀ rest) =\n Chunks (Text.drop (Text.length prefix) text₀) rest\n\nlexText :: Lexer Token\nlexText = lexeme do\n \"\\\"\"\n\n multiline <- (True <$ \"\\n\") <|> pure False\n\n let isText c =\n ('\\x09' <= c && c <= '\\x0A' && multiline)\n || ('\\x20' <= c && c <= '\\x21')\n || '\\x23' == c\n || ('\\x25' <= c && c <= '\\x5b')\n || ('\\x5d' <= c && c <= '\\x10FFFF')\n\n let unescaped = do\n t <- Megaparsec.takeWhile1P (Just \"text character\") isText\n\n return (Chunks t [])\n\n let unicodeEscape = do\n \"\\\\u\"\n\n codepoint <- Combinators.count 4 Megaparsec.Char.hexDigitChar\n\n case Read.hexadecimal (Text.pack codepoint) of\n Right (n, \"\") -> do\n return (Chunks (Text.singleton (Char.chr n)) [])\n _ -> do\n fail \"Internal error - invalid unicode escape sequence\"\n\n let escaped =\n Combinators.choice\n ( ( if multiline\n then []\n else [ \"\\n\" <$ \"\\\\n\", \"\\t\" <$ \"\\\\t\" ]\n )\n <> [ \"\\\"\" <$ \"\\\\\\\"\"\n , \"\\\\\" <$ \"\\\\\\\\\"\n , \"/\" <$ \"\\\\/\"\n , \"\\b\" <$ \"\\\\b\"\n , \"\\f\" <$ \"\\\\f\"\n , \"\\r\" <$ \"\\\\r\"\n , \"$\" <$ \"\\\\$\"\n , unicodeEscape\n ]\n ) Megaparsec. \"escape sequence\"\n\n let interpolated = do\n \"${\"\n\n originalState <- Megaparsec.getParserState\n\n let loop state = case result of\n Left _ -> []\n Right token -> token : loop newState\n where\n (newState, result) =\n Megaparsec.runParser' lexLocatedToken state\n\n let locatedTokens = loop afterSpace\n where\n (afterSpace, _) = Megaparsec.runParser' space originalState\n\n (syntax, index) <- case Earley.allParses (Earley.parser (grammar (Interpolation id))) locatedTokens of\n ([], Report{ position }) -> do\n case drop position locatedTokens of\n [] ->\n return ()\n LocatedToken{ state } : _ ->\n Megaparsec.setParserState state\n\n empty Megaparsec. \"Incomplete string interpolation\"\n\n (result : _, _) -> do\n return result\n\n case drop (index - 1) locatedTokens of\n [] -> do\n empty Megaparsec. \"Incomplete string literal\"\n\n LocatedToken{ state } : _ -> do\n Megaparsec.setParserState state\n\n \"}\"\n\n return (Chunks mempty [(syntax, mempty)])\n\n chunks <- many (unescaped <|> interpolated <|> escaped <|> (\"$\" <$ \"$\"))\n\n let chunk = mconcat chunks\n\n let dedented\n | multiline = dedent chunk\n | otherwise = chunk\n\n \"\\\"\"\n\n return (TextLiteral dedented)\n\nlexLabel :: Lexer Token\nlexLabel = lexUnquotedLabel <|> lexQuotedLabel\n\nlexUnquotedLabel :: Lexer Token\nlexUnquotedLabel = (try . lexeme) do\n c0 <- Megaparsec.satisfy Label.isLabel0 Megaparsec. \"label character\"\n\n cs <- Megaparsec.takeWhileP (Just \"label character\") Label.isLabel\n\n let name = Text.cons c0 cs\n\n Monad.guard (not (HashSet.member name Label.reservedLabels))\n\n return (Label name)\n\nlexQuotedLabel :: Lexer Token\nlexQuotedLabel = (try . lexeme) do\n \".\"\n\n name <- lexSingleQuoted\n\n return (Label name)\n\nlexUnquotedAlternative :: Lexer Token\nlexUnquotedAlternative = (try . lexeme) do\n c0 <- Megaparsec.satisfy Label.isAlternativeLabel0 Megaparsec. \"alternative character\"\n\n cs <- Megaparsec.takeWhileP (Just \"alternative character\") Label.isLabel\n\n let name = Text.cons c0 cs\n\n Monad.guard (not (HashSet.member name Label.reservedLabels))\n\n return (Grace.Parser.Alternative name)\n\nlexSingleQuoted :: Lexer Text\nlexSingleQuoted = do\n \"'\"\n\n let isText c =\n ('\\x20' <= c && c <= '\\x26')\n || ('\\x28' <= c && c <= '\\x5c')\n || ('\\x5d' <= c && c <= '\\x10FFFF')\n\n let unescaped = Megaparsec.takeWhile1P (Just \"alternative character\") isText\n\n let unicodeEscape = do\n \"\\\\u\"\n\n codepoint <- Combinators.count 4 Megaparsec.Char.hexDigitChar\n\n case Read.hexadecimal (Text.pack codepoint) of\n Right (n, \"\") -> do\n return (Text.singleton (Char.chr n))\n _ -> do\n fail \"Internal error - invalid unicode escape sequence\"\n\n let escaped =\n Combinators.choice\n [ \"'\" <$ \"\\\\\\'\"\n , \"\\\\\" <$ \"\\\\\\\\\"\n , \"/\" <$ \"\\\\/\"\n , \"\\b\" <$ \"\\\\b\"\n , \"\\f\" <$ \"\\\\f\"\n , \"\\n\" <$ \"\\\\n\"\n , \"\\r\" <$ \"\\\\r\"\n , \"\\t\" <$ \"\\\\t\"\n , unicodeEscape\n ] Megaparsec. \"escape sequence\"\n\n texts <- many (unescaped <|> escaped)\n\n \"'\"\n\n return (Text.concat texts)\n\nlexQuotedAlternative :: Lexer Token\nlexQuotedAlternative = lexeme do\n name <- lexSingleQuoted\n\n return (Grace.Parser.Alternative name)\n\nlexAlternative :: Lexer Token\nlexAlternative = lexUnquotedAlternative <|> lexQuotedAlternative\n\n-- | Tokens produced by lexing\ndata Token\n = Abs\n | Alternative Text\n | Alternatives\n | And\n | Arrow\n | At\n | Bar\n | Bool\n | CloseAngle\n | CloseBrace\n | CloseBracket\n | CloseParenthesis\n | Colon\n | Comma\n | Dash\n | Dot\n | DotNumber Integer\n | DoubleEquals\n | Else\n | Equals\n | Export\n | False_\n | Fields\n | File FilePath\n | Fold\n | For\n | Forall\n | ForwardSlash\n | GitHub\n | GreaterThanOrEqual\n | If\n | Import\n | In\n | Indexed\n | Int Sign Natural\n | Integer\n | JSON\n | Key\n | Label Text\n | Lambda\n | Length\n | LessThanOrEqual\n | Let\n | List\n | Map\n | Modulus\n | Natural\n | NotEqual\n | Null\n | Of\n | OpenAngle\n | OpenBrace\n | OpenBracket\n | OpenParenthesis\n | Optional\n | Or\n | Plus\n | HTTP\n | Prompt\n | Read\n | Real\n | RealLiteral Sign Scientific\n | Reveal\n | Show\n | Some\n | Text\n | TextLiteral (Chunks Offset Input)\n | Then\n | Times\n | True_\n | Type\n | URI URI.URI\n | YAML\n deriving stock (Eq, Show)\n\ndata Sign = Unsigned | Positive | Negative\n deriving stock (Eq, Show)\n\n{-| A token with parsing state attached, used for reporting line and column\n numbers in error messages\n-}\ndata LocatedToken = LocatedToken { token :: Token, state :: State Text Void }\n deriving stock (Show)\n\n-- | Errors related to lexing and parsing\ndata ParseError\n = LexingFailed Location\n | ParsingFailed Location\n deriving stock (Eq, Show)\n\ninstance Exception ParseError where\n displayException (LexingFailed location) = Text.unpack\n (Location.renderError \"Invalid input - Lexing failed\" location)\n displayException (ParsingFailed location) = Text.unpack\n (Location.renderError \"Invalid input - Parsing failed\" location)\n\ntype Parser r = Prod r Text LocatedToken\n\nmatchLabel :: Token -> Maybe Text\nmatchLabel (Grace.Parser.Label l) = Just l\nmatchLabel _ = Nothing\n\nmatchReservedLabel :: Token -> Maybe Text\nmatchReservedLabel Grace.Parser.Some = Just \"some\"\nmatchReservedLabel Grace.Parser.Null = Just \"null\"\nmatchReservedLabel Grace.Parser.True_ = Just \"true\"\nmatchReservedLabel Grace.Parser.False_ = Just \"false\"\nmatchReservedLabel _ = Nothing\n\nmatchAlternative :: Token -> Maybe Text\nmatchAlternative (Grace.Parser.Alternative a) = Just a\nmatchAlternative _ = Nothing\n\nmatchReal :: Token -> Maybe (Sign, Scientific)\nmatchReal (Grace.Parser.RealLiteral sign n) = Just (sign, n)\nmatchReal _ = Nothing\n\nmatchInt :: Token -> Maybe (Sign, Natural)\nmatchInt (Grace.Parser.Int sign n) = Just (sign, n)\nmatchInt _ = Nothing\n\nmatchDotNumber :: Token -> Maybe Integer\nmatchDotNumber (Grace.Parser.DotNumber n) = Just n\nmatchDotNumber _ = Nothing\n\nmatchChunks :: Token -> Maybe (Chunks Offset Input)\nmatchChunks (Grace.Parser.TextLiteral c) = Just c\nmatchChunks _ = Nothing\n\nmatchText :: Token -> Maybe Text\nmatchText (Grace.Parser.TextLiteral (Chunks t [])) = Just t\nmatchText _ = Nothing\n\nmatchFile :: Token -> Maybe FilePath\nmatchFile (Grace.Parser.File f) = Just f\nmatchFile _ = Nothing\n\nmatchURI :: Token -> Maybe URI.URI\nmatchURI (Grace.Parser.URI t) = Just t\nmatchURI _ = Nothing\n\nterminal :: (Token -> Maybe a) -> Parser r a\nterminal match = Earley.terminal match'\n where\n match' locatedToken_ = match (Grace.Parser.token locatedToken_)\n\nlabel :: Parser r Text\nlabel = terminal matchLabel\n\nreservedLabel :: Parser r Text\nreservedLabel = terminal matchReservedLabel\n\nalternative :: Parser r Text\nalternative = terminal matchAlternative\n\nint :: Parser r (Sign, Natural)\nint = terminal matchInt\n\ndotNumber :: Parser r Integer\ndotNumber = terminal matchDotNumber\n\ntext :: Parser r Text\ntext = terminal matchText\n\nparseToken :: Token -> Parser r ()\nparseToken t = void (Earley.satisfy predicate render t)\n where\n predicate locatedToken_ = token locatedToken_ == t\n\nlocatedTerminal :: (Token -> Maybe a) -> Parser r (Offset, a)\nlocatedTerminal match = Earley.terminal match'\n where\n match' locatedToken_@LocatedToken{ state } = do\n a <- match (token locatedToken_)\n return (Offset (stateOffset state), a)\n\nlocatedLabel :: Parser r (Offset, Text)\nlocatedLabel = locatedTerminal matchLabel\n\nlocatedReservedLabel :: Parser r (Offset, Text)\nlocatedReservedLabel = locatedTerminal matchReservedLabel\n\nlocatedAlternative :: Parser r (Offset, Text)\nlocatedAlternative = locatedTerminal matchAlternative\n\nlocatedReal :: Parser r (Offset, (Sign, Scientific))\nlocatedReal = locatedTerminal matchReal\n\nlocatedInt :: Parser r (Offset, (Sign, Natural))\nlocatedInt = locatedTerminal matchInt\n\nlocatedChunks :: Parser r (Offset, Chunks Offset Input)\nlocatedChunks = locatedTerminal matchChunks\n\nlocatedText :: Parser r (Offset, Text)\nlocatedText = locatedTerminal matchText\n\nlocatedFile :: Parser r (Offset, FilePath)\nlocatedFile = locatedTerminal matchFile\n\nlocatedURI :: Parser r (Offset, URI.URI)\nlocatedURI = locatedTerminal matchURI\n\nlocatedToken :: Token -> Parser r Offset\nlocatedToken expectedToken =\n Earley.terminal capture render expectedToken\n where\n capture LocatedToken{ token = actualToken, state }\n | expectedToken == actualToken = Just (Offset (stateOffset state))\n | otherwise = Nothing\n\n-- | This render function is currently never used since `Location.renderError`\n-- does not display expected tokens at all, but I maintain this anyway in\n-- case someone wants to modify the code to display them.\nrender :: Token -> Text\nrender t = case t of\n Grace.Parser.Abs -> \"abs\"\n Grace.Parser.Alternative _ -> \"an alternative\"\n Grace.Parser.Alternatives -> \"Alternatives\"\n Grace.Parser.And -> \"&&\"\n Grace.Parser.Arrow -> \" ->\"\n Grace.Parser.At -> \"@\"\n Grace.Parser.Bar -> \"|\"\n Grace.Parser.Bool -> \"Bool\"\n Grace.Parser.CloseAngle -> \">\"\n Grace.Parser.CloseBrace -> \"}\"\n Grace.Parser.CloseBracket -> \"]\"\n Grace.Parser.CloseParenthesis -> \")\"\n Grace.Parser.Colon -> \":\"\n Grace.Parser.Comma -> \",\"\n Grace.Parser.Dash -> \"-\"\n Grace.Parser.Dot -> \".\"\n Grace.Parser.DotNumber _ -> \".n\"\n Grace.Parser.DoubleEquals -> \"==\"\n Grace.Parser.Else -> \"else\"\n Grace.Parser.Equals -> \"=\"\n Grace.Parser.Export -> \"export\"\n Grace.Parser.False_ -> \"False\"\n Grace.Parser.Fields -> \"Fields\"\n Grace.Parser.File _ -> \"a file\"\n Grace.Parser.Fold -> \"fold\"\n Grace.Parser.For -> \"for\"\n Grace.Parser.Forall -> \"forall\"\n Grace.Parser.ForwardSlash -> \"/\"\n Grace.Parser.GitHub -> \"github\"\n Grace.Parser.GreaterThanOrEqual -> \">=\"\n Grace.Parser.If -> \"if\"\n Grace.Parser.Import -> \"import\"\n Grace.Parser.In -> \"in\"\n Grace.Parser.Indexed -> \"indexed\"\n Grace.Parser.Int _ _ -> \"an integer literal\"\n Grace.Parser.Integer -> \"Integer\"\n Grace.Parser.JSON -> \"JSON\"\n Grace.Parser.Key -> \"Key\"\n Grace.Parser.Label _ -> \"a label\"\n Grace.Parser.Lambda -> \"\\\\\"\n Grace.Parser.Length -> \"length\"\n Grace.Parser.LessThanOrEqual -> \"<=\"\n Grace.Parser.Let -> \"let\"\n Grace.Parser.List -> \"list\"\n Grace.Parser.Map -> \"map\"\n Grace.Parser.Modulus -> \"%\"\n Grace.Parser.Natural -> \"Natural\"\n Grace.Parser.NotEqual -> \"!=\"\n Grace.Parser.Null -> \"null\"\n Grace.Parser.Of -> \"of\"\n Grace.Parser.OpenAngle -> \"<\"\n Grace.Parser.OpenBrace -> \"{\"\n Grace.Parser.OpenBracket -> \"<\"\n Grace.Parser.OpenParenthesis -> \"(\"\n Grace.Parser.Optional -> \"List\"\n Grace.Parser.Or -> \"||\"\n Grace.Parser.Plus -> \"+\"\n Grace.Parser.HTTP -> \"http\"\n Grace.Parser.Prompt -> \"prompt\"\n Grace.Parser.Read -> \"read\"\n Grace.Parser.Real -> \"Real\"\n Grace.Parser.RealLiteral _ _ -> \"a real number literal\"\n Grace.Parser.Reveal -> \"reveal\"\n Grace.Parser.Show -> \"show\"\n Grace.Parser.Some -> \"some\"\n Grace.Parser.Text -> \"Text\"\n Grace.Parser.TextLiteral _ -> \"a text literal\"\n Grace.Parser.Then -> \"then\"\n Grace.Parser.Times -> \"*\"\n Grace.Parser.True_ -> \"True\"\n Grace.Parser.Type -> \"Type\"\n Grace.Parser.URI _ -> \"a URI\"\n Grace.Parser.YAML -> \"yaml\"\n\n{-| This is how we decide at the top-level what we want to parse, to work around\n the fact that the @Earley@ package only lets you return one `Parser`\n-}\ndata GrammaticalForm a\n = Expression (Syntax Offset Input -> a)\n | Interpolation (Syntax Offset Input -> a)\n | REPLCommand (REPLCommand -> a)\n\n-- | \ndata REPLCommand\n = Evaluate (Syntax Offset Input) | Assign (Assignment Offset Input)\n\ngrammar :: GrammaticalForm a -> Grammar r (Parser r a)\ngrammar form = mdo\n parseUnadornedBinding <- rule do\n ~(nameLocation, name) <- locatedLabel\n\n pure PlainBinding\n { plain = NameBinding\n { nameLocation\n , name\n , annotation = Nothing\n , assignment = Nothing\n }\n }\n\n parseAdornedBinding <- rule do\n let annotated = do\n parseToken Grace.Parser.OpenParenthesis\n\n ~(nameLocation, name) <- locatedLabel\n\n annotation <- optional do\n parseToken Grace.Parser.Colon\n\n r <- quantifiedType\n\n pure r\n\n assignment <- optional do\n parseToken Grace.Parser.Equals\n\n r <- expression\n\n pure r\n\n parseToken Grace.Parser.CloseParenthesis\n\n pure PlainBinding\n { plain = NameBinding\n { nameLocation\n , name\n , annotation\n , assignment\n }\n }\n\n let fields = do\n let parseAnnotation = do\n parseToken Grace.Parser.Colon\n\n annotation <- quantifiedType\n\n pure annotation\n\n let parseDefault = do\n parseToken Grace.Parser.Equals\n\n assignment <- expression\n\n pure assignment\n\n let parseFieldName = do\n ~(nameLocation, name) <- locatedRecordLabel\n\n annotation <- optional parseAnnotation\n\n assignment <- optional parseDefault\n\n return NameBinding{ nameLocation, name, annotation, assignment }\n\n fieldNamesLocation <- locatedToken Grace.Parser.OpenBrace\n\n fieldNames <- parseFieldName `sepBy` parseToken Grace.Parser.Comma\n parseToken Grace.Parser.CloseBrace\n\n pure RecordBinding{ fieldNamesLocation, fieldNames }\n\n annotated <|> fields\n\n parseBinding <- rule (parseUnadornedBinding <|> parseAdornedBinding)\n\n expression <- rule\n ( do location <- locatedToken Grace.Parser.Lambda\n\n bindings <- some1 parseBinding\n\n parseToken Grace.Parser.Arrow\n\n body0 <- expression\n\n return do\n let cons binding body = Syntax.Lambda\n { location\n , binding\n , body\n }\n\n foldr cons body0 bindings\n\n <|> do assignments <- some1 parseAssignment\n\n parseToken Grace.Parser.In\n\n body <- expression\n\n return do\n let location = case NonEmpty.head assignments of\n Syntax.Define{ definition = Syntax.Definition{ nameLocation } } -> nameLocation\n Syntax.Bind{ binding = Syntax.PlainBinding{ plain = Syntax.NameBinding{ nameLocation } } } -> nameLocation\n Syntax.Bind{ binding = Syntax.RecordBinding{ fieldNamesLocation } } -> fieldNamesLocation\n Syntax.Let{ location, assignments, body }\n\n <|> do location <- locatedToken Grace.Parser.If\n\n predicate <- expression\n\n parseToken Grace.Parser.Then\n\n ifTrue <- expression\n\n parseToken Grace.Parser.Else\n\n ifFalse <- expression\n\n return Syntax.If{ location, predicate, ifTrue, ifFalse }\n\n <|> do let annotatedFile = do\n ~(location, file) <- locatedFile\n\n return Syntax.Embed\n { location\n , embedded = Path file AsCode\n }\n\n let annotatedURI = do\n ~(location, uri) <- locatedURI\n\n return Syntax.Embed\n { location\n , embedded = Grace.Input.URI uri AsText\n }\n\n let adapt Syntax.Embed{ location, embedded = Path file AsCode } Type.Scalar{ scalar = Monotype.Text } =\n Syntax.Embed{ location, embedded = Path file AsText }\n adapt Syntax.Embed{ location, embedded = Path file AsCode } Type.Scalar{ scalar = Monotype.Key } =\n Syntax.Embed{ location, embedded = Path file AsKey }\n adapt Syntax.Embed{ location, embedded = Grace.Input.URI uri AsCode } Type.Scalar{ scalar = Monotype.Text } =\n Syntax.Embed\n { location\n , embedded = Grace.Input.URI uri AsText\n }\n adapt Syntax.Embed{ location, embedded = Grace.Input.URI uri AsCode } Type.Scalar{ scalar = Monotype.Key } =\n Syntax.Embed\n { location\n , embedded = Grace.Input.URI uri AsKey\n }\n adapt annotated annotation =\n Syntax.Annotation\n { location = Syntax.location annotated\n , annotated\n , annotation\n }\n\n annotated <-\n ( annotatedFile\n <|> annotatedURI\n <|> operatorExpression\n )\n\n parseToken Grace.Parser.Colon\n\n annotation <- quantifiedType\n\n return (adapt annotated annotation)\n\n <|> do operatorExpression\n )\n\n operatorExpression <- rule orExpression\n\n let op token_ operator subExpression = do\n let snoc left (operatorLocation, right) = Syntax.Operator\n { location = Syntax.location left\n , left\n , operatorLocation\n , operator\n , right\n }\n\n e0 <- subExpression\n\n ses <- many do\n s <- locatedToken token_\n\n e <- subExpression;\n\n return (s, e)\n\n return (foldl snoc e0 ses)\n\n orExpression <- rule (op Grace.Parser.Or Syntax.Or andExpression)\n\n andExpression <- rule (op Grace.Parser.And Syntax.And equalExpression)\n\n equalExpression <- rule (op Grace.Parser.DoubleEquals Syntax.Equal notEqualExpression)\n\n notEqualExpression <- rule (op Grace.Parser.NotEqual Syntax.NotEqual lessThanExpression)\n\n lessThanExpression <- rule (op Grace.Parser.OpenAngle Syntax.LessThan lessThanOrEqualExpression)\n\n lessThanOrEqualExpression <- rule (op Grace.Parser.LessThanOrEqual Syntax.LessThanOrEqual greaterThanExpression)\n\n greaterThanExpression <- rule (op Grace.Parser.CloseAngle Syntax.GreaterThan greaterThanOrEqualExpression)\n\n greaterThanOrEqualExpression <- rule (op Grace.Parser.GreaterThanOrEqual Syntax.GreaterThanOrEqual plusExpression)\n\n plusExpression <- rule (op Grace.Parser.Plus Syntax.Plus minusExpression)\n\n minusExpression <- rule (op Grace.Parser.Dash Syntax.Minus timesExpression)\n\n timesExpression <- rule (op Grace.Parser.Times Syntax.Times modulusExpression)\n\n modulusExpression <- rule (op Grace.Parser.Modulus Syntax.Modulus divideExpression)\n\n divideExpression <- rule (op Grace.Parser.ForwardSlash Syntax.Divide applicationExpression)\n\n let application function argument = Syntax.Application\n { location = Syntax.location function\n , function\n , argument\n }\n\n applicationExpression <- rule do\n e <- ( do i <- (True <$ locatedToken Grace.Parser.Import) <|> pure False\n f <- ( do location <- locatedToken Grace.Parser.Prompt\n\n arguments <- projectExpression\n\n return \\import_ -> Syntax.Prompt{ location, import_, arguments, schema = Nothing }\n\n <|> do location <- locatedToken Grace.Parser.HTTP\n\n arguments <- projectExpression\n\n return \\import_ -> Syntax.HTTP{ location, import_, arguments, schema = Nothing }\n\n <|> do location <- locatedToken Grace.Parser.Read\n\n arguments <- projectExpression\n\n return \\import_ -> Syntax.Read{ location, import_, arguments, schema = Nothing }\n\n <|> do location <- locatedToken Grace.Parser.GitHub\n\n arguments <- projectExpression\n\n return \\import_ -> Syntax.GitHub{ location, import_, arguments, schema = Nothing }\n )\n\n pure (f i)\n\n <|> do i <- (True <$ locatedToken Grace.Parser.Export) <|> pure False\n f <- ( do location <- locatedToken Grace.Parser.Show\n\n arguments <- projectExpression\n\n return \\export -> Syntax.Show{ location, export, arguments, schema = Nothing }\n\n <|> do location <- locatedToken Grace.Parser.Show\n\n parseToken Grace.Parser.OpenParenthesis\n\n arguments <- operatorExpression\n\n parseToken Grace.Parser.Colon\n\n schema <- quantifiedType\n\n parseToken Grace.Parser.CloseParenthesis\n\n return \\export -> Syntax.Show{ location, export, arguments, schema = Just schema }\n )\n\n pure (f i)\n\n <|> do location <- locatedToken Grace.Parser.Fold\n\n handlers <- projectExpression\n\n return Syntax.Fold{ location, handlers }\n\n <|> do projectExpression\n )\n\n es <- many projectExpression\n\n return (foldl application e es)\n\n projectExpression <- rule do\n let snoc location record f =\n f location record\n\n let parseField = do\n ~(fieldLocation, field) <- locatedRecordLabel\n\n return Syntax.Field{ fieldLocation, field }\n\n let parseSingle = do\n single <- parseField\n\n return \\location larger ->\n Syntax.Project{ location, larger, smaller = Syntax.Single{ single } }\n\n let parseMultiple = do\n multipleLocation <- locatedToken Grace.Parser.OpenBrace\n\n multiple <- parseField `sepBy` parseToken Grace.Parser.Comma\n\n parseToken Grace.Parser.CloseBrace\n\n return \\location larger ->\n Syntax.Project{ location, larger, smaller = Multiple{ multipleLocation, multiple } }\n\n let parseIndex = do\n index <- dotNumber\n\n return \\location larger ->\n Syntax.Project{ location, larger, smaller = Index { index } }\n\n let parseSlice = do\n let withSign (sign, n) = case sign of\n Unsigned -> fromIntegral n\n Positive -> fromIntegral n\n Negative -> negate (fromIntegral n)\n\n parseToken Grace.Parser.OpenBracket\n\n begin <- fmap (fmap withSign) (optional int)\n\n parseToken Grace.Parser.Colon\n\n end <- fmap (fmap withSign) (optional int)\n\n parseToken Grace.Parser.CloseBracket\n\n return \\location larger ->\n Syntax.Project\n { location\n , larger\n , smaller = Slice{ begin, end }\n }\n\n let parseDotAccess = do\n smaller <- parseIndex <|> (parseToken Grace.Parser.Dot *> (parseSingle <|> parseMultiple))\n\n pure smaller\n\n record <- alternativeExpression\n\n projections <- many\n (do smaller <- parseSlice <|> parseDotAccess\n\n pure smaller\n )\n\n return (foldl (snoc (Syntax.location record)) record projections)\n\n alternativeExpression <- rule\n ( do ~(location, name) <- locatedAlternative\n\n argument <- primitiveExpression\n\n return Syntax.Alternative{ location, name, argument }\n\n <|> primitiveExpression\n )\n\n\n primitiveExpression <- rule\n ( do ~(location, name) <- locatedLabel\n\n return Syntax.Variable{ location, name }\n\n <|> do location <- locatedToken Grace.Parser.OpenBracket\n\n optional (parseToken Grace.Parser.Comma)\n\n elements <- expression `sepBy` parseToken Grace.Parser.Comma\n\n optional (parseToken Grace.Parser.Comma)\n\n parseToken Grace.Parser.CloseBracket\n\n return Syntax.List{ location, elements = Seq.fromList elements }\n\n <|> do location <- locatedToken Grace.Parser.OpenBrace\n\n optional (parseToken Grace.Parser.Comma)\n\n fieldValues <- fieldValue `sepBy` parseToken Grace.Parser.Comma\n\n optional (parseToken Grace.Parser.Comma)\n\n parseToken Grace.Parser.CloseBrace\n\n return Syntax.Record{ location, fieldValues }\n\n <|> do location <- locatedToken Grace.Parser.True_\n\n return Syntax.Scalar{ location, scalar = Syntax.Bool True }\n\n <|> do location <- locatedToken Grace.Parser.False_\n\n return Syntax.Scalar{ location, scalar = Syntax.Bool False }\n\n <|> do location <- locatedToken Grace.Parser.Null\n\n return Syntax.Scalar{ location, scalar = Syntax.Null }\n\n <|> do let withSign Unsigned n = Syntax.Real n\n withSign Positive n = Syntax.Real n\n withSign Negative n = Syntax.Real (negate n)\n\n ~(location, (sign, n)) <- locatedReal\n\n return Syntax.Scalar{ location, scalar = withSign sign n }\n\n <|> do let withSign Unsigned n = Syntax.Natural (fromIntegral n)\n withSign Positive n = Syntax.Integer (fromIntegral n)\n withSign Negative n = Syntax.Integer (negate (fromIntegral n))\n\n ~(location, (sign, n)) <- locatedInt\n\n return Syntax.Scalar{ location, scalar = withSign sign n }\n\n <|> do location <- locatedToken Grace.Parser.Some\n\n return Syntax.Builtin{ location, builtin = Syntax.Some }\n\n <|> do location <- locatedToken Grace.Parser.YAML\n\n return Syntax.Builtin{ location, builtin = Syntax.YAML }\n\n <|> do location <- locatedToken Grace.Parser.Indexed\n\n return Syntax.Builtin{ location, builtin = Syntax.Indexed }\n\n <|> do location <- locatedToken Grace.Parser.Length\n\n return Syntax.Builtin{ location, builtin = Syntax.Length }\n\n <|> do location <- locatedToken Grace.Parser.Map\n\n return Syntax.Builtin{ location, builtin = Syntax.Map }\n\n <|> do location <- locatedToken Grace.Parser.Abs\n\n return Syntax.Builtin{ location, builtin = Syntax.Abs }\n\n <|> do location <- locatedToken Grace.Parser.Reveal\n\n return Syntax.Builtin{ location, builtin = Syntax.Reveal }\n\n <|> do ~(location, chunks) <- locatedChunks\n\n return Syntax.Text{ location, chunks }\n\n <|> do ~(location, file) <- locatedFile\n\n return Syntax.Embed{ location, embedded = Path file AsCode }\n\n <|> do ~(location, uri) <- locatedURI\n\n return Syntax.Embed\n { location\n , embedded = Grace.Input.URI uri AsCode\n }\n\n <|> do parseToken Grace.Parser.OpenParenthesis\n\n e <- expression\n\n parseToken Grace.Parser.CloseParenthesis\n\n return e\n )\n\n parseLetAssignment <- rule do\n let parseDefinition = do\n ~(nameLocation, name) <- locatedLabel\n\n bindings <- many parseBinding\n\n annotation <- optional do\n parseToken Grace.Parser.Colon\n\n t <- quantifiedType\n\n return t\n\n parseToken Grace.Parser.Equals\n\n assignment <- expression\n\n return \\assignmentLocation -> Syntax.Define\n { assignmentLocation\n , definition = Syntax.Definition\n { nameLocation\n , name\n , bindings\n , annotation\n , assignment\n }\n }\n\n let parseBind = do\n -- We don't use `parseBinding` here because otherwise\n -- `parseDefinition` and `parseBind` will overlap for\n -- assignments of the form `let x = e …` and then the parser\n -- will double the number of branches it tracks for each such\n -- assignment, leading to an exponential blowup in the parser.\n -- Using `parseAdornedBinding` here ensures that every `let`\n -- assignment is parsed unambiguously as a `Definition` or\n -- `Bind`.\n binding <- parseAdornedBinding\n\n parseToken Grace.Parser.Equals\n\n assignment <- expression\n\n return \\assignmentLocation -> Syntax.Bind\n { assignmentLocation\n , monad = IdentityMonad\n , binding\n , assignment\n }\n\n assignmentLocation <- locatedToken Grace.Parser.Let\n\n f <- parseDefinition <|> parseBind\n\n return (f assignmentLocation)\n\n parseAssignment <- rule do\n let parseListAssignment = do\n assignmentLocation <- locatedToken Grace.Parser.For\n\n binding <- parseBinding\n\n parseToken Grace.Parser.Of\n\n assignment <- expression\n\n return Syntax.Bind\n { assignmentLocation\n , monad = ListMonad\n , binding\n , assignment\n }\n\n let parseOptionalAssignment = do\n assignmentLocation <- locatedToken Grace.Parser.If\n\n parseToken Grace.Parser.Let\n\n binding <- parseBinding\n\n parseToken Grace.Parser.Equals\n\n assignment <- expression\n\n return Syntax.Bind\n { assignmentLocation\n , monad = OptionalMonad\n , binding\n , assignment\n }\n\n parseLetAssignment <|> parseListAssignment <|> parseOptionalAssignment\n\n recordLabel <- rule (reservedLabel <|> label <|> alternative <|> text)\n\n locatedRecordLabel <- rule\n ( locatedReservedLabel\n <|> locatedLabel\n <|> locatedAlternative\n <|> locatedText\n )\n\n fieldValue <- rule do\n let setting = do\n ~(nameLocation, name) <- locatedRecordLabel\n\n bindings <- many parseBinding\n\n annotation <- optional do\n parseToken Grace.Parser.Colon\n\n t <- quantifiedType\n\n return t\n\n parseToken Grace.Parser.Colon\n\n assignment <- expression\n\n return Syntax.Definition\n { nameLocation\n , name\n , bindings\n , annotation\n , assignment\n }\n\n let pun = do\n ~(nameLocation, name) <- locatedRecordLabel\n\n return Syntax.Definition\n { nameLocation\n , name\n , bindings = []\n , annotation = Nothing\n , assignment = Syntax.Variable\n { location = nameLocation\n , name\n }\n }\n\n setting <|> pun\n\n domain <- rule\n ( do parseToken Grace.Parser.Type\n\n return Domain.Type\n\n <|> do parseToken Grace.Parser.Fields\n\n return Domain.Fields\n\n <|> do parseToken Grace.Parser.Alternatives\n\n return Domain.Alternatives\n )\n\n quantifiedType <- rule do\n fss <- many\n ( do location <- locatedToken Grace.Parser.Forall\n\n fs <- some do\n parseToken Grace.Parser.OpenParenthesis\n\n ~(typeVariableOffset, typeVariable) <- locatedLabel\n\n parseToken Grace.Parser.Colon\n\n domain_ <- domain\n\n parseToken Grace.Parser.CloseParenthesis\n\n return \\location_ type_ -> Type.Forall\n { location = location_\n , nameLocation = typeVariableOffset\n , name = typeVariable\n , domain = domain_\n , type_\n }\n\n parseToken Grace.Parser.Dot\n\n return (map ($ location) fs)\n )\n\n t <- functionType\n\n return (foldr ($) t (concat fss))\n\n functionType <- rule do\n let function input output =\n Type.Function{ location = Type.location input, input, output }\n\n ts <- applicationType `sepBy1` parseToken Grace.Parser.Arrow\n\n return (foldr function (NonEmpty.last ts) (NonEmpty.init ts))\n\n applicationType <- rule\n ( do location <- locatedToken Grace.Parser.List\n\n type_ <- primitiveType\n\n return Type.List{ location, type_ }\n\n <|> do location <- locatedToken Grace.Parser.Optional\n\n type_ <- primitiveType\n\n return Type.Optional{ location, type_ }\n\n <|> do primitiveType\n )\n\n primitiveType <- rule\n ( do location <- locatedToken Grace.Parser.Bool\n\n return Type.Scalar{ location, scalar = Monotype.Bool }\n\n <|> do location <- locatedToken Grace.Parser.Real\n\n return Type.Scalar{ location, scalar = Monotype.Real }\n\n <|> do location <- locatedToken Grace.Parser.Integer\n\n return Type.Scalar{ location, scalar = Monotype.Integer }\n\n <|> do location <- locatedToken Grace.Parser.JSON\n\n return Type.Scalar{ location, scalar = Monotype.JSON }\n\n <|> do location <- locatedToken Grace.Parser.Natural\n\n return Type.Scalar{ location, scalar = Monotype.Natural }\n\n <|> do location <- locatedToken Grace.Parser.Text\n\n return Type.Scalar{ location, scalar = Monotype.Text }\n\n <|> do location <- locatedToken Grace.Parser.Key\n\n return Type.Scalar{ location, scalar = Monotype.Key }\n\n <|> do ~(location, name) <- locatedLabel\n\n return Type.VariableType{ location, name }\n\n <|> do locatedOpenBrace <- locatedToken Grace.Parser.OpenBrace\n\n optional (parseToken Grace.Parser.Comma)\n\n fieldTypes <- fieldType `endBy` parseToken Grace.Parser.Comma\n\n toFields <-\n ( do text_ <- recordLabel\n\n pure (\\fs -> Type.Fields fs (Monotype.VariableFields text_))\n\n <|> do pure (\\fs -> Type.Fields fs Monotype.EmptyFields)\n\n <|> do f <- fieldType\n\n pure (\\fs -> Type.Fields (fs <> [ f ]) Monotype.EmptyFields)\n )\n\n optional (parseToken Grace.Parser.Comma)\n\n parseToken Grace.Parser.CloseBrace\n\n return Type.Record\n { location = locatedOpenBrace\n , fields = toFields fieldTypes\n }\n\n <|> do locatedOpenAngle <- locatedToken Grace.Parser.OpenAngle\n\n optional (parseToken Grace.Parser.Bar)\n\n alternativeTypes <- alternativeType `endBy` parseToken Grace.Parser.Bar\n\n toAlternatives <-\n ( do text_ <- label\n\n return (\\as -> Type.Alternatives as (Monotype.VariableAlternatives text_))\n\n <|> do pure (\\as -> Type.Alternatives as Monotype.EmptyAlternatives)\n\n <|> do a <- alternativeType\n return (\\as -> Type.Alternatives (as <> [ a ]) Monotype.EmptyAlternatives)\n )\n\n optional (parseToken Grace.Parser.Bar)\n\n parseToken Grace.Parser.CloseAngle\n\n return Type.Union\n { location = locatedOpenAngle\n , alternatives = toAlternatives alternativeTypes\n }\n\n <|> do parseToken Grace.Parser.OpenParenthesis\n\n t <- quantifiedType\n\n parseToken Grace.Parser.CloseParenthesis\n\n return t\n )\n\n fieldType <- rule do\n field <- recordLabel\n\n parseToken Grace.Parser.Colon\n\n t <- quantifiedType\n\n return (field, t)\n\n alternativeType <- rule do\n a <- alternative\n\n parseToken Grace.Parser.Colon\n\n t <- quantifiedType\n\n return (a, t)\n\n -- Used for parsing a string interpolation\n expressionEndingWithBrace <- rule do\n a <- expression\n\n parseToken Grace.Parser.CloseBrace\n\n return a\n\n replCommand <- rule\n (fmap Evaluate expression <|> fmap Assign parseLetAssignment)\n\n return case form of\n Expression continuation ->\n fmap continuation expression\n Interpolation continuation ->\n fmap continuation expressionEndingWithBrace\n REPLCommand continuation ->\n fmap continuation replCommand\n\n-- | Parse a complete expression\nparse\n :: String\n -- ^ Name of the input (used for error messages)\n -> Text\n -- ^ Source code\n -> Either ParseError (Syntax Offset Input)\nparse = parseGrammaticalForm (Expression id)\n\n-- | Parse a grammatical form\nparseGrammaticalForm\n :: GrammaticalForm r\n -- ^ Grammatical form to parse\n -> String\n -- ^ Name of the input (used for error messages)\n -> Text\n -- ^ Source code\n -> Either ParseError r\nparseGrammaticalForm form name code = do\n tokens <- lex name code\n\n case Earley.fullParses (Earley.parser (grammar form)) tokens of\n ([], Report{ unconsumed }) -> do\n let offset =\n case unconsumed of\n [] ->\n Offset (Text.length code)\n locatedToken_ : _ ->\n Offset (stateOffset (state locatedToken_))\n\n Left (ParsingFailed Location{ name, code, offset })\n\n (result : _, _) -> do\n return result\n\n-- | Parse a @let@ assignment\nparseREPLCommand\n :: String\n -- ^ Name of the input (used for error messages)\n -> Text\n -- ^ Source code\n -> Either ParseError REPLCommand\nparseREPLCommand = parseGrammaticalForm (REPLCommand id)\n" }, { "path": "src/Grace/Pretty.hs", "content": "{-# LANGUAGE FlexibleInstances #-}\n\n-- | Pretty-printing logic\nmodule Grace.Pretty\n ( -- * Prettyprinting\n renderStrict\n , renderIO\n , toText\n , toSmart\n , Pretty(..)\n\n -- * Highlighting\n , keyword\n , punctuation\n , label\n , scalar\n , builtin\n , operator\n ) where\n\nimport Data.Scientific (Scientific)\nimport Data.Text (Text)\nimport Data.Void (Void)\nimport Numeric.Natural (Natural)\nimport Prettyprinter (Doc, LayoutOptions(..), PageWidth(..))\nimport Prettyprinter.Render.Terminal (AnsiStyle)\nimport System.IO (Handle)\n\nimport qualified Grace.Width as Width\nimport qualified Prettyprinter as Pretty\nimport qualified Prettyprinter.Render.Terminal as Pretty.Terminal\nimport qualified Prettyprinter.Render.Text as Pretty.Text\nimport qualified Text.URI as URI\n\n{-| Convenient wrapper around\n \"Prettyprinter.Render.Terminal\".`Pretty.Terminal.renderStrict`\n / \"Prettyprinter.Render.Text\".`Pretty.Text.renderStrict`\n-}\nrenderStrict\n :: Pretty a\n => Bool\n -- ^ `True` enable syntax highlighting\n -> Int\n -- ^ Available columns\n -> a\n -> Text\nrenderStrict highlight columns =\n render . Pretty.layoutSmart (layoutOptions columns) . pretty\n where\n render =\n if highlight\n then Pretty.Terminal.renderStrict\n else Pretty.Text.renderStrict\n\n{-| Convenient wrapper around\n \"Prettyprinter.Render.Terminal\".`Pretty.Terminal.renderIO`\n / \"Prettyprinter.Render.Text\".`Pretty.Text.renderIO`\n-}\nrenderIO\n :: Pretty a\n => Bool\n -- ^ `True` enables syntax highlighting\n -> Int\n -- ^ Available columns\n -> Handle\n -> a\n -> IO ()\nrenderIO highlight columns handle =\n render handle . Pretty.layoutSmart (layoutOptions columns) . pretty\n where\n render =\n if highlight\n then Pretty.Terminal.renderIO\n else Pretty.Text.renderIO\n\n-- | Simple conversion of a document to `Text`\ntoText :: Pretty a => a -> Text\ntoText = Pretty.Text.renderStrict . Pretty.layoutCompact . pretty\n\n{-| This is like @\"Prettyprinter\".`Prettyprinter.Pretty`@, except that this\n can return a `Doc` with `AnsiStyle` annotations\n-}\nclass Pretty a where\n pretty :: a -> Doc AnsiStyle\n\ninstance Pretty Double where\n pretty = Pretty.pretty\n\ninstance Pretty Scientific where\n pretty = Pretty.pretty . show\n\ninstance Pretty Int where\n pretty = Pretty.pretty\n\ninstance Pretty Integer where\n pretty = Pretty.pretty\n\ninstance Pretty Natural where\n pretty = Pretty.pretty\n\ninstance Pretty Text where\n pretty = Pretty.pretty\n\ninstance Pretty () where\n pretty = Pretty.pretty\n\ninstance Pretty Void where\n pretty = Pretty.pretty\n\ninstance Pretty String where\n pretty = Pretty.pretty\n\ninstance Pretty URI.URI where\n pretty = Pretty.pretty . URI.render\n\ninstance Pretty (Doc AnsiStyle) where\n pretty = id\n\nlayoutOptions\n :: Int\n -- ^ Available columns\n -> LayoutOptions\nlayoutOptions columns =\n LayoutOptions { layoutPageWidth = AvailablePerLine columns 1 }\n\n-- | Highlight a keyword (e.g. @let@ or @fold@)\nkeyword :: Doc AnsiStyle -> Doc AnsiStyle\nkeyword =\n Pretty.annotate\n ( Pretty.Terminal.bold\n <> Pretty.Terminal.colorDull Pretty.Terminal.Green\n )\n\n-- | Highlight punctuation (e.g. @{@ or @,@)\npunctuation :: Doc AnsiStyle -> Doc AnsiStyle\npunctuation =\n Pretty.annotate\n ( Pretty.Terminal.bold\n <> Pretty.Terminal.colorDull Pretty.Terminal.Green\n )\n\n-- | Highlight a label (e.g. @x@)\nlabel :: Doc AnsiStyle -> Doc AnsiStyle\nlabel = Pretty.annotate mempty\n\n-- | Highlight a scalar (e.g. @1@ or @\\\"abc\\\"@)\nscalar :: Doc AnsiStyle -> Doc AnsiStyle\nscalar = Pretty.annotate (Pretty.Terminal.colorDull Pretty.Terminal.Magenta)\n\n-- | Highlight a built-in (e.g. @length@)\nbuiltin :: Doc AnsiStyle -> Doc AnsiStyle\nbuiltin = Pretty.annotate Pretty.Terminal.underlined\n\n-- | Highlight an operator (e.g. @+@ or @&&@)\noperator :: Doc AnsiStyle -> Doc AnsiStyle\noperator =\n Pretty.annotate\n ( Pretty.Terminal.bold\n <> Pretty.Terminal.colorDull Pretty.Terminal.Green\n )\n\n-- | Render as `Text` using the smart layout algorithm\ntoSmart :: Pretty a => a -> Text\ntoSmart = Grace.Pretty.renderStrict False Width.defaultWidth\n" }, { "path": "src/Grace/Prompt/Types.hs", "content": "-- | Types associated with prompting LLMs\nmodule Grace.Prompt.Types\n ( -- * Types\n Prompt(..)\n , Message(..)\n , Effort(..)\n ) where\n\nimport Data.Aeson (FromJSON, ToJSON)\nimport Data.Text (Text)\nimport GHC.Generics (Generic)\nimport Grace.Decode (FromGrace, Key(..), ToGraceType)\nimport Grace.Encode (ToGrace)\n\n-- | Arguments to the @prompt@ keyword\ndata Prompt = Prompt\n { key :: Grace.Decode.Key\n , text :: Maybe Text\n , history :: Maybe [Message]\n , model :: Maybe Text\n , search :: Maybe Bool\n , effort :: Maybe Effort\n } deriving stock (Generic)\n deriving anyclass (FromGrace, FromJSON, ToGrace, ToGraceType, ToJSON)\n\n-- | A message added to the conversation history\ndata Message\n = System{ name :: Maybe Text, text :: Text }\n | User{ name :: Maybe Text, text :: Text }\n | Assistant{ name :: Maybe Text, text :: Text }\n deriving stock (Generic)\n deriving anyclass (FromGrace, FromJSON, ToGrace, ToGraceType, ToJSON)\n\n-- | The amount of effort a reasoning model puts into reasoning\ndata Effort = Minimal | Low | Medium | High\n deriving stock (Generic)\n deriving anyclass (FromGrace, FromJSON, ToGrace, ToGraceType, ToJSON)\n" }, { "path": "src/Grace/Prompt.hs", "content": "{-# LANGUAGE OverloadedLists #-}\n{-# LANGUAGE RecordWildCards #-}\n\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n\n-- | This module implements the @prompt@ keyword\nmodule Grace.Prompt\n ( -- * Prompting\n Prompt(..)\n , Effort(..)\n , prompt\n\n -- * Exceptions\n , UnsupportedModelOutput(..)\n ) where\n\nimport Control.Exception.Safe (Exception(..), SomeException(..))\nimport Control.Monad.IO.Class (MonadIO(..))\nimport Data.Foldable (fold, toList)\nimport Data.Text (Text)\nimport Data.Typeable (Typeable)\nimport Data.Vector (Vector)\nimport Grace.Decode (FromGrace(..), Key(..), ToGraceType(..))\nimport Grace.Input (Input(..))\nimport Grace.Location (Location(..))\nimport Grace.Monad (Grace)\nimport Grace.Pretty (Pretty(..))\nimport Grace.Prompt.Types (Effort(..), Prompt(..))\nimport Grace.Type (Type(..))\nimport Grace.Value (Value)\nimport OpenAI.V1.Models (Model(..))\nimport OpenAI.V1.ResponseFormat (JSONSchema(..), ResponseFormat(..))\nimport System.FilePath (())\n\nimport OpenAI.V1.Chat.Completions\n ( ChatCompletionObject(..)\n , Choice(..)\n , CreateChatCompletion(..)\n , Message(..)\n , ReasoningEffort(..)\n , WebSearchOptions(..)\n , _CreateChatCompletion\n )\n\nimport {-# SOURCE #-} qualified Grace.Interpret as Interpret\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Control.Monad.Reader as Reader\nimport qualified Data.Aeson as Aeson\nimport qualified Data.ByteString.Lazy as ByteString.Lazy\nimport qualified Data.Map as Map\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Encoding\nimport qualified Data.Vector as Vector\nimport qualified Grace.DataFile as DataFile\nimport qualified Grace.HTTP as HTTP\nimport qualified Grace.Import as Import\nimport qualified Grace.Infer as Infer\nimport qualified Grace.Monotype as Monotype\nimport qualified Grace.Pretty as Pretty\nimport qualified Grace.Prompt.Types as Prompt.Types\nimport qualified Grace.Type as Type\nimport qualified Grace.Value as Value\nimport qualified OpenAI.V1.Chat.Completions as Completions\nimport qualified Prettyprinter as Pretty\nimport qualified System.IO.Unsafe as Unsafe\n\nderiving anyclass instance FromGrace ReasoningEffort\nderiving anyclass instance ToGraceType ReasoningEffort\n\n-- | Context used to teach the LLM to code in Grace\nstaticAssets :: [ Message (Vector Completions.Content) ]\nstaticAssets = Unsafe.unsafePerformIO do\n let instructions₀ =\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text =\n \"Here are some resources which explain how to program using the Fall-from-Grace programming language (\\\"Grace\\\" for short)\"\n }\n ]\n }\n ]\n\n prompts <- do\n let files =\n [ \"abnf.md\"\n , \"inference.md\"\n ]\n\n let process :: FilePath -> IO (Message (Vector Completions.Content))\n process file = do\n text <- DataFile.readDataFile (\"prompts\" file)\n\n return System\n { name = Just (Text.pack file)\n , content = [ Completions.Text{ text } ]\n }\n\n traverse process files\n\n let instructions₁ =\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text =\n \"Here are some sample Grace programs showcasing various idioms and language features\"\n }\n ]\n }\n ]\n\n examples <- do\n let files =\n [ \"learn-in-y-minutes.ffg\"\n , \"chaining.ffg\"\n , \"prompt.ffg\"\n , \"tools.ffg\"\n ]\n\n let process :: FilePath -> IO (Message (Vector Completions.Content))\n process file = do\n text <- DataFile.readDataFile (\"examples\" file)\n\n return System\n { name = Just (Text.pack file)\n , content = [ Completions.Text{ text } ]\n }\n\n traverse process files\n\n return (instructions₀ <> prompts <> instructions₁ <> examples)\n{-# NOINLINE staticAssets #-}\n\ntoJSONSchema :: Type a -> Either (UnsupportedModelOutput a) Aeson.Value\ntoJSONSchema original = loop original\n where\n loop Type.Forall{ location, name, type_ } = do\n loop\n (Type.substituteType name 0 Type.Scalar{ location, scalar = Monotype.Text } type_)\n loop Type.Optional{ type_ } = do\n present <- loop type_\n\n let absent = Aeson.object [ (\"type\", \"null\") ]\n\n return\n ( Aeson.object\n [ (\"anyOf\", Aeson.toJSON ([ present, absent ] :: [ Aeson.Value ]))\n ]\n )\n\n loop Type.List{ type_ } = do\n items <- loop type_\n\n return (Aeson.object [ (\"type\", \"array\"), (\"items\", items) ])\n loop Type.Record{ fields = Type.Fields fieldTypes _ } = do\n let toProperty (field, type_) = do\n property <- loop type_\n\n return (field, property)\n\n properties <- traverse toProperty fieldTypes\n\n let required = fmap fst fieldTypes\n\n return\n ( Aeson.object\n [ (\"type\", \"object\")\n , (\"properties\", Aeson.toJSON (Map.fromList properties))\n , (\"additionalProperties\", Aeson.toJSON False)\n , (\"required\", Aeson.toJSON required)\n ]\n )\n loop Type.Union{ alternatives = Type.Alternatives alternativeTypes _ } = do\n let toAnyOf (alternative, type_) = do\n contents <- loop type_\n\n return\n (Aeson.object\n [ (\"type\", \"object\")\n , ( \"properties\"\n , Aeson.object\n [ ( \"tag\"\n , Aeson.object\n [ (\"type\", \"string\")\n , (\"const\", Aeson.toJSON alternative)\n ]\n )\n , (\"contents\", contents)\n ]\n )\n , (\"required\", Aeson.toJSON ([ \"tag\", \"contents\" ] :: [Text]))\n , (\"additionalProperties\", Aeson.toJSON False)\n ]\n )\n\n anyOfs <- traverse toAnyOf alternativeTypes\n\n return\n ( Aeson.object\n [ (\"type\", \"object\"), (\"anyOf\", Aeson.toJSON anyOfs) ]\n )\n loop Type.Scalar{ scalar = Monotype.Bool } =\n return (Aeson.object [ (\"type\", \"boolean\") ])\n loop Type.Scalar{ scalar = Monotype.Real } =\n return (Aeson.object [ (\"type\", \"number\") ])\n loop Type.Scalar{ scalar = Monotype.Integer } =\n return (Aeson.object [ (\"type\", \"integer\") ])\n loop Type.Scalar{ scalar = Monotype.JSON } =\n return (Aeson.object [ ])\n loop Type.Scalar{ scalar = Monotype.Natural } =\n return\n (Aeson.object\n [ (\"type\", \"number\")\n -- , (\"minimum\", Aeson.toJSON (0 :: Int))\n -- ^ Not supported by OpenAI\n ]\n )\n loop Type.Scalar{ scalar = Monotype.Text } =\n return (Aeson.object [ (\"type\", \"string\") ])\n loop _ = Left UnsupportedModelOutput{ original }\n\ntoResponseFormat\n :: Maybe (Type a) -> Either (UnsupportedModelOutput a) ResponseFormat\ntoResponseFormat Nothing = do\n return JSON_Object\ntoResponseFormat (Just type_) = do\n value <- toJSONSchema type_\n\n return JSON_Schema\n { json_schema = JSONSchema\n { description = Nothing\n , name = \"result\"\n , schema = Just value\n , strict = Just True\n }\n }\n\n-- | Implementation of the @prompt@ keyword\nprompt\n :: IO [(Text, Type Location, Value Location)]\n -> Bool\n -> Location\n -> Prompt\n -> Maybe (Type Location)\n -> Grace (Value Location)\nprompt generateContext import_ location Prompt{ key = Grace.Decode.Key{ text = key }, text, history, model, search, effort } schema = do\n keyToMethods <- liftIO HTTP.getMethods\n\n let methods = keyToMethods (Text.strip key)\n\n let defaultedSearch = case search of\n Just s -> s\n Nothing -> False\n\n let web_search_options\n | defaultedSearch = Just WebSearchOptions\n { search_context_size = Nothing\n , user_location = Nothing\n }\n | otherwise = Nothing\n\n let defaultedModel = case model of\n Just m -> m\n _ | defaultedSearch -> \"gpt-5-search-api\"\n | otherwise -> \"gpt-5-mini\"\n\n let reasoning_effort = do\n e <- effort\n\n return case e of\n Minimal -> ReasoningEffort_Minimal\n Low -> ReasoningEffort_Low\n Medium -> ReasoningEffort_Medium\n High -> ReasoningEffort_High\n\n let toOutput ChatCompletionObject{ choices = [ Choice{ message = Assistant{ assistant_content = Just output } } ] } = do\n return output\n toOutput ChatCompletionObject{ choices } = do\n Exception.throwIO UnexpectedModelResponse{ choices }\n\n let lastMessage = case text of\n Nothing ->\n [ ]\n Just t ->\n [ User\n { name = Nothing\n , content =\n [ Completions.Text{ text = t } ]\n }\n ]\n\n let initMessages = do\n message <- fold history\n\n return case message of\n Prompt.Types.System{ name, text = t } -> System\n { name\n , content = [ Completions.Text{ text = t } ]\n }\n Prompt.Types.Assistant{ name, text = t } -> Assistant\n { name\n , assistant_content = Just [ Completions.Text{ text = t } ]\n , refusal = Nothing\n , assistant_audio = Nothing\n , tool_calls = Nothing\n }\n Prompt.Types.User{ name, text = t } -> User\n { name\n , content = [ Completions.Text{ text = t } ]\n }\n\n let conversation = initMessages <> lastMessage\n\n if import_\n then do\n let retry errors\n | (_, interpretError) : rest <- errors\n , length rest == 3 = do\n Exception.throwIO interpretError\n | otherwise = do\n let instructions₀ = case conversation of\n [ ] ->\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text = \"Generate a Grace expression.\"\n }\n ]\n }\n ]\n\n [ _ ] ->\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text = \"Generate a Grace expression according to the previous message.\"\n }\n ]\n }\n ]\n\n _ ->\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text = \"Generate a Grace expression according to the previous conversation.\"\n }\n ]\n }\n ]\n\n let expect = case schema of\n Nothing ->\n [ ]\n Just s ->\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text = \"Your generated Grace expression must have the following type\"\n }\n ]\n }\n , System\n { name = Just \"Type\"\n , content =\n [ Completions.Text\n { text = Pretty.toSmart s\n }\n ]\n }\n ]\n\n bindings <- liftIO generateContext\n\n let renderAssignment (name, type_, _) =\n Pretty.toSmart (Pretty.group (Pretty.flatAlt long short)) <> \"\\n\\n\"\n where\n long = Pretty.label (pretty name)\n <> \" \"\n <> Pretty.punctuation \":\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (pretty type_)\n\n short = Pretty.label (pretty name)\n <> \" \"\n <> Pretty.punctuation \":\"\n <> \" \"\n <> pretty type_\n\n let environment = do\n binding <- bindings\n\n return System\n { name = Just \"Value\"\n , content =\n [ Completions.Text\n { text = renderAssignment binding\n }\n ]\n }\n\n let instructions₁ = case environment of\n [ ] ->\n [ ]\n _ ->\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text = \"You may use any of the following values to generate your Grace expression, all of which are in scope.\"\n }\n ]\n }\n ]\n\n let instructions₂ =\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text = \"Output a naked Grace expression without any code fence or explanation. Your response in its entirety should be a valid input to the Grace interpreter.\"\n }\n ]\n }\n ]\n\n let failedAttempts = do\n (program, interpretError) <- reverse errors\n\n let attempt = Assistant\n { name = Just \"Attempt\"\n , assistant_content = Just [ Completions.Text{ text = program } ]\n , refusal = Nothing\n , assistant_audio = Nothing\n , tool_calls = Nothing\n }\n\n let failure = System\n { name = Just \"Error\"\n , content =\n [ Completions.Text\n { text = Text.pack (displayException interpretError) }\n ]\n }\n\n [ attempt, failure ]\n\n let messages =\n Vector.fromList\n ( staticAssets\n <> conversation\n <> instructions₀\n <> expect\n <> instructions₁\n <> environment\n <> instructions₂\n <> failedAttempts\n )\n\n chatCompletionObject <- liftIO do\n HTTP.createChatCompletion methods _CreateChatCompletion\n { messages\n , model = Model defaultedModel\n , web_search_options\n , reasoning_effort\n }\n\n output <- toOutput chatCompletionObject\n\n parent <- Reader.ask\n\n Reader.local (\\i -> i <> Code \"(prompt)\" output) do\n child <- Reader.ask\n\n Import.referentiallySane parent child\n\n Interpret.interpretWith bindings schema\n `Exception.catch` \\(interpretError :: SomeException) -> do\n retry ((output, interpretError) : errors)\n\n\n (_, e) <- retry []\n\n return e\n\n else do\n let instructions₀ = case conversation of\n [ ] ->\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text = \"Generate JSON.\"\n }\n ]\n }\n ]\n\n [ _ ] ->\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text = \"Generate JSON according to the previous message.\"\n }\n ]\n }\n ]\n\n _ ->\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text = \"Generate JSON according to the previous conversation.\"\n }\n ]\n }\n ]\n\n let defaultedSchema = do\n s <- schema\n\n return (Type.defaultTo Type.Scalar{ scalar = Monotype.Text, location } s)\n\n let decode_ text_ = do\n let bytes = Encoding.encodeUtf8 text_\n\n let lazyBytes = ByteString.Lazy.fromStrict bytes\n\n case Aeson.eitherDecode lazyBytes of\n Left message_ -> Exception.throwIO ModelDecodingFailed{ message = message_, text = text_ }\n Right v -> return v\n\n let expect = case schema of\n Nothing ->\n [ ]\n Just s ->\n [ System\n { name = Just \"Instructions\"\n , content =\n [ Completions.Text\n { text = \"Your generated JSON must have the following type\"\n }\n ]\n }\n , System\n { name = Just \"Type\"\n , content =\n [ Completions.Text\n { text = Pretty.toSmart s\n }\n ]\n }\n ]\n\n let instructions₁ = instructions₀ <> expect\n\n let extractText = do\n let extract text_ = do\n return (Value.Text Unknown text_)\n\n return\n ( [ ]\n , ResponseFormat_Text\n , extract\n )\n\n let extractRecord = do\n responseFormat <- case toResponseFormat defaultedSchema of\n Left exception -> Exception.throwIO exception\n Right result -> return result\n\n let extract text_ = do\n v <- decode_ text_\n\n value <- case defaultedSchema of\n Nothing -> do\n return (Infer.inferJSON v)\n Just s -> do\n Infer.checkJSON s v\n\n return (fmap (\\_ -> Unknown) value)\n\n return\n ( instructions₁\n , responseFormat\n , extract\n )\n\n let extractNonRecord = do\n let adjustedSchema = do\n s <- defaultedSchema\n\n return (Type.Record (Type.location s) (Type.Fields [(\"response\", s)] Monotype.EmptyFields))\n\n responseFormat <- case toResponseFormat adjustedSchema of\n Left exception -> Exception.throwIO exception\n Right result -> return result\n\n let extract text_ = do\n v <- decode_ text_\n\n expression <- case adjustedSchema of\n Nothing -> do\n return (Infer.inferJSON v)\n Just s -> do\n Infer.checkJSON s v\n\n case fmap (\\_ -> Unknown) expression of\n Value.Record _ [(\"response\", (_, response))] -> do\n return response\n other -> do\n return other\n\n return\n ( instructions₁\n , responseFormat\n , extract\n )\n\n (instructions₂, response_format, extract) <- case defaultedSchema of\n Just Type.Scalar{ scalar = Monotype.Text } -> extractText\n Just Type.Record{ } -> extractRecord\n _ -> extractNonRecord\n\n let messages₀ = Vector.fromList (conversation <> instructions₂)\n\n let messages₁ = case messages₀ of\n [ ] ->\n [ User\n { name = Nothing\n , content = [ Completions.Text{ text = \"\" } ]\n }\n ]\n\n _ -> messages₀\n\n chatCompletionObject <- liftIO do\n HTTP.createChatCompletion methods _CreateChatCompletion\n { messages = messages₁\n , model = Model defaultedModel\n , response_format = Just response_format\n , reasoning_effort\n }\n\n output <- toOutput chatCompletionObject\n\n extract output\n\n-- | The expected type for the model output can't be encoded as JSON\nnewtype UnsupportedModelOutput a = UnsupportedModelOutput{ original :: Type a }\n deriving stock (Show)\n\ninstance (Show a, Typeable a) => Exception (UnsupportedModelOutput a) where\n displayException UnsupportedModelOutput{ original } =\n \"Unsupported model output type\\n\\\n \\\\n\\\n \\The expected type for the model output is:\\n\\\n \\\\n\\\n \\\" <> Text.unpack (Pretty.toSmart original) <> \"\\n\\\n \\\\n\\\n \\… but that type cannot be encoded as JSON\"\n\n-- | The model didn't return an expected, successful response\ndata UnexpectedModelResponse = UnexpectedModelResponse{ choices :: Vector Choice }\n deriving stock (Show)\n\ninstance Exception UnexpectedModelResponse where\n displayException UnexpectedModelResponse{ choices } =\n case toList choices of\n [] ->\n \"Unexpected model response\\n\\\n \\\\n\\\n \\The model did not return any choices\"\n\n _ : _ : _ ->\n \"Unexpected model response\\n\\\n \\\\n\\\n \\The model returned multiple choices when only one was expected\"\n [ Choice{ message = Assistant{ refusal = Just refusal } } ] ->\n \"Unexpected model response\\n\\\n \\\\n\\\n \\The model refused to answer for the following reason:\\n\\\n \\\\n\\\n \\\" <> Text.unpack refusal\n [ Choice{ message = Assistant{ assistant_content = Nothing } } ] ->\n \"Unexpected model response\\n\\\n \\\\n\\\n \\The model returned an empty answer\"\n [ Choice{ message } ] ->\n \"Unexpected model response\\n\\\n \\\\n\\\n \\The model responded with a non-assistant message\\n\\\n \\\\n\\\n \\Message:\\n\\\n \\\\n\\\n \\\" <> string\n where\n bytes = ByteString.Lazy.toStrict (Aeson.encode message)\n\n string = case Encoding.decodeUtf8' bytes of\n Left _ -> show bytes\n Right text -> Text.unpack text\n\n-- | Model decoding failed\ndata ModelDecodingFailed = ModelDecodingFailed\n { message :: String\n , text :: Text\n } deriving stock (Show)\n\ninstance Exception ModelDecodingFailed where\n displayException ModelDecodingFailed{ message, text } =\n \"Failed to decode output as JSON\\n\\\n \\\\n\\\n \\The model produced the following output:\\n\\\n \\\\n\\\n \\\" <> Text.unpack text <> \"\\n\\\n \\\\n\\\n \\… which failed to decode as JSON.\\n\\\n \\\\n\\\n \\Decoding error message:\\n\\\n \\\\n\\\n \\\" <> message\n" }, { "path": "src/Grace/REPL.hs", "content": "{-# LANGUAGE FlexibleContexts #-}\n\n-- | This module contains the implementation of the @grace repl@ subcommand\n\nmodule Grace.REPL\n ( -- * REPL\n repl\n ) where\n\nimport Control.Applicative (empty)\nimport Control.Monad.IO.Class (MonadIO(..))\nimport Control.Monad.State (MonadState(..))\nimport Data.Bifunctor (first)\nimport Data.Foldable (toList)\nimport Data.List.NonEmpty (NonEmpty(..))\nimport Grace.Interpret (Input(..))\nimport Grace.Location (Location(..))\nimport Grace.Monad (Status(..))\nimport Grace.Parser (REPLCommand(..))\nimport System.Console.Haskeline (Interrupt(..))\nimport System.Console.Repline (CompleterStyle(..), MultiLine(..), ReplOpts(..))\n\nimport Control.Exception.Safe\n (Exception, SomeException, displayException, throwIO)\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Control.Monad as Monad\nimport qualified Control.Monad.State as State\nimport qualified Data.Text as Text\nimport qualified Data.Text.IO as Text.IO\nimport qualified Grace.Context as Context\nimport qualified Grace.Infer as Infer\nimport qualified Grace.Label as Label\nimport qualified Grace.Monad as Grace\nimport qualified Grace.Normalize as Normalize\nimport qualified Grace.Parser as Parser\nimport qualified Grace.Pretty as Pretty\nimport qualified Grace.Syntax as Syntax\nimport qualified Grace.Type as Type\nimport qualified Grace.Value as Value\nimport qualified Grace.Width as Width\nimport qualified System.Console.Haskeline.Completion as Completion\nimport qualified System.Console.Repline as Repline\nimport qualified System.IO as IO\n\n-- | Entrypoint for the @grace repl@ subcommand\nrepl :: IO ()\nrepl = do\n let err :: (Exception e, MonadIO io) => e -> io ()\n err e =\n liftIO (Text.IO.hPutStrLn IO.stderr (Text.pack (displayException e)))\n\n let command infer string = do\n let text = Text.pack string\n\n let locate offset = Location\n { name = \"(input)\"\n , code = text\n , offset\n }\n\n let interpret syntax₀ = do\n assignments₀ <- State.get\n\n let syntax₁ = case reverse assignments₀ of\n [] -> first locate syntax₀\n\n assignment₁ : assignments₁ -> Syntax.Let\n { location = Unknown\n , assignments = assignment₁ :| assignments₁\n , body = first locate syntax₀\n }\n\n let input = Code \"(input)\" text\n\n let status = Status\n { count = 0\n , context = []\n }\n\n let action = do\n (inferred, elaborated) <- Infer.infer syntax₁\n\n value <- Normalize.evaluate [] elaborated\n\n return (inferred, value)\n\n result <- liftIO (Exception.try (Grace.runGrace input status action))\n\n case result of\n Left (e :: SomeException) -> do\n return (Left e)\n\n Right ((inferred, value), Status{ context }) -> do\n let annotation = Context.complete context inferred\n\n let annotated =\n Value.quote (Value.complete context value)\n\n return (Right (annotation, annotated))\n\n case Parser.parseREPLCommand \"(input)\" text of\n Left parseError -> do\n err parseError\n\n Right (Evaluate syntax₀) -> do\n result <- interpret syntax₀\n\n case result of\n Left (e :: SomeException) -> do\n err e\n\n Right (annotation, annotated) -> do\n width <- liftIO Width.getWidth\n\n let document =\n if infer\n then Pretty.pretty annotation\n else Pretty.pretty annotated\n\n liftIO (Pretty.renderIO True width IO.stdout (document <> \"\\n\"))\n\n Right (Assign assignment) -> do\n assignments <- State.get\n\n State.put (first locate assignment : assignments)\n\n result <- interpret Syntax.Record{ location = 0, fieldValues = [] }\n\n case result of\n Left e -> do\n State.put assignments\n\n err e\n\n Right _ -> do\n return ()\n\n let help _string = do\n liftIO (putStrLn\n \"Type any expression to normalize it or use one of the following commands:\\n\\\n \\:help\\n\\\n \\ Print help text and describe options\\n\\\n \\:paste\\n\\\n \\ Start a multi-line input. Submit with \\n\\\n \\let IDENTIFIER = EXPRESSION\\n\\\n \\ Assign an expression to a variable\\n\\\n \\:quit\\n\\\n \\ Exit the REPL\")\n\n let quit _ =\n liftIO (throwIO Interrupt)\n\n let options =\n [ (\"help\", Repline.dontCrash . help)\n -- `paste` is included here for auto-completion purposes only.\n -- `repline`'s `multilineCommand` logic overrides this no-op.\n , (\"paste\", Repline.dontCrash . \\_ -> return ())\n , (\"quit\", quit)\n , (\"type\", Repline.dontCrash . command True)\n ]\n\n let tabComplete = Prefix complete [ (\":\", completeCommands) ]\n where\n completeCommands =\n Repline.listCompleter (fmap adapt options)\n where\n adapt (c, _) = \":\" <> c\n\n complete =\n foldr Repline.fallbackCompletion Completion.noCompletion\n [ completeReserved\n , completeIdentifiers\n , completeFields\n , completeFile\n ]\n\n completeFile =\n Repline.runMatcher\n [ (\"/\" , Repline.fileCompleter)\n , (\"./\" , Repline.fileCompleter)\n , (\"../\", Repline.fileCompleter)\n , (\"~/\" , Repline.fileCompleter)\n ]\n Completion.noCompletion\n\n completeReserved =\n Repline.listCompleter (fmap Text.unpack (toList Label.reservedLabels))\n\n completeIdentifiers args = do\n assignments <- get\n\n let completions = do\n Syntax.Define{ definition = Syntax.Definition{ name } } <- assignments\n\n return name\n\n Repline.listCompleter (fmap Text.unpack completions) args\n\n completeFields =\n Repline.wordCompleter \\prefix -> do\n let toNonEmpty (x : xs) = x :| xs\n toNonEmpty [] = \"\" :| []\n\n let loop (c0 :| c1 : cs) context = do\n let newContext = do\n (name, annotation) <- context\n\n Monad.guard (c0 == name)\n\n case annotation of\n Just Type.Record{ fields = Type.Fields keyTypes _ } -> do\n (key, type_) <- keyTypes\n\n return (key, Just type_)\n _ -> do\n empty\n\n results <- loop (c1 :| cs) newContext\n\n let prepend result = c0 <> \".\" <> result\n\n return (fmap prepend results)\n\n loop (c0 :| []) context = return do\n (name, _) <- context\n\n Monad.guard (Text.isPrefixOf c0 name)\n\n return name\n\n let startingComponents =\n toNonEmpty (Text.splitOn \".\" (Text.pack prefix))\n\n assignments <- get\n\n let startingContext = do\n Syntax.Define{ definition = Syntax.Definition{ name, annotation } } <- assignments\n\n return (name, annotation)\n\n results <- loop startingComponents startingContext\n\n return (fmap Text.unpack results)\n\n let banner MultiLine = return \"... \"\n banner SingleLine = return \">>> \"\n\n let initialiser = liftIO (putStrLn \"Type :help for more information.\")\n\n let action = Repline.evalReplOpts ReplOpts\n { banner\n , command = command False\n , options\n , prefix = Just ':'\n , multilineCommand = Just \"paste\"\n , tabComplete\n , initialiser\n , finaliser = return Repline.Exit\n }\n\n State.evalStateT action []\n" }, { "path": "src/Grace/Syntax.hs", "content": "{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE OverloadedLists #-}\n\n{-| This module contains the syntax tree used for the surface syntax (i.e. the\n result of parsing), representing the code as the user wrote it.\n-}\n\nmodule Grace.Syntax\n ( -- * Syntax\n Syntax(..)\n , usedIn\n , freeVariables\n , effects\n , types\n , complete\n , Chunks(..)\n , Field(..)\n , Smaller(..)\n , Scalar(..)\n , Operator(..)\n , Builtin(..)\n , NameBinding(..)\n , Binding(..)\n , Definition(..)\n , BindMonad(..)\n , Assignment(..)\n ) where\n\nimport Control.Lens (Getting, Plated(..), Traversal')\nimport Data.Aeson (ToJSON(..))\nimport Data.Bifunctor (Bifunctor(..))\nimport Data.Generics.Sum (_As)\nimport Data.List.NonEmpty (NonEmpty(..))\nimport Data.Monoid (Any)\nimport Data.Scientific (Scientific)\nimport Data.Sequence (Seq((:<|)))\nimport Data.Set (Set)\nimport Data.String (IsString(..))\nimport Data.Text (Text)\nimport GHC.Generics (Generic)\nimport Grace.Compat () -- For an orphan instance for Lift (Seq a)\nimport Grace.Context (Context)\nimport Grace.Pretty (Pretty(..), keyword, punctuation)\nimport Grace.Type (Type)\nimport Language.Haskell.TH.Syntax (Lift)\nimport Numeric.Natural (Natural)\nimport Prettyprinter.Render.Terminal (AnsiStyle)\n\nimport Prettyprinter.Internal\n ( Doc\n ( Annotated\n , Cat\n , Column\n , Fail\n , FlatAlt\n , Line\n , Nest\n , Nesting\n , Union\n , WithPageWidth\n )\n )\n\nimport qualified Control.Lens as Lens\nimport qualified Control.Monad as Monad\nimport qualified Data.Aeson as Aeson\nimport qualified Data.Set as Set\nimport qualified Data.Text as Text\nimport qualified Grace.Context as Context\nimport qualified Grace.Pretty as Pretty\nimport qualified Grace.Type as Type\nimport qualified Prettyprinter as Pretty\n\n{- $setup\n\n >>> :set -XOverloadedStrings\n >>> :set -XOverloadedLists\n >>> :set -XTypeApplications\n >>> import Data.Void (Void)\n-}\n\n-- | The surface syntax for the language\ndata Syntax s a\n = Variable { location :: s, name :: Text }\n -- ^\n -- >>> pretty @(Syntax () Void) (Variable () \"x\")\n -- x\n | Lambda { location :: s, binding :: Binding s a, body :: Syntax s a }\n -- ^\n -- >>> pretty @(Syntax () Void) (Lambda () \"x\" \"x\")\n -- \\x -> x\n -- >>> pretty @(Syntax () Void) (Lambda () (PlainBinding (NameBinding () \"x\" (Just \"A\") Nothing)) \"x\")\n -- \\(x : A) -> x\n -- >>> pretty @(Syntax () Void) (Lambda () (PlainBinding (NameBinding () \"x\" Nothing (Just \"a\"))) \"x\")\n -- \\(x = a) -> x\n -- >>> pretty @(Syntax () Void) (Lambda () (PlainBinding (NameBinding () \"x\" (Just \"A\") (Just \"a\"))) \"x\")\n -- \\(x : A = a) -> x\n | Application { location :: s, function :: Syntax s a, argument :: Syntax s a }\n -- ^\n -- >>> pretty @(Syntax () Void) (Application () \"f\" \"x\")\n -- f x\n | Annotation { location :: s, annotated :: Syntax s a, annotation :: Type s }\n -- ^\n -- >>> pretty @(Syntax () Void) (Annotation () \"x\" \"A\")\n -- x : A\n | Let { location :: s, assignments :: NonEmpty (Assignment s a), body :: Syntax s a }\n -- ^\n -- >>> pretty @(Syntax () Void) (Let () (Define () (Definition () \"x\" [] Nothing \"y\") :| []) \"z\")\n -- let x = y in z\n -- >>> pretty @(Syntax () Void) (Let () (Define () (Definition () \"x\" [PlainBinding (NameBinding () \"a\" (Just \"A\") Nothing), PlainBinding (NameBinding () \"b\" Nothing (Just \"e\"))] (Just \"X\") \"y\") :| []) \"z\")\n -- let x (a : A) (b = e) : X = y in z\n -- >>> pretty @(Syntax () Void) (Let () (Define () (Definition () \"a\" [] Nothing \"b\") :| [ Define () (Definition () \"c\" [] Nothing \"d\") ]) \"e\")\n -- let a = b let c = d in e\n | List { location :: s, elements :: Seq (Syntax s a) }\n -- ^\n -- >>> pretty @(Syntax () Void) (List () [ \"x\", \"y\", \"z\" ])\n -- [ x, y, z ]\n | Record { location :: s, fieldValues :: [Definition s a] }\n -- ^\n -- >>> pretty @(Syntax () Void) (Record () [ Definition () \"x\" [] Nothing \"a\", Definition () \"y\" [] Nothing \"b\" ])\n -- { \"x\": a, \"y\": b }\n | Project { location :: s, larger :: Syntax s a, smaller :: Smaller s }\n -- ^\n -- >>> pretty @(Syntax () Void) (Project () \"x\" \"a\")\n -- x.a\n | Alternative { location :: s, name :: Text, argument :: Syntax s a }\n -- ^\n -- >>> pretty @(Syntax () Void) (Alternative () \"Foo\" \"a\")\n -- Foo a\n | Fold { location :: s, handlers :: Syntax s a }\n -- ^\n -- >>> pretty @(Syntax () Void) (Fold () \"x\")\n -- fold x\n | If { location :: s, predicate :: Syntax s a, ifTrue :: Syntax s a, ifFalse :: Syntax s a }\n -- ^\n -- >>> pretty @(Syntax () Void) (If () \"x\" \"y\" \"z\")\n -- if x then y else z\n | Text { location :: s, chunks :: Chunks s a }\n -- ^\n -- >>> pretty @(Syntax () Void) (Text () \"a\")\n -- \"a\"\n -- >>> pretty @(Syntax () Void) (Text () (Chunks \"a\" [(\"x\", \"b\")]))\n -- \"a${x}b\"\n | Prompt{ location :: s, import_ :: Bool, arguments :: Syntax s a, schema :: Maybe (Type s) }\n | HTTP{ location :: s, import_ :: Bool, arguments :: Syntax s a, schema :: Maybe (Type s) }\n | Read{ location :: s, import_ :: Bool, arguments :: Syntax s a, schema :: Maybe (Type s) }\n | GitHub{ location :: s, import_ :: Bool, arguments :: Syntax s a, schema :: Maybe (Type s) }\n | Show{ location :: s, export :: Bool, arguments :: Syntax s a, schema :: Maybe (Type s) }\n | Scalar { location :: s, scalar :: Scalar }\n | Operator { location :: s, left :: Syntax s a, operatorLocation :: s, operator :: Operator, right :: Syntax s a }\n -- ^\n -- >>> pretty @(Syntax () Void) (Operator () \"x\" () And \"y\")\n -- x && y\n -- >>> pretty @(Syntax () Void) (Operator () \"x\" () Plus \"y\")\n -- x + y\n | Builtin { location :: s, builtin :: Builtin }\n | Embed { location :: s, embedded :: a }\n deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable)\n\ninstance Applicative (Syntax ()) where\n pure embedded = Embed{ location = (), embedded }\n\n (<*>) = Monad.ap\n\ninstance Monad (Syntax ()) where\n Variable{ location, name } >>= _ =\n Variable{ location, name }\n\n Lambda{ location, binding, body } >>= f = Lambda\n { location\n , binding = onBinding binding\n , body = body >>= f\n }\n where\n onBinding PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment} } =\n PlainBinding\n { plain = NameBinding\n { nameLocation\n , name\n , annotation\n , assignment = fmap (>>= f) assignment\n }\n }\n onBinding RecordBinding{ fieldNamesLocation, fieldNames } =\n RecordBinding\n { fieldNamesLocation\n , fieldNames = fmap onFieldName fieldNames\n }\n\n onFieldName\n NameBinding{ nameLocation, name, annotation, assignment } =\n NameBinding\n { nameLocation\n , name\n , annotation\n , assignment = fmap (>>= f) assignment\n }\n Application{ location, function, argument } >>= f = Application\n { location\n , function = function >>= f\n , argument = argument >>= f\n }\n\n Annotation{ location, annotated, annotation } >>= f =\n Annotation{ location, annotated = annotated >>= f, annotation }\n\n Let{ location, assignments, body } >>= f = Let\n { location\n , assignments = fmap onAssignment assignments\n , body = body >>= f\n }\n where\n onAssignment\n Define{ assignmentLocation, definition = Definition{ nameLocation, name, bindings, annotation, assignment } } = Define\n { assignmentLocation\n , definition = Definition\n { name\n , nameLocation\n , bindings = fmap onBinding bindings\n , annotation\n , assignment = assignment >>= f\n }\n }\n onAssignment\n Bind{ assignmentLocation, monad, binding, assignment } = Bind\n { assignmentLocation\n , monad\n , binding = onBinding binding\n , assignment = assignment >>= f\n }\n\n onBinding\n PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } } =\n PlainBinding\n { plain = NameBinding\n { nameLocation\n , name\n , annotation\n , assignment = fmap (>>= f) assignment\n }\n }\n onBinding RecordBinding{ fieldNamesLocation, fieldNames } =\n RecordBinding\n { fieldNamesLocation\n , fieldNames = fmap onFieldName fieldNames\n }\n\n onFieldName\n NameBinding{ nameLocation, name, annotation, assignment } =\n NameBinding\n { nameLocation\n , name\n , annotation\n , assignment = fmap (>>= f) assignment\n }\n\n List{ location, elements } >>= f =\n List{ location, elements = fmap (>>= f) elements }\n\n Record{ location, fieldValues } >>= f =\n Record{ location, fieldValues = fmap onDefinition fieldValues }\n where\n onDefinition Definition{ nameLocation, name, bindings, annotation, assignment } =\n Definition\n { nameLocation\n , name\n , bindings = fmap onBinding bindings\n , annotation\n , assignment = assignment >>= f\n }\n\n onBinding\n PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } } =\n PlainBinding\n { plain = NameBinding\n { nameLocation\n , name\n , annotation\n , assignment = fmap (>>= f) assignment\n }\n }\n onBinding RecordBinding{ fieldNamesLocation, fieldNames } =\n RecordBinding\n { fieldNamesLocation\n , fieldNames = fmap onFieldName fieldNames\n }\n\n onFieldName\n NameBinding{ nameLocation, name, annotation, assignment } =\n NameBinding\n { nameLocation\n , name\n , annotation\n , assignment = fmap (>>= f) assignment\n }\n\n Project{ location, larger, smaller } >>= f =\n Project{ location, larger = larger >>= f, smaller }\n\n Alternative{ location, name, argument } >>= f =\n Alternative{ location, name, argument = argument >>= f }\n\n Fold{ location, handlers } >>= f =\n Fold{ location, handlers = handlers >>= f }\n\n If{ location, predicate, ifTrue, ifFalse } >>= f = If\n { location\n , predicate = predicate >>= f\n , ifTrue = ifTrue >>= f\n , ifFalse = ifFalse >>= f\n }\n\n Text{ location, chunks = Chunks text₀ rest } >>= f =\n Text{ location, chunks = Chunks text₀ (fmap onChunk rest) }\n where\n onChunk (interpolation, text) = (interpolation >>= f, text)\n\n Prompt{ location, import_, arguments, schema } >>= f =\n Prompt{ location, import_, arguments = arguments >>= f, schema }\n\n HTTP{ location, import_, arguments, schema } >>= f =\n HTTP{ location, import_, arguments = arguments >>= f, schema }\n\n Read{ location, import_, arguments, schema } >>= f =\n Read{ location, import_, arguments = arguments >>= f, schema }\n\n GitHub{ location, import_, arguments, schema } >>= f =\n GitHub{ location, import_, arguments = arguments >>= f, schema }\n\n Show{ location, export, arguments, schema } >>= f =\n Show{ location, export, arguments = arguments >>= f, schema }\n\n Scalar{ location, scalar } >>= _ =\n Scalar{ location, scalar }\n\n Operator{ location, left, operatorLocation, operator, right } >>= f =\n Operator\n { location\n , left = left >>= f\n , operatorLocation\n , operator\n , right = right >>= f\n }\n\n Builtin{ location, builtin } >>= _ =\n Builtin{ location, builtin }\n\n Embed{ embedded } >>= f =\n f embedded\n\ninstance Plated (Syntax s a) where\n plate onSyntax syntax =\n case syntax of\n Variable{ location, name } -> do\n pure Variable{ location, name }\n\n Lambda{ location, binding, body } -> do\n newBody <- onSyntax body\n\n return Lambda{ location, binding, body = newBody }\n\n Application{ location, function, argument } -> do\n newFunction <- onSyntax function\n newArgument <- onSyntax argument\n\n return Application\n { location\n , function = newFunction\n , argument = newArgument\n }\n\n Annotation{ location, annotated, annotation } -> do\n newAnnotated <- onSyntax annotated\n\n return Annotation\n { location\n , annotated = newAnnotated\n , annotation\n }\n\n Let{ location, assignments, body } -> do\n let onFieldName\n NameBinding{ nameLocation, name, annotation, assignment } = do\n newAssignment <- traverse onSyntax assignment\n\n return NameBinding\n { nameLocation\n , name\n , annotation\n , assignment = newAssignment\n }\n\n let onBinding\n PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } } = do\n newAssignment <- traverse onSyntax assignment\n\n return PlainBinding\n { plain = NameBinding\n { nameLocation\n , name\n , annotation\n , assignment = newAssignment\n }\n }\n\n onBinding\n RecordBinding{ fieldNamesLocation, fieldNames } = do\n newFieldNames <- traverse onFieldName fieldNames\n\n return RecordBinding\n { fieldNamesLocation\n , fieldNames = newFieldNames\n }\n\n let onAssignment\n Define{ assignmentLocation, definition = Definition{ nameLocation, name, bindings, annotation, assignment } } = do\n newAssignment <- onSyntax assignment\n\n newBindings <- traverse onBinding bindings\n\n return Define\n { assignmentLocation\n , definition = Definition\n { nameLocation\n , name\n , bindings = newBindings\n , annotation\n , assignment = newAssignment\n }\n }\n onAssignment\n Bind{ assignmentLocation, monad, binding, assignment } = do\n newBinding <- onBinding binding\n\n newAssignment <- onSyntax assignment\n\n return Bind\n { assignmentLocation\n , monad\n , binding = newBinding\n , assignment = newAssignment\n }\n\n newAssignments <- traverse onAssignment assignments\n\n newBody <- onSyntax body\n\n return Let\n { location\n , assignments = newAssignments\n , body = newBody\n }\n\n List{ location, elements } -> do\n newElements <- traverse onSyntax elements\n\n return List{ location, elements = newElements }\n\n Record{ location, fieldValues } -> do\n let onNameBinding\n NameBinding{ nameLocation, name, annotation, assignment } = do\n newAssignment <- traverse onSyntax assignment\n\n return NameBinding\n { nameLocation\n , name\n , annotation\n , assignment = newAssignment\n }\n\n let onBinding\n PlainBinding{ plain } = do\n newPlain <- onNameBinding plain\n\n return PlainBinding{ plain = newPlain }\n onBinding\n RecordBinding{ fieldNamesLocation, fieldNames } = do\n newFieldNames <- traverse onNameBinding fieldNames\n\n return RecordBinding\n { fieldNamesLocation\n , fieldNames = newFieldNames\n }\n\n let onDefinition Definition{ name, nameLocation, bindings, annotation, assignment } = do\n newBindings <- traverse onBinding bindings\n\n newAssignment <- onSyntax assignment\n\n return Definition\n { name\n , nameLocation\n , bindings = newBindings\n , annotation\n , assignment = newAssignment\n }\n\n newFieldValues <- traverse onDefinition fieldValues\n\n return Record{ location, fieldValues = newFieldValues }\n\n Project{ location, larger, smaller } -> do\n newLarger <- onSyntax larger\n\n return Project{ location, larger = newLarger, smaller }\n\n Alternative{ location, name, argument } -> do\n newArgument <- onSyntax argument\n\n pure Alternative{ name, location, argument = newArgument }\n\n Fold{ location, handlers } -> do\n newHandlers <- onSyntax handlers\n\n return Fold{ location, handlers = newHandlers }\n\n If{ location, predicate, ifTrue, ifFalse } -> do\n newPredicate <- onSyntax predicate\n newIfTrue <- onSyntax ifTrue\n newIfFalse <- onSyntax ifFalse\n\n return If\n { location\n , predicate = newPredicate\n , ifTrue = newIfTrue\n , ifFalse = newIfFalse\n }\n\n Text{ location, chunks = Chunks text₀ rest } -> do\n let onChunk (interpolation, text) = do\n newInterpolation <- onSyntax interpolation\n\n return (newInterpolation, text)\n\n newRest <- traverse onChunk rest\n\n return Text{ location, chunks = Chunks text₀ newRest }\n\n Prompt{ location, import_, arguments, schema } -> do\n newArguments <- onSyntax arguments\n\n return Prompt{ location, import_, arguments = newArguments, schema }\n\n HTTP{ location, import_, arguments, schema } -> do\n newArguments <- onSyntax arguments\n\n return HTTP{ location, import_, arguments = newArguments, schema }\n\n Read{ location, import_, arguments, schema } -> do\n newArguments <- onSyntax arguments\n\n return Read{ location, import_, arguments = newArguments, schema }\n\n GitHub{ location, import_, arguments, schema } -> do\n newArguments <- onSyntax arguments\n\n return GitHub{ location, import_, arguments = newArguments, schema }\n\n Show{ location, export, arguments, schema } -> do\n newArguments <- onSyntax arguments\n\n return Show{ location, export, arguments = newArguments, schema }\n\n Scalar{ location, scalar } -> do\n pure Scalar{ location, scalar }\n\n Operator{ location, left, operatorLocation, operator, right } -> do\n newLeft <- onSyntax left\n newRight <- onSyntax right\n\n return Operator\n { location\n , left = newLeft\n , operatorLocation\n , operator\n , right = newRight\n }\n\n Builtin{ location, builtin } -> do\n pure Builtin{ location, builtin }\n\n Embed{ location, embedded } -> do\n pure Embed{ location, embedded }\n\ninstance Bifunctor Syntax where\n first f Variable{ location, name } =\n Variable{ name, location = f location }\n\n first f Lambda{ location, binding, body } = Lambda\n { location = f location\n , binding = first f binding\n , body = first f body\n }\n\n first f Application{ location, function, argument } = Application\n { location = f location\n , function = first f function\n , argument = first f argument\n }\n\n first f Annotation{ location, annotated, annotation } = Annotation\n { location = f location\n , annotated = first f annotated\n , annotation = fmap f annotation\n }\n\n first f Let{ location, assignments, body } = Let\n { location = f location\n , assignments = fmap (first f) assignments\n , body = first f body\n }\n\n first f List{ location, elements } =\n List{ location = f location, elements = fmap (first f) elements }\n\n first f Record{ location, fieldValues } =\n Record{ location = f location, fieldValues = fmap (first f) fieldValues }\n\n first f Project{ location, larger, smaller } = Project\n { location = f location\n , larger = first f larger\n , smaller = fmap f smaller\n }\n\n first f Alternative{ location, name, argument } =\n Alternative{ location = f location, name, argument = first f argument }\n\n first f Fold{ location, handlers } =\n Fold{ location = f location, handlers = first f handlers }\n\n first f If{ location, predicate, ifTrue, ifFalse } = If\n { location = f location\n , predicate = first f predicate\n , ifTrue = first f ifTrue\n , ifFalse = first f ifFalse\n }\n\n first f Text{ location, chunks } =\n Text{ location = f location, chunks = first f chunks }\n\n first f Prompt{ location, import_, arguments, schema } = Prompt\n { location = f location\n , import_\n , arguments = first f arguments\n , schema = fmap (fmap f) schema\n }\n\n first f HTTP{ location, import_, arguments, schema } = HTTP\n { location = f location\n , import_\n , arguments = first f arguments\n , schema = fmap (fmap f) schema\n }\n\n first f Read{ location, import_, arguments, schema } = Read\n { location = f location\n , import_\n , arguments = first f arguments\n , schema = fmap (fmap f) schema\n }\n\n first f GitHub{ location, import_, arguments, schema } = GitHub\n { location = f location\n , import_\n , arguments = first f arguments\n , schema = fmap (fmap f) schema\n }\n\n first f Show{ location, export, arguments, schema } = Show\n { location = f location\n , export\n , arguments = first f arguments\n , schema = fmap (fmap f) schema\n }\n\n first f Scalar{ location, scalar } =\n Scalar{ location = f location, scalar }\n\n first f Operator{ location, left, operatorLocation, operator, right } =\n Operator\n { location = f location\n , left = first f left\n , operatorLocation = f operatorLocation\n , operator\n , right = first f right\n }\n\n first f Builtin{ location, builtin } =\n Builtin{ location = f location, builtin }\n\n first f Embed{ location, embedded } =\n Embed{ location = f location, embedded }\n\n second = fmap\n\ninstance IsString (Syntax () a) where\n fromString string =\n Variable{ location = (), name = fromString string }\n\ninstance Pretty a => Pretty (Syntax s a) where\n pretty = prettyExpression\n\n-- | Returns whether the given variable is used within the expression\nusedIn :: Text -> Syntax s a -> Bool\nusedIn name₀ Variable{ name = name₁ } =\n name₀ == name₁\nusedIn name₀ Lambda{ binding = PlainBinding{ plain = NameBinding{ name = name₁ } }, body } =\n (name₀ /= name₁) && usedIn name₀ body\nusedIn name₀ Lambda{ binding = RecordBinding{ fieldNames }, body } =\n (name₀ `notElem` fmap toName fieldNames) && usedIn name₀ body\n where\n toName NameBinding{ name = name₁ } = name₁\nusedIn name₀ Application{ function, argument } =\n usedIn name₀ function || usedIn name₀ argument\nusedIn name₀ Annotation{ annotated } =\n usedIn name₀ annotated\nusedIn name₀ Let{ assignments = Define{ definition = Definition{ name = name₁, assignment } } :| [], body } =\n usedIn name₀ assignment || (name₀ /= name₁ && usedIn name₀ body)\nusedIn name₀ Let{ assignments = Bind{ binding, assignment } :| [], body } =\n usedIn name₀ assignment || (name₀ `notElem` toNames binding && usedIn name₀ body)\n where\n toName NameBinding{ name = name₁ } = name₁\n\n toNames PlainBinding{ plain } = [ toName plain ]\n toNames RecordBinding{ fieldNames } = map toName fieldNames\nusedIn name₀ Let{ location, assignments = Define{ definition = Definition{ name = name₁, assignment } } :| (a : as), body } =\n usedIn name₀ assignment || (name₀ /= name₁ && usedIn name₀ Let{ location, assignments = a :| as, body })\nusedIn name₀ Let{ location, assignments = Bind{ binding, assignment } :| (a : as), body } =\n usedIn name₀ assignment || (name₀ `notElem` toNames binding && usedIn name₀ Let{ location, assignments = a :| as, body })\n where\n toName NameBinding{ name = name₁ } = name₁\n\n toNames PlainBinding{ plain } = [ toName plain ]\n toNames RecordBinding{ fieldNames } = map toName fieldNames\nusedIn name₀ List{ elements } =\n any (usedIn name₀) elements\nusedIn name₀ Record{ fieldValues } = any onDefinition fieldValues\n where\n onDefinition Definition{ bindings, assignment } =\n name₀ `notElem` concatMap toNames bindings && usedIn name₀ assignment\n\n toName NameBinding{ name = name₁ } = name₁\n\n toNames PlainBinding{ plain } = [ toName plain ]\n toNames RecordBinding{ fieldNames } = map toName fieldNames\nusedIn name₀ Project{ larger } =\n usedIn name₀ larger\nusedIn name₀ Alternative{ argument } =\n usedIn name₀ argument\nusedIn name₀ Fold{ handlers } =\n usedIn name₀ handlers\nusedIn name₀ If{ predicate, ifTrue, ifFalse } =\n usedIn name₀ predicate || usedIn name₀ ifTrue || usedIn name₀ ifFalse\nusedIn name₀ Text{ chunks = Chunks _ pairs } =\n any (usedIn name₀ . fst) pairs\nusedIn _ Scalar{ } =\n False\nusedIn name₀ Prompt{ arguments } =\n usedIn name₀ arguments\nusedIn name₀ HTTP{ arguments } =\n usedIn name₀ arguments\nusedIn name₀ Read{ arguments } =\n usedIn name₀ arguments\nusedIn name₀ GitHub{ arguments } =\n usedIn name₀ arguments\nusedIn name₀ Show{ arguments } =\n usedIn name₀ arguments\nusedIn name₀ Operator{ left, right } =\n usedIn name₀ left || usedIn name₀ right\nusedIn _ Builtin{ } =\n False\nusedIn _ Embed{ } =\n False\n\n-- | Returns all free variables within an expression\nfreeVariables :: Syntax s a -> Set Text\nfreeVariables Variable{ name } = Set.singleton name\nfreeVariables Lambda{ binding = PlainBinding{ plain = NameBinding{ name } }, body } =\n Set.delete name (freeVariables body)\nfreeVariables Lambda{ binding = RecordBinding{ fieldNames }, body } =\n Set.difference (freeVariables body) (Set.fromList (map toName fieldNames))\n where\n toName NameBinding{ name = name₁ } = name₁\nfreeVariables Application{ function, argument } =\n Set.union (freeVariables function) (freeVariables argument)\nfreeVariables Annotation{ annotated } =\n freeVariables annotated\nfreeVariables Let{ assignments = Define{ definition = Definition{ name, assignment } } :| [], body } =\n Set.union (freeVariables assignment) (Set.delete name (freeVariables body))\nfreeVariables Let{ assignments = Bind{ binding, assignment } :| [], body } =\n Set.union (freeVariables assignment) (Set.difference (freeVariables body) (Set.fromList (toNames binding)))\n where\n toName NameBinding{ name = name₁ } = name₁\n\n toNames PlainBinding{ plain } = [ toName plain ]\n toNames RecordBinding{ fieldNames } = map toName fieldNames\nfreeVariables Let{ location, assignments = Define{ definition = Definition{ name, assignment } } :| (a : as), body } =\n Set.union (freeVariables assignment) (Set.delete name (freeVariables Let{ location, assignments = a :| as, body }))\nfreeVariables Let{ location, assignments = Bind{ binding, assignment } :| (a : as), body } =\n Set.union (freeVariables assignment) (Set.difference (freeVariables Let{ location, assignments = a :| as, body }) (Set.fromList (toNames binding)))\n where\n toName NameBinding{ name = name₁ } = name₁\n\n toNames PlainBinding{ plain } = [ toName plain ]\n toNames RecordBinding{ fieldNames } = map toName fieldNames\nfreeVariables List{ elements } =\n Set.unions (fmap freeVariables elements)\nfreeVariables Record{ fieldValues } = Set.unions (fmap onDefinition fieldValues)\n where\n onDefinition Definition{ bindings, assignment } =\n Set.difference (freeVariables assignment) (Set.fromList (concatMap toNames bindings))\n\n toName NameBinding{ name = name₁ } = name₁\n\n toNames PlainBinding{ plain } = [ toName plain ]\n toNames RecordBinding{ fieldNames } = map toName fieldNames\nfreeVariables Project{ larger } =\n freeVariables larger\nfreeVariables Alternative{ argument } =\n freeVariables argument\nfreeVariables Fold{ handlers } =\n freeVariables handlers\nfreeVariables If{ predicate, ifTrue, ifFalse } =\n Set.unions\n ( [freeVariables predicate, freeVariables ifTrue, freeVariables ifFalse]\n :: [Set Text]\n )\nfreeVariables Text{ chunks = Chunks _ pairs } =\n Set.unions (fmap (freeVariables . fst) pairs)\nfreeVariables Scalar{ } =\n Set.empty\nfreeVariables Prompt{ arguments } =\n freeVariables arguments\nfreeVariables HTTP{ arguments } =\n freeVariables arguments\nfreeVariables Read{ arguments } =\n freeVariables arguments\nfreeVariables GitHub{ arguments } =\n freeVariables arguments\nfreeVariables Show{ arguments } =\n freeVariables arguments\nfreeVariables Operator{ left, right } =\n Set.union (freeVariables left) (freeVariables right)\nfreeVariables Builtin{ } =\n Set.empty\nfreeVariables Embed{ } =\n Set.empty\n\n-- | `Getting` that matches all effects within a `Syntax` tree\neffects :: Getting Any (Syntax s a) ()\neffects = Lens.cosmos . effect\n where\n effect =\n (_As @\"Prompt\" . Lens.to (\\_ -> ()))\n <> (_As @\"HTTP\" . Lens.to (\\_ -> ()))\n <> (_As @\"GitHub\" . Lens.to (\\_ -> ()))\n\n-- | A text literal with interpolated expressions\ndata Chunks s a = Chunks Text [(Syntax s a, Text)]\n deriving stock (Eq, Foldable, Functor, Lift, Show, Traversable)\n\ninstance Monoid (Chunks s a) where\n mempty = Chunks mempty mempty\n\ninstance Semigroup (Chunks s a) where\n Chunks text₀ rest₀ <> Chunks text₂ rest₂ = case unsnoc rest₀ of\n Nothing -> Chunks (text₀ <> text₂) rest₂\n Just (rest₁, (syntax, text₁)) ->\n Chunks text₀ (rest₁ <> ((syntax, text₁ <> text₂) : rest₂))\n where\n unsnoc [ ] = Nothing\n unsnoc [x] = Just ([], x)\n unsnoc (x : xs) = do\n (i, l) <- unsnoc xs\n return (x : i, l)\n\ninstance Bifunctor Chunks where\n first f (Chunks text₀ rest) = Chunks text₀ (fmap (first (first f)) rest)\n\n second = fmap\n\ninstance IsString (Chunks s a) where\n fromString string = Chunks (fromString string) []\n\ninstance Pretty a => Pretty (Chunks s a) where\n pretty (Chunks text₀ rest) = Pretty.flatAlt long short\n where\n short =\n ( Pretty.punctuation \"\\\"\"\n <> Pretty.scalar (Type.prettyTextBody False text₀)\n <> foldMap (prettyInterpolation False) rest\n <> Pretty.punctuation \"\\\"\"\n )\n\n long =\n (if multiline then Pretty.align else id)\n ( Pretty.punctuation prefix\n <> Pretty.scalar (Type.prettyTextBody multiline text₀)\n <> foldMap (prettyInterpolation multiline) rest\n <> Pretty.punctuation \"\\\"\"\n )\n\n prefix\n | multiline = \"\\\"\\n\"\n | otherwise = \"\\\"\"\n\n multiline =\n Text.any (== '\\n') text₀ || any (Text.any (== '\\n') . snd) rest\n\n prettyInterpolation m (syntax, text) =\n Pretty.punctuation \"${\"\n <> flatten (pretty syntax)\n <> Pretty.punctuation \"}\"\n <> Pretty.scalar (Type.prettyTextBody m text)\n\n-- | A field of a record\ndata Field s = Field{ fieldLocation :: s, field :: Text }\n deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable)\n\ninstance IsString (Field ()) where\n fromString string = Field{ fieldLocation = (), field = fromString string }\n\n-- | A projection of one or more fields\ndata Smaller s\n = Single{ single :: Field s }\n | Multiple{ multipleLocation :: s, multiple :: [Field s] }\n | Index{ index :: Integer }\n | Slice{ begin :: Maybe Integer, end :: Maybe Integer }\n deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable)\n\ninstance IsString (Smaller ()) where\n fromString string = Single{ single = fromString string }\n\n-- | @Traversal'@ from a `Syntax` to its immediate `Type`\ntypes :: Traversal' (Syntax s a) (Type s)\ntypes onType\n Lambda{ location, binding = PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } }, body } = do\n newAnnotation <- traverse onType annotation\n\n return Lambda\n { location\n , binding = PlainBinding\n { plain = NameBinding\n { nameLocation\n , name\n , annotation = newAnnotation\n , assignment\n }\n }\n , body\n }\ntypes onType Annotation{ location, annotated, annotation } = do\n newAnnotation <- onType annotation\n\n return Annotation{ location, annotated, annotation = newAnnotation }\ntypes onType Prompt{ location, import_, arguments, schema } = do\n newSchema <- traverse onType schema\n\n return Prompt{ location, import_, arguments, schema = newSchema }\ntypes onType HTTP{ location, import_, arguments, schema } = do\n newSchema <- traverse onType schema\n\n return HTTP{ location, import_, arguments, schema = newSchema }\ntypes onType Read{ location, import_, arguments, schema } = do\n newSchema <- traverse onType schema\n\n return Read{ location, import_, arguments, schema = newSchema }\ntypes onType GitHub{ location, import_, arguments, schema } = do\n newSchema <- traverse onType schema\n\n return GitHub{ location, import_, arguments, schema = newSchema }\ntypes onType Show{ location, export, arguments, schema } = do\n newSchema <- traverse onType schema\n\n return Show{ location, export, arguments, schema = newSchema }\ntypes onType Let{ location, assignments, body } = do\n newAssignments <- traverse onAssignment assignments\n\n return Let{ location, assignments = newAssignments, body }\n where\n onAssignment\n Define{ assignmentLocation, definition = Definition{ nameLocation, name, bindings, annotation, assignment } } = do\n newBindings <- traverse onBinding bindings\n\n newAnnotation <- traverse onType annotation\n\n return Define\n { assignmentLocation\n , definition = Definition\n { nameLocation\n , name\n , bindings = newBindings\n , annotation = newAnnotation\n , assignment\n }\n }\n onAssignment\n Bind{ assignmentLocation, monad, binding, assignment } = do\n newBinding <- onBinding binding\n\n return Bind\n { assignmentLocation\n , monad\n , binding = newBinding\n , assignment\n }\n\n onBinding PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } } = do\n newAnnotation <- traverse onType annotation\n\n return PlainBinding\n { plain = NameBinding\n { nameLocation\n , name\n , annotation = newAnnotation\n , assignment\n }\n }\n onBinding RecordBinding{ fieldNamesLocation, fieldNames } = do\n newFieldNames <- traverse onFieldName fieldNames\n\n return RecordBinding\n { fieldNamesLocation\n , fieldNames = newFieldNames\n }\n\n onFieldName\n NameBinding{ nameLocation, name, annotation, assignment } = do\n newAnnotation <- traverse onType annotation\n\n return NameBinding\n { nameLocation\n , name\n , annotation = newAnnotation\n , assignment\n }\ntypes _ e = pure e\n\n-- | Complete all `Type` annotations in a `Syntax` tree using the provided\n-- `Context`\ncomplete :: Context s -> Syntax s a -> Syntax s a\ncomplete context = Lens.transform (Lens.over types (Context.complete context))\n\n-- | A scalar value\ndata Scalar\n = Real Scientific\n -- ^\n -- >>> pretty (Real 1.0)\n -- 1.0\n | Integer Integer\n -- ^\n -- >>> pretty (Integer 1)\n -- 1\n | Natural Natural\n -- ^\n -- >>> pretty (Natural 1)\n -- 1\n | Bool Bool\n -- ^\n -- >>> pretty (Bool True)\n -- true\n -- >>> pretty (Bool False)\n -- false\n | Null\n -- ^\n -- >>> pretty Null\n -- null\n | Key Text\n -- ^\n -- >>> pretty (Key \"secret\")\n -- 🔒\n deriving stock (Eq, Generic, Lift, Show)\n\ninstance ToJSON Scalar where\n toJSON (Real n) = toJSON n\n toJSON (Integer n) = toJSON n\n toJSON (Natural n) = toJSON n\n toJSON (Bool b) = toJSON b\n toJSON Null = Aeson.Null\n toJSON (Key _) = Aeson.Null\n\ninstance Pretty Scalar where\n pretty (Bool True ) = Pretty.scalar \"true\"\n pretty (Bool False) = Pretty.scalar \"false\"\n pretty (Real number) = Pretty.scalar (pretty number)\n pretty (Integer number) = Pretty.scalar (pretty number)\n pretty (Natural number) = Pretty.scalar (pretty number)\n pretty Null = Pretty.scalar \"null\"\n pretty (Key _) = Pretty.scalar \"🔒\"\n\n-- | A binary infix operator\ndata Operator\n = Or\n -- ^\n -- >>> pretty Or\n -- ||\n | And\n -- ^\n -- >>> pretty And\n -- &&\n | Equal\n -- ^\n -- >>> pretty Equal\n -- ==\n | NotEqual\n -- ^\n -- >>> pretty NotEqual\n -- !=\n | LessThan\n -- ^\n -- >>> pretty LessThan\n -- <\n | LessThanOrEqual\n -- ^\n -- >>> pretty LessThanOrEqual\n -- <=\n | GreaterThan\n -- ^\n -- >>> pretty GreaterThan\n -- >\n | GreaterThanOrEqual\n -- ^\n -- >>> pretty GreaterThanOrEqual\n -- >=\n | Plus\n -- ^\n -- >>> pretty Plus\n -- +\n | Minus\n -- ^\n -- >>> pretty Minus\n -- -\n | Times\n -- ^\n -- >>> pretty Times\n -- *\n | Modulus\n -- ^\n -- >>> pretty Modulus\n -- %\n | Divide\n -- ^\n -- >>> pretty Divide\n -- /\n deriving stock (Eq, Generic, Lift, Show)\n\ninstance Pretty Operator where\n pretty And = Pretty.operator \"&&\"\n pretty Or = Pretty.operator \"||\"\n pretty Equal = Pretty.operator \"==\"\n pretty NotEqual = Pretty.operator \"!=\"\n pretty LessThan = Pretty.operator \"<\"\n pretty LessThanOrEqual = Pretty.operator \"<=\"\n pretty GreaterThan = Pretty.operator \">\"\n pretty GreaterThanOrEqual = Pretty.operator \">=\"\n pretty Plus = Pretty.operator \"+\"\n pretty Minus = Pretty.operator \"-\"\n pretty Times = Pretty.operator \"*\"\n pretty Modulus = Pretty.operator \"%\"\n pretty Divide = Pretty.operator \"/\"\n\n-- | A built-in function\ndata Builtin\n = Abs\n -- ^\n -- >>> pretty Abs\n -- abs\n | Indexed\n -- ^\n -- >>> pretty Indexed\n -- indexed\n | Length\n -- ^\n -- >>> pretty Length\n -- length\n | Map\n -- ^\n -- >>> pretty Map\n -- map\n | Reveal\n -- ^\n -- >>> pretty Reveal\n -- reveal\n | Some\n -- ^\n -- >>> pretty Some\n -- some\n | YAML\n -- ^\n -- >>> pretty YAML\n -- yaml\n deriving stock (Bounded, Enum, Eq, Generic, Lift, Show)\n\ninstance Pretty Builtin where\n pretty Abs = Pretty.builtin \"abs\"\n pretty Indexed = Pretty.builtin \"indexed\"\n pretty Length = Pretty.builtin \"length\"\n pretty Map = Pretty.builtin \"map\"\n pretty Reveal = Pretty.builtin \"reveal\"\n pretty Some = Pretty.builtin \"some\"\n pretty YAML = Pretty.builtin \"yaml\"\n\n-- | Pretty-print an expression\nprettyExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyExpression expression@Lambda{} =\n -- Anywhere you see `Pretty.group (Pretty.flatAlt long short)` that means\n -- that the pretty-printer will first attempt to display `short` if that\n -- fits on one line, otherwise it will fall back to displaying `long`\n -- (which is typically a multi-line result)\n Pretty.group (Pretty.flatAlt long short)\n where\n short = punctuation \"\\\\\" <> prettyShort expression\n\n long = prettyLong expression\n\n prettyShort Lambda{ binding, body } =\n pretty binding\n <> \" \"\n <> prettyShort body\n prettyShort body =\n punctuation \"->\"\n <> \" \"\n <> prettyExpression body\n\n prettyLong Lambda{ binding, body } =\n punctuation \"\\\\\"\n <> pretty binding\n <> \" \"\n <> punctuation \"->\"\n <> Pretty.hardline\n <> prettyLong body\n prettyLong body =\n \" \" <> Pretty.nest 2 (prettyExpression body)\n\nprettyExpression Let{ assignments, body }\n = Pretty.group (Pretty.flatAlt long short)\n where\n short = foldMap (\\assignment -> pretty assignment <> \" \") assignments\n <> keyword \"in\"\n <> \" \"\n <> prettyExpression body\n\n long = foldMap (\\assignment -> pretty assignment <> Pretty.hardline <> Pretty.hardline) assignments\n <> keyword \"in\"\n <> \" \"\n <> Pretty.nest 4 (prettyExpression body)\nprettyExpression If{ predicate, ifTrue, ifFalse } =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = keyword \"if\"\n <> \" \"\n <> prettyExpression predicate\n <> \" \"\n <> keyword \"then\"\n <> \" \"\n <> prettyExpression ifTrue\n <> \" \"\n <> keyword \"else\"\n <> \" \"\n <> prettyExpression ifFalse\n\n long = keyword \"if\"\n <> \" \"\n <> Pretty.nest 4 (prettyExpression predicate)\n <> Pretty.hardline\n <> keyword \"then\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyExpression ifTrue)\n <> Pretty.hardline\n <> keyword \"else\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyExpression ifFalse)\nprettyExpression Prompt{ arguments, import_, schema = Just schema } =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = prefix\n <> keyword \"prompt\"\n <> \" \"\n <> prettyProjectExpression arguments\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> pretty schema\n\n long = prefix\n <> keyword \"prompt\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression arguments)\n <> Pretty.hardline\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> Pretty.nest 4 (pretty schema)\n\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\nprettyExpression HTTP{ arguments, import_, schema = Just schema } =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = prefix\n <> keyword \"http\"\n <> \" \"\n <> prettyProjectExpression arguments\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> pretty schema\n\n long = prefix\n <> keyword \"http\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression arguments)\n <> Pretty.hardline\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> Pretty.nest 4 (pretty schema)\n\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\nprettyExpression Read{ arguments, import_, schema = Just schema } =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = prefix\n <> keyword \"read\"\n <> \" \"\n <> prettyProjectExpression arguments\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> pretty schema\n\n long = prefix\n <> keyword \"read\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression arguments)\n <> Pretty.hardline\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> Pretty.nest 4 (pretty schema)\n\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\nprettyExpression GitHub{ arguments, import_, schema = Just schema } =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = prefix\n <> keyword \"github\"\n <> \" \"\n <> prettyProjectExpression arguments\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> pretty schema\n\n long = prefix\n <> keyword \"github\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression arguments)\n <> Pretty.hardline\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> Pretty.nest 4 (pretty schema)\n\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\nprettyExpression Annotation{ annotated, annotation } =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = prettyOperatorExpression annotated\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> pretty annotation\n\n long = prettyOperatorExpression annotated\n <> Pretty.hardline\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> Pretty.nest 4 (pretty annotation)\nprettyExpression other =\n prettyOperatorExpression other\n\nprettyOperator\n :: Pretty a\n => Operator\n -> (Syntax s a -> Doc AnsiStyle)\n -> (Syntax s a -> Doc AnsiStyle)\nprettyOperator operator0 prettyNext expression@Operator{ operator = operator1 }\n | operator0 == operator1 = Pretty.group (Pretty.flatAlt long short)\n where\n short = prettyShort expression\n\n long = pretty (Text.replicate indent \" \") <> prettyLong expression\n\n prettyShort Operator{ left, operator, right }\n | operator0 == operator =\n prettyShort left\n <> \" \"\n <> pretty operator\n <> \" \"\n <> prettyShort right\n prettyShort other =\n prettyNext other\n\n prettyLong Operator{ left, operator, right }\n | operator0 == operator =\n Pretty.nest indent (prettyLong left)\n <> Pretty.hardline\n <> pretty operator\n <> pretty (Text.replicate spacing \" \")\n <> prettyLong right\n prettyLong other =\n pretty (Text.replicate indent \" \")\n <> Pretty.nest indent (prettyNext other)\n\n operatorWidth = Text.length (Pretty.toText operator0)\n\n alignment = 2\n\n align n = ((n `div` alignment) + 1) * alignment\n\n indent = align operatorWidth\n\n spacing = indent - operatorWidth\nprettyOperator _ prettyNext other =\n prettyNext other\n\nprettyOperatorExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyOperatorExpression = prettyOrExpression\n\nprettyOrExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyOrExpression = prettyOperator Or prettyAndExpression\n\nprettyAndExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyAndExpression = prettyOperator And prettyEqualExpression\n\nprettyEqualExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyEqualExpression = prettyOperator Equal prettyNotEqualExpression\n\nprettyNotEqualExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyNotEqualExpression = prettyOperator NotEqual prettyLessThanExpression\n\nprettyLessThanExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyLessThanExpression = prettyOperator LessThan prettyLessThanOrEqualExpression\n\nprettyLessThanOrEqualExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyLessThanOrEqualExpression = prettyOperator LessThanOrEqual prettyGreaterThanExpression\n\nprettyGreaterThanExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyGreaterThanExpression = prettyOperator GreaterThan prettyGreaterThanOrEqualExpression\n\nprettyGreaterThanOrEqualExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyGreaterThanOrEqualExpression = prettyOperator GreaterThanOrEqual prettyPlusExpression\n\nprettyPlusExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyPlusExpression = prettyOperator Plus prettyMinusExpression\n\nprettyMinusExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyMinusExpression = prettyOperator Minus prettyTimesExpression\n\nprettyTimesExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyTimesExpression = prettyOperator Times prettyModulusExpression\n\nprettyModulusExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyModulusExpression = prettyOperator Modulus prettyDivideExpression\n\nprettyDivideExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyDivideExpression = prettyOperator Divide prettyApplicationExpression\n\nprettyApplicationExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyApplicationExpression expression\n | isApplication expression = Pretty.group (Pretty.flatAlt long short)\n | otherwise = prettyProjectExpression expression\n where\n isApplication Application{} = True\n isApplication Fold{} = True\n isApplication Prompt{} = True\n isApplication HTTP{} = True\n isApplication Read{} = True\n isApplication GitHub{} = True\n isApplication Show{} = True\n isApplication _ = False\n\n short = prettyShort expression\n\n long = prettyLong expression\n\n prettyShort Application{ function, argument } =\n prettyShort function\n <> \" \"\n <> prettyProjectExpression argument\n prettyShort Fold{ handlers } =\n keyword \"fold\" <> \" \" <> prettyProjectExpression handlers\n prettyShort Prompt{ arguments, import_, schema = Nothing } =\n prefix <> keyword \"prompt\" <> \" \" <> prettyProjectExpression arguments\n where\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\n prettyShort HTTP{ arguments, import_, schema = Nothing } =\n prefix <> keyword \"http\" <> \" \" <> prettyProjectExpression arguments\n where\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\n prettyShort Read{ arguments, import_, schema = Nothing } =\n prefix <> keyword \"read\" <> \" \" <> prettyProjectExpression arguments\n where\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\n prettyShort GitHub{ arguments, import_, schema = Nothing } =\n prefix <> keyword \"github\" <> \" \" <> prettyProjectExpression arguments\n where\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\n prettyShort Show{ arguments, export, schema } =\n prefix <> keyword \"show\" <> \" \" <> prettyProjectExpression annotatedArguments\n where\n prefix = if export then keyword \"export\" <> \" \" else mempty\n\n annotatedArguments = case schema of\n Nothing -> arguments\n\n Just s -> Annotation\n { location = Type.location s\n , annotated = arguments\n , annotation = s\n }\n prettyShort other =\n prettyProjectExpression other\n\n prettyLong Application{ function, argument } =\n prettyLong function\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression argument)\n prettyLong Fold{ handlers } =\n keyword \"fold\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression handlers)\n prettyLong Prompt{ import_, arguments } =\n prefix\n <> keyword \"prompt\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression arguments)\n where\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\n prettyLong HTTP{ import_, arguments } =\n prefix\n <> keyword \"http\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression arguments)\n where\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\n prettyLong Read{ import_, arguments } =\n prefix\n <> keyword \"read\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression arguments)\n where\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\n prettyLong GitHub{ import_, arguments } =\n prefix\n <> keyword \"github\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression arguments)\n where\n prefix = if import_ then keyword \"import\" <> \" \" else mempty\n prettyLong Show{ export, arguments, schema } =\n prefix\n <> keyword \"show\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyProjectExpression annotatedArguments)\n where\n prefix = if export then keyword \"export\" <> \" \" else mempty\n\n annotatedArguments = case schema of\n Nothing -> arguments\n\n Just s -> Annotation\n { location = Type.location s\n , annotated = arguments\n , annotation = s\n }\n prettyLong other =\n prettyProjectExpression other\n\nprettyProjectExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyProjectExpression expression = case expression of\n Project{ } -> Pretty.group (Pretty.flatAlt long short)\n _ -> prettyAlternativeExpression expression\n where\n short = prettyShort expression\n\n long = prettyLong expression\n\n prettyShort Project{ larger, smaller = Single{ single = Field{ field } } } =\n prettyShort larger\n <> Pretty.operator \".\"\n <> Type.prettyRecordLabel False field\n prettyShort Project{ larger, smaller = Multiple{ multiple = [ ] } } =\n prettyShort larger\n <> Pretty.operator \".\"\n <> Pretty.punctuation \"{\"\n <> \" \"\n <> Pretty.punctuation \"}\"\n prettyShort Project{ larger, smaller = Multiple{ multiple = Field{ field = f₀ } : fs } } =\n prettyShort larger\n <> Pretty.operator \".\"\n <> Pretty.punctuation \"{\"\n <> \" \"\n <> Type.prettyRecordLabel False f₀\n <> foldMap (\\Field{ field = f } -> Pretty.punctuation \",\" <> \" \" <> Type.prettyRecordLabel False f) fs\n <> \" \"\n <> Pretty.punctuation \"}\"\n prettyShort Project{ larger, smaller = Index{ index } } =\n prettyShort larger\n <> Pretty.operator \".\"\n <> Pretty.scalar (pretty index)\n prettyShort other =\n prettyAlternativeExpression other\n\n prettyLong Project{ larger, smaller = Single{ single = Field{ field } } } =\n prettyLong larger\n <> Pretty.hardline\n <> \" \"\n <> Pretty.operator \".\"\n <> Type.prettyRecordLabel False field\n prettyLong Project{ larger, smaller = Multiple{ multiple = [ ] } } =\n prettyLong larger\n <> Pretty.hardline\n <> \" \"\n <> Pretty.operator \".\"\n <> Pretty.punctuation \"{\"\n <> \" \"\n <> Pretty.punctuation \"}\"\n prettyLong Project{ larger, smaller = Multiple{ multiple = Field{ field = f₀ } : fs } } =\n prettyLong larger\n <> Pretty.hardline\n <> \" \"\n <> Pretty.operator \".\"\n <> \" \"\n <> Pretty.nest 4\n ( Pretty.punctuation \"{\"\n <> \" \"\n <> Type.prettyRecordLabel False f₀\n <> foldMap (\\Field{ field = f } -> Pretty.hardline <> Pretty.punctuation \",\" <> \" \" <> Type.prettyRecordLabel False f) fs\n <> Pretty.hardline\n <> Pretty.punctuation \"}\"\n )\n prettyLong Project{ larger, smaller = Index{ index } } =\n prettyLong larger\n <> Pretty.hardline\n <> \" \"\n <> Pretty.operator \".\"\n <> Pretty.scalar (pretty index)\n prettyLong record =\n prettyAlternativeExpression record\n\nprettyAlternativeExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyAlternativeExpression Alternative{ name, argument = argument@Record{ } } =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = Type.prettyAlternativeLabel name\n <> prettyPrimitiveExpression argument\n\n long = Type.prettyAlternativeLabel name\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyPrimitiveExpression argument)\nprettyAlternativeExpression Alternative{ name, argument } =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = Type.prettyAlternativeLabel name\n <> \" \"\n <> prettyPrimitiveExpression argument\n\n long = Type.prettyAlternativeLabel name\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyPrimitiveExpression argument)\nprettyAlternativeExpression other =\n prettyPrimitiveExpression other\n\nprettyPrimitiveExpression :: Pretty a => Syntax s a -> Doc AnsiStyle\nprettyPrimitiveExpression Variable{ name } = Type.prettyLabel name\nprettyPrimitiveExpression List{ elements = [] } =\n punctuation \"[\" <> \" \" <> punctuation \"]\"\nprettyPrimitiveExpression List{ elements = element :<| elements } =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = punctuation \"[\"\n <> \" \"\n <> prettyExpression element\n <> foldMap (\\e -> punctuation \",\" <> \" \" <> prettyExpression e) elements\n <> \" \"\n <> punctuation \"]\"\n\n long = punctuation \"[\"\n <> \" \"\n <> prettyLongElement element\n <> foldMap (\\e -> punctuation \",\" <> \" \" <> prettyLongElement e) elements\n <> punctuation \"]\"\n\n prettyLongElement e = Pretty.nest 2 (prettyExpression e) <> Pretty.hardline\nprettyPrimitiveExpression Record{ fieldValues = [] } =\n punctuation \"{\" <> \" \" <> punctuation \"}\"\nprettyPrimitiveExpression Record { fieldValues = fieldValue : fieldValues } =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = punctuation \"{\"\n <> \" \"\n <> prettyShortFieldValue fieldValue\n <> foldMap (\\fv -> punctuation \",\" <> \" \" <> prettyShortFieldValue fv) fieldValues\n <> \" \"\n <> punctuation \"}\"\n\n long = punctuation \"{\"\n <> \" \"\n <> prettyLongFieldValue fieldValue\n <> foldMap (\\fv -> punctuation \",\" <> \" \" <> prettyLongFieldValue fv) fieldValues\n <> punctuation \"}\"\n\n prettyShortFieldValue Definition{ name, bindings, assignment } =\n Type.prettyRecordLabel True name\n <> foldMap renderBinding bindings\n <> Pretty.operator \":\"\n <> \" \"\n <> prettyExpression assignment\n where\n renderBinding binding = \" \" <> pretty binding\n\n prettyLongFieldValue Definition{ name, bindings, assignment } =\n Type.prettyRecordLabel True name\n <> foldMap renderBinding bindings\n <> Pretty.operator \":\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 4 (prettyExpression assignment)\n <> Pretty.hardline\n where\n renderBinding binding =\n Pretty.hardline\n <> \" \"\n <> Pretty.nest 4\n ( Pretty.punctuation \"(\"\n <> \" \"\n <> Pretty.nest 2 (pretty binding)\n <> Pretty.hardline\n <> Pretty.punctuation \")\"\n )\nprettyPrimitiveExpression Builtin{ builtin } =\n pretty builtin\nprettyPrimitiveExpression Scalar{ scalar } =\n pretty scalar\nprettyPrimitiveExpression Text{ chunks } = pretty chunks\nprettyPrimitiveExpression Embed{ embedded } =\n pretty embedded\nprettyPrimitiveExpression other = Pretty.group (Pretty.flatAlt long short)\n where\n short = punctuation \"(\" <> prettyExpression other <> punctuation \")\"\n\n long = punctuation \"(\"\n <> \" \"\n <> Pretty.nest 2 (prettyExpression other)\n <> Pretty.hardline\n <> punctuation \")\"\n\n{-| A bound field name\n\n >>> pretty @(NameBinding () Void) (NameBinding () \"x\" Nothing Nothing)\n x\n >>> pretty @(NameBinding () Void) (NameBinding () \"x\" (Just \"A\") Nothing)\n x : A\n >>> pretty @(NameBinding () Void) (NameBinding () \"x\" Nothing (Just \"a\"))\n x = a\n >>> pretty @(NameBinding () Void) (NameBinding () \"x\" (Just \"A\") (Just \"a\"))\n x : A = a\n-}\ndata NameBinding s a = NameBinding\n { nameLocation :: s\n , name :: Text\n , annotation :: Maybe (Type s)\n , assignment :: Maybe (Syntax s a)\n } deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable)\n\ninstance Bifunctor NameBinding where\n first f NameBinding{ nameLocation, name, annotation, assignment } =\n NameBinding\n { nameLocation = f nameLocation\n , name\n , annotation = fmap (fmap f) annotation\n , assignment = fmap (first f) assignment\n }\n\n second = fmap\n\ninstance IsString (NameBinding () a) where\n fromString string = NameBinding\n { nameLocation = ()\n , name = fromString string\n , annotation = Nothing\n , assignment = Nothing\n }\n\ninstance Pretty a => Pretty (NameBinding s a) where\n pretty NameBinding{ name, annotation, assignment } =\n Type.prettyRecordLabel False name\n <> foldMap renderAnnotation annotation\n <> foldMap renderAssignment assignment\n where\n renderAnnotation a =\n \" \" <> punctuation \":\" <> \" \" <> pretty a\n\n renderAssignment a =\n \" \" <> punctuation \"=\" <> \" \" <> pretty a\n\n{-| A bound variable, possibly with a type annotation\n\n >>> pretty @(Binding () Void) (PlainBinding (NameBinding () \"x\" Nothing Nothing))\n x\n >>> pretty @(Binding () Void) (PlainBinding (NameBinding () \"x\" (Just \"A\") Nothing))\n (x : A)\n >>> pretty @(Binding () Void) (PlainBinding (NameBinding () \"x\" Nothing (Just \"a\")))\n (x = a)\n >>> pretty @(Binding () Void) (PlainBinding (NameBinding () \"x\" (Just \"A\") (Just \"a\")))\n (x : A = a)\n >>> pretty @(Binding () Void) (RecordBinding () [])\n { }\n >>> pretty @(Binding () Void) (RecordBinding () [ \"x\", \"y\" ])\n { x, y }\n-}\ndata Binding s a\n = PlainBinding{ plain :: NameBinding s a }\n | RecordBinding\n { fieldNamesLocation :: s\n , fieldNames :: [NameBinding s a]\n }\n deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable)\n\ninstance Bifunctor Binding where\n first f PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } } =\n PlainBinding{ plain = NameBinding{ nameLocation = f nameLocation, name, annotation = fmap (fmap f) annotation, assignment = fmap (first f) assignment } }\n first f RecordBinding{ fieldNamesLocation, fieldNames } =\n RecordBinding{ fieldNamesLocation = f fieldNamesLocation, fieldNames = fmap (first f) fieldNames }\n\n second = fmap\n\ninstance IsString (Binding () a) where\n fromString string = PlainBinding\n { plain = NameBinding\n { nameLocation = ()\n , name = fromString string\n , annotation = Nothing\n , assignment = Nothing\n }\n }\n\ninstance Pretty a => Pretty (Binding s a) where\n pretty PlainBinding{ plain = NameBinding{ name, annotation = Nothing, assignment = Nothing } } =\n Type.prettyLabel name\n pretty PlainBinding{ plain = NameBinding{ name, annotation, assignment } } =\n punctuation \"(\"\n <> Type.prettyLabel name\n <> foldMap renderAnnotation annotation\n <> foldMap renderAssignment assignment\n <> punctuation \")\"\n where\n renderAnnotation a =\n \" \" <> Pretty.operator \":\" <> \" \" <> pretty a\n\n renderAssignment a =\n \" \" <> Pretty.operator \"=\" <> \" \" <> pretty a\n\n pretty RecordBinding{ fieldNames = [ ] } =\n punctuation \"{\"\n <> \" \"\n <> punctuation \"}\"\n\n pretty RecordBinding{ fieldNames = fieldName : fieldNames } =\n punctuation \"{\"\n <> \" \"\n <> pretty fieldName\n <> foldMap (\\f -> punctuation \",\" <> \" \" <> pretty f) fieldNames\n <> \" \"\n <> punctuation \"}\"\n\ndata Definition s a = Definition\n { nameLocation :: s\n , name :: Text\n , bindings :: [Binding s a]\n , annotation :: Maybe (Type s)\n , assignment :: Syntax s a\n } deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable)\n\ninstance Bifunctor Definition where\n first f Definition{ nameLocation, name, bindings, annotation, assignment } =\n Definition\n { nameLocation = f nameLocation\n , name\n , bindings = fmap (first f) bindings\n , annotation = fmap (fmap f) annotation\n , assignment = first f assignment\n }\n\n second = fmap\n\n-- | The monad that a `Bind` takes place in\ndata BindMonad = IdentityMonad | OptionalMonad | ListMonad\n deriving stock (Eq, Generic, Lift, Ord, Show)\n\ninstance Pretty BindMonad where\n pretty IdentityMonad = Pretty.builtin \"Identity\"\n pretty OptionalMonad = Pretty.builtin \"Optional\"\n pretty ListMonad = Pretty.builtin \"List\"\n\n{-| The assignment part of a @let@ binding\n\n >>> pretty @(Assignment () Void) (Define () (Definition () \"x\" [] Nothing \"y\"))\n let x = y\n >>> pretty @(Assignment () Void) (Define () (Definition () \"x\" [] (Just \"X\") \"y\"))\n let x : X = y\n >>> pretty @(Assignment () Void) (Define () (Definition () \"x\" [PlainBinding (NameBinding () \"a\" (Just \"A\") Nothing)] (Just \"X\") \"y\"))\n let x (a : A) : X = y\n-}\ndata Assignment s a\n = Define\n { assignmentLocation :: s\n , definition :: Definition s a\n }\n | Bind\n { assignmentLocation :: s\n , monad :: BindMonad\n , binding :: Binding s a\n , assignment :: Syntax s a\n }\n deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable)\n\ninstance Bifunctor Assignment where\n first f\n Define{ assignmentLocation, definition = Definition{ nameLocation, name, bindings, annotation, assignment } } = Define\n { assignmentLocation = f assignmentLocation\n , definition = Definition\n { nameLocation = f nameLocation\n , name\n , bindings = fmap (first f) bindings\n , annotation = fmap (fmap f) annotation\n , assignment = first f assignment\n }\n }\n first f\n Bind{ assignmentLocation, monad, binding, assignment } = Bind\n { assignmentLocation = f assignmentLocation\n , monad\n , binding = first f binding\n , assignment = first f assignment\n }\n\n second = fmap\n\ninstance Pretty a => Pretty (Assignment s a) where\n pretty Define{ definition = Definition{ name, bindings, annotation = Nothing, assignment } } =\n Pretty.group (Pretty.flatAlt long short)\n where\n long = keyword \"let\"\n <> \" \"\n <> Type.prettyLabel name\n <> Pretty.hardline\n <> foldMap (\\binding -> \" \" <> Pretty.nest 6 (pretty binding) <> Pretty.hardline) bindings\n <> \" \"\n <> punctuation \"=\"\n <> \" \"\n <> Pretty.nest 8 (pretty assignment)\n\n short = keyword \"let\"\n <> \" \"\n <> Type.prettyLabel name\n <> \" \"\n <> foldMap (\\binding -> pretty binding <> \" \") bindings\n <> punctuation \"=\"\n <> \" \"\n <> pretty assignment\n pretty Define{ definition = Definition{ name, bindings, annotation = Just type_, assignment } } =\n Pretty.group (Pretty.flatAlt long short)\n where\n long = keyword \"let\"\n <> \" \"\n <> Type.prettyLabel name\n <> Pretty.hardline\n <> foldMap (\\binding -> \" \" <> Pretty.nest 6 (pretty binding) <> Pretty.hardline) bindings\n <> \" \"\n <> Pretty.operator \":\"\n <> \" \"\n <> Pretty.nest 8 (pretty type_)\n <> Pretty.hardline\n <> \" \"\n <> punctuation \"=\"\n <> \" \"\n <> Pretty.nest 8 (pretty assignment)\n\n short = keyword \"let\"\n <> \" \"\n <> Type.prettyLabel name\n <> \" \"\n <> foldMap (\\binding -> pretty binding <> \" \") bindings\n <> Pretty.operator \":\"\n <> \" \"\n <> pretty type_\n <> \" \"\n <> punctuation \"=\"\n <> \" \"\n <> pretty assignment\n pretty Bind{ monad = IdentityMonad, binding, assignment } =\n Pretty.group (Pretty.flatAlt long short)\n where\n long = keyword \"let\"\n <> \" \"\n <> pretty binding\n <> Pretty.hardline\n <> \" \"\n <> punctuation \"=\"\n <> \" \"\n <> Pretty.nest 8 (pretty assignment)\n\n short = keyword \"let\"\n <> \" \"\n <> pretty binding\n <> \" \"\n <> punctuation \"=\"\n <> \" \"\n <> pretty assignment\n pretty Bind{ monad = ListMonad, binding, assignment } =\n Pretty.group (Pretty.flatAlt long short)\n where\n long = keyword \"for\"\n <> \" \"\n <> pretty binding\n <> Pretty.hardline\n <> \" \"\n <> punctuation \"of\"\n <> \" \"\n <> Pretty.nest 8 (pretty assignment)\n\n short = keyword \"for\"\n <> \" \"\n <> pretty binding\n <> \" \"\n <> punctuation \"of\"\n <> \" \"\n <> pretty assignment\n pretty Bind{ monad = OptionalMonad, binding, assignment } =\n Pretty.group (Pretty.flatAlt long short)\n where\n long = keyword \"if\"\n <> \" \"\n <> keyword \"let\"\n <> \" \"\n <> pretty binding\n <> Pretty.hardline\n <> \" \"\n <> punctuation \"=\"\n <> \" \"\n <> Pretty.nest 8 (pretty assignment)\n\n short = keyword \"if\"\n <> \" \"\n <> keyword \"let\"\n <> \" \"\n <> pretty binding\n <> \" \"\n <> punctuation \"of\"\n <> \" \"\n <> pretty assignment\n\nflatten :: Doc ann -> Doc ann\nflatten doc = case doc of\n FlatAlt _ y -> flatten y\n Cat x y -> Cat (flatten x) (flatten y)\n Nest i x -> Nest i (flatten x)\n Line -> Fail\n Union x _ -> flatten x\n Column f -> Column (flatten . f)\n WithPageWidth f -> WithPageWidth (flatten . f)\n Nesting f -> Nesting (flatten . f)\n Annotated ann x -> Annotated ann (flatten x)\n _ -> doc\n" }, { "path": "src/Grace/TH.hs", "content": "{- | This module provides Template Haskell functions to embed expression and\n their times at compile-time.\n-}\n\nmodule Grace.TH\n ( grace\n -- * Embedding an expression\n , expressionFromCode\n , expressionFromFile\n , expressionFromInput\n -- * Embedding the type of an expression\n , typeOfCode\n , typeOfFile\n , typeOfInput\n ) where\n\nimport Control.Monad.IO.Class (liftIO)\nimport Data.Functor (void)\nimport Data.Text (Text)\nimport Data.Void (Void)\nimport Grace.Input (Input(..), Mode(..))\nimport Grace.Syntax (Syntax)\nimport Grace.Type (Type)\nimport Language.Haskell.TH.Quote (QuasiQuoter(..))\nimport Language.Haskell.TH.Syntax (Code(examineCode), Lift, Q, TExp(..))\nimport Prelude hiding (exp)\n\nimport qualified Data.Text as Text\nimport qualified Grace.Interpret as Interpret\nimport qualified Grace.Value as Value\nimport qualified Language.Haskell.TH as TH\nimport qualified Language.Haskell.TH.Syntax as TH\n\n-- $setup\n-- >>> :set -XOverloadedStrings -XQuasiQuotes -XTemplateHaskell\n\n{- | A quasi-quoter for expressions.\n\n Takes the source code of a expression, type checks it and returns the fully\n normalized AST.\n\n >>> [grace| \"hello\" |]\n Text {location = (), chunks = Chunks \"hello\" []}\n\n This quoter is implemented using `expressionFromCode`.\n Note that other quoting (declarations, patterns, types) is not supported.\n-}\ngrace :: QuasiQuoter\ngrace = QuasiQuoter\n { quoteExp = fmap TH.unType . examineCode . expressionFromCode . Text.pack\n , quoteDec = error \"Declaration quoting not supported\"\n , quotePat = error \"Pattern quoting not supported\"\n , quoteType = error \"Type quoting not supported\"\n }\n\n{- | Evaluate an expression at compile time.\n\n This function takes the source code of a expressions, type checks it and\n returns the fully normalized AST.\n\n >>> $$(expressionFromCode \"\\\"hello\\\"\")\n Text {location = (), chunks = Chunks \"hello\" []}\n-}\nexpressionFromCode :: Text -> Code Q (Syntax () Void)\nexpressionFromCode code = expressionFromInput (Code \"(quasiquote)\" code)\n\n-- | Like `expressionFromCode`, but takes path of a source file as input.\nexpressionFromFile :: FilePath -> Code Q (Syntax () Void)\nexpressionFromFile path = expressionFromInput (Path path AsCode)\n\n-- | Like `expressionFromCode`, but expects `Input` as an argument.\nexpressionFromInput :: Input -> Code Q (Syntax () Void)\nexpressionFromInput = helperFunction snd\n\n{- | Infer the type of an expression at compile time.\n\n This function takes the source code of an expressions, type checks it and\n returns the inferred type of that expression.\n\n >>> $$(typeOfCode \"\\\"hello\\\"\")\n Scalar {location = (), scalar = Text}\n-}\ntypeOfCode :: Text -> Code Q (Type ())\ntypeOfCode = typeOfInput . Code \"(input)\"\n\n-- | Like `typeOfCode`, but takes path of a source file as input.\ntypeOfFile :: FilePath -> Code Q (Type ())\ntypeOfFile path = typeOfInput (Path path AsCode)\n\n-- | Like `typeOfCode`, but expects `Input` as an argument.\ntypeOfInput :: Input -> Code Q (Type ())\ntypeOfInput = helperFunction fst\n\n-- | Underlying code for all TemplateHaskell utilities\nhelperFunction\n :: Lift result\n => ((Type (), Syntax () Void) -> result) -> Input -> Code Q result\nhelperFunction f input = TH.Code do\n (inferred, value) <- liftIO (Interpret.interpret input)\n\n let type_ = void inferred\n\n let syntax = Value.quote (void value)\n\n exp <- TH.lift (f (type_, syntax))\n\n return (TExp exp)\n" }, { "path": "src/Grace/Type.hs", "content": "{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE RecordWildCards #-}\n\n{-# OPTIONS_GHC -Wno-orphans #-}\n\n{-| This module stores the `Type` type representing polymorphic types and\n utilities for operating on `Type`s\n-}\nmodule Grace.Type\n ( -- * Types\n Type(..)\n , Record(..)\n , Union(..)\n\n -- * Utilities\n , solveType\n , solveFields\n , solveAlternatives\n , typeFreeIn\n , fieldsFreeIn\n , alternativesFreeIn\n , substituteType\n , substituteFields\n , substituteAlternatives\n , defaultTo\n\n -- * Pretty-printing\n , prettyRecordLabel\n , prettyAlternativeLabel\n , prettyLabel\n , prettyTextLiteral\n , prettyTextBody\n ) where\n\nimport Control.Lens (Plated(..))\nimport Data.Bifunctor (Bifunctor(..))\nimport Data.Generics.Product (the)\nimport Data.Generics.Sum (_As)\nimport Data.String (IsString(..))\nimport Data.Text (Text)\nimport GHC.Generics (Generic)\nimport Grace.Domain (Domain)\nimport Grace.Existential (Existential)\nimport Grace.Pretty (Pretty(..), builtin, keyword, label, operator, punctuation)\nimport Language.Haskell.TH.Syntax (Lift)\nimport Prelude hiding (lines)\nimport Prettyprinter (Doc)\nimport Prettyprinter.Render.Terminal (AnsiStyle)\n\nimport Grace.Monotype\n (Monotype, RemainingAlternatives(..), RemainingFields(..), Scalar(..))\n\nimport qualified Control.Lens as Lens\nimport qualified Data.List as List\nimport qualified Data.Text as Text\nimport qualified Grace.Domain as Domain\nimport qualified Grace.Label as Label\nimport qualified Grace.Monotype as Monotype\nimport qualified Prettyprinter as Pretty\n\n{- $setup\n\n >>> :set -XOverloadedStrings\n >>> :set -XTypeApplications\n-}\n\n-- | A potentially polymorphic type\ndata Type s\n = VariableType { location :: s, name :: Text }\n -- ^ Type variable\n --\n -- >>> pretty @(Type ()) (VariableType () \"a\")\n -- a\n | UnsolvedType { location :: s, existential :: Existential Monotype }\n -- ^ A placeholder variable whose type has not yet been inferred\n --\n -- >>> pretty @(Type ()) (UnsolvedType () 0)\n -- a?\n | Forall { location :: s, nameLocation :: s, name :: Text, domain :: Domain, type_ :: Type s }\n -- ^ Universally quantified type\n --\n -- >>> pretty @(Type ()) (Forall () () \"a\" Domain.Type \"a\")\n -- forall (a : Type) . a\n | Function { location :: s, input :: Type s, output :: Type s }\n -- ^ Function type\n --\n -- >>> pretty @(Type ()) (Function () \"a\" \"b\")\n -- a -> b\n | Optional { location :: s, type_ :: Type s }\n -- ^ Optional type\n --\n -- >>> pretty @(Type ()) (Optional () \"a\")\n -- Optional a\n | List { location :: s, type_ :: Type s }\n -- ^ List type\n --\n -- >>> pretty @(Type ()) (List () \"a\")\n -- List a\n | Record { location :: s, fields :: Record s }\n -- ^ Record type\n --\n -- >>> pretty @(Type ()) (Record () (Fields [(\"x\", \"X\"), (\"y\", \"Y\")] Monotype.EmptyFields))\n -- { x: X, y: Y }\n -- >>> pretty @(Type ()) (Record () (Fields [(\"x\", \"X\"), (\"y\", \"Y\")] (Monotype.UnsolvedFields 0)))\n -- { x: X, y: Y, a? }\n | Union { location :: s, alternatives :: Union s }\n -- ^ Union type\n --\n -- >>> pretty @(Type ()) (Union () (Alternatives [(\"X\", \"X\"), (\"Y\", \"Y\")] Monotype.EmptyAlternatives))\n -- < X: X | Y: Y >\n -- >>> pretty @(Type ()) (Union () (Alternatives [(\"X\", \"X\"), (\"Y\", \"Y\")] (Monotype.UnsolvedAlternatives 0)))\n -- < X: X | Y: Y | a? >\n | Scalar { location :: s, scalar :: Scalar }\n deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable)\n\ninstance IsString (Type ()) where\n fromString string = VariableType{ name = fromString string, location = () }\n\ninstance Pretty (Type s) where\n pretty = prettyQuantifiedType\n\ninstance Plated (Type s) where\n plate onType type_ =\n case type_ of\n VariableType{..} -> do\n pure VariableType{..}\n UnsolvedType{..} -> do\n pure UnsolvedType{..}\n Forall{ type_ = oldType, .. } -> do\n newType <- onType oldType\n return Forall{ type_ = newType, .. }\n Function{ input = oldInput, output = oldOutput, .. } -> do\n newInput <- onType oldInput\n newOutput <- onType oldOutput\n return Function{ input = newInput, output = newOutput, .. }\n Optional{ type_ = oldType, .. } -> do\n newType <- onType oldType\n return Optional{ type_ = newType, .. }\n List{ type_ = oldType, .. } -> do\n newType <- onType oldType\n return List{ type_ = newType, .. }\n Record{ fields = Fields oldFieldTypes remainingFields, .. } -> do\n let onPair (field, oldType) = do\n newType <- onType oldType\n return (field, newType)\n newFieldTypes <- traverse onPair oldFieldTypes\n return Record{ fields = Fields newFieldTypes remainingFields, .. }\n Union{ alternatives = Alternatives oldAlternativeTypes remainingAlternatives, .. } -> do\n let onPair (alternative, oldType) = do\n newType <- onType oldType\n return (alternative, newType)\n newAlternativeTypes <- traverse onPair oldAlternativeTypes\n return Union{ alternatives = Alternatives newAlternativeTypes remainingAlternatives, .. }\n Scalar{..} -> do\n pure Scalar{..}\n\n-- | A potentially polymorphic record type\ndata Record s = Fields [(Text, Type s)] RemainingFields\n deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable)\n\ninstance Pretty (Record s) where\n pretty = prettyRecordType\n\n-- | A potentially polymorphic union type\ndata Union s = Alternatives [(Text, Type s)] RemainingAlternatives\n deriving stock (Eq, Functor, Foldable, Generic, Lift, Show, Traversable)\n\ninstance Pretty (Union s) where\n pretty = prettyUnionType\n\n{-| This function should not be exported or generally used because it does not\n handle the `location` field correctly. It is only really safe to use within\n one of the @solve*@ functions\n-}\nfromMonotype :: Monotype -> Type ()\nfromMonotype monotype =\n case monotype of\n Monotype.VariableType name ->\n VariableType{..}\n Monotype.UnsolvedType existential ->\n UnsolvedType{..}\n Monotype.Function input output ->\n Function{ input = fromMonotype input, output = fromMonotype output, .. }\n Monotype.Optional type_ ->\n Optional{ type_ = fromMonotype type_, .. }\n Monotype.List type_ ->\n List{ type_ = fromMonotype type_, .. }\n Monotype.Record (Monotype.Fields kτs ρ) ->\n Record{ fields = Fields (map (second fromMonotype) kτs) ρ, .. }\n Monotype.Union (Monotype.Alternatives kτs ρ) ->\n Union{ alternatives = Alternatives (map (second fromMonotype) kτs) ρ, .. }\n Monotype.Scalar scalar ->\n Scalar{..}\n where\n location = ()\n\ninstance Pretty Monotype where\n pretty = pretty . fromMonotype\n\n{-| Substitute a `Type` by replacing all occurrences of the given unsolved\n variable with a `Monotype`\n-}\nsolveType :: Existential Monotype -> Monotype -> Type s -> Type s\nsolveType unsolved monotype = Lens.transform transformType\n where\n transformType UnsolvedType{..}\n | unsolved == existential =\n fmap (\\_ -> location) (fromMonotype monotype)\n\n transformType type_ =\n type_\n\n{-| Substitute a `Type` by replacing all occurrences of the given unsolved\n fields variable with a t`Monotype.Record`\n-}\nsolveFields\n :: Existential Monotype.Record -> Monotype.Record -> Type s -> Type s\nsolveFields unsolved (Monotype.Fields fieldMonotypes fields) =\n Lens.transform transformType\n where\n transformType Record{ fields = Fields fieldTypes (UnsolvedFields existential), .. }\n | unsolved == existential =\n Record{ fields = Fields fieldTypes' fields, .. }\n where\n fieldTypes' =\n fieldTypes <> map transformPair fieldMonotypes\n\n transformPair (field, monotype) =\n (field, fmap (\\_ -> location) (fromMonotype monotype))\n\n transformType type_ =\n type_\n\n{-| Substitute a `Type` by replacing all occurrences of the given unsolved\n alternatives variable with a t`Monotype.Union`\n-}\nsolveAlternatives\n :: Existential Monotype.Union -> Monotype.Union -> Type s -> Type s\nsolveAlternatives unsolved (Monotype.Alternatives alternativeMonotypes alternatives) =\n Lens.transform transformType\n where\n transformType Union{ alternatives = Alternatives alternativeTypes (UnsolvedAlternatives existential), .. }\n | unsolved == existential =\n Union{ alternatives = Alternatives alternativeTypes' alternatives, .. }\n where\n alternativeTypes' =\n alternativeTypes <> map transformPair alternativeMonotypes\n\n transformPair (alternative, monotype) =\n (alternative, fmap (\\_ -> location) (fromMonotype monotype))\n\n transformType type_ =\n type_\n\n{-| Replace all occurrences of a variable within one `Type` with another `Type`,\n given the variable's label and index\n-}\nsubstituteType :: Text -> Int -> Type s -> Type s -> Type s\nsubstituteType a n _A type_ =\n case type_ of\n VariableType{..}\n | a == name && n == 0 -> _A\n | otherwise -> VariableType{..}\n\n UnsolvedType{..} ->\n UnsolvedType{..}\n\n Forall{ type_ = oldType, .. } -> Forall{ type_ = newType, .. }\n where\n newType = substituteType a n' _A oldType\n\n n' | a == name && domain == Domain.Type = n + 1\n | otherwise = n\n\n Function{ input = oldInput, output = oldOutput, .. } ->\n Function{ input = newInput, output = newOutput, .. }\n where\n newInput = substituteType a n _A oldInput\n\n newOutput = substituteType a n _A oldOutput\n\n Optional{ type_ = oldType, .. } -> Optional{ type_ = newType, .. }\n where\n newType = substituteType a n _A oldType\n\n List{ type_ = oldType, .. } -> List{ type_ = newType, .. }\n where\n newType = substituteType a n _A oldType\n\n Record{ fields = Fields kAs ρ, .. } ->\n Record{ fields = Fields (map (second (substituteType a n _A)) kAs) ρ, .. }\n\n Union{ alternatives = Alternatives kAs ρ, .. } ->\n Union{ alternatives = Alternatives (map (second (substituteType a n _A)) kAs) ρ, .. }\n\n Scalar{..} ->\n Scalar{..}\n\n{-| Replace all occurrences of a variable within one `Type` with another `Type`,\n given the variable's label and index\n-}\nsubstituteFields :: Text -> Int -> Record s -> Type s -> Type s\nsubstituteFields ρ0 n r@(Fields kτs ρ1) type_ =\n case type_ of\n VariableType{..} ->\n VariableType{..}\n\n UnsolvedType{..} ->\n UnsolvedType{..}\n\n Forall{ type_ = oldType, .. } -> Forall{ type_ = newType, .. }\n where\n newType = substituteFields ρ0 n' r oldType\n\n n' | ρ0 == name && domain == Domain.Fields = n + 1\n | otherwise = n\n\n Function{ input = oldInput, output = oldOutput, .. } ->\n Function{ input = newInput, output = newOutput, .. }\n where\n newInput = substituteFields ρ0 n r oldInput\n\n newOutput = substituteFields ρ0 n r oldOutput\n\n Optional{ type_ = oldType, .. } -> Optional{ type_ = newType, .. }\n where\n newType = substituteFields ρ0 n r oldType\n\n List{ type_ = oldType, .. } -> List{ type_ = newType, .. }\n where\n newType = substituteFields ρ0 n r oldType\n\n Record{ fields = Fields kAs0 ρ, .. }\n | VariableFields ρ0 == ρ && n == 0 ->\n Record{ fields = Fields (map (second (substituteFields ρ0 n r)) kAs1) ρ1, .. }\n | otherwise ->\n Record{ fields = Fields (map (second (substituteFields ρ0 n r)) kAs0) ρ, .. }\n where\n kAs1 = kAs0 <> map (second (fmap (\\_ -> location))) kτs\n\n Union{ alternatives = Alternatives kAs ρ, .. } ->\n Union{ alternatives = Alternatives (map (second (substituteFields ρ0 n r)) kAs) ρ, .. }\n\n Scalar{..} ->\n Scalar{..}\n\n{-| Replace all occurrences of a variable within one `Type` with another `Type`,\n given the variable's label and index\n-}\nsubstituteAlternatives :: Text -> Int -> Union s -> Type s -> Type s\nsubstituteAlternatives ρ0 n r@(Alternatives kτs ρ1) type_ =\n case type_ of\n VariableType{..} ->\n VariableType{..}\n\n UnsolvedType{..} ->\n UnsolvedType{..}\n\n Forall{ type_ = oldType, .. } -> Forall{ type_ = newType, .. }\n where\n newType = substituteAlternatives ρ0 n' r oldType\n\n n' | ρ0 == name && domain == Domain.Alternatives = n + 1\n | otherwise = n\n\n Function{ input = oldInput, output = oldOutput, .. } ->\n Function{ input = newInput, output = newOutput, .. }\n where\n newInput = substituteAlternatives ρ0 n r oldInput\n\n newOutput = substituteAlternatives ρ0 n r oldOutput\n\n Optional{ type_ = oldType, .. } -> Optional{ type_ = newType, .. }\n where\n newType = substituteAlternatives ρ0 n r oldType\n\n List{ type_ = oldType, .. } -> List{ type_ = newType, .. }\n where\n newType = substituteAlternatives ρ0 n r oldType\n\n Record{ fields = Fields kAs ρ, .. } ->\n Record{ fields = Fields (map (second (substituteAlternatives ρ0 n r)) kAs) ρ, .. }\n\n Union{ alternatives = Alternatives kAs0 ρ, .. }\n | Monotype.VariableAlternatives ρ0 == ρ && n == 0 ->\n Union{ alternatives = Alternatives (map (second (substituteAlternatives ρ0 n r)) kAs1) ρ1, .. }\n | otherwise ->\n Union{ alternatives = Alternatives (map (second (substituteAlternatives ρ0 n r)) kAs0) ρ, .. }\n where\n kAs1 = kAs0 <> map (second (fmap (\\_ -> location))) kτs\n\n Scalar{..} ->\n Scalar{..}\n\n{-| Count how many times the given `Existential` `Type` variable appears within\n a `Type`\n-}\ntypeFreeIn :: Existential Monotype -> Type s -> Bool\ntypeFreeIn unsolved =\n Lens.has\n ( Lens.cosmos\n . _As @\"UnsolvedType\"\n . the @2\n . Lens.only unsolved\n )\n\n{-| Count how many times the given `Existential` t`Monotype.Record` variable\n appears within a `Type`\n-}\nfieldsFreeIn :: Existential Monotype.Record -> Type s -> Bool\nfieldsFreeIn unsolved =\n Lens.has\n ( Lens.cosmos\n . _As @\"Record\"\n . the @2\n . the @2\n . _As @\"UnsolvedFields\"\n . Lens.only unsolved\n )\n\n{-| Count how many times the given `Existential` t`Monotype.Union` variable\n appears within a `Type`\n-}\nalternativesFreeIn :: Existential Monotype.Union -> Type s -> Bool\nalternativesFreeIn unsolved =\n Lens.has\n ( Lens.cosmos\n . _As @\"Union\"\n . the @2\n . the @2\n . _As @\"UnsolvedAlternatives\"\n . Lens.only unsolved\n )\n\n-- | Default unsolved type variables\ndefaultTo :: Type s -> Type s -> Type s\ndefaultTo type₀ = Lens.transform transformation\n where\n transformation UnsolvedType{ } = type₀\n transformation type₁ = type₁\n\nprettyQuantifiedType :: Type s -> Doc AnsiStyle\nprettyQuantifiedType type0@Forall{} =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = prettyShort (keyword \"forall\" <> \" \") type0\n\n long = prettyLong type0\n\n prettyShort prefix Forall{..} =\n prefix\n <> punctuation \"(\"\n <> label (pretty name)\n <> \" \"\n <> punctuation \":\"\n <> \" \"\n <> pretty domain\n <> punctuation \")\"\n <> \" \"\n <> prettyShort \"\" type_\n\n prettyShort _prefix _A =\n punctuation \".\" <> \" \" <> prettyFunctionType _A\n\n prettyLong Forall{..} =\n keyword \"forall\"\n <> \" \"\n <> punctuation \"(\"\n <> label (pretty name)\n <> \" \"\n <> punctuation \":\"\n <> \" \"\n <> pretty domain\n <> punctuation \")\"\n <> \" \"\n <> punctuation \".\"\n <> Pretty.hardline\n <> prettyLong type_\n prettyLong _A =\n \" \" <> Pretty.nest 2 (prettyFunctionType _A)\nprettyQuantifiedType other = prettyFunctionType other\n\nprettyFunctionType :: Type s -> Doc AnsiStyle\nprettyFunctionType type_@Function{} = Pretty.group (Pretty.flatAlt long short)\n where\n long = prettyLong type_\n\n short = prettyShort type_\n\n prettyShort Function{..} =\n prettyApplicationType input\n <> \" \"\n <> punctuation \"->\"\n <> \" \"\n <> prettyShort output\n prettyShort _A =\n prettyApplicationType _A\n\n prettyLong Function{..} =\n prettyApplicationType input\n <> \" \"\n <> punctuation \"->\"\n <> Pretty.hardline\n <> prettyLong output\n prettyLong _A =\n \" \" <> Pretty.nest 2 (prettyApplicationType _A)\nprettyFunctionType other =\n prettyApplicationType other\n\nprettyApplicationType :: Type s -> Doc AnsiStyle\nprettyApplicationType Optional{..} = Pretty.group (Pretty.flatAlt long short)\n where\n short = builtin \"Optional\" <> \" \" <> prettyPrimitiveType type_\n\n long = builtin \"Optional\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyPrimitiveType type_)\nprettyApplicationType List{..} = Pretty.group (Pretty.flatAlt long short)\n where\n short = builtin \"List\" <> \" \" <> prettyPrimitiveType type_\n\n long = builtin \"List\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 2 (prettyPrimitiveType type_)\nprettyApplicationType other =\n prettyPrimitiveType other\n\nprettyPrimitiveType :: Type s -> Doc AnsiStyle\nprettyPrimitiveType VariableType{..} =\n label (pretty name)\nprettyPrimitiveType UnsolvedType{..} =\n label (pretty existential <> \"?\")\nprettyPrimitiveType Record{..} =\n prettyRecordType fields\nprettyPrimitiveType Union{..} =\n prettyUnionType alternatives\nprettyPrimitiveType Scalar{..} =\n pretty scalar\nprettyPrimitiveType other =\n Pretty.group (Pretty.flatAlt long short)\n where\n short = punctuation \"(\" <> prettyQuantifiedType other <> punctuation \")\"\n\n long = punctuation \"(\"\n <> \" \"\n <> Pretty.nest 2 (prettyQuantifiedType other)\n <> Pretty.hardline\n <> punctuation \")\"\n\nprettyRecordType :: Record s -> Doc AnsiStyle\nprettyRecordType (Fields [] fields) =\n punctuation \"{\"\n <> (case fields of\n EmptyFields -> \" \"\n UnsolvedFields ρ -> \" \" <> label (pretty ρ <> \"?\") <> \" \"\n VariableFields ρ -> \" \" <> label (pretty ρ) <> \" \"\n )\n <> punctuation \"}\"\nprettyRecordType (Fields (keyType : keyTypes) fields) =\n Pretty.group (Pretty.flatAlt long short)\n where\n short =\n punctuation \"{\"\n <> \" \"\n <> prettyShortFieldType keyType\n <> foldMap (\\ft -> punctuation \",\" <> \" \" <> prettyShortFieldType ft) keyTypes\n <> (case fields of\n EmptyFields ->\n mempty\n UnsolvedFields ρ ->\n punctuation \",\" <> \" \" <> label (pretty ρ <> \"?\")\n VariableFields ρ ->\n punctuation \",\" <> \" \" <> label (pretty ρ)\n )\n <> \" \"\n <> punctuation \"}\"\n\n long = punctuation \"{\"\n <> \" \"\n <> prettyLongFieldType keyType\n <> foldMap (\\ft -> punctuation \",\" <> \" \" <> prettyLongFieldType ft) keyTypes\n <> case fields of\n EmptyFields ->\n punctuation \"}\"\n UnsolvedFields ρ ->\n punctuation \",\"\n <> \" \"\n <> label (pretty ρ <> \"?\")\n <> Pretty.hardline\n <> punctuation \"}\"\n VariableFields ρ ->\n punctuation \",\"\n <> \" \"\n <> label (pretty ρ)\n <> Pretty.hardline\n <> punctuation \"}\"\n\n prettyShortFieldType :: (Text, Type s) -> Doc AnsiStyle\n prettyShortFieldType (key, type_) =\n prettyRecordLabel False key\n <> operator \":\"\n <> \" \"\n <> prettyQuantifiedType type_\n\n prettyLongFieldType :: (Text, Type s) -> Doc AnsiStyle\n prettyLongFieldType (key, type_) =\n prettyRecordLabel False key\n <> operator \":\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 4 (prettyQuantifiedType type_)\n <> Pretty.hardline\n\nprettyUnionType :: Union s -> Doc AnsiStyle\nprettyUnionType (Alternatives [] alternatives) =\n punctuation \"<\"\n <> (case alternatives of\n EmptyAlternatives -> \" \"\n UnsolvedAlternatives ρ -> \" \" <> label (pretty ρ <> \"?\") <> \" \"\n VariableAlternatives ρ -> \" \" <> label (pretty ρ) <> \" \"\n )\n <> punctuation \">\"\nprettyUnionType (Alternatives (keyType : keyTypes) alternatives) =\n Pretty.group (Pretty.flatAlt long short)\n where\n short =\n punctuation \"<\"\n <> \" \"\n <> prettyShortAlternativeType keyType\n <> foldMap (\\kt -> \" \" <> punctuation \"|\" <> \" \" <> prettyShortAlternativeType kt) keyTypes\n <> (case alternatives of\n EmptyAlternatives ->\n mempty\n UnsolvedAlternatives ρ ->\n \" \"\n <> punctuation \"|\"\n <> \" \"\n <> label (pretty ρ <> \"?\")\n VariableAlternatives ρ ->\n \" \"\n <> punctuation \"|\"\n <> \" \"\n <> label (pretty ρ)\n )\n <> \" \"\n <> punctuation \">\"\n\n long = punctuation \"<\"\n <> \" \"\n <> prettyLongAlternativeType keyType\n <> foldMap (\\kt -> punctuation \"|\" <> \" \" <> prettyLongAlternativeType kt) keyTypes\n <> case alternatives of\n EmptyAlternatives ->\n punctuation \">\"\n UnsolvedAlternatives ρ ->\n punctuation \"|\"\n <> \" \"\n <> label (pretty ρ <> \"?\")\n <> Pretty.hardline\n <> punctuation \">\"\n VariableAlternatives ρ ->\n punctuation \"|\"\n <> \" \"\n <> label (pretty ρ)\n <> Pretty.hardline\n <> punctuation \">\"\n\n prettyShortAlternativeType (key, type_) =\n prettyAlternativeLabel key\n <> operator \":\"\n <> \" \"\n <> prettyQuantifiedType type_\n\n prettyLongAlternativeType (key, type_) =\n prettyAlternativeLabel key\n <> operator \":\"\n <> Pretty.hardline\n <> \" \"\n <> Pretty.nest 4 (prettyQuantifiedType type_)\n <> Pretty.hardline\n\n-- | Pretty-print a @Text@ literal\nprettyTextLiteral :: Text -> Doc AnsiStyle\nprettyTextLiteral text = \"\\\"\" <> prettyTextBody False text <> \"\\\"\"\n\n-- | Pretty-print the body of a @Text@ literal\nprettyTextBody\n :: Bool\n -- ^ Is this a multiline string literal\n -> Text\n -> Doc AnsiStyle\nprettyTextBody False text =\n ( pretty\n . Text.replace \"\\\"\" \"\\\\\\\"\"\n . Text.replace \"\\b\" \"\\\\b\"\n . Text.replace \"\\f\" \"\\\\f\"\n . Text.replace \"\\n\" \"\\\\n\"\n . Text.replace \"\\r\" \"\\\\r\"\n . Text.replace \"\\t\" \"\\\\t\"\n . Text.replace \"\\\\\" \"\\\\\\\\\"\n ) text\nprettyTextBody True text =\n mconcat\n (List.intersperse\n Pretty.hardline\n (map\n ( pretty\n . Text.replace \"\\\"\" \"\\\\\\\"\"\n . Text.replace \"\\b\" \"\\\\b\"\n . Text.replace \"\\f\" \"\\\\f\"\n . Text.replace \"\\r\" \"\\\\r\"\n . Text.replace \"\\\\\" \"\\\\\\\\\"\n )\n lines\n )\n )\n where\n lines = Text.splitOn \"\\n\" text\n\n-- | Pretty-print a quoted alternative\nprettyQuotedAlternative :: Text -> Doc AnsiStyle\nprettyQuotedAlternative text =\n \"'\"\n <> ( pretty\n . Text.replace \"'\" \"\\\\\\'\"\n . Text.replace \"\\b\" \"\\\\b\"\n . Text.replace \"\\f\" \"\\\\f\"\n . Text.replace \"\\n\" \"\\\\n\"\n . Text.replace \"\\r\" \"\\\\r\"\n . Text.replace \"\\t\" \"\\\\t\"\n . Text.replace \"\\\\\" \"\\\\\\\\\"\n ) text\n <> \"'\"\n\n-- | Pretty-print a record label\nprettyRecordLabel\n :: Bool\n -- ^ Always quote the label if `True`\n --\n -- This is mainly set to `True` when pretty-printing records so that the\n -- output is valid JSON\n -> Text\n -> Doc AnsiStyle\nprettyRecordLabel alwaysQuote field\n | Label.validRecordLabel field && not alwaysQuote =\n label (pretty field)\n | otherwise =\n label (prettyTextLiteral field)\n\n-- | Pretty-print an alternative label\nprettyAlternativeLabel\n :: Text\n -> Doc AnsiStyle\nprettyAlternativeLabel alternative\n | Label.validAlternativeLabel alternative =\n label (pretty alternative)\n | otherwise =\n label (prettyQuotedAlternative alternative)\n\n-- | Pretty-print a label\nprettyLabel\n :: Text\n -> Doc AnsiStyle\nprettyLabel name\n | Label.validLabel name =\n label (pretty name)\n | otherwise =\n punctuation \".\" <> label (prettyQuotedAlternative name)\n" }, { "path": "src/Grace/Value.hs", "content": "{-# LANGUAGE OverloadedLists #-}\n\n{-| This module contains the `Value` type used internally for efficient\n evaluation of expressions\n-}\nmodule Grace.Value\n ( -- * Types\n Names(..)\n , Value(..)\n , location\n\n -- * Utilities\n , quote\n , fromJSON\n , toJSON\n , syntax\n , complete\n , effects\n ) where\n\nimport Control.Applicative (empty)\nimport Control.Lens (Getting, Plated(..), Traversal')\nimport Data.Aeson (FromJSON(..))\nimport Data.Bifunctor (first)\nimport Data.Foldable (toList)\nimport Data.Generics.Sum (_As)\nimport Data.Generics.Product (the)\nimport Data.HashMap.Strict.InsOrd (InsOrdHashMap)\nimport Data.List.NonEmpty (NonEmpty(..))\nimport Data.Monoid (Any)\nimport Data.Sequence (Seq)\nimport Data.Text (Text)\nimport Data.Void (Void)\nimport GHC.Generics (Generic)\nimport Grace.Context (Context)\nimport Grace.Pretty (Pretty(..))\nimport Grace.Syntax (Builtin, Scalar, Syntax)\n\nimport qualified Control.Lens as Lens\nimport qualified Data.Aeson as Aeson\nimport qualified Data.HashMap.Strict.InsOrd as HashMap\nimport qualified Data.Sequence as Seq\nimport qualified Grace.Compat as Compat\nimport qualified Grace.Syntax as Syntax\n\n{-| This is basically `Syntax.NameBinding` but with only the names and not\n the values or locations\n-}\ndata Names location\n = Name location Text (Maybe (Value location))\n | FieldNames location [(location, Text, Maybe (Value location))]\n deriving stock (Eq, Functor, Show)\n\n{-| This type represents a fully evaluated expression with no reducible\n sub-expressions\n\n There are two benefits to using a type separate from the surface syntax for\n this purpose:\n\n * To avoid wastefully reducing the same sub-expression multiple times\n\n * To use a more efficient representation for reduction purposes\n-}\ndata Value location\n = Lambda location [(Text, Value location)] (Names location) (Syntax location Void)\n -- The `Lambda` constructor captures the environment at the time it is\n -- evaluated, so that evaluation can be lazily deferred until the function\n -- input is known. This is essentially the key optimization that powers\n -- the fast normalization-by-evaluation algorithm.\n | Application location (Value location) (Value location)\n | List location (Seq (Value location))\n | Record location (InsOrdHashMap Text (location, Value location))\n | Alternative location Text (Value location)\n | Fold location (Value location)\n | Text location Text\n | Builtin location Builtin\n | Scalar location Scalar\n deriving stock (Eq, Generic, Show)\n\nlocation :: Value location -> location\nlocation (Lambda l _ _ _) = l\nlocation (Application l _ _) = l\nlocation (List l _) = l\nlocation (Record l _) = l\nlocation (Alternative l _ _) = l\nlocation (Fold l _) = l\nlocation (Text l _) = l\nlocation (Builtin l _) = l\nlocation (Scalar l _) = l\n\ninstance Functor Value where\n fmap f (Lambda location₀ environment names body) =\n Lambda (f location₀) (fmap (fmap (fmap f)) environment) (fmap f names) (first f body)\n fmap f (Application location₀ function argument) =\n Application (f location₀) (fmap f function) (fmap f argument)\n fmap f (List location₀ elements) =\n List (f location₀) (fmap (fmap f) elements)\n fmap f (Record location₀ fieldValues) =\n Record (f location₀) (fmap adapt fieldValues)\n where\n adapt (location₁, value) = (f location₁, fmap f value)\n fmap f (Alternative location₀ text argument) =\n Alternative (f location₀) text (fmap f argument)\n fmap f (Fold location₀ handlers) =\n Fold (f location₀) (fmap f handlers)\n fmap f (Text location₀ text) =\n Text (f location₀) text\n fmap f (Builtin location₀ builtin) =\n Builtin (f location₀) builtin\n fmap f (Scalar location₀ scalar) =\n Scalar (f location₀) scalar\n\ninstance Plated (Value location₀) where\n plate onValue value = case value of\n Lambda location₀ environment names body -> do\n pure (Lambda location₀ environment names body)\n Application location₀ function argument -> do\n newFunction <- onValue function\n newArgument <- onValue argument\n return (Application location₀ newFunction newArgument)\n List location₀ elements -> do\n newElements <- traverse onValue elements\n return (List location₀ newElements)\n Record location₀ fieldValues -> do\n let onElement (location₁, value₁) = do\n newValue <- onValue value₁\n\n return (location₁, newValue)\n\n newFieldValues <- traverse onElement fieldValues\n\n return (Record location₀ newFieldValues)\n Alternative location₀ text argument -> do\n newArgument <- onValue argument\n pure (Alternative location₀ text newArgument)\n Fold location₀ handlers -> do\n newHandlers <- onValue handlers\n return (Fold location₀ newHandlers)\n Text location₀ text -> do\n pure (Text location₀ text)\n Builtin location₀ builtin -> do\n pure (Builtin location₀ builtin)\n Scalar location₀ scalar -> do\n pure (Scalar location₀ scalar)\n\ninstance FromJSON (Value ()) where\n parseJSON value = pure (fromJSON value)\n\ninstance Pretty (Value s) where\n pretty value = pretty (quote value)\n\n-- | Convert a `Value` back into the surface `Syntax`\nquote :: Value location -> Syntax location Void\nquote value = case value of\n Lambda location₀ env names_ body₀ ->\n foldl snoc newLambda env\n where\n binding = case names_ of\n Name nameLocation name assignment ->\n Syntax.PlainBinding\n { plain = Syntax.NameBinding\n { nameLocation\n , name\n , annotation = Nothing\n , assignment = fmap quote assignment\n }\n }\n\n FieldNames fieldNamesLocation fieldNames ->\n Syntax.RecordBinding\n { fieldNamesLocation\n , fieldNames = do\n (nameLocation, name, assignment) <- fieldNames\n return Syntax.NameBinding\n { nameLocation\n , name\n , annotation = Nothing\n , assignment = fmap quote assignment\n }\n }\n\n newLambda = Syntax.Lambda\n { location = location₀\n , binding\n , body = body₀\n }\n\n toBinding n v = Syntax.Define\n { assignmentLocation = location₀\n , definition = Syntax.Definition\n { name = n\n , nameLocation = location₀\n , bindings = []\n , annotation = Nothing\n , assignment = quote v\n }\n }\n\n snoc e@Syntax.Let{ assignments = a :| as, body = body₁ } (n, v)\n | Syntax.usedIn n e = Syntax.Let\n { location = location₀\n , assignments = toBinding n v :| (a : as)\n , body = body₁\n }\n | otherwise = e\n snoc e (n, v)\n | Syntax.usedIn n e = Syntax.Let\n { location = location₀\n , assignments = toBinding n v :| []\n , body = e\n }\n | otherwise = e\n\n Application location₀ function argument ->\n Syntax.Application\n { location = location₀\n , function = quote function\n , argument = quote argument\n }\n\n List location₀ elements ->\n Syntax.List{ location = location₀, elements = fmap quote elements }\n\n Record location₀ fieldValues ->\n Syntax.Record\n { location = location₀\n , fieldValues = map adapt (HashMap.toList fieldValues)\n }\n where\n adapt (field, (nameLocation, value_)) = Syntax.Definition\n { nameLocation\n , name = field\n , bindings = []\n , annotation = Nothing\n , assignment = quote value_\n }\n\n Alternative location₀ name argument ->\n Syntax.Alternative\n { location = location₀\n , name\n , argument = quote argument\n }\n\n Fold location₀ handlers ->\n Syntax.Fold{ location = location₀, handlers = quote handlers }\n\n Text location₀ text ->\n Syntax.Text{ location = location₀, chunks = Syntax.Chunks text [] }\n\n Scalar location₀ scalar ->\n Syntax.Scalar{ location = location₀, scalar }\n\n Builtin location₀ builtin ->\n Syntax.Builtin{ location = location₀, builtin }\n\n-- | Convert a JSON `Aeson.Value` to a `Value`\nfromJSON :: Aeson.Value -> Value ()\nfromJSON (Aeson.Object object) =\n Record () (Compat.fromAesonMap (fmap adapt object))\n where\n adapt json = ((), fromJSON json)\nfromJSON (Aeson.Array array) =\n List () (Seq.fromList (toList (fmap fromJSON array)))\nfromJSON (Aeson.String text) =\n Text () text\nfromJSON (Aeson.Number scientific) =\n Scalar () (Syntax.Real scientific)\nfromJSON (Aeson.Bool bool) = do\n Scalar () (Syntax.Bool bool)\nfromJSON Aeson.Null =\n Scalar () Syntax.Null\n\n-- | Convert a `Value` to the equivalent JSON `Aeson.Value`\ntoJSON :: Value location -> Maybe Aeson.Value\ntoJSON (Application _ (Builtin _ Syntax.Some) value) = do\n toJSON value\ntoJSON (List _ elements) = do\n newElements <- traverse toJSON elements\n\n return (Aeson.toJSON newElements)\ntoJSON (Record _ fieldValues) = do\n let adapt (_, value) = do\n toJSON value\n\n newFieldValues <- traverse adapt fieldValues\n\n return (Aeson.toJSON (Compat.toAesonMap newFieldValues))\ntoJSON (Text _ text) = do\n return (Aeson.toJSON text)\ntoJSON (Scalar _ scalar) = do\n return (Aeson.toJSON scalar)\ntoJSON _ = do\n empty\n\n-- | @Traversal'@ from a `Value` to a \nsyntax :: Traversal' (Value location) (Syntax location Void)\nsyntax = _As @\"Lambda\" . the @4\n\n-- | Complete all `Type` annotations in a `Value` using the provided\n-- `Context`\ncomplete :: Context location -> Value location -> Value location\ncomplete context = Lens.transform (Lens.over syntax (Syntax.complete context))\n\n-- | Determines whether the `Value` has an effect\neffects :: Getting Any (Value location) ()\neffects = Lens.cosmos . syntax . Syntax.effects\n" }, { "path": "src/Grace.hs", "content": "{-| This module contains the top-level `main` function that implements the\n command-line API\n-}\nmodule Grace\n ( -- * Main\n main\n ) where\n\nimport Control.Applicative (many, (<|>))\nimport Control.Exception.Safe (Exception(..), SomeException)\nimport Data.Foldable (traverse_)\nimport Data.Void (Void)\nimport Grace.Input (Input(..), Mode(..))\nimport Grace.Location (Location(..))\nimport Grace.Monad (Status(..))\nimport Grace.Syntax (Builtin(..), Syntax(..))\nimport Grace.Type (Type(..))\nimport Options.Applicative (Parser, ParserInfo)\nimport Prettyprinter (Doc)\nimport Prettyprinter.Render.Terminal (AnsiStyle)\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Data.Text as Text\nimport qualified Data.Text.IO as Text.IO\nimport qualified GHC.IO.Encoding\nimport qualified Grace.Infer as Infer\nimport qualified Grace.Interpret as Interpret\nimport qualified Grace.Monad as Grace\nimport qualified Grace.Monotype as Monotype\nimport qualified Grace.Normalize as Normalize\nimport qualified Grace.Parser as Parser\nimport qualified Grace.Pretty\nimport qualified Grace.REPL as REPL\nimport qualified Grace.Syntax as Syntax\nimport qualified Grace.Type as Type\nimport qualified Grace.Value as Value\nimport qualified Grace.Width as Width\nimport qualified Options.Applicative as Options\nimport qualified Prettyprinter as Pretty\nimport qualified System.Console.ANSI as ANSI\nimport qualified System.Exit as Exit\nimport qualified System.IO as IO\n\ndata Highlight\n = Color\n -- ^ Force the use of ANSI color escape sequences to highlight source code\n | Plain\n -- ^ Don't highlight source code\n | Auto\n -- ^ Auto-detect whether to highlight source code based on whether or not\n -- @stdout@ is a terminal\n\ndata Options\n = Interpret\n { annotate :: Bool\n , highlight :: Highlight\n , file :: FilePath\n }\n | Text { file :: FilePath }\n | Format { highlight :: Highlight, files :: [FilePath] }\n | Builtins { highlight :: Highlight }\n | REPL\n\nparserInfo :: ParserInfo Options\nparserInfo =\n Options.info (Options.helper <*> parser)\n (Options.progDesc \"Command-line utility for the Grace language\")\n\nparser :: Parser Options\nparser = do\n let interpret = do\n annotate <- Options.switch\n ( Options.long \"annotate\"\n <> Options.help \"Add a type annotation for the inferred type\"\n )\n\n file <- Options.strArgument\n ( Options.help \"File to interpret\"\n <> Options.metavar \"FILE\"\n )\n\n highlight <- parseHighlight\n\n return Interpret{ annotate, file, highlight }\n\n let text = do\n file <- Options.strArgument\n ( Options.help \"File to interpret\"\n <> Options.metavar \"FILE\"\n )\n\n return Grace.Text{ file }\n\n let format = do\n let parseFile =\n Options.strArgument\n ( Options.help \"File to format\"\n <> Options.metavar \"FILE\"\n )\n\n highlight <- parseHighlight\n\n files <- many parseFile\n\n return Format{ highlight, files }\n\n let builtins = do\n highlight <- parseHighlight\n\n return Builtins{ highlight }\n\n let repl = do\n pure REPL{ }\n\n Options.hsubparser\n ( Options.command \"interpret\"\n (Options.info interpret\n (Options.progDesc \"Interpret a Grace file\")\n )\n\n <> Options.command \"text\"\n (Options.info text\n (Options.progDesc \"Render a Grace text literal\")\n )\n\n <> Options.command \"format\"\n (Options.info format\n (Options.progDesc \"Format Grace code\")\n )\n\n <> Options.command \"builtins\"\n (Options.info builtins\n (Options.progDesc \"List all built-in functions and their types\")\n )\n <> Options.command \"repl\"\n (Options.info repl\n (Options.progDesc \"Enter a REPL for Grace\")\n )\n )\n where\n parseHighlight =\n Options.flag' Color\n ( Options.long \"color\"\n <> Options.help \"Enable syntax highlighting\"\n )\n <|> Options.flag' Plain\n ( Options.long \"plain\"\n <> Options.help \"Disable syntax highlighting\"\n )\n <|> pure Auto\n\ndetectColor :: Highlight -> IO Bool\ndetectColor Color = do return True\ndetectColor Plain = do return False\ndetectColor Auto = do ANSI.hSupportsANSI IO.stdout\n\ngetRender :: Highlight -> IO (Doc AnsiStyle -> IO ())\ngetRender highlight = do\n color <- detectColor highlight\n\n width <- Width.getWidth\n\n return (Grace.Pretty.renderIO color width IO.stdout)\n\nthrows :: Exception e => Either e a -> IO a\nthrows (Left e) = do\n Text.IO.hPutStrLn IO.stderr (Text.pack (displayException e))\n Exit.exitFailure\nthrows (Right result) = do\n return result\n\n-- | Command-line entrypoint\nmain :: IO ()\nmain = Exception.handle handler do\n GHC.IO.Encoding.setLocaleEncoding IO.utf8\n\n options <- Options.execParser parserInfo\n\n case options of\n Interpret{ annotate, highlight, file } -> do\n input <- case file of\n \"-\" -> do\n Code \"(input)\" <$> Text.IO.getContents\n _ -> do\n return (Path file AsCode)\n\n (inferred, value) <- Interpret.interpret input\n\n let syntax = Normalize.strip (Value.quote value)\n\n let annotatedExpression\n | annotate = Annotation\n { annotated = syntax\n , annotation = inferred\n , location = Syntax.location syntax\n }\n | otherwise =\n syntax\n\n render <- getRender highlight\n\n render (Grace.Pretty.pretty annotatedExpression <> Pretty.hardline)\n\n Grace.Text{ file } -> do\n input <- case file of\n \"-\" -> do\n Code \"(input)\" <$> Text.IO.getContents\n _ -> do\n return (Path file AsCode)\n\n let location = Location\n { name = \"(input)\"\n , code = \"… : Text\"\n , offset = 4\n }\n\n let expected = Type.Scalar{ scalar = Monotype.Text, location }\n\n let initialStatus = Status{ count = 0, context = [] }\n\n (_, value) <- Grace.evalGrace input initialStatus (Interpret.interpretWith [] (Just expected))\n\n case value of\n Value.Text _ text -> Text.IO.putStr text\n _ -> do\n Text.IO.hPutStrLn IO.stderr\n \"Internal error: Not a plain Text literal\\n\\\n \\\\n\\\n \\The input expression did not evaluate to a Text literal, even though it had the\\n\\\n \\correct type\"\n Exit.exitFailure\n\n Format{ highlight, files } -> do\n case files of\n [ \"-\" ] -> do\n text <- Text.IO.getContents\n\n syntax <- throws (Parser.parse \"(input)\" text)\n\n render <- getRender highlight\n\n render (Grace.Pretty.pretty syntax <> Pretty.hardline)\n _ -> do\n let formatFile file = do\n text <- Text.IO.readFile file\n\n syntax <- throws (Parser.parse file text)\n\n IO.withFile file IO.WriteMode \\handle -> do\n Grace.Pretty.renderIO\n False\n Width.defaultWidth\n handle\n (Grace.Pretty.pretty syntax <> Pretty.hardline)\n\n traverse_ formatFile files\n\n Builtins{ highlight } -> do\n let displayBuiltin :: Builtin -> IO ()\n displayBuiltin builtin = do\n let code =\n Grace.Pretty.renderStrict\n False\n Width.defaultWidth\n (Grace.Pretty.pretty builtin)\n\n let expression = Syntax.Builtin\n { location = Location\n { name = \"(input)\", code, offset = 0 }\n , builtin\n }\n\n let input = Code \"(input)\" code\n\n (type_, _) <- Infer.typeOf input expression\n\n let annotated :: Syntax Location Void\n annotated = Annotation\n { annotated = expression\n , annotation = type_\n , location = Syntax.location expression\n }\n\n render <- getRender highlight\n\n render (Grace.Pretty.pretty annotated <> Pretty.hardline)\n\n let builtins = [ minBound .. maxBound ]\n\n case builtins of\n [] -> do\n return ()\n\n b0 : bs -> do\n displayBuiltin b0\n\n traverse_ (\\b -> Text.IO.putStrLn \"\" >> displayBuiltin b) bs\n\n REPL{ } -> do\n REPL.repl\n where\n handler :: SomeException -> IO a\n handler e = do\n Text.IO.hPutStrLn IO.stderr (Text.pack (displayException e))\n Exit.exitFailure\n" }, { "path": "tasty/Main.hs", "content": "{-# LANGUAGE BlockArguments #-}\n{-# LANGUAGE DeriveAnyClass #-}\n{-# LANGUAGE DeriveGeneric #-}\n{-# LANGUAGE DerivingStrategies #-}\n{-# LANGUAGE DuplicateRecordFields #-}\n{-# LANGUAGE EmptyDataDecls #-}\n{-# LANGUAGE NamedFieldPuns #-}\n{-# LANGUAGE OverloadedStrings #-}\n\nmodule Main where\n\nimport Control.Exception.Safe (Exception, SomeException)\nimport Data.Aeson (Value)\nimport Data.Int (Int8, Int16, Int32, Int64)\nimport Data.Scientific (Scientific)\nimport Data.Sequence (Seq)\nimport Data.Text (Text)\nimport Data.Word (Word8, Word16, Word32, Word64)\nimport GHC.Generics (Generic)\nimport Grace.Decode (FromGrace, Key, ToGraceType)\nimport Grace.Input (Input(..), Mode(..))\nimport Grace.Location (Location(..))\nimport Grace.Pretty (Pretty(..))\nimport Grace.Type (Type(..))\nimport Numeric.Natural (Natural)\nimport System.FilePath (())\nimport Test.Tasty (TestTree)\n\nimport qualified Control.Exception.Safe as Exception\nimport qualified Data.Aeson as Aeson\nimport qualified Data.Sequence as Seq\nimport qualified Data.Text as Text\nimport qualified Data.Text.Lazy as Text.Lazy\nimport qualified Data.Vector as Vector\nimport qualified Grace.Decode as Decode\nimport qualified Grace.Interpret as Interpret\nimport qualified Grace.Monotype as Monotype\nimport qualified Grace.Pretty\nimport qualified Grace.Syntax as Syntax\nimport qualified Grace.Type as Type\nimport qualified Grace.Value as Value\nimport qualified Grace.Width as Width\nimport qualified Prettyprinter as Pretty\nimport qualified System.Directory as Directory\nimport qualified System.Environment as Environment\nimport qualified System.FilePath as FilePath\nimport qualified System.Timeout as Timeout\nimport qualified Test.Tasty as Tasty\nimport qualified Test.Tasty.HUnit as Tasty.HUnit\nimport qualified Test.Tasty.Silver as Silver\n\npretty_ :: Pretty a => a -> Text\npretty_ x =\n Grace.Pretty.renderStrict False Width.defaultWidth\n (pretty x <> Pretty.hardline)\n\ninterpret :: Input -> IO (Either SomeException (Type Location, Value.Value ()))\ninterpret input =\n fmap (fmap (fmap (fmap (\\_ -> ())))) (Exception.try (Interpret.interpret input))\n\nthrows :: Exception e => IO (Either e a) -> IO a\nthrows io = do\n result <- io\n\n case result of\n Left e -> Exception.throw e\n Right a -> return a\n\nfileToTestTree :: FilePath -> IO TestTree\nfileToTestTree prefix = do\n let input = prefix <> \"-input.ffg\"\n let expectedTypeFile = prefix <> \"-type.ffg\"\n let expectedOutputFile = prefix <> \"-output.ffg\"\n let expectedStderrFile = prefix <> \"-stderr.txt\"\n\n let name = FilePath.takeBaseName input\n\n result <- Timeout.timeout 10000000 (interpret (Path input AsCode))\n\n case result of\n Nothing -> do\n return\n (Tasty.testGroup name\n [ Silver.goldenVsAction\n (name <> \" - timeout\")\n expectedStderrFile\n (return \"timeout\")\n id\n ]\n )\n Just (Left e) -> do\n return\n (Tasty.testGroup name\n [ Silver.goldenVsAction\n (name <> \" - error\")\n expectedStderrFile\n (return (Text.pack (Exception.displayException e)))\n id\n ]\n )\n\n Just (Right (inferred, value)) -> do\n let generateTypeFile = return (pretty_ inferred)\n\n let generateOutputFile = return (pretty_ value)\n\n return\n (Tasty.testGroup name\n [ Silver.goldenVsAction\n (name <> \" - type\")\n expectedTypeFile\n generateTypeFile\n id\n , Silver.goldenVsAction\n (name <> \" - output\")\n expectedOutputFile\n generateOutputFile\n id\n ]\n )\n\ninputFileToPrefix :: FilePath -> Maybe FilePath\ninputFileToPrefix inputFile =\n fmap Text.unpack (Text.stripSuffix \"-input.ffg\" (Text.pack inputFile))\n\ndirectoryToTestTree :: FilePath -> IO TestTree\ndirectoryToTestTree directory = do\n let name = FilePath.takeBaseName directory\n\n children <- Directory.listDirectory directory\n\n let process child = do\n let childPath = directory child\n\n isDirectory <- Directory.doesDirectoryExist childPath\n\n if isDirectory\n then do\n testTree <- directoryToTestTree childPath\n\n return [ testTree ]\n\n else do\n case inputFileToPrefix childPath of\n Just prefix -> do\n testTree <- fileToTestTree prefix\n\n return [ testTree ]\n\n Nothing -> do\n return [ ]\n\n testTreess <- traverse process children\n\n return (Tasty.testGroup name (concat testTreess))\n\ndata T0\n = C0\n | C1{ foo :: Text }\n | C2{ bar :: Natural, baz :: Maybe Bool }\n | C3{ a :: Maybe Int, b :: Maybe Int, c :: Maybe Int }\n | C4{ a :: Maybe Int, b :: Maybe Int, c :: Maybe Int, d :: Maybe Int }\n deriving stock (Eq, Generic, Show)\n deriving anyclass (FromGrace, ToGraceType)\n\ndata T1\n deriving stock (Generic)\n deriving anyclass (FromGrace, ToGraceType)\n\nmain :: IO ()\nmain = do\n autogeneratedTestTree <- directoryToTestTree \"tasty/data\"\n\n let manualTestTree =\n Tasty.testGroup \"Manual tests\"\n [ interpretCode\n , interpretCodeWithEnvURI\n , interpretCodeWithFileURI\n , interpretCodeWithImport\n , decodeWithTypeError\n , decodeWithRangeError\n , loadSuccessfully\n , load \"()\" \"{ }\" ()\n , load \"(Bool, Bool)\" \"{ \\\"0\\\": false, \\\"1\\\": true }\" (False, True)\n , load \"(Bool, Bool)\" \"{ \\\"0\\\": false, \\\"1\\\": true }\" (False, True)\n , load \"Either Int Bool\" \"Left 2\" (Left 2 :: Either Int Bool)\n , load \"Either Int Bool\" \"Right true\" (Right True :: Either Int Bool)\n , load \"Either Int Bool\" \"Right true\" (Right True :: Either Int Bool)\n , load \"Int\" \"-2\" (-2 :: Int)\n , load \"Int8\" \"-2\" (-2 :: Int8)\n , load \"Int16\" \"-2\" (-2 :: Int16)\n , load \"Int32\" \"-2\" (-2 :: Int32)\n , load \"Int64\" \"-2\" (-2 :: Int64)\n , load \"Word\" \"2\" (2 :: Word)\n , load \"Word8\" \"2\" (2 :: Word8)\n , load \"Word16\" \"2\" (2 :: Word16)\n , load \"Word32\" \"2\" (2 :: Word32)\n , load \"Word64\" \"2\" (2 :: Word64)\n , load \"Natural\" \"2\" (2 :: Natural)\n , load \"Integer\" \"2\" (2 :: Integer)\n , load \"Integer\" \"+2\" (2 :: Integer)\n , load \"Scientific\" \"2\" (2.0 :: Scientific)\n , load \"Scientific\" \"+2\" (2.0 :: Scientific)\n , load \"Scientific\" \"2.5\" (2.5 :: Scientific)\n , load \"Double\" \"2.5\" (2.5 :: Double)\n , load \"Float\" \"2.5\" (2.5 :: Float)\n , load \"Text\" \"\\\"abc\\\"\" (\"abc\" :: Text)\n , load \"Lazy Text\" \"\\\"abc\\\"\" (\"abc\" :: Text.Lazy.Text)\n , load \"String\" \"\\\"abc\\\"\" (\"abc\" :: String)\n , load \"Key\" \"\\\"abc\\\"\" (\"abc\" :: Key)\n , load \"Value\" \"null\" Aeson.Null\n , load \"Seq Bool\" \"[ false, true ]\" (Seq.fromList [ False, True ])\n , load \"Vector Bool\" \"[ false, true ]\" (Vector.fromList [ False, True ])\n , load \"T0\" \"C0{ }\" C0{ }\n , load \"T0\" \"C1{ foo: \\\"abc\\\" }\" C1{ foo = \"abc\" }\n , load \"T0\" \"C2{ bar: 2 }\" C2{ bar = 2, baz = Nothing }\n , load \"T0\" \"C2{ bar: 3, baz: true }\" C2{ bar = 3, baz = Just True }\n , load \"T0\" \"C3{ }\" C3{ a = Nothing, b = Nothing, c = Nothing }\n , load \"T0\" \"C4{ }\" C4{ a = Nothing, b = Nothing, c = Nothing, d = Nothing }\n ]\n\n let tests = Tasty.testGroup \"Tests\" [ autogeneratedTestTree, manualTestTree ]\n\n Tasty.defaultMain tests\n\ninterpretCode :: TestTree\ninterpretCode = Tasty.HUnit.testCase \"interpret code\" do\n actualValue <- throws (interpret (Code \"(input)\" \"2 + 2\"))\n\n let expectedValue =\n (Type.Scalar{ location, scalar = Monotype.Natural }, Value.Scalar () (Syntax.Natural 4))\n where\n location = Location{ name = \"(input)\", code = \"2 + 2\", offset = 2 }\n\n Tasty.HUnit.assertEqual \"\" expectedValue actualValue\n\ninterpretCodeWithImport :: TestTree\ninterpretCodeWithImport = Tasty.HUnit.testCase \"interpret code with import from file\" do\n actualValue <- throws (interpret (Code \"(input)\" \"./tasty/data/unit/plus-input.ffg\"))\n\n let expectedValue =\n (Type.Scalar{ location, scalar = Monotype.Natural }, Value.Scalar () (Syntax.Natural 5))\n where\n location = Location{ name = \"./tasty/data/unit/plus-input.ffg\", code = \"2 + 3\\n\", offset = 2 }\n\n Tasty.HUnit.assertEqual \"\" expectedValue actualValue\n\ninterpretCodeWithEnvURI :: TestTree\ninterpretCodeWithEnvURI = Tasty.HUnit.testCase \"interpret code with env: import\" do\n let key = \"GRACE_TEST_VAR\"\n\n let name = \"env:\" <> key\n\n let open = do\n m <- Environment.lookupEnv key\n\n Environment.setEnv key \"true\"\n\n return m\n\n let close Nothing = Environment.unsetEnv key\n close (Just v ) = Environment.setEnv key v\n\n actualValue <- Exception.bracket open close \\_ -> do\n throws (interpret (Code \"(input)\" (Text.pack name)))\n\n let expectedValue =\n (Type.Scalar{ location, scalar = Monotype.Bool }, Value.Scalar () (Syntax.Bool True))\n where\n location = Location{ name, code = \"true\", offset = 0 }\n\n Tasty.HUnit.assertEqual \"\" expectedValue actualValue\n\ninterpretCodeWithFileURI :: TestTree\ninterpretCodeWithFileURI = Tasty.HUnit.testCase \"interpret code with file:// import\" do\n absolute <- Directory.makeAbsolute \"./tasty/data/true.ffg\"\n\n let uri = \"file://\" <> absolute\n\n actualValue <- throws (interpret (Code \"(input)\" (Text.pack uri)))\n\n let expectedValue =\n (Type.Scalar{ location, scalar = Monotype.Bool }, Value.Scalar () (Syntax.Bool True))\n where\n location = Location{ name = absolute, code = \"true\\n\", offset = 0 }\n\n Tasty.HUnit.assertEqual \"\" expectedValue actualValue\n\nloadSuccessfully :: TestTree\nloadSuccessfully = Tasty.HUnit.testCase \"load code\" do\n let actual :: Either DecodingError Natural\n actual = decode (Value.Scalar () (Syntax.Natural 2))\n\n Tasty.HUnit.assertEqual \"\" (Right 2) actual\n\nload :: (Eq a, FromGrace a, Show a) => String -> Text -> a -> TestTree\nload name code expected = Tasty.HUnit.testCase (\"load \" <> name) do\n actual <- Interpret.load (Code \"(input)\" code)\n\n Tasty.HUnit.assertEqual \"\" expected actual\n\ndata DecodingError = TypeError | RangeError deriving stock (Eq, Show)\n\ndecode :: FromGrace a => Value.Value () -> Either DecodingError a\ndecode value = case Decode.decode (fmap (\\_ -> Unknown) value) of\n Left Decode.TypeError{ } -> Left TypeError\n Left Decode.RangeError{ } -> Left RangeError\n Right a -> Right a\n\ndecodeWithTypeError :: TestTree\ndecodeWithTypeError = Tasty.HUnit.testCase \"load code with type error\" do\n let actual₀ :: Either DecodingError Bool\n actual₀ = decode (Value.Scalar () (Syntax.Natural 2))\n\n Tasty.HUnit.assertEqual \"\" (Left TypeError) actual₀\n\n let actual₁ :: Either DecodingError T0\n actual₁ = decode (Value.Alternative () \"C1\" (Value.Record () mempty))\n\n Tasty.HUnit.assertEqual \"\" (Left TypeError) actual₁\n\n let actual₂ :: Either DecodingError Natural\n actual₂ = decode (Value.Scalar () (Syntax.Bool False))\n\n Tasty.HUnit.assertEqual \"\" (Left TypeError) actual₂\n\n let actual₃ :: Either DecodingError Integer\n actual₃ = decode (Value.Scalar () (Syntax.Bool False))\n\n Tasty.HUnit.assertEqual \"\" (Left TypeError) actual₃\n\n let actual₄ :: Either DecodingError Text\n actual₄ = decode (Value.Scalar () (Syntax.Bool False))\n\n Tasty.HUnit.assertEqual \"\" (Left TypeError) actual₄\n\n let actual₅ :: Either DecodingError Key\n actual₅ = decode (Value.Scalar () (Syntax.Bool False))\n\n Tasty.HUnit.assertEqual \"\" (Left TypeError) actual₅\n\n let actual₆ :: Either DecodingError Value\n actual₆ = decode (Value.Lambda () [] (Value.Name () \"x\" Nothing) Syntax.Variable{ location = (), name = \"x\" })\n\n Tasty.HUnit.assertEqual \"\" (Left TypeError) actual₆\n\n let actual₇ :: Either DecodingError (Seq Bool)\n actual₇ = decode (Value.Scalar () (Syntax.Bool False))\n\n Tasty.HUnit.assertEqual \"\" (Left TypeError) actual₇\n\n let actual₈ :: Either DecodingError Scientific\n actual₈ = decode (Value.Scalar () (Syntax.Bool False))\n\n Tasty.HUnit.assertEqual \"\" (Left TypeError) actual₈\n\ndecodeWithRangeError :: TestTree\ndecodeWithRangeError = Tasty.HUnit.testCase \"load code with range error\" do\n let actual₀ :: Either DecodingError Word8\n actual₀ = decode (Value.Scalar () (Syntax.Natural 256))\n\n Tasty.HUnit.assertEqual \"\" (Left RangeError) actual₀\n" }, { "path": "tasty/data/complex/abstract-fold-input.ffg", "content": "# A `fold` with an abstract record of handlers will default to treating the\n# record as `List` handlers, meaning that the inferred type of this expression\n# will be:\n#\n# forall (a : Type) (b : Type)\n# . { nil: a, cons: b -> a -> a } -> List b -> a\n#\n# There are other possible choices, but we default to assuming `List` handlers\n# since the `fold` keyword historically is most closely associated with lists,\n# even though all supported Grace `fold`s are folds in the more general sense of\n# the term:\n#\n# https://www.haskellforall.com/2021/02/folds-are-constructor-substitution.html\n\\x -> fold x\n" }, { "path": "tasty/data/complex/abstract-fold-output.ffg", "content": "\\x -> fold x\n" }, { "path": "tasty/data/complex/abstract-fold-type.ffg", "content": "forall (a : Type) (b : Type) . { nil: a, cons: b -> a -> a } -> List b -> a\n" }, { "path": "tasty/data/complex/alternative-input.ffg", "content": "# The purpose of this test is to verify that alternatives bind to their\n# arguments more tightly than function application. This should be parsed as:\n#\n# \\f -> f (Point{x: 1, y: 2 })\n#\n# … and not:\n#\n# (\\f -> f Point){x: 1, y: 2 }\n#\n# This precedence is intentional to reduce the number of parentheses required\n# when functions have union-valued arguments. One particularly notable example\n# of this is the `http` builtin, where you can write:\n#\n# http GET{ url: \"https://httpbin.org\" }\n#\n# … without parentheses, thanks to the tighter precedence of alternative\n# application.\n\\f -> f Point{ x: 1, y: 2 }\n" }, { "path": "tasty/data/complex/alternative-output.ffg", "content": "\\f -> f Point{ \"x\": 1, \"y\": 2 }\n" }, { "path": "tasty/data/complex/alternative-type.ffg", "content": "forall (a : Type) .\nforall (b : Alternatives) .\n (< Point: { x: Natural, y: Natural } | b > -> a) -> a\n" }, { "path": "tasty/data/complex/arithmetic-input.ffg", "content": "# This test exercises all of the various arithmetic permutations to make sure\n# that they work without type annotations and produce a result of the desired\n# output type\n{ add0: 2 + 2\n, add1: 2 + -3\n, add2: 2 + 0.1\n, add3: \"A\" + \"B\"\n, add4: [ true ] + [ false ]\n\n, multiply0: 2 * 2\n, multiply1: 2 * -3\n, multiply2: 2 * 0.1\n\n, subtract0: 2 - 2\n, subtract1: 2 - -3\n, subtract2: 2 - 0.1\n\n, divide0: 2 / 2\n, divide1: 2 / -3\n, divide2: 2 / 0.1\n\n, modulus0: 2 % 2\n, modulus1: -3 % 2\n, modulus2: 0.1 % 2\n\n, lessThan0: 2 < 2\n, lessThan1: 2 < -3\n, lessThan2: 2 < 0.1\n\n, lessThanOrEqual0: 2 <= 2\n, lessThanOrEqual1: 2 <= -3\n, lessThanOrEqual2: 2 <= 0.1\n\n, greaterThan0: 2 > 2\n, greaterThan1: 2 > -3\n, greaterThan2: 2 > 0.1\n\n, greaterThanOrEqual0: 2 >= 2\n, greaterThanOrEqual1: 2 >= -3\n, greaterThanOrEqual2: 2 >= 0.1\n}\n" }, { "path": "tasty/data/complex/arithmetic-output.ffg", "content": "{ \"add0\":\n 4\n, \"add1\":\n -1\n, \"add2\":\n 2.1\n, \"add3\":\n \"AB\"\n, \"add4\":\n [ true, false ]\n, \"multiply0\":\n 4\n, \"multiply1\":\n -6\n, \"multiply2\":\n 0.2\n, \"subtract0\":\n 0\n, \"subtract1\":\n 5\n, \"subtract2\":\n 1.9\n, \"divide0\":\n 1.0\n, \"divide1\":\n -0.6666666666666666\n, \"divide2\":\n 20.0\n, \"modulus0\":\n { \"quotient\": 1, \"remainder\": 0 }\n, \"modulus1\":\n { \"quotient\": -2, \"remainder\": 1 }\n, \"modulus2\":\n { \"quotient\": 0, \"remainder\": 0.1 }\n, \"lessThan0\":\n false\n, \"lessThan1\":\n false\n, \"lessThan2\":\n false\n, \"lessThanOrEqual0\":\n true\n, \"lessThanOrEqual1\":\n false\n, \"lessThanOrEqual2\":\n false\n, \"greaterThan0\":\n false\n, \"greaterThan1\":\n true\n, \"greaterThan2\":\n true\n, \"greaterThanOrEqual0\":\n true\n, \"greaterThanOrEqual1\":\n true\n, \"greaterThanOrEqual2\":\n true\n}\n" }, { "path": "tasty/data/complex/arithmetic-type.ffg", "content": "{ add0:\n Natural\n, add1:\n Integer\n, add2:\n Real\n, add3:\n Text\n, add4:\n List Bool\n, multiply0:\n Natural\n, multiply1:\n Integer\n, multiply2:\n Real\n, subtract0:\n Integer\n, subtract1:\n Integer\n, subtract2:\n Real\n, divide0:\n Real\n, divide1:\n Real\n, divide2:\n Real\n, modulus0:\n { quotient: Natural, remainder: Natural }\n, modulus1:\n { quotient: Integer, remainder: Natural }\n, modulus2:\n { quotient: Integer, remainder: Real }\n, lessThan0:\n Bool\n, lessThan1:\n Bool\n, lessThan2:\n Bool\n, lessThanOrEqual0:\n Bool\n, lessThanOrEqual1:\n Bool\n, lessThanOrEqual2:\n Bool\n, greaterThan0:\n Bool\n, greaterThan1:\n Bool\n, greaterThan2:\n Bool\n, greaterThanOrEqual0:\n Bool\n, greaterThanOrEqual1:\n Bool\n, greaterThanOrEqual2:\n Bool\n}\n" }, { "path": "tasty/data/complex/chain-identity-input.ffg", "content": "# This test verifies that the type-checker doesn't blow up even when\n# instantiating `id` to a very high-order type\nlet id : forall (a : Type) . a -> a = \\x -> x\n\nin id id id id id id id id id id id id id id id id id id id id id id id true\n" }, { "path": "tasty/data/complex/chain-identity-output.ffg", "content": "true\n" }, { "path": "tasty/data/complex/chain-identity-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/complex/check-function-input.ffg", "content": "fold { true: 0, false: 1 } : Bool -> Integer\n" }, { "path": "tasty/data/complex/check-function-output.ffg", "content": "\\a -> fold { \"true\": 0, \"false\": 1 } a : Integer\n" }, { "path": "tasty/data/complex/check-function-type.ffg", "content": "Bool -> Integer\n" }, { "path": "tasty/data/complex/church-encode-list-input.ffg", "content": "# This tests that Boehm-Berarducci-encoding a list works correctly\nlet nil : forall (a : Type)\n . forall (list : Type)\n . (a -> list -> list) -> list -> list\n = \\cons -> \\nil -> nil\n\nlet cons\n : forall (a : Type)\n . a\n -> (forall (list : Type) . (a -> list -> list) -> list -> list)\n -> (forall (list : Type) . (a -> list -> list) -> list -> list)\n = \\x -> \\list -> \\cons -> \\nil -> cons x (list cons nil)\n\nlet and : (forall (list : Type) . (Bool -> list -> list) -> list -> list)\n -> Bool\n = \\list -> list (\\x -> \\y -> x && y) true\n\nin and (cons true (cons false (cons true nil)))\n" }, { "path": "tasty/data/complex/church-encode-list-output.ffg", "content": "false\n" }, { "path": "tasty/data/complex/church-encode-list-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/complex/default-arguments-input.ffg", "content": "# This test verifies that defaults are correctly selected when the argument is\n# missing, either because it is set to `null` or (if it is a record field)\n# omitted from the record.\nlet f (x = 1) { y = false } = { x, y }\n\nin [ f null { }\n , f 2 { y: true }\n ]\n" }, { "path": "tasty/data/complex/default-arguments-output.ffg", "content": "[ { \"x\": 1, \"y\": false }, { \"x\": 2, \"y\": true } ]\n" }, { "path": "tasty/data/complex/default-arguments-type.ffg", "content": "List { x: Natural, y: Bool }\n" }, { "path": "tasty/data/complex/destructure-lambda-input.ffg", "content": "# This test exercises all of the supported syntax for destructuring a lambda\n\\{ a, b: Natural, c = 0, d: Natural = 0 } -> a + b + c + d\n" }, { "path": "tasty/data/complex/destructure-lambda-output.ffg", "content": "\\{ a, b, c = 0, d = 0 } -> a + b + c + d\n" }, { "path": "tasty/data/complex/destructure-lambda-type.ffg", "content": "forall (a : Fields) .\n { a: Natural, b: Natural, c: Optional Natural, d: Optional Natural, a } ->\n Natural\n" }, { "path": "tasty/data/complex/destructure-let-argument-input.ffg", "content": "# This test exercises all of the supported syntax for destructuring a function\n# argument defined using `let`\nlet f { a\n , b: Natural # Non-`Optional` fields must be present\n , c = 0 # Defaults are overriden if the field is present\n , d: Natural = 0 # Annotation must match default and field\n , e # Absent fields bound as `null`\n , f = 0 # Absent fields default to default value\n , g: Optional Natural # `Optional` fields may be omitted\n , h: Natural = 0\n } = { a, b, c, d, e, f, g, h }\n\nin f { a: 1, b: 1, c: 1, d: 1 }\n" }, { "path": "tasty/data/complex/destructure-let-argument-output.ffg", "content": "{ \"a\": 1, \"b\": 1, \"c\": 1, \"d\": 1, \"e\": null, \"f\": 0, \"g\": null, \"h\": 0 }\n" }, { "path": "tasty/data/complex/destructure-let-argument-type.ffg", "content": "forall (a : Type) .\n { a:\n Natural\n , b:\n Natural\n , c:\n Natural\n , d:\n Natural\n , e:\n Optional a\n , f:\n Natural\n , g:\n Optional Natural\n , h:\n Natural\n }\n" }, { "path": "tasty/data/complex/destructure-record-input.ffg", "content": "# This test exercises all of the supported cases for destructuring a record,\n# with or without the field present\nlet { a\n , b: Natural # Non-`Optional` fields must be present\n , c = 0 # Defaults are overriden if the field is present\n , d: Natural = 0 # Annotation must match default and field\n , e # Absent fields bound as `null`\n , f = 0 # Absent fields default to default value\n , g: Optional Natural # `Optional` fields may be omitted\n , h: Natural = 0\n } = { a: 1, b: 1, c: 1, d: 1 }\n\nin { a, b, c, d, e, f, g, h }\n" }, { "path": "tasty/data/complex/destructure-record-output.ffg", "content": "{ \"a\": 1, \"b\": 1, \"c\": 1, \"d\": 1, \"e\": null, \"f\": 0, \"g\": null, \"h\": 0 }\n" }, { "path": "tasty/data/complex/destructure-record-type.ffg", "content": "forall (a : Type) .\n { a:\n Natural\n , b:\n Natural\n , c:\n Natural\n , d:\n Natural\n , e:\n Optional a\n , f:\n Natural\n , g:\n Optional Natural\n , h:\n Natural\n }\n" }, { "path": "tasty/data/complex/elaborate-inside-optional-input.ffg", "content": "\\(x : Optional Natural) -> x : Optional (Optional Natural)\n" }, { "path": "tasty/data/complex/elaborate-inside-optional-output.ffg", "content": "\\x -> (if let (x : Natural) of x in some x) : Optional (Optional Natural)\n" }, { "path": "tasty/data/complex/elaborate-inside-optional-type.ffg", "content": "Optional Natural -> Optional (Optional Natural)\n" }, { "path": "tasty/data/complex/equality-input.ffg", "content": " { number: 0, bool: true, list: [ 2, 3, 5 ], text: \"\" }\n== { number: 0, bool: true, list: [ 2, 3, 5 ], text: \"\" }\n" }, { "path": "tasty/data/complex/equality-output.ffg", "content": "true\n" }, { "path": "tasty/data/complex/equality-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/complex/even-input.ffg", "content": "# This tests that folding `Natural` numbers doesn't have a gross inefficiency by\n# implementing the even function as a fold\nlet not (b : Bool) : Bool = if b then false else true\n\nlet even (n : Natural) : Bool = fold { succ: not, zero: true } n\n\nin even 1000000\n" }, { "path": "tasty/data/complex/even-output.ffg", "content": "true\n" }, { "path": "tasty/data/complex/even-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/complex/examples-input.ffg", "content": "# These are all of the examples/tutorial from the trygrace.dev tutorial\n{ hello: ../../../examples/tutorial/hello.ffg\n, html: ../../../examples/tutorial/html.ffg\n, data: ../../../examples/tutorial/data.ffg\n, prompting: ../../../examples/tutorial/prompting.ffg\n, variables: ../../../examples/tutorial/variables.ffg\n, functions: ../../../examples/tutorial/functions.ffg\n, imports: ../../../examples/tutorial/imports.ffg\n, coding: ../../../examples/tutorial/coding.ffg\n, conclusion: ../../../examples/tutorial/conclusion.ffg\n}\n" }, { "path": "tasty/data/complex/examples-output.ffg", "content": "{ \"hello\":\n \"Hello, world!\"\n, \"html\":\n [ true, false, true ]\n, \"data\":\n { \"An example string\":\n \"Mercury\"\n , \"An example string with a type annotation\":\n \"cosmic\"\n , \"A boolean value\":\n true\n , \"Annotated boolean value\":\n false\n , \"A natural number\":\n 42\n , \"An integer\":\n -12\n , \"A real number\":\n 3.14159265359\n , \"A list of natural numbers\":\n [ 1, 1, 2, 3, 5, 8, 13 ]\n , \"Annotated list of natural numbers\":\n [ 1, 1, 2, 3, 5, 8, 13 ]\n , \"Annotated record\":\n { \"x\": 0, \"y\": 0 }\n , \"A list of records (using JSON syntax with quoted field names)\":\n [ { \"isActive\":\n true\n , \"age\":\n 36\n , \"name\":\n \"Dunlap Hubbard\"\n , \"email\":\n \"dunlaphubbard@example.com\"\n , \"phone\":\n \"+1 (555) 543-2508\"\n }\n , { \"isActive\":\n true\n , \"age\":\n 24\n , \"name\":\n \"Kirsten Sellers\"\n , \"email\":\n \"kirstensellers@example.com\"\n , \"phone\":\n \"+1 (555) 564-2190\"\n }\n ]\n }\n, \"prompting\":\n \\arguments ->\n let key = arguments.\"OpenAI API key\"\n\n in { \"names\":\n prompt\n { \"key\":\n key\n , \"text\":\n some \"Give me a list of names\"\n , \"history\":\n null\n , \"model\":\n null\n , \"search\":\n null\n , \"effort\":\n null\n }\n : forall (p : Type) . p\n , \"structuredNames\":\n prompt\n { \"key\":\n key\n , \"text\":\n some \"Give me a list of names\"\n , \"history\":\n null\n , \"model\":\n null\n , \"search\":\n null\n , \"effort\":\n null\n }\n : List Text\n , \"fullNames\":\n prompt\n { \"key\":\n key\n , \"text\":\n some \"Give me a list of names\"\n , \"history\":\n null\n , \"model\":\n null\n , \"search\":\n null\n , \"effort\":\n null\n }\n : List { firstName: Text, lastName: Text }\n , \"tacitFullNames\":\n prompt\n { \"key\":\n key\n , \"text\":\n null\n , \"history\":\n null\n , \"model\":\n null\n , \"search\":\n null\n , \"effort\":\n null\n }\n : List { firstName: Text, lastName: Text }\n , \"differentModel\":\n prompt\n { \"key\":\n key\n , \"model\":\n some \"gpt-5-nano\"\n , \"text\":\n null\n , \"history\":\n null\n , \"search\":\n null\n , \"effort\":\n null\n }\n : List { firstName: Text, lastName: Text }\n }\n, \"variables\":\n 216\n, \"functions\":\n { \"greet\":\n \\{ name } -> \"Hello, ${name}!\"\n , \"greeting\":\n \"Hello, world!\"\n , \"makeUser\":\n \\{ user } ->\n let home = \"/home/${user}\"\n\n let privateKey = \"${home}/.ssh/id_ed25519\"\n\n let publicKey = \"${privateKey}.pub\"\n\n in { \"home\": home, \"privateKey\": privateKey, \"publicKey\": publicKey }\n , \"users\":\n [ { \"home\":\n \"/home/bill\"\n , \"privateKey\":\n \"/home/bill/.ssh/id_ed25519\"\n , \"publicKey\":\n \"/home/bill/.ssh/id_ed25519.pub\"\n }\n , { \"home\":\n \"/home/jane\"\n , \"privateKey\":\n \"/home/jane/.ssh/id_ed25519\"\n , \"publicKey\":\n \"/home/jane/.ssh/id_ed25519.pub\"\n }\n ]\n }\n, \"imports\":\n { \"URL import\":\n \\{ \"Filing status\", \"Taxable income\" } ->\n let toBracket\n brackets\n (_ : { })\n income\n = fold\n { \"cons\":\n \\bracket ->\n \\result ->\n if income > bracket.\"Lower bound\"\n then\n bracket.\"Minimum tax\"\n + bracket.\"Tax rate\"\n * (income - bracket.\"Lower bound\")\n else\n result\n , \"nil\":\n 0.0 : Real\n }\n brackets\n\n let tax\n = fold\n { \"Single filers\":\n toBracket\n [ { \"Tax rate\":\n 0.37\n , \"Lower bound\":\n 539900.0\n , \"Minimum tax\":\n 162718.0\n }\n , { \"Tax rate\":\n 0.35\n , \"Lower bound\":\n 215950.0\n , \"Minimum tax\":\n 49335.5\n }\n , { \"Tax rate\":\n 0.32\n , \"Lower bound\":\n 170050.0\n , \"Minimum tax\":\n 34647.5\n }\n , { \"Tax rate\":\n 0.24\n , \"Lower bound\":\n 89075.0\n , \"Minimum tax\":\n 15213.5\n }\n , { \"Tax rate\":\n 0.22\n , \"Lower bound\":\n 41775.0\n , \"Minimum tax\":\n 4807.5\n }\n , { \"Tax rate\":\n 0.12\n , \"Lower bound\":\n 10275.0\n , \"Minimum tax\":\n 1027.5\n }\n , { \"Tax rate\":\n 0.1\n , \"Lower bound\":\n 0.0\n , \"Minimum tax\":\n 0.0\n }\n ]\n , \"Married, filing jointly\":\n toBracket\n [ { \"Tax rate\":\n 0.37\n , \"Lower bound\":\n 647850.0\n , \"Minimum tax\":\n 174253.5\n }\n , { \"Tax rate\":\n 0.35\n , \"Lower bound\":\n 431900.0\n , \"Minimum tax\":\n 98671.0\n }\n , { \"Tax rate\":\n 0.32\n , \"Lower bound\":\n 340100.0\n , \"Minimum tax\":\n 69295.0\n }\n , { \"Tax rate\":\n 0.24\n , \"Lower bound\":\n 178150.0\n , \"Minimum tax\":\n 30427.0\n }\n , { \"Tax rate\":\n 0.22\n , \"Lower bound\":\n 93550.0\n , \"Minimum tax\":\n 9615.0\n }\n , { \"Tax rate\":\n 0.12\n , \"Lower bound\":\n 20550.0\n , \"Minimum tax\":\n 2055.0\n }\n , { \"Tax rate\":\n 0.1\n , \"Lower bound\":\n 0.0\n , \"Minimum tax\":\n 0.0\n }\n ]\n , \"Married, filing separately\":\n toBracket\n [ { \"Tax rate\":\n 0.37\n , \"Lower bound\":\n 539900.0\n , \"Minimum tax\":\n 162718.0\n }\n , { \"Tax rate\":\n 0.35\n , \"Lower bound\":\n 215950.0\n , \"Minimum tax\":\n 49335.5\n }\n , { \"Tax rate\":\n 0.32\n , \"Lower bound\":\n 170050.0\n , \"Minimum tax\":\n 34647.5\n }\n , { \"Tax rate\":\n 0.24\n , \"Lower bound\":\n 89075.0\n , \"Minimum tax\":\n 15213.5\n }\n , { \"Tax rate\":\n 0.22\n , \"Lower bound\":\n 41775.0\n , \"Minimum tax\":\n 4807.5\n }\n , { \"Tax rate\":\n 0.12\n , \"Lower bound\":\n 10275.0\n , \"Minimum tax\":\n 1027.5\n }\n , { \"Tax rate\":\n 0.1\n , \"Lower bound\":\n 0.0\n , \"Minimum tax\":\n 0.0\n }\n ]\n , \"Head of household\":\n toBracket\n [ { \"Tax rate\":\n 0.37\n , \"Lower bound\":\n 539900.0\n , \"Minimum tax\":\n 161218.5\n }\n , { \"Tax rate\":\n 0.35\n , \"Lower bound\":\n 215950.0\n , \"Minimum tax\":\n 47836.0\n }\n , { \"Tax rate\":\n 0.32\n , \"Lower bound\":\n 170050.0\n , \"Minimum tax\":\n 33148.0\n }\n , { \"Tax rate\":\n 0.24\n , \"Lower bound\":\n 89050.0\n , \"Minimum tax\":\n 13708.0\n }\n , { \"Tax rate\":\n 0.22\n , \"Lower bound\":\n 55900.0\n , \"Minimum tax\":\n 6415.0\n }\n , { \"Tax rate\":\n 0.12\n , \"Lower bound\":\n 14650.0\n , \"Minimum tax\":\n 1465.0\n }\n , { \"Tax rate\":\n 0.1\n , \"Lower bound\":\n 0.0\n , \"Minimum tax\":\n 0.0\n }\n ]\n }\n .'Filing status'\n .'Taxable income'\n\n in { \"Tax\": tax }\n , \"GitHub import\":\n \\{ \"Filing status\", \"Taxable income\" } ->\n let toBracket\n brackets\n (_ : { })\n income\n = fold\n { \"cons\":\n \\bracket ->\n \\result ->\n if income > bracket.\"Lower bound\"\n then\n bracket.\"Minimum tax\"\n + bracket.\"Tax rate\"\n * (income - bracket.\"Lower bound\")\n else\n result\n , \"nil\":\n 0.0 : Real\n }\n brackets\n\n let tax\n = fold\n { \"Single filers\":\n toBracket\n [ { \"Tax rate\":\n 0.37\n , \"Lower bound\":\n 539900.0\n , \"Minimum tax\":\n 162718.0\n }\n , { \"Tax rate\":\n 0.35\n , \"Lower bound\":\n 215950.0\n , \"Minimum tax\":\n 49335.5\n }\n , { \"Tax rate\":\n 0.32\n , \"Lower bound\":\n 170050.0\n , \"Minimum tax\":\n 34647.5\n }\n , { \"Tax rate\":\n 0.24\n , \"Lower bound\":\n 89075.0\n , \"Minimum tax\":\n 15213.5\n }\n , { \"Tax rate\":\n 0.22\n , \"Lower bound\":\n 41775.0\n , \"Minimum tax\":\n 4807.5\n }\n , { \"Tax rate\":\n 0.12\n , \"Lower bound\":\n 10275.0\n , \"Minimum tax\":\n 1027.5\n }\n , { \"Tax rate\":\n 0.1\n , \"Lower bound\":\n 0.0\n , \"Minimum tax\":\n 0.0\n }\n ]\n , \"Married, filing jointly\":\n toBracket\n [ { \"Tax rate\":\n 0.37\n , \"Lower bound\":\n 647850.0\n , \"Minimum tax\":\n 174253.5\n }\n , { \"Tax rate\":\n 0.35\n , \"Lower bound\":\n 431900.0\n , \"Minimum tax\":\n 98671.0\n }\n , { \"Tax rate\":\n 0.32\n , \"Lower bound\":\n 340100.0\n , \"Minimum tax\":\n 69295.0\n }\n , { \"Tax rate\":\n 0.24\n , \"Lower bound\":\n 178150.0\n , \"Minimum tax\":\n 30427.0\n }\n , { \"Tax rate\":\n 0.22\n , \"Lower bound\":\n 93550.0\n , \"Minimum tax\":\n 9615.0\n }\n , { \"Tax rate\":\n 0.12\n , \"Lower bound\":\n 20550.0\n , \"Minimum tax\":\n 2055.0\n }\n , { \"Tax rate\":\n 0.1\n , \"Lower bound\":\n 0.0\n , \"Minimum tax\":\n 0.0\n }\n ]\n , \"Married, filing separately\":\n toBracket\n [ { \"Tax rate\":\n 0.37\n , \"Lower bound\":\n 539900.0\n , \"Minimum tax\":\n 162718.0\n }\n , { \"Tax rate\":\n 0.35\n , \"Lower bound\":\n 215950.0\n , \"Minimum tax\":\n 49335.5\n }\n , { \"Tax rate\":\n 0.32\n , \"Lower bound\":\n 170050.0\n , \"Minimum tax\":\n 34647.5\n }\n , { \"Tax rate\":\n 0.24\n , \"Lower bound\":\n 89075.0\n , \"Minimum tax\":\n 15213.5\n }\n , { \"Tax rate\":\n 0.22\n , \"Lower bound\":\n 41775.0\n , \"Minimum tax\":\n 4807.5\n }\n , { \"Tax rate\":\n 0.12\n , \"Lower bound\":\n 10275.0\n , \"Minimum tax\":\n 1027.5\n }\n , { \"Tax rate\":\n 0.1\n , \"Lower bound\":\n 0.0\n , \"Minimum tax\":\n 0.0\n }\n ]\n , \"Head of household\":\n toBracket\n [ { \"Tax rate\":\n 0.37\n , \"Lower bound\":\n 539900.0\n , \"Minimum tax\":\n 161218.5\n }\n , { \"Tax rate\":\n 0.35\n , \"Lower bound\":\n 215950.0\n , \"Minimum tax\":\n 47836.0\n }\n , { \"Tax rate\":\n 0.32\n , \"Lower bound\":\n 170050.0\n , \"Minimum tax\":\n 33148.0\n }\n , { \"Tax rate\":\n 0.24\n , \"Lower bound\":\n 89050.0\n , \"Minimum tax\":\n 13708.0\n }\n , { \"Tax rate\":\n 0.22\n , \"Lower bound\":\n 55900.0\n , \"Minimum tax\":\n 6415.0\n }\n , { \"Tax rate\":\n 0.12\n , \"Lower bound\":\n 14650.0\n , \"Minimum tax\":\n 1465.0\n }\n , { \"Tax rate\":\n 0.1\n , \"Lower bound\":\n 0.0\n , \"Minimum tax\":\n 0.0\n }\n ]\n }\n .'Filing status'\n .'Taxable income'\n\n in { \"Tax\": tax }\n , \"Short link\":\n \"\n The Grace browser also supports short links for code hosted on GitHub. For\n example, the short link for the above federal income tax form is:\n\n [https://trygrace.dev?github=Gabriella439/grace/examples/taxes.ffg](https://trygrace.dev?github=Gabriella439/grace/examples/taxes.ffg)\n\n More generally, the format of GitHub short links is:\n\n ```\n https://trygrace.dev?github=${owner}/${repository}/${path}[&reference=${reference}][&private=true]\n ```\n\n - `&reference=${reference}` pins the short link to a specific git reference\n\n … and defaults to the trunk branch of the repository.\n\n - `&private=true` will prompt you for a GitHub personal access token\n\n … so that you can import from a private GitHub repository.\n\n GitHub code imported in this way is displayed as a \\\"white-label\\\" form\n displaying just the form without the title bar or the code editor.\n \"\n , \"Import Prelude function\":\n \\b -> b == false\n , \"Import entire Prelude\":\n \\b -> b == false\n }\n, \"coding\":\n \\arguments ->\n let key = arguments.\"OpenAI API key\"\n\n in import prompt\n { \"key\":\n key\n , \"text\":\n null\n , \"history\":\n null\n , \"model\":\n null\n , \"search\":\n null\n , \"effort\":\n null\n }\n : { \"Job Description\": Text } ->\n { \"Is Finance?\": Bool, \"Rationale\": Text }\n, \"conclusion\":\n \\{ \"Want to get involved?\" } ->\n if .'Want to get involved?'\n then\n \"\n Visit Grace's [GitHub repository](https://github.com/Gabriella439/grace)\n or follow her [Bluesky profile](https://bsky.app/profile/trygrace.dev).\n \"\n else\n \"Have fun using the Grace browser!\"\n}\n" }, { "path": "tasty/data/complex/examples-type.ffg", "content": "forall (k : Fields) .\nforall (l : Fields) .\nforall (m : Fields) .\nforall (n : Fields) .\nforall (o : Fields) .\nforall (p : Type) .\nforall (q : Fields) .\n { hello:\n Text\n , html:\n List Bool\n , data:\n { \"An example string\":\n Text\n , \"An example string with a type annotation\":\n Text\n , \"A boolean value\":\n Bool\n , \"Annotated boolean value\":\n Bool\n , \"A natural number\":\n Natural\n , \"An integer\":\n Integer\n , \"A real number\":\n Real\n , \"A list of natural numbers\":\n List Natural\n , \"Annotated list of natural numbers\":\n List Natural\n , \"Annotated record\":\n { x: Natural, y: Natural }\n , \"A list of records (using JSON syntax with quoted field names)\":\n List\n { isActive:\n Bool\n , age:\n Natural\n , name:\n Text\n , email:\n Text\n , phone:\n Text\n }\n }\n , prompting:\n { \"OpenAI API key\": Key, q } ->\n { names:\n p\n , structuredNames:\n List Text\n , fullNames:\n List { firstName: Text, lastName: Text }\n , tacitFullNames:\n List { firstName: Text, lastName: Text }\n , differentModel:\n List { firstName: Text, lastName: Text }\n }\n , variables:\n Natural\n , functions:\n { greet:\n { name: Text, o } -> Text\n , greeting:\n Text\n , makeUser:\n { user: Text } -> { home: Text, privateKey: Text, publicKey: Text }\n , users:\n List { home: Text, privateKey: Text, publicKey: Text }\n }\n , imports:\n { \"URL import\":\n { \"Filing status\":\n < 'Head of household':\n { }\n | 'Married, filing jointly':\n { }\n | 'Married, filing separately':\n { }\n | 'Single filers':\n { }\n >\n , \"Taxable income\":\n Real\n , n\n } ->\n { \"Tax\": Real }\n , \"GitHub import\":\n { \"Filing status\":\n < 'Head of household':\n { }\n | 'Married, filing jointly':\n { }\n | 'Married, filing separately':\n { }\n | 'Single filers':\n { }\n >\n , \"Taxable income\":\n Real\n , m\n } ->\n { \"Tax\": Real }\n , \"Short link\":\n Text\n , \"Import Prelude function\":\n Bool -> Bool\n , \"Import entire Prelude\":\n Bool -> Bool\n }\n , coding:\n { \"OpenAI API key\": Key, l } ->\n { \"Job Description\": Text } ->\n { \"Is Finance?\": Bool, \"Rationale\": Text }\n , conclusion:\n { \"Want to get involved?\": Bool, k } -> Text\n }\n" }, { "path": "tasty/data/complex/exclaim-input.ffg", "content": "# Test defining and using a function\nlet exclaim t = \"${t}!\"\n\nin exclaim \"Hello, world\"\n" }, { "path": "tasty/data/complex/exclaim-output.ffg", "content": "\"Hello, world!\"\n" }, { "path": "tasty/data/complex/exclaim-type.ffg", "content": "Text\n" }, { "path": "tasty/data/complex/exhaust-type-variable-alphabet-input.ffg", "content": "# The purpose of this test is to force the type-inference algorithm to use up\n# the type variable alphabet so that we start displaying type variables like\n# `a0`\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\n\\x ->\nx\n" }, { "path": "tasty/data/complex/exhaust-type-variable-alphabet-output.ffg", "content": "\\x x x x x x x x x x x x x x x x x x x x x x x x x x x -> x\n" }, { "path": "tasty/data/complex/exhaust-type-variable-alphabet-type.ffg", "content": "forall (a : Type) .\nforall (b : Type) .\nforall (c : Type) .\nforall (d : Type) .\nforall (e : Type) .\nforall (f : Type) .\nforall (g : Type) .\nforall (h : Type) .\nforall (i : Type) .\nforall (j : Type) .\nforall (k : Type) .\nforall (l : Type) .\nforall (m : Type) .\nforall (n : Type) .\nforall (o : Type) .\nforall (p : Type) .\nforall (q : Type) .\nforall (r : Type) .\nforall (s : Type) .\nforall (t : Type) .\nforall (u : Type) .\nforall (v : Type) .\nforall (w : Type) .\nforall (x : Type) .\nforall (y : Type) .\nforall (z : Type) .\nforall (a0 : Type) .\n a0 ->\n z ->\n y ->\n x ->\n w ->\n v ->\n u ->\n t ->\n s ->\n r ->\n q ->\n p ->\n o ->\n n ->\n m ->\n l ->\n k ->\n j ->\n i ->\n h ->\n g ->\n f ->\n e ->\n d ->\n c ->\n b ->\n a ->\n a\n" }, { "path": "tasty/data/complex/existential-records-input.ffg", "content": "[ { x: 1, y: true }\n, { x: 1, z: \"\" }\n] : List { x : Natural, y : Optional Bool, z : Optional Text }\n" }, { "path": "tasty/data/complex/existential-records-output.ffg", "content": "[ { \"x\": 1, \"y\": some true, \"z\": null }, { \"x\": 1, \"z\": some \"\", \"y\": null } ]\n" }, { "path": "tasty/data/complex/existential-records-type.ffg", "content": "List { x: Natural, y: Optional Bool, z: Optional Text }\n" }, { "path": "tasty/data/complex/export-show-input.ffg", "content": "{ \"Example 0\":\n # Expressions should be normalized before they are shown, meaning that the\n # following expression should render as \"1\" and not \"let x = 1 in x\"\n export show (let x = 1 in x)\n\n, \"Example 1\":\n # Test that a read followed by show works without a type annotation\n export show (import read \"\\\\x -> x\")\n\n, \"Example 2\":\n # This test illustrates that `export show` has an effective type of\n # `forall (a : Type) . a -> Text` which means that we are very intentionally\n # breaking parametricity by permitting this feature.\n \\x -> export show x\n}\n" }, { "path": "tasty/data/complex/export-show-output.ffg", "content": "{ \"Example 0\":\n \"1\"\n, \"Example 1\":\n \"\\\\x -> x\"\n, \"Example 2\":\n \\x -> export show (x : forall (b : Type) . b)\n}\n" }, { "path": "tasty/data/complex/export-show-type.ffg", "content": "forall (b : Type) .\n { \"Example 0\": Text, \"Example 1\": Text, \"Example 2\": b -> Text }\n" }, { "path": "tasty/data/complex/extra-fields-input.ffg", "content": "let f (r : { x : Natural }) = r.x\nin f { x: 1, y: true }\n" }, { "path": "tasty/data/complex/extra-fields-output.ffg", "content": "1\n" }, { "path": "tasty/data/complex/extra-fields-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/complex/fold-bool-input.ffg", "content": "\\{ false, true } -> fold{ false, true }\n" }, { "path": "tasty/data/complex/fold-bool-output.ffg", "content": "\\{ false, true } -> fold { \"false\": .'false', \"true\": .'true' }\n" }, { "path": "tasty/data/complex/fold-bool-type.ffg", "content": "forall (a : Type) (b : Fields) . { false: a, true: a, b } -> Bool -> a\n" }, { "path": "tasty/data/complex/fold-json-input.ffg", "content": "\\{ array, bool, integer, natural, null, object, real, string } ->\n fold{ array, bool, integer, natural, null, object, real, string }\n" }, { "path": "tasty/data/complex/fold-json-output.ffg", "content": "\\{ array, bool, integer, natural, null, object, real, string } ->\n fold\n { \"array\":\n array\n , \"bool\":\n bool\n , \"integer\":\n integer\n , \"natural\":\n natural\n , \"null\":\n .'null'\n , \"object\":\n object\n , \"real\":\n real\n , \"string\":\n string\n }\n" }, { "path": "tasty/data/complex/fold-json-type.ffg", "content": "forall (a : Type) .\nforall (b : Fields) .\n { array:\n List a -> a\n , bool:\n Bool -> a\n , integer:\n Integer -> a\n , natural:\n Natural -> a\n , null:\n a\n , object:\n List { key: Text, value: a } -> a\n , real:\n Real -> a\n , string:\n Text -> a\n , b\n } ->\n JSON ->\n a\n" }, { "path": "tasty/data/complex/fold-list-input.ffg", "content": "\\{ nil, cons } -> fold{ nil, cons }\n" }, { "path": "tasty/data/complex/fold-list-output.ffg", "content": "\\{ nil, cons } -> fold { \"nil\": nil, \"cons\": cons }\n" }, { "path": "tasty/data/complex/fold-list-type.ffg", "content": "forall (a : Type) .\nforall (b : Type) .\nforall (c : Fields) .\n { nil: a, cons: b -> a -> a, c } -> List b -> a\n" }, { "path": "tasty/data/complex/fold-missing-field-input.ffg", "content": "# This tests how `fold` behaves when missing various arguments, along with\n# commentary on why each case behaves the way it does:\n{ \"Example 0\":\n # The inferred type will be:\n #\n # Bool -> Optional Natural\n #\n # … because this will elaborate to:\n #\n # fold{ false: some 0, true: null }\n fold{ false: 0 }\n\n, \"Example 1\":\n # The inferred type will be:\n #\n # forall (a : Type) . Natural -> Optional a`\n #\n # … because this will elaborate to:\n #\n # fold{ succ x: x, zero: null }\n #\n # … and the inferred type correctly deduces that must always return `null`\n # no matter what `Natural` number we provide.\n fold{ succ x: x }\n\n, \"Example 2\":\n # The inferred type will be:\n #\n # forall (a : Type) . Optional (Optional a) -> Optional a\n #\n # … because this will elaborate to:\n #\n # fold{ some x: x, null: null }\n fold{ some x: x }\n\n, \"Example 3\":\n # The inferred type will be:\n #\n # Optional Natural -> Optional Natural\n #\n # … because this will elaborate to:\n #\n # fold{ some x: some (x + 1), null: null }\n #\n # Note that (unlike the previous example) the typechecker has to insert a\n # `some` around the `some` handler, which is why the inferred type has a\n # different shape than the previous example.\n fold{ some x: x + 1 }\n\n, \"Example 4\":\n # The inferred type will be:\n #\n # forall (a : Type) (b : Type) . List a -> Optional b\n #\n # … because this will elaborate to:\n #\n # fold{ cons: \\x y -> y, nil: null }\n fold{ cons: \\x y -> y }\n}\n" }, { "path": "tasty/data/complex/fold-missing-field-output.ffg", "content": "{ \"Example 0\":\n fold { \"false\": some 0, \"true\": null }\n, \"Example 1\":\n fold { \"succ\": \\x -> x, \"zero\": null }\n, \"Example 2\":\n fold { \"some\": \\x -> x, \"null\": null }\n, \"Example 3\":\n fold { \"some\": \\x -> some (x + 1), \"null\": null }\n, \"Example 4\":\n fold { \"cons\": \\x y -> y, \"nil\": null }\n}\n" }, { "path": "tasty/data/complex/fold-missing-field-type.ffg", "content": "forall (a : Type) .\nforall (b : Type) .\nforall (c : Type) .\nforall (d : Type) .\n { \"Example 0\":\n Bool -> Optional Natural\n , \"Example 1\":\n Natural -> Optional d\n , \"Example 2\":\n Optional (Optional c) -> Optional c\n , \"Example 3\":\n Optional Natural -> Optional Natural\n , \"Example 4\":\n List b -> Optional a\n }\n" }, { "path": "tasty/data/complex/fold-natural-input.ffg", "content": "\\{ zero, succ } -> fold{ zero, succ }\n" }, { "path": "tasty/data/complex/fold-natural-output.ffg", "content": "\\{ zero, succ } -> fold { \"zero\": zero, \"succ\": succ }\n" }, { "path": "tasty/data/complex/fold-natural-type.ffg", "content": "forall (a : Type) (b : Fields) . { zero: a, succ: a -> a, b } -> Natural -> a\n" }, { "path": "tasty/data/complex/fold-optional-input.ffg", "content": "\\{ null, some } -> fold{ null, some }\n" }, { "path": "tasty/data/complex/fold-optional-output.ffg", "content": "\\{ null, some } -> fold { \"null\": .'null', \"some\": .'some' }\n" }, { "path": "tasty/data/complex/fold-optional-type.ffg", "content": "forall (a : Type) .\nforall (b : Type) .\nforall (c : Fields) .\n { null: a, some: b -> a, c } -> Optional b -> a\n" }, { "path": "tasty/data/complex/for-annotation-input.ffg", "content": "(for x of [] in x + 1) : List Natural\n" }, { "path": "tasty/data/complex/for-annotation-output.ffg", "content": "[ ]\n" }, { "path": "tasty/data/complex/for-annotation-type.ffg", "content": "List Natural\n" }, { "path": "tasty/data/complex/for-check-list-input.ffg", "content": "# Exercise the check judgment on Optional comprehensions\n(if let x = some 1 in x) : Optional Natural\n" }, { "path": "tasty/data/complex/for-check-list-output.ffg", "content": "some 1\n" }, { "path": "tasty/data/complex/for-check-list-type.ffg", "content": "Optional Natural\n" }, { "path": "tasty/data/complex/for-lambda-input.ffg", "content": "# This test verifies that the `check` rule for `for` assignments works\n# correctly when the type annotation is an unsolved variable,such as\n# when checking the body of a lambda without an annotation.\n\\y -> for x of [ 1 ] in x\n" }, { "path": "tasty/data/complex/for-lambda-output.ffg", "content": "\\y -> for x of [ 1 ] in x\n" }, { "path": "tasty/data/complex/for-lambda-type.ffg", "content": "forall (a : Type) . a -> List Natural\n" }, { "path": "tasty/data/complex/for-list-input.ffg", "content": "let bools = [ false, true ]\n\nfor bool of bools\n\nlet numbers = if bool then [ 1, 2, 3 ] else [ 4, 5, 6 ]\n\nfor number of numbers\n\nin { bool, number }\n" }, { "path": "tasty/data/complex/for-list-output.ffg", "content": "[ { \"bool\": false, \"number\": 4 }\n, { \"bool\": false, \"number\": 5 }\n, { \"bool\": false, \"number\": 6 }\n, { \"bool\": true, \"number\": 1 }\n, { \"bool\": true, \"number\": 2 }\n, { \"bool\": true, \"number\": 3 }\n]\n" }, { "path": "tasty/data/complex/for-list-type.ffg", "content": "List { bool: Bool, number: Natural }\n" }, { "path": "tasty/data/complex/for-naked-output.ffg", "content": "some 1\n" }, { "path": "tasty/data/complex/for-naked-type.ffg", "content": "Optional Natural\n" }, { "path": "tasty/data/complex/for-optional-input.ffg", "content": "let a = some 1\n\nif let x = a\n\nlet b = some x\n\nif let y = b\n\nlet c = null\n\nif let z = c\n\nin { x, y, z }\n" }, { "path": "tasty/data/complex/for-optional-output.ffg", "content": "null\n" }, { "path": "tasty/data/complex/for-optional-type.ffg", "content": "forall (a : Type) . Optional { x: Natural, y: Natural, z: a }\n" }, { "path": "tasty/data/complex/forall-annotation-input.ffg", "content": "# Test a polymorphic type annotation\n(\\x -> x) : forall (a : Type) . a -> a\n" }, { "path": "tasty/data/complex/forall-annotation-output.ffg", "content": "\\x -> x\n" }, { "path": "tasty/data/complex/forall-annotation-type.ffg", "content": "forall (a : Type) . a -> a\n" }, { "path": "tasty/data/complex/higher-rank-annotation-input.ffg", "content": "# This test illustrates how a type annotation is necessary for higher-rank\n# functions. In the absence of the annotation the example fails with an\n# unbound type variable error.\n( \\id -> [ id : forall (a : Type) . a -> a , \\x -> x ]\n) : (forall (a : Type) . a -> a) -> List (forall (a : Type) . a -> a)\n" }, { "path": "tasty/data/complex/higher-rank-annotation-output.ffg", "content": "\\id -> [ id : forall (a : Type) . a -> a, \\x -> x ]\n" }, { "path": "tasty/data/complex/higher-rank-annotation-type.ffg", "content": "(forall (a : Type) . a -> a) -> List (forall (a : Type) . a -> a)\n" }, { "path": "tasty/data/complex/higher-rank-input.ffg", "content": "# This test verifies that higher-rank functions work\nlet f : (forall (a : Type) . a -> a) -> Natural -> Natural\n = \\g -> g\n\nlet id\n : forall (a : Type) . a -> a\n = \\x -> x\n\nin f id\n" }, { "path": "tasty/data/complex/higher-rank-output.ffg", "content": "\\x -> x\n" }, { "path": "tasty/data/complex/higher-rank-subtype-input.ffg", "content": "# The purpose of this test is to fully exercise the <:∀R judgment\nlet f : Natural -> (forall (a : Type) . Bool) -> Natural\n = \\n _ -> n\n\nin f 0 (true : forall (a : Type) . Bool)\n" }, { "path": "tasty/data/complex/higher-rank-subtype-output.ffg", "content": "0\n" }, { "path": "tasty/data/complex/higher-rank-subtype-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/complex/higher-rank-type.ffg", "content": "Natural -> Natural\n" }, { "path": "tasty/data/complex/if-then-else-input.ffg", "content": "# This checks what type would be inferred for a first-class function equivalent\n# to an `if` expression\n\\x -> \\y -> \\z -> if x then y else z\n" }, { "path": "tasty/data/complex/if-then-else-output.ffg", "content": "\\x y z -> if x then y else z\n" }, { "path": "tasty/data/complex/if-then-else-type.ffg", "content": "forall (a : Type) . Bool -> a -> a -> a\n" }, { "path": "tasty/data/complex/import-github-input.ffg", "content": "import github\n { owner: \"Gabriella439\"\n , repository: \"grace\"\n , reference: \"2aa58c1b5aeffab08acf2dd4c0d2de430a380b9b\"\n , path: \"prelude/bool/not.ffg\"\n }\n" }, { "path": "tasty/data/complex/import-github-output.ffg", "content": "\\b -> b == false\n" }, { "path": "tasty/data/complex/import-github-type.ffg", "content": "Bool -> Bool\n" }, { "path": "tasty/data/complex/impredicative-const-input.ffg", "content": "# Verify that higher-rank predicative polymorphism is allowed by giving the\n# `const` function the highest-rank polymorphic type possible\n(\\x -> \\y -> x) : forall (a : Type) . a -> (forall (b : Type) . b -> a)\n" }, { "path": "tasty/data/complex/impredicative-const-output.ffg", "content": "\\x y -> x\n" }, { "path": "tasty/data/complex/impredicative-const-type.ffg", "content": "forall (a : Type) . a -> (forall (b : Type) . b -> a)\n" }, { "path": "tasty/data/complex/index-input.ffg", "content": "{ example0: [ 2, 3, 5 ].0\n, example1: [ 2, 3, 5 ].-1\n, example2: [ 2, 3, 5 ].3\n, example3: [ 2, 3, 5 ].-4\n, example4: [].0\n}\n" }, { "path": "tasty/data/complex/index-output.ffg", "content": "{ \"example0\":\n some 2\n, \"example1\":\n some 5\n, \"example2\":\n null\n, \"example3\":\n null\n, \"example4\":\n null\n}\n" }, { "path": "tasty/data/complex/index-type.ffg", "content": "forall (a : Type) .\n { example0:\n Optional Natural\n , example1:\n Optional Natural\n , example2:\n Optional Natural\n , example3:\n Optional Natural\n , example4:\n Optional a\n }\n" }, { "path": "tasty/data/complex/inequality-input.ffg", "content": " { number: 0, bool: true, list: [ 2, 3, 5 ], text: \"\" }\n== { number: 0, bool: true, list: [ 2, 3, 6 ], text: \"\" }\n" }, { "path": "tasty/data/complex/inequality-output.ffg", "content": "false\n" }, { "path": "tasty/data/complex/inequality-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/complex/infer-higher-order-input.ffg", "content": "# Verify that we can infer the types of higher-order functions\n\\f x -> f x\n" }, { "path": "tasty/data/complex/infer-higher-order-output.ffg", "content": "\\f x -> f x\n" }, { "path": "tasty/data/complex/infer-higher-order-type.ffg", "content": "forall (a : Type) (b : Type) . (b -> a) -> b -> a\n" }, { "path": "tasty/data/complex/infer-reverse-input.ffg", "content": "# This is a basic test that type inference can work backwards from output types\n# to infer input types\n\\x -> x : Bool\n" }, { "path": "tasty/data/complex/infer-reverse-output.ffg", "content": "\\x -> x : Bool\n" }, { "path": "tasty/data/complex/infer-reverse-type.ffg", "content": "Bool -> Bool\n" }, { "path": "tasty/data/complex/inner-forall-input.ffg", "content": "let wrappedId\n : { wrapped : forall (a : Type). a -> a }\n = { wrapped : \\x -> x }\nin wrappedId : { wrapped: forall (a : Type). a -> a }\n" }, { "path": "tasty/data/complex/inner-forall-output.ffg", "content": "{ \"wrapped\": \\x -> x }\n" }, { "path": "tasty/data/complex/inner-forall-type.ffg", "content": "forall (a : Type) . { wrapped: a -> a }\n" }, { "path": "tasty/data/complex/instantiate-nested-type-input.ffg", "content": "# This test is designed to exercise as many code paths as possible for the\n# `Grace.Type.substitute{Type,Fields,Alternatives}` family of functions\nlet f : forall (a : Type)\n . forall (a : Fields)\n . forall (a : Type)\n . forall (t : Type)\n . forall (r : Fields)\n . forall (u : Alternatives)\n . a\n -> t\n -> { r }\n -> < u >\n -> List < C : { y : a, t : Text, b : Bool, n : Natural, t : t, r : { r }, u : < u > } >\n = \\x ->\n \\t ->\n \\r ->\n \\u ->\n [ C { y: x, t: \"\", b: false, n: 0, t: t, r: r, u: u } ]\n\nlet g : forall (a : Fields)\n . forall (a : Alternatives)\n . forall (a : Fields)\n . forall (t : Type)\n . forall (r : Fields)\n . forall (u : Alternatives)\n . { a }\n -> t\n -> { r }\n -> < u >\n -> List < C : { y : { a }, t : Text, b : Bool, n : Natural, t : t, r : { r }, u : < u > } >\n = f\n\nlet h : forall (a : Alternatives)\n . forall (a : Type)\n . forall (a : Alternatives)\n . forall (t : Type)\n . forall (r : Fields)\n . forall (u : Alternatives)\n . < a >\n -> t\n -> { r }\n -> < u >\n -> List < C : { y : < a >, t : Text, b : Bool, n : Natural, t : t, r : { r }, u : < u > } >\n = f\n\nlet example0 = f 1\n\nlet example1 = g { foo: 1 }\n\nlet example2 = h (Foo 1)\n\nin { }\n" }, { "path": "tasty/data/complex/instantiate-nested-type-output.ffg", "content": "{ }\n" }, { "path": "tasty/data/complex/instantiate-nested-type-type.ffg", "content": "{ }\n" }, { "path": "tasty/data/complex/instantiate-variable-input.ffg", "content": "# This exercises instantiation of an unsolved variable to a type variable\n{ a: null : forall (a : Type) . Optional a\n, b: null : forall (a : Fields) . Optional { a }\n, c: null : forall (a : Alternatives) . Optional < a >\n}\n" }, { "path": "tasty/data/complex/instantiate-variable-output.ffg", "content": "{ \"a\": null, \"b\": null, \"c\": null }\n" }, { "path": "tasty/data/complex/instantiate-variable-type.ffg", "content": "forall (a : Alternatives) .\nforall (b : Fields) .\nforall (c : Type) .\n { a: Optional c, b: Optional { b }, c: Optional < a > }\n" }, { "path": "tasty/data/complex/interpolate-default-input.ffg", "content": "let greet{ name = \"John Doe\" } = \"Hello, ${name}!\"\n\nin [ greet{ name: \"Mary Sue\" }\n , greet{ name: null }\n , greet{ }\n ]\n" }, { "path": "tasty/data/complex/interpolate-default-output.ffg", "content": "[ \"Hello, Mary Sue!\", \"Hello, John Doe!\", \"Hello, John Doe!\" ]\n" }, { "path": "tasty/data/complex/interpolate-default-type.ffg", "content": "List Text\n" }, { "path": "tasty/data/complex/interpolation-input.ffg", "content": "{ example0: \"a${\"b\" + \"c\"}d\"\n, example1: \"a${ \"b\" }c\"\n}\n" }, { "path": "tasty/data/complex/interpolation-output.ffg", "content": "{ \"example0\": \"abcd\", \"example1\": \"abc\" }\n" }, { "path": "tasty/data/complex/interpolation-type.ffg", "content": "{ example0: Text, example1: Text }\n" }, { "path": "tasty/data/complex/json-fold-input.ffg", "content": "fold\n { \"bool\": \\b -> if b then 1 else 0\n , \"natural\": \\x -> x\n , \"integer\": abs\n , \"real\": \\_ -> 1\n , \"string\": \\_ -> 2\n , \"null\": 3\n , \"object\": length\n , \"array\": fold { cons: \\x -> \\y -> x + y : Natural, nil: 0 : Natural }\n }\n [ true, 1, [ -2, false, \"\" ], null, { foo: { } } ]\n" }, { "path": "tasty/data/complex/json-fold-output.ffg", "content": "10\n" }, { "path": "tasty/data/complex/json-fold-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/complex/keyword-prefix-input.ffg", "content": "# Check that identifiers can begin with keyword prefixes\n#\n# `input` starts with `in`, which is a keyword\nlet input = 1\n\nin input\n" }, { "path": "tasty/data/complex/keyword-prefix-output.ffg", "content": "1\n" }, { "path": "tasty/data/complex/keyword-prefix-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/complex/lambda-annotation-input.ffg", "content": "(\\(x : forall (a : Type) . a -> a) -> x) (\\y -> y)\n" }, { "path": "tasty/data/complex/lambda-annotation-output.ffg", "content": "\\y -> y\n" }, { "path": "tasty/data/complex/lambda-annotation-type.ffg", "content": "forall (a : Type) . a -> a\n" }, { "path": "tasty/data/complex/let-functions-input.ffg", "content": "let f0 succ zero = succ (succ zero)\n\nlet f1 (succ : Natural -> Natural) (zero : Natural) : Natural = succ (succ zero)\n\nlet succ0 x = x + 1 : Natural\n\nlet succ1 (x : Natural) : Natural = x + 1\n\nin f0 succ0 0 + f1 succ1 0\n" }, { "path": "tasty/data/complex/let-functions-output.ffg", "content": "4\n" }, { "path": "tasty/data/complex/let-functions-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/complex/list-append-subtype-input.ffg", "content": "[ -2 ] + [ 3 ]\n" }, { "path": "tasty/data/complex/list-append-subtype-output.ffg", "content": "[ -2, 3 ]\n" }, { "path": "tasty/data/complex/list-append-subtype-type.ffg", "content": "List Integer\n" }, { "path": "tasty/data/complex/list-of-alternatives-input.ffg", "content": "# This verifies that you can unify list elements of different types using a\n# union\n[ Left 1, Right true ]\n" }, { "path": "tasty/data/complex/list-of-alternatives-output.ffg", "content": "[ Left 1, Right true ]\n" }, { "path": "tasty/data/complex/list-of-alternatives-type.ffg", "content": "forall (a : Alternatives) . List < Left: Natural | Right: Bool | a >\n" }, { "path": "tasty/data/complex/list-unequal-length-input.ffg", "content": "# This verifies that `==` returns `false` for lists of unequal length\n[ 2 ] == [ ]\n" }, { "path": "tasty/data/complex/list-unequal-length-output.ffg", "content": "false\n" }, { "path": "tasty/data/complex/list-unequal-length-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/complex/merge-multiple-input.ffg", "content": "# This checks that the type-checker correctly infers that the input type of the\n# `X` handler is `Natural`, by working backwards from the result type of the `Y`\n# handler\nfold { X: \\x -> x, Y: \\_ -> 2 }\n" }, { "path": "tasty/data/complex/merge-multiple-output.ffg", "content": "fold { \"X\": \\x -> x, \"Y\": \\_ -> 2 }\n" }, { "path": "tasty/data/complex/merge-multiple-type.ffg", "content": "forall (a : Type) . < X: Natural | Y: a > -> Natural\n" }, { "path": "tasty/data/complex/merge-optional-input.ffg", "content": "let toNatural\n : Optional Natural -> Natural\n = fold { some: \\x -> x, null: 0 }\n\nin { example0: toNatural [ ].0\n , example1: toNatural [ 1 ].0\n }\n" }, { "path": "tasty/data/complex/merge-optional-output.ffg", "content": "{ \"example0\": 0, \"example1\": 1 }\n" }, { "path": "tasty/data/complex/merge-optional-type.ffg", "content": "{ example0: Natural, example1: Natural }\n" }, { "path": "tasty/data/complex/minus-natural-input.ffg", "content": "2 - 3\n" }, { "path": "tasty/data/complex/minus-natural-output.ffg", "content": "-1\n" }, { "path": "tasty/data/complex/minus-natural-type.ffg", "content": "Integer\n" }, { "path": "tasty/data/complex/modulus-input.ffg", "content": "{ naturals: map (\\n -> (n : Natural) % 3) [ 0, 1, 2, 3 ]\n, integers: map (\\n -> (n : Integer) % 3) [ -3, -2, -1, 0, 1, 2, 3 ]\n, reals: map (\\n -> (n : Real) % 3) [ -3.1, -3, -2.9, -0.1, 0, 0.1, 2.9, 3, 3.1 ]\n}\n" }, { "path": "tasty/data/complex/modulus-output.ffg", "content": "{ \"naturals\":\n [ { \"quotient\": 0, \"remainder\": 0 }\n , { \"quotient\": 0, \"remainder\": 1 }\n , { \"quotient\": 0, \"remainder\": 2 }\n , { \"quotient\": 1, \"remainder\": 0 }\n ]\n, \"integers\":\n [ { \"quotient\": -1, \"remainder\": 0 }\n , { \"quotient\": -1, \"remainder\": 1 }\n , { \"quotient\": -1, \"remainder\": 2 }\n , { \"quotient\": 0, \"remainder\": 0 }\n , { \"quotient\": 0, \"remainder\": 1 }\n , { \"quotient\": 0, \"remainder\": 2 }\n , { \"quotient\": 1, \"remainder\": 0 }\n ]\n, \"reals\":\n [ { \"quotient\": -2, \"remainder\": 2.9 }\n , { \"quotient\": -1, \"remainder\": 0.0 }\n , { \"quotient\": -1, \"remainder\": 0.1 }\n , { \"quotient\": -1, \"remainder\": 2.9 }\n , { \"quotient\": 0, \"remainder\": 0.0 }\n , { \"quotient\": 0, \"remainder\": 0.1 }\n , { \"quotient\": 0, \"remainder\": 2.9 }\n , { \"quotient\": 1, \"remainder\": 0.0 }\n , { \"quotient\": 1, \"remainder\": 0.1 }\n ]\n}\n" }, { "path": "tasty/data/complex/modulus-type.ffg", "content": "{ naturals:\n List { quotient: Natural, remainder: Natural }\n, integers:\n List { quotient: Integer, remainder: Natural }\n, reals:\n List { quotient: Integer, remainder: Real }\n}\n" }, { "path": "tasty/data/complex/nested-arithmetic-input.ffg", "content": "1 + 2 * 3 + (4 * 5 + 1) + ( 6 + 2 * 2 )\n" }, { "path": "tasty/data/complex/nested-arithmetic-output.ffg", "content": "38\n" }, { "path": "tasty/data/complex/nested-arithmetic-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/complex/nested-constructor-input.ffg", "content": "# This verifies that multiple occurrences of the same constructor (e.g. `C` in\n# this example) are not necessarily treated as belonging to the same union type\n\\x -> C (C x)\n" }, { "path": "tasty/data/complex/nested-constructor-output.ffg", "content": "\\x -> C (C x)\n" }, { "path": "tasty/data/complex/nested-constructor-type.ffg", "content": "forall (a : Type) .\nforall (b : Alternatives) .\nforall (c : Alternatives) .\n a -> < C: < C: a | b > | c >\n" }, { "path": "tasty/data/complex/nested-fields-input.ffg", "content": "# This test checks to see that fields variables are inferred three levels deep\n\\x -> x.a.b.c\n" }, { "path": "tasty/data/complex/nested-fields-output.ffg", "content": "\\x -> x.a.b.c\n" }, { "path": "tasty/data/complex/nested-fields-type.ffg", "content": "forall (a : Type) .\nforall (b : Fields) .\nforall (c : Fields) .\nforall (d : Fields) .\n { a: { b: { c: a, b }, c }, d } -> a\n" }, { "path": "tasty/data/complex/nested-let-input.ffg", "content": "let f (x: Text) =\n let y = x\n\n in y\n\nin f \"\"\n" }, { "path": "tasty/data/complex/nested-let-output.ffg", "content": "\"\"\n" }, { "path": "tasty/data/complex/nested-let-type.ffg", "content": "Text\n" }, { "path": "tasty/data/complex/numeric-subtyping-input.ffg", "content": "# This verifies that list subtyping works in the presence of a type annotation\n{ example0: [ 1, -1 ] : List Integer\n, example1: [ 1, -1, 1.1 ] : List Real\n}\n" }, { "path": "tasty/data/complex/numeric-subtyping-output.ffg", "content": "{ \"example0\": [ 1, -1 ], \"example1\": [ 1.0, -1.0, 1.1 ] }\n" }, { "path": "tasty/data/complex/numeric-subtyping-type.ffg", "content": "{ example0: List Integer, example1: List Real }\n" }, { "path": "tasty/data/complex/optional-fields-input.ffg", "content": "# This verifies that the idiom of unifying present/absent fields using\n# `Optional` types works\n[ { x: 1 }, { y: true } ] : List { x: Optional Natural, y: Optional Bool }\n" }, { "path": "tasty/data/complex/optional-fields-output.ffg", "content": "[ { \"x\": some 1, \"y\": null }, { \"y\": some true, \"x\": null } ]\n" }, { "path": "tasty/data/complex/optional-fields-type.ffg", "content": "List { x: Optional Natural, y: Optional Bool }\n" }, { "path": "tasty/data/complex/package-input.ffg", "content": "# This checks that anonymous unions work for a realistic example\n[ GitHub\n { repository:\n \"https://github.com/Gabriel439/Haskell-Turtle-Library.git\"\n , revision: \"ae5edf227b515b34c1cb6c89d9c58ea0eece12d5\"\n }\n, Local { relativePath: \"~/proj/optparse-applicative\" }\n, Local { relativePath: \"~/proj/discrimination\" }\n, Hackage { package: \"lens\", version: \"4.15.4\" }\n, GitHub\n { repository: \"https://github.com/haskell/text.git\"\n , revision: \"ccbfabedea1cf5b38ff19f37549feaf01225e537\"\n }\n, Local { relativePath: \"~/proj/servant-swagger\" }\n, Hackage { package: \"aeson\", version: \"1.2.3.0\" }\n] : List\n < Local : { relativePath : Text }\n | GitHub : { repository : Text, revision : Text }\n | Hackage : { package : Text, version : Text }\n >\n" }, { "path": "tasty/data/complex/package-output.ffg", "content": "[ GitHub\n { \"repository\":\n \"https://github.com/Gabriel439/Haskell-Turtle-Library.git\"\n , \"revision\":\n \"ae5edf227b515b34c1cb6c89d9c58ea0eece12d5\"\n }\n, Local{ \"relativePath\": \"~/proj/optparse-applicative\" }\n, Local{ \"relativePath\": \"~/proj/discrimination\" }\n, Hackage{ \"package\": \"lens\", \"version\": \"4.15.4\" }\n, GitHub\n { \"repository\":\n \"https://github.com/haskell/text.git\"\n , \"revision\":\n \"ccbfabedea1cf5b38ff19f37549feaf01225e537\"\n }\n, Local{ \"relativePath\": \"~/proj/servant-swagger\" }\n, Hackage{ \"package\": \"aeson\", \"version\": \"1.2.3.0\" }\n]\n" }, { "path": "tasty/data/complex/package-type.ffg", "content": "List\n < Local:\n { relativePath: Text }\n | GitHub:\n { repository: Text, revision: Text }\n | Hackage:\n { package: Text, version: Text }\n >\n" }, { "path": "tasty/data/complex/pattern-input.ffg", "content": "let match = fold\n { C0 x: x\n , C1 bool: Text: if bool then \"true\" else \"false\"\n , C2 (text: Text): text\n , C3 (number: Natural): Text: show number\n , C4 { x, y : Natural }: Text: show (x + y)\n }\n\nin map match [ C0 \"a\", C1 false, C2 \"b\", C3 2, C4 { x: 3, y: 5 } ]\n" }, { "path": "tasty/data/complex/pattern-output.ffg", "content": "[ \"a\", \"false\", \"b\", \"2\", \"8\" ]\n" }, { "path": "tasty/data/complex/pattern-type.ffg", "content": "List Text\n" }, { "path": "tasty/data/complex/polymorphic-instantiation-input.ffg", "content": "# This test illustrates a type variable being instantiated a more specific\n# type without impredicative polymorphism\nlet f : forall (a : Type) . a -> a\n = \\x -> x\n\n# Carefully note the `forall (c : Type)` has to be floated out for this to work.\n# If the type annotation were:\n#\n# (forall (b : Type) . b -> b) -> (forall (c : Type) . c -> c)\n#\n# … then that would require impredicative polymorphism\nlet g : forall (c : Type) . (forall (b : Type) . b -> b) -> (c -> c)\n = f\n\nin { }\n" }, { "path": "tasty/data/complex/polymorphic-instantiation-output.ffg", "content": "{ }\n" }, { "path": "tasty/data/complex/polymorphic-instantiation-type.ffg", "content": "{ }\n" }, { "path": "tasty/data/complex/polymorphic-let-input.ffg", "content": "# This verifies that a type with a polymorphic type annotation can be\n# instantiated to multiple types within the same expression\nlet id : forall (a : Type) . a -> a = \\x -> x\n\nin { example0: id true\n , example1: id { }\n }\n" }, { "path": "tasty/data/complex/polymorphic-let-output.ffg", "content": "{ \"example0\": true, \"example1\": { } }\n" }, { "path": "tasty/data/complex/polymorphic-let-type.ffg", "content": "{ example0: Bool, example1: { } }\n" }, { "path": "tasty/data/complex/polymorphic-subsumption-input.ffg", "content": "# This checks that a polymorphic type is a subtype of a corresponding\n# instantiated monomorphic type\n((\\x -> x) : forall (a : Type) . a -> a) : Bool -> Bool\n" }, { "path": "tasty/data/complex/polymorphic-subsumption-output.ffg", "content": "\\x -> x\n" }, { "path": "tasty/data/complex/polymorphic-subsumption-type.ffg", "content": "Bool -> Bool\n" }, { "path": "tasty/data/complex/potpourri-input.ffg", "content": "# This checks a modestly interesting type inference puzzle\n\\f -> \\x -> f (x.a [ x.b, x.c ])\n" }, { "path": "tasty/data/complex/potpourri-output.ffg", "content": "\\f x -> f (x.a [ x.b, x.c ])\n" }, { "path": "tasty/data/complex/potpourri-type.ffg", "content": "forall (a : Type) .\nforall (b : Type) .\nforall (c : Type) .\nforall (d : Fields) .\n (c -> a) -> { a: List b -> c, b: b, c: b, d } -> a\n" }, { "path": "tasty/data/complex/predicative-null-input.ffg", "content": "# This ensures that `null`'s type is inferred as `Optional a?` where `a?` is an\n# unsolved type variable, instead of `forall (a : Type) . Optional a`, since\n# the latter type would lead to a type error due to relying on impredicativity.\n\\x -> [ null, x ]\n" }, { "path": "tasty/data/complex/predicative-null-output.ffg", "content": "\\x -> [ null, x ]\n" }, { "path": "tasty/data/complex/predicative-null-type.ffg", "content": "forall (a : Type) . Optional a -> List (Optional a)\n" }, { "path": "tasty/data/complex/prelude-input.ffg", "content": "../../../prelude/package.ffg\n" }, { "path": "tasty/data/complex/prelude-output.ffg", "content": "{ \"bool\":\n { \"and\":\n fold { \"cons\": \\x y -> x && y, \"nil\": true }\n , \"not\":\n \\b -> b == false\n , \"or\":\n fold { \"cons\": \\x y -> x || y, \"nil\": false }\n }\n, \"real\":\n { \"product\":\n fold { \"cons\": \\x y -> x * y : Real, \"nil\": 1.0 }\n , \"sum\":\n fold { \"cons\": \\x y -> x + y : Real, \"nil\": 0.0 }\n }\n, \"integer\":\n { \"clamp\":\n \\n -> if (n : Real) < 0.0 then 0 else abs n\n , \"product\":\n fold { \"cons\": \\x y -> x * y : Integer, \"nil\": 1 }\n , \"sum\":\n fold { \"cons\": \\x y -> x + y : Integer, \"nil\": 0 }\n , \"toNatural\":\n \\n -> if (n : Real) < 0.0 then null else some (abs n)\n }\n, \"list\":\n { \"all\":\n \\predicate ->\n fold\n { \"cons\":\n \\element result -> predicate element && result\n , \"nil\":\n true\n }\n , \"any\":\n \\predicate ->\n fold\n { \"cons\":\n \\element result -> predicate element || result\n , \"nil\":\n false\n }\n , \"concat\":\n \\lists -> for list of lists for element of list in element\n , \"generate\":\n let replicate\n = \\n x -> fold { \"succ\": \\xs -> [ x ] + xs, \"zero\": [ ] } n\n\n in \\n f -> map (\\x -> f x.index) (indexed (replicate n { }))\n , \"null\":\n \\xs -> length xs == 0\n , \"reject\":\n \\f ->\n fold { \"cons\": \\x xs -> if f x then xs else [ x ] + xs, \"nil\": [ ] }\n , \"replicate\":\n \\n x -> fold { \"succ\": \\xs -> [ x ] + xs, \"zero\": [ ] } n\n , \"select\":\n \\f ->\n fold { \"cons\": \\x xs -> if f x then [ x ] + xs else xs, \"nil\": [ ] }\n }\n, \"natural\":\n { \"product\":\n fold { \"cons\": \\x y -> x * y : Natural, \"nil\": 1 }\n , \"sum\":\n fold { \"cons\": \\x y -> x + y : Natural, \"nil\": 0 }\n }\n, \"text\":\n { \"concat\":\n fold { \"cons\": \\x y -> x + y : Text, \"nil\": \"\" }\n , \"concatMap\":\n \\f -> fold { \"cons\": \\x y -> f x + y, \"nil\": \"\" }\n , \"concatMapSep\":\n let concatSep\n = \\separator ->\n \\(xs : List Text) ->\n let status\n = fold\n { \"cons\":\n \\element ->\n fold\n { \"null\":\n some element\n , \"some\":\n \\result ->\n some (element + separator + result)\n }\n , \"nil\":\n null\n }\n xs\n\n in fold { \"null\": \"\", \"some\": \\result -> result } status\n\n in \\separator f xs -> concatSep separator (map f xs)\n , \"concatSep\":\n \\separator ->\n \\(xs : List Text) ->\n let status\n = fold\n { \"cons\":\n \\element ->\n fold\n { \"null\":\n some element\n , \"some\":\n \\result -> some (element + separator + result)\n }\n , \"nil\":\n null\n }\n xs\n\n in fold { \"null\": \"\", \"some\": \\result -> result } status\n }\n}\n" }, { "path": "tasty/data/complex/prelude-type.ffg", "content": "forall (a : Type) .\nforall (b : Type) .\nforall (c : Type) .\nforall (d : Type) .\nforall (e : Type) .\nforall (f : Type) .\nforall (g : Type) .\nforall (h : Type) .\nforall (i : Type) .\nforall (j : Type) .\n { bool:\n { and: List Bool -> Bool, not: Bool -> Bool, or: List Bool -> Bool }\n , real:\n { product: List Real -> Real, sum: List Real -> Real }\n , integer:\n { clamp:\n Integer -> Natural\n , product:\n List Integer -> Integer\n , sum:\n List Integer -> Integer\n , toNatural:\n Integer -> Optional Natural\n }\n , list:\n { all:\n (j -> Bool) -> List j -> Bool\n , any:\n (i -> Bool) -> List i -> Bool\n , concat:\n List (List h) -> List h\n , generate:\n Natural -> (Natural -> g) -> List g\n , null:\n List f -> Bool\n , reject:\n (e -> Bool) -> List e -> List e\n , replicate:\n Natural -> d -> List d\n , select:\n (c -> Bool) -> List c -> List c\n }\n , natural:\n { product: List Natural -> Natural, sum: List Natural -> Natural }\n , text:\n { concat:\n List Text -> Text\n , concatMap:\n (b -> Text) -> List b -> Text\n , concatMapSep:\n Text -> (a -> Text) -> List a -> Text\n , concatSep:\n Text -> List Text -> Text\n }\n }\n" }, { "path": "tasty/data/complex/preserve-row-input.ffg", "content": "# This verifies that type inference correctly detects that the input and\n# output record should have the same fields variable\n\\x -> let y = x.a && x.b in x\n" }, { "path": "tasty/data/complex/preserve-row-output.ffg", "content": "\\x -> let y = x.a && x.b in x\n" }, { "path": "tasty/data/complex/preserve-row-type.ffg", "content": "forall (a : Fields) . { a: Bool, b: Bool, a } -> { a: Bool, b: Bool, a }\n" }, { "path": "tasty/data/complex/principle-of-explosion-input.ffg", "content": "# This is the Grace encoding of the \"principle of explosion\":\n#\n# https://en.wikipedia.org/wiki/Principle_of_explosion\nfold { } : forall (a : Type) . < > -> a\n" }, { "path": "tasty/data/complex/principle-of-explosion-output.ffg", "content": "fold { }\n" }, { "path": "tasty/data/complex/principle-of-explosion-type.ffg", "content": "forall (a : Type) . < > -> a\n" }, { "path": "tasty/data/complex/quantifiers-input.ffg", "content": "let x : forall (a : Type) (b : Type) . { } = { } in x\n" }, { "path": "tasty/data/complex/quantifiers-output.ffg", "content": "{ }\n" }, { "path": "tasty/data/complex/quantifiers-type.ffg", "content": "{ }\n" }, { "path": "tasty/data/complex/quoted-label-input.ffg", "content": "let .'The Identity Function' .'Function Argument' = .'Function Argument'\n\nin .'The Identity Function' 1\n" }, { "path": "tasty/data/complex/quoted-label-output.ffg", "content": "1\n" }, { "path": "tasty/data/complex/quoted-label-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/complex/read-input.ffg", "content": "(read \"{ \\\"x\\\": 1 }\").x\n" }, { "path": "tasty/data/complex/read-output.ffg", "content": "1\n" }, { "path": "tasty/data/complex/read-type.ffg", "content": "JSON\n" }, { "path": "tasty/data/complex/record-mismatch-both-extra-input.ffg", "content": "[ { x: 1 }, { y: 1 } ]\n" }, { "path": "tasty/data/complex/record-mismatch-both-extra-output.ffg", "content": "[ { \"x\": some 1, \"y\": null }, { \"y\": some 1, \"x\": null } ]\n" }, { "path": "tasty/data/complex/record-mismatch-both-extra-type.ffg", "content": "List { x: Optional Natural, y: Optional Natural }\n" }, { "path": "tasty/data/complex/record-mismatch-left-extra-input.ffg", "content": "[ { x: 1 }, { } ]\n" }, { "path": "tasty/data/complex/record-mismatch-left-extra-output.ffg", "content": "[ { \"x\": some 1 }, { \"x\": null } ]\n" }, { "path": "tasty/data/complex/record-mismatch-left-extra-type.ffg", "content": "List { x: Optional Natural }\n" }, { "path": "tasty/data/complex/record-mismatch-right-extra-input.ffg", "content": "[ { }, { x: 1 } ]\n" }, { "path": "tasty/data/complex/record-mismatch-right-extra-output.ffg", "content": "[ { \"x\": null }, { \"x\": some 1 } ]\n" }, { "path": "tasty/data/complex/record-mismatch-right-extra-type.ffg", "content": "List { x: Optional Natural }\n" }, { "path": "tasty/data/complex/record-mismatch-two-extra-input.ffg", "content": "[ { x: 1, y: 2 }, { } ]\n" }, { "path": "tasty/data/complex/record-mismatch-two-extra-output.ffg", "content": "[ { \"x\": some 1, \"y\": some 2 }, { \"x\": null, \"y\": null } ]\n" }, { "path": "tasty/data/complex/record-mismatch-two-extra-type.ffg", "content": "List { x: Optional Natural, y: Optional Natural }\n" }, { "path": "tasty/data/complex/remote-transitive-import-input.ffg", "content": "# This test verifies that transitive relative imports work for remote imports\nhttps://gist.githubusercontent.com/Gabriella439/c092e646209d638ba34d74f7b08c91e3/raw/de5741f2ca5a9ddd118b6e4e91f7d3f571466c52/x.ffg\n" }, { "path": "tasty/data/complex/remote-transitive-import-output.ffg", "content": "1\n" }, { "path": "tasty/data/complex/remote-transitive-import-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/complex/restrict-project-input.ffg", "content": "# This should return `null` and have type `forall (a : Type) . Optional a`\n# because restricting the underlying record value to the empty record type\n# deletes all the fields.\n({ x: 1 } : { }).x\n" }, { "path": "tasty/data/complex/restrict-project-output.ffg", "content": "null\n" }, { "path": "tasty/data/complex/restrict-project-type.ffg", "content": "forall (a : Type) . Optional a\n" }, { "path": "tasty/data/complex/separators-input.ffg", "content": "# This test verifies that trailing and leading separators are supported\n\n{ example0: [ , 1, 2, 3, ]\n, example1: { , x: 1, y: true, }\n, example2:\n (\\x -> x)\n : forall (a : Fields)\n . { , x : Integer, y: Bool, a, } -> { , x : Integer, y: Bool, a, }\n, example3: \\x -> x : < | A : Natural | B : Bool | >\n, example4:\n (\\x -> x)\n : forall (a : Alternatives)\n . < | A : Natural | B : Bool | a | > -> < | A : Natural | B : Bool | a | >\n}\n" }, { "path": "tasty/data/complex/separators-output.ffg", "content": "{ \"example0\":\n [ 1, 2, 3 ]\n, \"example1\":\n { \"x\": 1, \"y\": true }\n, \"example2\":\n \\x -> x\n, \"example3\":\n \\x -> x : < A: Natural | B: Bool >\n, \"example4\":\n \\x -> x\n}\n" }, { "path": "tasty/data/complex/separators-type.ffg", "content": "forall (a : Alternatives) .\nforall (b : Fields) .\n { example0:\n List Natural\n , example1:\n { x: Natural, y: Bool }\n , example2:\n { x: Integer, y: Bool, b } -> { x: Integer, y: Bool, b }\n , example3:\n < A: Natural | B: Bool > -> < A: Natural | B: Bool >\n , example4:\n < A: Natural | B: Bool | a > -> < A: Natural | B: Bool | a >\n }\n" }, { "path": "tasty/data/complex/show-input.ffg", "content": "show\n { bool: true\n , list: [ 2, 3, 5 ]\n , null: null\n }\n" }, { "path": "tasty/data/complex/show-output.ffg", "content": "\"{\\\"bool\\\":true,\\\"list\\\":[2,3,5],\\\"null\\\":null}\"\n" }, { "path": "tasty/data/complex/show-type.ffg", "content": "Text\n" }, { "path": "tasty/data/complex/skolem-function-type-input.ffg", "content": "# The following test exercises the case where a universally quantified variable\n# cannot necessarily be treated as a function type\nlet f : forall (a : Type) . a -> a = \\x -> x 1 in f\n" }, { "path": "tasty/data/complex/skolem-function-type-stderr.txt", "content": "Not necessarily a function type\n\nThe following type variable:\n\n a\n\n… could potentially be any type and is not necessarily a function type.\n\ntasty/data/complex/skolem-function-type-input.ffg:3:29: \n │\n3 │ let f : forall (a : Type) . a -> a = \\x -> x 1 in f\n │ ↑" }, { "path": "tasty/data/complex/slice-input.ffg", "content": "let list = [ 2, 3, 5, 7, 11, 13, 17 ]\n\nin { \"slicing an empty list always return null\":\n [][:]\n , \"otherwise, [:] returns the entire list\":\n list[:]\n , \"[:] is equivalent to [0:0]\":\n list[0:0]\n , \"[n:n] returns the entire list starting and ending at element n\":\n list[3:3]\n , \"[m:n] returns the mth element up to and not including the mth element\":\n list[3:5]\n , \"[n:] drops the first n elements of the list\":\n list[3:]\n , \"[n:] is equivalent to [n:0]\":\n list[3:0]\n , \"[:-n] drops the last n elements of the list\":\n list[:-3]\n , \"[:n] is equivalent to [0:n]\":\n list[0:-3]\n , \"slice indices do not need to be in order\":\n list[5:3]\n , \"both slice indices can be negative\":\n list[-3:-1]\n , \"both slice indices can be past the end of the list\":\n list[8:10]\n }\n" }, { "path": "tasty/data/complex/slice-output.ffg", "content": "{ \"slicing an empty list always return null\":\n null\n, \"otherwise, [:] returns the entire list\":\n some [ 2, 3, 5, 7, 11, 13, 17 ]\n, \"[:] is equivalent to [0:0]\":\n some [ 2, 3, 5, 7, 11, 13, 17 ]\n, \"[n:n] returns the entire list starting and ending at element n\":\n some [ 7, 11, 13, 17, 2, 3, 5 ]\n, \"[m:n] returns the mth element up to and not including the mth element\":\n some [ 7, 11 ]\n, \"[n:] drops the first n elements of the list\":\n some [ 7, 11, 13, 17 ]\n, \"[n:] is equivalent to [n:0]\":\n some [ 7, 11, 13, 17 ]\n, \"[:-n] drops the last n elements of the list\":\n some [ 2, 3, 5, 7 ]\n, \"[:n] is equivalent to [0:n]\":\n some [ 2, 3, 5, 7 ]\n, \"slice indices do not need to be in order\":\n some [ 13, 17, 2, 3, 5 ]\n, \"both slice indices can be negative\":\n some [ 11, 13 ]\n, \"both slice indices can be past the end of the list\":\n some [ 3, 5 ]\n}\n" }, { "path": "tasty/data/complex/slice-type.ffg", "content": "forall (a : Type) .\n { \"slicing an empty list always return null\":\n Optional (List a)\n , \"otherwise, [:] returns the entire list\":\n Optional (List Natural)\n , \"[:] is equivalent to [0:0]\":\n Optional (List Natural)\n , \"[n:n] returns the entire list starting and ending at element n\":\n Optional (List Natural)\n , \"[m:n] returns the mth element up to and not including the mth element\":\n Optional (List Natural)\n , \"[n:] drops the first n elements of the list\":\n Optional (List Natural)\n , \"[n:] is equivalent to [n:0]\":\n Optional (List Natural)\n , \"[:-n] drops the last n elements of the list\":\n Optional (List Natural)\n , \"[:n] is equivalent to [0:n]\":\n Optional (List Natural)\n , \"slice indices do not need to be in order\":\n Optional (List Natural)\n , \"both slice indices can be negative\":\n Optional (List Natural)\n , \"both slice indices can be past the end of the list\":\n Optional (List Natural)\n }\n" }, { "path": "tasty/data/complex/solve-fields-input.ffg", "content": "# The purpose of this test is to exercise instantiation of unsolved fields\n# variables\n\\r -> \\s ->\n\nlet _ = [ r.x, 1 ]\n\nlet _ = [ s.y, 1 ]\n\nin { a: [ r, { x: 1, z: 1 } ], b: [ { y: 1, z: 1 }, s ] }\n" }, { "path": "tasty/data/complex/solve-fields-output.ffg", "content": "\\r ->\n\\s ->\n let _ = [ r.x, 1 ]\n\n let _ = [ s.y, 1 ]\n\n in { \"a\": [ r, { \"x\": 1, \"z\": 1 } ], \"b\": [ { \"y\": 1, \"z\": 1 }, s ] }\n" }, { "path": "tasty/data/complex/solve-fields-type.ffg", "content": "{ x: Natural, z: Natural } ->\n{ y: Natural, z: Natural } ->\n { a: List { x: Natural, z: Natural }, b: List { y: Natural, z: Natural } }\n" }, { "path": "tasty/data/complex/solve-unused-impredicative-polymorphism-input.ffg", "content": "# This test exercises solving a variable to a valid impredicative type\n\\x -> x : List (forall (a : Type) . Bool)\n" }, { "path": "tasty/data/complex/solve-unused-impredicative-polymorphism-output.ffg", "content": "\\x -> x : List (forall (a : Type) . Bool)\n" }, { "path": "tasty/data/complex/solve-unused-impredicative-polymorphism-type.ffg", "content": "List Bool -> List Bool\n" }, { "path": "tasty/data/complex/subtype-function-input.ffg", "content": "(\\(x : Integer) -> x) : Natural -> Integer\n" }, { "path": "tasty/data/complex/subtype-function-output.ffg", "content": "\\a -> (\\(x : Integer) -> x) (a : Integer)\n" }, { "path": "tasty/data/complex/subtype-function-type.ffg", "content": "Natural -> Integer\n" }, { "path": "tasty/data/complex/triple-field-input.ffg", "content": "# This is a regression test for an expression that used to break the\n# type-checker's support for row polymorphism\n\\x -> x.a && x.b && x.c\n" }, { "path": "tasty/data/complex/triple-field-output.ffg", "content": "\\x -> x.a && x.b && x.c\n" }, { "path": "tasty/data/complex/triple-field-type.ffg", "content": "forall (a : Fields) . { a: Bool, b: Bool, c: Bool, a } -> Bool\n" }, { "path": "tasty/data/complex/triple-supertype-input.ffg", "content": "# This test ensures that a supertype of 3 or more values doesn't wrap optional\n# fields in more than one layer of `Optional`. The expected type should be\n#\n# List { x: Optional Natural, y: Optional Natural, z: Optional Natural }\n#\n# … and not something like:\n#\n# List\n# { x: Optional (Optional Natural)\n# , y: Optional (Optional Natural)\n# , z: Optional Natural\n# }\n#\n# More generally, getting this correct ensures that the most-specific supertype\n# operation is associative and commutative.\n[ { x: 1 }, { y: 1 }, { z: 1 } ]\n" }, { "path": "tasty/data/complex/triple-supertype-output.ffg", "content": "[ { \"x\": some 1, \"y\": null, \"z\": null }\n, { \"y\": some 1, \"x\": null, \"z\": null }\n, { \"z\": some 1, \"x\": null, \"y\": null }\n]\n" }, { "path": "tasty/data/complex/triple-supertype-type.ffg", "content": "List { x: Optional Natural, y: Optional Natural, z: Optional Natural }\n" }, { "path": "tasty/data/complex/unbound-alternatives-variable-input.ffg", "content": "# This test exercises the error message for unbound alternatives variables\nLeft 1 : < Left : Natural | a >\n" }, { "path": "tasty/data/complex/unbound-alternatives-variable-stderr.txt", "content": "Unbound alternatives variable: a\n\ntasty/data/complex/unbound-alternatives-variable-input.ffg:2:10: \n │\n2 │ Left 1 : < Left : Natural | a >\n │ ↑" }, { "path": "tasty/data/complex/unbound-fields-variable-input.ffg", "content": "# This test exercises the error message for unbound fields variables\n{ } : { a }\n" }, { "path": "tasty/data/complex/unbound-fields-variable-stderr.txt", "content": "Unbound fields variable: a\n\ntasty/data/complex/unbound-fields-variable-input.ffg:2:7: \n │\n2 │ { } : { a }\n │ ↑" }, { "path": "tasty/data/complex/undo-elaboration-input.ffg", "content": "# This is a regression test for:\n#\n# https://github.com/Gabriella439/grace/pull/175#issuecomment-3449878560\nlet { x = 0, y } = { x: 1, y: 2 } in x + y\n" }, { "path": "tasty/data/complex/undo-elaboration-output.ffg", "content": "3\n" }, { "path": "tasty/data/complex/undo-elaboration-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/complex/unify-json-input.ffg", "content": "# The purpose of this test is to exercise the JSON subtyping rules\n\n\\(x : JSON) ->\n [ x, \"hi\", [ 1, 2 ], some true, { x: \"bye\" } ]\n" }, { "path": "tasty/data/complex/unify-json-output.ffg", "content": "\\x -> [ x, \"hi\", [ 1, 2 ] : JSON, some true, { \"x\": \"bye\" } ]\n" }, { "path": "tasty/data/complex/unify-json-type.ffg", "content": "JSON -> List JSON\n" }, { "path": "tasty/data/complex/unify-null-input.ffg", "content": "# This test illustrates that you can unify `null` with other types so long as\n# you provide a type annotation, since the interpreter will automatically wrap\n# the non-`null` values with a `some` in the course of interpretation (and then\n# strip the `some` in the final result)\n[ null, 1 ] : List (Optional Natural)\n" }, { "path": "tasty/data/complex/unify-null-output.ffg", "content": "[ null, some 1 ]\n" }, { "path": "tasty/data/complex/unify-null-type.ffg", "content": "List (Optional Natural)\n" }, { "path": "tasty/data/complex/unify-unsolved-input.ffg", "content": "# Exercise unsolved variables for certain unification code paths\n\\r s x ->\n\nlet a = r.x\n\nlet b = s.y\n\nlet c = L 1\n\nlet d = R true\n\nin { example0: [ r, s ]\n , example1: [ r, r ]\n , example2: [ c, d ]\n , example3: [ c, c ]\n , example4: [ x, x ]\n }\n" }, { "path": "tasty/data/complex/unify-unsolved-output.ffg", "content": "\\r ->\n\\s ->\n\\x ->\n let a = r.x\n\n let b = s.y\n\n let c = L 1\n\n let d = R true\n\n in { \"example0\":\n [ r, s ]\n , \"example1\":\n [ r, r ]\n , \"example2\":\n [ c, d ]\n , \"example3\":\n [ c, c ]\n , \"example4\":\n [ x, x ]\n }\n" }, { "path": "tasty/data/complex/unify-unsolved-type.ffg", "content": "forall (a : Type) .\nforall (b : Alternatives) .\nforall (c : Type) .\nforall (d : Type) .\nforall (e : Fields) .\n { x: d, y: c, e } ->\n { y: c, x: d, e } ->\n a ->\n { example0:\n List { x: d, y: c, e }\n , example1:\n List { x: d, y: c, e }\n , example2:\n List < L: Natural | R: Bool | b >\n , example3:\n List < L: Natural | R: Bool | b >\n , example4:\n List a\n }\n" }, { "path": "tasty/data/complex/unused-impredicative-polymorphism-input.ffg", "content": "# This test exercises impredicative polymorphism that is unused, which is the\n# only case where impredicative polymorphism is permitted.\n[ true ] : List (forall (a : Type) . Bool)\n" }, { "path": "tasty/data/complex/unused-impredicative-polymorphism-output.ffg", "content": "[ true ]\n" }, { "path": "tasty/data/complex/unused-impredicative-polymorphism-type.ffg", "content": "List (forall (a : Type) . Bool)\n" }, { "path": "tasty/data/complex/unused-polymorphism-input.ffg", "content": "# This exercises the <:∀R rule of the type inference algorithm\n{ x: true } : { x: forall (a : Type) . Bool }\n" }, { "path": "tasty/data/complex/unused-polymorphism-output.ffg", "content": "{ \"x\": true }\n" }, { "path": "tasty/data/complex/unused-polymorphism-type.ffg", "content": "{ x: forall (a : Type) . Bool }\n" }, { "path": "tasty/data/complex/use-equation-input.ffg", "content": "# This test exercises weird code paths for the `equate*` unification utilities\n\\a ->\n\\r ->\n\n\\b ->\n\\u ->\n\nlet # This forces `r`'s type to be instantiated to a record with an unsolved\n # fields variable\n field0 = [ true, r.x ]\n\nin { # This triggers instantiation of `a`'s unsolved type to a record type with\n # an unsolved fields variable\n field1: [ r, a ]\n\n # This triggers instantiation of `b`'s unsolved type to a union type with\n # an unsolved alternatives variable\n , field2: [ L 1, b ]\n }\n" }, { "path": "tasty/data/complex/use-equation-output.ffg", "content": "\\a ->\n\\r ->\n\\b ->\n\\u ->\n let field0 = [ true, r.x ] in { \"field1\": [ r, a ], \"field2\": [ L 1, b ] }\n" }, { "path": "tasty/data/complex/use-equation-type.ffg", "content": "forall (a : Alternatives) .\nforall (b : Fields) .\nforall (c : Type) .\n { x: Bool, b } ->\n { x: Bool, b } ->\n < L: Natural | a > ->\n c ->\n { field1: List { x: Bool, b }, field2: List < L: Natural | a > }\n" }, { "path": "tasty/data/complex/well-formed-input.ffg", "content": "# The purpose of this test is to exercise weird code paths for the well-formed\n# type check\n{ example0: (\\r -> r) : forall (a : Fields) . forall (b : Type) . { a } -> { a }\n, example1: (\\u -> u) : forall (a : Alternatives) . forall (b : Type) . < a > -> < a >\n}\n" }, { "path": "tasty/data/complex/well-formed-output.ffg", "content": "{ \"example0\": \\r -> r, \"example1\": \\u -> u }\n" }, { "path": "tasty/data/complex/well-formed-type.ffg", "content": "forall (a : Alternatives) .\nforall (b : Fields) .\n { example0: { b } -> { b }, example1: < a > -> < a > }\n" }, { "path": "tasty/data/complex/yaml-input.ffg", "content": "yaml\n { multiline: \"ab\\ncd\\n\"\n , elements: [ 1, 2, 3 ]\n , bool: true\n , real: -2.3\n }\n" }, { "path": "tasty/data/complex/yaml-output.ffg", "content": "\"\n'bool': true\n'elements':\n - 1\n - 2\n - 3\n'multiline': |\n ab\n cd\n'real': -2.3\n\"\n" }, { "path": "tasty/data/complex/yaml-type.ffg", "content": "Text\n" }, { "path": "tasty/data/error/for-naked-input.ffg", "content": "for x of 1 in x\n" }, { "path": "tasty/data/error/for-naked-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n Natural\n\ntasty/data/error/for-naked-input.ffg:1:10: \n │\n1 │ for x of 1 in x\n │ ↑\n\n… is not a subtype of:\n\n List a?\n\ntasty/data/error/for-naked-input.ffg:1:1: \n │\n1 │ for x of 1 in x\n │ ↑" }, { "path": "tasty/data/error/parse/eof-input.ffg", "content": "[\n" }, { "path": "tasty/data/error/parse/eof-stderr.txt", "content": "tasty/data/error/parse/eof-input.ffg:2:1: Invalid input - Parsing failed\n │\n2 │ \n │ ↑" }, { "path": "tasty/data/error/parse/incomplete-escape-input.ffg", "content": "\"\\ \"\n" }, { "path": "tasty/data/error/parse/incomplete-escape-stderr.txt", "content": "tasty/data/error/parse/incomplete-escape-input.ffg:1:2: Invalid input - Lexing failed\n │\n1 │ \"\\ \"\n │ ↑" }, { "path": "tasty/data/error/parse/incomplete-interpolation-input.ffg", "content": "\"a${\"b\" +}d\"\n" }, { "path": "tasty/data/error/parse/incomplete-interpolation-stderr.txt", "content": "tasty/data/error/parse/incomplete-interpolation-input.ffg:1:10: Invalid input - Lexing failed\n │\n1 │ \"a${\"b\" +}d\"\n │ ↑" }, { "path": "tasty/data/error/parse/incomplete-string-input.ffg", "content": "\"a${\"b\" + \"c\"}\n" }, { "path": "tasty/data/error/parse/incomplete-string-stderr.txt", "content": "tasty/data/error/parse/incomplete-string-input.ffg:1:15: Invalid input - Lexing failed\n │\n1 │ \"a${\"b\" + \"c\"}\n │ ↑" }, { "path": "tasty/data/error/parse/invalid-multiline-input.ffg", "content": "\"abc\n\"\n" }, { "path": "tasty/data/error/parse/invalid-multiline-stderr.txt", "content": "tasty/data/error/parse/invalid-multiline-input.ffg:1:5: Invalid input - Lexing failed\n │\n1 │ \"abc\n │ ↑" }, { "path": "tasty/data/error/parse/unbalanced-bracket-input.ffg", "content": "1 ]\n" }, { "path": "tasty/data/error/parse/unbalanced-bracket-stderr.txt", "content": "tasty/data/error/parse/unbalanced-bracket-input.ffg:1:3: Invalid input - Parsing failed\n │\n1 │ 1 ]\n │ ↑" }, { "path": "tasty/data/error/parse/unrecognized-symbol-input.ffg", "content": "True & False\n" }, { "path": "tasty/data/error/parse/unrecognized-symbol-stderr.txt", "content": "tasty/data/error/parse/unrecognized-symbol-input.ffg:1:7: Invalid input - Lexing failed\n │\n1 │ True & False\n │ ↑" }, { "path": "tasty/data/error/resolve/empty-environment-variable-input.ffg", "content": "env:\n" }, { "path": "tasty/data/error/resolve/empty-environment-variable-stderr.txt", "content": "Import resolution failed: env:\n\nMissing path" }, { "path": "tasty/data/error/resolve/environment-authority-input.ffg", "content": "env://foo/bar\n" }, { "path": "tasty/data/error/resolve/environment-authority-stderr.txt", "content": "Import resolution failed: env://foo/bar\n\nUnsupported authority" }, { "path": "tasty/data/error/resolve/environment-leading-slash-input.ffg", "content": "env:/foo\n" }, { "path": "tasty/data/error/resolve/environment-leading-slash-stderr.txt", "content": "Import resolution failed: env:/foo\n\nUnsupported path separators" }, { "path": "tasty/data/error/resolve/environment-missing-input.ffg", "content": "env:Eechiqu4sooCoy8aisei\n" }, { "path": "tasty/data/error/resolve/environment-missing-stderr.txt", "content": "Import resolution failed: env:Eechiqu4sooCoy8aisei\n\nMissing environment variable" }, { "path": "tasty/data/error/resolve/environment-variable-slash-input.ffg", "content": "env:foo/\n" }, { "path": "tasty/data/error/resolve/environment-variable-slash-stderr.txt", "content": "Import resolution failed: env:foo/\n\nUnsupported path separators" }, { "path": "tasty/data/error/resolve/file-authority-input.ffg", "content": "file://a/b\n" }, { "path": "tasty/data/error/resolve/file-authority-stderr.txt", "content": "Import resolution failed: file://a/b\n\nUnsupported authority" }, { "path": "tasty/data/error/resolve/file-missing-path-input.ffg", "content": "file:\n" }, { "path": "tasty/data/error/resolve/file-missing-path-stderr.txt", "content": "Import resolution failed: file:\n\nMissing path" }, { "path": "tasty/data/error/resolve/host-not-found-input.ffg", "content": "https://MaiYohngaz6jiaWieYea\n" }, { "path": "tasty/data/error/resolve/host-not-found-stderr.txt", "content": "Import resolution failed: https://maiyohngaz6jiawieyea\n\nRemote host not found" }, { "path": "tasty/data/error/resolve/invalid-destination-host-input.ffg", "content": "http://:80\n" }, { "path": "tasty/data/error/resolve/invalid-destination-host-stderr.txt", "content": "Import resolution failed: http://:80\n\nInvalid remote host name" }, { "path": "tasty/data/error/resolve/invalid-utf8-input.ffg", "content": "https://raw.githubusercontent.com/dhall-lang/dhall-lang/1907a1d1a6dff9ff8638547f7bc49d6b5135bcdf/tests/parser/success/reservedPrefixB.dhallb\n" }, { "path": "tasty/data/error/resolve/invalid-utf8-stderr.txt", "content": "Import resolution failed: https://raw.githubusercontent.com/dhall-lang/dhall-lang/1907a1d1a6dff9ff8638547f7bc49d6b5135bcdf/tests/parser/success/reservedPrefixB.dhallb\n\nNot UTF8\n\nCannot decode byte '\\x85': Data.Text.Internal.Encoding: Invalid UTF-8 stream" }, { "path": "tasty/data/error/resolve/read-invalid-json-input.ffg", "content": "read \"{\"\n" }, { "path": "tasty/data/error/resolve/read-invalid-json-stderr.txt", "content": "Failed to decode output as JSON\n\nThe following text:\n\n{\n\n… to decode as JSON.\n\nDecoding error message:\n\nError in $: not enough input" }, { "path": "tasty/data/error/resolve/remote-invalid-parse-input.ffg", "content": "https://raw.githubusercontent.com/Gabriel439/grace/164038e0277c2c9f08c9e4528d493d316e85bb76/README.md\n" }, { "path": "tasty/data/error/resolve/remote-invalid-parse-stderr.txt", "content": "https://raw.githubusercontent.com/Gabriel439/grace/164038e0277c2c9f08c9e4528d493d316e85bb76/README.md:11:75: Invalid input - Lexing failed\n │\n11 │ * You're interested in learning more about state-of-the-art algorithms for\n │ ↑" }, { "path": "tasty/data/error/resolve/remote-referentially-insane-input.ffg", "content": "https://gist.githubusercontent.com/Gabriella439/7dce61ec95e1c38ecf14448eef7dd827/raw/fbb01f2afb0eaa98ea0e1bd1d4bb1e8fe482b081/test.ffg\n" }, { "path": "tasty/data/error/resolve/remote-referentially-insane-stderr.txt", "content": "Import resolution failed: https://gist.githubusercontent.com/Gabriella439/7dce61ec95e1c38ecf14448eef7dd827/raw/fbb01f2afb0eaa98ea0e1bd1d4bb1e8fe482b081/test.ffg\n\nLocal imports are rejected within remote imports\n\nRejected local import: env:FOO" }, { "path": "tasty/data/error/type/alternatives-variable-input.ffg", "content": "[ Left 1 : forall (a : Alternatives) . < Left: Natural | a >\n, Right true : forall (b : Alternatives) . < Right: Bool | b >\n]\n" }, { "path": "tasty/data/error/type/alternatives-variable-stderr.txt", "content": "Alternatives variable mismatch\n\nThis alternatives variable:\n\n a\n\ntasty/data/error/type/alternatives-variable-input.ffg:1:40: \n │\n1 │ [ Left 1 : forall (a : Alternatives) . < Left: Natural | a >\n │ ↑\n\n… and this alternatives variable:\n\n b\n\ntasty/data/error/type/alternatives-variable-input.ffg:2:44: \n │\n2 │ , Right true : forall (b : Alternatives) . < Right: Bool | b >\n │ ↑\n\n… cannot be unified" }, { "path": "tasty/data/error/type/bad-type-annotation-input.ffg", "content": "1 : Text\n" }, { "path": "tasty/data/error/type/bad-type-annotation-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n Natural\n\ntasty/data/error/type/bad-type-annotation-input.ffg:1:1: \n │\n1 │ 1 : Text\n │ ↑\n\n… is not a subtype of:\n\n Text\n\ntasty/data/error/type/bad-type-annotation-input.ffg:1:5: \n │\n1 │ 1 : Text\n │ ↑" }, { "path": "tasty/data/error/type/destructure-missing-required-input.ffg", "content": "let { x: Natural } = { } in x\n" }, { "path": "tasty/data/error/type/destructure-missing-required-stderr.txt", "content": "Record type mismatch\n\nThe following record type:\n\n { }\n\ntasty/data/error/type/destructure-missing-required-input.ffg:1:22: \n │\n1 │ let { x: Natural } = { } in x\n │ ↑\n\n… is not a subtype of the following record type:\n\n { x: Natural, b? }\n\ntasty/data/error/type/destructure-missing-required-input.ffg:1:5: \n │\n1 │ let { x: Natural } = { } in x\n │ ↑\n\nThe latter record has the following extra fields:\n\n• x" }, { "path": "tasty/data/error/type/dynamic-scope-input.ffg", "content": "# This is a regression test for: https://github.com/Gabriella439/grace/issues/67\n#\n# This verifies that `let` bindings are lexically scoped\nlet x = (let y = 4 in y) in y\n" }, { "path": "tasty/data/error/type/dynamic-scope-stderr.txt", "content": "Unbound variable: y\n\ntasty/data/error/type/dynamic-scope-input.ffg:4:29: \n │\n4 │ let x = (let y = 4 in y) in y\n │ ↑" }, { "path": "tasty/data/error/type/fields-variable-mismatch-input.ffg", "content": "let f : forall (a : Fields) . forall (b : Fields) . { a } -> { b } -> { a }\n = \\x -> \\y -> y\n\nin f\n" }, { "path": "tasty/data/error/type/fields-variable-mismatch-stderr.txt", "content": "Record type mismatch\n\nThe following record type:\n\n { b }\n\ntasty/data/error/type/fields-variable-mismatch-input.ffg:1:62: \n │\n1 │ let f : forall (a : Fields) . forall (b : Fields) . { a } -> { b } -> { a }\n │ ↑\n\n… is not a subtype of the following record type:\n\n { a }\n\ntasty/data/error/type/fields-variable-mismatch-input.ffg:1:71: \n │\n1 │ let f : forall (a : Fields) . forall (b : Fields) . { a } -> { b } -> { a }\n │ ↑" }, { "path": "tasty/data/error/type/fold-missing-field-input.ffg", "content": "# `fold`s can in some cases tolerate missing fields. For example, this is a\n# valid `fold`:\n#\n# fold{ succ x: x }\n#\n# … which elaborates to:\n#\n# fold{ succ x: x, zero: null } : forall (a : Type) . Natural -> Optional a\n#\n# … but you cannot do it the other way around (keep `zero` and omit the `succ`),\n# because it is not a valid `fold` no matter how you interpret it. If you\n# attempt to interpret it as a `fold` for `Natural` numbers the expression is\n# elaborated to:\n#\n# fold{ succ: null, zero: 0 }\n#\n# … which doesn't work because the `succ` handler needs to be a function (and\n# `null` is not a function). However, it also doesn't work if you fall back to\n# treating it as a fold for a union, because a fold for a union requires all\n# handlers to be functions (and `0` is not a function).\nfold{ zero: 0 }\n" }, { "path": "tasty/data/error/type/fold-missing-field-stderr.txt", "content": "Record type mismatch\n\nThe following record type:\n\n { }\n\ntasty/data/error/type/fold-missing-field-input.ffg:21:5: \n │\n21 │ fold{ zero: 0 }\n │ ↑\n\n… is not a subtype of the following record type:\n\n { succ: Natural -> Natural }\n\ntasty/data/error/type/fold-missing-field-input.ffg:21:1: \n │\n21 │ fold{ zero: 0 }\n │ ↑\n\nThe latter record has the following extra fields:\n\n• succ" }, { "path": "tasty/data/error/type/fold-typo-field-input.ffg", "content": "# If at least one field is recognized as belonging to a reserved `fold` (e.g. \n# the `false` field belongs to the reserved `fold` for `Bool`s) then other\n# unexpected fields (e.g. a typo) will be rejected by the type checker.\nfold{ false: 0, tru: 1 }\n" }, { "path": "tasty/data/error/type/fold-typo-field-stderr.txt", "content": "Not a function type\n\nAn expression of the following type:\n\n Natural\n\ntasty/data/error/type/fold-typo-field-input.ffg:4:14: \n │\n4 │ fold{ false: 0, tru: 1 }\n │ ↑\n\n… was invoked as if it were a function, but the above type is not a function\ntype." }, { "path": "tasty/data/error/type/for-annotation-input.ffg", "content": "(for x of [] in x + 1) : List Text\n" }, { "path": "tasty/data/error/type/for-annotation-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n Natural\n\ntasty/data/error/type/for-annotation-input.ffg:1:21: \n │\n1 │ (for x of [] in x + 1) : List Text\n │ ↑\n\n… is not a subtype of:\n\n Text\n\ntasty/data/error/type/for-annotation-input.ffg:1:31: \n │\n1 │ (for x of [] in x + 1) : List Text\n │ ↑" }, { "path": "tasty/data/error/type/for-mixed-input.ffg", "content": "for x of [ 1, 2, 3 ]\n\nfor y of some 4\n\nin x + y\n" }, { "path": "tasty/data/error/type/for-mixed-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n Optional Natural\n\ntasty/data/error/type/for-mixed-input.ffg:3:10: \n │\n3 │ for y of some 4\n │ ↑\n\n… is not a subtype of:\n\n List Natural\n\ntasty/data/error/type/for-mixed-input.ffg:3:1: \n │\n3 │ for y of some 4\n │ ↑" }, { "path": "tasty/data/error/type/impredicative-instantiation-input.ffg", "content": "# This test verifies that impredicative instantiation of polymorphic types is\n# not permitted\nlet f : forall (a : Type) . a -> a\n = \\x -> x\n\nlet g : (forall (b : Type) . b -> b) -> (forall (c : Type) . c -> c)\n = f\n\nin g\n" }, { "path": "tasty/data/error/type/impredicative-instantiation-stderr.txt", "content": "Unbound type variable: b\n\ntasty/data/error/type/impredicative-instantiation-input.ffg:6:30: \n │\n6 │ let g : (forall (b : Type) . b -> b) -> (forall (c : Type) . c -> c)\n │ ↑" }, { "path": "tasty/data/error/type/impredicative-polymorphism-input.ffg", "content": "[ \\x -> x ] : List (forall (a : Type) . a -> a)\n" }, { "path": "tasty/data/error/type/impredicative-polymorphism-output.ffg", "content": "[ \\x -> x ]\n" }, { "path": "tasty/data/error/type/impredicative-polymorphism-type.ffg", "content": "List (forall (a : Type) . a -> a)\n" }, { "path": "tasty/data/error/type/index-slice-input.ffg", "content": "# This should fail because a slice returns an `Optional`\n[{ }][0:].0\n" }, { "path": "tasty/data/error/type/index-slice-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n Optional (List { })\n\ntasty/data/error/type/index-slice-input.ffg:2:1: \n │\n2 │ [{ }][0:].0\n │ ↑\n\n… is not a subtype of:\n\n List a?\n\ntasty/data/error/type/index-slice-input.ffg:2:1: \n │\n2 │ [{ }][0:].0\n │ ↑" }, { "path": "tasty/data/error/type/invalid-argument-input.ffg", "content": "let f (x : Natural) = x\n\nin f \"\"\n" }, { "path": "tasty/data/error/type/invalid-argument-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n Text\n\ntasty/data/error/type/invalid-argument-input.ffg:3:7: \n │\n3 │ in f \"\"\n │ ↑\n\n… is not a subtype of:\n\n Natural\n\ntasty/data/error/type/invalid-argument-input.ffg:1:12: \n │\n1 │ let f (x : Natural) = x\n │ ↑" }, { "path": "tasty/data/error/type/invalid-handler-input.ffg", "content": "fold { x: 1 }\n" }, { "path": "tasty/data/error/type/invalid-handler-stderr.txt", "content": "Not a function type\n\nAn expression of the following type:\n\n Natural\n\ntasty/data/error/type/invalid-handler-input.ffg:1:11: \n │\n1 │ fold { x: 1 }\n │ ↑\n\n… was invoked as if it were a function, but the above type is not a function\ntype." }, { "path": "tasty/data/error/type/invalid-plus-annotation-input.ffg", "content": "# This exercises the failing case for checking an addition\n(true + true) : Bool\n" }, { "path": "tasty/data/error/type/invalid-plus-annotation-stderr.txt", "content": "Invalid operands\n\nYou cannot add the following operands:\n\ntasty/data/error/type/invalid-plus-annotation-input.ffg:2:2: \n │\n2 │ (true + true) : Bool\n │ ↑\n\ntasty/data/error/type/invalid-plus-annotation-input.ffg:2:9: \n │\n2 │ (true + true) : Bool\n │ ↑" }, { "path": "tasty/data/error/type/invalid-plus-operands-input.ffg", "content": "# This test exercises the error message if you add invalid types\ntrue + true\n" }, { "path": "tasty/data/error/type/invalid-plus-operands-stderr.txt", "content": "Invalid operands\n\nYou cannot add the following operands:\n\ntasty/data/error/type/invalid-plus-operands-input.ffg:2:1: \n │\n2 │ true + true\n │ ↑\n\ntasty/data/error/type/invalid-plus-operands-input.ffg:2:8: \n │\n2 │ true + true\n │ ↑" }, { "path": "tasty/data/error/type/invalid-times-annotation-input.ffg", "content": "# This exercises the failing case for checking a multiplication\n(true * true) : Bool\n\n" }, { "path": "tasty/data/error/type/invalid-times-annotation-stderr.txt", "content": "Invalid operands\n\nYou cannot multiply the following operands:\n\ntasty/data/error/type/invalid-times-annotation-input.ffg:2:2: \n │\n2 │ (true * true) : Bool\n │ ↑\n\ntasty/data/error/type/invalid-times-annotation-input.ffg:2:9: \n │\n2 │ (true * true) : Bool\n │ ↑" }, { "path": "tasty/data/error/type/invalid-times-operands-input.ffg", "content": "# This test exercises the error message if you multiply invalid types\ntrue * true\n" }, { "path": "tasty/data/error/type/invalid-times-operands-stderr.txt", "content": "Invalid operands\n\nYou cannot multiply the following operands:\n\ntasty/data/error/type/invalid-times-operands-input.ffg:2:1: \n │\n2 │ true * true\n │ ↑\n\ntasty/data/error/type/invalid-times-operands-input.ffg:2:8: \n │\n2 │ true * true\n │ ↑" }, { "path": "tasty/data/error/type/merge-wrong-type-input.ffg", "content": "fold 1\n" }, { "path": "tasty/data/error/type/merge-wrong-type-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n Natural\n\ntasty/data/error/type/merge-wrong-type-input.ffg:1:6: \n │\n1 │ fold 1\n │ ↑\n\n… is not a subtype of:\n\n { a? }\n\ntasty/data/error/type/merge-wrong-type-input.ffg:1:1: \n │\n1 │ fold 1\n │ ↑" }, { "path": "tasty/data/error/type/missing-required-field-input.ffg", "content": "{ x: 1 }.y : Bool\n" }, { "path": "tasty/data/error/type/missing-required-field-stderr.txt", "content": "Record type mismatch\n\nThe following record type:\n\n { x: Natural }\n\ntasty/data/error/type/missing-required-field-input.ffg:1:1: \n │\n1 │ { x: 1 }.y : Bool\n │ ↑\n\n… is not a subtype of the following record type:\n\n { y: Bool, b? }\n\ntasty/data/error/type/missing-required-field-input.ffg:1:10: \n │\n1 │ { x: 1 }.y : Bool\n │ ↑\n\nThe latter record has the following extra fields:\n\n• y" }, { "path": "tasty/data/error/type/modulus-abstract-input.ffg", "content": "let f x = 3 % x\n\nin f 0\n" }, { "path": "tasty/data/error/type/modulus-abstract-stderr.txt", "content": "Divisor must be concrete\n\nYou must divide by a concrete (non-abstract) numeric literal:\n\ntasty/data/error/type/modulus-abstract-input.ffg:1:15: \n │\n1 │ let f x = 3 % x\n │ ↑" }, { "path": "tasty/data/error/type/modulus-zero-input.ffg", "content": "3 % 0\n" }, { "path": "tasty/data/error/type/modulus-zero-stderr.txt", "content": "Zero divisor\n\nYou cannot divide a number by zero:\n\ntasty/data/error/type/modulus-zero-input.ffg:1:5: \n │\n1 │ 3 % 0\n │ ↑" }, { "path": "tasty/data/error/type/non-singular-pattern-input.ffg", "content": "fold { A x y: x && y } (A true false)\n" }, { "path": "tasty/data/error/type/non-singular-pattern-stderr.txt", "content": "Not a function type\n\nAn expression of the following type:\n\n < A: Bool | g? >\n\ntasty/data/error/type/non-singular-pattern-input.ffg:1:25: \n │\n1 │ fold { A x y: x && y } (A true false)\n │ ↑\n\n… was invoked as if it were a function, but the above type is not a function\ntype." }, { "path": "tasty/data/error/type/not-a-function-input.ffg", "content": "1 1\n" }, { "path": "tasty/data/error/type/not-a-function-stderr.txt", "content": "Not a function type\n\nAn expression of the following type:\n\n Natural\n\ntasty/data/error/type/not-a-function-input.ffg:1:1: \n │\n1 │ 1 1\n │ ↑\n\n… was invoked as if it were a function, but the above type is not a function\ntype." }, { "path": "tasty/data/error/type/occurs-alternatives-input.ffg", "content": "# This test exercises the occurs check for alternatives variables\n\\x -> [ x, C x ]\n" }, { "path": "tasty/data/error/type/occurs-alternatives-stderr.txt", "content": "No supertype\n\nThe following two types:\n\n a?\n\ntasty/data/error/type/occurs-alternatives-input.ffg:2:2: \n │\n2 │ \\x -> [ x, C x ]\n │ ↑\n\n < C: a? | c? >\n\ntasty/data/error/type/occurs-alternatives-input.ffg:2:12: \n │\n2 │ \\x -> [ x, C x ]\n │ ↑\n\n… have no shared supertype." }, { "path": "tasty/data/error/type/occurs-type-backwards-input.ffg", "content": "# This test exercises the occurs check when the subtype occurs in the supertype\n\\f -> \\x -> [ f, f x ]\n" }, { "path": "tasty/data/error/type/occurs-type-backwards-stderr.txt", "content": "No supertype\n\nThe following two types:\n\n e? -> f?\n\ntasty/data/error/type/occurs-type-backwards-input.ffg:2:2: \n │\n2 │ \\f -> \\x -> [ f, f x ]\n │ ↑\n\n f?\n\ntasty/data/error/type/occurs-type-backwards-input.ffg:2:2: \n │\n2 │ \\f -> \\x -> [ f, f x ]\n │ ↑\n\n… have no shared supertype." }, { "path": "tasty/data/error/type/occurs-type-input.ffg", "content": "# This test exercises the occurs check for type variables\n\\x -> x x\n" }, { "path": "tasty/data/error/type/occurs-type-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n c? -> d?\n\ntasty/data/error/type/occurs-type-input.ffg:2:2: \n │\n2 │ \\x -> x x\n │ ↑\n\n… is not a subtype of:\n\n c?\n\ntasty/data/error/type/occurs-type-input.ffg:2:2: \n │\n2 │ \\x -> x x\n │ ↑" }, { "path": "tasty/data/error/type/pattern-input.ffg", "content": "{ f (x : Natural): Text: x }\n" }, { "path": "tasty/data/error/type/pattern-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n Natural\n\ntasty/data/error/type/pattern-input.ffg:1:10: \n │\n1 │ { f (x : Natural): Text: x }\n │ ↑\n\n… is not a subtype of:\n\n Text\n\ntasty/data/error/type/pattern-input.ffg:1:20: \n │\n1 │ { f (x : Natural): Text: x }\n │ ↑" }, { "path": "tasty/data/error/type/pin-fields-variable-input.ffg", "content": "# This verifies that two record types cannot unify if they share the same\n# fields variable but different monomorphic fields\nlet f : forall (a : Fields) . { a } -> { x : Bool, a }\n = \\x -> x\n\nin f\n" }, { "path": "tasty/data/error/type/pin-fields-variable-stderr.txt", "content": "Record type mismatch\n\nThe following record type:\n\n { a }\n\ntasty/data/error/type/pin-fields-variable-input.ffg:3:31: \n │\n3 │ let f : forall (a : Fields) . { a } -> { x : Bool, a }\n │ ↑\n\n… is not a subtype of the following record type:\n\n { x: Bool, a }\n\ntasty/data/error/type/pin-fields-variable-input.ffg:3:40: \n │\n3 │ let f : forall (a : Fields) . { a } -> { x : Bool, a }\n │ ↑\n\nThe latter record has the following extra fields:\n\n• x" }, { "path": "tasty/data/error/type/read-fail-input.ffg", "content": "# Grace's support for \"eval\" is type-safe, so the following example will fail\nlet not x = import read \"x == false\"\n\nin not 4\n" }, { "path": "tasty/data/error/type/read-fail-stderr.txt", "content": "No supertype\n\nThe following two types:\n\n Natural\n\ntasty/data/error/type/read-fail-input.ffg:4:9: \n │\n4 │ in not 4\n │ ↑\n\n Bool\n\n(read):1:6: \n │\n1 │ x == false\n │ ↑\n\n… have no shared supertype." }, { "path": "tasty/data/error/type/read-input.ffg", "content": "read \"[ 1, 2, 3 ]\" : List Text\n" }, { "path": "tasty/data/error/type/read-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n Natural\n\n(json):1:1: \n │\n1 │ 1\n │ ↑\n\n… is not a subtype of:\n\n Text\n\ntasty/data/error/type/read-input.ffg:1:27: \n │\n1 │ read \"[ 1, 2, 3 ]\" : List Text\n │ ↑" }, { "path": "tasty/data/error/type/show-key-input.ffg", "content": "show (\"skproj-…\" : Key)\n" }, { "path": "tasty/data/error/type/show-key-stderr.txt", "content": "Not a subtype of JSON\n\nThe following type:\n\n Key\n\ntasty/data/error/type/show-key-input.ffg:1:20: \n │\n1 │ show (\"skproj-…\" : Key)\n │ ↑\n\n… is not a subtype of JSON." }, { "path": "tasty/data/error/type/subtype-function-input.ffg", "content": "(\\(x : Natural) -> x) : Integer -> Natural\n" }, { "path": "tasty/data/error/type/subtype-function-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n Integer\n\ntasty/data/error/type/subtype-function-input.ffg:1:25: \n │\n1 │ (\\(x : Natural) -> x) : Integer -> Natural\n │ ↑\n\n… is not a subtype of:\n\n Natural\n\ntasty/data/error/type/subtype-function-input.ffg:1:8: \n │\n1 │ (\\(x : Natural) -> x) : Integer -> Natural\n │ ↑" }, { "path": "tasty/data/error/type/type-mismatch-input.ffg", "content": "1 + true\n" }, { "path": "tasty/data/error/type/type-mismatch-stderr.txt", "content": "Invalid operands\n\nYou cannot add the following operands:\n\ntasty/data/error/type/type-mismatch-input.ffg:1:1: \n │\n1 │ 1 + true\n │ ↑\n\ntasty/data/error/type/type-mismatch-input.ffg:1:5: \n │\n1 │ 1 + true\n │ ↑" }, { "path": "tasty/data/error/type/unbound-input.ffg", "content": "x\n" }, { "path": "tasty/data/error/type/unbound-stderr.txt", "content": "Unbound variable: x\n\ntasty/data/error/type/unbound-input.ffg:1:1: \n │\n1 │ x\n │ ↑" }, { "path": "tasty/data/error/type/unbound-type-input.ffg", "content": "let f (x : a) : a = x\n\nin f\n" }, { "path": "tasty/data/error/type/unbound-type-stderr.txt", "content": "Unbound type variable: a\n\ntasty/data/error/type/unbound-type-input.ffg:1:12: \n │\n1 │ let f (x : a) : a = x\n │ ↑" }, { "path": "tasty/data/error/type/union-mismatch-both-extra-input.ffg", "content": "\\x -> (x : < A : { } >) : < B : { } >\n" }, { "path": "tasty/data/error/type/union-mismatch-both-extra-stderr.txt", "content": "Union type mismatch\n\nThe following union type:\n\n < A: { } >\n\ntasty/data/error/type/union-mismatch-both-extra-input.ffg:1:12: \n │\n1 │ \\x -> (x : < A : { } >) : < B : { } >\n │ ↑\n\n… is not a subtype of the following union type:\n\n < B: { } >\n\ntasty/data/error/type/union-mismatch-both-extra-input.ffg:1:27: \n │\n1 │ \\x -> (x : < A : { } >) : < B : { } >\n │ ↑\n\nThe former union has the following extra alternatives:\n\n• A" }, { "path": "tasty/data/error/type/union-mismatch-left-extra-input.ffg", "content": "\\x -> (x : < A : { } >) : < >\n" }, { "path": "tasty/data/error/type/union-mismatch-left-extra-stderr.txt", "content": "Union type mismatch\n\nThe following union type:\n\n < A: { } >\n\ntasty/data/error/type/union-mismatch-left-extra-input.ffg:1:12: \n │\n1 │ \\x -> (x : < A : { } >) : < >\n │ ↑\n\n… is not a subtype of the following union type:\n\n < >\n\ntasty/data/error/type/union-mismatch-left-extra-input.ffg:1:27: \n │\n1 │ \\x -> (x : < A : { } >) : < >\n │ ↑\n\nThe former union has the following extra alternatives:\n\n• A" }, { "path": "tasty/data/error/type/union-mismatch-right-extra-input.ffg", "content": "\\x -> (x : < >) : < A : { } >\n" }, { "path": "tasty/data/error/type/union-mismatch-right-extra-output.ffg", "content": "\\x -> x : < A: { } >\n" }, { "path": "tasty/data/error/type/union-mismatch-right-extra-type.ffg", "content": "< > -> < A: { } >\n" }, { "path": "tasty/data/error/type/union-variable-mismatch-input.ffg", "content": "let f : forall (a : Alternatives) . forall (b : Alternatives) . < a > -> < b > -> < a >\n = \\x -> \\y -> y\n\nin f\n" }, { "path": "tasty/data/error/type/union-variable-mismatch-stderr.txt", "content": "Union type mismatch\n\nThe following union type:\n\n < b >\n\ntasty/data/error/type/union-variable-mismatch-input.ffg:1:74: \n │\n1 │ let f : forall (a : Alternatives) . forall (b : Alternatives) . < a > -> < b > -> < a >\n │ ↑\n\n… is not a subtype of the following union type:\n\n < a >\n\ntasty/data/error/type/union-variable-mismatch-input.ffg:1:83: \n │\n1 │ let f : forall (a : Alternatives) . forall (b : Alternatives) . < a > -> < b > -> < a >\n │ ↑" }, { "path": "tasty/data/error/type/variable-mismatch-input.ffg", "content": "let f : forall (a : Type) . forall (b : Type) . a -> b -> a\n = \\x -> \\y -> y\n\nin f\n" }, { "path": "tasty/data/error/type/variable-mismatch-stderr.txt", "content": "Not a subtype\n\nThe following type:\n\n b\n\ntasty/data/error/type/variable-mismatch-input.ffg:1:54: \n │\n1 │ let f : forall (a : Type) . forall (b : Type) . a -> b -> a\n │ ↑\n\n… is not a subtype of:\n\n a\n\ntasty/data/error/type/variable-mismatch-input.ffg:1:59: \n │\n1 │ let f : forall (a : Type) . forall (b : Type) . a -> b -> a\n │ ↑" }, { "path": "tasty/data/json/colors-input.ffg", "content": "# https://www.sitepoint.com/colors-json-example/\n#\n# Note that the example from the above page is not valid JSON (due to a\n# trailing comma)\n./colors.json :\n { colors: List\n { color: Text\n , category: Text\n , code: { rgba: List Natural, hex: Text }\n , type: Optional Text\n }\n }\n" }, { "path": "tasty/data/json/colors-output.ffg", "content": "{ \"colors\":\n [ { \"color\":\n \"black\"\n , \"category\":\n \"hue\"\n , \"type\":\n some \"primary\"\n , \"code\":\n { \"rgba\": [ 255, 255, 255, 1 ], \"hex\": \"#000\" }\n }\n , { \"color\":\n \"white\"\n , \"category\":\n \"value\"\n , \"code\":\n { \"rgba\": [ 0, 0, 0, 1 ], \"hex\": \"#FFF\" }\n , \"type\":\n null\n }\n , { \"color\":\n \"red\"\n , \"category\":\n \"hue\"\n , \"type\":\n some \"primary\"\n , \"code\":\n { \"rgba\": [ 255, 0, 0, 1 ], \"hex\": \"#FF0\" }\n }\n , { \"color\":\n \"blue\"\n , \"category\":\n \"hue\"\n , \"type\":\n some \"primary\"\n , \"code\":\n { \"rgba\": [ 0, 0, 255, 1 ], \"hex\": \"#00F\" }\n }\n , { \"color\":\n \"yellow\"\n , \"category\":\n \"hue\"\n , \"type\":\n some \"primary\"\n , \"code\":\n { \"rgba\": [ 255, 255, 0, 1 ], \"hex\": \"#FF0\" }\n }\n , { \"color\":\n \"green\"\n , \"category\":\n \"hue\"\n , \"type\":\n some \"secondary\"\n , \"code\":\n { \"rgba\": [ 0, 255, 0, 1 ], \"hex\": \"#0F0\" }\n }\n ]\n}\n" }, { "path": "tasty/data/json/colors-type.ffg", "content": "{ colors:\n List\n { color:\n Text\n , category:\n Text\n , code:\n { rgba: List Natural, hex: Text }\n , type:\n Optional Text\n }\n}\n" }, { "path": "tasty/data/json/colors.json", "content": "{\n \"colors\": [\n {\n \"color\": \"black\",\n \"category\": \"hue\",\n \"type\": \"primary\",\n \"code\": {\n \"rgba\": [255,255,255,1],\n \"hex\": \"#000\"\n }\n },\n {\n \"color\": \"white\",\n \"category\": \"value\",\n \"code\": {\n \"rgba\": [0,0,0,1],\n \"hex\": \"#FFF\"\n }\n },\n {\n \"color\": \"red\",\n \"category\": \"hue\",\n \"type\": \"primary\",\n \"code\": {\n \"rgba\": [255,0,0,1],\n \"hex\": \"#FF0\"\n }\n },\n {\n \"color\": \"blue\",\n \"category\": \"hue\",\n \"type\": \"primary\",\n \"code\": {\n \"rgba\": [0,0,255,1],\n \"hex\": \"#00F\"\n }\n },\n {\n \"color\": \"yellow\",\n \"category\": \"hue\",\n \"type\": \"primary\",\n \"code\": {\n \"rgba\": [255,255,0,1],\n \"hex\": \"#FF0\"\n }\n },\n {\n \"color\": \"green\",\n \"category\": \"hue\",\n \"type\": \"secondary\",\n \"code\": {\n \"rgba\": [0,255,0,1],\n \"hex\": \"#0F0\"\n }\n },\n ]\n}\n" }, { "path": "tasty/data/json/geoip-input.ffg", "content": "# https://www.sitepoint.com/geoip-json-example\n./geoip.json\n" }, { "path": "tasty/data/json/geoip-output.ffg", "content": "{ \"as\":\n \"AS16509 Amazon.com, Inc.\"\n, \"city\":\n \"Boardman\"\n, \"country\":\n \"United States\"\n, \"countryCode\":\n \"US\"\n, \"isp\":\n \"Amazon\"\n, \"lat\":\n 45.8696\n, \"lon\":\n -119.688\n, \"org\":\n \"Amazon\"\n, \"query\":\n \"54.148.84.95\"\n, \"region\":\n \"OR\"\n, \"regionName\":\n \"Oregon\"\n, \"status\":\n \"success\"\n, \"timezone\":\n \"America/Los_Angeles\"\n, \"zip\":\n \"97818\"\n}\n" }, { "path": "tasty/data/json/geoip-type.ffg", "content": "{ as:\n Text\n, city:\n Text\n, country:\n Text\n, countryCode:\n Text\n, isp:\n Text\n, lat:\n Real\n, lon:\n Real\n, org:\n Text\n, query:\n Text\n, region:\n Text\n, regionName:\n Text\n, status:\n Text\n, timezone:\n Text\n, zip:\n Text\n}\n" }, { "path": "tasty/data/json/geoip.json", "content": "{\n \"as\": \"AS16509 Amazon.com, Inc.\",\n \"city\": \"Boardman\",\n \"country\": \"United States\",\n \"countryCode\": \"US\",\n \"isp\": \"Amazon\",\n \"lat\": 45.8696,\n \"lon\": -119.688,\n \"org\": \"Amazon\",\n \"query\": \"54.148.84.95\",\n \"region\": \"OR\",\n \"regionName\": \"Oregon\",\n \"status\": \"success\",\n \"timezone\": \"America\\/Los_Angeles\",\n \"zip\": \"97818\"\n}\n\n" }, { "path": "tasty/data/json/glossary-input.ffg", "content": "# https://json.org/example.html\n./glossary.json\n" }, { "path": "tasty/data/json/glossary-output.ffg", "content": "{ \"glossary\":\n { \"title\":\n \"example glossary\"\n , \"GlossDiv\":\n { \"title\":\n \"S\"\n , \"GlossList\":\n { \"GlossEntry\":\n { \"ID\":\n \"SGML\"\n , \"SortAs\":\n \"SGML\"\n , \"GlossTerm\":\n \"Standard Generalized Markup Language\"\n , \"Acronym\":\n \"SGML\"\n , \"Abbrev\":\n \"ISO 8879:1986\"\n , \"GlossDef\":\n { \"para\":\n \"A meta-markup language, used to create markup languages such as DocBook.\"\n , \"GlossSeeAlso\":\n [ \"GML\", \"XML\" ]\n }\n , \"GlossSee\":\n \"markup\"\n }\n }\n }\n }\n}\n" }, { "path": "tasty/data/json/glossary-type.ffg", "content": "{ glossary:\n { title:\n Text\n , \"GlossDiv\":\n { title:\n Text\n , \"GlossList\":\n { \"GlossEntry\":\n { \"ID\":\n Text\n , \"SortAs\":\n Text\n , \"GlossTerm\":\n Text\n , \"Acronym\":\n Text\n , \"Abbrev\":\n Text\n , \"GlossDef\":\n { para: Text, \"GlossSeeAlso\": List Text }\n , \"GlossSee\":\n Text\n }\n }\n }\n }\n}\n" }, { "path": "tasty/data/json/glossary.json", "content": "{\n \"glossary\": {\n \"title\": \"example glossary\",\n\t\t\"GlossDiv\": {\n \"title\": \"S\",\n\t\t\t\"GlossList\": {\n \"GlossEntry\": {\n \"ID\": \"SGML\",\n\t\t\t\t\t\"SortAs\": \"SGML\",\n\t\t\t\t\t\"GlossTerm\": \"Standard Generalized Markup Language\",\n\t\t\t\t\t\"Acronym\": \"SGML\",\n\t\t\t\t\t\"Abbrev\": \"ISO 8879:1986\",\n\t\t\t\t\t\"GlossDef\": {\n \"para\": \"A meta-markup language, used to create markup languages such as DocBook.\",\n\t\t\t\t\t\t\"GlossSeeAlso\": [\"GML\", \"XML\"]\n },\n\t\t\t\t\t\"GlossSee\": \"markup\"\n }\n }\n }\n }\n}\n" }, { "path": "tasty/data/json/markers-input.ffg", "content": "# https://www.sitepoint.com/google-maps-json-file/\n#\n# Note that the example from the above page is not valid JSON (due to a trailing\n# comma)\n./markers.json : { markers : List { name : Text, location: Optional (List Real), position: Optional (List Real) } }\n" }, { "path": "tasty/data/json/markers-output.ffg", "content": "{ \"markers\":\n [ { \"name\":\n \"Rixos The Palm Dubai\"\n , \"position\":\n some [ 25.1212, 55.1535 ]\n , \"location\":\n null\n }\n , { \"name\":\n \"Shangri-La Hotel\"\n , \"location\":\n some [ 25.2084, 55.2719 ]\n , \"position\":\n null\n }\n , { \"name\":\n \"Grand Hyatt\"\n , \"location\":\n some [ 25.2285, 55.3273 ]\n , \"position\":\n null\n }\n ]\n}\n" }, { "path": "tasty/data/json/markers-type.ffg", "content": "{ markers:\n List\n { name:\n Text\n , location:\n Optional (List Real)\n , position:\n Optional (List Real)\n }\n}\n" }, { "path": "tasty/data/json/markers.json", "content": "{\n \"markers\": [\n {\n \"name\": \"Rixos The Palm Dubai\",\n \"position\": [25.1212, 55.1535],\n },\n {\n \"name\": \"Shangri-La Hotel\",\n \"location\": [25.2084, 55.2719]\n },\n {\n \"name\": \"Grand Hyatt\",\n \"location\": [25.2285, 55.3273]\n }\n ]\n}\n\n" }, { "path": "tasty/data/json/menu-input.ffg", "content": "# https://json.org/example.html\n./menu.json\n" }, { "path": "tasty/data/json/menu-output.ffg", "content": "{ \"menu\":\n { \"id\":\n \"file\"\n , \"value\":\n \"File\"\n , \"popup\":\n { \"menuitem\":\n [ { \"value\": \"New\", \"onclick\": \"CreateNewDoc()\" }\n , { \"value\": \"Open\", \"onclick\": \"OpenDoc()\" }\n , { \"value\": \"Close\", \"onclick\": \"CloseDoc()\" }\n ]\n }\n }\n}\n" }, { "path": "tasty/data/json/menu-type.ffg", "content": "{ menu:\n { id:\n Text\n , value:\n Text\n , popup:\n { menuitem: List { value: Text, onclick: Text } }\n }\n}\n" }, { "path": "tasty/data/json/menu.json", "content": "{\"menu\": {\n \"id\": \"file\",\n \"value\": \"File\",\n \"popup\": {\n \"menuitem\": [\n {\"value\": \"New\", \"onclick\": \"CreateNewDoc()\"},\n {\"value\": \"Open\", \"onclick\": \"OpenDoc()\"},\n {\"value\": \"Close\", \"onclick\": \"CloseDoc()\"}\n ]\n }\n}}\n" }, { "path": "tasty/data/json/menu2-input.ffg", "content": "./menu2.json :\n { menu:\n { header: Text\n , items: List (Optional { id: Text, label: Optional Text })\n }\n }\n" }, { "path": "tasty/data/json/menu2-output.ffg", "content": "{ \"menu\":\n { \"header\":\n \"SVG Viewer\"\n , \"items\":\n [ some { \"id\": \"Open\", \"label\": null }\n , some { \"id\": \"OpenNew\", \"label\": some \"Open New\" }\n , null\n , some { \"id\": \"ZoomIn\", \"label\": some \"Zoom In\" }\n , some { \"id\": \"ZoomOut\", \"label\": some \"Zoom Out\" }\n , some { \"id\": \"OriginalView\", \"label\": some \"Original View\" }\n , null\n , some { \"id\": \"Quality\", \"label\": null }\n , some { \"id\": \"Pause\", \"label\": null }\n , some { \"id\": \"Mute\", \"label\": null }\n , null\n , some { \"id\": \"Find\", \"label\": some \"Find...\" }\n , some { \"id\": \"FindAgain\", \"label\": some \"Find Again\" }\n , some { \"id\": \"Copy\", \"label\": null }\n , some { \"id\": \"CopyAgain\", \"label\": some \"Copy Again\" }\n , some { \"id\": \"CopySVG\", \"label\": some \"Copy SVG\" }\n , some { \"id\": \"ViewSVG\", \"label\": some \"View SVG\" }\n , some { \"id\": \"ViewSource\", \"label\": some \"View Source\" }\n , some { \"id\": \"SaveAs\", \"label\": some \"Save As\" }\n , null\n , some { \"id\": \"Help\", \"label\": null }\n , some { \"id\": \"About\", \"label\": some \"About Adobe CVG Viewer...\" }\n ]\n }\n}\n" }, { "path": "tasty/data/json/menu2-type.ffg", "content": "{ menu:\n { header: Text, items: List (Optional { id: Text, label: Optional Text }) }\n}\n" }, { "path": "tasty/data/json/menu2.json", "content": "{\"menu\": {\n \"header\": \"SVG Viewer\",\n \"items\": [\n {\"id\": \"Open\"},\n {\"id\": \"OpenNew\", \"label\": \"Open New\"},\n null,\n {\"id\": \"ZoomIn\", \"label\": \"Zoom In\"},\n {\"id\": \"ZoomOut\", \"label\": \"Zoom Out\"},\n {\"id\": \"OriginalView\", \"label\": \"Original View\"},\n null,\n {\"id\": \"Quality\"},\n {\"id\": \"Pause\"},\n {\"id\": \"Mute\"},\n null,\n {\"id\": \"Find\", \"label\": \"Find...\"},\n {\"id\": \"FindAgain\", \"label\": \"Find Again\"},\n {\"id\": \"Copy\"},\n {\"id\": \"CopyAgain\", \"label\": \"Copy Again\"},\n {\"id\": \"CopySVG\", \"label\": \"Copy SVG\"},\n {\"id\": \"ViewSVG\", \"label\": \"View SVG\"},\n {\"id\": \"ViewSource\", \"label\": \"View Source\"},\n {\"id\": \"SaveAs\", \"label\": \"Save As\"},\n null,\n {\"id\": \"Help\"},\n {\"id\": \"About\", \"label\": \"About Adobe CVG Viewer...\"}\n ]\n}}\n" }, { "path": "tasty/data/json/numbers-input.ffg", "content": "# https://opensource.adobe.com/Spry/samples/data_region/JSONDataSetSample.html\n./numbers.json\n" }, { "path": "tasty/data/json/numbers-output.ffg", "content": "[ 100, 500, 300, 200, 400 ]\n" }, { "path": "tasty/data/json/numbers-type.ffg", "content": "List Natural\n" }, { "path": "tasty/data/json/numbers.json", "content": "[ 100, 500, 300, 200, 400 ]\n" }, { "path": "tasty/data/json/people-input.ffg", "content": "# https://www.sitepoint.com/test-data-json-example/\n./people.json\n" }, { "path": "tasty/data/json/people-output.ffg", "content": "{ \"clients\":\n [ { \"id\":\n \"59761c23b30d971669fb42ff\"\n , \"isActive\":\n true\n , \"age\":\n 36\n , \"name\":\n \"Dunlap Hubbard\"\n , \"gender\":\n \"male\"\n , \"company\":\n \"CEDWARD\"\n , \"email\":\n \"dunlaphubbard@cedward.com\"\n , \"phone\":\n \"+1 (890) 543-2508\"\n , \"address\":\n \"169 Rutledge Street, Konterra, Northern Mariana Islands, 8551\"\n }\n , { \"id\":\n \"59761c233d8d0f92a6b0570d\"\n , \"isActive\":\n true\n , \"age\":\n 24\n , \"name\":\n \"Kirsten Sellers\"\n , \"gender\":\n \"female\"\n , \"company\":\n \"EMERGENT\"\n , \"email\":\n \"kirstensellers@emergent.com\"\n , \"phone\":\n \"+1 (831) 564-2190\"\n , \"address\":\n \"886 Gallatin Place, Fannett, Arkansas, 4656\"\n }\n , { \"id\":\n \"59761c23fcb6254b1a06dad5\"\n , \"isActive\":\n true\n , \"age\":\n 30\n , \"name\":\n \"Acosta Robbins\"\n , \"gender\":\n \"male\"\n , \"company\":\n \"ORGANICA\"\n , \"email\":\n \"acostarobbins@organica.com\"\n , \"phone\":\n \"+1 (882) 441-3367\"\n , \"address\":\n \"697 Linden Boulevard, Sattley, Idaho, 1035\"\n }\n ]\n}\n" }, { "path": "tasty/data/json/people-type.ffg", "content": "{ clients:\n List\n { id:\n Text\n , isActive:\n Bool\n , age:\n Natural\n , name:\n Text\n , gender:\n Text\n , company:\n Text\n , email:\n Text\n , phone:\n Text\n , address:\n Text\n }\n}\n" }, { "path": "tasty/data/json/people.json", "content": "{\n \"clients\": [\n {\n \"id\": \"59761c23b30d971669fb42ff\",\n \"isActive\": true,\n \"age\": 36,\n \"name\": \"Dunlap Hubbard\",\n \"gender\": \"male\",\n \"company\": \"CEDWARD\",\n \"email\": \"dunlaphubbard@cedward.com\",\n \"phone\": \"+1 (890) 543-2508\",\n \"address\": \"169 Rutledge Street, Konterra, Northern Mariana Islands, 8551\"\n },\n {\n \"id\": \"59761c233d8d0f92a6b0570d\",\n \"isActive\": true,\n \"age\": 24,\n \"name\": \"Kirsten Sellers\",\n \"gender\": \"female\",\n \"company\": \"EMERGENT\",\n \"email\": \"kirstensellers@emergent.com\",\n \"phone\": \"+1 (831) 564-2190\",\n \"address\": \"886 Gallatin Place, Fannett, Arkansas, 4656\"\n },\n {\n \"id\": \"59761c23fcb6254b1a06dad5\",\n \"isActive\": true,\n \"age\": 30,\n \"name\": \"Acosta Robbins\",\n \"gender\": \"male\",\n \"company\": \"ORGANICA\",\n \"email\": \"acostarobbins@organica.com\",\n \"phone\": \"+1 (882) 441-3367\",\n \"address\": \"697 Linden Boulevard, Sattley, Idaho, 1035\"\n }\n ]\n}\n\n" }, { "path": "tasty/data/json/products-input.ffg", "content": "# https://www.sitepoint.com/database-json-file/\n./products.json\n" }, { "path": "tasty/data/json/products-output.ffg", "content": "[ { \"_id\":\n { \"$oid\": \"5968dd23fc13ae04d9000001\" }\n , \"product_name\":\n \"sildenafil citrate\"\n , \"supplier\":\n \"Wisozk Inc\"\n , \"quantity\":\n 261\n , \"unit_cost\":\n \"$10.47\"\n }\n, { \"_id\":\n { \"$oid\": \"5968dd23fc13ae04d9000002\" }\n , \"product_name\":\n \"Mountain Juniperus ashei\"\n , \"supplier\":\n \"Keebler-Hilpert\"\n , \"quantity\":\n 292\n , \"unit_cost\":\n \"$8.74\"\n }\n, { \"_id\":\n { \"$oid\": \"5968dd23fc13ae04d9000003\" }\n , \"product_name\":\n \"Dextromathorphan HBr\"\n , \"supplier\":\n \"Schmitt-Weissnat\"\n , \"quantity\":\n 211\n , \"unit_cost\":\n \"$20.53\"\n }\n]\n" }, { "path": "tasty/data/json/products-type.ffg", "content": "List\n { _id:\n { \"$oid\": Text }\n , product_name:\n Text\n , supplier:\n Text\n , quantity:\n Natural\n , unit_cost:\n Text\n }\n" }, { "path": "tasty/data/json/products.json", "content": "[{\n \"_id\": {\n \"$oid\": \"5968dd23fc13ae04d9000001\"\n },\n \"product_name\": \"sildenafil citrate\",\n \"supplier\": \"Wisozk Inc\",\n \"quantity\": 261,\n \"unit_cost\": \"$10.47\"\n}, {\n \"_id\": {\n \"$oid\": \"5968dd23fc13ae04d9000002\"\n },\n \"product_name\": \"Mountain Juniperus ashei\",\n \"supplier\": \"Keebler-Hilpert\",\n \"quantity\": 292,\n \"unit_cost\": \"$8.74\"\n}, {\n \"_id\": {\n \"$oid\": \"5968dd23fc13ae04d9000003\"\n },\n \"product_name\": \"Dextromathorphan HBr\",\n \"supplier\": \"Schmitt-Weissnat\",\n \"quantity\": 211,\n \"unit_cost\": \"$20.53\"\n}]\n\n" }, { "path": "tasty/data/json/recipes-input.ffg", "content": "# https://opensource.adobe.com/Spry/samples/data_region/JSONDataSetSample.html\n./recipes.json\n" }, { "path": "tasty/data/json/recipes-output.ffg", "content": "[ { \"id\":\n \"0001\"\n , \"type\":\n \"donut\"\n , \"name\":\n \"Cake\"\n , \"ppu\":\n 0.55\n , \"batters\":\n { \"batter\":\n [ { \"id\": \"1001\", \"type\": \"Regular\" }\n , { \"id\": \"1002\", \"type\": \"Chocolate\" }\n , { \"id\": \"1003\", \"type\": \"Blueberry\" }\n , { \"id\": \"1004\", \"type\": \"Devil's Food\" }\n ]\n }\n , \"topping\":\n [ { \"id\": \"5001\", \"type\": \"None\" }\n , { \"id\": \"5002\", \"type\": \"Glazed\" }\n , { \"id\": \"5005\", \"type\": \"Sugar\" }\n , { \"id\": \"5007\", \"type\": \"Powdered Sugar\" }\n , { \"id\": \"5006\", \"type\": \"Chocolate with Sprinkles\" }\n , { \"id\": \"5003\", \"type\": \"Chocolate\" }\n , { \"id\": \"5004\", \"type\": \"Maple\" }\n ]\n }\n, { \"id\":\n \"0002\"\n , \"type\":\n \"donut\"\n , \"name\":\n \"Raised\"\n , \"ppu\":\n 0.55\n , \"batters\":\n { \"batter\": [ { \"id\": \"1001\", \"type\": \"Regular\" } ] }\n , \"topping\":\n [ { \"id\": \"5001\", \"type\": \"None\" }\n , { \"id\": \"5002\", \"type\": \"Glazed\" }\n , { \"id\": \"5005\", \"type\": \"Sugar\" }\n , { \"id\": \"5003\", \"type\": \"Chocolate\" }\n , { \"id\": \"5004\", \"type\": \"Maple\" }\n ]\n }\n, { \"id\":\n \"0003\"\n , \"type\":\n \"donut\"\n , \"name\":\n \"Old Fashioned\"\n , \"ppu\":\n 0.55\n , \"batters\":\n { \"batter\":\n [ { \"id\": \"1001\", \"type\": \"Regular\" }\n , { \"id\": \"1002\", \"type\": \"Chocolate\" }\n ]\n }\n , \"topping\":\n [ { \"id\": \"5001\", \"type\": \"None\" }\n , { \"id\": \"5002\", \"type\": \"Glazed\" }\n , { \"id\": \"5003\", \"type\": \"Chocolate\" }\n , { \"id\": \"5004\", \"type\": \"Maple\" }\n ]\n }\n]\n" }, { "path": "tasty/data/json/recipes-type.ffg", "content": "List\n { id:\n Text\n , type:\n Text\n , name:\n Text\n , ppu:\n Real\n , batters:\n { batter: List { id: Text, type: Text } }\n , topping:\n List { id: Text, type: Text }\n }\n" }, { "path": "tasty/data/json/recipes.json", "content": "[\n\t{\n\t\t\"id\": \"0001\",\n\t\t\"type\": \"donut\",\n\t\t\"name\": \"Cake\",\n\t\t\"ppu\": 0.55,\n\t\t\"batters\":\n\t\t\t{\n\t\t\t\t\"batter\":\n\t\t\t\t\t[\n\t\t\t\t\t\t{ \"id\": \"1001\", \"type\": \"Regular\" },\n\t\t\t\t\t\t{ \"id\": \"1002\", \"type\": \"Chocolate\" },\n\t\t\t\t\t\t{ \"id\": \"1003\", \"type\": \"Blueberry\" },\n\t\t\t\t\t\t{ \"id\": \"1004\", \"type\": \"Devil's Food\" }\n\t\t\t\t\t]\n\t\t\t},\n\t\t\"topping\":\n\t\t\t[\n\t\t\t\t{ \"id\": \"5001\", \"type\": \"None\" },\n\t\t\t\t{ \"id\": \"5002\", \"type\": \"Glazed\" },\n\t\t\t\t{ \"id\": \"5005\", \"type\": \"Sugar\" },\n\t\t\t\t{ \"id\": \"5007\", \"type\": \"Powdered Sugar\" },\n\t\t\t\t{ \"id\": \"5006\", \"type\": \"Chocolate with Sprinkles\" },\n\t\t\t\t{ \"id\": \"5003\", \"type\": \"Chocolate\" },\n\t\t\t\t{ \"id\": \"5004\", \"type\": \"Maple\" }\n\t\t\t]\n\t},\n\t{\n\t\t\"id\": \"0002\",\n\t\t\"type\": \"donut\",\n\t\t\"name\": \"Raised\",\n\t\t\"ppu\": 0.55,\n\t\t\"batters\":\n\t\t\t{\n\t\t\t\t\"batter\":\n\t\t\t\t\t[\n\t\t\t\t\t\t{ \"id\": \"1001\", \"type\": \"Regular\" }\n\t\t\t\t\t]\n\t\t\t},\n\t\t\"topping\":\n\t\t\t[\n\t\t\t\t{ \"id\": \"5001\", \"type\": \"None\" },\n\t\t\t\t{ \"id\": \"5002\", \"type\": \"Glazed\" },\n\t\t\t\t{ \"id\": \"5005\", \"type\": \"Sugar\" },\n\t\t\t\t{ \"id\": \"5003\", \"type\": \"Chocolate\" },\n\t\t\t\t{ \"id\": \"5004\", \"type\": \"Maple\" }\n\t\t\t]\n\t},\n\t{\n\t\t\"id\": \"0003\",\n\t\t\"type\": \"donut\",\n\t\t\"name\": \"Old Fashioned\",\n\t\t\"ppu\": 0.55,\n\t\t\"batters\":\n\t\t\t{\n\t\t\t\t\"batter\":\n\t\t\t\t\t[\n\t\t\t\t\t\t{ \"id\": \"1001\", \"type\": \"Regular\" },\n\t\t\t\t\t\t{ \"id\": \"1002\", \"type\": \"Chocolate\" }\n\t\t\t\t\t]\n\t\t\t},\n\t\t\"topping\":\n\t\t\t[\n\t\t\t\t{ \"id\": \"5001\", \"type\": \"None\" },\n\t\t\t\t{ \"id\": \"5002\", \"type\": \"Glazed\" },\n\t\t\t\t{ \"id\": \"5003\", \"type\": \"Chocolate\" },\n\t\t\t\t{ \"id\": \"5004\", \"type\": \"Maple\" }\n\t\t\t]\n\t}\n]\n" }, { "path": "tasty/data/json/server-input.ffg", "content": "# https://www.sitepoint.com/local-rest-json-file/\n./server.json\n" }, { "path": "tasty/data/json/server-output.ffg", "content": "{ \"host\":\n \"localhost\"\n, \"port\":\n 3030\n, \"public\":\n \"../public/\"\n, \"paginate\":\n { \"default\": 10, \"max\": 50 }\n, \"mongodb\":\n \"mongodb://localhost:27017/api\"\n}\n" }, { "path": "tasty/data/json/server-type.ffg", "content": "{ host:\n Text\n, port:\n Natural\n, public:\n Text\n, paginate:\n { default: Natural, max: Natural }\n, mongodb:\n Text\n}\n" }, { "path": "tasty/data/json/server.json", "content": "{\n \"host\": \"localhost\",\n \"port\": 3030,\n \"public\": \"../public/\",\n \"paginate\": {\n \"default\": 10,\n \"max\": 50\n },\n \"mongodb\": \"mongodb://localhost:27017/api\"\n}\n" }, { "path": "tasty/data/json/twitter-input.ffg", "content": "# https://www.sitepoint.com/twitter-json-example/\n#\n# Note that the example from the above page is not valid JSON (due to a trailing\n# comma)\n./twitter.json\n" }, { "path": "tasty/data/json/twitter-output.ffg", "content": "[ { \"created_at\":\n \"Thu Jun 22 21:00:00 +0000 2017\"\n , \"id\":\n 877994604561387500\n , \"id_str\":\n \"877994604561387520\"\n , \"text\":\n \"Creating a Grocery List Manager Using Angular, Part 1: Add & Display Items https://t.co/xFox78juL1 #Angular\"\n , \"truncated\":\n false\n , \"entities\":\n { \"hashtags\":\n [ { \"text\": \"Angular\", \"indices\": [ 103, 111 ] } ]\n , \"symbols\":\n [ ]\n , \"user_mentions\":\n [ ]\n , \"urls\":\n [ { \"url\":\n \"https://t.co/xFox78juL1\"\n , \"expanded_url\":\n \"http://buff.ly/2sr60pf\"\n , \"display_url\":\n \"buff.ly/2sr60pf\"\n , \"indices\":\n [ 79, 102 ]\n }\n ]\n }\n , \"source\":\n \"Buffer\"\n , \"user\":\n { \"id\":\n 772682964\n , \"id_str\":\n \"772682964\"\n , \"name\":\n \"SitePoint JavaScript\"\n , \"screen_name\":\n \"SitePointJS\"\n , \"location\":\n \"Melbourne, Australia\"\n , \"description\":\n \"Keep up with JavaScript tutorials, tips, tricks and articles at SitePoint.\"\n , \"url\":\n \"http://t.co/cCH13gqeUK\"\n , \"entities\":\n { \"url\":\n { \"urls\":\n [ { \"url\":\n \"http://t.co/cCH13gqeUK\"\n , \"expanded_url\":\n \"https://www.sitepoint.com/javascript\"\n , \"display_url\":\n \"sitepoint.com/javascript\"\n , \"indices\":\n [ 0, 22 ]\n }\n ]\n }\n , \"description\":\n { \"urls\": [ ] }\n }\n , \"protected\":\n false\n , \"followers_count\":\n 2145\n , \"friends_count\":\n 18\n , \"listed_count\":\n 328\n , \"created_at\":\n \"Wed Aug 22 02:06:33 +0000 2012\"\n , \"favourites_count\":\n 57\n , \"utc_offset\":\n 43200\n , \"time_zone\":\n \"Wellington\"\n }\n }\n]\n" }, { "path": "tasty/data/json/twitter-type.ffg", "content": "forall (a : Type) .\nforall (b : Type) .\nforall (c : Type) .\n List\n { created_at:\n Text\n , id:\n Natural\n , id_str:\n Text\n , text:\n Text\n , truncated:\n Bool\n , entities:\n { hashtags:\n List { text: Text, indices: List Natural }\n , symbols:\n List c\n , user_mentions:\n List b\n , urls:\n List\n { url:\n Text\n , expanded_url:\n Text\n , display_url:\n Text\n , indices:\n List Natural\n }\n }\n , source:\n Text\n , user:\n { id:\n Natural\n , id_str:\n Text\n , name:\n Text\n , screen_name:\n Text\n , location:\n Text\n , description:\n Text\n , url:\n Text\n , entities:\n { url:\n { urls:\n List\n { url:\n Text\n , expanded_url:\n Text\n , display_url:\n Text\n , indices:\n List Natural\n }\n }\n , description:\n { urls: List a }\n }\n , protected:\n Bool\n , followers_count:\n Natural\n , friends_count:\n Natural\n , listed_count:\n Natural\n , created_at:\n Text\n , favourites_count:\n Natural\n , utc_offset:\n Natural\n , time_zone:\n Text\n }\n }\n" }, { "path": "tasty/data/json/twitter.json", "content": "[{\n \"created_at\": \"Thu Jun 22 21:00:00 +0000 2017\",\n \"id\": 877994604561387500,\n \"id_str\": \"877994604561387520\",\n \"text\": \"Creating a Grocery List Manager Using Angular, Part 1: Add & Display Items https://t.co/xFox78juL1 #Angular\",\n \"truncated\": false,\n \"entities\": {\n \"hashtags\": [{\n \"text\": \"Angular\",\n \"indices\": [103, 111]\n }],\n \"symbols\": [],\n \"user_mentions\": [],\n \"urls\": [{\n \"url\": \"https://t.co/xFox78juL1\",\n \"expanded_url\": \"http://buff.ly/2sr60pf\",\n \"display_url\": \"buff.ly/2sr60pf\",\n \"indices\": [79, 102]\n }]\n },\n \"source\": \"Buffer\",\n \"user\": {\n \"id\": 772682964,\n \"id_str\": \"772682964\",\n \"name\": \"SitePoint JavaScript\",\n \"screen_name\": \"SitePointJS\",\n \"location\": \"Melbourne, Australia\",\n \"description\": \"Keep up with JavaScript tutorials, tips, tricks and articles at SitePoint.\",\n \"url\": \"http://t.co/cCH13gqeUK\",\n \"entities\": {\n \"url\": {\n \"urls\": [{\n \"url\": \"http://t.co/cCH13gqeUK\",\n \"expanded_url\": \"https://www.sitepoint.com/javascript\",\n \"display_url\": \"sitepoint.com/javascript\",\n \"indices\": [0, 22]\n }]\n },\n \"description\": {\n \"urls\": []\n }\n },\n \"protected\": false,\n \"followers_count\": 2145,\n \"friends_count\": 18,\n \"listed_count\": 328,\n \"created_at\": \"Wed Aug 22 02:06:33 +0000 2012\",\n \"favourites_count\": 57,\n \"utc_offset\": 43200,\n \"time_zone\": \"Wellington\",\n },\n}]\n\n" }, { "path": "tasty/data/json/widget-input.ffg", "content": "# https://json.org/example.html\n./widget.json\n" }, { "path": "tasty/data/json/widget-output.ffg", "content": "{ \"widget\":\n { \"debug\":\n \"on\"\n , \"window\":\n { \"title\":\n \"Sample Konfabulator Widget\"\n , \"name\":\n \"main_window\"\n , \"width\":\n 500\n , \"height\":\n 500\n }\n , \"image\":\n { \"src\":\n \"Images/Sun.png\"\n , \"name\":\n \"sun1\"\n , \"hOffset\":\n 250\n , \"vOffset\":\n 250\n , \"alignment\":\n \"center\"\n }\n , \"text\":\n { \"data\":\n \"Click Here\"\n , \"size\":\n 36\n , \"style\":\n \"bold\"\n , \"name\":\n \"text1\"\n , \"hOffset\":\n 250\n , \"vOffset\":\n 100\n , \"alignment\":\n \"center\"\n , \"onMouseUp\":\n \"sun1.opacity = (sun1.opacity / 100) * 90;\"\n }\n }\n}\n" }, { "path": "tasty/data/json/widget-type.ffg", "content": "{ widget:\n { debug:\n Text\n , window:\n { title: Text, name: Text, width: Natural, height: Natural }\n , image:\n { src:\n Text\n , name:\n Text\n , hOffset:\n Natural\n , vOffset:\n Natural\n , alignment:\n Text\n }\n , text:\n { data:\n Text\n , size:\n Natural\n , style:\n Text\n , name:\n Text\n , hOffset:\n Natural\n , vOffset:\n Natural\n , alignment:\n Text\n , onMouseUp:\n Text\n }\n }\n}\n" }, { "path": "tasty/data/json/widget.json", "content": "{\"widget\": {\n \"debug\": \"on\",\n \"window\": {\n \"title\": \"Sample Konfabulator Widget\",\n \"name\": \"main_window\",\n \"width\": 500,\n \"height\": 500\n },\n \"image\": { \n \"src\": \"Images/Sun.png\",\n \"name\": \"sun1\",\n \"hOffset\": 250,\n \"vOffset\": 250,\n \"alignment\": \"center\"\n },\n \"text\": {\n \"data\": \"Click Here\",\n \"size\": 36,\n \"style\": \"bold\",\n \"name\": \"text1\",\n \"hOffset\": 250,\n \"vOffset\": 100,\n \"alignment\": \"center\",\n \"onMouseUp\": \"sun1.opacity = (sun1.opacity / 100) * 90;\"\n }\n}}\n" }, { "path": "tasty/data/json/youtube-input.ffg", "content": "# https://www.sitepoint.com/youtube-json-example/\n./youtube.json :\n { kind : Text\n , etag : Text\n , nextPageToken : Text\n , regionCode : Text\n , pageInfo : { totalResults : Natural, resultsPerPage : Natural }\n , items : List\n { kind : Text\n , etag : Text\n , id : { kind : Text, channelId: Optional Text, videoId: Optional Text }\n }\n }\n\n" }, { "path": "tasty/data/json/youtube-output.ffg", "content": "{ \"kind\":\n \"youtube#searchListResponse\"\n, \"etag\":\n \"\\\"m2yskBQFythfE4irbTIeOgYYfBU/PaiEDiVxOyCWelLPuuwa9LKz3Gk\\\"\"\n, \"nextPageToken\":\n \"CAUQAA\"\n, \"regionCode\":\n \"KE\"\n, \"pageInfo\":\n { \"totalResults\": 4249, \"resultsPerPage\": 5 }\n, \"items\":\n [ { \"kind\":\n \"youtube#searchResult\"\n , \"etag\":\n \"\\\"m2yskBQFythfE4irbTIeOgYYfBU/QpOIr3QKlV5EUlzfFcVvDiJT0hw\\\"\"\n , \"id\":\n { \"kind\":\n \"youtube#channel\"\n , \"channelId\":\n some \"UCJowOS1R0FnhipXVqEnYU1A\"\n , \"videoId\":\n null\n }\n }\n , { \"kind\":\n \"youtube#searchResult\"\n , \"etag\":\n \"\\\"m2yskBQFythfE4irbTIeOgYYfBU/AWutzVOt_5p1iLVifyBdfoSTf9E\\\"\"\n , \"id\":\n { \"kind\":\n \"youtube#video\"\n , \"videoId\":\n some \"Eqa2nAAhHN0\"\n , \"channelId\":\n null\n }\n }\n , { \"kind\":\n \"youtube#searchResult\"\n , \"etag\":\n \"\\\"m2yskBQFythfE4irbTIeOgYYfBU/2dIR9BTfr7QphpBuY3hPU-h5u-4\\\"\"\n , \"id\":\n { \"kind\":\n \"youtube#video\"\n , \"videoId\":\n some \"IirngItQuVs\"\n , \"channelId\":\n null\n }\n }\n ]\n}\n" }, { "path": "tasty/data/json/youtube-type.ffg", "content": "{ kind:\n Text\n, etag:\n Text\n, nextPageToken:\n Text\n, regionCode:\n Text\n, pageInfo:\n { totalResults: Natural, resultsPerPage: Natural }\n, items:\n List\n { kind:\n Text\n , etag:\n Text\n , id:\n { kind: Text, channelId: Optional Text, videoId: Optional Text }\n }\n}\n" }, { "path": "tasty/data/json/youtube.json", "content": "{\n \"kind\": \"youtube#searchListResponse\",\n \"etag\": \"\\\"m2yskBQFythfE4irbTIeOgYYfBU/PaiEDiVxOyCWelLPuuwa9LKz3Gk\\\"\",\n \"nextPageToken\": \"CAUQAA\",\n \"regionCode\": \"KE\",\n \"pageInfo\": {\n \"totalResults\": 4249,\n \"resultsPerPage\": 5\n },\n \"items\": [\n {\n \"kind\": \"youtube#searchResult\",\n \"etag\": \"\\\"m2yskBQFythfE4irbTIeOgYYfBU/QpOIr3QKlV5EUlzfFcVvDiJT0hw\\\"\",\n \"id\": {\n \"kind\": \"youtube#channel\",\n \"channelId\": \"UCJowOS1R0FnhipXVqEnYU1A\"\n }\n },\n {\n \"kind\": \"youtube#searchResult\",\n \"etag\": \"\\\"m2yskBQFythfE4irbTIeOgYYfBU/AWutzVOt_5p1iLVifyBdfoSTf9E\\\"\",\n \"id\": {\n \"kind\": \"youtube#video\",\n \"videoId\": \"Eqa2nAAhHN0\"\n }\n },\n {\n \"kind\": \"youtube#searchResult\",\n \"etag\": \"\\\"m2yskBQFythfE4irbTIeOgYYfBU/2dIR9BTfr7QphpBuY3hPU-h5u-4\\\"\",\n \"id\": {\n \"kind\": \"youtube#video\",\n \"videoId\": \"IirngItQuVs\"\n }\n }\n ]\n}\n\n" }, { "path": "tasty/data/true.ffg", "content": "true\n" }, { "path": "tasty/data/unit/add-integer-input.ffg", "content": "1 + -1\n" }, { "path": "tasty/data/unit/add-integer-output.ffg", "content": "0\n" }, { "path": "tasty/data/unit/add-integer-type.ffg", "content": "Integer\n" }, { "path": "tasty/data/unit/alternative-input.ffg", "content": "Foo 1\n" }, { "path": "tasty/data/unit/alternative-output.ffg", "content": "Foo 1\n" }, { "path": "tasty/data/unit/alternative-type.ffg", "content": "forall (a : Alternatives) . < Foo: Natural | a >\n" }, { "path": "tasty/data/unit/and-input.ffg", "content": "true && false\n" }, { "path": "tasty/data/unit/and-output.ffg", "content": "false\n" }, { "path": "tasty/data/unit/and-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/append-list-input.ffg", "content": "[ 2, 3 ] + [ 5, 7 ]\n" }, { "path": "tasty/data/unit/append-list-output.ffg", "content": "[ 2, 3, 5, 7 ]\n" }, { "path": "tasty/data/unit/append-list-type.ffg", "content": "List Natural\n" }, { "path": "tasty/data/unit/append-text-input.ffg", "content": "\"a\" + \"b\"\n" }, { "path": "tasty/data/unit/append-text-output.ffg", "content": "\"ab\"\n" }, { "path": "tasty/data/unit/append-text-type.ffg", "content": "Text\n" }, { "path": "tasty/data/unit/application-input.ffg", "content": "show false\n" }, { "path": "tasty/data/unit/application-output.ffg", "content": "\"false\"\n" }, { "path": "tasty/data/unit/application-type.ffg", "content": "Text\n" }, { "path": "tasty/data/unit/bool-input.ffg", "content": "true\n" }, { "path": "tasty/data/unit/bool-output.ffg", "content": "true\n" }, { "path": "tasty/data/unit/bool-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/default-argument-input.ffg", "content": "let f (x = 1) = x\n\nin f null\n" }, { "path": "tasty/data/unit/default-argument-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/default-argument-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/default-record-argument-input.ffg", "content": "let f { x = 1 } = x\n\nin f { }\n" }, { "path": "tasty/data/unit/default-record-argument-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/default-record-argument-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/destructure-lambda-input.ffg", "content": "\\{ x } -> x\n" }, { "path": "tasty/data/unit/destructure-lambda-output.ffg", "content": "\\{ x } -> x\n" }, { "path": "tasty/data/unit/destructure-lambda-type.ffg", "content": "forall (a : Type) (b : Fields) . { x: a, b } -> a\n" }, { "path": "tasty/data/unit/destructure-let-argument-input.ffg", "content": "let f { x } = x\n\nin f\n" }, { "path": "tasty/data/unit/destructure-let-argument-output.ffg", "content": "\\{ x } -> x\n" }, { "path": "tasty/data/unit/destructure-let-argument-type.ffg", "content": "forall (a : Type) (b : Fields) . { x: a, b } -> a\n" }, { "path": "tasty/data/unit/destructure-record-input.ffg", "content": "let { x } = { x: 1 } in x\n" }, { "path": "tasty/data/unit/destructure-record-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/destructure-record-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/divide-input.ffg", "content": "-5 / 3\n" }, { "path": "tasty/data/unit/divide-output.ffg", "content": "-1.6666666666666667\n" }, { "path": "tasty/data/unit/divide-type.ffg", "content": "Real\n" }, { "path": "tasty/data/unit/equal-input.ffg", "content": "0 == 0\n" }, { "path": "tasty/data/unit/equal-output.ffg", "content": "true\n" }, { "path": "tasty/data/unit/equal-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/export-show-input.ffg", "content": "export show (\\x -> x)\n" }, { "path": "tasty/data/unit/export-show-output.ffg", "content": "\"\\\\x -> x\"\n" }, { "path": "tasty/data/unit/export-show-type.ffg", "content": "Text\n" }, { "path": "tasty/data/unit/field-input.ffg", "content": "{ x: true }.x\n" }, { "path": "tasty/data/unit/field-output.ffg", "content": "true\n" }, { "path": "tasty/data/unit/field-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/fields-input.ffg", "content": "{ x: 1, y: true }.{ z, x }\n" }, { "path": "tasty/data/unit/fields-output.ffg", "content": "{ \"z\": null, \"x\": 1 }\n" }, { "path": "tasty/data/unit/fields-type.ffg", "content": "forall (a : Type) . { z: Optional a, x: Natural }\n" }, { "path": "tasty/data/unit/for-list-input.ffg", "content": "for x of [ 1, 2, 3 ] in x + 1\n" }, { "path": "tasty/data/unit/for-list-output.ffg", "content": "[ 2, 3, 4 ]\n" }, { "path": "tasty/data/unit/for-list-type.ffg", "content": "List Natural\n" }, { "path": "tasty/data/unit/for-optional-input.ffg", "content": "if let x = some 1\n\nin x + 1\n" }, { "path": "tasty/data/unit/for-optional-output.ffg", "content": "some 2\n" }, { "path": "tasty/data/unit/for-optional-type.ffg", "content": "Optional Natural\n" }, { "path": "tasty/data/unit/greater-than-input.ffg", "content": "2 > 3\n" }, { "path": "tasty/data/unit/greater-than-or-equal-input.ffg", "content": "2 >= 3\n" }, { "path": "tasty/data/unit/greater-than-or-equal-output.ffg", "content": "false\n" }, { "path": "tasty/data/unit/greater-than-or-equal-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/greater-than-output.ffg", "content": "false\n" }, { "path": "tasty/data/unit/greater-than-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/if-input.ffg", "content": "if true then true else false\n" }, { "path": "tasty/data/unit/if-output.ffg", "content": "true\n" }, { "path": "tasty/data/unit/if-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/import-input.ffg", "content": "./bool-input.ffg\n" }, { "path": "tasty/data/unit/import-output.ffg", "content": "true\n" }, { "path": "tasty/data/unit/import-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/index-input.ffg", "content": "[ 2, 3, 5 ].1\n" }, { "path": "tasty/data/unit/index-output.ffg", "content": "some 3\n" }, { "path": "tasty/data/unit/index-type.ffg", "content": "Optional Natural\n" }, { "path": "tasty/data/unit/inequality-input.ffg", "content": "0 == 1\n" }, { "path": "tasty/data/unit/inequality-output.ffg", "content": "false\n" }, { "path": "tasty/data/unit/inequality-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/integer-abs-input.ffg", "content": "abs -4\n" }, { "path": "tasty/data/unit/integer-abs-output.ffg", "content": "4\n" }, { "path": "tasty/data/unit/integer-abs-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/integer-input.ffg", "content": "-1\n" }, { "path": "tasty/data/unit/integer-output.ffg", "content": "-1\n" }, { "path": "tasty/data/unit/integer-type.ffg", "content": "Integer\n" }, { "path": "tasty/data/unit/interpolation-input.ffg", "content": "\"a${\"b\"}c\"\n" }, { "path": "tasty/data/unit/interpolation-output.ffg", "content": "\"abc\"\n" }, { "path": "tasty/data/unit/interpolation-type.ffg", "content": "Text\n" }, { "path": "tasty/data/unit/json-input.ffg", "content": "{ array: [ 2, 3, 5 ]\n, string: \"ABC\"\n, natural: 0\n, integer: -1\n, real: 1.1\n, bool: true\n, \"null\": null\n, mixed: [ 1, -1, true ]\n} : JSON\n" }, { "path": "tasty/data/unit/json-output.ffg", "content": "{ \"array\":\n [ 2, 3, 5 ]\n, \"string\":\n \"ABC\"\n, \"natural\":\n 0\n, \"integer\":\n -1\n, \"real\":\n 1.1\n, \"bool\":\n true\n, \"null\":\n null\n, \"mixed\":\n [ 1, -1, true ]\n}\n" }, { "path": "tasty/data/unit/json-subtype-input.ffg", "content": "(1 : Natural) : JSON\n" }, { "path": "tasty/data/unit/json-subtype-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/json-subtype-type.ffg", "content": "JSON\n" }, { "path": "tasty/data/unit/json-type.ffg", "content": "JSON\n" }, { "path": "tasty/data/unit/key-input.ffg", "content": "\"sk-proj-…\" : Key\n" }, { "path": "tasty/data/unit/key-output.ffg", "content": "🔒\n" }, { "path": "tasty/data/unit/key-type.ffg", "content": "Key\n" }, { "path": "tasty/data/unit/lambda-annotation-input.ffg", "content": "\\(x : Natural) -> x\n" }, { "path": "tasty/data/unit/lambda-annotation-output.ffg", "content": "\\x -> x\n" }, { "path": "tasty/data/unit/lambda-annotation-type.ffg", "content": "Natural -> Natural\n" }, { "path": "tasty/data/unit/lambda-input.ffg", "content": "\\x -> x\n" }, { "path": "tasty/data/unit/lambda-output.ffg", "content": "\\x -> x\n" }, { "path": "tasty/data/unit/lambda-type.ffg", "content": "forall (a : Type) . a -> a\n" }, { "path": "tasty/data/unit/less-than-input.ffg", "content": "1 < 2\n" }, { "path": "tasty/data/unit/less-than-or-equal-input.ffg", "content": "1 <= 2\n" }, { "path": "tasty/data/unit/less-than-or-equal-output.ffg", "content": "true\n" }, { "path": "tasty/data/unit/less-than-or-equal-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/less-than-output.ffg", "content": "true\n" }, { "path": "tasty/data/unit/less-than-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/let-default-input.ffg", "content": "let (x = 1) = null in x\n" }, { "path": "tasty/data/unit/let-default-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/let-default-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/let-function-input.ffg", "content": "let f x = x\n\nin f 1\n" }, { "path": "tasty/data/unit/let-function-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/let-function-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/let-input.ffg", "content": "let x = true\n\nlet y = x\n\nin y\n" }, { "path": "tasty/data/unit/let-output.ffg", "content": "true\n" }, { "path": "tasty/data/unit/let-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/list-fold-input.ffg", "content": "fold { cons: \\x y -> x + y : Natural, nil: 0 } [ 2, 3 ]\n" }, { "path": "tasty/data/unit/list-fold-output.ffg", "content": "5\n" }, { "path": "tasty/data/unit/list-fold-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/list-indexed-input.ffg", "content": "indexed [ true, false ]\n" }, { "path": "tasty/data/unit/list-indexed-output.ffg", "content": "[ { \"index\": 0, \"value\": true }, { \"index\": 1, \"value\": false } ]\n" }, { "path": "tasty/data/unit/list-indexed-type.ffg", "content": "List { index: Natural, value: Bool }\n" }, { "path": "tasty/data/unit/list-input.ffg", "content": "[ ]\n" }, { "path": "tasty/data/unit/list-length-input.ffg", "content": "length [ true, false ]\n" }, { "path": "tasty/data/unit/list-length-output.ffg", "content": "2\n" }, { "path": "tasty/data/unit/list-length-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/list-map-input.ffg", "content": "map (\\x -> x + 1) [ 2, 3, 5 ]\n" }, { "path": "tasty/data/unit/list-map-output.ffg", "content": "[ 3, 4, 6 ]\n" }, { "path": "tasty/data/unit/list-map-type.ffg", "content": "List Natural\n" }, { "path": "tasty/data/unit/list-output.ffg", "content": "[ ]\n" }, { "path": "tasty/data/unit/list-type.ffg", "content": "forall (a : Type) . List a\n" }, { "path": "tasty/data/unit/merge-bool-input.ffg", "content": "fold { false: 0, true: 1 }\n" }, { "path": "tasty/data/unit/merge-bool-output.ffg", "content": "fold { \"false\": 0, \"true\": 1 }\n" }, { "path": "tasty/data/unit/merge-bool-type.ffg", "content": "Bool -> Natural\n" }, { "path": "tasty/data/unit/merge-evaluation-input.ffg", "content": "fold { X: \\x -> x } (X 1)\n" }, { "path": "tasty/data/unit/merge-evaluation-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/merge-evaluation-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/merge-input.ffg", "content": "fold { X: \\x -> x }\n" }, { "path": "tasty/data/unit/merge-optional-input.ffg", "content": "fold { null: false, some: \\_ -> true }\n" }, { "path": "tasty/data/unit/merge-optional-output.ffg", "content": "fold { \"null\": false, \"some\": \\_ -> true }\n" }, { "path": "tasty/data/unit/merge-optional-type.ffg", "content": "forall (a : Type) . Optional a -> Bool\n" }, { "path": "tasty/data/unit/merge-output.ffg", "content": "fold { \"X\": \\x -> x }\n" }, { "path": "tasty/data/unit/merge-type.ffg", "content": "forall (a : Type) . < X: a > -> a\n" }, { "path": "tasty/data/unit/minus-input.ffg", "content": "3 - 2\n" }, { "path": "tasty/data/unit/minus-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/minus-type.ffg", "content": "Integer\n" }, { "path": "tasty/data/unit/missing-field-input.ffg", "content": "{ x: 1 }.y\n" }, { "path": "tasty/data/unit/missing-field-output.ffg", "content": "null\n" }, { "path": "tasty/data/unit/missing-field-type.ffg", "content": "forall (a : Type) . Optional a\n" }, { "path": "tasty/data/unit/missing-optional-field-input.ffg", "content": "let f (arguments : { x: Natural, y: Optional Bool }) = arguments.x\n\nin [ f { x: 1 }, f { x: 2, y: true } ]\n" }, { "path": "tasty/data/unit/missing-optional-field-output.ffg", "content": "[ 1, 2 ]\n" }, { "path": "tasty/data/unit/missing-optional-field-type.ffg", "content": "List Natural\n" }, { "path": "tasty/data/unit/modulus-input.ffg", "content": "5 % 3\n" }, { "path": "tasty/data/unit/modulus-output.ffg", "content": "{ \"quotient\": 1, \"remainder\": 2 }\n" }, { "path": "tasty/data/unit/modulus-type.ffg", "content": "{ quotient: Natural, remainder: Natural }\n" }, { "path": "tasty/data/unit/multi-lambda-input.ffg", "content": "\\x y -> [x, y]\n" }, { "path": "tasty/data/unit/multi-lambda-output.ffg", "content": "\\x y -> [ x, y ]\n" }, { "path": "tasty/data/unit/multi-lambda-type.ffg", "content": "forall (a : Type) . a -> a -> List a\n" }, { "path": "tasty/data/unit/multiline-input.ffg", "content": "let example0 = \"\n a\n\n b\n \"\n\nlet example1 = \"\n a\"\n\nin { example0, example1 }\n" }, { "path": "tasty/data/unit/multiline-output.ffg", "content": "{ \"example0\": \"a\\n\\nb\\n\", \"example1\": \"a\" }\n" }, { "path": "tasty/data/unit/multiline-type.ffg", "content": "{ example0: Text, example1: Text }\n" }, { "path": "tasty/data/unit/multiple-path-components-input.ffg", "content": "../unit/bool-input.ffg\n" }, { "path": "tasty/data/unit/multiple-path-components-output.ffg", "content": "true\n" }, { "path": "tasty/data/unit/multiple-path-components-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/natural-fold-input.ffg", "content": "fold { succ: \\x -> x + \"a\", zero: \"\" } 3\n" }, { "path": "tasty/data/unit/natural-fold-output.ffg", "content": "\"aaa\"\n" }, { "path": "tasty/data/unit/natural-fold-type.ffg", "content": "Text\n" }, { "path": "tasty/data/unit/natural-input.ffg", "content": "1\n" }, { "path": "tasty/data/unit/natural-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/natural-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/not-equal-input.ffg", "content": "1 == 2\n" }, { "path": "tasty/data/unit/not-equal-output.ffg", "content": "false\n" }, { "path": "tasty/data/unit/not-equal-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/null-input.ffg", "content": "null\n" }, { "path": "tasty/data/unit/null-output.ffg", "content": "null\n" }, { "path": "tasty/data/unit/null-type.ffg", "content": "forall (a : Type) . Optional a\n" }, { "path": "tasty/data/unit/or-input.ffg", "content": "true || false\n" }, { "path": "tasty/data/unit/or-output.ffg", "content": "true\n" }, { "path": "tasty/data/unit/or-type.ffg", "content": "Bool\n" }, { "path": "tasty/data/unit/pattern-input.ffg", "content": "fold { some x: x, null: 0 } 1\n" }, { "path": "tasty/data/unit/pattern-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/pattern-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/plus-input.ffg", "content": "2 + 3\n" }, { "path": "tasty/data/unit/plus-output.ffg", "content": "5\n" }, { "path": "tasty/data/unit/plus-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/positive-integer-input.ffg", "content": "+1\n" }, { "path": "tasty/data/unit/positive-integer-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/positive-integer-type.ffg", "content": "Integer\n" }, { "path": "tasty/data/unit/pun-input.ffg", "content": "let x = 1\n\n in { x }\n" }, { "path": "tasty/data/unit/pun-output.ffg", "content": "{ \"x\": 1 }\n" }, { "path": "tasty/data/unit/pun-type.ffg", "content": "{ x: Natural }\n" }, { "path": "tasty/data/unit/quoted-label-input.ffg", "content": "\\.'a b' -> .'a b'\n" }, { "path": "tasty/data/unit/quoted-label-output.ffg", "content": "\\.'a b' -> .'a b'\n" }, { "path": "tasty/data/unit/quoted-label-type.ffg", "content": "forall (a : Type) . a -> a\n" }, { "path": "tasty/data/unit/read-input.ffg", "content": "read \"1\"\n" }, { "path": "tasty/data/unit/read-output.ffg", "content": "1\n" }, { "path": "tasty/data/unit/read-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/real-dot-zero-input.ffg", "content": "1.0\n" }, { "path": "tasty/data/unit/real-dot-zero-output.ffg", "content": "1.0\n" }, { "path": "tasty/data/unit/real-dot-zero-type.ffg", "content": "Real\n" }, { "path": "tasty/data/unit/real-input.ffg", "content": "1.1\n" }, { "path": "tasty/data/unit/real-output.ffg", "content": "1.1\n" }, { "path": "tasty/data/unit/real-type.ffg", "content": "Real\n" }, { "path": "tasty/data/unit/record-desugar-input.ffg", "content": "{ f x: x }\n" }, { "path": "tasty/data/unit/record-desugar-output.ffg", "content": "{ \"f\": \\x -> x }\n" }, { "path": "tasty/data/unit/record-desugar-type.ffg", "content": "forall (a : Type) . { f: a -> a }\n" }, { "path": "tasty/data/unit/record-input.ffg", "content": "{ x: true, y: false }\n" }, { "path": "tasty/data/unit/record-output.ffg", "content": "{ \"x\": true, \"y\": false }\n" }, { "path": "tasty/data/unit/record-type.ffg", "content": "{ x: Bool, y: Bool }\n" }, { "path": "tasty/data/unit/remote-import-input.ffg", "content": "https://raw.githubusercontent.com/Gabriel439/grace/537e82bc92e31590f258b9aa4fa1db2f227463f8/prelude/bool/not.ffg\n" }, { "path": "tasty/data/unit/remote-import-output.ffg", "content": "\\b -> if b then false else true\n" }, { "path": "tasty/data/unit/remote-import-type.ffg", "content": "Bool -> Bool\n" }, { "path": "tasty/data/unit/reveal-input.ffg", "content": "let key: Key = \"abc\"\n\nin reveal key\n" }, { "path": "tasty/data/unit/reveal-output.ffg", "content": "\"abc\"\n" }, { "path": "tasty/data/unit/reveal-type.ffg", "content": "Text\n" }, { "path": "tasty/data/unit/show-input.ffg", "content": "show 0\n" }, { "path": "tasty/data/unit/show-output.ffg", "content": "\"0\"\n" }, { "path": "tasty/data/unit/show-type.ffg", "content": "Text\n" }, { "path": "tasty/data/unit/slice-input.ffg", "content": "[2, 3, 5][1:2]\n" }, { "path": "tasty/data/unit/slice-output.ffg", "content": "some [ 3 ]\n" }, { "path": "tasty/data/unit/slice-type.ffg", "content": "Optional (List Natural)\n" }, { "path": "tasty/data/unit/string-labels-input.ffg", "content": "{ \"foo bar\": 1, \"if\": 2 }\n" }, { "path": "tasty/data/unit/string-labels-output.ffg", "content": "{ \"foo bar\": 1, \"if\": 2 }\n" }, { "path": "tasty/data/unit/string-labels-type.ffg", "content": "{ \"foo bar\": Natural, \"if\": Natural }\n" }, { "path": "tasty/data/unit/text-escaped-input.ffg", "content": "\"\\\"\\/\\b\\f\\n\\r\\t\\u024c\\\\\\u2192\"\n" }, { "path": "tasty/data/unit/text-escaped-output.ffg", "content": "\"\n\\\"/\\b\\f\n\\r\tɌ\\\\→\"\n" }, { "path": "tasty/data/unit/text-escaped-type.ffg", "content": "Text\n" }, { "path": "tasty/data/unit/text-input.ffg", "content": "\"a\"\n" }, { "path": "tasty/data/unit/text-output.ffg", "content": "\"a\"\n" }, { "path": "tasty/data/unit/text-type.ffg", "content": "Text\n" }, { "path": "tasty/data/unit/times-input.ffg", "content": "2 * 3\n" }, { "path": "tasty/data/unit/times-output.ffg", "content": "6\n" }, { "path": "tasty/data/unit/times-type.ffg", "content": "Natural\n" }, { "path": "tasty/data/unit/union-input.ffg", "content": "C 1\n" }, { "path": "tasty/data/unit/union-output.ffg", "content": "C 1\n" }, { "path": "tasty/data/unit/union-type.ffg", "content": "forall (a : Alternatives) . < C: Natural | a >\n" }, { "path": "tasty/data/unit/visible-row-quantification-input.ffg", "content": "(\\x -> x.foo) : forall (a : Type) . forall (p : Fields) . { foo : a, p } -> a\n" }, { "path": "tasty/data/unit/visible-row-quantification-output.ffg", "content": "\\x -> x.foo\n" }, { "path": "tasty/data/unit/visible-row-quantification-type.ffg", "content": "forall (a : Type) (p : Fields) . { foo: a, p } -> a\n" }, { "path": "tasty/data/unit/visible-variant-quantification-input.ffg", "content": "(\\x -> X x) : forall (a : Type) . forall (p : Alternatives) . a -> < X : a | p >\n" }, { "path": "tasty/data/unit/visible-variant-quantification-output.ffg", "content": "\\x -> X x\n" }, { "path": "tasty/data/unit/visible-variant-quantification-type.ffg", "content": "forall (a : Type) (p : Alternatives) . a -> < X: a | p >\n" }, { "path": "tasty/data/unit/yaml-input.ffg", "content": "yaml [ 1, 2, 3 ]\n" }, { "path": "tasty/data/unit/yaml-output.ffg", "content": "\"\n\n- 1\n- 2\n- 3\n\"\n" }, { "path": "tasty/data/unit/yaml-type.ffg", "content": "Text\n" }, { "path": "try-grace/Main.hs", "content": "{-# LANGUAGE BlockArguments #-}\n{-# LANGUAGE DataKinds #-}\n{-# LANGUAGE DuplicateRecordFields #-}\n{-# LANGUAGE NamedFieldPuns #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE MultiWayIf #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TypeApplications #-}\n\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n\nmodule Main where\n\nimport Control.Applicative (empty, liftA2, (<|>))\nimport Control.Concurrent.Async (Async, Concurrently(..))\nimport Control.Exception.Safe (catch, Exception(..), SomeException)\nimport Control.Monad.IO.Class (MonadIO(..))\nimport Control.Monad.Morph (hoist)\nimport Control.Monad.Trans.Class (lift)\nimport Control.Monad.Trans.Maybe (MaybeT)\nimport Control.Monad.Trans.Reader (ReaderT)\nimport Control.Monad.Trans.State (StateT)\nimport Data.Foldable (toList, traverse_)\nimport Data.IORef (IORef)\nimport Data.Maybe (isJust)\nimport Data.JSString (JSString)\nimport Data.Sequence (ViewR(..), (|>))\nimport Data.Text (Text)\nimport Data.Traversable (forM)\nimport Data.Void (Void)\nimport Grace.Monad (Status(..))\nimport Grace.Type (Type(..))\nimport GHCJS.Foreign.Callback (Callback)\nimport GHCJS.Types (JSVal)\nimport Grace.Decode (FromGrace)\nimport Grace.Encode (ToGrace(..))\nimport Grace.Input (Input(..))\nimport Grace.Location (Location(..))\nimport Grace.Monotype (RemainingFields(..))\nimport Grace.Syntax (Binding(..), NameBinding(..), Scalar(..), Syntax)\nimport Grace.Value (Value(..))\nimport JavaScript.Array (JSArray)\nimport Numeric.Natural (Natural)\nimport Prelude hiding (div, error, id, length, span, subtract)\nimport System.FilePath (())\n\nimport qualified Control.Concurrent.Async as Async\nimport qualified Control.Concurrent.MVar as MVar\nimport qualified Control.Concurrent.STM as STM\nimport qualified Control.Concurrent.STM.TVar as TVar\nimport qualified Control.Exception.Safe as Exception\nimport qualified Control.Lens as Lens\nimport qualified Control.Monad as Monad\nimport qualified Control.Monad.State as State\nimport qualified Control.Monad.Trans.Maybe as Maybe\nimport qualified Control.Monad.Trans.Reader as Reader\nimport qualified Data.Aeson as Aeson\nimport qualified Data.HashMap.Strict.InsOrd as HashMap\nimport qualified Data.IORef as IORef\nimport qualified Data.JSString as JSString\nimport qualified Data.JSString.Text as JSString.Text\nimport qualified Data.List as List\nimport qualified Data.Scientific as Scientific\nimport qualified Data.Sequence as Seq\nimport qualified Data.Text as Text\nimport qualified Data.Text.Lazy as Text.Lazy\nimport qualified Data.Text.Lazy.Encoding as Text.Encoding\nimport qualified GHCJS.Foreign.Callback as Callback\nimport qualified GHCJS.Types\nimport qualified Grace.Context as Context\nimport qualified Grace.DataFile as DataFile\nimport qualified Grace.Decode as Decode\nimport qualified Grace.Import as Import\nimport qualified Grace.Infer as Infer\nimport qualified Grace.Input as Input\nimport qualified Grace.Interpret as Interpret\nimport qualified Grace.Monad as Grace\nimport qualified Grace.Monotype as Monotype\nimport qualified Grace.Normalize as Normalize\nimport qualified Grace.Pretty as Pretty\nimport qualified Grace.Syntax as Syntax\nimport qualified Grace.Type as Type\nimport qualified Grace.Value as Value\nimport qualified JavaScript.Array as Array\nimport qualified Network.URI.Encode as URI.Encode\n\ninstance (Applicative m, Semigroup a) => Semigroup (ReaderT r m a) where\n (<>) = liftA2 (<>)\n\ninstance (Applicative m, Monoid a) => Monoid (ReaderT r m a) where\n mempty = pure mempty\n\ninstance (Monad m, Semigroup a) => Semigroup (StateT r m a) where\n (<>) = liftA2 (<>)\n\ninstance (Monad m, Monoid a) => Monoid (StateT r m a) where\n mempty = pure mempty\n\nforeign import javascript unsafe \"document.getElementById($1)\"\n getElementById_ :: JSString -> IO JSVal\n\ngetElementById :: MonadIO io => Text -> io JSVal\ngetElementById a = liftIO (getElementById_ (fromText a))\n\nforeign import javascript unsafe \"$1.value\"\n toValue_ :: JSVal -> IO JSString\n\ntoValue :: MonadIO io => JSVal -> io Text\ntoValue a = liftIO (fmap toText (toValue_ a))\n\nforeign import javascript unsafe \"$1.value = $2\"\n setValue_ :: JSVal -> JSString -> IO ()\n\nsetValue :: MonadIO io => JSVal -> Text -> io ()\nsetValue a b = liftIO (setValue_ a (fromText b))\n\ntoIntegerValue :: MonadIO io => JSVal -> io Integer\ntoIntegerValue a = liftIO (fmap (read . JSString.unpack) (toValue_ a))\n\nsetIntegerValue :: MonadIO io => JSVal -> Integer -> io ()\nsetIntegerValue a b = liftIO (setValue_ a (JSString.pack (show b)))\n\ntoNaturalValue :: MonadIO io => JSVal -> io Natural\ntoNaturalValue a = liftIO (fmap (read . JSString.unpack) (toValue_ a))\n\nsetNaturalValue :: MonadIO io => JSVal -> Natural -> io ()\nsetNaturalValue a b = liftIO (setValue_ a (JSString.pack (show b)))\n\nforeign import javascript unsafe \"$1.value\"\n toDoubleValue_ :: JSVal -> IO Double\n\ntoDoubleValue :: MonadIO io => JSVal -> io Double\ntoDoubleValue a = liftIO (toDoubleValue_ a)\n\nforeign import javascript unsafe \"$1.value = $2\"\n setDoubleValue_ :: JSVal -> Double -> IO ()\n\nsetDoubleValue :: MonadIO io => JSVal -> Double -> io ()\nsetDoubleValue a b = liftIO (setDoubleValue_ a b)\n\nforeign import javascript unsafe \"$1.checked\"\n getChecked_ :: JSVal -> IO Bool\n\ngetChecked :: MonadIO io => JSVal -> io Bool\ngetChecked a = liftIO (getChecked_ a)\n\nforeign import javascript unsafe \"$1.checked = $2\"\n setChecked_ :: JSVal -> Bool -> IO ()\n\nsetChecked :: MonadIO io => JSVal -> Bool -> io ()\nsetChecked a b = liftIO (setChecked_ a b)\n\nforeign import javascript unsafe \"$1.textContent = $2\"\n setTextContent_ :: JSVal -> JSString -> IO ()\n\nsetTextContent :: MonadIO io => JSVal -> Text -> io ()\nsetTextContent a b = liftIO (setTextContent_ a (fromText b))\n\nforeign import javascript unsafe \"$1.innerText = $2\"\n setInnerText_ :: JSVal -> JSString -> IO ()\n\nsetInnerText :: MonadIO io => JSVal -> Text -> io ()\nsetInnerText a b = liftIO (setInnerText_ a (fromText b))\n\nforeign import javascript unsafe \"$1.innerHTML = $2\"\n setInnerHTML_ :: JSVal -> JSString -> IO ()\n\nsetInnerHTML :: MonadIO io => JSVal -> Text -> io ()\nsetInnerHTML a b = liftIO (setInnerHTML_ a (fromText b))\n\nforeign import javascript unsafe \"$1.style.display = $2\"\n setDisplay_ :: JSVal -> JSString -> IO ()\n\nforeign import javascript unsafe \"converter.makeHtml($1)\"\n markdownToHTML_ :: JSString -> JSString\n\nmarkdownToHTML :: Text -> Text\nmarkdownToHTML a = toText (markdownToHTML_ (fromText a))\n\nsetDisplay :: MonadIO io => JSVal -> Text -> io ()\nsetDisplay a b = liftIO (setDisplay_ a (fromText b))\n\nforeign import javascript unsafe \"$1.addEventListener($2, $3)\"\n addEventListener_ :: JSVal -> JSString -> Callback (IO ()) -> IO ()\n\naddEventListener :: MonadIO io => JSVal -> Text -> Callback (IO ()) -> io ()\naddEventListener a b c = liftIO (addEventListener_ a (fromText b) c)\n\nforeign import javascript unsafe \"autoResize($1)\"\n autoResize_ :: JSVal -> IO ()\n\nautoResize :: MonadIO io => JSVal -> io ()\nautoResize a = liftIO (autoResize_ a)\n\nforeign import javascript unsafe \"document.createElement($1)\"\n createElement_ :: JSString -> IO JSVal\n\ncreateElement :: MonadIO io => Text -> io JSVal\ncreateElement a = liftIO (createElement_ (fromText a))\n\nforeign import javascript unsafe \"$1.setAttribute($2,$3)\"\n setAttribute_ :: JSVal -> JSString -> JSString -> IO ()\n\nsetAttribute :: MonadIO io => JSVal -> Text -> Text -> io ()\nsetAttribute a b c = liftIO (setAttribute_ a (fromText b) (fromText c))\n\nforeign import javascript unsafe \"$1.disabled = $2\"\n setDisabled_ :: JSVal -> Bool -> IO ()\n\nsetDisabled :: MonadIO io => JSVal -> Bool -> io ()\nsetDisabled a b = liftIO (setDisabled_ a b)\n\nforeign import javascript unsafe \"$1.replaceChildren($2)\"\n replaceChild_ :: JSVal -> JSVal -> IO ()\n\nreplaceChild :: MonadIO io => JSVal -> JSVal -> io ()\nreplaceChild a b = liftIO (replaceChild_ a b)\n\nforeign import javascript unsafe \"new MutationObserver($1)\"\n newObserver_ :: Callback (IO ()) -> IO JSVal\n\nnewObserver :: MonadIO io => Callback (IO ()) -> io JSVal\nnewObserver a = liftIO (newObserver_ a)\n\nforeign import javascript unsafe \"$1.observe($2, { childList: true, subtree: true })\"\n observe_ :: JSVal -> JSVal -> IO ()\n\nobserve :: MonadIO io => JSVal -> JSVal -> io ()\nobserve a b = liftIO (observe_ a b)\n\nforeign import javascript unsafe \"(new URL(document.location)).searchParams\"\n getSearchParams_ :: IO JSVal\n\ngetSearchParams :: MonadIO io => io JSVal\ngetSearchParams = liftIO getSearchParams_\n\nforeign import javascript unsafe \"$1.has($2)\"\n hasParam_ :: JSVal -> JSString -> IO Bool\n\nhasParam :: MonadIO io => JSVal -> Text -> io Bool\nhasParam a b = liftIO (hasParam_ a (fromText b))\n\nforeign import javascript unsafe \"$1.get($2)\"\n getParam_ :: JSVal -> JSString -> IO JSString\n\ngetParam :: MonadIO io => JSVal -> Text -> io Text\ngetParam a b = liftIO (fmap toText (getParam_ a (fromText b)))\n\nforeign import javascript unsafe \"$1.set($2,$3)\"\n setParam_ :: JSVal -> JSString -> JSString -> IO ()\n\nsetParam :: MonadIO io => JSVal -> Text -> Text -> io ()\nsetParam a b c = liftIO (setParam_ a (fromText b) (fromText c))\n\n-- @$1.delete($2)@ doesn't work because GHCJS treats delete as a forbidden\n-- reserved keyword, so we work around this by defining the\n-- @deleteSearchParamWorkaround@ function in JavaScript which takes care of this\n-- for us\nforeign import javascript unsafe \"deleteSearchParamWorkaround($1, $2)\"\n deleteParam_ :: JSVal -> JSString -> IO ()\n\ndeleteParam :: MonadIO io => JSVal -> Text -> io ()\ndeleteParam a b = liftIO (deleteParam_ a (fromText b))\n\nforeign import javascript unsafe \"history.replaceState(null, null, '?'+$1.toString())\"\n saveSearchParams_ :: JSVal -> IO ()\n\nsaveSearchParams :: MonadIO io => JSVal -> io ()\nsaveSearchParams a = liftIO (saveSearchParams_ a)\n\n-- @$1.replaceChildren(...$2)@ does not work because GHCJS fails to parse the\n-- spread operator, so we work around this by defining the\n-- @replaceChildrenWorkaround@ function in JavaScript which takes care of the\n-- spread operator for us\nforeign import javascript unsafe \"replaceChildrenWorkaround($1, $2)\"\n replaceChildren_ :: JSVal -> JSArray -> IO ()\n\nreplaceChildren :: MonadIO io => JSVal -> [JSVal] -> io ()\nreplaceChildren a b = liftIO (replaceChildren_ a (Array.fromList b))\n\nforeign import javascript unsafe \"$1.before($2)\"\n before_ :: JSVal -> JSVal -> IO ()\n\nbefore :: MonadIO io => JSVal -> JSVal -> io ()\nbefore a b = liftIO (before_ a b)\n\nforeign import javascript unsafe \"$1.after($2)\"\n after_ :: JSVal -> JSVal -> IO ()\n\nafter :: MonadIO io => JSVal -> JSVal -> io ()\nafter a b = liftIO (after_ a b)\n\nforeign import javascript unsafe \"$1.remove()\"\n remove_ :: JSVal -> IO ()\n\nremove :: MonadIO io => JSVal -> io ()\nremove a = liftIO (remove_ a)\n\nforeign import javascript unsafe \"CodeMirror.fromTextArea($1, { mode: 'python', lineNumbers: true, viewportMargin: Infinity, extraKeys: { 'Shift-Tab': false, 'Tab': false } })\"\n setupCodemirrorInput_ :: JSVal -> IO JSVal\n\nsetupCodemirrorInput :: MonadIO io => JSVal -> io JSVal\nsetupCodemirrorInput a = liftIO (setupCodemirrorInput_ a)\n\nforeign import javascript unsafe \"CodeMirror.fromTextArea($1, { mode: 'python', lineNumbers: false, viewportMargin: Infinity, readOnly: true })\"\n setupCodemirrorOutput_ :: JSVal -> IO JSVal\n\nsetupCodemirrorOutput :: MonadIO io => JSVal -> io JSVal\nsetupCodemirrorOutput a = liftIO (setupCodemirrorOutput_ a)\n\nforeign import javascript unsafe \"$1.refresh()\"\n refresh_ :: JSVal -> IO ()\n\nrefresh :: MonadIO io => JSVal -> io ()\nrefresh a = liftIO (refresh_ a)\n\nforeign import javascript unsafe \"$1.getWrapperElement()\"\n getWrapperElement :: JSVal -> JSVal\n\nforeign import javascript unsafe \"$1.on('change', $2)\"\n onChange_ :: JSVal -> Callback (IO ()) -> IO ()\n\nonChange :: MonadIO io => JSVal -> Callback (IO ()) -> io ()\nonChange a b = liftIO (onChange_ a b)\n\nforeign import javascript unsafe \"$1.setValue($2)\"\n setCodeValue_ :: JSVal -> JSString -> IO ()\n\nsetCodeValue :: MonadIO io => JSVal -> Text -> io ()\nsetCodeValue a b = liftIO (setCodeValue_ a (fromText b))\n\nforeign import javascript unsafe \"$1.getValue()\"\n getValue_ :: JSVal -> IO JSString\n\ngetValue :: MonadIO io => JSVal -> io Text\ngetValue a = liftIO (fmap toText (getValue_ a))\n\nforeign import javascript unsafe \"document.getElementsByClassName($1)\"\n getElementsByClassName_ :: JSString -> IO JSArray\n\ngetElementsByClassName :: MonadIO io => Text -> io [JSVal]\ngetElementsByClassName a =\n fmap Array.toList (liftIO (getElementsByClassName_ (fromText a)))\n\nforeign import javascript unsafe \"$1.classList.remove($2)\"\n removeClass_ :: JSVal -> JSString -> IO ()\n\nremoveClass :: MonadIO io => JSVal -> Text -> io ()\nremoveClass a b = liftIO (removeClass_ a (fromText b))\n\nforeign import javascript unsafe \"$1.classList.add($2)\"\n addClass_ :: JSVal -> JSString -> IO ()\n\naddClass :: MonadIO io => JSVal -> Text -> io ()\naddClass a b = liftIO (addClass_ a (fromText b))\n\nforeign import javascript unsafe \"$1.focus()\"\n focus_ :: JSVal -> IO ()\n\nfocus :: MonadIO io => JSVal -> io ()\nfocus a = liftIO (focus_ a)\n\nforeign import javascript unsafe \"sessionStorage.setItem($1, $2)\"\n setSessionStorage_ :: JSString -> JSString -> IO ()\n\nsetSessionStorage :: MonadIO io => Text -> Text -> io ()\nsetSessionStorage a b = liftIO (setSessionStorage_ (fromText a) (fromText b))\n\nforeign import javascript unsafe \"sessionStorage.getItem($1)\"\n getSessionStorage_ :: JSString -> IO JSVal\n\ngetSessionStorage :: MonadIO io => Text -> io (Maybe Text)\ngetSessionStorage a = liftIO do\n jsVal <- getSessionStorage_ (fromText a)\n\n if GHCJS.Types.isNull jsVal\n then return Nothing\n else return (Just (JSString.Text.textFromJSVal jsVal))\n\nforeign import javascript unsafe \"sessionStorage.removeItem($1)\"\n removeSessionStorage_ :: JSString -> IO ()\n\nremoveSessionStorage :: MonadIO io => Text -> io ()\nremoveSessionStorage a = liftIO (removeSessionStorage_ (fromText a))\n\nforeign import javascript unsafe \"localStorage.setItem($1, $2)\"\n setLocalStorage_ :: JSString -> JSString -> IO ()\n\nsetLocalStorage :: MonadIO io => Text -> Text -> io ()\nsetLocalStorage a b = liftIO (setLocalStorage_ (fromText a) (fromText b))\n\nforeign import javascript unsafe \"localStorage.getItem($1)\"\n getLocalStorage_ :: JSString -> IO JSVal\n\ngetLocalStorage :: MonadIO io => Text -> io (Maybe Text)\ngetLocalStorage a = liftIO do\n jsVal <- getLocalStorage_ (fromText a)\n\n if GHCJS.Types.isNull jsVal\n then return Nothing\n else return (Just (JSString.Text.textFromJSVal jsVal))\n\nforeign import javascript unsafe \"print($1)\"\n printElement_ :: JSVal -> IO ()\n\nprintElement :: MonadIO io => JSVal -> io ()\nprintElement a = liftIO (printElement_ a)\n\nforeign import javascript unsafe \"navigator.clipboard.writeText($1)\"\n writeClipboard_ :: JSString -> IO ()\n\nwriteClipboard :: MonadIO io => Text -> io ()\nwriteClipboard a = liftIO (writeClipboard_ (fromText a))\n\ntoText :: JSString -> Text\ntoText = Text.pack . JSString.unpack\n\nfromText :: Text -> JSString\nfromText = JSString.pack . Text.unpack\n\ntypeToText :: Type s -> Text\ntypeToText = Pretty.renderStrict False 80\n\nvalueToText :: Value location -> Text\nvalueToText = Pretty.renderStrict False 80\n\nhideElement :: MonadIO io => JSVal -> io ()\nhideElement element = do\n setDisplay element \"none\"\n addClass element \"grace-ignore\"\n\nshowElement :: MonadIO io => Text -> JSVal -> io ()\nshowElement display element = do\n setDisplay element display\n removeClass element \"grace-ignore\"\n\ndata Config = Config\n { counter :: IORef Natural\n , status :: Status\n , input :: Input\n , edit :: Bool\n }\n\nrenderValue\n :: JSVal\n -> Type Location\n -> Value Location\n -> ReaderT Config IO (IO ())\nrenderValue parent Type.Optional{ type_ } value =\n renderValue parent type_ value\n\nrenderValue parent _ (Value.Text _ text) = do\n printable <- createElement \"div\"\n addClass printable \"grace-printable\"\n\n markdown <- createElement \"div\"\n addClass markdown \"grace-output-text\"\n\n let innerHTML = if text == \"\" then \"

\\x200B

\" else markdownToHTML text\n setInnerHTML markdown innerHTML\n\n sidebar <- createElement \"div\"\n addClass sidebar \"grace-printable-buttons\"\n\n printButton <- createElement \"button\"\n addClass printButton \"grace-print\"\n setAttribute printButton \"type\" \"button\"\n setInnerText printButton \"Print\"\n hideElement printButton\n\n printCallback <- liftIO (Callback.asyncCallback (printElement markdown))\n addEventListener printButton \"click\" printCallback\n\n copyButton <- createElement \"button\"\n addClass copyButton \"grace-copy\"\n setAttribute copyButton \"type\" \"button\"\n setInnerText copyButton \"Copy\"\n hideElement copyButton\n\n copyCallback <- liftIO (Callback.asyncCallback (writeClipboard text))\n addEventListener copyButton \"click\" copyCallback\n\n showCallback <- (liftIO . Callback.asyncCallback) do\n showElement \"inline-block\" printButton\n showElement \"inline-block\" copyButton\n\n hideCallback <- (liftIO . Callback.asyncCallback) do\n hideElement printButton\n hideElement copyButton\n\n addEventListener parent \"mouseenter\" showCallback\n addEventListener parent \"mouseleave\" hideCallback\n\n replaceChildren sidebar [ printButton, copyButton ]\n replaceChildren printable [ markdown, sidebar ]\n replaceChild parent printable\n\n mempty\n\nrenderValue parent _ (Value.Scalar _ (Bool bool)) = do\n input <- createElement \"input\"\n addClass input \"grace-output-bool\"\n setAttribute input \"type\" \"checkbox\"\n setDisabled input True\n\n Monad.when bool (setAttribute input \"checked\" \"\")\n\n replaceChild parent input\n\n mempty\n\nrenderValue parent _ (Value.Scalar _ Null) = do\n span <- createElement \"span\"\n addClass span \"grace-output-json\"\n setTextContent span \"∅\"\n\n replaceChild parent span\n\n mempty\n\nrenderValue parent _ value@Value.Scalar{} = do\n span <- createElement \"span\"\n addClass span \"grace-output-json\"\n setTextContent span (valueToText value)\n\n replaceChild parent span\n\n mempty\n\nrenderValue parent outer (Value.List _ values) = do\n inner <- case outer of\n Type.List{ type_ } -> do\n return type_\n\n Type.Scalar{ scalar = Monotype.JSON } -> do\n return outer\n\n _ -> do\n fail \"renderValue: Missing element type\"\n\n results <- forM values \\value -> do\n li <- createElement \"li\"\n addClass li \"grace-output-element\"\n\n refreshOutput <- renderValue li inner value\n\n return (li, refreshOutput)\n\n let (lis, refreshOutputs) = unzip (toList results)\n\n ul <- createElement \"ul\"\n addClass ul \"grace-output-list\"\n addClass ul \"grace-stack\"\n\n replaceChildren ul lis\n\n replaceChild parent ul\n\n return (sequence_ refreshOutputs)\n\nrenderValue parent outer (Value.Record _ keyValues) = do\n let lookupKey = case outer of\n Type.Record{ fields = Type.Fields keyTypes _ } ->\n \\key -> lookup key keyTypes\n\n Type.Scalar{ scalar = Monotype.JSON } ->\n \\_ -> pure outer\n\n _ ->\n \\_ -> empty\n\n let process key (_, value) = do\n type_ <- case lookupKey key of\n Nothing -> fail \"renderValue: Missing field type\"\n Just type_ -> return type_\n\n dt <- createElement \"dt\"\n addClass dt \"grace-output-field-name\"\n\n setTextContent dt key\n\n dd <- createElement \"dd\"\n addClass dt \"grace-output-field-value\"\n\n refreshOutput <- renderValue dd type_ value\n\n definition <- createElement \"div\"\n replaceChildren definition [ dt, dd ]\n\n return (definition, refreshOutput)\n\n result <- HashMap.traverseWithKey process keyValues\n\n let (definitions, refreshOutputs) = unzip (HashMap.elems result)\n\n dl <- createElement \"dl\"\n addClass dl \"grace-output-record\"\n addClass dl \"grace-stack\"\n\n replaceChildren dl definitions\n\n replaceChild parent dl\n\n return (sequence_ refreshOutputs)\n\nrenderValue parent outer (Value.Application _ (Value.Builtin _ Syntax.Some) value) = do\n renderValue parent outer value\n\nrenderValue parent outer (Value.Alternative location alternative value) = do\n inner <- case outer of\n Type.Union{ alternatives = Type.Alternatives keyTypes _ } ->\n case lookup alternative keyTypes of\n Nothing -> fail \"renderValue: Missing alternative type\"\n Just type_ -> return type_\n\n _ -> do\n fail \"renderValue: Missing alternative type\"\n\n -- Render unions the same as a record with one field\n let recordType = Type.Record\n { location = Type.location outer\n , fields = Type.Fields [(alternative, inner)] EmptyFields\n }\n\n let recordValue =\n Value.Record location (HashMap.singleton alternative (location, value))\n\n renderValue parent recordType recordValue\n\nrenderValue parent Type.Function{ location, input, output } function = do\n r@Config{ edit, status, input = input_ } <- Reader.ask\n\n outputVal <- createElement \"div\"\n addClass outputVal \"grace-result\"\n\n let hasEffects = Lens.has Value.effects function\n\n let tabbed = edit && hasEffects\n\n (setBusy, setSuccess, setError) <- createForm tabbed outputVal\n\n let render Nothing = do\n replaceChildren outputVal []\n\n render (Just value) = do\n setBusy\n\n let interpretOutput = do\n newValue <- Normalize.apply location function value\n\n status_@Status{ context } <- State.get\n\n let completedType = Context.complete context output\n\n let solvedType = Context.solveType context output\n\n refreshOutput <- liftIO $ setSuccess completedType newValue \\htmlWrapper -> do\n Reader.runReaderT (renderValue htmlWrapper solvedType newValue) (r :: Config){ status = status_ }\n\n liftIO refreshOutput\n\n eitherResult <- liftIO (Exception.try (Grace.evalGrace input_ status interpretOutput))\n\n case eitherResult of\n Left exception -> do\n setError (Text.pack (displayException (exception :: SomeException)))\n\n Right x -> do\n return x\n\n debouncedRender <- debounce render\n\n let renderOutput Change | hasEffects = mempty\n renderOutput _ = debouncedRender\n\n (_, reader) <- renderInput [] input\n\n i <- Reader.ask\n\n result <- liftIO (Maybe.runMaybeT (Reader.runReaderT (reader renderOutput) i))\n\n case result of\n Nothing -> do\n replaceChildren parent [ ]\n\n mempty\n\n Just (inputVal, invoke, refreshOutput) -> do\n if hasEffects\n then do\n button <- createElement \"button\"\n addClass button \"grace-submit\"\n setAttribute button \"type\" \"button\"\n setTextContent button \"Submit\"\n\n buttons <- createElement \"div\"\n addClass buttons \"grace-cluster\"\n replaceChild buttons button\n\n hr <- createElement \"hr\"\n addClass hr \"grace-horizontal-rule\"\n\n stack <- createElement \"div\"\n addClass stack \"grace-stack-large\"\n\n callback <- (liftIO . Callback.asyncCallback) do\n replaceChildren stack [ inputVal, buttons, hr, outputVal ]\n\n invoke Submit\n\n addEventListener button \"click\" callback\n\n replaceChildren stack [ inputVal, buttons ]\n\n replaceChild parent stack\n\n else do\n liftIO (invoke Submit)\n\n hr <- createElement \"hr\"\n addClass hr \"grace-horizontal-rule\"\n\n stack <- createElement \"div\"\n addClass stack \"grace-stack-large\"\n\n replaceChildren stack [ inputVal, hr, outputVal ]\n\n replaceChild parent stack\n\n return refreshOutput\n\n-- At the time of this writing this case should (in theory) never be hit,\n-- because all of the `Value` constructors are either explicitly handled (e.g.\n-- `Text` / `Scalar`) or handled by the case for `Type.Function` (e.g. `Builtin`\n-- / `Alternative`)\nrenderValue parent _ value = do\n renderDefault parent value\n\nrenderDefault :: MonadIO io => JSVal -> Value Location -> io (IO ())\nrenderDefault parent value = liftIO do\n code <- createElement \"code\"\n addClass code \"grace-output-default\"\n\n setTextContent code (valueToText value)\n\n replaceChild parent code\n\n mempty\n\ndata Mode\n = Change\n -- ^ The function is being run in response to a form input changing\n | Submit\n -- ^ The function is being run in response to form submission\n\nregister\n :: MonadIO m\n => JSVal\n -> MaybeT IO (Value Location)\n -> (Mode -> Maybe (Value Location) -> IO ())\n -> ReaderT Config m (Mode -> IO ())\nregister input get renderOutput = liftIO do\n let invoke mode = do\n maybeValue <- Maybe.runMaybeT get\n\n renderOutput mode maybeValue\n\n callback <- Callback.asyncCallback (invoke Change)\n\n addEventListener input \"input\" callback\n\n return invoke\n\nrenderPath :: [Text] -> Type Location -> Text\nrenderPath path type_ = (prefix <> \" : \" <> suffix)\n where\n prefix =\n Text.intercalate \".\"\n (fmap (Pretty.toText . Type.prettyRecordLabel False) path)\n\n suffix = Pretty.toText type_\n\nfromStorage :: (MonadIO io, FromGrace a) => Maybe Text -> io (Maybe a)\nfromStorage Nothing = do\n return Nothing\nfromStorage (Just text) = liftIO do\n load `catch` \\(_ :: SomeException) -> return Nothing\n where\n load = do\n a <- Interpret.load (Code \"(storage)\" text)\n return (Just a)\n\ntoStorage :: ToGrace a => a -> Text\ntoStorage a = Pretty.toText (encode a)\n\nrenderInput\n :: [Text]\n -> Type Location\n -> ReaderT Config IO\n ( Maybe (Value Location)\n , (Mode -> Maybe (Value Location) -> IO ())\n -> ReaderT Config (MaybeT IO) (JSVal, Mode -> IO (), IO ())\n )\nrenderInput path type_@Type.Scalar{ location, scalar = Monotype.Bool } = do\n maybeText <- getSessionStorage (renderPath path type_)\n\n maybeBool <- fromStorage maybeText\n\n let bool₀ = case maybeBool of\n Just b -> b\n Nothing -> False\n\n let maybeValue₀ = Just (Value.Scalar location (Bool bool₀))\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n input <- createElement \"input\"\n addClass input \"grace-input-bool\"\n setAttribute input \"type\" \"checkbox\"\n\n setChecked input bool₀\n\n let get = do\n bool <- getChecked input\n\n setSessionStorage (renderPath path type_) (toStorage bool)\n\n return (Value.Scalar location (Bool bool))\n\n invoke <- register input get renderOutput\n\n return (input, invoke, mempty)\n\nrenderInput path type_@Type.Scalar{ location, scalar = Monotype.Real } = do\n maybeText <- getSessionStorage (renderPath path type_)\n\n maybeScientific <- fromStorage maybeText\n\n let scientific₀ = case maybeScientific of\n Just s -> s\n Nothing -> 0\n\n let maybeValue₀ = Just (Value.Scalar location (Real scientific₀))\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n input <- createElement \"input\"\n addClass input \"grace-input-json\"\n setAttribute input \"type\" \"number\"\n setAttribute input \"step\" \"any\"\n setAttribute input \"value\" \"0\"\n\n setDoubleValue input (Scientific.toRealFloat scientific₀)\n\n let get = do\n double <- toDoubleValue input\n\n setSessionStorage (renderPath path type_) (toStorage double)\n\n return (Value.Scalar location (Real (Scientific.fromFloatDigits double)))\n\n invoke <- register input get renderOutput\n\n return (input, invoke, mempty)\n\nrenderInput path type_@Type.Scalar{ location, scalar = Monotype.Integer } = do\n maybeText <- getSessionStorage (renderPath path type_)\n\n maybeInteger <- fromStorage maybeText\n\n let integer₀ = case maybeInteger of\n Just i -> i\n Nothing -> 0\n\n let maybeValue₀ = Just (Value.Scalar location (Integer integer₀))\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n input <- createElement \"input\"\n addClass input \"grace-input-json\"\n setAttribute input \"type\" \"number\"\n setAttribute input \"value\" \"0\"\n\n setIntegerValue input integer₀\n\n let get = do\n integer <- toIntegerValue input\n\n setSessionStorage (renderPath path type_) (toStorage integer)\n\n return (Value.Scalar location (Integer integer))\n\n invoke <- register input get renderOutput\n\n return (input, invoke, mempty)\n\nrenderInput path type_@Type.Scalar{ location, scalar = Monotype.Natural } = do\n maybeText <- getSessionStorage (renderPath path type_)\n\n maybeNatural <- fromStorage maybeText\n\n let natural₀ = case maybeNatural of\n Just n -> n\n Nothing -> 0\n\n let maybeValue₀ = Just (Value.Scalar location (Natural natural₀))\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n input <- createElement \"input\"\n addClass input \"grace-input-json\"\n setAttribute input \"type\" \"number\"\n setAttribute input \"value\" \"0\"\n setAttribute input \"min\" \"0\"\n\n setNaturalValue input natural₀\n\n let get = do\n natural <- toNaturalValue input\n\n setSessionStorage (renderPath path type_) (toStorage natural)\n\n return (Value.Scalar location (Natural natural))\n\n invoke <- register input get renderOutput\n\n return (input, invoke, mempty)\n\nrenderInput path type_@Type.Scalar{ scalar = Monotype.JSON } = do\n maybeText <- getSessionStorage (renderPath path type_)\n\n maybeTextValue <- fromStorage maybeText\n\n let text₀ = case maybeTextValue of\n Just t -> t\n Nothing -> \"null\"\n\n let maybeValue₀ = do\n let lazyText = Text.Lazy.fromStrict text₀\n\n value :: Value () <- Aeson.decode (Text.Encoding.encodeUtf8 lazyText)\n\n return (fmap (\\_ -> Unknown) value)\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n input <- createElement \"input\"\n addClass input \"grace-input-json\"\n addClass input \"grace-input-json-valid\"\n setAttribute input \"placeholder\" \"Enter JSON…\"\n setAttribute input \"data-1p-ignore\" \"\"\n\n setValue input text₀\n\n let get = do\n strictText <- toValue input\n\n setSessionStorage (renderPath path type_) (toStorage strictText)\n\n let lazyText = Text.Lazy.fromStrict strictText\n\n case Aeson.eitherDecode (Text.Encoding.encodeUtf8 lazyText) of\n Left _ -> do\n removeClass input \"grace-input-json-valid\"\n addClass input \"grace-input-json-invalid\"\n\n empty\n\n Right value -> do\n removeClass input \"grace-input-json-invalid\"\n addClass input \"grace-input-json-valid\"\n\n return (fmap (\\_ -> Unknown) (value :: Value ()))\n\n invoke <- register input get renderOutput\n\n return (input, invoke, mempty)\n\nrenderInput path type_@Type.Scalar{ location, scalar = Monotype.Text } = do\n maybeText <- getSessionStorage (renderPath path type_)\n\n maybeTextValue <- fromStorage maybeText\n\n let text₀ = case maybeTextValue of\n Just t -> t\n Nothing -> \"\"\n\n let maybeValue₀ = Just (Value.Text location text₀)\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n input <- createElement \"textarea\"\n addClass input \"grace-input-text\"\n setAttribute input \"rows\" \"1\"\n setAttribute input \"placeholder\" \"Enter text…\"\n setAttribute input \"data-1p-ignore\" \"\"\n\n autoResize input\n\n setValue input text₀\n\n let get = do\n text <- toValue input\n\n setSessionStorage (renderPath path type_) (toStorage text)\n\n return (Value.Text location text)\n\n invoke <- register input get renderOutput\n\n return (input, invoke, mempty)\n\nrenderInput path type_@Type.Scalar{ location, scalar = Monotype.Key } = do\n maybeText <- getLocalStorage (renderPath path type_)\n\n maybeKey <- fromStorage maybeText\n\n let key₀ = case maybeKey of\n Just (Decode.Key k) -> k\n Nothing -> \"\"\n\n let maybeValue₀ = Just (Value.Scalar location (Key key₀))\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n input <- createElement \"input\"\n addClass input \"grace-input-json\"\n setAttribute input \"placeholder\" \"Enter key…\"\n setAttribute input \"type\" \"password\"\n setAttribute input \"rows\" \"1\"\n\n setValue input key₀\n\n let get = do\n key <- toValue input\n\n setLocalStorage (renderPath path type_) (toStorage key)\n\n return (Value.Scalar location (Key key))\n\n invoke <- register input get renderOutput\n\n return (input, invoke, mempty)\n\nrenderInput path Type.Record{ location, fields = Type.Fields keyTypes _ } = do\n let outer (key, type_) = do\n (maybeStart, reader) <- renderInput (key : path) type_\n\n return (key, (key, fmap ((,) location) maybeStart), (key, reader))\n\n result <- traverse outer keyTypes\n\n let (keys, keyMaybeStarts, keyReaders) = unzip3 result\n\n let hashMap = HashMap.fromList keyMaybeStarts\n\n let maybeValue₀ = do\n keyStarts <- sequence hashMap\n\n Monad.guard (HashMap.keys keyStarts == keys)\n\n return (Value.Record location keyStarts)\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n ref <- liftIO (IORef.newIORef hashMap)\n\n let inner (key, reader) = do\n let newRenderOutput mode maybeValue = do\n let update m = (m', m')\n where\n m' = HashMap.insert key (fmap ((,) location) maybeValue) m\n\n keyMaybeValues <- liftIO (IORef.atomicModifyIORef' ref update)\n\n let maybeRecord = do\n keyValues <- sequence keyMaybeValues\n\n Monad.guard (HashMap.keys keyValues == keys)\n\n return (Value.Record location keyValues)\n\n renderOutput mode maybeRecord\n\n (inputField, _, refreshField) <- reader newRenderOutput\n\n dt <- createElement \"dt\"\n addClass dt \"grace-input-field-name\"\n\n setTextContent dt key\n\n dd <- createElement \"dd\"\n addClass dt \"grace-input-field-value\"\n\n replaceChild dd inputField\n\n definition <- createElement \"div\"\n replaceChildren definition [ dt, dd ]\n\n return (definition, refreshField)\n\n results <- traverse inner keyReaders\n\n let (definitions, refreshOutputs) = unzip results\n\n dl <- createElement \"dl\"\n addClass dl \"grace-input-record\"\n addClass dl \"grace-stack\"\n\n replaceChildren dl definitions\n\n let invoke mode = do\n keyMaybeValues <- IORef.readIORef ref\n\n let maybeRecord = do\n keyValues <- sequence keyMaybeValues\n\n return (Value.Record location keyValues)\n\n renderOutput mode maybeRecord\n\n let refreshOutput = sequence_ refreshOutputs\n\n return (dl, invoke, refreshOutput)\n\nrenderInput path type_@Type.Union{ location, alternatives = Type.Alternatives keyTypes _ } = do\n maybeAlternative <- getSessionStorage (renderPath path type_)\n\n let predicate = case maybeAlternative of\n Nothing -> \\_ -> True\n Just a -> \\(k, _) -> k == a\n\n case List.find predicate keyTypes of\n Nothing -> do\n renderInputDefault path type_\n\n Just (key₀, type_₀) -> do\n (maybeStart, _) <- renderInput (key₀ : path) type_₀\n\n let maybeValue₀ = do\n start <- maybeStart\n\n return (Value.Alternative location key₀ start)\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n Config{ counter } <- Reader.ask\n\n n <- liftIO (IORef.atomicModifyIORef' counter (\\a -> (a + 1, a)))\n\n checkedValRef <- liftIO (IORef.newIORef Nothing)\n\n let process (key, alternativeType) = do\n let checked = key == key₀\n\n let name = \"radio\" <> Text.pack (show n)\n\n let id = name <> \"-\" <> key\n\n input <- createElement \"input\"\n addClass input \"grace-input-alternative-radio\"\n setAttribute input \"type\" \"radio\"\n setAttribute input \"name\" name\n setAttribute input \"id\" id\n Monad.when checked (setAttribute input \"checked\" \"\")\n\n box <- createElement \"div\"\n addClass box \"grace-input-alternative-radio-box\"\n replaceChild box input\n\n inputStack <- createElement \"div\"\n addClass inputStack \"grace-stack\"\n replaceChild inputStack box\n\n let newRenderOutput mode maybeValue = do\n enabled <- getChecked input\n\n let maybeResult = do\n value <- maybeValue\n\n return (Alternative location key value)\n\n Monad.when enabled (renderOutput mode maybeResult)\n\n (_, reader) <- hoist lift (renderInput (key : path) alternativeType)\n\n (nestedInput, nestedInvoke, nestedRefresh) <- reader newRenderOutput\n\n label <- createElement \"label\"\n addClass label \"grace-input-alternative-label\"\n setAttribute label \"for\" id\n setTextContent label key\n\n fieldset <- createElement \"fieldset\"\n setDisabled fieldset (not checked)\n\n replaceChild fieldset nestedInput\n\n alternativeStack <- createElement \"div\"\n addClass alternativeStack \"grace-input-alternative\"\n addClass alternativeStack \"grace-stack\"\n\n case alternativeType of\n Type.Record{ fields = Type.Fields kts _ } | null kts -> do\n replaceChild alternativeStack label\n _ -> do\n replaceChildren alternativeStack [ label, fieldset ]\n\n sidebar <- createElement \"div\"\n addClass sidebar \"grace-input-alternative-selection\"\n\n replaceChildren sidebar [ inputStack, alternativeStack]\n\n liftIO (Monad.when checked (IORef.writeIORef checkedValRef (Just fieldset)))\n\n liftIO do\n let update mode = do\n setSessionStorage (renderPath path type_) key\n\n let adapt m = (Just fieldset, m)\n\n oldFieldset <- IORef.atomicModifyIORef' checkedValRef adapt\n\n traverse_ (\\x -> setDisabled x True) oldFieldset\n\n setDisabled fieldset False\n\n nestedInvoke mode\n\n callback <- Callback.asyncCallback (update Change)\n\n addEventListener input \"input\" callback\n\n let invoke mode = do\n enabled <- getChecked input\n\n Monad.when enabled (nestedInvoke mode)\n\n return (sidebar, invoke, nestedRefresh)\n\n results <- traverse process keyTypes\n\n let (children, invokes, refreshOutputs) = unzip3 results\n\n div <- createElement \"div\"\n addClass div \"grace-input-union\"\n\n replaceChildren div children\n\n let invoke mode = sequence_ (map ($ mode) invokes)\n\n let refreshOutput = sequence_ refreshOutputs\n\n liftIO (invoke Change)\n\n return (div, invoke, refreshOutput)\n\nrenderInput path optionalType@Type.Optional{ location, type_ } = do\n maybeText <- getSessionStorage (renderPath path optionalType)\n\n maybeEnabled <- fromStorage maybeText\n\n let enabled = case maybeEnabled of\n Just b -> b\n Nothing -> False\n\n (maybeStart, reader) <- renderInput (\"?\" : path) type_\n\n let maybeValue₀ = if enabled\n then do\n start <- maybeStart\n\n return (Application location (Value.Builtin location Syntax.Some) start)\n else do\n return (Value.Scalar location Null)\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n input <- createElement \"input\"\n addClass input \"grace-input-bool\"\n setAttribute input \"type\" \"checkbox\"\n\n setChecked input enabled\n\n let newRenderOutput mode maybeValue = do\n checked <- getChecked input\n\n if checked\n then do\n let maybeSomeValue = do\n value <- maybeValue\n\n return (Application location (Value.Builtin location Syntax.Some) value)\n\n renderOutput mode maybeSomeValue\n else do\n renderOutput mode (Just (Value.Scalar location Null))\n\n (nestedInput, nestedInvoke, nestedRefresh) <- reader newRenderOutput\n\n box <- createElement \"div\"\n addClass box \"grace-input-bool-box\"\n replaceChild box input\n\n sidebar <- createElement \"div\"\n addClass sidebar \"grace-stack\"\n replaceChild sidebar box\n\n div <- createElement \"div\"\n addClass div \"grace-input-optional\"\n\n fieldset <- createElement \"fieldset\"\n\n replaceChild fieldset nestedInput\n\n replaceChildren div [sidebar, fieldset]\n\n liftIO do\n let update mode = do\n checked <- getChecked input\n\n setSessionStorage (renderPath path optionalType) (toStorage checked)\n\n setDisabled fieldset (not checked)\n\n nestedInvoke mode\n\n callback <- Callback.asyncCallback (update Change)\n\n addEventListener input \"input\" callback\n\n update Change\n\n return (div, nestedInvoke, nestedRefresh)\n\nrenderInput path listType@Type.List{ location, type_ } = do\n maybeText <- getSessionStorage (renderPath path listType)\n\n maybeIndex <- fromStorage maybeText\n\n let length = case maybeIndex of\n Just n -> n :: Natural\n Nothing -> 0\n\n let process index = do\n renderInput (Text.pack (show (index :: Integer)) : path) type_\n\n results <- traverse process [ 0 .. (fromIntegral length - 1) ]\n\n let (maybeStarts, readers) = unzip results\n\n let maybeValue₀ = do\n starts <- sequence maybeStarts\n\n return (Value.List location (Seq.fromList starts))\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n childrenRef <- liftIO (IORef.newIORef Seq.empty)\n\n plus <- createElement \"button\"\n addClass plus \"grace-input-list-plus\"\n setAttribute plus \"type\" \"button\"\n\n setTextContent plus \"+\"\n\n minus <- createElement \"button\"\n addClass minus \"grace-input-list-minus\"\n setAttribute minus \"type\" \"button\"\n hideElement minus\n\n setTextContent minus \"-\"\n\n buttons <- createElement \"li\"\n addClass buttons \"grace-input-list-element\"\n addClass buttons \"grace-cluster-start\"\n\n replaceChildren buttons [ plus, minus ]\n\n ul <- createElement \"ul\"\n addClass ul \"grace-input-list\"\n addClass ul \"grace-stack\"\n\n replaceChild ul buttons\n\n input <- Reader.ask\n\n let insert maybeReader = do\n showElement \"inline-block\" minus\n\n children₀ <- IORef.readIORef childrenRef\n\n let index = Seq.length children₀\n\n reader <- case maybeReader of\n Just reader -> do\n return reader\n Nothing -> do\n (_, reader) <- Reader.runReaderT (process (fromIntegral index)) input\n\n return reader\n\n IORef.atomicModifyIORef' childrenRef (\\s -> (s |> _Child, ()))\n\n setSessionStorage (renderPath path listType) (toStorage (fromIntegral index + 1 :: Natural))\n\n let newRenderOutput mode maybeValue = do\n let adjust =\n Seq.adjust (\\c -> c{ value = maybeValue }) index\n\n let adapt s = let s' = adjust s in (s', s')\n\n children <- IORef.atomicModifyIORef' childrenRef adapt\n\n let maybeList = do\n values <- traverse (\\Child{ value } -> value) children\n\n return (Value.List location values)\n\n renderOutput mode maybeList\n\n result <- Maybe.runMaybeT (Reader.runReaderT (reader newRenderOutput) input)\n\n li <- createElement \"li\"\n addClass li \"grace-input-list-element\"\n\n before buttons li\n\n case result of\n Nothing -> do\n return ()\n\n Just (nestedInput, nestedInvoke, nestedRefresh) -> do\n replaceChild li nestedInput\n\n let adjust =\n Seq.adjust (\\c -> c{ refreshOutput = nestedRefresh, li = Just li }) index\n\n IORef.atomicModifyIORef' childrenRef (\\m -> (adjust m, ()))\n\n nestedRefresh\n\n nestedInvoke Change\n\n liftIO (traverse_ (insert . Just) readers)\n\n insertCallback <- (liftIO . Callback.asyncCallback) (insert Nothing)\n\n addEventListener plus \"click\" insertCallback\n\n let invoke mode = do\n children <- IORef.readIORef childrenRef\n\n let maybeList = do\n values <- traverse (\\Child{ value } -> value) children\n\n return (Value.List location values)\n\n renderOutput mode maybeList\n\n delete <- (liftIO . Callback.asyncCallback) do\n children <- IORef.readIORef childrenRef\n\n case Seq.viewr children of\n prefix :> Child{ li } -> do\n Monad.when (Seq.null prefix) (hideElement minus)\n\n setSessionStorage (renderPath path listType) (toStorage (fromIntegral (Seq.length prefix) :: Natural))\n\n traverse_ remove li\n\n IORef.writeIORef childrenRef prefix\n\n invoke Change\n\n EmptyR -> do\n return ()\n\n addEventListener minus \"click\" delete\n\n let refreshOutput = do\n children <- IORef.readIORef childrenRef\n\n sequence_ do\n Child{ refreshOutput = nestedRefresh } <- children\n\n return nestedRefresh\n\n return (ul, invoke, refreshOutput)\n\nrenderInput path type_ = do\n renderInputDefault path type_\n\ndata Child = Child\n { value :: Maybe (Value Location)\n , refreshOutput :: IO ()\n , li :: Maybe JSVal\n }\n\n_Child :: Child\n_Child = Child\n { value = Nothing\n , refreshOutput = mempty\n , li = Nothing\n }\n\nrenderInputDefault\n :: [Text]\n -> Type Location\n -> ReaderT Config IO\n ( Maybe (Value Location)\n , (Mode -> Maybe (Value Location) -> IO ())\n -> ReaderT Config (MaybeT IO) (JSVal, Mode -> IO (), IO ())\n )\nrenderInputDefault path type_ = do\n Config{ status = status₀, input = input₀ } <- Reader.ask\n\n maybeText <- getSessionStorage (renderPath path type_)\n\n let text₀ = case maybeText of\n Just t -> t\n Nothing -> \"\"\n\n let textToValue text = do\n let newInput = input₀ <> Code \"(input)\" text\n\n let interpretInput = do\n (_, value) <- Interpret.interpretWith [] (Just type_)\n\n return value\n\n Grace.evalGrace newInput status₀ interpretInput\n\n result₀ <- Exception.try (textToValue text₀)\n\n let maybeValue₀ = case result₀ of\n Left (_ :: SomeException) -> Nothing\n Right v -> Just v\n\n return $ (,) maybeValue₀ \\renderOutput -> do\n Config{ status, input } <- Reader.ask\n\n textarea <- createElement \"textarea\"\n setAttribute textarea \"placeholder\" \"Enter code…\"\n\n hideElement textarea\n\n error <- createElement \"pre\"\n addClass error \"grace-error\"\n\n hideElement error\n\n div <- createElement \"div\"\n addClass div \"grace-pane\"\n addClass div \"grace-stack\"\n\n replaceChildren div [ textarea, error ]\n\n codeInput <- setupCodemirrorInput textarea\n\n setCodeValue codeInput text₀\n\n let get = do\n text <- getValue codeInput\n\n setSessionStorage (renderPath path type_) text\n\n let newInput = input <> Code \"(input)\" text\n\n let interpretInput = do\n (_, value) <- Interpret.interpretWith [] (Just type_)\n\n return value\n\n result <- liftIO (Exception.try (Grace.evalGrace newInput status interpretInput))\n\n case result of\n Left exception -> do\n if (text == \"\")\n then do\n hideElement error\n else do\n setTextContent error (Text.pack (displayException (exception :: SomeException)))\n\n showElement \"block\" error\n\n empty\n\n Right value -> do\n hideElement error\n\n setTextContent error \"\"\n\n return value\n\n liftIO do\n let invoke mode = do\n maybeValue <- Maybe.runMaybeT get\n\n renderOutput mode maybeValue\n\n callback <- Callback.asyncCallback (invoke Change)\n\n onChange codeInput callback\n\n return (div, invoke, refresh codeInput)\n\ndata DebounceStatus = Ready | Lock | Running (Async ())\n\ndebounce :: MonadIO io => (a -> IO ()) -> io (a -> IO ())\ndebounce f = liftIO do\n tvar <- TVar.newTVarIO Ready\n\n return \\args -> do\n m <- STM.atomically do\n status <- TVar.readTVar tvar\n\n case status of\n Ready -> do\n TVar.writeTVar tvar Lock\n return Nothing\n Lock -> do\n empty\n Running async -> do\n return (Just async)\n\n traverse_ Async.cancel m\n\n async <- Async.async (f args)\n\n STM.atomically (TVar.writeTVar tvar (Running async))\n\n Async.wait async\n\n STM.atomically (TVar.writeTVar tvar Ready)\n\ncreateForm\n :: MonadIO io\n => Bool\n -- ^ Show tabs?\n -> JSVal\n -> io\n ( IO ()\n , Type Location -> Value Location -> (JSVal -> IO (IO ())) -> IO (IO ())\n , Text -> IO ()\n )\ncreateForm showTabs output = liftIO do\n let toTab name = do\n tab <- createElement \"button\"\n addClass tab \"grace-tab\"\n setAttribute tab \"type\" \"button\"\n setTextContent tab name\n\n return tab\n\n formTab <- toTab \"Form\"\n codeTab <- toTab \"Code\"\n typeTab <- toTab \"Type\"\n\n let tabs = [ formTab, codeTab, typeTab ]\n\n tabsList <- createElement \"div\"\n addClass tabsList \"grace-tabs\"\n\n replaceChildren tabsList tabs\n\n pane <- createElement \"div\"\n addClass pane \"grace-pane\"\n Monad.when showTabs (addClass pane \"grace-tabbed\")\n\n success <- createElement \"div\"\n addClass success \"grace-success\"\n\n let successChildren = if showTabs then [ tabsList, pane ] else [ pane ]\n\n replaceChildren success successChildren\n\n codemirrorBuffer <- getElementById \"codemirror-buffer\"\n\n let createCodemirrorOutput = do\n textarea <- createElement \"textarea\"\n setAttribute textarea \"placeholder\" \"Enter code…\"\n\n replaceChild codemirrorBuffer textarea\n\n codeMirror <- setupCodemirrorOutput textarea\n\n replaceChildren codemirrorBuffer []\n\n return (codeMirror, getWrapperElement codeMirror)\n\n htmlWrapper <- createElement \"form\"\n addClass htmlWrapper \"grace-form\"\n setAttribute htmlWrapper \"autocomplete\" \"off\"\n\n (codeOutput, codeWrapper) <- createCodemirrorOutput\n (typeOutput, typeWrapper) <- createCodemirrorOutput\n\n let registerTabCallback selectedTab action = do\n callback <- Callback.asyncCallback do\n let deselect tab = removeClass tab \"grace-tab-selected\"\n\n traverse_ deselect tabs\n\n addClass selectedTab \"grace-tab-selected\"\n\n action\n\n addEventListener selectedTab \"click\" callback\n\n registerTabCallback formTab do\n replaceChild pane htmlWrapper\n\n registerTabCallback codeTab do\n replaceChild pane codeWrapper\n\n refresh codeOutput\n\n registerTabCallback typeTab do\n replaceChild pane typeWrapper\n\n refresh typeOutput\n\n addClass formTab \"grace-tab-selected\"\n\n replaceChild pane htmlWrapper\n\n spinner <- do\n spinner <- createElement \"div\"\n addClass spinner \"grace-spinner\"\n setAttribute spinner \"role\" \"status\"\n setAttribute spinner \"overflow\" \"hidden\"\n\n return spinner\n\n error <- createElement \"pre\"\n addClass error \"grace-error\"\n\n let setBusy = do\n replaceChild output spinner\n\n let setError text = do\n setTextContent error text\n\n replaceChild output error\n\n let setSuccess type_ value render = do\n setCodeValue codeOutput (valueToText value)\n setCodeValue typeOutput (typeToText type_)\n\n refreshInput <- render htmlWrapper\n\n replaceChild output success\n\n refresh codeOutput\n refresh typeOutput\n\n return refreshInput\n\n return (setBusy, setSuccess, setError)\n\nmain :: IO ()\nmain = do\n inputArea <- getElementById \"input\"\n startTutorial <- getElementById \"start-tutorial\"\n\n codeInput <- setupCodemirrorInput inputArea\n\n counter <- IORef.newIORef 0\n\n params <- getSearchParams\n\n hasGitHub <- hasParam params \"github\"\n\n hasTutorial <- hasParam params \"tutorial\"\n\n maybeExpression₀ <- do\n hasExpression <- hasParam params \"expression\"\n\n if hasExpression\n then do\n expression <- getParam params \"expression\"\n\n return (Just expression)\n else do\n return Nothing\n\n maybeExpression₁ <- getSessionStorage \"expression\"\n\n let maybeExpression = maybeExpression₀ <|> maybeExpression₁\n\n hasEdit <- hasParam params \"edit\"\n\n edit <- if hasTutorial\n then do\n setParam params \"edit\" \"true\"\n\n return True\n else do\n if hasEdit\n then do\n return True\n else do\n if isJust maybeExpression || hasGitHub\n then do\n return False\n else do\n setParam params \"edit\" \"true\"\n\n return True\n\n if edit\n then do\n title <- getElementById \"title\"\n\n showElement \"block\" title\n\n focus codeInput\n else do\n hideElement (getWrapperElement codeInput)\n\n output <- getElementById \"output\"\n addClass output \"grace-result\"\n\n (setBusy, setSuccess, setError) <- createForm edit output\n\n let interpret () = do\n text <- getValue codeInput\n\n if text == \"\" || hasGitHub\n then removeSessionStorage \"expression\"\n else setSessionStorage \"expression\" (URI.Encode.encodeText text)\n\n tutorial <- hasParam params \"tutorial\"\n\n saveSearchParams params\n\n if not tutorial && Text.null text\n then showElement \"inline-block\" startTutorial\n else hideElement startTutorial\n\n if | Text.null text -> do\n hideElement output\n replaceChildren output []\n\n | otherwise -> do\n hideElement startTutorial\n\n setBusy\n\n let input_ = Code \"(input)\" text\n\n let initialStatus = Status\n { count = 0\n , context = []\n }\n\n let interpretOutput = do\n expression <- liftIO (Import.resolve Input.AsCode input_)\n\n (inferred, elaboratedExpression) <- Infer.infer expression\n\n value <- Normalize.evaluate [] elaboratedExpression\n\n status@Status{ context } <- State.get\n\n let completedType =\n Context.complete context inferred\n\n let solvedType = Context.solveType context inferred\n\n refreshOutput <- liftIO $ setSuccess completedType value \\htmlWrapper -> do\n let config = Config\n { counter\n , status\n , input = input_\n , edit\n }\n\n Reader.runReaderT (renderValue htmlWrapper solvedType value) config\n\n liftIO refreshOutput\n\n result <- Exception.try (Grace.evalGrace input_ initialStatus interpretOutput)\n\n\n case result of\n Left exception -> do\n setError (Text.pack (displayException (exception :: SomeException)))\n Right () -> do\n return ()\n\n showElement \"block\" output\n\n debouncedInterpret <- debounce interpret\n\n inputCallback <- Callback.asyncCallback (debouncedInterpret ())\n\n onChange codeInput inputCallback\n\n enableTutorialMVar <- MVar.newMVar Nothing\n\n let loadTutorial = do\n stopTutorial <- createElement \"button\"\n addClass stopTutorial \"grace-tutorial-end\"\n\n setAttribute stopTutorial \"type\" \"button\"\n setAttribute stopTutorial \"id\" \"stop-tutorial\"\n\n setTextContent stopTutorial \"Exit the tutorial\"\n\n hideElement stopTutorial\n\n let createExample (name, file) = do\n n <- State.get\n\n State.put (n + 1)\n\n (return . Concurrently) do\n text <- DataFile.readDataFile (\"examples\" \"tutorial\" file)\n\n let code = Text.strip text\n\n let id = \"example-\" <> Text.pack (show n)\n\n tab <- createElement \"button\"\n addClass tab \"example-tab\"\n addClass tab \"grace-tab\"\n\n setAttribute tab \"id\" id\n setAttribute tab \"aria-current\" \"page\"\n setAttribute tab \"type\" \"button\"\n\n setTextContent tab name\n\n let click = do\n setCodeValue codeInput code\n\n elements <- getElementsByClassName \"example-tab\"\n\n Monad.forM_ elements \\element -> do\n removeClass element \"grace-tab-selected\"\n\n element <- getElementById id\n\n addClass element \"grace-tab-selected\"\n\n callback <- Callback.asyncCallback click\n\n addEventListener tab \"click\" callback\n\n return [(tab, click)]\n\n let examples =\n [ (\"Hello, world!\", \"hello.ffg\" )\n , (\"HTML\" , \"html.ffg\" )\n , (\"Data\" , \"data.ffg\" )\n , (\"Prompting\" , \"prompting.ffg\" )\n , (\"Variables\" , \"variables.ffg\" )\n , (\"Functions\" , \"functions.ffg\" )\n , (\"Imports\" , \"imports.ffg\" )\n , (\"Coding\" , \"coding.ffg\" )\n , (\"Conclusion\" , \"conclusion.ffg\")\n ]\n\n results <- Async.runConcurrently (State.evalState (foldMap createExample examples) (0 :: Int))\n\n let (tabs, clickFirstExample : _) = unzip results\n\n navigationBar <- createElement \"div\"\n addClass navigationBar \"grace-tabs\"\n\n replaceChildren navigationBar tabs\n\n hideElement navigationBar\n\n before inputArea navigationBar\n\n stopTutorialCallback <- Callback.asyncCallback do\n deleteParam params \"tutorial\"\n\n saveSearchParams params\n\n hideElement stopTutorial\n hideElement navigationBar\n\n text <- getValue codeInput\n\n if Text.null text\n then do\n showElement \"inline-block\" startTutorial\n else do\n hideElement startTutorial\n\n focus codeInput\n\n addEventListener stopTutorial \"click\" stopTutorialCallback\n\n after startTutorial stopTutorial\n\n return do\n setParam params \"tutorial\" \"true\"\n\n saveSearchParams params\n\n clickFirstExample\n\n hideElement startTutorial\n showElement \"flex\" navigationBar\n showElement \"inline-block\" stopTutorial\n\n focus codeInput\n\n let enableTutorial = do\n enable <- MVar.modifyMVar enableTutorialMVar \\maybeEnable -> do\n enable <- case maybeEnable of\n Nothing -> loadTutorial\n Just enable -> return enable\n\n return (Just enable, enable)\n\n enable\n\n startTutorialCallback <- Callback.asyncCallback enableTutorial\n\n addEventListener startTutorial \"click\" startTutorialCallback\n\n Monad.when hasTutorial enableTutorial\n\n Monad.when hasGitHub do\n githubText <- getParam params \"github\"\n\n hasPrivate <- hasParam params \"private\"\n\n hasReference <- hasParam params \"reference\"\n\n reference <- case hasReference of\n False -> do\n return Syntax.Scalar\n { location = ()\n , scalar = Syntax.Null\n }\n\n True -> do\n ref <- getParam params \"reference\"\n\n return Syntax.Application\n { location = ()\n , function = Syntax.Builtin\n { location = ()\n , builtin = Syntax.Some\n }\n , argument = Syntax.Text\n { location = ()\n , chunks = Syntax.Chunks ref []\n }\n }\n\n\n case Text.splitOn \"/\" githubText of\n owner : repository : path -> do\n if hasPrivate\n then do\n let expression = Syntax.Lambda\n { location = ()\n , binding = RecordBinding\n { fieldNamesLocation = ()\n , fieldNames =\n [ NameBinding\n { nameLocation = ()\n , name = \"GitHub personal access token\"\n , annotation = Just Type.Scalar\n { location = ()\n , scalar = Monotype.Key\n }\n , assignment = Nothing\n }\n ]\n }\n , body = Syntax.GitHub\n { location = ()\n , import_ = True\n , arguments = Syntax.Record\n { location = ()\n , fieldValues =\n [ Syntax.Definition\n { nameLocation = ()\n , name = \"key\"\n , bindings = []\n , annotation = Nothing\n , assignment = Syntax.Application\n { location = ()\n , function = Syntax.Builtin\n { location = ()\n , builtin = Syntax.Some\n }\n , argument = \"GitHub personal access token\"\n }\n }\n , Syntax.Definition\n { nameLocation = ()\n , name = \"owner\"\n , bindings = []\n , annotation = Nothing\n , assignment = Syntax.Text\n { location = ()\n , chunks = Syntax.Chunks owner []\n }\n }\n , Syntax.Definition\n { nameLocation = ()\n , name = \"repository\"\n , bindings = []\n , annotation = Nothing\n , assignment = Syntax.Text\n { location = ()\n , chunks = Syntax.Chunks repository []\n }\n }\n , Syntax.Definition\n { nameLocation = ()\n , name = \"reference\"\n , bindings = []\n , annotation = Nothing\n , assignment = reference\n }\n , Syntax.Definition\n { nameLocation = ()\n , name = \"path\"\n , bindings = []\n , annotation = Nothing\n , assignment = Syntax.Text\n { location = ()\n , chunks = Syntax.Chunks (Text.intercalate \"/\" path) []\n }\n }\n ]\n }\n , schema = Nothing\n }\n }\n\n setCodeValue codeInput (Pretty.toSmart (expression :: Syntax () Void))\n\n else do\n let expression = Syntax.GitHub\n { location = ()\n , import_ = True\n , arguments = Syntax.Record\n { location = ()\n , fieldValues =\n [ Syntax.Definition\n { nameLocation = ()\n , name = \"key\"\n , bindings = []\n , annotation = Nothing\n , assignment = Syntax.Scalar\n { location = ()\n , scalar = Syntax.Null\n }\n }\n , Syntax.Definition\n { nameLocation = ()\n , name = \"owner\"\n , bindings = []\n , annotation = Nothing\n , assignment = Syntax.Text\n { location = ()\n , chunks = Syntax.Chunks owner []\n }\n }\n , Syntax.Definition\n { nameLocation = ()\n , name = \"repository\"\n , bindings = []\n , annotation = Nothing\n , assignment = Syntax.Text\n { location = ()\n , chunks = Syntax.Chunks repository []\n }\n }\n , Syntax.Definition\n { nameLocation = ()\n , name = \"reference\"\n , bindings = []\n , annotation = Nothing\n , assignment = reference\n }\n , Syntax.Definition\n { nameLocation = ()\n , name = \"path\"\n , bindings = []\n , annotation = Nothing\n , assignment = Syntax.Text\n { location = ()\n , chunks = Syntax.Chunks (Text.intercalate \"/\" path) []\n }\n }\n ]\n }\n , schema = Nothing\n }\n\n setCodeValue codeInput (Pretty.toSmart (expression :: Syntax () Void))\n _ -> do\n return ()\n\n case maybeExpression of\n Just expression -> do\n setCodeValue codeInput (URI.Encode.decodeText expression)\n Nothing -> do\n return ()\n\n debouncedInterpret ()\n" }, { "path": "website/css/grace.css", "content": "@font-face {\n font-family: 'Noto Sans';\n font-style: normal;\n font-weight: normal;\n src: url('fonts/noto-sans-v42-latin-regular.woff2') format('woff2');\n font-display: swap;\n}\n\n@font-face {\n font-family: 'Fira Mono';\n font-style: normal;\n font-weight: normal;\n src: url('fonts/firamono-regular-webfont.woff2') format('woff2');\n font-display: swap;\n}\n\n:root {\n --measure: 91ch;\n\n --ratio: 1.5;\n --s-6: calc(var(--s-5) / var(--ratio));\n --s-5: calc(var(--s-4) / var(--ratio));\n --s-4: calc(var(--s-3) / var(--ratio));\n --s-3: calc(var(--s-2) / var(--ratio));\n --s-2: calc(var(--s-1) / var(--ratio));\n --s-1: calc(var(--s0) / var(--ratio));\n --s0: 1rem;\n --s1: calc(var(--s0) * var(--ratio));\n --s2: calc(var(--s1) * var(--ratio));\n --s3: calc(var(--s2) * var(--ratio));\n --s4: calc(var(--s3) * var(--ratio));\n --s5: calc(var(--s4) * var(--ratio));\n\n font-family: 'Noto Sans', sans-serif;\n\n --rosewater: #dc8a78;\n --flamingo: #dd7878;\n --pink: #ea76cb;\n --mauve: #8839ef;\n --red: #d20f39;\n --maroon: #e64553;\n --peach: #fe640b;\n --yellow: #df8e1d;\n --green: #40a02b;\n --teal: #179299;\n --sky: #04a5e5;\n --sapphire: #209fb5;\n --blue: #1e66f5;\n --lavender: #7287fd;\n --text: #4c4f69;\n --subtext1: #5c5f77;\n --subtext0: #6c6f85;\n --overlay2: #7c7f93;\n --overlay1: #8c8fa1;\n --overlay0: #9ca0b0;\n --surface2: #acb0be;\n --surface1: #bcc0cc;\n --surface0: #ccd0da;\n --base: #eff1f5;\n --mantle: #e6e9ef;\n --crust: #dce0e8;\n}\n\n@media (prefers-color-scheme: dark) {\n :root {\n --rosewater: #f2d5cf;\n --flamingo: #eebebe;\n --pink: #f4b8e4;\n --mauve: #ca9ee6;\n --red: #e78284;\n --maroon: #ea999c;\n --peach: #ef9f76;\n --yellow: #e5c890;\n --green: #a6d189;\n --teal: #81c8be;\n --sky: #99d1db;\n --sapphire: #85c1dc;\n --blue: #8caaee;\n --lavender: #babbf1;\n --text: #c6d0f5;\n --subtext1: #b5bfe2;\n --subtext0: #a5adce;\n --overlay2: #949cbb;\n --overlay1: #838ba7;\n --overlay0: #737994;\n --surface2: #626880;\n --surface1: #51576d;\n --surface0: #414559;\n --base: #303446;\n --mantle: #292c3c;\n --crust: #232634;\n }\n/*\n :root {\n --rosewater: #f5e0dc;\n --flamingo: #f2cdcd;\n --pink: #f5c2e7;\n --mauve: #cba6f7;\n --red: #f38ba8;\n --maroon: #eba0ac;\n --peach: #fab387;\n --yellow: #f9e2af;\n --green: #a6e3a1;\n --teal: #94e2d5;\n --sky: #89dceb;\n --sapphire: #74c7ec;\n --blue: #89b4fa;\n --lavender: #b4befe;\n --text: #cdd6f4;\n --subtext1: #bac2de;\n --subtext0: #a6adc8;\n --overlay2: #9399b2;\n --overlay1: #7f849c;\n --overlay0: #6c7086;\n --surface2: #585b70;\n --surface1: #45475a;\n --surface0: #313244;\n --base: #1e1e2e;\n --mantle: #181825;\n --crust: #11111b;\n }\n*/\n}\n\n::selection {\n background-color: color-mix(in oklch, var(--overlay2) 30%, transparent);\n}\n\n* {\n box-sizing: border-box;\n max-inline-size: var(--measure);\n}\n\nhtml,\nbody,\ndiv,\nheader,\nnav,\nmain,\nfooter {\n max-inline-size: none;\n}\n\nbody {\n background-color: var(--base);\n color: var(--text);\n}\n\na {\n color: var(--blue);\n text-decoration: none;\n}\n\nbutton {\n background-color: var(--blue);\n color: var(--base);\n border: 0;\n border-radius: var(--s-2);\n padding-block: var(--s-2);\n padding-inline: var(--s-1);\n font-size: var(--s0);\n font-weight: 600;\n}\n\nbutton:hover {\n background-color: var(--sky);\n cursor: pointer;\n}\n\nbutton:active {\n background-color: var(--lavender);\n}\n\nfieldset {\n border: 0;\n padding: 0;\n}\n\nfieldset:disabled {\n}\n\ntextarea {\n resize: none;\n}\n\nli > textarea {\n vertical-align: baseline;\n}\n\nli > span {\n vertical-align: middle;\n}\n\n.grace-pane {\n background-color: var(--mantle);\n border-radius: var(--s-2);\n padding: var(--s0);\n}\n\n.grace-pane .grace-pane {\n padding: 0;\n}\n\n.grace-success .grace-success .grace-form {\n margin-block-start: var(--s0);\n}\n\n.grace-input-json,\n.grace-input-text,\n.grace-output-json,\n.grace-output-text {\n color: var(--text);\n padding-inline: var(--s-1);\n padding-block: var(--s-2);\n border-style: none;\n border-radius: var(--s-2);\n font-size: var(--s0);\n}\n\n.grace-input-json,\n.grace-input-text,\n.grace-output-json,\n.grace-output-text {\n background-color: var(--crust);\n}\n\n.grace-output-json,\n.grace-output-text {\n overflow-x: auto;\n}\n\n.grace-output-json {\n display: inline-block;\n}\n\n.grace-input-json,\n.grace-output-json {\n font-family: 'Fira Mono', monospace;\n}\n\n.grace-input-text,\n.grace-output-text {\n font-family: 'Noto Sans', sans-serif;\n}\n\n.grace-output-text > :first-child {\n margin-block-start: 0;\n}\n\n.grace-output-text > :last-child {\n margin-block-end: 0;\n}\n\n.grace-input-list-plus,\n.grace-input-list-minus {\n height: var(--s2);\n width: var(--s2);\n}\n\n.grace-input-optional,\n.grace-input-alternative-selection {\n display: flex;\n flex-wrap: wrap;\n gap: var(--s-2);\n}\n\n.grace-input-optional > :first-child,\n.grace-input-alternative-selection > :first-child {\n flex-grow: 1;\n}\n\n.grace-input-optional > :last-child,\n.grace-input-alternative-selection > :last-child {\n flex-basis: 0;\n flex-grow: 999;\n min-inline-size: 50%;\n}\n\n.grace-input-bool-box, .grace-input-alternative-radio-box {\n padding: var(--s-2);\n}\n\n.grace-horizontal-rule {\n background-color: var(--surface0);\n border: none;\n height: var(--s-6);\n}\n\n.grace-input-alternative {\n padding-block: var(--s-2);\n}\n\n:focus {\n outline: none;\n}\n\ninput[type=\"number\"]:focus,\ninput[type=\"password\"]:focus,\ninput[type=\"text\"]:focus,\ntextarea:focus {\n box-shadow: 0 0 0 var(--s-6) var(--lavender);\n}\n\ncode {\n font-family: 'Fira Mono', monospace;\n white-space: pre;\n}\n\npre {\n font-family: 'Fira Mono', monospace;\n line-height: 1.29;\n}\n\n.grace-input-field-name,\n.grace-input-alternative-label,\n.grace-output-field-name {\n font-weight: bold;\n color: var(--mauve);\n}\n\nul, dt, pre, fieldset {\n margin: 0;\n}\n\ndl {\n margin-block: 0;\n}\n\ndd {\n margin-inline-start: var(--s1);\n margin-block-start: var(--s-3);\n}\n\nul {\n padding-inline-start: var(--s1);\n}\n\n.grace-center {\n box-sizing: content-box;\n margin-inline: auto;\n max-inline-size: var(--measure);\n}\n\n.grace-stack {\n display: flex;\n flex-direction: column;\n justify-content: flex-start;\n}\n\n.grace-stack-large > header > *,\n.grace-stack > header > * {\n margin-block: 0;\n}\n\n.grace-stack-large > main > *,\n.grace-stack > main > * {\n margin-block: 0;\n}\n\n.grace-stack-large > *,\n.grace-stack > * {\n margin-block: 0;\n} \n\n.grace-stack > * + * {\n margin-block-start: var(--margin, var(--s-2));\n}\n\n.grace-stack-large > * + * {\n margin-block-start: var(--margin, var(--s1));\n}\n\n.grace-stack-large > * + .grace-ignore,\n.grace-stack > * + .grace-ignore {\n margin-block-start: 0;\n}\n\n.grace-cluster-start {\n display: flex;\n flex-wrap: wrap;\n gap: var(--space, 1rem);\n justify-content: flex-start;\n align-items: center;\n}\n\n.grace-printable-buttons {\n display: flex;\n flex-wrap: wrap;\n gap: var(--s0);\n justify-content: flex-start;\n align-items: flex-start;\n}\n\n.grace-printable {\n display: flex;\n flex-wrap: wrap;\n gap: var(--s0);\n}\n\n.grace-printable > :last-child {\n flex-grow: 0;\n flex-basis: var(--s5);\n}\n\n.grace-printable > :first-child {\n flex-basis: 0;\n flex-grow: 1;\n min-inline-size: 50%;\n}\n\n.grace-print, .grace-copy {\n border-radius: var(--s-3);\n padding-block: var(--s-3);\n padding-inline: var(--s-2);\n font-size: var(--s-1);\n}\n\n.grace-tabs {\n display: flex;\n block-size: auto;\n overflow-x: auto;\n overflow-y: hidden;\n}\n\n.grace-tabs > * {\n flex: 0 0 auto;\n margin-block-end: var(--s-3);\n}\n\n.grace-tabs > * + * {\n margin-inline-start: var(--s-2);\n}\n\n.grace-tabs.overflowing {\n padding-block-end: var(--s-6);\n}\n\n.grace-tabs:has(+ * + .CodeMirror) {\n padding-inline-start: 29px; /* … to match CodeMirror's gutter */\n}\n\n.grace-tab {\n border-radius: var(--s-2) var(--s-2) 0 0;\n padding-inline: var(--s-2);\n padding-block: var(--s-2);\n background-color: transparent;\n color: var(--blue);\n border-style: solid;\n border-width: 0 0 var(--s-4) 0;\n border-color: transparent;\n}\n\n.grace-tab:hover {\n color: var(--sky);\n border-color: transparent transparent var(--sky) transparent;\n background-color: transparent;\n}\n\n.grace-tab-selected {\n color: var(--lavender);\n border-color: transparent transparent var(--lavender) transparent;\n}\n\n.grace-spinner {\n margin: var(--s1);\n width: var(--s3);\n height: var(--s3);\n border-radius: 50%;\n display: inline-block;\n border-top: var(--s-3) solid var(--rosewater);\n border-right: var(--s-3) solid transparent;\n animation: rotation 1s linear infinite;\n}\n\n.grace-spinner::after {\n content: '';\n box-sizing: border-box;\n position: absolute;\n left: 0;\n top: 0;\n width: var(--s3);\n height: var(--s3);\n border-radius: 50%;\n border-left: var(--s-3) solid var(--peach);\n border-bottom: var(--s-3) solid transparent;\n animation: rotation 0.5s linear infinite reverse;\n}\n\n@keyframes rotation {\n 0% {\n transform: rotate(0deg);\n }\n 100% {\n transform: rotate(360deg);\n }\n}\n\n.CodeMirror {\n font-family: 'Fira Mono', monospace;\n height: auto;\n margin-block-start: 0;\n background-color: var(--mantle);\n border-radius: var(--s-2);\n color: var(--text);\n}\n\n.CodeMirror-gutters {\n background: var(--crust);\n border-style: none;\n}\n\n.CodeMirror-linenumber {\n color: var(--subtext0);\n}\n\n.CodeMirror-cursor {\n border-inline-start-style: solid;\n border-inline-start-color: var(--rosewater);\n border-inline-start-width: var(--s-5);\n}\n\n.cm-s-default .cm-keyword { color: inherit; }\n.cm-s-default .cm-atom { color: var(--red); }\n.cm-s-default .cm-number { color: var(--peach); }\n.cm-s-default .cm-def { color: inherit; }\n.cm-s-default .cm-variable, .cm-variable-2, .cm-variable3 { color: inherit; }\n.cm-s-default .cm-punctuation { color: var(--subtext1); }\n.cm-s-default .cm-property { color: inherit; }\n.cm-s-default .cm-operator { color: inherit; }\n.cm-s-default .cm-type { color: inherit; }\n.cm-s-default .cm-comment { color: var(--overlay2); }\n.cm-s-default .cm-string, .cm-string-2 { color: var(--green); }\n.cm-s-default .cm-meta { color: inherit; }\n.cm-s-default .cm-qualifier { color: inherit; }\n.cm-s-default .cm-builtin { color: inherit; }\n.cm-s-default .cm-bracket { color: var(--subtext1); }\n.cm-s-default .cm-tag { color: inherit; }\n.cm-s-default .cm-attribute { color: inherit; }\n.cm-s-default .cm-hr { color: inherit; }\n.cm-s-default .cm-link { color: inherit; }\n.cm-s-default .cm-error { color: var(--red); }\n.cm-s-default .cm-invalidchar { color: var(--red); }\n\n.CodeMirror-line::selection,\n.CodeMirror-line > span::selection,\n.CodeMirror-line > span > span::selection {\n background-color: color-mix(in oklch, var(--overlay2) 30%, transparent) !important;\n}\n\n.CodeMirror-selected {\n background-color: color-mix(in oklch, var(--overlay2) 30%, transparent) !important;\n}\n\n.CodeMirror pre.CodeMirror-line,\n.CodeMirror pre.CodeMirror-line-like {\n padding-inline: var(--s-2);\n}\n\n.CodeMirror pre.CodeMirror-placeholder {\n color: var(--overlay1);\n}\n" }, { "path": "website/index.html", "content": "\n\n\nGrace browser\n\n\n\n\n\n\n\n\n\n\n\n
\n
\n
\n

Grace browser

\n
\n
\n
\n
\n \n
\n \n
\n
\n
\n
\n
\n
\n
\n
\n\n\n\n\n\n\n\n\n" } ]