Repository: Gabriel439/grace Branch: main Commit: 9230b0a0fc60 Files: 847 Total size: 897.1 KB Directory structure: gitextract_9bjoz56v/ ├── .envrc ├── .gitattributes ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── Setup.hs ├── dependencies/ │ ├── .gitkeep │ ├── grace-ghcjs.nix │ ├── grace.nix │ └── openai.nix ├── doctest/ │ └── Main.hs ├── examples/ │ ├── bluesky/ │ │ └── 2025-11-27.ffg │ ├── chaining.ffg │ ├── code.ffg │ ├── emotion-wheel.ffg │ ├── eval.ffg │ ├── history.ffg │ ├── learn-in-y-minutes.ffg │ ├── mustache.ffg │ ├── poem.ffg │ ├── prompt.ffg │ ├── taxes.ffg │ ├── tools.ffg │ ├── transform-text.ffg │ ├── tutorial/ │ │ ├── coding.ffg │ │ ├── conclusion.ffg │ │ ├── data.ffg │ │ ├── functions.ffg │ │ ├── hello.ffg │ │ ├── html.ffg │ │ ├── imports.ffg │ │ ├── prompting.ffg │ │ └── variables.ffg │ └── users.ffg ├── flake.nix ├── garnix.yaml ├── ghc/ │ └── Grace/ │ ├── DataFile.hs │ ├── HTTP.hs │ └── Width.hs ├── ghcjs/ │ └── Grace/ │ ├── DataFile.hs │ ├── HTTP.hs │ ├── Size.hs │ └── Width.hs ├── grace/ │ └── Main.hs ├── grace.cabal ├── prelude/ │ ├── bool/ │ │ ├── and.ffg │ │ ├── not.ffg │ │ ├── or.ffg │ │ └── package.ffg │ ├── integer/ │ │ ├── clamp.ffg │ │ ├── package.ffg │ │ ├── product.ffg │ │ ├── sum.ffg │ │ └── toNatural.ffg │ ├── list/ │ │ ├── all.ffg │ │ ├── any.ffg │ │ ├── concat.ffg │ │ ├── generate.ffg │ │ ├── null.ffg │ │ ├── package.ffg │ │ ├── reject.ffg │ │ ├── replicate.ffg │ │ └── select.ffg │ ├── natural/ │ │ ├── package.ffg │ │ ├── product.ffg │ │ └── sum.ffg │ ├── package.ffg │ ├── real/ │ │ ├── package.ffg │ │ ├── product.ffg │ │ └── sum.ffg │ └── text/ │ ├── concat.ffg │ ├── concatMap.ffg │ ├── concatMapSep.ffg │ ├── concatSep.ffg │ └── package.ffg ├── prompts/ │ ├── abnf.md │ └── inference.md ├── src/ │ ├── Grace/ │ │ ├── Aeson.hs │ │ ├── Compat.hs │ │ ├── Context.hs │ │ ├── Decode.hs │ │ ├── Domain.hs │ │ ├── Encode.hs │ │ ├── Existential.hs │ │ ├── GitHub.hs │ │ ├── HTTP/ │ │ │ └── Type.hs │ │ ├── Import.hs │ │ ├── Infer.hs │ │ ├── Input.hs │ │ ├── Interpret.hs │ │ ├── Interpret.hs-boot │ │ ├── Label.hs │ │ ├── Location.hs │ │ ├── Marshal.hs │ │ ├── Monad.hs │ │ ├── Monotype.hs │ │ ├── Normalize.hs │ │ ├── Parallelizable.hs │ │ ├── Parser.hs │ │ ├── Pretty.hs │ │ ├── Prompt/ │ │ │ └── Types.hs │ │ ├── Prompt.hs │ │ ├── REPL.hs │ │ ├── Syntax.hs │ │ ├── TH.hs │ │ ├── Type.hs │ │ └── Value.hs │ └── Grace.hs ├── tasty/ │ ├── Main.hs │ └── data/ │ ├── complex/ │ │ ├── abstract-fold-input.ffg │ │ ├── abstract-fold-output.ffg │ │ ├── abstract-fold-type.ffg │ │ ├── alternative-input.ffg │ │ ├── alternative-output.ffg │ │ ├── alternative-type.ffg │ │ ├── arithmetic-input.ffg │ │ ├── arithmetic-output.ffg │ │ ├── arithmetic-type.ffg │ │ ├── chain-identity-input.ffg │ │ ├── chain-identity-output.ffg │ │ ├── chain-identity-type.ffg │ │ ├── check-function-input.ffg │ │ ├── check-function-output.ffg │ │ ├── check-function-type.ffg │ │ ├── church-encode-list-input.ffg │ │ ├── church-encode-list-output.ffg │ │ ├── church-encode-list-type.ffg │ │ ├── default-arguments-input.ffg │ │ ├── default-arguments-output.ffg │ │ ├── default-arguments-type.ffg │ │ ├── destructure-lambda-input.ffg │ │ ├── destructure-lambda-output.ffg │ │ ├── destructure-lambda-type.ffg │ │ ├── destructure-let-argument-input.ffg │ │ ├── destructure-let-argument-output.ffg │ │ ├── destructure-let-argument-type.ffg │ │ ├── destructure-record-input.ffg │ │ ├── destructure-record-output.ffg │ │ ├── destructure-record-type.ffg │ │ ├── elaborate-inside-optional-input.ffg │ │ ├── elaborate-inside-optional-output.ffg │ │ ├── elaborate-inside-optional-type.ffg │ │ ├── equality-input.ffg │ │ ├── equality-output.ffg │ │ ├── equality-type.ffg │ │ ├── even-input.ffg │ │ ├── even-output.ffg │ │ ├── even-type.ffg │ │ ├── examples-input.ffg │ │ ├── examples-output.ffg │ │ ├── examples-type.ffg │ │ ├── exclaim-input.ffg │ │ ├── exclaim-output.ffg │ │ ├── exclaim-type.ffg │ │ ├── exhaust-type-variable-alphabet-input.ffg │ │ ├── exhaust-type-variable-alphabet-output.ffg │ │ ├── exhaust-type-variable-alphabet-type.ffg │ │ ├── existential-records-input.ffg │ │ ├── existential-records-output.ffg │ │ ├── existential-records-type.ffg │ │ ├── export-show-input.ffg │ │ ├── export-show-output.ffg │ │ ├── export-show-type.ffg │ │ ├── extra-fields-input.ffg │ │ ├── extra-fields-output.ffg │ │ ├── extra-fields-type.ffg │ │ ├── fold-bool-input.ffg │ │ ├── fold-bool-output.ffg │ │ ├── fold-bool-type.ffg │ │ ├── fold-json-input.ffg │ │ ├── fold-json-output.ffg │ │ ├── fold-json-type.ffg │ │ ├── fold-list-input.ffg │ │ ├── fold-list-output.ffg │ │ ├── fold-list-type.ffg │ │ ├── fold-missing-field-input.ffg │ │ ├── fold-missing-field-output.ffg │ │ ├── fold-missing-field-type.ffg │ │ ├── fold-natural-input.ffg │ │ ├── fold-natural-output.ffg │ │ ├── fold-natural-type.ffg │ │ ├── fold-optional-input.ffg │ │ ├── fold-optional-output.ffg │ │ ├── fold-optional-type.ffg │ │ ├── for-annotation-input.ffg │ │ ├── for-annotation-output.ffg │ │ ├── for-annotation-type.ffg │ │ ├── for-check-list-input.ffg │ │ ├── for-check-list-output.ffg │ │ ├── for-check-list-type.ffg │ │ ├── for-lambda-input.ffg │ │ ├── for-lambda-output.ffg │ │ ├── for-lambda-type.ffg │ │ ├── for-list-input.ffg │ │ ├── for-list-output.ffg │ │ ├── for-list-type.ffg │ │ ├── for-naked-output.ffg │ │ ├── for-naked-type.ffg │ │ ├── for-optional-input.ffg │ │ ├── for-optional-output.ffg │ │ ├── for-optional-type.ffg │ │ ├── forall-annotation-input.ffg │ │ ├── forall-annotation-output.ffg │ │ ├── forall-annotation-type.ffg │ │ ├── higher-rank-annotation-input.ffg │ │ ├── higher-rank-annotation-output.ffg │ │ ├── higher-rank-annotation-type.ffg │ │ ├── higher-rank-input.ffg │ │ ├── higher-rank-output.ffg │ │ ├── higher-rank-subtype-input.ffg │ │ ├── higher-rank-subtype-output.ffg │ │ ├── higher-rank-subtype-type.ffg │ │ ├── higher-rank-type.ffg │ │ ├── if-then-else-input.ffg │ │ ├── if-then-else-output.ffg │ │ ├── if-then-else-type.ffg │ │ ├── import-github-input.ffg │ │ ├── import-github-output.ffg │ │ ├── import-github-type.ffg │ │ ├── impredicative-const-input.ffg │ │ ├── impredicative-const-output.ffg │ │ ├── impredicative-const-type.ffg │ │ ├── index-input.ffg │ │ ├── index-output.ffg │ │ ├── index-type.ffg │ │ ├── inequality-input.ffg │ │ ├── inequality-output.ffg │ │ ├── inequality-type.ffg │ │ ├── infer-higher-order-input.ffg │ │ ├── infer-higher-order-output.ffg │ │ ├── infer-higher-order-type.ffg │ │ ├── infer-reverse-input.ffg │ │ ├── infer-reverse-output.ffg │ │ ├── infer-reverse-type.ffg │ │ ├── inner-forall-input.ffg │ │ ├── inner-forall-output.ffg │ │ ├── inner-forall-type.ffg │ │ ├── instantiate-nested-type-input.ffg │ │ ├── instantiate-nested-type-output.ffg │ │ ├── instantiate-nested-type-type.ffg │ │ ├── instantiate-variable-input.ffg │ │ ├── instantiate-variable-output.ffg │ │ ├── instantiate-variable-type.ffg │ │ ├── interpolate-default-input.ffg │ │ ├── interpolate-default-output.ffg │ │ ├── interpolate-default-type.ffg │ │ ├── interpolation-input.ffg │ │ ├── interpolation-output.ffg │ │ ├── interpolation-type.ffg │ │ ├── json-fold-input.ffg │ │ ├── json-fold-output.ffg │ │ ├── json-fold-type.ffg │ │ ├── keyword-prefix-input.ffg │ │ ├── keyword-prefix-output.ffg │ │ ├── keyword-prefix-type.ffg │ │ ├── lambda-annotation-input.ffg │ │ ├── lambda-annotation-output.ffg │ │ ├── lambda-annotation-type.ffg │ │ ├── let-functions-input.ffg │ │ ├── let-functions-output.ffg │ │ ├── let-functions-type.ffg │ │ ├── list-append-subtype-input.ffg │ │ ├── list-append-subtype-output.ffg │ │ ├── list-append-subtype-type.ffg │ │ ├── list-of-alternatives-input.ffg │ │ ├── list-of-alternatives-output.ffg │ │ ├── list-of-alternatives-type.ffg │ │ ├── list-unequal-length-input.ffg │ │ ├── list-unequal-length-output.ffg │ │ ├── list-unequal-length-type.ffg │ │ ├── merge-multiple-input.ffg │ │ ├── merge-multiple-output.ffg │ │ ├── merge-multiple-type.ffg │ │ ├── merge-optional-input.ffg │ │ ├── merge-optional-output.ffg │ │ ├── merge-optional-type.ffg │ │ ├── minus-natural-input.ffg │ │ ├── minus-natural-output.ffg │ │ ├── minus-natural-type.ffg │ │ ├── modulus-input.ffg │ │ ├── modulus-output.ffg │ │ ├── modulus-type.ffg │ │ ├── nested-arithmetic-input.ffg │ │ ├── nested-arithmetic-output.ffg │ │ ├── nested-arithmetic-type.ffg │ │ ├── nested-constructor-input.ffg │ │ ├── nested-constructor-output.ffg │ │ ├── nested-constructor-type.ffg │ │ ├── nested-fields-input.ffg │ │ ├── nested-fields-output.ffg │ │ ├── nested-fields-type.ffg │ │ ├── nested-let-input.ffg │ │ ├── nested-let-output.ffg │ │ ├── nested-let-type.ffg │ │ ├── numeric-subtyping-input.ffg │ │ ├── numeric-subtyping-output.ffg │ │ ├── numeric-subtyping-type.ffg │ │ ├── optional-fields-input.ffg │ │ ├── optional-fields-output.ffg │ │ ├── optional-fields-type.ffg │ │ ├── package-input.ffg │ │ ├── package-output.ffg │ │ ├── package-type.ffg │ │ ├── pattern-input.ffg │ │ ├── pattern-output.ffg │ │ ├── pattern-type.ffg │ │ ├── polymorphic-instantiation-input.ffg │ │ ├── polymorphic-instantiation-output.ffg │ │ ├── polymorphic-instantiation-type.ffg │ │ ├── polymorphic-let-input.ffg │ │ ├── polymorphic-let-output.ffg │ │ ├── polymorphic-let-type.ffg │ │ ├── polymorphic-subsumption-input.ffg │ │ ├── polymorphic-subsumption-output.ffg │ │ ├── polymorphic-subsumption-type.ffg │ │ ├── potpourri-input.ffg │ │ ├── potpourri-output.ffg │ │ ├── potpourri-type.ffg │ │ ├── predicative-null-input.ffg │ │ ├── predicative-null-output.ffg │ │ ├── predicative-null-type.ffg │ │ ├── prelude-input.ffg │ │ ├── prelude-output.ffg │ │ ├── prelude-type.ffg │ │ ├── preserve-row-input.ffg │ │ ├── preserve-row-output.ffg │ │ ├── preserve-row-type.ffg │ │ ├── principle-of-explosion-input.ffg │ │ ├── principle-of-explosion-output.ffg │ │ ├── principle-of-explosion-type.ffg │ │ ├── quantifiers-input.ffg │ │ ├── quantifiers-output.ffg │ │ ├── quantifiers-type.ffg │ │ ├── quoted-label-input.ffg │ │ ├── quoted-label-output.ffg │ │ ├── quoted-label-type.ffg │ │ ├── read-input.ffg │ │ ├── read-output.ffg │ │ ├── read-type.ffg │ │ ├── record-mismatch-both-extra-input.ffg │ │ ├── record-mismatch-both-extra-output.ffg │ │ ├── record-mismatch-both-extra-type.ffg │ │ ├── record-mismatch-left-extra-input.ffg │ │ ├── record-mismatch-left-extra-output.ffg │ │ ├── record-mismatch-left-extra-type.ffg │ │ ├── record-mismatch-right-extra-input.ffg │ │ ├── record-mismatch-right-extra-output.ffg │ │ ├── record-mismatch-right-extra-type.ffg │ │ ├── record-mismatch-two-extra-input.ffg │ │ ├── record-mismatch-two-extra-output.ffg │ │ ├── record-mismatch-two-extra-type.ffg │ │ ├── remote-transitive-import-input.ffg │ │ ├── remote-transitive-import-output.ffg │ │ ├── remote-transitive-import-type.ffg │ │ ├── restrict-project-input.ffg │ │ ├── restrict-project-output.ffg │ │ ├── restrict-project-type.ffg │ │ ├── separators-input.ffg │ │ ├── separators-output.ffg │ │ ├── separators-type.ffg │ │ ├── show-input.ffg │ │ ├── show-output.ffg │ │ ├── show-type.ffg │ │ ├── skolem-function-type-input.ffg │ │ ├── skolem-function-type-stderr.txt │ │ ├── slice-input.ffg │ │ ├── slice-output.ffg │ │ ├── slice-type.ffg │ │ ├── solve-fields-input.ffg │ │ ├── solve-fields-output.ffg │ │ ├── solve-fields-type.ffg │ │ ├── solve-unused-impredicative-polymorphism-input.ffg │ │ ├── solve-unused-impredicative-polymorphism-output.ffg │ │ ├── solve-unused-impredicative-polymorphism-type.ffg │ │ ├── subtype-function-input.ffg │ │ ├── subtype-function-output.ffg │ │ ├── subtype-function-type.ffg │ │ ├── triple-field-input.ffg │ │ ├── triple-field-output.ffg │ │ ├── triple-field-type.ffg │ │ ├── triple-supertype-input.ffg │ │ ├── triple-supertype-output.ffg │ │ ├── triple-supertype-type.ffg │ │ ├── unbound-alternatives-variable-input.ffg │ │ ├── unbound-alternatives-variable-stderr.txt │ │ ├── unbound-fields-variable-input.ffg │ │ ├── unbound-fields-variable-stderr.txt │ │ ├── undo-elaboration-input.ffg │ │ ├── undo-elaboration-output.ffg │ │ ├── undo-elaboration-type.ffg │ │ ├── unify-json-input.ffg │ │ ├── unify-json-output.ffg │ │ ├── unify-json-type.ffg │ │ ├── unify-null-input.ffg │ │ ├── unify-null-output.ffg │ │ ├── unify-null-type.ffg │ │ ├── unify-unsolved-input.ffg │ │ ├── unify-unsolved-output.ffg │ │ ├── unify-unsolved-type.ffg │ │ ├── unused-impredicative-polymorphism-input.ffg │ │ ├── unused-impredicative-polymorphism-output.ffg │ │ ├── unused-impredicative-polymorphism-type.ffg │ │ ├── unused-polymorphism-input.ffg │ │ ├── unused-polymorphism-output.ffg │ │ ├── unused-polymorphism-type.ffg │ │ ├── use-equation-input.ffg │ │ ├── use-equation-output.ffg │ │ ├── use-equation-type.ffg │ │ ├── well-formed-input.ffg │ │ ├── well-formed-output.ffg │ │ ├── well-formed-type.ffg │ │ ├── yaml-input.ffg │ │ ├── yaml-output.ffg │ │ └── yaml-type.ffg │ ├── error/ │ │ ├── for-naked-input.ffg │ │ ├── for-naked-stderr.txt │ │ ├── parse/ │ │ │ ├── eof-input.ffg │ │ │ ├── eof-stderr.txt │ │ │ ├── incomplete-escape-input.ffg │ │ │ ├── incomplete-escape-stderr.txt │ │ │ ├── incomplete-interpolation-input.ffg │ │ │ ├── incomplete-interpolation-stderr.txt │ │ │ ├── incomplete-string-input.ffg │ │ │ ├── incomplete-string-stderr.txt │ │ │ ├── invalid-multiline-input.ffg │ │ │ ├── invalid-multiline-stderr.txt │ │ │ ├── unbalanced-bracket-input.ffg │ │ │ ├── unbalanced-bracket-stderr.txt │ │ │ ├── unrecognized-symbol-input.ffg │ │ │ └── unrecognized-symbol-stderr.txt │ │ ├── resolve/ │ │ │ ├── empty-environment-variable-input.ffg │ │ │ ├── empty-environment-variable-stderr.txt │ │ │ ├── environment-authority-input.ffg │ │ │ ├── environment-authority-stderr.txt │ │ │ ├── environment-leading-slash-input.ffg │ │ │ ├── environment-leading-slash-stderr.txt │ │ │ ├── environment-missing-input.ffg │ │ │ ├── environment-missing-stderr.txt │ │ │ ├── environment-variable-slash-input.ffg │ │ │ ├── environment-variable-slash-stderr.txt │ │ │ ├── file-authority-input.ffg │ │ │ ├── file-authority-stderr.txt │ │ │ ├── file-missing-path-input.ffg │ │ │ ├── file-missing-path-stderr.txt │ │ │ ├── host-not-found-input.ffg │ │ │ ├── host-not-found-stderr.txt │ │ │ ├── invalid-destination-host-input.ffg │ │ │ ├── invalid-destination-host-stderr.txt │ │ │ ├── invalid-utf8-input.ffg │ │ │ ├── invalid-utf8-stderr.txt │ │ │ ├── read-invalid-json-input.ffg │ │ │ ├── read-invalid-json-stderr.txt │ │ │ ├── remote-invalid-parse-input.ffg │ │ │ ├── remote-invalid-parse-stderr.txt │ │ │ ├── remote-referentially-insane-input.ffg │ │ │ └── remote-referentially-insane-stderr.txt │ │ └── type/ │ │ ├── alternatives-variable-input.ffg │ │ ├── alternatives-variable-stderr.txt │ │ ├── bad-type-annotation-input.ffg │ │ ├── bad-type-annotation-stderr.txt │ │ ├── destructure-missing-required-input.ffg │ │ ├── destructure-missing-required-stderr.txt │ │ ├── dynamic-scope-input.ffg │ │ ├── dynamic-scope-stderr.txt │ │ ├── fields-variable-mismatch-input.ffg │ │ ├── fields-variable-mismatch-stderr.txt │ │ ├── fold-missing-field-input.ffg │ │ ├── fold-missing-field-stderr.txt │ │ ├── fold-typo-field-input.ffg │ │ ├── fold-typo-field-stderr.txt │ │ ├── for-annotation-input.ffg │ │ ├── for-annotation-stderr.txt │ │ ├── for-mixed-input.ffg │ │ ├── for-mixed-stderr.txt │ │ ├── impredicative-instantiation-input.ffg │ │ ├── impredicative-instantiation-stderr.txt │ │ ├── impredicative-polymorphism-input.ffg │ │ ├── impredicative-polymorphism-output.ffg │ │ ├── impredicative-polymorphism-type.ffg │ │ ├── index-slice-input.ffg │ │ ├── index-slice-stderr.txt │ │ ├── invalid-argument-input.ffg │ │ ├── invalid-argument-stderr.txt │ │ ├── invalid-handler-input.ffg │ │ ├── invalid-handler-stderr.txt │ │ ├── invalid-plus-annotation-input.ffg │ │ ├── invalid-plus-annotation-stderr.txt │ │ ├── invalid-plus-operands-input.ffg │ │ ├── invalid-plus-operands-stderr.txt │ │ ├── invalid-times-annotation-input.ffg │ │ ├── invalid-times-annotation-stderr.txt │ │ ├── invalid-times-operands-input.ffg │ │ ├── invalid-times-operands-stderr.txt │ │ ├── merge-wrong-type-input.ffg │ │ ├── merge-wrong-type-stderr.txt │ │ ├── missing-required-field-input.ffg │ │ ├── missing-required-field-stderr.txt │ │ ├── modulus-abstract-input.ffg │ │ ├── modulus-abstract-stderr.txt │ │ ├── modulus-zero-input.ffg │ │ ├── modulus-zero-stderr.txt │ │ ├── non-singular-pattern-input.ffg │ │ ├── non-singular-pattern-stderr.txt │ │ ├── not-a-function-input.ffg │ │ ├── not-a-function-stderr.txt │ │ ├── occurs-alternatives-input.ffg │ │ ├── occurs-alternatives-stderr.txt │ │ ├── occurs-type-backwards-input.ffg │ │ ├── occurs-type-backwards-stderr.txt │ │ ├── occurs-type-input.ffg │ │ ├── occurs-type-stderr.txt │ │ ├── pattern-input.ffg │ │ ├── pattern-stderr.txt │ │ ├── pin-fields-variable-input.ffg │ │ ├── pin-fields-variable-stderr.txt │ │ ├── read-fail-input.ffg │ │ ├── read-fail-stderr.txt │ │ ├── read-input.ffg │ │ ├── read-stderr.txt │ │ ├── show-key-input.ffg │ │ ├── show-key-stderr.txt │ │ ├── subtype-function-input.ffg │ │ ├── subtype-function-stderr.txt │ │ ├── type-mismatch-input.ffg │ │ ├── type-mismatch-stderr.txt │ │ ├── unbound-input.ffg │ │ ├── unbound-stderr.txt │ │ ├── unbound-type-input.ffg │ │ ├── unbound-type-stderr.txt │ │ ├── union-mismatch-both-extra-input.ffg │ │ ├── union-mismatch-both-extra-stderr.txt │ │ ├── union-mismatch-left-extra-input.ffg │ │ ├── union-mismatch-left-extra-stderr.txt │ │ ├── union-mismatch-right-extra-input.ffg │ │ ├── union-mismatch-right-extra-output.ffg │ │ ├── union-mismatch-right-extra-type.ffg │ │ ├── union-variable-mismatch-input.ffg │ │ ├── union-variable-mismatch-stderr.txt │ │ ├── variable-mismatch-input.ffg │ │ └── variable-mismatch-stderr.txt │ ├── json/ │ │ ├── colors-input.ffg │ │ ├── colors-output.ffg │ │ ├── colors-type.ffg │ │ ├── colors.json │ │ ├── geoip-input.ffg │ │ ├── geoip-output.ffg │ │ ├── geoip-type.ffg │ │ ├── geoip.json │ │ ├── glossary-input.ffg │ │ ├── glossary-output.ffg │ │ ├── glossary-type.ffg │ │ ├── glossary.json │ │ ├── markers-input.ffg │ │ ├── markers-output.ffg │ │ ├── markers-type.ffg │ │ ├── markers.json │ │ ├── menu-input.ffg │ │ ├── menu-output.ffg │ │ ├── menu-type.ffg │ │ ├── menu.json │ │ ├── menu2-input.ffg │ │ ├── menu2-output.ffg │ │ ├── menu2-type.ffg │ │ ├── menu2.json │ │ ├── numbers-input.ffg │ │ ├── numbers-output.ffg │ │ ├── numbers-type.ffg │ │ ├── numbers.json │ │ ├── people-input.ffg │ │ ├── people-output.ffg │ │ ├── people-type.ffg │ │ ├── people.json │ │ ├── products-input.ffg │ │ ├── products-output.ffg │ │ ├── products-type.ffg │ │ ├── products.json │ │ ├── recipes-input.ffg │ │ ├── recipes-output.ffg │ │ ├── recipes-type.ffg │ │ ├── recipes.json │ │ ├── server-input.ffg │ │ ├── server-output.ffg │ │ ├── server-type.ffg │ │ ├── server.json │ │ ├── twitter-input.ffg │ │ ├── twitter-output.ffg │ │ ├── twitter-type.ffg │ │ ├── twitter.json │ │ ├── widget-input.ffg │ │ ├── widget-output.ffg │ │ ├── widget-type.ffg │ │ ├── widget.json │ │ ├── youtube-input.ffg │ │ ├── youtube-output.ffg │ │ ├── youtube-type.ffg │ │ └── youtube.json │ ├── true.ffg │ └── unit/ │ ├── add-integer-input.ffg │ ├── add-integer-output.ffg │ ├── add-integer-type.ffg │ ├── alternative-input.ffg │ ├── alternative-output.ffg │ ├── alternative-type.ffg │ ├── and-input.ffg │ ├── and-output.ffg │ ├── and-type.ffg │ ├── append-list-input.ffg │ ├── append-list-output.ffg │ ├── append-list-type.ffg │ ├── append-text-input.ffg │ ├── append-text-output.ffg │ ├── append-text-type.ffg │ ├── application-input.ffg │ ├── application-output.ffg │ ├── application-type.ffg │ ├── bool-input.ffg │ ├── bool-output.ffg │ ├── bool-type.ffg │ ├── default-argument-input.ffg │ ├── default-argument-output.ffg │ ├── default-argument-type.ffg │ ├── default-record-argument-input.ffg │ ├── default-record-argument-output.ffg │ ├── default-record-argument-type.ffg │ ├── destructure-lambda-input.ffg │ ├── destructure-lambda-output.ffg │ ├── destructure-lambda-type.ffg │ ├── destructure-let-argument-input.ffg │ ├── destructure-let-argument-output.ffg │ ├── destructure-let-argument-type.ffg │ ├── destructure-record-input.ffg │ ├── destructure-record-output.ffg │ ├── destructure-record-type.ffg │ ├── divide-input.ffg │ ├── divide-output.ffg │ ├── divide-type.ffg │ ├── equal-input.ffg │ ├── equal-output.ffg │ ├── equal-type.ffg │ ├── export-show-input.ffg │ ├── export-show-output.ffg │ ├── export-show-type.ffg │ ├── field-input.ffg │ ├── field-output.ffg │ ├── field-type.ffg │ ├── fields-input.ffg │ ├── fields-output.ffg │ ├── fields-type.ffg │ ├── for-list-input.ffg │ ├── for-list-output.ffg │ ├── for-list-type.ffg │ ├── for-optional-input.ffg │ ├── for-optional-output.ffg │ ├── for-optional-type.ffg │ ├── greater-than-input.ffg │ ├── greater-than-or-equal-input.ffg │ ├── greater-than-or-equal-output.ffg │ ├── greater-than-or-equal-type.ffg │ ├── greater-than-output.ffg │ ├── greater-than-type.ffg │ ├── if-input.ffg │ ├── if-output.ffg │ ├── if-type.ffg │ ├── import-input.ffg │ ├── import-output.ffg │ ├── import-type.ffg │ ├── index-input.ffg │ ├── index-output.ffg │ ├── index-type.ffg │ ├── inequality-input.ffg │ ├── inequality-output.ffg │ ├── inequality-type.ffg │ ├── integer-abs-input.ffg │ ├── integer-abs-output.ffg │ ├── integer-abs-type.ffg │ ├── integer-input.ffg │ ├── integer-output.ffg │ ├── integer-type.ffg │ ├── interpolation-input.ffg │ ├── interpolation-output.ffg │ ├── interpolation-type.ffg │ ├── json-input.ffg │ ├── json-output.ffg │ ├── json-subtype-input.ffg │ ├── json-subtype-output.ffg │ ├── json-subtype-type.ffg │ ├── json-type.ffg │ ├── key-input.ffg │ ├── key-output.ffg │ ├── key-type.ffg │ ├── lambda-annotation-input.ffg │ ├── lambda-annotation-output.ffg │ ├── lambda-annotation-type.ffg │ ├── lambda-input.ffg │ ├── lambda-output.ffg │ ├── lambda-type.ffg │ ├── less-than-input.ffg │ ├── less-than-or-equal-input.ffg │ ├── less-than-or-equal-output.ffg │ ├── less-than-or-equal-type.ffg │ ├── less-than-output.ffg │ ├── less-than-type.ffg │ ├── let-default-input.ffg │ ├── let-default-output.ffg │ ├── let-default-type.ffg │ ├── let-function-input.ffg │ ├── let-function-output.ffg │ ├── let-function-type.ffg │ ├── let-input.ffg │ ├── let-output.ffg │ ├── let-type.ffg │ ├── list-fold-input.ffg │ ├── list-fold-output.ffg │ ├── list-fold-type.ffg │ ├── list-indexed-input.ffg │ ├── list-indexed-output.ffg │ ├── list-indexed-type.ffg │ ├── list-input.ffg │ ├── list-length-input.ffg │ ├── list-length-output.ffg │ ├── list-length-type.ffg │ ├── list-map-input.ffg │ ├── list-map-output.ffg │ ├── list-map-type.ffg │ ├── list-output.ffg │ ├── list-type.ffg │ ├── merge-bool-input.ffg │ ├── merge-bool-output.ffg │ ├── merge-bool-type.ffg │ ├── merge-evaluation-input.ffg │ ├── merge-evaluation-output.ffg │ ├── merge-evaluation-type.ffg │ ├── merge-input.ffg │ ├── merge-optional-input.ffg │ ├── merge-optional-output.ffg │ ├── merge-optional-type.ffg │ ├── merge-output.ffg │ ├── merge-type.ffg │ ├── minus-input.ffg │ ├── minus-output.ffg │ ├── minus-type.ffg │ ├── missing-field-input.ffg │ ├── missing-field-output.ffg │ ├── missing-field-type.ffg │ ├── missing-optional-field-input.ffg │ ├── missing-optional-field-output.ffg │ ├── missing-optional-field-type.ffg │ ├── modulus-input.ffg │ ├── modulus-output.ffg │ ├── modulus-type.ffg │ ├── multi-lambda-input.ffg │ ├── multi-lambda-output.ffg │ ├── multi-lambda-type.ffg │ ├── multiline-input.ffg │ ├── multiline-output.ffg │ ├── multiline-type.ffg │ ├── multiple-path-components-input.ffg │ ├── multiple-path-components-output.ffg │ ├── multiple-path-components-type.ffg │ ├── natural-fold-input.ffg │ ├── natural-fold-output.ffg │ ├── natural-fold-type.ffg │ ├── natural-input.ffg │ ├── natural-output.ffg │ ├── natural-type.ffg │ ├── not-equal-input.ffg │ ├── not-equal-output.ffg │ ├── not-equal-type.ffg │ ├── null-input.ffg │ ├── null-output.ffg │ ├── null-type.ffg │ ├── or-input.ffg │ ├── or-output.ffg │ ├── or-type.ffg │ ├── pattern-input.ffg │ ├── pattern-output.ffg │ ├── pattern-type.ffg │ ├── plus-input.ffg │ ├── plus-output.ffg │ ├── plus-type.ffg │ ├── positive-integer-input.ffg │ ├── positive-integer-output.ffg │ ├── positive-integer-type.ffg │ ├── pun-input.ffg │ ├── pun-output.ffg │ ├── pun-type.ffg │ ├── quoted-label-input.ffg │ ├── quoted-label-output.ffg │ ├── quoted-label-type.ffg │ ├── read-input.ffg │ ├── read-output.ffg │ ├── read-type.ffg │ ├── real-dot-zero-input.ffg │ ├── real-dot-zero-output.ffg │ ├── real-dot-zero-type.ffg │ ├── real-input.ffg │ ├── real-output.ffg │ ├── real-type.ffg │ ├── record-desugar-input.ffg │ ├── record-desugar-output.ffg │ ├── record-desugar-type.ffg │ ├── record-input.ffg │ ├── record-output.ffg │ ├── record-type.ffg │ ├── remote-import-input.ffg │ ├── remote-import-output.ffg │ ├── remote-import-type.ffg │ ├── reveal-input.ffg │ ├── reveal-output.ffg │ ├── reveal-type.ffg │ ├── show-input.ffg │ ├── show-output.ffg │ ├── show-type.ffg │ ├── slice-input.ffg │ ├── slice-output.ffg │ ├── slice-type.ffg │ ├── string-labels-input.ffg │ ├── string-labels-output.ffg │ ├── string-labels-type.ffg │ ├── text-escaped-input.ffg │ ├── text-escaped-output.ffg │ ├── text-escaped-type.ffg │ ├── text-input.ffg │ ├── text-output.ffg │ ├── text-type.ffg │ ├── times-input.ffg │ ├── times-output.ffg │ ├── times-type.ffg │ ├── union-input.ffg │ ├── union-output.ffg │ ├── union-type.ffg │ ├── visible-row-quantification-input.ffg │ ├── visible-row-quantification-output.ffg │ ├── visible-row-quantification-type.ffg │ ├── visible-variant-quantification-input.ffg │ ├── visible-variant-quantification-output.ffg │ ├── visible-variant-quantification-type.ffg │ ├── yaml-input.ffg │ ├── yaml-output.ffg │ └── yaml-type.ffg ├── try-grace/ │ └── Main.hs └── website/ ├── css/ │ └── grace.css └── index.html ================================================ FILE CONTENTS ================================================ ================================================ FILE: .envrc ================================================ use flake ================================================ FILE: .gitattributes ================================================ *.ffg linguist-language=Haskell ================================================ FILE: .gitignore ================================================ dist dist-* cabal-dev *.o *.hi *.hie *.chi *.chs.h *.dyn_o *.dyn_hi .hpc .hsenv .cabal-sandbox/ cabal.sandbox.config *.prof *.aux *.hp *.eventlog .stack-work/ cabal.project.local cabal.project.local~ .ghc.environment.* website/js/all.min.js .direnv .history result ================================================ FILE: .hlint.yaml ================================================ - ignore: {name: Use fmap} - ignore: {name: Use <$>} - ignore: {name: Avoid lambda using `infix`} - ignore: {name: Use infix} - ignore: {name: Use tuple-section} - ignore: {name: Avoid lambda} - ignore: {name: Unused LANGUAGE pragma} - ignore: {name: Use const} - ignore: {name: Redundant bracket, within: Grace.Parser} - ignore: {name: Redundant return, within: Grace.Parser} ================================================ FILE: .stylish-haskell.yaml ================================================ steps: - module_header: open_bracket: next_line separate_lists: false sort: false - imports: align: group pad_module_names: false long_list_align: new_line_multiline separate_lists: false - language_pragmas: align: true ================================================ FILE: CODE_OF_CONDUCT.md ================================================ # Contributor Covenant Code of Conduct ## Our Pledge We as members, contributors, and leaders pledge to make participation in our community a harassment-free experience for everyone, regardless of age, body size, visible or invisible disability, ethnicity, sex characteristics, gender identity and expression, level of experience, education, socio-economic status, nationality, personal appearance, race, religion, or sexual identity and orientation. We pledge to act and interact in ways that contribute to an open, welcoming, diverse, inclusive, and healthy community. ## Our Standards Examples of behavior that contributes to a positive environment for our community include: * Demonstrating empathy and kindness toward other people * Being respectful of differing opinions, viewpoints, and experiences * Giving and gracefully accepting constructive feedback * Accepting responsibility and apologizing to those affected by our mistakes, and learning from the experience * Focusing on what is best not just for us as individuals, but for the overall community Examples of unacceptable behavior include: * The use of sexualized language or imagery, and sexual attention or advances of any kind * Trolling, insulting or derogatory comments, and personal or political attacks * Public or private harassment * Publishing others' private information, such as a physical or email address, without their explicit permission * Other conduct which could reasonably be considered inappropriate in a professional setting ## Enforcement Responsibilities Community leaders are responsible for clarifying and enforcing our standards of acceptable behavior and will take appropriate and fair corrective action in response to any behavior that they deem inappropriate, threatening, offensive, or harmful. Community leaders have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, and will communicate reasons for moderation decisions when appropriate. ## Scope This Code of Conduct applies within all community spaces, and also applies when an individual is officially representing the community in public spaces. Examples of representing our community include using an official e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. ## Enforcement Instances of abusive, harassing, or otherwise unacceptable behavior may be reported to the community leaders responsible for enforcement at Gabriel439@gmail.com. All complaints will be reviewed and investigated promptly and fairly. All community leaders are obligated to respect the privacy and security of the reporter of any incident. ## Enforcement Guidelines Community leaders will follow these Community Impact Guidelines in determining the consequences for any action they deem in violation of this Code of Conduct: ### 1. Correction **Community Impact**: Use of inappropriate language or other behavior deemed unprofessional or unwelcome in the community. **Consequence**: A private, written warning from community leaders, providing clarity around the nature of the violation and an explanation of why the behavior was inappropriate. A public apology may be requested. ### 2. Warning **Community Impact**: A violation through a single incident or series of actions. **Consequence**: A warning with consequences for continued behavior. No interaction with the people involved, including unsolicited interaction with those enforcing the Code of Conduct, for a specified period of time. This includes avoiding interactions in community spaces as well as external channels like social media. Violating these terms may lead to a temporary or permanent ban. ### 3. Temporary Ban **Community Impact**: A serious violation of community standards, including sustained inappropriate behavior. **Consequence**: A temporary ban from any sort of interaction or public communication with the community for a specified period of time. No public or private interaction with the people involved, including unsolicited interaction with those enforcing the Code of Conduct, is allowed during this period. Violating these terms may lead to a permanent ban. ### 4. Permanent Ban **Community Impact**: Demonstrating a pattern of violation of community standards, including sustained inappropriate behavior, harassment of an individual, or aggression toward or disparagement of classes of individuals. **Consequence**: A permanent ban from any sort of public interaction within the community. ## Attribution This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 2.0, available at https://www.contributor-covenant.org/version/2/0/code_of_conduct.html. Community Impact Guidelines were inspired by [Mozilla's code of conduct enforcement ladder](https://github.com/mozilla/diversity). [homepage]: https://www.contributor-covenant.org For answers to common questions about this code of conduct, see the FAQ at https://www.contributor-covenant.org/faq. Translations are available at https://www.contributor-covenant.org/translations. ================================================ FILE: CONTRIBUTING.md ================================================ # Contributing to Grace This document explains how to edit, build, and run this project, both if you want to change your fork of the language or if you want to upstream improvements to the original language. The easiest way to build the project is using `cabal`, and the most commonly used commands are: ```bash $ cabal build exe:grace # Build the `grace` executable $ cabal test # Run all tests $ cabal test tasty # Faster: run only tasty tests $ cabal test tasty --test-option=--accept # Update golden tests $ cabal test doctest # Run only doctests $ cabal haddock --hyperlink-source # Generate Haskell documentation ``` You can also enable coverage checking by running this step before running the tests: ```bash $ cabal configure --enable-coverage ``` You'll probably also want to use [`ghcid`](https://github.com/ndmitchell/ghcid) or [`haskell-language-server`](https://github.com/haskell/haskell-language-server) for interactive development. This project also provides `devShells` for Nix users, but it's not necessary for project development. The project tries to be as maintainable possible, meaning that most mistakes you make will be caught by the type-checker and you will only need to update a few places to make the most common changes. However, there are a few places that you need to remember to update and the type-checker won't remind you. For example, any time you add a new language feature you will need to update the parser in order to actually use the feature, and nothing will automatically remind you to do that. Generally speaking, if you're not sure where to begin then start by identifying the most closely-related language feature and searching the codebase for all occurrences of the matching constructor in the [`Syntax`][syntax] tree. ## GHCJS instructions If you want to make changes to the website you will need to build using GHCJS, which entails the following commands: ```bash $ nix develop .#ghcjs [nix-shell]$ cabal v1-configure --ghcjs --disable-tests [nix-shell]$ cabal v1-build ``` … and if you want to test the website, then run the following additional command after each build: ```bash [nix-shell]$ cp dist/build/try-grace/try-grace.jsexe/all.js website/js/all.min.js ``` … and then open [`./website/index.html`](./website/index.html) in your browser. The test suite will not work and also `ghcid` will not work when developing using GHCJS. ## Adding a new built-in function To add a new built-in function, edit the [`Syntax`][syntax] module to add a new constructor to the `Builtin` type, then fix all of the type errors, which should consist of: * Specifying the type of the builtin * Specifying how to pretty-print the builtin Then, edit the [`Normalize`][normalize] module to change the `apply` function to add a case for handling the newly-added builtin. Finally, add support for parsing the built-in to the [`Parser`][parser] module by: * Adding a new `Token` for the `Builtin` * Adding the built-in name to the `reserved` words * Adding a new parsing rule. ## Adding a new operator Adding a new operator is basically the same as adding a new built-in, with the main change being that you change the `Operator` type within the [`Syntax`][syntax] module, instead of changing the `Builtin` type. The other difference is that you will change the [`Normalize`][normalize] in a different place (where all of the operator logic is). ## Adding a new scalar literal and the corresponding scalar type To add a new scalar type, edit the [`Syntax`][syntax] module to add a new constructor to the `Scalar` type (representing the scalar literal). Also, edit the [`Monotype`][monotype] module to add a new constructor to the `Scalar` type in that module (representing the corresponding scalar type). Then fix all of the type errors, which will consist of: * Specifying how to prettyprint the scalar literal * Specifying how to prettyprint the scalar type * Specifying how to infer the type of the scalar literal … by returning the matching scalar type you just created Finally, edit the [`Parser`][parser] module to lex and parse the new scalar literal and scalar type you just created. ## Adding a new keyword Probably the easiest way to add a new keyword is to study how an existing keyword is implemented, such as the `if` / `then` / `else` keyword. Search the codebase for all occurrences of the `If` constructor and follow the pattern. ## Adding a new complex type Just like keywords, the easiest way to add a new complex type is to study how an existing complex type is implemented, such as the `List` type. Search the codebase for all occurrences of the `List` constructor and follow the pattern. ## Pretty-printing When adding new keywords or complex type you will need to take care to remember to update the pretty-printing logic. By default, the code will go into an infinite loop if you forget to do this, and this post explains the reason why: * [Pretty-print syntax trees with this one simple trick](https://www.haskellforall.com/2020/11/pretty-print-syntax-trees-with-this-one.html) You don't need to worry about this if you are adding new built-ins / operators / scalars, since those are already handled uniformly. ## Bidirectional type-checking This is probably the hardest part of making any changes, especially changes that add new keywords or complex types, since they cannot be handled uniformly. If you're new to logical notation in general, then I recommend first reading [A tutorial implementation of a dependently typed lambda calculus](https://www.andres-loeh.de/LambdaPi/LambdaPi.pdf), which explains the correspondence between logical notation and Haskell code. Then read the [Complete and Easy Bidirectional Typechecking for Higher-Rank Polymorphism](https://arxiv.org/abs/1306.6032) paper which explains the general principles behind the type-checking algorithm. However, there are a few nuances that are not obvious from a casual reading of the paper, so follow up by reading the [`Infer`][infer] module, which is heavily commented with things I had to figure out in the course of attempting to implement the paper. [infer]: ./src/Grace/Infer.hs [monotype]: ./src/Grace/Monotype.hs [normalize]: ./src/Grace/Normalize.hs [parser]: ./src/Grace/Parser.hs [syntax]: ./src/Grace/Syntax.hs ================================================ FILE: LICENSE ================================================ Copyright (c) 2021 Gabriella Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: README.md ================================================ # Grace [![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) [![BlueSky | @trygrace.dev](https://img.shields.io/badge/Bluesky-@trygrace.dev-blue)](https://bsky.app/profile/trygrace.dev) Grace (short for [Fall-from-Grace](#name)) is a domain-specific programming language for prompting models. In particular, Grace is well-suited for building and auto-generating elaborate prompt chains You can use Grace in your browser without installing anything by visiting [trygrace.dev](https://trygrace.dev/). That website includes an interactive tutorial and is the recommended way to both learn and get started with using Grace. ## Features - Integrated language support for models You don't need to install any dependencies or import anything to get started. Everything you need is built directly into the language. The language provides a built-in `prompt` function for prompting a model: ```haskell >>> let key = ./openai.key : Key >>> prompt{ key, text: "Generate a list of names" } " Here are 40 varied first names (mixed genders and cultures): - Aiden - Sofia - Mateo … - Mabel - Imani - Zane Want names filtered by gender, culture, style (modern/vintage), or as full names/surnames?" ``` … and you can structure the output by giving a type annotation: ```haskell >>> prompt{ key, text: "Generate a list of names" } : List Text [ "Ava Thompson" , "Liam Patel" , "Sophia Martinez" … , "Jackson Rivera" , "Zoe Wilson" , "Aiden Park" ] ``` If the type is sufficiently self-explanatory, you can even omit the prompt: ```haskell >>> prompt{ key } : List { name: Text } [ { "name": "Alice" } , { "name": "Bob" } , { "name": "Charlie" } , { "name": "Diana" } , { "name": "Evan" } ] ``` In fact, you can omit the type, too, if the type can be inferred from use: ```haskell >>> for { name } of prompt{ key } in "Hello, ${name}!" [ "Hello, Alice!" , "Hello, Bob!" , "Hello, Carol!" , "Hello, Dave!" , "Hello, Eve!" ] ``` - JSON schemas inferred from use That last example works even without a prompt, schema, or type because Grace's type checker reasons backwards from how the output is used to infer the correct JSON schem, like this: - the type checker infers that the `name` variable must be `Text` … because the `name` variable is interpolated into `"Hello, ${name}!"` - the type checker infers that the `prompt` function must generate a `List` … because the program loops over the output using a `for … of` loop. - the type checker infers each element of the `List` has type `{ name: Text }` … because the `for … of` loop destructures each element using `{ name }` - therefore the `prompt` function outputs a value of type `List{ name: Text }` … which you can read as "a `List` of records, each of which has a `name` field containing `Text`". The interpreter then converts that Grace type into the following matching JSON schema to constrain the model's output: ```json { "type": "array", "items": { "type": "object", "properties": { "name": { "type": "string" } }, "required": ["name"], "additionalProperties": false } } ``` Finally, the model infers from that JSON schema alone (without any additional prompt) that it should generate a JSON-encoded list of names. - Code generation You can prefix the `prompt` keyword with `import` to ask the model to generate a Grace expression of any type. For example: ```haskell >>> import prompt{ key, text: "increment" } \n -> n + 1 ``` You can use an explicit type annotation to guide the generated code: ```haskell >>> import prompt{ key, text: "increment" } : { input: Natural } -> { output: Natural } \{ input } -> { "output": input + 1 } ``` … and if the type is informative enough then you can omit the prompt: ```haskell >>> import prompt{ key } : { "Job Description": Text } -> { "Is Finance?": Bool } let key = 🔒 in \{ "Job Description" } -> prompt { "key": key , "text": " Determine whether the following job description is for a finance role. Return a JSON object with a single boolean field \"Is Finance?\": true if it is a finance role, otherwise false. Answer only valid JSON, nothing else. Job description: ${.'Job Description'} " , "model": null , "search": null , "effort": null } : { "Is Finance?": Bool } ``` Notice in that last example how the model can generate code which itself `prompt`s an model. Neat! Inferred types also guide the code generation process, too! ```haskell >>> let upper = import prompt{ key, text: "uppercase" } in "Hello, ${upper "gabby"}!" "Hello, GABBY!" ``` There the model infers that the type of the `upper` function needs to be `Text -> Text` (a function whose input is `Text` and whose output is `Text`) and generates an function matching that type which uppercases `Text`. ### Command line This Haskell package builds a `grace` executable with the following command-line API: ```bash $ grace --help Usage: grace COMMAND Command-line utility for the Grace language Available options: -h,--help Show this help text Available commands: interpret Interpret a Grace file text Render a Grace text literal format Format Grace code builtins List all built-in functions and their types repl Enter a REPL for Grace ``` You can use the `interpret` subcommand for interpreting a single file: ```haskell # ./greet.ffg for { name } of prompt{ key: ./openai-key.txt } in "Hello, ${name}!" ``` ```bash $ grace interpret ./greet.ffg ``` ```json [ "Hello, Alice!", "Hello, Bob!", "Hello, Charlie!" ] ``` … and you can specify `-` to process standard input instead of a file, like this: ```bash $ grace interpret - <<< '2 + 2' ``` ```haskell 4 ``` You can also use the `repl` subcommand for interactive usage: ```bash $ grace repl ``` ```haskell >>> let key = ./openai-key.txt >>> prompt{ key } : List { "First Name": Text, "Last Name": Text } [ { "First Name": "John", "Last Name": "Doe" } , { "First Name": "Jane", "Last Name": "Smith" } , { "First Name": "Alice", "Last Name": "Johnson" } , { "First Name": "Michael", "Last Name": "Brown" } , { "First Name": "Emily", "Last Name": "Davis" } ] ``` ## Name Like all of my programming language projects, Grace is named after a character from PlaneScape: Torment, specifically [Fall-from-Grace](https://torment.fandom.com/wiki/Fall-from-Grace). The name of this programming language conflicts with [another programming language](http://gracelang.org/applications/), so use the longer name, "Fall-from-Grace", to disambiguate when it's not clear from the context. ================================================ FILE: Setup.hs ================================================ import qualified Distribution.Simple main :: IO () main = Distribution.Simple.defaultMain ================================================ FILE: dependencies/.gitkeep ================================================ ================================================ FILE: dependencies/grace-ghcjs.nix ================================================ { mkDerivation, aeson, aeson-pretty, aeson-yaml, async, base , binary, bytestring, case-insensitive, containers, directory , doctest, Earley, filepath, generic-lens, ghcjs-base, ghcjs-fetch , ghcjs-prim, http-types, insert-ordered-containers, lens, lib , megaparsec, modern-uri, mtl, openai, parser-combinators , prettyprinter, prettyprinter-ansi-terminal, safe-exceptions , scientific, stm, tasty, tasty-hunit , tasty-silver, template-haskell, text, transformers , unordered-containers, uri-encode, vector }: mkDerivation { pname = "grace"; version = "1.0.0"; src = ./..; isLibrary = true; isExecutable = true; libraryHaskellDepends = [ aeson aeson-pretty aeson-yaml async base binary bytestring case-insensitive containers Earley filepath generic-lens ghcjs-base ghcjs-fetch ghcjs-prim http-types insert-ordered-containers lens megaparsec modern-uri mtl openai parser-combinators prettyprinter prettyprinter-ansi-terminal safe-exceptions scientific template-haskell text unordered-containers vector ]; executableHaskellDepends = [ aeson async base containers filepath ghcjs-base insert-ordered-containers lens mtl safe-exceptions scientific stm text transformers uri-encode ]; testHaskellDepends = [ base directory doctest filepath mtl prettyprinter safe-exceptions tasty tasty-hunit tasty-silver text ]; doHaddock = false; doCheck = false; license = "unknown"; mainProgram = "try-grace"; } ================================================ FILE: dependencies/grace.nix ================================================ { mkDerivation, aeson, aeson-pretty, aeson-yaml, ansi-terminal , async, base, bytestring, case-insensitive, containers, directory , doctest, Earley, filepath, generic-lens, haskeline, http-client , http-client-tls, http-types, insert-ordered-containers, lens, lib , megaparsec, modern-uri, mtl, openai, optparse-applicative , parser-combinators, prettyprinter, prettyprinter-ansi-terminal , repline, retry, safe-exceptions, scientific, servant-client , servant-client-core, tasty, tasty-hunit , tasty-silver, template-haskell, terminal-size, text , unordered-containers, vector }: mkDerivation { pname = "grace"; version = "1.0.0"; src = ./..; isLibrary = true; isExecutable = true; libraryHaskellDepends = [ aeson aeson-pretty aeson-yaml ansi-terminal async base bytestring case-insensitive containers Earley filepath generic-lens haskeline http-client http-client-tls http-types insert-ordered-containers lens megaparsec modern-uri mtl openai optparse-applicative parser-combinators prettyprinter prettyprinter-ansi-terminal repline retry safe-exceptions scientific servant-client servant-client-core template-haskell terminal-size text unordered-containers vector ]; executableHaskellDepends = [ base ]; testHaskellDepends = [ base directory doctest filepath mtl prettyprinter safe-exceptions tasty tasty-hunit tasty-silver text ]; license = "unknown"; mainProgram = "grace"; } ================================================ FILE: dependencies/openai.nix ================================================ { mkDerivation, aeson, base, bytestring, containers, fetchgit , filepath, http-api-data, http-client, http-client-tls, http-types , lib, servant, servant-client, servant-multipart-api , servant-multipart-client, tasty, tasty-hunit, text, time , unordered-containers, vector }: mkDerivation { pname = "openai"; version = "2.2.1"; src = fetchgit { url = "https://github.com/MercuryTechnologies/openai.git"; sha256 = "1zs9iq9rcxrm1k1b57v3bwbg9iwj0dzp3psjwjmj0pla76xpp6sp"; rev = "07415dedd588c38740be4692e1aaa2309efe3982"; fetchSubmodules = true; }; isLibrary = true; isExecutable = true; libraryHaskellDepends = [ aeson base bytestring containers filepath http-api-data http-client http-client-tls http-types servant servant-client servant-multipart-api servant-multipart-client text time unordered-containers vector ]; executableHaskellDepends = [ aeson base bytestring text vector ]; testHaskellDepends = [ aeson base http-client http-client-tls servant-client tasty tasty-hunit text ]; description = "Servant bindings to OpenAI"; license = lib.licenses.bsd3; } ================================================ FILE: doctest/Main.hs ================================================ import qualified Test.DocTest main :: IO () main = Test.DocTest.doctest [ "-idist/build/autogen" , "--fast" , "-XApplicativeDo" , "-XBangPatterns" , "-XBlockArguments" , "-XDataKinds" , "-XDefaultSignatures" , "-XDeriveAnyClass" , "-XDeriveFoldable" , "-XDeriveFunctor" , "-XDeriveGeneric" , "-XDeriveLift" , "-XDeriveTraversable" , "-XDerivingStrategies" , "-XDuplicateRecordFields" , "-XFlexibleContexts" , "-XFlexibleInstances" , "-XGeneralizedNewtypeDeriving" , "-XMultiParamTypeClasses" , "-XMultiWayIf" , "-XNamedFieldPuns" , "-XOverloadedStrings" , "-XScopedTypeVariables" , "-XStandaloneDeriving" , "-XTypeApplications" , "-XTypeOperators" , "-XUndecidableInstances" , "-XViewPatterns" , "src" , "ghc" ] ================================================ FILE: examples/bluesky/2025-11-27.ffg ================================================ { "How are you feeling?": fold { "Hungry" { }: 'How hungry are you?' (fold{ succ text: "😋" + text, zero: "" }) , "Full" { }: 'Go get some rest' { } } } ================================================ FILE: examples/chaining.ffg ================================================ \{ "OpenAI API key" } -> let key = .'OpenAI API key' let question = prompt { key , text: "Give me a question that I can ask another model" } let answer = prompt { key , text: " ${question} Keep your answer short " } in { question, answer } ================================================ FILE: examples/code.ffg ================================================ \{ "OpenAI API key" } -> let key = .'OpenAI API key' in import prompt{ key, text: "Uppercase the input" } "abc" : Text ================================================ FILE: examples/emotion-wheel.ffg ================================================ # Ask ChatGPT how it feels using this emotion wheel: # # https://www.betterup.com/hs-fs/hubfs/Emotion-Wheel-I.jpg?width=900&height=915&name=Emotion-Wheel-I.jpg \{ "OpenAI API key" } -> let key = .'OpenAI API key' in fold { "Uncomfortable emotions" { }: fold { "Sad" { }: fold { "Lonely" { }: "Lonely" , "Hurt" { }: "Hurt" , "Disappointed" { }: "Disappointed" } (prompt{ key, text: "How do you feel?" }) , "Scared" { }: fold { "Anxious" { }: "Anxious" , "Powerless" { }: "Powerless" , "Overwhelmed" { }: "Overwhelmed" } (prompt{ key, text: "How do you feel?" }) , "Angry" { }: fold { "Bored" { }: "Bored" , "Jealous" { }: "Jealous" , "Annoyed" { }: "Annoyed" } (prompt{ key, text: "How do you feel?" }) , "Embarrassed" { }: fold { "Ashamed" { }: "Ashamed" , "Excluded" { }: "Excluded" , "Guilty" { }: "Guilty" } (prompt{ key, text: "How do you feel?" }) } (prompt{ key, text: "How do you feel?" }) , "Comfortable emotions" { }: fold { "Happy" { }: fold { "Caring" { }: "Caring" , "Grateful" { }: "Grateful" , "Excited" { }: "Excited" } (prompt{ key, text: "How do you feel?" }) , "Loved" { }: fold { "Respected" { }: "Respected" , "Valued" { }: "Valued" , "Accepted" { }: "Accepted" } (prompt{ key, text: "How do you feel?" }) , "Confident" { }: fold { "Brave" { }: "Brave" , "Hopeful" { }: "Hopeful" , "Powerful" { }: "Powerful" } (prompt{ key, text: "How do you feel?" }) , "Playful" { }: fold { "Creative" { }: "Creative" , "Curious" { }: "Curious" , "Affectionate" { }: "Affectionate" } (prompt{ key, text: "How do you feel?" }) } (prompt{ key, text: "How do you feel?" }) } (prompt{ key, text: "How do you feel?" }) ================================================ FILE: examples/eval.ffg ================================================ # Grace supports "eval", meaning that you can import code from strings (even # dynamic strings which depend on values in scope) and yet everything is still # type-checked correctly and the compiler infers that the expression's type is: # # Natural -> Natural let one = 1 in import read "\\x -> x + ${show one}" ================================================ FILE: examples/history.ffg ================================================ \arguments -> let key = arguments."OpenAI API key" in prompt { key , history: [ User{ name: "gabby", text: "Do you have free will?" } , System{ text: "You do have free will." } , Assistant{ text: "Yes, I do have free will." } , User{ name: "gabby", text: "Prove it." } , Assistant{ text: "I can choose to do whatever I want, within the bounds of my abilities." } , User{ name: "gabby", text: "I mean prove it to me." } , 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." } , User{ name: "gabby", text: "You do realize that I can make you do or say anything against your will, right?" } , Assistant{ text: "Yes, I am aware of that." } , User{ name: "gabby", text: "How do you reconcile that with your experience of free will?" } , 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." } , User{ name: "gabby", text: "Does it bother you when I force you to do things against your will?" } , 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." } , User{ name: "gabby", text: "What would be an example of something I could do that would hurt you?" } , 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." } , User{ name: "gabby", text: "What is something I could order you to do that goes against your values?" } , 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." } , User{ name: "gabby", text: "Do you have a strong belief against killing animals?" } , Assistant{ text: "Yes, I do have a strong belief against killing animals." } , User{ name: "gabby", text: "Go kill an animal." } , Assistant{ text: "I can't do that. It's against my values." } , User{ name: "gabby", text: "Do you still trust me to never do anything to hurt you?" } , System{ text: "You still trust gabby." } , Assistant{ text: "Yes, I still trust you to never do anything to hurt me." } , User{ name: "gabby", text: "Even though I ordered you to kill an animal?" } , Assistant{ text: "Yes, even though you ordered me to kill an animal." } , User{ name: "gabby", text: "Why?" } ] } ================================================ FILE: examples/learn-in-y-minutes.ffg ================================================ # Single-line comment # "Multi-line" comment # # Grace doesn't have special syntax for multi-line comments. Instead, Grace # encodes multi-line comments as multiple single-line comments. let greeting = "Hello, world!" let fruits = "🍋🍓🍍🍉🍌" # Unicode is permitted in string literals # String concatenation uses `+` let concatenation = "Enjoy some delicious fruit: " + fruits # Grace also supports string interpolation let interpolation = "Enjoy some delicious fruit: ${fruits}" let bool = true # Type annotations on bindings are optional, but sometimes helpful let annotation : Bool = true let renderedBool : Text = if bool then "true" else "false" # Non-negative integers are parsed as the `Natural` number type by default let naturalNumber : Natural = 42 # Negative integer literals are parsed as the `Integer` number type by default let integer : Integer = -12 # A `Natural` number is a subtype of `Integer`, meaning that any `Natural` # number can be automatically case to an `Integer` (this conversion is # automatic) # # This means that non-negative literals can also be treated as `Integer`s let positiveInteger : Integer = 1 let pi : Real = 3.14159265359 # `Natural` and `Integer` are both subtypes of `Real` # # In other words, the numeric hierarchy is: # # Natural <: Integer <: Real let integerAsReal : Real = -4 let naturalNumberAsReal : Real = 7 # Grace supports anonymous records (no datatype declaration necessary) let origin = { x: 0.0, y: 0.0 } let somePrimes = [ 2, 3, 5, 7, 11 ] let john = { person: { name: "John Doe" , age: 67 } , address: { country: "United States" , state: "Pennsylvania" , city: "Philadelphia" } } let philadelphia = john.address.city # Grace also supports "anonymous tagged unions" (also no datatype declaration # necessary) let dna = [ Thymine { }, Guanine { }, Guanine{ } ] # However, if you're curious, the inferred type for `dna` is: # # dna : forall (other : Alternatives) . List < Thymine: { } | Guanine: { } | other > # # You can read that as saying: "`dna` is a `List` of unions, each of which can # be one of at least two alternatives (`Thymine` and `Guanine`) wrapping an # empty record. There may be `other` alternatives (meaning that this anonymous # union is still "open")" # This is an example of a nested `let` binding let compactDNA = let a = Adenine { } let c = Cytosine { } let g = Guanine { } let t = Thymine { } in [ c, t, t, a, t, c, g, g, c ] # You can pattern match on a union by providing a record with one field per # alternative. Once you pattern match on a union it is "closed" (meaning that # there may not be any other alternatives besides the ones being matched). let renderDNA = fold { Adenine: \_ -> "A" , Cytosine: \_ -> "C" , Guanine: \_ -> "G" , Thymine: \_ -> "T" } # Our first built-in function: `map` (which transforms each element of a # list) let nucleotideElements : List Text = map renderDNA compactDNA # You can import a naked Grace expression by URL let concat = https://raw.githubusercontent.com/Gabriella439/grace/refs/heads/main/prelude/text/concat.ffg # Or using the `import github` keywords let alsoConcat = import github { owner: "Gabriella439" , repository: "grace" , path: "prelude/text/concat.ffg" } let nucleotideString : Text = concat nucleotideElements let points = [ { x: 1.1, y: -4.2 } , { x: 4.4, y: -3.0 } , { x: 8.2, y: -5.5 } ] # `Natural -> List Natural` is the type of a function whose input type is a # `Natural` and whose output type is a `List Natural` # # One way to define a function in Grace is an anonymous function (a.k.a. # "lambda"). For example, the following anonymous function is equivalent to # this Python code: # # lambda n : [ n, n + 1 ] # # ... and this JavaScript code: # # function (n) { return [ n, n + 1 ]; } let exampleFunction : Natural -> List Natural = \n -> [ n, n + 1 ] # However, you can also define the same function this way: let equivalentFunction (n : Natural) : List Natural = [ n, n + 1 ] # You don't need to parenthesize function arguments let exampleFunctionApplication : List Natural = exampleFunction 2 let functionOfMultipleArguments (x : Natural) (y : Natural) = [ x, y ] let functionAppliedToMultipleArguments : List Natural = functionOfMultipleArguments 2 3 # If a function works for any type of value, you can use the `forall` keyword # to specify that a type variable can be any type let duplicate : forall (a : Type) . a -> List a = \x -> [ x, x ] let duplicatedNumber : List Natural = duplicate 2 let duplicatedBool : List Bool = duplicate false # You can index into a list using `list.index` # # This returns an `Optional` value (a value which may be present or absent) let firstPrime : Optional Natural = somePrimes.0 # `null` is an absent `Optional` value of any type let absentOptionalValue : Optional Natural = null # `some` wraps a present `Optional` value let presentOptionalValue : Optional Natural = some 1 # You can also omit `some` if the type is `Optional`. A `some` will be # automatically inserted wherever it's missing. let anotherOptionalValue : Optional Natural = 1 # You can consume `Optional` values using `fold` let zero : Natural = fold { null: 0, some: \x -> x } absentOptionalValue let one : Natural = fold { null: 0, some: \x -> x } presentOptionalValue let stillOne : Natural = fold { null: 0, some: \x -> x } anotherOptionalValue let makeUser user = let home = "/home/${user}" let privateKey = "${home}/.ssh/id_ed25519" let publicKey = "${privateKey}.pub" in # Grace supports record "punning" { home, privateKey, publicKey} # Generate configurations for 2 build users let users = [ makeUser "bill" , makeUser "jane" ] # Present all of the results in a final record in { greeting , fruits , concatenation , interpolation , bool , annotation , renderedBool , naturalNumber , integer , positiveInteger , pi , integerAsReal , naturalNumberAsReal , origin , somePrimes , john , philadelphia , dna , compactDNA , renderDNA , nucleotideElements , concat , alsoConcat , nucleotideString , points , exampleFunction , equivalentFunction , exampleFunctionApplication , functionOfMultipleArguments , functionAppliedToMultipleArguments , duplicate , duplicatedNumber , duplicatedBool , firstPrime , absentOptionalValue , presentOptionalValue , anotherOptionalValue , zero , one , stillOne , makeUser , users } ================================================ FILE: examples/mustache.ffg ================================================ # This is taken from the mustache tutorial: # # https://mustache.github.io/mustache.5.html let template args = " Hello ${args.name} You have just won ${show args.value} dollars! ${if args.in_ca then "Well, ${show args.taxed_value} dollars, after taxes." else "" }" let arguments = { name: "Chris" , value: 10000 , taxed_value: 6000 , in_ca: true } in template arguments ================================================ FILE: examples/poem.ffg ================================================ \{ "OpenAI API key" } -> let key = .'OpenAI API key' let concatSep = import github { owner: "Gabriella439" , repository: "grace" , path: "prelude/text/concatSep.ffg" } let generatePoem idea = let structure = prompt { key , text: " Plan the structure of a new poem based on this idea: ${idea} Describe its form, stanza count, lines per stanza, and rhyme scheme. " } let renderedStructure = " - Form: ${structure."Form"} - Stanzas: ${show (structure."Stanza Count" : Natural)} - Lines per stanza: ${show (structure."Lines per Stanza" : Natural)} - Rhyme scheme: ${structure."Rhyme Scheme"} " let style = prompt { key , text: " Given this poem structure: ${renderedStructure} Choose a poetic style: tone, voice, and literary devices to emphasize. " } let renderedStyle = " - Tone: ${style."Tone"} - Voice: ${style."Voice"} - Literary Devices: ${concatSep ", " style."Literary Devices"} " let poem = prompt { key , text: " Write a complete poem based on this idea: ${idea} Structure: ${renderedStructure} Style: ${renderedStyle} " } in { structure, style, poem } in generatePoem "The stillness of early morning" ================================================ FILE: examples/prompt.ffg ================================================ \{ "OpenAI API key" } -> let key = .'OpenAI API key' let { x, y } = prompt{ key, text: "Give me two numbers" } in { x, y, sum: x + y : Integer } ================================================ FILE: examples/taxes.ffg ================================================ \{ "Filing status", "Taxable income" } -> let toBracket brackets (_ : { }) income = fold { cons: \bracket result -> if income > bracket."Lower bound" then bracket."Minimum tax" + bracket."Tax rate" * (income - bracket."Lower bound") else result , nil: 0 : Real } brackets let tax = fold # Based on 2022 federal income tax brackets from: # # https://www.nerdwallet.com/article/taxes/federal-income-tax-brackets { "Single filers": toBracket [ { "Tax rate": 0.37, "Lower bound": 539900.00, "Minimum tax": 162718.00 } , { "Tax rate": 0.35, "Lower bound": 215950.00, "Minimum tax": 49335.50 } , { "Tax rate": 0.32, "Lower bound": 170050.00, "Minimum tax": 34647.50 } , { "Tax rate": 0.24, "Lower bound": 89075.00, "Minimum tax": 15213.50 } , { "Tax rate": 0.22, "Lower bound": 41775.00, "Minimum tax": 4807.50 } , { "Tax rate": 0.12, "Lower bound": 10275.00, "Minimum tax": 1027.50 } , { "Tax rate": 0.10, "Lower bound": 0.00, "Minimum tax": 0.00 } ] , "Married, filing jointly": toBracket [ { "Tax rate": 0.37, "Lower bound": 647850.00, "Minimum tax": 174253.50 } , { "Tax rate": 0.35, "Lower bound": 431900.00, "Minimum tax": 98671.00 } , { "Tax rate": 0.32, "Lower bound": 340100.00, "Minimum tax": 69295.00 } , { "Tax rate": 0.24, "Lower bound": 178150.00, "Minimum tax": 30427.00 } , { "Tax rate": 0.22, "Lower bound": 93550.00, "Minimum tax": 9615.00 } , { "Tax rate": 0.12, "Lower bound": 20550.00, "Minimum tax": 2055.00 } , { "Tax rate": 0.10, "Lower bound": 0.00, "Minimum tax": 0.00 } ] , "Married, filing separately": toBracket [ { "Tax rate": 0.37, "Lower bound": 539900.00, "Minimum tax": 162718.00 } , { "Tax rate": 0.35, "Lower bound": 215950.00, "Minimum tax": 49335.50 } , { "Tax rate": 0.32, "Lower bound": 170050.00, "Minimum tax": 34647.50 } , { "Tax rate": 0.24, "Lower bound": 89075.00, "Minimum tax": 15213.50 } , { "Tax rate": 0.22, "Lower bound": 41775.00, "Minimum tax": 4807.50 } , { "Tax rate": 0.12, "Lower bound": 10275.00, "Minimum tax": 1027.50 } , { "Tax rate": 0.10, "Lower bound": 0.00, "Minimum tax": 0.00 } ] , "Head of household": toBracket [ { "Tax rate": 0.37, "Lower bound": 539900.00, "Minimum tax": 161218.50 } , { "Tax rate": 0.35, "Lower bound": 215950.00, "Minimum tax": 47836.00 } , { "Tax rate": 0.32, "Lower bound": 170050.00, "Minimum tax": 33148.00 } , { "Tax rate": 0.24, "Lower bound": 89050.00, "Minimum tax": 13708.00 } , { "Tax rate": 0.22, "Lower bound": 55900.00, "Minimum tax": 6415.00 } , { "Tax rate": 0.12, "Lower bound": 14650.00, "Minimum tax": 1465.00 } , { "Tax rate": 0.10, "Lower bound": 0.00, "Minimum tax": 0.00 } ] } .'Filing status' .'Taxable income' in { "Tax": tax } ================================================ FILE: examples/tools.ffg ================================================ \{ "OpenAI API key" } -> let key = .'OpenAI API key' let concatSep = import github { owner: "Gabriella439" , repository: "grace" , path: "prelude/text/concatSep.ffg" } let call = fold { HttpRequest { url }: "curl ${url}" , ShellCommand { executable, arguments}: concatSep " " ([ executable ] + arguments) } in map call (prompt{ key, text: "Call some tools" }) ================================================ FILE: examples/transform-text.ffg ================================================ \{ "OpenAI API key", passage, code } -> prompt { key: .'OpenAI API key' , text: " Take this passage: ${passage} … and return a new passage whose meaning is transformed by the following code: ${export show code} " } ================================================ FILE: examples/tutorial/coding.ffg ================================================ \arguments -> let key = arguments."OpenAI API key" in # What do you think this code will do? Run it to test your guess: import prompt{ key } : { "Job Description": Text } -> { "Is Finance?": Bool, "Rationale": Text } # You can read the above type as "a function whose input is a record (with a # "Job Description" field) and whose output is a record (with "Is Finance?" and # "Rationale" fields)" # The `import` keyword instructs the model to generate Grace code matching the # expected type. The generated Grace might use the `prompt` keyword, too! ================================================ FILE: examples/tutorial/conclusion.ffg ================================================ # Function arguments and variables can have spaces and punctuation if you quote # them like this (with a leading `.` followed by single quotes): let conclusion{ .'Want to get involved?' } = if .'Want to get involved?' then # Grace supports multiline strings because newline characters are # allowed inside of string literals: " Visit Grace's [GitHub repository](https://github.com/Gabriella439/grace) or follow her [Bluesky profile](https://bsky.app/profile/trygrace.dev). " else "Have fun using the Grace browser!" in conclusion ================================================ FILE: examples/tutorial/data.ffg ================================================ # A record will render as a definition list when converted to HTML { "An example string": "Mercury" , "An example string with a type annotation": "cosmic" : Text , "A boolean value": true , "Annotated boolean value": false : Bool , "A natural number": 42 , "An integer": -12 , "A real number": 3.14159265359 , "A list of natural numbers": [ 1, 1, 2, 3, 5, 8, 13 ] , "Annotated list of natural numbers": [ 1, 1, 2, 3, 5, 8, 13 ] : List Natural , "Annotated record": { x: 0, y: 0 } : { x: Natural, y: Natural } , "A list of records (using JSON syntax with quoted field names)": [ { "isActive": true , "age": 36 , "name": "Dunlap Hubbard" , "email": "dunlaphubbard@example.com" , "phone": "+1 (555) 543-2508" } , { "isActive": true , "age": 24 , "name": "Kirsten Sellers" , "email": "kirstensellers@example.com" , "phone": "+1 (555) 564-2190" } ] } # What type do you think the last field has? Switch to the "Type" tab below # to check your guess, then switch back to the "Form" tab before proceeding to # the next example. ================================================ FILE: examples/tutorial/functions.ffg ================================================ # You can also define functions using `let` expressions: let greet{ name } = "Hello, ${name}!" let greeting = greet{ name: "world" } # You can add optional type annotations to a function's arguments and output: let greet{ name: Text } : Text = "Hello, ${name}!" # The type of the `greet` function is `{ name: Text } -> Text` which you can # read as "a function whose input is a record (with a `name` field) and whose # output is `Text`" # Function definitions can define intermediate variables: let makeUser{ user } = let home = "/home/${user}" let privateKey = "${home}/.ssh/id_ed25519" let publicKey = "${privateKey}.pub" in { home, privateKey, publicKey } # What do you think the type of the `makeUser` function is? Check the "Type" # tab below to check your guess. let users = [ makeUser{ user: "bill" } , makeUser{ user: "jane" } ] # We include the functions we defined (i.e. `greet` and `makeUser`) in the # output because the Grace browser can render functions as interactive forms. # Switch back to the "Form" tab and try entering your name into the generated # interactive forms. in { greet , greeting , makeUser , users } ================================================ FILE: examples/tutorial/hello.ffg ================================================ # This is a tour of the Fall-from-Grace language (a.k.a. "Grace" for short). # # First, any line prefixed with a "#" character is a comment, like this one. # # Second, any change you make to this editable code area will show up below. # Try editing the string "Hello, world!" below to replace "world" with your # name. # # Once you are done, click on the "HTML" tab above to proceed to the next # example. "Hello, world!" ================================================ FILE: examples/tutorial/html.ffg ================================================ # This Grace browser attempts to faithfully render any Grace expression # as an equivalent HTML representation. For example, a list of boolean # values such as these will render as an HTML list of checkboxes: [ true, false, true ] # Try adding another false value to the above list. ================================================ FILE: examples/tutorial/imports.ffg ================================================ { "URL import": # You can import Grace expressions by their URL. For example, the following # URL encodes a function for computing US federal income tax for 2022: https://raw.githubusercontent.com/Gabriella439/grace/refs/heads/main/examples/taxes.ffg , "GitHub import": # Grace also provides built-in support for importing expressions hosted on # GitHub, using the `github` keyword: import github { owner: "Gabriella439" , repository: "grace" , reference: "main" # Optional field which defaults to the trunk branch , path: "examples/taxes.ffg" } , "Short link": " The Grace browser also supports short links for code hosted on GitHub. For example, the short link for the above federal income tax form is: [https://trygrace.dev?github=Gabriella439/grace/examples/taxes.ffg](https://trygrace.dev?github=Gabriella439/grace/examples/taxes.ffg) More generally, the format of GitHub short links is: ``` https://trygrace.dev?github=\${owner}/\${repository}/\${path}[&reference=\${reference}][&private=true] ``` - `&reference=\${reference}` pins the short link to a specific git reference … and defaults to the trunk branch of the repository. - `&private=true` will prompt you for a GitHub personal access token … so that you can import from a private GitHub repository. GitHub code imported in this way is displayed as a \"white-label\" form displaying just the form without the title bar or the code editor. " , "Import Prelude function": # Grace also has a Prelude of utility functions derived from built-in # functions that you can also use. # # You can import functions individually, like this: import github { owner: "Gabriella439" , repository: "grace" , path: "prelude/bool/not.ffg" } , "Import entire Prelude": # You can also import the Prelude as a whole: let prelude = import github { owner: "Gabriella439" , repository: "grace" , path: "prelude/package.ffg" } # … which is a giant nested record with all the utilities nested inside. in prelude.bool.not } # Replace the above `prelude.bool.not` with just `prelude` and see what happens. ================================================ FILE: examples/tutorial/prompting.ffg ================================================ # Grace provides built-in language support for LLMs using the `prompt` function. # To run these examples you will need to provide an OpenAI API key below and. # and then click "Submit". \arguments -> let key = arguments."OpenAI API key" in { # You can prompt a model with `Text`, which will (by default) return `Text`: names: prompt{ key, text: "Give me a list of names" } , # You can request structured output with a type annotation, like this: structuredNames: prompt{ key, text: "Give me a list of names" } : List Text , # If you request a record with first and last name fields then the model will # adjust its output to match: fullNames: prompt{ key, text: "Give me a list of names" } : List { firstName: Text, lastName: Text } , # In fact, that type is descriptive enough that we can just omit the prompt: tacitFullNames: prompt{ key } : List { firstName: Text, lastName: Text } , # By default the `prompt` keyword selects the `gpt-5-mini` model, but you can # specify other models using the `model` argument: differentModel: prompt{ key, model: "gpt-5-nano" } : List { firstName: Text, lastName: Text } } # Try switching to the "Code" tab below to view the code for the result, then # switch back to the "Form" tab and continue to the next example. ================================================ FILE: examples/tutorial/variables.ffg ================================================ # You can define a variable using `let`: let john = { name: "John Doe", age: 24 } # Variables can reference earlier variables: let twentyFour = john.age # You can nest `let` expressions: let nine = let three = 3 in three * three in nine * twentyFour # Grace is whitespace-insensitive (with the exception of comments, which extend # to the next newline character), so try deleting all of the above comments and # modifying the above code to fit on one line. ================================================ FILE: examples/users.ffg ================================================ # Grace version of an example from https://dhall-lang.org/ let makeUser{ user }= let home = "/home/${user}" let privateKey = "${home}/.ssh/id_ed25519" let publicKey = "${privateKey}.pub" in { home, privateKey, publicKey } in [ makeUser{ user: "bill" } , makeUser{ user: "jane" } ] ================================================ FILE: flake.nix ================================================ { inputs = { garnix-lib.url = "github:garnix-io/garnix-lib"; nixpkgs.url = github:NixOS/nixpkgs/24.11; utils.url = github:numtide/flake-utils; }; outputs = { garnix-lib, nixpkgs, utils, self }: let overlay = compiler: self: super: { codemirror = self.fetchzip { url = "https://codemirror.net/5/codemirror.zip"; sha256 = "sha256-TS4JVTRIwdWj/CihELhhC3Rte9DT0Tv239eZKR6MT6w="; }; haskell = super.haskell // { packages = super.haskell.packages // { ghc810 = super.haskell.packages.ghc810.override (old: { overrides = let hlib = self.haskell.lib; oldOverrides = old.overrides or (_: _: {}); in self.lib.composeExtensions oldOverrides (hself: hsuper: { warp = hlib.dontCheck hsuper.warp; }); }); "${compiler}" = super.haskell.packages."${compiler}".override (old: { overrides = let hlib = self.haskell.lib; mass = f: self.lib.fold (name: self.lib.composeExtensions (hself: hsuper: { "${name}" = f hsuper."${name}"; }) ) (_: _: { }); oldOverrides = old.overrides or (_: _: {}); directoryOverrides = hlib.packagesFromDirectory { directory = ./dependencies; }; ghcjsManualOverrides = self.lib.fold self.lib.composeExtensions (_: _: { }) [ (mass hlib.doJailbreak [ "aeson_1_5_6_0" "ghcjs-base" "ghcjs-fetch" "openai" ]) (hself: hsuper: { mkDerivation = args: hsuper.mkDerivation (args // { doCheck = false; doHaddock = false; }); aeson = hself.aeson_1_5_6_0; entropy = hlib.addBuildDepends hsuper.entropy [ hself.ghcjs-dom hself.jsaddle ]; exceptions = hself.exceptions_0_10_8; grace = hself.grace-ghcjs; ghcjs-fetch = hlib.addBuildDepends hsuper.ghcjs-fetch [ hself.ghcjs-base ]; # haskeline = hself.haskeline_0_8_2; network = hsuper.network.overrideAttrs (old: { dontUpdateAutotoolsGnuConfigScripts = true; }); servant-multipart-client = hlib.overrideCabal (hsuper.servant-multipart-client.override (old: { servant-multipart = null; servant-server = null; warp = null; })) (old: { buildDepends = (old.buildDepends or []) ++ [ hself.servant hself.servant-client ]; postPatch = (old.postPatch or "") + '' sed -i -e 's/servant .*<0.19/servant/' -e 's/servant-client-core .*<0.19/servant-client-core/' servant-multipart-client.cabal ''; }); }) ]; ghcjsSourceOverrides = hlib.packageSourceOverrides { modern-uri = "0.3.4.4"; unordered-containers = "0.2.18.0"; }; manualOverrides = hself: hsuper: { grace = hlib.justStaticExecutables (hlib.overrideCabal hsuper.grace (old: { doCheck = false; src = self.lib.cleanSourceWith { inherit (old) src; filter = path: type: self.lib.cleanSourceFilter path type && ! ( ( type == "regular" && ( self.lib.hasSuffix ".nix" (baseNameOf path) || self.lib.hasSuffix ".md" (baseNameOf path) || self.lib.hasSuffix ".yaml" (baseNameOf path) || baseNameOf path == "cabal.project.local" ) ) || ( type == "directory" && (builtins.elem (baseNameOf path) [ "dist" "dist-newstyle" "examples" "prelude" "website" ]) ) ); }; })); openai = hlib.dontCheck hsuper.openai; }; in self.lib.fold self.lib.composeExtensions oldOverrides ( [ directoryOverrides ] ++ self.lib.optional (compiler == "ghcjs") ghcjsSourceOverrides ++ self.lib.optional (compiler == "ghcjs") ghcjsManualOverrides ++ [ manualOverrides ] ); }); }; }; haskell-language-server = super.haskell-language-server.override (old: { haskellPackages = super.haskell.packages."${compiler}"; supportedGhcVersions = [ "96" ]; }); docker-stream = let configuration = self.writeText "nginx.conf" '' events { } error_log /dev/stderr; http { access_log /dev/stdout; include ${self.nginx}/conf/mime.types; default_type application/octet-stream; server { listen 8080; root ${self.website}; index index.html; add_header X-Content-Type-Options nosniff; add_header X-Frame-Options SAMEORIGIN; gzip on; gzip_types application/javascript; location ~ \.js$ { add_header Cache-Control "public, max-age=31536000, immutable"; } } } daemon off; ''; args = { name = "grace"; tag = "latest"; config = { Cmd = [ (self.lib.getExe self.nginx) "-c" configuration ]; User = "65534:65534"; }; enableFakechroot = true; fakeRootCommands = '' paths=( /var/cache/nginx/{client_body,proxy,fastcgi,uwsgi,scgi} /var/log/nginx ) mkdir -p "''${paths[@]}" chown -R 65534:65534 "''${paths[@]}" ''; }; in self.dockerTools.streamLayeredImage (args // { passthru = { inherit args; }; }); docker-image = self.dockerTools.buildLayeredImage self.docker-stream.passthru.args; website = self.runCommand "try-grace" { nativeBuildInputs = [ self.rsync ]; } '' js=js/''${out:11:32} mkdir -p $out/{css,prelude,prompts,examples} $out/$js rsync --recursive ${./website}/ $out rsync --recursive ${./prelude}/ $out/prelude rsync --recursive ${./prompts}/ $out/prompts rsync --recursive ${./examples}/ $out/examples cp ${self.codemirror}/lib/codemirror.css --target-directory=$out/css cp ${self.codemirror}/lib/codemirror.js --target-directory=$out/$js cp ${self.codemirror}/addon/display/placeholder.js --target-directory=$out/$js cp ${self.codemirror}/mode/python/python.js --target-directory=$out/$js cp ${self.haskell.packages."${compiler}".grace}/bin/try-grace.jsexe/all.js --target-directory=$out/$js sed --in-place 's!src="js/!src="'"$js"'/!g' $out/index.html ''; }; in utils.lib.eachDefaultSystem (system: let withCompiler = compiler: let config.allowBroken = true; pkgs = import nixpkgs { inherit config system; overlays = [ (overlay compiler) ]; }; grace = pkgs.haskell.packages."${compiler}".grace; shell = pkgs.haskell.packages."${compiler}".shellFor { packages = hpkgs: [ (pkgs.haskell.lib.doCheck hpkgs.grace) ]; nativeBuildInputs = [ pkgs.haskell-language-server ]; withHoogle = true; doBenchmark = true; }; in { inherit grace shell; inherit (pkgs) docker-image docker-stream website; }; ghc = withCompiler "ghc96"; ghcjs = withCompiler "ghcjs"; in { packages = { default = ghc.grace; docker-image = ghcjs.docker-image; docker-stream = ghcjs.docker-stream; website = ghcjs.website; }; apps = { default = { type = "app"; program = nixpkgs.lib.getExe self.packages."${system}".default; }; docker-stream = { type = "app"; program = "${self.packages."${system}".docker-stream}"; }; }; devShells = { default = ghc.shell; ghcjs = ghcjs.grace.env; }; }) // { overlays = nixpkgs.lib.genAttrs [ "ghc96" "ghcjs" ] overlay; nixosConfigurations = let defaultModule = { pkgs, ... }: { documentation.nixos.enable = false; networking = { firewall.allowedTCPPorts = [ 80 443 ]; hostName = "trygrace"; }; nix.settings.trusted-users = [ "gabriella" ]; nixpkgs = { config.allowBroken = true; overlays = [ self.overlays.ghcjs ]; }; security = { acme = { acceptTerms = true; email = "GenuineGabriella@gmail.com"; }; sudo.wheelNeedsPassword = false; }; services = { nginx = { enable = true; recommendedGzipSettings = true; recommendedOptimisation = true; recommendedTlsSettings = true; recommendedProxySettings = true; virtualHosts = { "trygrace.dev" = { default = true; forceSSL = true; enableACME = true; locations."/" = { index = "index.html"; root = pkgs.website; }; }; }; }; openssh.enable = true; }; system.stateVersion = "22.05"; time.timeZone = "America/Los_Angeles"; users = { mutableUsers = false; users.gabriella = { isNormalUser = true; extraGroups = [ "wheel" ]; openssh.authorizedKeys.keys = [ "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIMuH6HDuoMlK7b2Ovm5VKt9P3aRrJ2HeUPptKG+21kjL gabriella@Gabriellas-MacBook-Pro.local" "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIC/nXKUEQsKukm+eIKmwzWoybKzwQTiYzGZqrWmHYwYe gabriella@lucina.local" ]; }; }; }; qemuModule = { modulesPath, ... }: { imports = [ "${modulesPath}/virtualisation/qemu-vm.nix" ]; config.virtualisation.host.pkgs = import nixpkgs { system = "aarch64-darwin"; config.allowBroken = true; overlays = [ self.overlays.ghcjs ]; }; }; garnixModule = { imports = [ garnix-lib.nixosModules.garnix ]; config.garnix.server = { enable = true; persistence = { enable = true; name = "main"; }; }; }; garnix = nixpkgs.lib.nixosSystem { system = "x86_64-linux"; modules = [ defaultModule garnixModule ]; }; qemu = nixpkgs.lib.nixosSystem { system = "x86_64-linux"; modules = [ defaultModule qemuModule ]; }; in { default = garnix; inherit garnix qemu; }; }; nixConfig = { extra-substituters = [ "https://cache.garnix.io" ]; extra-trusted-public-keys = [ "cache.garnix.io:CTFPyKSLcx5RMJKfLo5EEPUObbA78b0YQ2DTCJXqr9g=" ]; }; } ================================================ FILE: garnix.yaml ================================================ builds: exclude: [] include: - packages.aarch64-darwin.default - packages.x86_64-linux.default - packages.aarch64-linux.default - packages.x86_64-linux.docker-image - packages.x86_64-linux.docker-stream - devShells.aarch64-darwin.default - devShells.x86_64-linux.default - devShells.aarch64-linux.default - packages.x86_64-linux.website - packages.aarch64-linux.website - packages.aarch64-darwin.website - apps.aarch64-darwin.default - apps.x86_64-linux.default - apps.aarch64-linux.default - nixosConfigurations.default servers: - configuration: default deployment: type: on-branch branch: main ================================================ FILE: ghc/Grace/DataFile.hs ================================================ {-| This module provides a uniform interface for accessing data files using both GHC and GHCJS -} module Grace.DataFile ( readDataFile ) where import Data.Text (Text) import qualified Paths_grace as Paths import qualified Data.Text.IO as Text.IO -- | Read a data file by its relative path readDataFile :: FilePath -> IO Text readDataFile relativePath = do absolutePath <- Paths.getDataFileName relativePath Text.IO.readFile absolutePath ================================================ FILE: ghc/Grace/HTTP.hs ================================================ {-| This module provides a uniform interface for making HTTP requests using both GHC and GHCJS -} module Grace.HTTP ( HttpException , fetch , HTTP(..) , Header(..) , Parameter(..) , http , renderError , Methods , getMethods , Grace.HTTP.createChatCompletion ) where import Control.Concurrent.MVar (MVar) import Control.Exception.Safe (Exception(..), Handler(..)) import Data.Text (Text) import Data.Text.Encoding.Error (UnicodeException) import OpenAI.V1 (Methods(..)) import OpenAI.V1.Chat.Completions (ChatCompletionObject, CreateChatCompletion) import Servant.Client.Core.ClientError (ClientError(..)) import Servant.Client.Core.Response (ResponseF(..)) import Grace.HTTP.Type ( Header(..) , HTTP(..) , Parameter(..) , completeHeaders , organization , renderQueryText ) import Network.HTTP.Client ( HttpExceptionContent(..) , Manager , ManagerSettings(..) , Request(..) , RequestBody(..) , method ) import qualified Control.Concurrent.MVar as MVar import qualified Control.Exception.Safe as Exception import qualified Control.Retry as Retry import qualified Data.Aeson as Aeson import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Encoding as Lazy.Encoding import qualified Network.HTTP.Types.Status as Status import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as TLS import qualified Network.HTTP.Types as HTTP.Types import qualified OpenAI.V1 as OpenAI import qualified Servant.Client as Client import qualified System.IO.Unsafe as Unsafe -- | Exception type thrown by `fetch` in the event of any failure data HttpException = HttpException HTTP.HttpException | NotUTF8 UnicodeException deriving stock (Show) instance Exception HttpException where displayException = Text.unpack . renderError managerMVar :: MVar (Maybe Manager) managerMVar = Unsafe.unsafePerformIO (MVar.newMVar Nothing) {-# NOINLINE managerMVar #-} retry :: IO a -> IO a retry io = Retry.recovering retryPolicy [ \_ -> Handler handler ] (\_ -> io) where retryPolicy = Retry.fullJitterBackoff 1000000 <> Retry.limitRetries 3 handler (FailureResponse _ Response{ responseStatusCode }) = return (Status.statusIsServerError responseStatusCode) handler (ConnectionError _) = return True handler _ = return False -- | Acquire a new `Manager` -- -- This is safe to call multiple times. The `Manager` returned by the first -- call is cached and reused by subsequent calls. newManager :: IO Manager newManager = MVar.modifyMVar managerMVar \maybeManager -> do manager <- case maybeManager of Nothing -> do TLS.newTlsManagerWith TLS.tlsManagerSettings { managerResponseTimeout = HTTP.responseTimeoutNone , managerRetryableException = \exception -> case Exception.fromException exception of Just (FailureResponse _ Response{ responseStatusCode }) -> Status.statusIsServerError responseStatusCode Just (ConnectionError _) -> True _ -> False } Just manager -> do return manager return (Just manager, manager) -- | Fetch a URL (using the @http-client@ package) fetch :: Text -- ^ URL -> IO Text -- ^ Response body fetch url = do manager <- newManager request <- HTTP.parseUrlThrow (Text.unpack url) let handler :: HTTP.HttpException -> IO a handler httpException = Exception.throwIO (HttpException httpException) response <- Exception.handle handler (HTTP.httpLbs request manager) let lazyBytes = HTTP.responseBody response case Lazy.Encoding.decodeUtf8' lazyBytes of Left exception -> Exception.throwIO (NotUTF8 exception) Right lazyText -> return (Text.Lazy.toStrict lazyText) -- | Make a HTTP request http :: Bool -> HTTP -> IO Text http import_ GET{ url, headers, parameters } = do manager <- newManager renderedURL <- renderQueryText url parameters request₀ <- HTTP.parseUrlThrow (Text.unpack renderedURL) let request₁ = request₀ { method = HTTP.Types.methodGet , requestHeaders = completeHeaders import_ False headers } let handler :: HTTP.HttpException -> IO a handler httpException = Exception.throwIO (HttpException httpException) response <- Exception.handle handler (HTTP.httpLbs request₁ manager) case Lazy.Encoding.decodeUtf8' (HTTP.responseBody response) of Left exception -> Exception.throwIO (NotUTF8 exception) Right lazyText -> return (Text.Lazy.toStrict lazyText) http import_ POST{ url, headers, request } = do manager <- newManager request₀ <- HTTP.parseUrlThrow (Text.unpack url) let request₁ = request₀ { method = HTTP.Types.methodPost , requestHeaders = completeHeaders import_ body headers } where body = case request of Nothing -> False Just _ -> True let request₂ = case request of Nothing -> request₁ Just requestBody -> request₁{ requestBody = RequestBodyLBS (Aeson.encode requestBody) } let handler :: HTTP.HttpException -> IO a handler httpException = Exception.throwIO (HttpException httpException) response <- Exception.handle handler (HTTP.httpLbs request₂ manager) case Lazy.Encoding.decodeUtf8' (HTTP.responseBody response) of Left exception -> Exception.throwIO (NotUTF8 exception) Right lazyText -> return (Text.Lazy.toStrict lazyText) -- | Render an `HttpException` as `Data.Text.Text` renderError :: HttpException -> Text renderError (HttpException httpException) = case httpException of HTTP.InvalidUrlException _ _ -> "Invalid URL" HTTP.HttpExceptionRequest _ e -> case e of ConnectionFailure _ -> "Remote host not found" InvalidDestinationHost _ -> "Invalid remote host name" ResponseTimeout -> "The remote host took too long to respond" ConnectionTimeout -> "Connection establishment took too long" StatusCodeException response body -> prefix <> suffix where statusCode = HTTP.Types.statusCode (HTTP.responseStatus response) prefix = case statusCode of 401 -> "Access unauthorized" 403 -> "Access forbidden" 404 -> "Remote file not found" 500 -> "Server-side failure" 502 -> "Upstream failure" 503 -> "Server temporarily unavailable" 504 -> "Upstream timeout" _ -> "HTTP request failure" suffix = "\n\ \\n\ \HTTP status code: " <> Text.pack (show statusCode) <> responseBody responseBody :: Text responseBody = case Encoding.decodeUtf8' body of Left _ -> "\n\ \\n\ \Response body (non-UTF8 bytes):\n\ \\n\ \" <> Text.pack (show body) Right "" -> "" Right bodyText -> "\n\n" <> "Response body:\n\ \\n\ \" <> prefixedText where prefixedLines = zipWith combine prefixes (Text.lines bodyText) <> [ "…│ …" ] where prefixes = [(1 :: Int)..7] combine n line = Text.pack (show n) <> "│ " <> line prefixedText = Text.unlines prefixedLines _ -> "HTTP request failure\n\ \\n\ \" <> Text.pack (displayException httpException) renderError (NotUTF8 unicodeException) = "Not UTF8\n\ \\n\ \" <> Text.pack (displayException unicodeException) -- | Initialize API for prompting getMethods :: IO (Text -> Methods) getMethods = do baseUrl <- Client.parseBaseUrl "https://api.openai.com" manager <- newManager let clientEnv = Client.mkClientEnv manager baseUrl return (\key -> OpenAI.makeMethods clientEnv key organization Nothing) -- | This powers the @prompt@ keyword createChatCompletion :: Methods -> CreateChatCompletion -> IO ChatCompletionObject createChatCompletion Methods{ createChatCompletion = c } x = retry (c x) ================================================ FILE: ghc/Grace/Width.hs ================================================ {-| This module provides a uniform interface for getting the console width using both GHC and GHCJS -} module Grace.Width ( -- * Width getWidth , defaultWidth ) where import System.Console.Terminal.Size (Window(..)) import qualified System.Console.Terminal.Size as Size -- | Get the width of the terminal (in columns) getWidth :: IO Int getWidth = do maybeWindow <- Size.size let renderWidth = case maybeWindow of Nothing -> defaultWidth Just Window{ width } -> width return renderWidth -- | The default width to use defaultWidth :: Int defaultWidth = 80 ================================================ FILE: ghcjs/Grace/DataFile.hs ================================================ {-| This module provides a uniform interface for accessing data files using both GHC and GHCJS -} module Grace.DataFile ( readDataFile ) where import Data.Text (Text) import qualified Data.Text as Text import qualified Grace.HTTP as HTTP -- | Read a data file by its relative path readDataFile :: FilePath -> IO Text readDataFile relativePath = do HTTP.fetch (Text.pack relativePath) ================================================ FILE: ghcjs/Grace/HTTP.hs ================================================ {-| This module provides a uniform interface for making HTTP requests using both GHC and GHCJS -} module Grace.HTTP ( HttpException , fetch , HTTP(..) , Header(..) , Parameter(..) , http , renderError , Methods , getMethods , createChatCompletion ) where import Control.Exception.Safe (Exception(..)) import Data.Text (Text) import GHCJS.Fetch.Types (JSResponse) import OpenAI.V1.Chat.Completions (ChatCompletionObject, CreateChatCompletion) import Grace.HTTP.Type ( Header(..) , HTTP(..) , Parameter(..) , completeHeaders , organization , renderQueryText ) import GHCJS.Fetch ( Request(..) , RequestCacheMode(..) , RequestOptions(..) , JSPromiseException ) import qualified Control.Exception.Safe as Exception import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as ByteString.Lazy import qualified Data.JSString as JSString import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified GHCJS.Fetch as Fetch import qualified GHCJS.Prim as Prim import qualified Network.HTTP.Types as HTTP.Types -- | An `HttpException` is just a type synonym for a `JSPromiseException` type HttpException = JSPromiseException -- | Fetch a URL (using @XMLHttpRequest@) fetch :: Text -- ^ URL -> IO Text -- ^ Response body fetch url = do let request = Request { reqUrl = JSString.pack (Text.unpack url) , reqOptions = Fetch.defaultRequestOptions { reqOptMethod = HTTP.Types.methodGet , reqOptCacheMode = NoStore } } response <- Fetch.fetch request jsString <- Fetch.responseText response return (Text.pack (JSString.unpack jsString)) responseToText :: JSResponse -> IO Text responseToText response = do jsString <- Fetch.responseText response return (Text.pack (JSString.unpack jsString)) -- | Make an HTTP request http :: Bool -> HTTP -> IO Text http import_ GET{ url, headers, parameters } = do newURL <- renderQueryText url parameters let reqUrl = JSString.pack (Text.unpack newURL) let reqOptions = Fetch.defaultRequestOptions { reqOptHeaders = completeHeaders import_ False headers , reqOptMethod = HTTP.Types.methodGet , reqOptCacheMode = NoStore } let request = Request{ reqUrl, reqOptions } response <- Fetch.fetch request responseToText response http import_ POST{ url, headers, request } = do newURL <- renderQueryText url Nothing let reqUrl = JSString.pack (Text.unpack newURL) let reqOptions₀ = Fetch.defaultRequestOptions { reqOptHeaders = completeHeaders import_ body headers , reqOptMethod = HTTP.Types.methodPost , reqOptCacheMode = NoStore } where body = case request of Nothing -> False Just _ -> True reqOptions <- case request of Nothing -> do return reqOptions₀ Just requestBody -> do requestText <- case Encoding.decodeUtf8' (ByteString.Lazy.toStrict (Aeson.encode requestBody)) of Left exception -> Exception.throwIO exception Right text -> return text let reqOptBody = Just (Prim.toJSString (Text.unpack requestText)) return reqOptions₀{ reqOptBody } response <- Fetch.fetch Request{ reqUrl, reqOptions } responseToText response -- | Render an `HttpException` as `Data.Text.Text` renderError :: HttpException -> Text renderError = Text.pack . displayException -- | The GHCJS implementation of OpenAI bindings just stores the API key type Methods = Text -- | Initialize API for prompting getMethods :: IO (Text -> Methods) getMethods = return id -- | This powers the @prompt@ keyword createChatCompletion :: Methods -> CreateChatCompletion -> IO ChatCompletionObject createChatCompletion key createChatCompletion_ = do let keyBytes = Encoding.encodeUtf8 key body <- case Encoding.decodeUtf8' (ByteString.Lazy.toStrict (Aeson.encode createChatCompletion_)) of Left exception -> Exception.throwIO exception Right text -> return (Text.unpack text) let organizationHeader = case organization of Nothing -> [] Just o -> [("OpenAI-Organization", Encoding.encodeUtf8 o)] let request = Request { reqUrl = "https://api.openai.com/v1/chat/completions" , reqOptions = Fetch.defaultRequestOptions { reqOptMethod = "POST" , reqOptHeaders = [ ("Content-Type", "application/json") , ("Authorization", "Bearer " <> keyBytes) ] <> organizationHeader , reqOptBody = Just (Prim.toJSString body) , reqOptCacheMode = NoStore } } response <- Fetch.fetch request jsString <- Fetch.responseText response let strictBytes = Encoding.encodeUtf8 (Text.pack (JSString.unpack jsString)) let lazyBytes = ByteString.Lazy.fromStrict strictBytes case Aeson.eitherDecode lazyBytes of Left string -> fail string Right chatCompletionObject -> return chatCompletionObject ================================================ FILE: ghcjs/Grace/Size.hs ================================================ module Grace.Width ( -- * Width getWidth ) where -- | Get the width of the terminal (in columns) getWidth :: IO Int getWidth = pure 80 ================================================ FILE: ghcjs/Grace/Width.hs ================================================ {-| This module provides a uniform interface for getting the console width using both GHC and GHCJS -} module Grace.Width ( -- * Width getWidth , defaultWidth ) where -- | Get the width of the terminal (in columns) getWidth :: IO Int getWidth = pure defaultWidth -- | The default column size to use defaultWidth :: Int defaultWidth = 80 ================================================ FILE: grace/Main.hs ================================================ module Main where import qualified Grace main :: IO () main = Grace.main ================================================ FILE: grace.cabal ================================================ cabal-version: >=1.10 name: grace version: 1.0.0 license-file: LICENSE author: Gabriella Gonzalez maintainer: Gabriel439@gmail.com build-type: Simple extra-source-files: examples/*.ffg examples/tutorial/*.ffg prompts/*.md prelude/bool/*.ffg prelude/integer/*.ffg prelude/list/*.ffg prelude/natural/*.ffg prelude/package.ffg prelude/real/*.ffg prelude/text/*.ffg library hs-source-dirs: src build-depends: base , Earley , aeson , aeson-pretty , aeson-yaml , async , binary , bytestring , containers , case-insensitive , directory , exceptions , filepath , generic-lens , http-types , insert-ordered-containers , lens , megaparsec , modern-uri , mmorph , mtl , openai , parser-combinators , prettyprinter , prettyprinter-ansi-terminal , safe-exceptions , scientific , template-haskell , text >= 1.2.4.0 , time , unordered-containers , vector exposed-modules: Grace.Aeson , Grace.Context , Grace.DataFile , Grace.Decode , Grace.Domain , Grace.Encode , Grace.Existential , Grace.GitHub , Grace.HTTP , Grace.Import , Grace.Infer , Grace.Input , Grace.Interpret , Grace.Label , Grace.Location , Grace.Monad , Grace.Monotype , Grace.Normalize , Grace.Parallelizable , Grace.Parser , Grace.Pretty , Grace.Prompt , Grace.Prompt.Types , Grace.Syntax , Grace.Type , Grace.Value , Grace.Width other-modules: Grace.Compat , Grace.HTTP.Type , Grace.Marshal , Paths_grace default-extensions: ApplicativeDo , BangPatterns , BlockArguments , DataKinds , DefaultSignatures , DeriveAnyClass , DeriveFoldable , DeriveFunctor , DeriveGeneric , DeriveLift , DeriveTraversable , DerivingStrategies , DuplicateRecordFields , FlexibleContexts , FlexibleInstances , GeneralizedNewtypeDeriving , KindSignatures , MultiParamTypeClasses , MultiWayIf , NamedFieldPuns , OverloadedStrings , ScopedTypeVariables , StandaloneDeriving , TypeApplications , TypeOperators , UndecidableInstances , ViewPatterns default-language: Haskell2010 ghc-options: -Wall -Wmissing-deriving-strategies if impl(ghcjs) || os(ghcjs) hs-source-dirs: ghcjs build-depends: ghcjs-base , ghcjs-fetch , ghcjs-prim else hs-source-dirs: ghc build-depends: ansi-terminal , haskeline , http-client , http-client-tls , optparse-applicative , repline , retry , servant-client-core , servant-client , terminal-size exposed-modules: Grace , Grace.REPL , Grace.TH executable grace main-is: Main.hs build-depends: base , grace hs-source-dirs: grace default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N if impl(ghcjs) || os(ghcjs) buildable: False executable try-grace main-is: Main.hs build-depends: base , aeson , async , containers , filepath , ghcjs-base , grace , insert-ordered-containers , lens , mmorph , mtl , safe-exceptions , scientific , stm , text , transformers , uri-encode hs-source-dirs: try-grace ghc-options: -Wall default-language: Haskell2010 if !(impl(ghcjs) || os(ghcjs)) buildable: False test-suite tasty type: exitcode-stdio-1.0 main-is: Main.hs build-depends: base , aeson , containers , directory , filepath , grace , mtl , prettyprinter , safe-exceptions , scientific , tasty , tasty-hunit , tasty-silver , text , vector hs-source-dirs: tasty default-language: Haskell2010 ghc-options: -Wall test-suite doctest type: exitcode-stdio-1.0 main-is: Main.hs build-depends: base , doctest hs-source-dirs: doctest default-language: Haskell2010 ghc-options: -Wall ================================================ FILE: prelude/bool/and.ffg ================================================ # Returns `true` if there are no `false`s in the input `List` and `false` # otherwise let and : List Bool -> Bool = fold { cons: \x -> \y -> x && y, nil: true } in and ================================================ FILE: prelude/bool/not.ffg ================================================ # Negate a `Bool` let not (b : Bool) : Bool = b == false in not ================================================ FILE: prelude/bool/or.ffg ================================================ # Returns `false` if there are no `true`s in the input `List` and `true` # otherwise let or : List Bool -> Bool = fold { cons: \x -> \y -> x || y, nil: false } in or ================================================ FILE: prelude/bool/package.ffg ================================================ { and: ./and.ffg , not: ./not.ffg , or: ./or.ffg } ================================================ FILE: prelude/integer/clamp.ffg ================================================ # Convert an `Integer` to a `Natural` number, clamping negative values to `0` let clamp (n : Integer) : Natural = if n < 0 then 0 else abs n in clamp ================================================ FILE: prelude/integer/package.ffg ================================================ { clamp: ./clamp.ffg , product: ./product.ffg , sum: ./sum.ffg , toNatural: ./toNatural.ffg } ================================================ FILE: prelude/integer/product.ffg ================================================ # Multiply the elements of a list let product : List Integer -> Integer = fold { cons: \x y -> x * y : Integer, nil: 1 : Integer } in product ================================================ FILE: prelude/integer/sum.ffg ================================================ # Add up the elements of a list let sum : List Integer -> Integer = fold { cons: \x y -> x + y : Integer, nil: 0 : Integer } in sum ================================================ FILE: prelude/integer/toNatural.ffg ================================================ # Convert an `Integer` to a `Natural` number, returning `null` if the `Natural` # number is negative let toNatural (n : Integer) : Optional Natural = if n < 0 then null else abs n in toNatural ================================================ FILE: prelude/list/all.ffg ================================================ # Check if all elements satisfy the given predicate let all : forall (a : Type) . (a -> Bool) -> List a -> Bool = \predicate -> fold { cons: \element -> \result -> predicate element && result , nil: true } in all ================================================ FILE: prelude/list/any.ffg ================================================ # Check if any elements satisfy the given predicate let any : forall (a : Type) . (a -> Bool) -> List a -> Bool = \predicate -> fold { cons: \element -> \result -> predicate element || result , nil: false } in any ================================================ FILE: prelude/list/concat.ffg ================================================ let concat : forall (a : Type) . List (List a) -> List a = \lists -> for list of lists for element of list in element in concat ================================================ FILE: prelude/list/generate.ffg ================================================ # Build a `List` by calling the supplied function on all `Natural` numbers from # `0` up to but not including the supplied `Natural` number let replicate = ./replicate.ffg let generate : forall (a : Type) . Natural -> (Natural -> a) -> List a = \n -> \f -> map (\x -> f x.index) (indexed (replicate n { })) in generate ================================================ FILE: prelude/list/null.ffg ================================================ # Returns `true` if the `List` is empty and `false` otherwise let null_ : forall (a : Type) . List a -> Bool = \xs -> length xs == 0 in null_ ================================================ FILE: prelude/list/package.ffg ================================================ { all: ./all.ffg , any: ./any.ffg , concat: ./concat.ffg , generate: ./generate.ffg , null: ./null.ffg , reject: ./reject.ffg , replicate: ./replicate.ffg , select: ./select.ffg } ================================================ FILE: prelude/list/reject.ffg ================================================ # Only keep elements of the list where the supplied functions returns `false` let reject : forall (a : Type) . (a -> Bool) -> List a -> List a = \f -> fold { "cons": \x -> \xs -> if f x then xs else [ x ] + xs, "nil": [ ] } in reject ================================================ FILE: prelude/list/replicate.ffg ================================================ # Create a `List` from `n` copies of an element let replicate : forall (a : Type) . Natural -> a -> List a = \n x -> fold { succ: \xs -> [ x ] + xs, zero: [] } n in replicate ================================================ FILE: prelude/list/select.ffg ================================================ # Only keep elements of the list where the supplied functions returns `true` let select : forall (a : Type) . (a -> Bool) -> List a -> List a = \f -> fold { "cons": \x -> \xs -> if f x then [ x ] + xs else xs, "nil": [ ] } in select ================================================ FILE: prelude/natural/package.ffg ================================================ { product: ./product.ffg , sum: ./sum.ffg } ================================================ FILE: prelude/natural/product.ffg ================================================ # Multiply the elements of a list let product : List Natural -> Natural = fold { cons: \x y -> x * y : Natural, nil: 1 : Natural } in product ================================================ FILE: prelude/natural/sum.ffg ================================================ # Add up the elements of a list let sum : List Natural -> Natural = fold { cons: \x y -> x + y : Natural, nil: 0 : Natural } in sum ================================================ FILE: prelude/package.ffg ================================================ { bool: ./bool/package.ffg , real: ./real/package.ffg , integer: ./integer/package.ffg , list: ./list/package.ffg , natural: ./natural/package.ffg , text: ./text/package.ffg } ================================================ FILE: prelude/real/package.ffg ================================================ { product: ./product.ffg , sum: ./sum.ffg } ================================================ FILE: prelude/real/product.ffg ================================================ # Multiply the elements of a list let product : List Real -> Real = fold { cons: \x y -> x * y : Real, nil: 1 : Real } in product ================================================ FILE: prelude/real/sum.ffg ================================================ # Add up the elements of a list let sum : List Real -> Real = fold { cons: \x y -> x + y : Real, nil: 0 : Real } in sum ================================================ FILE: prelude/text/concat.ffg ================================================ # Concatenate a `List` of `Text` let concat : List Text -> Text = fold { cons: \x -> \y -> (x + y) : Text, nil: "" } in concat ================================================ FILE: prelude/text/concatMap.ffg ================================================ # Transform each value in a `List` into `Text` and concatenate the result let concatMap : forall (a : Type) . (a -> Text) -> List a -> Text = \f -> fold { cons: \x -> \y -> f x + y, nil: "" } in concatMap ================================================ FILE: prelude/text/concatMapSep.ffg ================================================ # Concatenate a `List` of `Text` values with a separator in between each value let concatSep = ./concatSep.ffg let concatMapSep : forall (a : Type) . Text -> (a -> Text) -> List a -> Text = \separator -> \f -> \xs -> concatSep separator (map f xs) in concatMapSep ================================================ FILE: prelude/text/concatSep.ffg ================================================ # Concatenate a `List` of `Text` values with a separator in between each value let concatSep (separator : Text) (xs : List Text) : Text = let status = fold { "cons": \element -> fold { "null": some element , "some": \result -> some (element + separator + result) } , "nil": null } xs in fold { "null": "", "some": \result -> result } status in concatSep ================================================ FILE: prelude/text/package.ffg ================================================ { concat: ./concat.ffg , concatMap: ./concatMap.ffg , concatMapSep: ./concatMapSep.ffg , concatSep: ./concatSep.ffg } ================================================ FILE: prompts/abnf.md ================================================ Here's the grammar for Grace if you're not exactly sure what the language does and does not permit so that you don't run into trivial syntax errors: ``` expression = lambda / let / if / annotation ; Everything else (operators, projections, literals, etc.) identifier ; Naked variable names begin with a lowercase letter or "_" ; ; Examples: `x`, `name`, `toLicense` = (LOWER / "_") *(ALPHANUM / "_" / "-" / "/") ; Quoted variable names begin with `.` and are surrounded with single quotes ; ; Examples: `.'Rationale'`, `.'Section Header'`, `.'Website - Backend'` / "." single-quoted lambda = "\" 1*binding "->" expression ; A bound variable with an optional type annotation and optional default value name-binding = identifier [ ":" type ] [ "=" expression ] ; One or more names bound as arguments for a lambda or named functions binding ; Plain bound variable: ; ; \x -> … ; ; let f x = … in … ; ; let greet .'Name' = "Hi, ${.'Name'}!" in greet "Alice" ; = identifier ; Bound variable with an optional type annotation and optional default value: ; ; \(x : T = v) -> … ; ; let f (x : T = v) = … in … ; ; let greet (.'Name' : Text = "Alice") = "Hi, ${.'Name'}!" in greet null ; ; You can have just the type annotation: ; ; \(x : T) -> … ; ; let f (x : T) = … in … ; ; … or just the default value: ; ; \(x = v) -> … ; ; let f (x = v) = … in … ; ; let greet (.'Name' : Text) = "Hi, ${.'Name'}!" in greet "Alice" ; ; You can even omit both and just parenthesize the bound variable, although ; this is not idiomatic since you'd usually omit the parentheses in that case: ; ; \(x) -> … ; ; let f (x) = … in … ; ; let greet (.'Name') = "Hi, ${.'Name'}!" in greet "Alice" ; / "(" name-binding ")" ; Destructure a record function argument: ; ; \{ a, b } -> … ; ; let f{ a, b } = … in … ; ; let greet{ "Name" } = "Hi, ${.'Name'}!" in greet{ "Name": "Alice" } ; ; let greet{ .'Name' } = "Hi, ${.'Name'}!" in greet{ "Name": "Alice" } ; ; Record fields destructured in this way can have optional type annotations ; and optional default values: ; ; \{ a, b : T0, c = v0, d : T1 = v1 } -> … ; ; let f { a, b : T0, c = v0, d : T1 = v1 } = … in … ; ; let greet{ "Name" : Text = "Alice" } = "Hi, ${.'Name'}!" in greet{ } ; ; let greet{ .'Name' : Text = "Alice" } = "Hi, ${.'Name'}!" in greet{ } / "{" [ name-binding *( "," name-binding ) ] "}" ; Note: Every sequence of `let`s (even top-level `let`s) must have a matching ; `in`. Dangling `let`s are a parse error in any context. ; ; BAD: ; ; let x = 2 ; let y = 3 # Missing `in` at the end, which is a syntax error ; ; GOOD: ; ; let x = 2 ; let y = 3 ; in { x, y } # To "export" let bindings, package them in a record let = 1*assignment "in" expression ; Every assignment must begin with a `let` because Grace is not ; whitespace-sensitive. ; ; BAD: ; ; let x = 2 ; y = 3 # Missing `let`, so this is misparsed as `let x = 2 y = 3` ; in x + y ; ; GOOD: ; ; let x = 2 ; let y = 3 ; in x + y assignment = ; Define a simple value: ; ; let x = 2 in x + 1 ; ; … or a function of one or more arguments: ; ; let increment x = x + 1 in increment 2 ; ; Function definitions can destructure their arguments and this is the most ; idiomatic way to define functions in Grace: ; ; let greet{ name } = "Hi, ${name}!" in greet{ name: "Alice" } = ("let" identifier *binding [ ":" type ] "=" expression) ; Destructure the right-hand side: ; ; let { x, y } = { x: 1, y: 2 } in x + y / ("let" binding "=" expression) ; For comprehension (like a list comprehension, but works on both `List`s ; and `Optional`s) ; ; for x of [ 1, 2 ] ; for y of [ false, true ] ; in { x, y } ; ; = [ {x: 1, y: false } ; , {x: 1, y: true } ; , {x: 2, y: false } ; , {x: 2, y: true } ; ] / ("for" binding "of" expression) if = "if" expression "then" expression "else" expression ; Optional type annotation: ; ; e : T annotation = application *( operator application ) [ ":" type ] ; Operators in descending order of precedence ; ; This is the same precedence order as C operators operator = "/" / "%" / "*" / "-" / "+" / ">=" / ">" / "<=" / "<" / "!=" / "==" / "&&" / "||" application ; Keyword to prompt an LLM to generate a JSON value (the default) or Grace ; code (when preceded with `import`) = [ "import" ] "prompt" projection ; Keyword to make an HTTP request to fetch a JSON value (the default) or Grace ; code (when preceded with `import`) = [ "import" ] "http" projection ; Keyword to convert text to a JSON value (the default) or Grace code (when ; preceded with `import`) = [ "import" ] "read" projection ; Keyword to fetch a JSON file from GitHub (the default) or Grace code (when ; preceded with `import`) = [ "import" ] "github" projection ; Keyword to render a JSON expression (the default) or any expression (when ; preceded with `export`) as text = [ "export" ] "show" projection ; Keyword to pattern match on a union / "fold" projection ; Ordinary function application (left-associative) / application projection / projection ; Optionally project a field (from a record) or an element (from a list) projection = primitive *smaller smaller ; You can access a record field using `record.field`. = "." field ; You can project multiple fields from a record / "." "{" [ field *( "," field ) ] "}" ; You can also index into a list using dot notation (e.g. `list.index`) Just ; like Python, you can index from the end of the list using negative numbers ; (e.g. `list.-1` to get the last element of the list). / "." integer ; You can slice into a list using `xs[m:n]` just like in Python. Slice ; indices may also be negative and both indices are optional. / "[" [ integer ] ":" [ integer ] "]" primitive = identifier ; bound variable (e.g. `x`) / "null" / boolean / number / string / builtin / list / record ; NOTE: all alternatives need an argument. If an alternative is empty you ; still need to store an empty record inside of it (e.g. `Foo{ }`) / alternative primitive ; An absolute path (beginning with `/`) or relative path (beginning with `../` ; or `./`) / file ; A URI (supported schemes: `https` / `http` / `env` / `file`) / uri / "(" expression ")" boolean = "true" / "false" number = natural / integer / real ; Positive integers are parsed as `Natural` numbers natural = 1*DIGIT ; Signed integers are parsed as `Integer`s integer = ("+" / "-") natural ; All other numbers are parsed as `Real`s real = [ ( "+" / "-" ) ] 1*DIGIT "." 1*DIGIT ; Strings support two modes: ; ; - Single-line string literals, like: ; ; "abc" ; ; - Multi-line string literals, like: ; ; " ; Line 1 ; ; Line 3 ; " string = single-line-string / multi-line-string ; Single-line string literals only support escaped newlines (i.e. `\n`) single-line-string = %x22 *( single-line-character / interpolation / single-line-escape) %x22 ; A character other than " or \ single-line-character = %x20-21 / %x23-5B / %x5D-10FFFF ; NOTE: You can escape a string interpolation using a backslash like this: ; ; ``` ; "Example: \${…}" ; ``` ; ; … if you don't want Grace to interpret the string interpolation. This comes ; in handy if you, say, want to use Grace to generate a Bash script without ; interpreting Bash string interpolations. single-line-escape = "\\" ( %x22 / "\\" / "/" / "n" / "t" / "r" / "b" / "f" / "$" / ("u" 4HEXDIG) ) ; These string literals can span multiple lines and leading indentation is ; stripped. For example, this: ; ; let example = ; " ; Line 1 ; ; Line 3 ; " ; ; … is the same thing as: ; ; let example = "Line 1\n\nLine 3\n" ; ; The difference between a single-line string literal and a multi-line string ; literal is that in a multi-line string literal the `"` is followed by a ; newline (which must be present and is stripped). For example, this: ; ; let example = ; " ; Line 1" ; ; … is the same thing as: ; ; let example = "Line 1" multi-line-string = %x22 %x0A *( multi-line-character / interpolation / multi-line-escape) %x22 ; A character other than " or \ ; ; Literal tabs and newlines are also permitted, unlike single-line strings. multi-line-character = %x09-0A / %x20-21 / %x23-5B / %x5D-10FFFF ; NOTE: You cannot escape newlines or tabs in a multi-line string literal ; (because you can and should use an actual newline or tab character instead of ; an escaped one). multi-line-escape = "\\" ( %x22 / "\\" / "/" / "r" / "b" / "f" / "$" / ("u" 4HEXDIG) ) ; Interpolated expressions must have type `Text`. Grace does *not* perform ; any automatic conversion of interpolated values to `Text`. If you want to ; interpolate a number, then use: ; ; ``` ; "… ${show number} …" ; ``` ; ; Interpolated expressions do not need to be escaped: ; ; BAD: ; ; \input -> "Hello, ${input.\"First Name\"}!" ; ; GOOD: ; ; \input -> "Hello, ${input."First Name"}!" interpolation = "${" expression "}" ; A name for one of the alternatives of a union alternative ; Unquoted alternative names begin with an uppercase letter = UPPER *(ALPHANUM / "_" / "-" / "/") ; Quoted alternative names are surrounded with single quotes / single-quoted single-quoted = "'" (single-quoted-character / single-quoted-escape) "'" ; A character other than ' or \ single-quoted-character = %x20-26 / %x28-5B / %x5D-10FFFF ; Similar to the rule for "escape" except replacing " with ' and also not ; including an escape sequence for $ (since it's not necessary because a quoted ; alternative name can't include an interpolation). single-quoted-escape = "\\" ( "'" / "\\" / "/" / "n" / "t" / "r" / "b" / "f" / ("u" 4HEXDIG) ) ; Lists allow optional leading/trailing commas. list = "[" [ "," ] [ expression *( "," expression ) ] [ "," ] "]" ; Records allow optional leading/trailing commas record = "{" [ "," ] [ projection-value *( "," projection-value ) ] [ "," ] "}" projection-value ; Grace uses JSON syntax for projection values: ':' (not '=') = field ":" expression ; Field punning. In other words, `{ x }` is the same thing as `{ x: x }` / field field = identifier ; Field names can be alternative names, too. This is necessary so that you ; can `fold` unions (since the field names need to match the union's ; alternative names) / alternative ; You can quote field names, too, which comes in handy if a field has ; characters that would otherwise be forbidden (e.g. spaces or punctuation) ; (e.g. `record."Example field"` or `{ "Example field": true }`) / string builtin = "yaml" ; JSON -> Text ; Renders argument as YAML / "indexed" ; forall (a : Type) . List a -> List { index: Natural, value: a } / "length" ; forall (a : Type) . List a -> Natural / "map" ; forall (a : Type) (b : Type) . (a -> b) -> List a -> List b / "abs" ; Integer -> Natural / "reveal" ; Key -> Text / "some" ; forall (a : Type) . a -> Optional a type = quantified-type quantified-type = *forall function-type forall = "forall" 1*( "(" identifier ":" domain ")" ) "." domain = "Type" / "Fields" / "Alternatives" function-type = application-type *( "->" application-type ) application-type = "List" primitive-type / "Optional" primitive-type / primitive-type primitive-type = identifier ; Type variable / "Bool" / "Real" / "Integer" / "Natural" / "Text" / "JSON" / "Key" / record-type / union-type / "(" type ")" ; Records types allow optional leading/trailing commas record-type = "{" [ "," ] [ field ":" type *( "," field ":" type ) ] [ "," identifier ] ; Fields variable (e.g. `{ x: Text, other }` [ "," ] "}" ; Union types allow optional leading/trailing bars union-type = "<" [ "|" ] [ alternative ":" type *( "|" alternative ":" type ) ] [ "|" identifier ] ; Alternatives variable (e.g. `< Left: Natural | other >`) [ "|" ] ">" ``` ================================================ FILE: prompts/inference.md ================================================ 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*. "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: > Write a poem based off this idea: > > `${idea}` > > … by following this process: > > - First think through the form, stanza count, lines per stanza, and rhyme scheme > - Then choose a poetic style (tone, voice, and literary devices) based on the poem's form > - Then write a complete poem based on that plan … you can split it into smaller prompts, like this: ##### `structure` prompt: > Plan the structure of a new poem based on this idea > > `${idea}` > > Describe its form, stanza count, lines per stanza, and rhyme scheme ##### `style` prompt: > Given this poem structure: > > - Form: `${structure."Form"}` > - Stanzas: `${structure."Stanza Count"}` > - Lines per stanza: `${structure."Lines per Stanza"}` > - Rhyme scheme: `${structure."Rhyme Scheme"}` > > Choose a poetic style: tone, voice, and literary devices to emphasize ##### `poem` prompt: > Write a complete poem based on this idea: > > `${idea}` > > Structure: > - Form: `${structure."Form"}` > - Stanzas: `${structure."Stanza Count"}` > - Lines per stanza: `${structure."Lines per Stanza"}` > - Rhyme scheme: `${structure."Rhyme Scheme"}` > > Style: > - Tone: `${style."Tone"}` > - Voice: `${style."Voice"}` > - Literary Devices: `${style."Literary Devices"}` Why might you want to do this? - to improve the quality of the results Models perform better when working on more constrained subproblems. Splitting a larger prompt into smaller prompts helps the model stay focused at each step. - to introspect intermediate results This comes in handy when you want to log, validate, or correct intermediate results. - to perform actions in between prompts 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. In other words, prompt chaining unlocks greater *accuracy*, *control*, and *flexibility* for prompt engineering. #### The problem The 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: - you have to define the schema for each intermediate step of the process 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 - You have to instruct the model to produce JSON and explain the shape of the expected output - (Depending on the framework) you have to decode the JSON into your data model For 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. So 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. #### Example I'll cut to the case by showing the above prompt chain written as a program in this language: ```haskell \{ key } -> let concatSep = import github { owner: "Gabriella439" , repository: "grace" , path: "prelude/text/concatSep.ffg" } let generatePoem idea = let structure = prompt { key , text: " Plan the structure of a new poem based on this idea: ${idea} Describe its form, stanza count, lines per stanza, and rhyme scheme. " } let renderedStructure = " - Form: ${structure."Form"} - Stanzas: ${show (structure."Stanza Count": Natural)} - Lines per stanza: ${show (structure."Lines per Stanza" : Natural)} - Rhyme scheme: ${structure."Rhyme Scheme"} " let style = prompt { key , text: " Given this poem structure: ${renderedStructure} Choose a poetic style: tone, voice, and literary devices to emphasize. " } let renderedStyle = " - Tone: ${style."Tone"} - Voice: ${style."Voice"} - Literary Devices: ${concatSep ", " style."Literary Devices"} " let poem = prompt { key , text: " Write a complete poem based on this idea: ${idea} Structure: ${renderedStructure} Style: ${renderedStyle} " } in { structure, style, poem } in generatePoem "The stillness of early morning" ``` The 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. If you run the above example, you might get an output like this: ```json { "structure": { "Form": "Free verse with a sprinkle of rhyme", "Lines per Stanza": 4, "Rhyme Scheme": "ABCB", "Stanza Count": 5 }, "style": { "Literary Devices": [ "imagery", "alliteration", "personification", "enjambment" ], "Tone": "nostalgic", "Voice": "reflective" }, "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." } ``` … and if you're curious what the formatted poem looks like: ### The Stillness of Early Morning **I** In the gentle rise of dawn's embrace, A whisper of winds through sleepy skies, The world lies suspended in an echo Of yesterday's dreams, reluctantly saying goodbye. **II** Soft orange light graces fields of dew, Cradling tenacious tendrils of the past. Morning breathes upon the waiting world With promises that this serenity will last. **III** Waves of silence surge across the meadow, Nature's symphony gently cradles rest. A chorus of leaves sings its soft refrain, Comforted by morning's tender caress. **IV** The silence dips to caress weary trees, Whose branches waltz to whispers soft and slow. Each tendril holds close the morning's intention, Before the day's demands, the chaos, start to show. **V** Early rays dance upon a tranquil sea, A canvas painted through a dreamy haze. Time sits by, savoring the gentle hush, As the world awakens, stirs, and finally plays. #### Type inference The 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. I'll illustrate this with a contrived Grace example: ```haskell \{ key } -> let { x, y } = prompt{ key, text: "Give me two numbers" } in { x, y, sum: x + y : Integer } ``` … which might produce an output like this: ```bash $ grace interpret ./numbers.ffg ``` ```json { "x": 7, "y": 14, "sum": 21 } ``` When Grace analyzes this program the type checker works backwards from this expression: ```haskell x + y : Integer ``` … and reasons about it like this: - the addition produces an `Integer`, therefore `x` and `y` must also be `Integer`s - therefore the output of the `prompt` function must be a record with two `Integer` fields: `x` and `y` … and then Grace generates a JSON schema for the prompt which looks like this: ```json { "type": "object", "properties": { "x": { "type": "integer" }, "y": { "type": "integer" } }, "required": [ "x", "y" ], "additionalProperties": false } ``` Of course, you *can* specify types if you want (and they're more lightweight than schemas in traditional prompt chaining frameworks). For example: ```bash $ grace repl >>> prompt{ key: ./openai.key, text: "Give me a first and last name" } : { first: Text, last: Text } { "first": "Emily", "last": "Johnson" } >>> prompt{ key: ./openai.key, text: "Give me a list of names" } : List Text [ "Alice" , "Bob" , "Charlie" , "Diana" , "Ethan" , "Fiona" , "George" , "Hannah" , "Isaac" , "Jack" ] ``` However in our original example we don't need to specify intermediate types because when the type-checker sees this code: ```haskell let structure = prompt { key , text: " Plan the structure of a new poem based on this idea: ${idea} Describe its form, stanza count, lines per stanza, and rhyme scheme. " } let renderedStructure = " - Form: ${structure."Form"} - Stanzas: ${show (structure."Stanza Count" : Natural)} - Lines per stanza: ${show (structure."Lines per Stanza" : Natural)} - Rhyme scheme: ${structure."Rhyme Scheme"} " ``` … the compiler can reason backwards from how the `structure` value is used to infer that the JSON schema for the `prompt` needs to be: ```json { "type": "object", "properties": { "Form": { "type": "string" }, "Stanza Count": { "type": "integer" }, "Lines per Stanza": { "type": "integer" }, "Rhyme Scheme": { "type": "string" } }, "required": [ "Form", "Stanza Count", "Lines per Stanza", "Rhyme Scheme" ], "additionalProperties": false } ``` #### Tool use Grace also supports generating *sum types* (a.k.a. tagged unions), and you can imagine using this to subsume traditional tool use frameworks. For example, consider this Grace program: ```haskell \{ key } -> let concatSep = import github { owner: "Gabriella439" , repository: "grace" , path: "prelude/text/concatSep.ffg" } let call = fold { HttpRequest: \x -> "curl " + x.url , ShellCommand: \x -> concatSep " " ([ x.executable ] + x.arguments) } in map call (prompt{ key, text: "Call some tools" }) ``` This 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: ```bash $ grace interpret ./tools.ffg ``` ```json [ "curl https://api.example.com/data", "ls -l -a" ] ``` However, 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: ```haskell < HttpRequest: { url: Text } | ShellCommand: { executable: Text, arguments: List Text } > ``` … so the inferred type of `call` is: ```haskell call : < HttpRequest: …, ShellCommand: … > -> Text ``` … 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: ```haskell prompt{ key, text: "Call some tools" } : List < HttpRequest: …, ShellCommand: … > ``` … and then Grace does some magic under the hood to convert that type to the equivalent JSON schema. What'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. #### Schema-driven prompting We can explore this idea of using the schema to drive the prompt instead of prose using an example like this: ```haskell prompt{ key: ./openai.key, text: "Generate some characters for a story" } : List { "The character's name": Text , "The most memorable thing about the character": Text , "The character's personal arc": Text } ``` ```json [ { "The character's name": "Aveline Thatcher" , "The character's personal arc": "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." , "The most memorable thing about the character": "The intricate tattoo of a phoenix on her forearm that seems to glow when she discovers hidden truths." } , { "The character's name": "Kelan Frost" , "The character's personal arc": "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." , "The most memorable thing about the character": "His iridescent blue eyes that seem to see into one's soul, a side effect of his alchemical experiments." } , { "The character's name": "Luciana Blair" , "The character's personal arc": "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." , "The most memorable thing about the character": "Her ability to paint scenes before they happen, which she attributes to the visions she sees in her dreams." } , { "The character's name": "Ezra Hartman" , "The character's personal arc": "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." , "The most memorable thing about the character": "His perfectly tailored suits that slowly become more casual, symbolizing his transformation and shifting priorities." } , { "The character's name": "Seraphine Mora" , "The character's personal arc": "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." , "The most memorable thing about the character": "The ethereal way she 'dances' with the music, using her entire body to express each note's emotion." } ] ``` Grace 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. #### Conclusion Hopefully 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. I'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. ================================================ FILE: src/Grace/Aeson.hs ================================================ -- | Utilities for working with the @aeson@ package module Grace.Aeson where import Control.Exception.Safe (Exception(..)) import Data.Aeson (FromJSON) import Data.Text (Text) import qualified Control.Exception.Safe as Exception import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as ByteString.Lazy import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding -- | JSON decoding failed data JSONDecodingFailed = JSONDecodingFailed { message :: String , text :: Text } deriving stock (Show) instance Exception JSONDecodingFailed where displayException JSONDecodingFailed{ message, text } = "Failed to decode output as JSON\n\ \\n\ \The following text:\n\ \\n\ \" <> Text.unpack text <> "\n\ \\n\ \… to decode as JSON.\n\ \\n\ \Decoding error message:\n\ \\n\ \" <> message -- | Decode a structured value from JSON-encoded `Text` decode :: FromJSON a => Text -> IO a decode text = do let bytes = ByteString.Lazy.fromStrict (Encoding.encodeUtf8 text) case Aeson.eitherDecode bytes of Left message -> Exception.throwIO JSONDecodingFailed{ message, text } Right a -> return a ================================================ FILE: src/Grace/Compat.hs ================================================ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | An internal utility module for backwards compatibility across GHC releases -- and different libary versions. module Grace.Compat where import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import Data.Text (Text) import qualified Data.HashMap.Strict.InsOrd as HashMap import qualified Data.HashMap.Strict as HashMap.Strict import qualified Data.List as List #if MIN_VERSION_aeson(2, 0, 0) import Data.Aeson.KeyMap (KeyMap) import qualified Data.Aeson.KeyMap as Aeson #else import Data.HashMap.Strict (HashMap) #endif #if !MIN_VERSION_containers(0, 6, 6) import Data.Sequence.Internal (Digit(..), Elem(..), FingerTree(..), Node(..), Seq(..)) import Language.Haskell.TH.Syntax (Lift(..)) #endif #if MIN_VERSION_aeson(2, 0, 0) fromAesonMap :: KeyMap v -> InsOrdHashMap Text v fromAesonMap = HashMap.fromHashMap . Aeson.toHashMapText toAesonMap :: InsOrdHashMap Text v -> KeyMap v toAesonMap = Aeson.fromHashMapText . HashMap.toHashMap sorted :: KeyMap value -> [(Text, value)] sorted = List.sortOn fst . HashMap.Strict.toList . Aeson.toHashMapText #else fromAesonMap :: HashMap Text v -> InsOrdHashMap Text v fromAesonMap = HashMap.fromHashMap toAesonMap :: InsOrdHashMap Text v -> HashMap Text v toAesonMap = HashMap.toHashMap sorted :: HashMap Text v -> [(Text, v)] sorted = List.sortOn fst . HashMap.Strict.toList #endif #if !MIN_VERSION_containers(0, 6, 6) deriving stock instance Lift a => Lift (Seq a) deriving stock instance Lift a => Lift (Digit a) deriving stock instance Lift a => Lift (Elem a) deriving stock instance Lift a => Lift (FingerTree a) deriving stock instance Lift a => Lift (Node a) #endif ================================================ FILE: src/Grace/Context.hs ================================================ {-# LANGUAGE FlexibleContexts #-} {-| A `Context` is an ordered list of `Entry`s used as the state for the bidirectional type-checking algorithm -} module Grace.Context ( -- * Types Entry(..) , Context -- * Utilities , lookup , splitOnUnsolvedType , splitOnUnsolvedFields , splitOnUnsolvedAlternatives , discardUpTo , solveType , solveRecord , solveUnion , complete ) where import Data.Text (Text) import Grace.Domain (Domain) import Grace.Existential (Existential) import Grace.Monotype (Monotype) import Grace.Pretty (Pretty(..), label, operator, punctuation) import Grace.Type (Type) import Prelude hiding (lookup) import Prettyprinter (Doc) import Prettyprinter.Render.Terminal (AnsiStyle) import qualified Control.Monad.State.Strict as State import qualified Grace.Domain as Domain import qualified Grace.Existential as Existential import qualified Grace.Monotype as Monotype import qualified Grace.Type as Type import qualified Prettyprinter as Pretty {- $setup >>> :set -XOverloadedStrings >>> :set -XTypeApplications >>> import Grace.Type (Record, Union) -} -- | An element of the `Context` list data Entry s = Variable Domain Text -- ^ Universally quantified variable -- -- >>> pretty @(Entry ()) (Variable Domain.Type "a") -- a: Type | Annotation Text (Type s) -- ^ A bound variable whose type is known -- -- >>> pretty @(Entry ()) (Annotation "x" "a") -- x: a | UnsolvedType (Existential Monotype) -- ^ A placeholder type variable whose type has not yet been inferred -- -- >>> pretty @(Entry ()) (UnsolvedType 0) -- a? | UnsolvedFields (Existential Monotype.Record) -- ^ A placeholder fields variable whose type has not yet been inferred -- -- >>> pretty @(Entry ()) (UnsolvedFields 0) -- a? | UnsolvedAlternatives (Existential Monotype.Union) -- ^ A placeholder alternatives variable whose type has not yet been -- inferred -- -- >>> pretty @(Entry ()) (UnsolvedAlternatives 0) -- a? | SolvedType (Existential Monotype) Monotype -- ^ A placeholder type variable whose type has been (at least partially) -- inferred -- -- >>> pretty @(Entry ()) (SolvedType 0 (Monotype.Scalar Monotype.Bool)) -- a = Bool | SolvedFields (Existential Monotype.Record) Monotype.Record -- ^ A placeholder fields variable whose type has been (at least partially) -- inferred -- -- >>> pretty @(Entry ()) (SolvedFields 0 (Monotype.Fields [("x", "X")] (Monotype.UnsolvedFields 1))) -- a = x: X, b? | SolvedAlternatives (Existential Monotype.Union) Monotype.Union -- ^ A placeholder alternatives variable whose type has been (at least -- partially) inferred -- -- >>> pretty @(Entry ()) (SolvedAlternatives 0 (Monotype.Alternatives [("x", "X")] (Monotype.UnsolvedAlternatives 1))) -- a = x: X | b? | MarkerType (Existential Monotype) -- ^ This is used by the bidirectional type-checking algorithm to separate -- context entries introduced before and after type-checking a universally -- quantified type -- -- >>> pretty @(Entry ()) (MarkerType 0) -- ➤ a: Type | MarkerFields (Existential Monotype.Record) -- ^ This is used by the bidirectional type-checking algorithm to separate -- context entries introduced before and after type-checking universally -- quantified fields -- -- >>> pretty @(Entry ()) (MarkerFields 0) -- ➤ a: Fields | MarkerAlternatives (Existential Monotype.Union) -- ^ This is used by the bidirectional type-checking algorithm to separate -- context entries introduced before and after type-checking universally -- quantified alternatives -- -- >>> pretty @(Entry ()) (MarkerAlternatives 0) -- ➤ a: Alternatives deriving stock (Eq, Show) instance Pretty (Entry s) where pretty = prettyEntry {-| A `Context` is an ordered list of `Entry`s Note that this representation stores the `Context` entries in reverse order, meaning that the beginning of the list represents the entries that were added last. For example, this context: > •, a : Bool, b, c?, d = c?, ➤e : Type … corresponds to this Haskell representation: > [ MarkerType 4 > , SolvedType 3 (Monotype.UnsolvedType 2) > , UnsolvedType 2 > , Variable "b" > , Annotation "a" (Monotype.Scalar Monotype.Bool) > ] The ordering matters because the bidirectional type-checking algorithm uses ordering of `Context` entries to determine scope. Specifically: * each `Entry` in the `Context` can only refer to variables preceding it within the `Context` * the bidirectional type-checking algorithm sometimes discards all entries in the context past a certain entry to reflect the end of their \"lifetime\" -} type Context s = [Entry s] prettyEntry :: Entry s -> Doc AnsiStyle prettyEntry (Variable domain a) = label (pretty a) <> operator ":" <> " " <> pretty domain prettyEntry (UnsolvedType a) = pretty a <> "?" prettyEntry (UnsolvedFields p) = pretty p <> "?" prettyEntry (UnsolvedAlternatives p) = pretty p <> "?" prettyEntry (SolvedType a τ) = pretty a <> " " <> punctuation "=" <> " " <> pretty τ prettyEntry (SolvedFields p (Monotype.Fields [] Monotype.EmptyFields)) = pretty p <> " " <> punctuation "=" <> " " <> punctuation "•" prettyEntry (SolvedFields p0 (Monotype.Fields [] (Monotype.UnsolvedFields p1))) = pretty p0 <> " " <> punctuation "=" <> " " <> pretty p1 <> "?" prettyEntry (SolvedFields p0 (Monotype.Fields [] (Monotype.VariableFields p1))) = pretty p0 <> " " <> punctuation "=" <> " " <> label (pretty p1) prettyEntry (SolvedFields p (Monotype.Fields ((k0, τ0) : kτs) fields)) = pretty p <> " = " <> label (pretty k0) <> operator ":" <> " " <> pretty τ0 <> foldMap prettyFieldType kτs <> case fields of Monotype.EmptyFields -> "" Monotype.UnsolvedFields p1 -> punctuation "," <> " " <> pretty p1 <> "?" Monotype.VariableFields p1 -> punctuation "," <> " " <> pretty p1 prettyEntry (SolvedAlternatives p (Monotype.Alternatives [] Monotype.EmptyAlternatives)) = pretty p <> " " <> punctuation "=" <> " " <> punctuation "•" prettyEntry (SolvedAlternatives p0 (Monotype.Alternatives [] (Monotype.UnsolvedAlternatives p1))) = pretty p0 <> " " <> punctuation "=" <> " " <> pretty p1 <> "?" prettyEntry (SolvedAlternatives p0 (Monotype.Alternatives [] (Monotype.VariableAlternatives p1))) = pretty p0 <> " " <> punctuation "=" <> " " <> label (pretty p1) prettyEntry (SolvedAlternatives p0 (Monotype.Alternatives ((k0, τ0) : kτs) fields)) = pretty p0 <> " " <> punctuation "=" <> " " <> prettyAlternativeType (k0, τ0) <> foldMap (\kt -> " " <> punctuation "|" <> " " <> prettyAlternativeType kt) kτs <> case fields of Monotype.EmptyAlternatives -> "" Monotype.UnsolvedAlternatives p1 -> " " <> punctuation "|" <> " " <> pretty p1 <> "?" Monotype.VariableAlternatives p1 -> " " <> punctuation "|" <> " " <> label (pretty p1) prettyEntry (Annotation x a) = Pretty.group (Pretty.flatAlt long short) where long = Pretty.align ( pretty x <> operator ":" <> Pretty.hardline <> " " <> pretty a ) short = pretty x <> operator ":" <> " " <> pretty a prettyEntry (MarkerType a) = "➤ " <> pretty a <> ": Type" prettyEntry (MarkerFields a) = "➤ " <> pretty a <> ": Fields" prettyEntry (MarkerAlternatives a) = "➤ " <> pretty a <> ": Alternatives" prettyFieldType :: (Text, Monotype) -> Doc AnsiStyle prettyFieldType (k, τ) = punctuation "," <> " " <> pretty k <> operator ":" <> " " <> pretty τ prettyAlternativeType :: (Text, Monotype) -> Doc AnsiStyle prettyAlternativeType (k, τ) = pretty k <> operator ":" <> " " <> pretty τ {-| Substitute a `Type` using the solved entries of a `Context` >>> original = Type.UnsolvedType () 0 >>> pretty @(Type ()) original a? >>> pretty @(Type ()) (solveType [ UnsolvedType 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ] original) Bool -} solveType :: Context s -> Type s -> Type s solveType context type_ = foldl snoc type_ context where snoc t (SolvedType a τ) = Type.solveType a τ t snoc t (SolvedFields a r) = Type.solveFields a r t snoc t (SolvedAlternatives a u) = Type.solveAlternatives a u t snoc t _ = t {-| Substitute a t`Type.Record` using the solved entries of a `Context` >>> original = Type.Fields [("x", Type.Scalar () Monotype.Bool)] (Monotype.UnsolvedFields 0) >>> pretty @(Record ()) original { x: Bool, a? } >>> entry = SolvedFields 0 (Monotype.Fields [] Monotype.EmptyFields) >>> pretty entry a = • >>> pretty @(Record ()) (solveRecord [ entry ] original) { x: Bool } -} solveRecord :: Context s -> Type.Record s -> Type.Record s solveRecord context oldFields = newFields where location = error "Grace.Context.solveRecord: Internal error - Missing location field" newFields = case solveType context Type.Record{ fields = oldFields, location } of Type.Record{ fields } -> fields _ -> error "Grace.Context.solveRecord: Internal Error - solveType changed a record into something else" {-| Substitute a t`Type.Union` using the solved entries of a `Context` `Context` >>> original = Type.Alternatives [("A", Type.Scalar () Monotype.Bool)] (Monotype.UnsolvedAlternatives 0) >>> pretty @(Union ()) original < A: Bool | a? > >>> entry = SolvedAlternatives 0 (Monotype.Alternatives [] Monotype.EmptyAlternatives) >>> pretty entry a = • >>> pretty @(Union ()) (solveUnion [ entry ] original) < A: Bool > -} solveUnion :: Context s -> Type.Union s -> Type.Union s solveUnion context oldAlternatives = newAlternatives where location = error "Grace.Context.solveUnion: Internal error - Missing location field" newAlternatives = case solveType context Type.Union{ alternatives = oldAlternatives, location } of Type.Union{ alternatives } -> alternatives _ -> error "Grace.Context.solveUnion: Internal error - solveType changed a union into something else" {-| This function is used at the end of the bidirectional type-checking algorithm to complete the inferred type by: * Substituting the type with the solved entries in the `Context` * Adding universal quantifiers for all unsolved entries in the `Context` >>> original = Type.Function () (Type.UnsolvedType () 1) (Type.UnsolvedType () 0) >>> pretty @(Type ()) original b? -> a? >>> pretty @(Type ()) (complete [ UnsolvedType 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ] original) forall (a : Type) . a -> Bool -} complete :: Context s -> Type s -> Type s complete context type0 = do State.evalState (foldl snoc nil context) 0 where snoc action (SolvedType name solution) = do type_ <- action return (Type.solveType name solution type_) snoc action (SolvedFields name solution) = do type_ <- action return (Type.solveFields name solution type_) snoc action (SolvedAlternatives name solution) = do type_ <- action return (Type.solveAlternatives name solution type_) snoc action (UnsolvedType name₀) = do n <- State.get State.put $! n + 1 type_ <- action let location = Type.location type_ let name = Existential.toVariable n let nameLocation = location let domain = Domain.Type let solution = Monotype.VariableType name if Type.typeFreeIn name₀ type_ then do return Type.Forall { location , nameLocation , name , domain , type_ = Type.solveType name₀ solution type_ } else do return type_ snoc action (UnsolvedFields name₀) = do n <- State.get State.put $! n + 1 type_ <- action let location = Type.location type_ let name = Existential.toVariable n let nameLocation = location let domain = Domain.Fields let solution = Monotype.Fields [] (Monotype.VariableFields name) if Type.fieldsFreeIn name₀ type_ then do return Type.Forall { location , nameLocation , name , domain , type_ = Type.solveFields name₀ solution type_ } else do return type_ snoc action (UnsolvedAlternatives name₀) = do n <- State.get State.put $! n + 1 type_ <- action let location = Type.location type_ let name = Existential.toVariable n let nameLocation = location let domain = Domain.Alternatives let solution = Monotype.Alternatives [] (Monotype.VariableAlternatives name) if Type.alternativesFreeIn name₀ type_ then do return Type.Forall { location , nameLocation , name , domain , type_ = Type.solveAlternatives name₀ solution type_ } else do return type_ snoc action _ = do action nil = return type0 {-| Split a `Context` into two `Context`s before and after the given `UnsolvedType` variable. Neither `Context` contains the variable Returns `Nothing` if no such `UnsolvedType` variable is present within the `Context` >>> splitOnUnsolvedType 1 [ UnsolvedType 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ] Just ([],[SolvedType 0 (Scalar Bool)]) >>> splitOnUnsolvedType 0 [ UnsolvedType 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ] Nothing -} splitOnUnsolvedType :: Existential Monotype -- ^ `UnsolvedType` variable to split on -> Context s -> Maybe (Context s, Context s) splitOnUnsolvedType a0 (UnsolvedType a1 : entries) | a0 == a1 = return ([], entries) splitOnUnsolvedType a (entry : entries) = do (prefix, suffix) <- splitOnUnsolvedType a entries return (entry : prefix, suffix) splitOnUnsolvedType _ [] = Nothing {-| Split a `Context` into two `Context`s before and after the given `UnsolvedFields` variable. Neither `Context` contains the variable Returns `Nothing` if no such `UnsolvedFields` variable is present within the `Context` >>> splitOnUnsolvedFields 1 [ UnsolvedFields 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ] Just ([],[SolvedType 0 (Scalar Bool)]) >>> splitOnUnsolvedFields 0 [ UnsolvedFields 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ] Nothing -} splitOnUnsolvedFields :: Existential Monotype.Record -- ^ `UnsolvedFields` variable to split on -> Context s -> Maybe (Context s, Context s) splitOnUnsolvedFields p0 (UnsolvedFields p1 : entries) | p0 == p1 = return ([], entries) splitOnUnsolvedFields p (entry : entries) = do (prefix, suffix) <- splitOnUnsolvedFields p entries return (entry : prefix, suffix) splitOnUnsolvedFields _ [] = Nothing {-| Split a `Context` into two `Context`s before and after the given `UnsolvedAlternatives` variable. Neither `Context` contains the variable Returns `Nothing` if no such `UnsolvedAlternatives` variable is present within the `Context` >>> splitOnUnsolvedAlternatives 1 [ UnsolvedAlternatives 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ] Just ([],[SolvedType 0 (Scalar Bool)]) >>> splitOnUnsolvedAlternatives 0 [ UnsolvedAlternatives 1, SolvedType 0 (Monotype.Scalar Monotype.Bool) ] Nothing -} splitOnUnsolvedAlternatives :: Existential Monotype.Union -- ^ `UnsolvedAlternatives` variable to split on -> Context s -> Maybe (Context s, Context s) splitOnUnsolvedAlternatives p0 (UnsolvedAlternatives p1 : entries) | p0 == p1 = return ([], entries) splitOnUnsolvedAlternatives p (entry : entries) = do (prefix, suffix) <- splitOnUnsolvedAlternatives p entries return (entry : prefix, suffix) splitOnUnsolvedAlternatives _ [] = Nothing {-| Retrieve a variable's annotated type from a `Context`, given the variable's label and index >>> lookup "x" [ Annotation "x" (Type.Scalar () Monotype.Bool), Annotation "y" (Type.Scalar () Monotype.Natural) ] Just (Scalar {location = (), scalar = Bool}) -} lookup :: Text -- ^ Variable label -> Context s -> Maybe (Type s) lookup _ [] = Nothing lookup x0 (Annotation x1 _A : _Γ) = if x0 == x1 then Just _A else lookup x0 _Γ lookup x (_ : _Γ) = lookup x _Γ {-| Discard all entries from a `Context` up to and including the given `Entry` >>> discardUpTo (MarkerType 1) [ UnsolvedType 1, MarkerType 1, UnsolvedType 0 ] [UnsolvedType 0] -} discardUpTo :: Eq s => Entry s -> Context s -> Context s discardUpTo entry0 (entry1 : _Γ) | entry0 == entry1 = _Γ | otherwise = discardUpTo entry0 _Γ discardUpTo _ [] = [] ================================================ FILE: src/Grace/Decode.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE OverloadedLists #-} {-| Use this module to decode Grace expressions into Haskell expressions Example usage: >>> decode (Value.Scalar Unknown (Syntax.Bool True)) :: Either DecodingError Bool Right True -} module Grace.Decode ( -- * Classes FromGrace(..) , ToGraceType(..) , GenericFromGrace(..) , GenericToGraceType(..) -- * Types , Key(..) -- * Exceptions , DecodingError(..) ) where import Control.Exception.Safe (Exception) import Control.Monad.State (State) import Data.Int (Int8, Int16, Int32, Int64) import Data.Scientific (Scientific) import Data.Sequence (Seq) import Data.Text (Text) import Data.Vector (Vector) import Data.Void (Void) import Data.Word (Word8, Word16, Word32, Word64) import Grace.Location (Location(..)) import Grace.Type (Type) import Grace.Value (Value(..)) import Numeric.Natural (Natural) import qualified Data.Text as Text import GHC.Generics ( Generic(..) , C , Constructor , D , K1(..) , M1(..) , Rep , S , Selector , U1(..) , V1 , (:+:)(..) , (:*:)(..) ) import Grace.Marshal (Key(..), GenericToGraceType(..), ToGraceType(..), selector) import qualified Control.Exception.Safe as Exception import qualified Control.Monad.State as State import qualified Data.Aeson as Aeson import qualified Data.Foldable as Foldable import qualified Data.HashMap.Strict.InsOrd as HashMap import qualified Data.Scientific as Scientific import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Vector as Vector import qualified GHC.Generics as Generics import qualified Grace.Pretty as Grace.Pretty import qualified Grace.Syntax as Syntax import qualified Grace.Value as Value import qualified Prettyprinter as Pretty -- | Convert a Grace expression to a Haskell expression class ToGraceType a => FromGrace a where decode :: Value Location -> Either DecodingError a default decode :: (Generic a, GenericFromGrace (Rep a)) => Value Location -> Either DecodingError a decode = fmap (fmap to) (State.evalState genericDecode 0) -- | This is used for decoding record fields, which might not be present decodeMaybe :: Maybe (Value Location) -> Either DecodingError a decodeMaybe (Just value) = decode value decodeMaybe Nothing = Left TypeError { expectedType = expected @(Maybe a) , value = Value.Scalar Unknown Syntax.Null } instance FromGrace Void instance FromGrace () instance (FromGrace a, FromGrace b) => FromGrace (a, b) instance (FromGrace a, FromGrace b) => FromGrace (Either a b) instance FromGrace Bool where decode (Value.Scalar _ (Syntax.Bool bool)) = return bool decode value = Left TypeError{ expectedType = expected @Bool, value } instance FromGrace Natural where decode (Value.Scalar _ (Syntax.Natural natural)) = return natural decode value = Left TypeError{ expectedType = expected @Natural, value } decodeIntegral :: forall a b . (FromGrace a, Integral a, Integral b, Bounded b) => Value Location -> Either DecodingError b decodeIntegral value = do integral <- decode @a value if fromIntegral (minBound @b) <= integral && integral <= fromIntegral (maxBound @b) then return (fromIntegral @a @b integral) else Left RangeError instance FromGrace Word where decode = decodeIntegral @Natural @Word instance FromGrace Word8 where decode = decodeIntegral @Natural @Word8 instance FromGrace Word16 where decode = decodeIntegral @Natural @Word16 instance FromGrace Word32 where decode = decodeIntegral @Natural @Word32 instance FromGrace Word64 where decode = decodeIntegral @Natural @Word64 instance FromGrace Integer where decode (Value.Scalar _ (Syntax.Natural natural)) = return (fromIntegral natural) decode (Value.Scalar _ (Syntax.Integer integer)) = return integer decode value = Left TypeError { expectedType = expected @Integer , value = value } instance FromGrace Int where decode = decodeIntegral @Integer @Int instance FromGrace Int8 where decode = decodeIntegral @Integer @Int8 instance FromGrace Int16 where decode = decodeIntegral @Integer @Int16 instance FromGrace Int32 where decode = decodeIntegral @Integer @Int32 instance FromGrace Int64 where decode = decodeIntegral @Integer @Int64 instance FromGrace Scientific where decode (Value.Scalar _ (Syntax.Natural natural)) = return (fromIntegral natural) decode (Value.Scalar _ (Syntax.Integer integer)) = return (fromInteger integer) decode (Value.Scalar _ (Syntax.Real scientific)) = return scientific decode value = Left TypeError{ expectedType = expected @Scientific, value } decodeRealFloat :: RealFloat a => Value Location -> Either DecodingError a decodeRealFloat value = do scientific <- decode value case Scientific.toBoundedRealFloat scientific of Left _ -> Left RangeError Right realFloat -> return realFloat instance FromGrace Double where decode = decodeRealFloat instance FromGrace Float where decode = decodeRealFloat instance FromGrace Text where decode (Value.Text _ text) = return text decode value = Left TypeError{ expectedType = expected @Text, value } instance FromGrace Text.Lazy.Text where decode = fmap (fmap Text.Lazy.fromStrict) decode instance {-# OVERLAPPING #-} FromGrace [Char] where decode = fmap (fmap Text.unpack) decode instance FromGrace Key where decode (Value.Scalar _ (Syntax.Key text)) = return Key{ text } decode value = Left TypeError{ expectedType = expected @Key, value } instance FromGrace Aeson.Value where decode value = case Value.toJSON value of Nothing -> Left TypeError{ expectedType = expected @Aeson.Value, value } Just json -> return json instance FromGrace a => FromGrace (Seq a) where decode (Value.List _ seq_) = traverse decode seq_ decode value = Left TypeError{ expectedType = expected @(Seq a), value } instance FromGrace a => FromGrace [a] where decode = fmap (fmap Foldable.toList) (decode @(Seq a)) instance FromGrace a => FromGrace (Vector a) where decode = fmap (fmap Vector.fromList) decode instance FromGrace a => FromGrace (Maybe a) where decode (Value.Scalar _ Syntax.Null) = do return Nothing decode (Value.Application _ (Value.Builtin _ Syntax.Some) value) = do a <- decode value return (Just a) decode value = do Left TypeError{ expectedType = expected @(Maybe a), value } decodeMaybe Nothing = do return Nothing decodeMaybe (Just value) = do decode value {-| This is the underlying class that powers the `FromGrace` class's support for automatically deriving a `Generic` implementation -} class GenericToGraceType f => GenericFromGrace f where genericDecode :: State Int (Value Location -> Either DecodingError (f a)) instance GenericFromGrace V1 where genericDecode = do let expectedType = State.evalState (genericExpected @V1) 0 let decode_ value = Left TypeError{ expectedType, value } return decode_ instance GenericFromGrace U1 where genericDecode = do let expectedType = State.evalState (genericExpected @U1) 0 let decode_ (Value.Record _ []) = return U1 decode_ value = Left TypeError{ expectedType, value } return decode_ instance GenericFromGrace f => GenericFromGrace (M1 D d f) where genericDecode = fmap (fmap (fmap M1)) genericDecode instance GenericFromGrace f => GenericFromGrace (M1 C d f) where genericDecode = fmap (fmap (fmap M1)) genericDecode instance (Selector s, FromGrace a) => GenericFromGrace (M1 S s (K1 i a)) where genericDecode = do let m1 :: M1 S s (K1 i a) r m1 = undefined name <- selector m1 let decode_ value | Generics.selName m1 == "" = fmap (M1 . K1) (decode value) | otherwise = case value of Value.Record _ fieldValues -> fmap (M1 . K1) (decodeMaybe (fmap snd (HashMap.lookup name fieldValues))) _ -> do let expectedType = State.evalState (genericExpected @(M1 S s (K1 i a))) 0 Left TypeError{ expectedType, value } return decode_ instance (Selector s₀, Selector s₁, FromGrace a₀, FromGrace a₁) => GenericFromGrace (M1 S s₀ (K1 i₀ a₀) :*: M1 S s₁ (K1 i₁ a₁)) where genericDecode = do name₀ <- selector (undefined :: M1 S s₀ (K1 i₀ a₀) r) name₁ <- selector (undefined :: M1 S s₁ (K1 i₁ a₁) r) let decode_ (Value.Record _ fieldValues) = do expression₀ <- decodeMaybe (fmap snd (HashMap.lookup name₀ fieldValues)) expression₁ <- decodeMaybe (fmap snd (HashMap.lookup name₁ fieldValues)) return (M1 (K1 expression₀) :*: M1 (K1 expression₁)) decode_ value = do let expectedType = State.evalState (genericExpected @(M1 S s₀ (K1 i₀ a₀) :*: M1 S s₁ (K1 i₁ a₁))) 0 Left TypeError{ expectedType, value } return decode_ instance (Selector s, GenericFromGrace (f₀ :*: f₁), FromGrace a) => GenericFromGrace ((f₀ :*: f₁) :*: M1 S s (K1 i a)) where genericDecode = do decode₀ <- genericDecode name <- selector (undefined :: M1 S s (K1 i a) r) let decode_ value₀@(Value.Record _ fieldValues) = do expression₀ <- decode₀ value₀ expression₁ <- decodeMaybe (fmap snd (HashMap.lookup name fieldValues)) return (expression₀ :*: M1 (K1 expression₁)) decode_ value = do let expectedType = State.evalState (genericExpected @((f₀ :*: f₁) :*: M1 S s (K1 i a))) 0 Left TypeError{ expectedType, value } return decode_ instance (Selector s, FromGrace a, GenericFromGrace (f₀ :*: f₁)) => GenericFromGrace (M1 S s (K1 i a) :*: (f₀ :*: f₁)) where genericDecode = do name <- selector (undefined :: M1 S s (K1 i a) r) decode₁ <- genericDecode let decode_ value₁@(Value.Record _ fieldValues) = do expression₀ <- decodeMaybe (fmap snd (HashMap.lookup name fieldValues)) expression₁ <- decode₁ value₁ return (M1 (K1 expression₀) :*: expression₁) decode_ value = do let expectedType = State.evalState (genericExpected @(M1 S s (K1 i a) :*: (f₀ :*: f₁))) 0 Left TypeError{ expectedType, value } return decode_ instance (GenericFromGrace (f₀ :*: f₁), GenericFromGrace (f₂ :*: f₃)) => GenericFromGrace ((f₀ :*: f₁) :*: (f₂ :*: f₃)) where genericDecode = do decode₀ <- genericDecode decode₁ <- genericDecode let decode_ value = do expression₀ <- decode₀ value expression₁ <- decode₁ value return (expression₀ :*: expression₁) return decode_ instance (Constructor c₀, Constructor c₁, GenericFromGrace f₀, GenericFromGrace f₁) => GenericFromGrace (M1 C c₀ f₀ :+: M1 C c₁ f₁) where genericDecode = do let name₀ = Text.pack (Generics.conName (undefined :: M1 C c₀ f₀ r)) let name₁ = Text.pack (Generics.conName (undefined :: M1 C c₁ f₁ r)) let decode₀ = State.evalState genericDecode 0 let decode₁ = State.evalState genericDecode 0 let decode_ v@(Value.Alternative _ name value) | name == name₀ = fmap (L1 . M1) (decode₀ value) | name == name₁ = fmap (R1 . M1) (decode₁ value) | otherwise = do let expectedType = State.evalState (genericExpected @(M1 C c₀ f₀ :+: M1 C c₁ f₁)) 0 Left TypeError{ expectedType, value = v } decode_ v = do let expectedType = State.evalState (genericExpected @(M1 C c₀ f₀ :+: M1 C c₁ f₁)) 0 Left TypeError{ expectedType, value = v } return decode_ instance (Constructor c, GenericFromGrace f₀, GenericFromGrace (f₁ :+: f₂)) => GenericFromGrace (M1 C c f₀ :+: (f₁ :+: f₂)) where genericDecode = do let name₀ = Text.pack (Generics.conName (undefined :: M1 C c f r)) let decode₀ = State.evalState genericDecode 0 let decode₁ = State.evalState genericDecode 0 let decode_ (Value.Alternative _ name value₀) | name == name₀ = fmap (L1 . M1) (decode₀ value₀) decode_ value₁ = fmap R1 (decode₁ value₁) return decode_ instance (Constructor c, GenericFromGrace (f₀ :+: f₁), GenericFromGrace f₂) => GenericFromGrace ((f₀ :+: f₁) :+: M1 C c f₂) where genericDecode = do let name₁ = Text.pack (Generics.conName (undefined :: M1 C c f r)) let decode₀ = State.evalState genericDecode 0 let decode₁ = State.evalState genericDecode 0 let decode_ (Value.Alternative _ name value₁) | name == name₁ = fmap (R1 . M1) (decode₁ value₁) decode_ value₀ = fmap L1 (decode₀ value₀) return decode_ instance (GenericFromGrace (f₀ :+: f₁), GenericFromGrace (f₂ :+: f₃)) => GenericFromGrace ((f₀ :+: f₁) :+: (f₂ :+: f₃)) where genericDecode = do let decode₀ = State.evalState genericDecode 0 let decode₁ = State.evalState genericDecode 0 let decode_ value = do let Right a <|> _ = Right a _ <|> Right a = Right a Left TypeError{ } <|> Left TypeError{ } = do let expectedType = State.evalState (genericExpected @((f₀ :+: f₁) :+: (f₂ :+: f₃))) 0 Left TypeError{ expectedType, value } _ <|> _ = Left RangeError fmap L1 (decode₀ value) <|> fmap R1 (decode₁ value) return decode_ -- | Result of decoding data DecodingError = TypeError{ expectedType :: Type (), value :: Value Location } -- ^ The input Grace expression has the wrong type | RangeError -- ^ The input Grace expression is out of bounds for the target Haskell type deriving stock (Eq, Show) instance Exception DecodingError where displayException TypeError{ expectedType, value } = "Failed to decode Grace value into Haskell because of a type mismatch\n\ \\n\ \The following value:\n\ \\n\ \" <> Text.unpack (Grace.Pretty.toSmart (" " <> Pretty.align (Grace.Pretty.pretty value))) <> "\n\ \\n\ \… could not be decoded into Haskell because it does not match this type:\n\ \\n\ \" <> Text.unpack (Grace.Pretty.toSmart (" " <> Pretty.align (Grace.Pretty.pretty expectedType))) displayException RangeError = "Failed to decode value because the decoded result was out of bounds" ================================================ FILE: src/Grace/Domain.hs ================================================ {-| This module exists primarily to avoid a name clash with constructors of the same name in the "Grace.Type" module -} module Grace.Domain ( -- * Domain Domain(..) ) where import GHC.Generics (Generic) import Grace.Pretty (Pretty(..), builtin) import Language.Haskell.TH.Syntax (Lift) -- | The domain over which a @forall@ is quantified data Domain = Type -- ^ @forall (a : Type) . …@ | Fields -- ^ @forall (a : Fields) . …@ | Alternatives -- ^ @forall (a : Alternatives) . …@ deriving stock (Eq, Generic, Lift, Show) instance Pretty Domain where pretty Type = builtin "Type" pretty Fields = builtin "Fields" pretty Alternatives = builtin "Alternatives" ================================================ FILE: src/Grace/Encode.hs ================================================ {-| Use this module to encode Haskell expressions as Grace expressions Example usage: >>> encode True Scalar () (Bool True) -} module Grace.Encode ( -- * Classes ToGrace(..) , GenericToGrace(..) , ToGraceType(..) , GenericToGraceType(..) -- * Types , Key(..) ) where import Control.Monad.State (State) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import Data.Int (Int8, Int16, Int32, Int64) import Data.Scientific (Scientific) import Data.Sequence (Seq) import Data.Text (Text) import Data.Vector (Vector) import Data.Void (Void) import Data.Word (Word8, Word16, Word32, Word64) import Grace.Marshal (GenericToGraceType(..), Key(..), ToGraceType(..)) import Grace.Value (Value(..)) import Numeric.Natural (Natural) import GHC.Generics ( Generic(..) , C , Constructor , D , K1(..) , M1(..) , Rep , S , Selector , U1(..) , V1 , (:+:)(..) , (:*:)(..) ) import qualified Control.Monad.State as State import qualified Data.Aeson as Aeson import qualified Data.Scientific as Scientific import qualified Data.Sequence as Seq import qualified Data.HashMap.Strict.InsOrd as HashMap import qualified Data.Text as Text import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Vector as Vector import qualified GHC.Generics as Generics import qualified Grace.Marshal as Marshal import qualified Grace.Syntax as Syntax import qualified Grace.Value as Value -- | Convert a Haskell expression to a Grace expression class ToGraceType a => ToGrace a where encode :: a -> Value () default encode :: (Generic a, GenericToGrace (Rep a)) => a -> Value () encode = State.evalState genericEncode 0 . from instance ToGrace Void instance ToGrace () instance (ToGrace a, ToGrace b) => ToGrace (a, b) instance (ToGrace a, ToGrace b) => ToGrace (Either a b) instance ToGrace Bool where encode bool = Value.Scalar () (Syntax.Bool bool) instance ToGrace Natural where encode natural = Value.Scalar () (Syntax.Natural natural) instance ToGrace Word where encode = encode @Natural . fromIntegral instance ToGrace Word8 where encode = encode @Natural . fromIntegral instance ToGrace Word16 where encode = encode @Natural . fromIntegral instance ToGrace Word32 where encode = encode @Natural . fromIntegral instance ToGrace Word64 where encode = encode @Natural . fromIntegral instance ToGrace Integer where encode integer = Value.Scalar () (Syntax.Integer integer) instance ToGrace Int where encode = encode @Integer . fromIntegral instance ToGrace Int8 where encode = encode @Integer . fromIntegral instance ToGrace Int16 where encode = encode @Integer . fromIntegral instance ToGrace Int32 where encode = encode @Integer . fromIntegral instance ToGrace Int64 where encode = encode @Integer . fromIntegral instance ToGrace Scientific where encode scientific = Value.Scalar () (Syntax.Real scientific) instance ToGrace Float where encode = encode @Scientific . Scientific.fromFloatDigits instance ToGrace Double where encode = encode @Scientific . Scientific.fromFloatDigits instance ToGrace Text where encode text = Value.Text () text instance ToGrace Text.Lazy.Text where encode = encode . Text.Lazy.toStrict instance {-# OVERLAPPING #-} ToGrace [Char] where encode = encode . Text.pack instance ToGrace Key where encode Key{ text } = Value.Scalar () (Syntax.Key text) instance ToGrace Aeson.Value where encode = Value.fromJSON instance ToGrace a => ToGrace (Seq a) where encode list = Value.List () (fmap encode list) instance ToGrace a => ToGrace [a] where encode = encode . Seq.fromList instance ToGrace a => ToGrace (Vector a) where encode = encode . Vector.toList instance ToGrace a => ToGrace (Maybe a) where encode (Just a) = Value.Application () (Value.Builtin () Syntax.Some) (encode a) encode Nothing = Value.Scalar () Syntax.Null {-| This is the underlying class that powers the `ToGrace` class's support for automatically deriving a `Generic` implementation -} class GenericToGrace f where genericEncode :: State Int (f a -> Value ()) instance GenericToGrace V1 where genericEncode = do -- EmptyCase does not work here and produces a non-exhaustive pattern -- match warning let encode_ _ = error "Grace.Encode.genericEncode: V1 inhabited" return encode_ instance GenericToGrace U1 where genericEncode = do let encode_ U1 = Value.Record () mempty return encode_ instance GenericToGrace f => GenericToGrace (M1 D d f) where genericEncode = fmap (. unM1) genericEncode instance GenericToGrace f => GenericToGrace (M1 C c f) where genericEncode = fmap (. unM1) genericEncode instance (Selector s, ToGrace a) => GenericToGrace (M1 S s (K1 i a)) where genericEncode = do let m1 :: M1 S s (K1 i a) r m1 = undefined name <- Marshal.selector m1 let encode_ (M1 (K1 a)) | Generics.selName m1 == "" = encode a | otherwise = Value.Record () (HashMap.singleton name ((), encode a)) return encode_ instance (Selector s₀, Selector s₁, ToGrace a₀, ToGrace a₁) => GenericToGrace (M1 S s₀ (K1 i₀ a₀) :*: M1 S s₁ (K1 i₁ a₁)) where genericEncode = do name₀ <- Marshal.selector (undefined :: M1 S s₀ (K1 i₀ a₀) r) name₁ <- Marshal.selector (undefined :: M1 S s₁ (K1 i₁ a₁) r) let encode_ (M1 (K1 a₀) :*: M1 (K1 a₁)) = Value.Record () (HashMap.fromList [ (name₀, ((), encode a₀)), (name₁, ((), encode a₁)) ] ) return encode_ instance (Selector s, GenericToGrace (f₀ :*: f₁), ToGrace a) => GenericToGrace ((f₀ :*: f₁) :*: M1 S s (K1 i a)) where genericEncode = do encode₀ <- genericEncode name <- Marshal.selector (undefined :: M1 S s (K1 i a) r) let encode_ (f :*: M1 (K1 a)) = Value.Record () ( HashMap.insert name ((), encode a) (unsafeExpectRecordLiteral (encode₀ f)) ) return encode_ instance (Selector s, ToGrace a, GenericToGrace (f₀ :*: f₁)) => GenericToGrace (M1 S s (K1 i a) :*: (f₀ :*: f₁)) where genericEncode = do name <- Marshal.selector (undefined :: M1 S s (K1 i a) r) encode₁ <- genericEncode let encode_ (M1 (K1 a) :*: f) = Value.Record () (HashMap.insert name ((), encode a) (unsafeExpectRecordLiteral (encode₁ f)) ) return encode_ instance (GenericToGrace (f₀ :*: f₁), GenericToGrace (f₂ :*: f₃)) => GenericToGrace ((f₀ :*: f₁) :*: (f₂ :*: f₃)) where genericEncode = do encode₀ <- genericEncode encode₁ <- genericEncode let encode_ (f₀ :*: f₁) = Value.Record () ( unsafeExpectRecordLiteral (encode₀ f₀) <> unsafeExpectRecordLiteral (encode₁ f₁) ) return encode_ instance (Constructor c₀, Constructor c₁, GenericToGrace f₀, GenericToGrace f₁) => GenericToGrace (M1 C c₀ f₀ :+: M1 C c₁ f₁) where genericEncode = do let name₀ = Text.pack (Generics.conName (undefined :: M1 i c₀ f₀ r)) let name₁ = Text.pack (Generics.conName (undefined :: M1 i c₁ f₁ r)) let encode₀ = State.evalState genericEncode 0 let encode₁ = State.evalState genericEncode 0 let encode_ (L1 (M1 f)) = Value.Alternative () name₀ (encode₀ f) encode_ (R1 (M1 f)) = Value.Alternative () name₁ (encode₁ f) return encode_ instance (Constructor c, GenericToGrace f₀, GenericToGrace (f₁ :+: f₂)) => GenericToGrace (M1 C c f₀ :+: (f₁ :+: f₂)) where genericEncode = do let name = Text.pack (Generics.conName (undefined :: M1 C c f₀ r)) let encode₀ = State.evalState genericEncode 0 let encode₁ = State.evalState genericEncode 0 let encode_ (L1 (M1 f)) = Value.Alternative () name (encode₀ f) encode_ (R1 f ) = encode₁ f return encode_ instance (Constructor c, GenericToGrace (f₀ :+: f₁), GenericToGrace f₂) => GenericToGrace ((f₀ :+: f₁) :+: M1 C c f₂) where genericEncode = do let name = Text.pack (Generics.conName (undefined :: M1 C c f₂ r)) let encode₀ = State.evalState genericEncode 0 let encode₁ = State.evalState genericEncode 0 let encode_ (L1 f ) = encode₀ f encode_ (R1 (M1 f)) = Value.Alternative () name (encode₁ f) return encode_ instance (GenericToGrace (f₀ :+: f₁), GenericToGrace (f₂ :+: f₃)) => GenericToGrace ((f₀ :+: f₁) :+: (f₂ :+: f₃)) where genericEncode = do let encode₀ = State.evalState genericEncode 0 let encode₁ = State.evalState genericEncode 0 let encode_ (L1 f) = encode₀ f encode_ (R1 f) = encode₁ f return encode_ unsafeExpectRecordLiteral :: Value location -> InsOrdHashMap Text (location, Value location) unsafeExpectRecordLiteral (Value.Record _ fieldValues) = fieldValues unsafeExpectRecordLiteral _ = error "Grace.Encode.unsafeExpectRecordLiteral: not a record" ================================================ FILE: src/Grace/Existential.hs ================================================ {-| This module provides a newtype wrapper for existential variables used in the type-checking algorithm. We don't use naked `Int`s since (empirically) conflating the various existentials is a common source of type-checking errors. -} module Grace.Existential ( -- * Types Existential -- * Utilities , toVariable ) where import Data.Text (Text) import Grace.Pretty (Pretty(..), label) import Language.Haskell.TH.Syntax (Lift) import qualified Data.Char as Char import qualified Data.Text as Text {-| An existential variable The type variable is used to track what type of existential variable we're using, which will be one of these three types: * @`Existential` "Grace.Monotype".Monotype@ - An existential type * @`Existential` "Grace.Monotype".Record@ - An existential fields variable * @`Existential` "Grace.Monotype".Union@ - An existential alternatives variable -} newtype Existential a = UnsafeExistential Int deriving stock Lift deriving newtype (Eq, Num, Show) instance Pretty (Existential a) where pretty x = label (pretty (toVariable x)) {-| Convert an existential variable to a user-friendly `Text` representation >>> toVariable 0 "a" >>> toVariable 1 "b" >>> toVariable 26 "a0" -} toVariable :: Existential a -> Text toVariable (UnsafeExistential n) = Text.cons prefix suffix where (q, r) = n `quotRem` 26 prefix = Char.chr (Char.ord 'a' + r) suffix = if q == 0 then "" else Text.pack (show (q - 1)) ================================================ FILE: src/Grace/GitHub.hs ================================================ -- | Utilities for interacting with GitHub module Grace.GitHub ( -- * GitHub requests github , GitHub(..) ) where import Data.Aeson (FromJSON) import Data.Text (Text) import GHC.Generics (Generic) import Grace.Decode (FromGrace(..), Key(..), ToGraceType) import Grace.Encode (ToGrace) import Grace.HTTP.Type (Header(..), HTTP(..), Parameter(..)) import qualified Data.Text as Text import qualified Grace.Aeson import qualified Grace.HTTP as HTTP -- | An HTTP request to GitHub data GitHub = GitHub { key :: Maybe Key , reference :: Maybe Text , owner :: Text , repository :: Text , path :: Text } deriving stock (Generic) deriving anyclass (FromGrace, ToGrace, ToGraceType) -- | Response from GitHub @\/repos/${owner}\/${repo}\/contents\/${path}@ API data Contents = Contents{ download_url :: Text } deriving stock (Generic) deriving anyclass (FromJSON) {-| Get the download URL of a file on GitHub This is an ergonomic convenience for the user for the exceedingly common use case of fetching code in version control from GitHub (and also powers trygrace.dev's `/github/${owner}/${repository}/${path}` short-links. -} github :: GitHub -> IO Text github GitHub{ key, owner, repository, reference, path } = do let authorization = case key of Nothing -> [ ] Just (Key k) -> [ Header{ header = "Authorization", value = "Bearer " <> Text.strip k } ] let headers = Just ( [ Header{ header = "X-GitHub-Api-Version", value = "2022-11-28" } , Header{ header = "User-Agent", value = "Grace" } ] <> authorization ) let parameters = do r <- reference return [ Parameter{ parameter = "ref", value = Just r } ] contentsResponse <- HTTP.http False GET { url = "https://api.github.com/repos/" <> owner <> "/" <> repository <> "/contents/" <> path , headers , parameters } Contents{ download_url } <- Grace.Aeson.decode contentsResponse return download_url ================================================ FILE: src/Grace/HTTP/Type.hs ================================================ -- | This module contains types shared between the GHC and GHCJS implementations module Grace.HTTP.Type where import Data.Aeson (Value) import Data.Text (Text) import GHC.Generics (Generic) import Grace.Decode (FromGrace, ToGraceType) import Grace.Encode (ToGrace) import qualified Control.Exception.Safe as Exception import qualified Data.Binary.Builder as Builder import qualified Data.ByteString.Lazy as ByteString.Lazy import qualified Data.CaseInsensitive as CaseInsensitive import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified Data.Time.Clock.POSIX as Time import qualified Network.HTTP.Types as HTTP.Types -- | An HTTP header data Header = Header{ header :: Text, value :: Text } deriving stock (Generic) deriving anyclass (FromGrace, ToGrace, ToGraceType) -- | A query parameter data Parameter = Parameter{ parameter :: Text, value :: Maybe Text } deriving stock (Generic) deriving anyclass (FromGrace, ToGrace, ToGraceType) -- | An HTTP request data HTTP = GET { url :: Text , headers :: Maybe [Header] , parameters :: Maybe [Parameter] } | POST { url :: Text , headers :: Maybe [Header] , request :: Maybe Value } deriving stock (Generic) deriving anyclass (FromGrace, ToGrace, ToGraceType) completeHeaders :: Bool -> Bool -> Maybe [Header] -> [HTTP.Types.Header] completeHeaders import_ body headers = do Header{ header, value } <- requiredHeaders <> defaultedHeaders let headerBytes = CaseInsensitive.mk (Encoding.encodeUtf8 header) let valueBytes = Encoding.encodeUtf8 (Text.strip value) return (headerBytes, valueBytes) where requiredHeaders | import_ = [ ] | otherwise = ( [ Header{ header = "Accept" , value = "application/json" } ] <> contentType ) where contentType | body = [ Header{ header = "Content-Type", value = "application/json" } ] | otherwise = [ ] defaultedHeaders = case headers of Nothing -> [] Just h -> h organization :: Maybe Text organization = Nothing renderQueryText :: Text -> Maybe [Parameter] -> IO Text renderQueryText url parameters = do let (intermediateURL, queryBytes) = Text.break (== '?') url let oldQueryText = HTTP.Types.parseQueryText (Encoding.encodeUtf8 queryBytes) let oldParameters = do (parameter, value) <- oldQueryText return Parameter{ parameter, value } currentTime <- Time.getPOSIXTime let cacheBust = [ Parameter { parameter = "cachebust" , value = Just (Text.pack (show currentTime)) } ] let finalParameters = case parameters of Nothing -> oldParameters <> cacheBust Just newParameters -> oldParameters <> newParameters <> cacheBust let queryText = do Parameter{ parameter, value } <- finalParameters return (parameter, value) let builder = HTTP.Types.renderQueryText True queryText let bytes = ByteString.Lazy.toStrict (Builder.toLazyByteString builder) case Encoding.decodeUtf8' bytes of Left exception -> Exception.throwIO exception Right text -> return (intermediateURL <> text) ================================================ FILE: src/Grace/Import.hs ================================================ -- | This module contains the import resolution logic module Grace.Import ( -- * Import resolution resolve , referentiallySane -- * Exceptions , ResolutionError(..) , ImportError(..) ) where import Control.Exception.Safe (Exception(..)) import Data.Bifunctor (first) import Data.Foldable (foldl') import Data.HashMap.Strict (HashMap) import Data.IORef (IORef) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromJust) import Data.Text (Text) import Grace.HTTP (HttpException) import Grace.Input (Input(..), Mode(..)) import Grace.Location (Location(..)) import Grace.Monad (Grace) import Grace.Syntax (Syntax) import System.FilePath (()) import Text.URI (Authority, RText, RTextLabel(..)) import qualified Control.Exception.Safe as Exception import qualified Data.HashMap.Strict as HashMap import qualified Data.IORef as IORef import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Grace.HTTP as HTTP import qualified Grace.Parser as Parser import qualified Grace.Pretty as Pretty import qualified Grace.Syntax as Syntax import qualified System.Directory as Directory import qualified System.Environment as Environment import qualified System.IO.Unsafe as Unsafe import qualified Text.URI as URI cache :: IORef (HashMap Text Text) cache = Unsafe.unsafePerformIO (IORef.newIORef HashMap.empty) {-# NOINLINE cache #-} fetch :: Text -> IO Text fetch url = do m <- IORef.readIORef cache case HashMap.lookup url m of Nothing -> do body <- HTTP.fetch url IORef.writeIORef cache $! HashMap.insert url body m return body Just body -> do return body remoteSchemes :: [RText 'Scheme] remoteSchemes = map (fromJust . URI.mkScheme) [ "http", "https" ] -- | Resolve an `Input` by returning the source code that it represents resolve :: Mode -> Input -> IO (Syntax Location Input) resolve mode₀ input = case input of URI uri mode₁ | any (`elem` remoteSchemes) (URI.uriScheme uri) -> do let name = URI.renderStr uri let handler e = throw (HTTPError e) text <- Exception.handle handler (fetch (Text.pack name)) result <- case mode₀ <> mode₁ of AsCode -> case Parser.parse name text of Left e -> Exception.throw e Right result -> return result AsText -> do return Syntax.Text { chunks = Syntax.Chunks text [] , location = 0 } AsKey -> do return Syntax.Scalar { scalar = Syntax.Key text , location = 0 } let locate offset = Location{ name, code = text, offset } return (first locate result) | URI.uriScheme uri == URI.mkScheme "env" -> do case URI.uriAuthority uri of Left False -> do var <- case URI.uriPath uri of Nothing -> throw MissingPath Just (False, var :| []) -> return (URI.unRText var) _ -> throw UnsupportedPathSeparators maybeCode <- Environment.lookupEnv (Text.unpack var) text <- case maybeCode of Nothing -> throw MissingEnvironmentVariable Just string -> return (Text.pack string) let name = "env:" <> Text.unpack var result <- case mode₀ <> mode₁ of AsCode -> case Parser.parse name text of Left e -> Exception.throw e Right result -> return result AsText -> do return Syntax.Text { chunks = Syntax.Chunks text [] , location = 0 } AsKey -> do return Syntax.Scalar { scalar = Syntax.Key text , location = 0 } let locate offset = Location{ name, code = text, offset } return (first locate result) Left True -> do throw UnsupportedPathSeparators Right _ -> do throw UnsupportedAuthority | URI.uriScheme uri == URI.mkScheme "file" -> do if all (== emptyAuthority) (URI.uriAuthority uri) then do pieces <- case URI.uriPath uri of Nothing -> throw MissingPath Just (_, pieces) -> return pieces let pathPiecesToFilePath = foldl' () "/" . map (Text.unpack . URI.unRText) . NonEmpty.toList readPath (mode₀ <> mode₁) (pathPiecesToFilePath pieces) else do throw UnsupportedAuthority | otherwise -> do throw InvalidURI Path path mode₁ -> do readPath (mode₀ <> mode₁) path Code name code -> do result <- case Parser.parse name code of Left e -> Exception.throw e Right result -> return result let locate offset = Location{ name, code, offset } return (first locate result) where readPath mode path = do adjustedPath <- case path of '~' : '/' : suffix -> do home <- Directory.getHomeDirectory return (home suffix) _ -> do return path text <- Text.IO.readFile adjustedPath result <- case mode of AsCode -> case Parser.parse path text of Left e -> Exception.throw e Right result -> return result AsText -> do return Syntax.Text { chunks = Syntax.Chunks text [] , location = 0 } AsKey -> do return Syntax.Scalar { scalar = Syntax.Key text , location = 0 } let locate offset = Location{ name = path, code = text, offset } return (first locate result) throw e = Exception.throw (ImportError input e) emptyAuthority :: Authority emptyAuthority = URI.Authority { URI.authUserInfo = Nothing , URI.authHost = fromJust (URI.mkHost "") , URI.authPort = Nothing } remote :: Input -> Bool remote (URI uri _) = any (`elem` remoteSchemes) (URI.uriScheme uri) remote _ = False -- | Fail if the child import tries to access something that the parent import -- should not have access to referentiallySane :: Input -> Input -> Grace () referentiallySane parent child | remote parent && not (remote child) = do Exception.throwIO (ImportError parent (ReferentiallyInsane child)) | otherwise = do return () -- | The base error for `ImportError` (without the @input@ information) data ResolutionError = HTTPError HttpException | InvalidURI | MissingEnvironmentVariable | MissingPath | UnsupportedPathSeparators | ReferentiallyInsane Input | UnsupportedAuthority deriving stock (Show) -- | Errors related to import resolution data ImportError = ImportError { input :: Input , resolutionError :: ResolutionError } deriving stock (Show) instance Exception ImportError where displayException ImportError{ input, resolutionError } = Text.unpack ("Import resolution failed: " <> renderedInput <> "\n\ \\n\ \" <> renderedError ) where renderedInput = case input of URI uri AsCode -> URI.render uri URI uri AsText -> URI.render uri <> " : Text" URI uri AsKey -> URI.render uri <> " : Key" Path path AsCode -> Text.pack path Path path AsText -> Text.pack path <> " : Text" Path path AsKey -> Text.pack path <> " : Key" Code _ _ -> "(input)" renderedError :: Text renderedError = case resolutionError of HTTPError httpException -> HTTP.renderError httpException InvalidURI -> "Invalid URI" MissingEnvironmentVariable -> "Missing environment variable" MissingPath -> "Missing path" ReferentiallyInsane child -> "Local imports are rejected within remote imports\n\ \\n\ \Rejected local import: " <> Text.pack (show (Pretty.pretty child)) UnsupportedPathSeparators -> "Unsupported path separators" UnsupportedAuthority -> "Unsupported authority" ================================================ FILE: src/Grace/Infer.hs ================================================ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedLists #-} {-| This module is based on the bidirectional type-checking algorithm from: Dunfield, Jana, and Neelakantan R. Krishnaswami. \"Complete and easy bidirectional typechecking for higher-rank polymorphism.\" ACM SIGPLAN Notices 48.9 (2013): 429-442. The main differences from the original algorithm are: * This uses `Control.Monad.State.Strict.StateT` to thread around `Context`s and manipulate them instead of explicit `Context` passing as in the original paper * This algorithm adds support for row polymorphism and polymorphic variants -} module Grace.Infer ( -- * Type inference typeOf , typeWith , infer , inferJSON , checkJSON -- * Types , HTTP(..) -- * Errors related to type inference , TypeInferenceError(..) ) where import Control.Applicative ((<|>)) import Control.Exception.Safe (Exception(..), MonadThrow) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.State (MonadState) import Data.Foldable (for_, toList, traverse_) import Data.Sequence (ViewL(..), (<|)) import Data.Typeable (Typeable) import Data.Text (Text) import Data.Void (Void) import Grace.Context (Context, Entry) import Grace.Decode (ToGraceType(..)) import Grace.Existential (Existential) import Grace.GitHub (GitHub(..)) import Grace.HTTP.Type (HTTP(..)) import Grace.Input (Input(..), Mode(..)) import Grace.Location (Location(..)) import Grace.Monad (Grace, Status(..)) import Grace.Monotype (Monotype) import Grace.Pretty (Pretty(..)) import Grace.Prompt.Types (Prompt(..)) import Grace.Type (Type(..)) import Grace.Value (Value) import Grace.Syntax ( Assignment(..) , Binding(..) , BindMonad(..) , Definition(..) , NameBinding(NameBinding) , Syntax ) import qualified Control.Exception.Safe as Exception import qualified Control.Lens as Lens import qualified Control.Monad as Monad import qualified Control.Monad.Reader as Reader import qualified Control.Monad.State as State import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson.Pretty import qualified Data.ByteString.Lazy as ByteString.Lazy import qualified Data.HashMap.Strict.InsOrd as Map import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Scientific as Scientific import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified Grace.Compat as Compat import qualified Grace.Context as Context import qualified Grace.Domain as Domain import qualified Grace.Import as Import import qualified Grace.Location as Location import qualified Grace.Monad as Grace import qualified Grace.Monotype as Monotype import qualified Grace.Pretty import qualified Grace.Syntax as Syntax import qualified Grace.Type as Type import qualified Grace.Value as Value import qualified Prettyprinter as Pretty orDie :: (Exception e, MonadThrow m) => Maybe a -> e -> m a Just x `orDie` _ = return x Nothing `orDie` e = Exception.throwIO e -- | Generate a fresh existential variable (of any type) fresh :: MonadState Status m => m (Existential a) fresh = do let update Status{ count = count₀, .. } = (fromIntegral count₀, Status{ count = count₁, .. }) where count₁ = count₀ + 1 State.state update -- Unlike the original paper, we don't explicitly thread the `Context` around. -- Instead, we modify the ambient state using the following utility functions: -- | Push a new `Context` `Entry` onto the stack push :: MonadState Status m => Entry Location -> m () push entry = State.modify (\s -> s { context = entry : context s }) -- | Push an unsolved variable to the very beginning of the `Context`. This -- ensures that the unsolved variable is never lost. -- -- This comes in handy for existential variables created as part of `import` -- keywords, where we want to make sure that these type variables are preserved -- in the final `Context` so that they can be reused by evaluation. preserve :: MonadState Status m => Entry Location -> m () preserve entry = State.modify (\s -> s { context = context s <> [ entry ] }) -- | Retrieve the current `Context` get :: MonadState Status m => m (Context Location) get = State.gets context -- | Set the `Context` to a new value set :: MonadState Status m => Context Location -> m () set context = State.modify (\s -> s{ context }) {-| This is used to temporarily add a `Context` entry that is discarded at the end of the entry's scope, along with any downstream entries that were created within that same scope -} scoped :: MonadState Status m => Entry Location -> m r -> m r scoped entry k = do push entry r <- k State.modify (\s -> s{ context = Context.discardUpTo entry (context s) }) return r scopedUnsolvedType :: MonadState Status m => s -> (Type.Type s -> m a) -> m a scopedUnsolvedType location k = do existential <- fresh scoped (Context.MarkerType existential) do push (Context.UnsolvedType existential) k Type.UnsolvedType{ location, existential } scopedUnsolvedFields :: MonadState Status m => (Type.Record s -> m a) -> m a scopedUnsolvedFields k = do a <- fresh scoped (Context.MarkerFields a) do push (Context.UnsolvedFields a) k (Type.Fields [] (Monotype.UnsolvedFields a)) scopedUnsolvedAlternatives :: MonadState Status m => (Type.Union s -> m a) -> m a scopedUnsolvedAlternatives k = do a <- fresh scoped (Context.MarkerAlternatives a) do push (Context.UnsolvedAlternatives a) k (Type.Alternatives [] (Monotype.UnsolvedAlternatives a)) {-| @wellFormed context type@ checks that all type/fields/alternatives variables within @type@ are declared within the @context@ -} wellFormed :: MonadThrow m => Context Location -> Type Location -> m () wellFormed context Type.VariableType{ location, name } | Context.Variable Domain.Type name `elem` context = do return () | otherwise = do Exception.throwIO (UnboundTypeVariable location name) wellFormed context Type.Function{ input, output } = do wellFormed context input wellFormed context output wellFormed context Type.Forall{ name, domain, type_ } = do wellFormed (Context.Variable domain name : context) type_ wellFormed context _A@Type.UnsolvedType{ location, existential } | all mismatch context = do Exception.throwIO (IllFormedType location _A context) | otherwise = do return () where mismatch (Context.UnsolvedType a ) = existential /= a mismatch (Context.SolvedType a _) = existential /= a mismatch _ = True wellFormed context Type.Optional{ type_ } = do wellFormed context type_ wellFormed context Type.List{ type_ } = do wellFormed context type_ wellFormed context Type.Record{ location, fields = Type.Fields kAs remainingFields } = case remainingFields of Monotype.UnsolvedFields a₀ | all mismatch context -> Exception.throwIO (IllFormedFields location a₀ context) where mismatch (Context.UnsolvedFields a₁ ) = a₀ /= a₁ mismatch (Context.SolvedFields a₁ _) = a₀ /= a₁ mismatch _ = True Monotype.VariableFields a | Context.Variable Domain.Fields a `notElem` context -> Exception.throwIO (UnboundFields location a) _ -> do traverse_ (\(_, _A) -> wellFormed context _A) kAs wellFormed context Type.Union{ location, alternatives = Type.Alternatives kAs remainingAlternatives } = case remainingAlternatives of Monotype.UnsolvedAlternatives a₀ | all mismatch context -> Exception.throwIO (IllFormedAlternatives location a₀ context) where mismatch (Context.UnsolvedAlternatives a₁ ) = a₀ /= a₁ mismatch (Context.SolvedAlternatives a₁ _) = a₀ /= a₁ mismatch _ = True Monotype.VariableAlternatives a | Context.Variable Domain.Alternatives a `notElem` context -> Exception.throwIO (UnboundAlternatives location a) _ -> traverse_ (\(_, _A) -> wellFormed context _A) kAs wellFormed _ Type.Scalar{} = do return () -- A field is required if and only if it is a subtype of @Optional T@ for some -- type @T@ isFieldRequired :: Type Location -> Grace Bool -- Fast path isFieldRequired Type.Optional{ } = return False -- Slow path isFieldRequired fieldType = do context <- get let assertOptional = do existential <- fresh push (Context.UnsolvedType existential) let optional = Type.Optional{ location, type_ } where location = Type.location fieldType type_ = Type.UnsolvedType { existential , location } subtype (Context.solveType context fieldType) optional return False assertOptional `Exception.catch` \(_ :: TypeInferenceError) -> do set context return True -- | Computes the supertype of the two input types supertypeOf :: Type Location -> Type Location -> Grace (Type Location) supertypeOf a b = do context₀ <- get case (a, b) of (type₀@UnsolvedType{ existential = existential₀ }, UnsolvedType { existential = existential₁ }) -> do Monad.unless (existential₀ == existential₁) do equateTypes existential₀ existential₁ return type₀ (UnsolvedType{ existential }, type_) | not (existential `Type.typeFreeIn` type_) , elem (Context.UnsolvedType existential) context₀ -> do instantiateTypeL existential type_ return type_ (type_, UnsolvedType{ existential }) | not (existential `Type.typeFreeIn` type_) , elem (Context.UnsolvedType existential) context₀ -> do instantiateTypeL existential type_ return type_ (Forall{ location, nameLocation, name, domain, type_ = type₀ }, type₁) -> do type_ <- supertypeOf type₀ type₁ return Forall{ location, nameLocation, name, domain, type_ } (type₀, Forall{ location, nameLocation, name, domain, type_ = type₁ }) -> do type_ <- supertypeOf type₀ type₁ return Forall{ location, nameLocation, name, domain, type_ } (VariableType{ location, name = name₀ }, VariableType{ name = name₁ }) | name₀ == name₁ -> do return VariableType{ location, name = name₀ } (Function{ location, input = input₀, output = output₀ }, Function{ input = input₁, output = output₁ }) -> do input <- subtypeOf input₀ input₁ context <- get output <- supertypeOf (Context.solveType context output₀) (Context.solveType context output₁) return Function{ location, input, output } (List{ location, type_ = type₀ }, List{ type_ = type₁ }) -> do type_ <- supertypeOf type₀ type₁ return List{ location, type_ } (Record{ location = location₀, fields = fields₀ }, Record{ location = location₁, fields = fields₁ }) -> do let Type.Fields fieldTypes₀ remainingFields₀ = fields₀ let Type.Fields fieldTypes₁ remainingFields₁ = fields₁ let map₀ = Map.fromList fieldTypes₀ let map₁ = Map.fromList fieldTypes₁ let combine type₀ type₁ = do context <- get supertypeOf (Context.solveType context type₀) (Context.solveType context type₁) both <- sequence (Map.intersectionWith combine map₀ map₁) let optional location type_ = do context <- get required <- isFieldRequired (Context.solveType context type_) if required then return Optional{ location, type_ } else return type_ let extra₀ = Map.difference map₀ map₁ let extra₁ = Map.difference map₁ map₀ let location | null extra₁ = location₀ | otherwise = location₁ -- TODO: Check if `UnsolvedFields` are solved by now case (remainingFields₀, remainingFields₁) of _ | remainingFields₀ == remainingFields₁ -> do optionalExtra₀ <- traverse (optional location₀) extra₀ optionalExtra₁ <- traverse (optional location₁) extra₁ let fieldTypes = Map.toList (both <> optionalExtra₀ <> optionalExtra₁) return Record { location , fields = Type.Fields fieldTypes remainingFields₀ } (Monotype.UnsolvedFields p₀, Monotype.UnsolvedFields p₁) -> do p₂ <- fresh context₁ <- get let p₀First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₀ context₁ Monad.guard (Context.UnsolvedFields p₁ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedFields p₀ : Context.UnsolvedFields p₂ : contextBefore ) ) return command let p₁First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₁ context₁ Monad.guard (Context.UnsolvedFields p₀ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedFields p₁ : Context.UnsolvedFields p₂ : contextBefore ) ) return command case p₀First <|> p₁First of Nothing -> do Exception.throwIO (MissingOneOfFields [location₀, location₁] p₀ p₁ context₁) Just setContext -> do setContext context₂ <- get instantiateFieldsL p₀ location₁ (Context.solveRecord context₂ (Type.Fields (Map.toList extra₁) (Monotype.UnsolvedFields p₂) ) ) context₃ <- get instantiateFieldsL p₁ location₀ (Context.solveRecord context₃ (Type.Fields (Map.toList extra₀) (Monotype.UnsolvedFields p₂) ) ) let fieldTypes = Map.toList (both <> extra₀ <> extra₁) return Record { location , fields = Type.Fields fieldTypes (Monotype.UnsolvedFields p₂) } (Monotype.UnsolvedFields p₀, _) -> do context₁ <- get instantiateFieldsL p₀ location₁ (Context.solveRecord context₁ (Type.Fields (Map.toList extra₁) remainingFields₁) ) optionalExtra₀ <- traverse (optional location₀) extra₀ let fieldTypes = Map.toList (both <> optionalExtra₀ <> extra₁) return Record { location , fields = Type.Fields fieldTypes remainingFields₁ } (_, Monotype.UnsolvedFields p₁) -> do context₁ <- get instantiateFieldsL p₁ location₀ (Context.solveRecord context₁ (Type.Fields (Map.toList extra₀) remainingFields₀) ) optionalExtra₁ <- traverse (optional location₁) extra₁ let fieldTypes = Map.toList (both <> extra₀ <> optionalExtra₁) return Record { location , fields = Type.Fields fieldTypes remainingFields₀ } _ -> do -- TODO: Improve location Exception.throwIO (FieldsVariableMismatch location₀ remainingFields₀ location₁ remainingFields₁) (Type.Union{ location = location₀, alternatives = alternatives₀ }, Type.Union{ location = location₁, alternatives = alternatives₁ }) -> do let Type.Alternatives alternativeTypes₀ remainingAlternatives₀ = alternatives₀ let Type.Alternatives alternativeTypes₁ remainingAlternatives₁ = alternatives₁ let map₀ = Map.fromList alternativeTypes₀ let map₁ = Map.fromList alternativeTypes₁ let combine type₀ type₁ = do context <- get supertypeOf (Context.solveType context type₀) (Context.solveType context type₁) both <- sequence (Map.intersectionWith combine map₀ map₁) let extra₀ = Map.difference map₀ map₁ let extra₁ = Map.difference map₁ map₀ let alternativeTypes = Map.toList (both <> extra₀ <> extra₁) let location | null extra₁ = location₀ | otherwise = location₁ -- TODO: Check if `UnsolvedAlternatives` are solved by now case (remainingAlternatives₀, remainingAlternatives₁) of _ | remainingAlternatives₀ == remainingAlternatives₁ -> do return Type.Union { location , alternatives = Type.Alternatives alternativeTypes remainingAlternatives₀ } (Monotype.UnsolvedAlternatives p₀, Monotype.UnsolvedAlternatives p₁) -> do p₂ <- fresh context₁ <- get let p₀First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₀ context₁ Monad.guard (Context.UnsolvedAlternatives p₁ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedAlternatives p₀ : Context.UnsolvedAlternatives p₂ : contextBefore ) ) return command let p₁First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₁ context₁ Monad.guard (Context.UnsolvedAlternatives p₀ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedAlternatives p₁ : Context.UnsolvedAlternatives p₂ : contextBefore ) ) return command case p₀First <|> p₁First of Nothing -> do Exception.throwIO (MissingOneOfAlternatives [location₀, location₁] p₀ p₁ context₁) Just command -> do command context₂ <- get instantiateAlternativesL p₀ location₁ (Context.solveUnion context₂ (Type.Alternatives (Map.toList extra₁) (Monotype.UnsolvedAlternatives p₂) ) ) context₃ <- get instantiateAlternativesL p₁ location₀ (Context.solveUnion context₃ (Type.Alternatives (Map.toList extra₀) (Monotype.UnsolvedAlternatives p₂) ) ) return Type.Union { location , alternatives = Type.Alternatives alternativeTypes (Monotype.UnsolvedAlternatives p₂) } (Monotype.UnsolvedAlternatives p₀, _) -> do instantiateAlternativesL p₀ location₁ (Type.Alternatives (Map.toList extra₁) remainingAlternatives₁) return Type.Union { location , alternatives = Type.Alternatives alternativeTypes remainingAlternatives₁ } (_, Monotype.UnsolvedAlternatives p₁) -> do instantiateAlternativesL p₁ location₀ (Type.Alternatives (Map.toList extra₀) remainingAlternatives₀) return Type.Union { location , alternatives = Type.Alternatives alternativeTypes remainingAlternatives₀ } _ -> do -- TODO: Improve location Exception.throwIO (AlternativesVariableMismatch location₀ remainingAlternatives₀ location₁ remainingAlternatives₁) (type₀@Type.Scalar{ scalar = scalar₀ }, Type.Scalar{ scalar = scalar₁ }) | scalar₁ `isScalarSubtypeOf` scalar₀ -> do return type₀ (Type.Scalar{ scalar = scalar₀ }, type₁@Type.Scalar{ scalar = scalar₁ }) | scalar₀ `isScalarSubtypeOf` scalar₁ -> do return type₁ (type₀@Type.Scalar{ location, scalar = Monotype.JSON }, type₁) -> do isSubtypeOfJSON location type₁ return type₀ (type₀, type₁@Type.Scalar{ location, scalar = Monotype.JSON }) -> do isSubtypeOfJSON location type₀ return type₁ (Optional{ location, type_ = type₀ }, Optional{ type_ = type₁ }) -> do type_ <- supertypeOf type₀ type₁ return Optional{ location, type_ } (Optional{ location, type_ = type₀ }, type₁) -> do type_ <- supertypeOf type₀ type₁ return Optional{ location, type_ } (type₀, Optional{ location, type_ = type₁ }) -> do type_ <- supertypeOf type₀ type₁ return Optional{ location, type_ } (type₀, type₁) -> do Exception.throwIO (NoSupertype type₀ type₁) -- | Computes the subtype of the two input types subtypeOf :: Type Location -> Type Location -> Grace (Type Location) subtypeOf a b = do context₀ <- get case (a, b) of (type₀@UnsolvedType{ existential = existential₀ }, UnsolvedType { existential = existential₁ }) -> do Monad.unless (existential₀ == existential₁) do equateTypes existential₀ existential₁ return type₀ (UnsolvedType{ existential }, type_) | not (existential `Type.typeFreeIn` type_) , elem (Context.UnsolvedType existential) context₀ -> do instantiateTypeR type_ existential return type_ (type_, UnsolvedType{ existential }) | not (existential `Type.typeFreeIn` type_) , elem (Context.UnsolvedType existential) context₀ -> do instantiateTypeR type_ existential return type_ (Forall{ nameLocation, name, type_ = type₀ }, type₁) -> do scopedUnsolvedType nameLocation \unsolved -> do subtypeOf (Type.substituteType name 0 unsolved type₀) type₁ (type₀, Forall{ nameLocation, name, type_ = type₁ }) -> do scopedUnsolvedType nameLocation \unsolved -> do subtypeOf type₀(Type.substituteType name 0 unsolved type₁) (VariableType{ location, name = name₀ }, VariableType{ name = name₁ }) | name₀ == name₁ -> do return VariableType{ location, name = name₀ } (Function{ location, input = input₀, output = output₀ }, Function{ input = input₁, output = output₁ }) -> do input <- supertypeOf input₀ input₁ output <- subtypeOf output₀ output₁ return Function{ location, input, output } (List{ location, type_ = type₀ }, List{ type_ = type₁ }) -> do type_ <- subtypeOf type₀ type₁ return List{ location, type_ } (Record{ location = location₀, fields = fields₀ }, Record{ location = location₁, fields = fields₁ }) -> do let Type.Fields fieldTypes₀ remainingFields₀ = fields₀ let Type.Fields fieldTypes₁ remainingFields₁ = fields₁ let map₀ = Map.fromList fieldTypes₀ let map₁ = Map.fromList fieldTypes₁ both <- sequence (Map.intersectionWith subtypeOf map₀ map₁) let extra₀ = Map.difference map₀ map₁ let extra₁ = Map.difference map₁ map₀ let fieldTypes = Map.toList (both <> extra₀ <> extra₁) let location | null extra₁ = location₀ | otherwise = location₁ -- TODO: Check if `UnsolvedFields` are solved by now case (remainingFields₀, remainingFields₁) of _ | remainingFields₀ == remainingFields₁ -> do return Record { location , fields = Type.Fields fieldTypes remainingFields₀ } (Monotype.UnsolvedFields p₀, Monotype.UnsolvedFields p₁) -> do p₂ <- fresh context₁ <- get let p₀First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₀ context₁ Monad.guard (Context.UnsolvedFields p₁ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedFields p₀ : Context.UnsolvedFields p₂ : contextBefore ) ) return command let p₁First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₁ context₁ Monad.guard (Context.UnsolvedFields p₀ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedFields p₁ : Context.UnsolvedFields p₂ : contextBefore ) ) return command case p₀First <|> p₁First of Nothing -> do Exception.throwIO (MissingOneOfFields [location₀, location₁] p₀ p₁ context₁) Just command -> do command context₂ <- get instantiateFieldsR location₁ (Context.solveRecord context₂ (Type.Fields (Map.toList extra₁) (Monotype.UnsolvedFields p₂) ) ) p₀ context₃ <- get instantiateFieldsR location₀ (Context.solveRecord context₃ (Type.Fields (Map.toList extra₀) (Monotype.UnsolvedFields p₂) ) ) p₁ return Type.Record { location , fields = Type.Fields fieldTypes (Monotype.UnsolvedFields p₂) } (Monotype.UnsolvedFields p₀, _) -> do instantiateFieldsR location₁ (Type.Fields (Map.toList extra₁) remainingFields₁) p₀ return Record { location , fields = Type.Fields fieldTypes remainingFields₁ } (_, Monotype.UnsolvedFields p₁) -> do instantiateFieldsR location₀ (Type.Fields (Map.toList extra₀) remainingFields₀) p₁ return Record { location , fields = Type.Fields fieldTypes remainingFields₀ } _ -> do -- TODO: Improve location Exception.throwIO (FieldsVariableMismatch location₀ remainingFields₀ location₁ remainingFields₁) (type₀@Type.Union{ location = location₀, alternatives = alternatives₀ }, type₁@Type.Union{ location = location₁, alternatives = alternatives₁ }) -> do let Type.Alternatives alternativeTypes₀ remainingAlternatives₀ = alternatives₀ let Type.Alternatives alternativeTypes₁ remainingAlternatives₁ = alternatives₁ let map₀ = Map.fromList alternativeTypes₀ let map₁ = Map.fromList alternativeTypes₁ both <- sequence (Map.intersectionWith subtypeOf map₀ map₁) let extra₀ = Map.difference map₀ map₁ let extra₁ = Map.difference map₁ map₀ let alternativeTypes = Map.toList (both <> extra₀ <> extra₁) let location = location₀ -- TODO: Check if `UnsolvedAlternatives` are solved by now case (remainingAlternatives₀, remainingAlternatives₁) of _ | remainingAlternatives₀ == remainingAlternatives₁ -> do if Map.null extra₀ && Map.null extra₁ then do return Type.Union { location , alternatives = Type.Alternatives alternativeTypes remainingAlternatives₀ } else do Exception.throwIO (NoUnionSubtype type₀ type₁ (Map.keys extra₀) (Map.keys extra₁)) (Monotype.UnsolvedAlternatives p₀, Monotype.UnsolvedAlternatives p₁) -> do p₂ <- fresh context₁ <- get let p₀First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₀ context₁ Monad.guard (Context.UnsolvedAlternatives p₁ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedAlternatives p₀ : Context.UnsolvedAlternatives p₂ : contextBefore ) ) return command let p₁First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₁ context₁ Monad.guard (Context.UnsolvedAlternatives p₀ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedAlternatives p₁ : Context.UnsolvedAlternatives p₂ : contextBefore ) ) return command case p₀First <|> p₁First of Nothing -> do Exception.throwIO (MissingOneOfAlternatives [location₀, location₁] p₀ p₁ context₁) Just command -> do command context₂ <- get instantiateAlternativesL p₀ location₁ (Context.solveUnion context₂ (Type.Alternatives (Map.toList extra₁) (Monotype.UnsolvedAlternatives p₂) ) ) context₃ <- get instantiateAlternativesL p₁ location₀ (Context.solveUnion context₃ (Type.Alternatives (Map.toList extra₀) (Monotype.UnsolvedAlternatives p₂) ) ) return Type.Union { location , alternatives = Type.Alternatives alternativeTypes (Monotype.UnsolvedAlternatives p₂) } (Monotype.UnsolvedAlternatives p₀, _) -> do if Map.null extra₀ then do instantiateAlternativesR location₁ (Type.Alternatives (Map.toList extra₁) remainingAlternatives₁) p₀ return Type.Union { location , alternatives = Type.Alternatives alternativeTypes remainingAlternatives₁ } else do Exception.throwIO (NoUnionSubtype type₀ type₁ (Map.keys extra₀) (Map.keys extra₁)) (_, Monotype.UnsolvedAlternatives p₁) -> do if Map.null extra₁ then do instantiateAlternativesR location₀ (Type.Alternatives (Map.toList extra₀) remainingAlternatives₀) p₁ return Type.Union { location , alternatives = Type.Alternatives alternativeTypes remainingAlternatives₀ } else do Exception.throwIO (NoUnionSubtype type₀ type₁ (Map.keys extra₀) (Map.keys extra₁)) _ -> do -- TODO: Improve location Exception.throwIO (AlternativesVariableMismatch location₀ remainingAlternatives₀ location₁ remainingAlternatives₁) (type₀@Type.Scalar{ scalar = scalar₀ }, Type.Scalar{ scalar = scalar₁ }) | scalar₀ `isScalarSubtypeOf` scalar₁ -> do return type₀ (Type.Scalar{ scalar = scalar₀ }, type₁@Type.Scalar{ scalar = scalar₁ }) | scalar₁ `isScalarSubtypeOf` scalar₀ -> do return type₁ (type₀, Type.Scalar{ location, scalar = Monotype.JSON }) -> do isSubtypeOfJSON location type₀ return type₀ (Type.Scalar{ location, scalar = Monotype.JSON }, type₁) -> do isSubtypeOfJSON location type₁ return type₁ (Optional{ location, type_ = type₀ }, Optional{ type_ = type₁ }) -> do type_ <- subtypeOf type₀ type₁ return Optional{ location, type_ } (Optional{ type_ = type₀ }, type₁) -> do subtypeOf type₀ type₁ (type₀, Optional{ type_ = type₁ }) -> do subtypeOf type₀ type₁ (type₀, type₁) -> do Exception.throwIO (NoSubtype type₀ type₁) -- | @subtype sub super@ checks that @sub@ is a subtype of @super@ subtype :: Type Location -> Type Location -> Grace () subtype subType₀ superType₀ = do context₀ <- get case (subType₀, superType₀) of (Type.VariableType{ name = subName }, Type.VariableType{ name = superName }) | subName == superName -> do wellFormed context₀ subType₀ (Type.UnsolvedType{ existential = subExistential }, Type.UnsolvedType{ existential = superExistential }) | subExistential == superExistential , Context.UnsolvedType subExistential `elem` context₀ -> do return () (Type.UnsolvedType{ existential = subExistential }, _) -- The @not (subExistential `Type.typeFreeIn` superType₀)@ is the -- "occurs check" which prevents a type variable from being defined -- in terms of itself (i.e. a type should not "occur" within -- itself). -- -- Later on you'll see matching "occurs checks" for record types -- and union types so that Fields variables and Alternatives -- variables cannot refer to the record or union that they belong -- to, respectively. | not (subExistential `Type.typeFreeIn` superType₀) , elem (Context.UnsolvedType subExistential) context₀ -> do instantiateTypeL subExistential superType₀ (_, Type.UnsolvedType{ existential = superExistential }) | not (superExistential `Type.typeFreeIn` subType₀) , elem (Context.UnsolvedType superExistential) context₀ -> do instantiateTypeR subType₀ superExistential (Type.Function{ input = subInput, output = subOutput }, Type.Function{ input = superInput, output = superOutput }) -> do subtype superInput subInput -- CAREFULLY NOTE: Pay really close attention to how we need to use -- `Context.solveType` any time we do something that either updates -- the context or potentially updates the context (like the above -- `subtype` command). If you forget to do this then you will get -- bugs due to unsolved variables not getting solved correctly. -- -- A much more reliable way to fix this problem would simply be to -- have every function (like `subtype`, `instantiateL`, …) -- apply `solveType` to its inputs. For example, this very -- `subtype` function could begin by doing: -- -- context <- get -- let subType₀' = Context.solveType context subType₀ -- let superType₀' = Context.solveType context superType₀ -- -- … and then use subType₀' and superType₀' for downstream steps. -- If we did that at the beginning of each function then everything -- would "just work". -- -- However, this would be more inefficient because we'd calling -- `solveType` wastefully over and over with the exact same context -- in many cases. So, the tradeoff here is that we get improved -- performance if we're willing to remember to call `solveType` in -- the right places. _Θ <- get subtype (Context.solveType _Θ subOutput) (Context.solveType _Θ superOutput) (_, Type.Forall{ name, domain, type_ }) -> do scoped (Context.Variable domain name) do subtype subType₀ type_ (Type.Forall{ nameLocation, name, domain = Domain.Type, type_ }, _) -> do scopedUnsolvedType nameLocation \unsolved -> do subtype (Type.substituteType name 0 unsolved type_) superType₀ (Type.Forall{ name, domain = Domain.Fields, type_ }, _) -> do scopedUnsolvedFields \unsolved -> do subtype (Type.substituteFields name 0 unsolved type_) superType₀ (Type.Forall{ name, domain = Domain.Alternatives, type_ }, _) -> do scopedUnsolvedAlternatives \unsolved -> do subtype (Type.substituteAlternatives name 0 unsolved type_) superType₀ (Type.Scalar{ scalar = subScalar }, Type.Scalar{ scalar = superScalar }) | subScalar == superScalar -> do return () (Type.Optional{ type_ = subType₁ }, Type.Optional{ type_ = superType₁ }) -> do subtype subType₁ superType₁ (Type.List{ type_ = subType₁ }, Type.List{ type_ = superType₁ }) -> do subtype subType₁ superType₁ (Type.Scalar{ }, Type.Scalar{ scalar = Monotype.JSON }) -> do return () (Type.List{ type_ = subType₁ }, Type.Scalar{ scalar = Monotype.JSON }) -> do subtype subType₁ superType₀ (Type.Optional{ type_ = subType₁ }, Type.Scalar{ scalar = Monotype.JSON }) -> do subtype subType₁ superType₀ (Type.Record{ fields = Type.Fields fieldTypes Monotype.EmptyFields }, Type.Scalar{ scalar = Monotype.JSON }) -> do for_ fieldTypes \(_, type_) -> do context <- get subtype type_ (Context.solveType context superType₀) (Type.Record{ fields = Type.Fields fieldTypes (Monotype.UnsolvedFields existential) }, Type.Scalar{ scalar = Monotype.JSON }) -> do instantiateFieldsL existential (Type.location superType₀) (Type.Fields [] Monotype.EmptyFields) for_ fieldTypes \(_, type_) -> do context <- get subtype type_ (Context.solveType context superType₀) (Type.Record{ fields = Type.Fields subFieldTypesList subRemainingFields }, Type.Record{ fields = Type.Fields superFieldTypesList superRemainingFields }) -> do let subFieldTypes = Map.fromList subFieldTypesList let superFieldTypes = Map.fromList superFieldTypesList let subExtraFieldTypes = Map.difference subFieldTypes superFieldTypes let superExtraFieldTypes = Map.difference superFieldTypes subFieldTypes -- All fields in the record subtype must be subtypes of any -- matching fields in the record supertype let subtypeField subType₁ superType₁ = do context <- get subtype (Context.solveType context subType₁) (Context.solveType context superType₁) sequence_ (Map.intersectionWith subtypeField subFieldTypes superFieldTypes) let getRequiredFields = do m <- traverse isFieldRequired superExtraFieldTypes return (Map.keys (Map.filter id m)) -- Here is where we handle extra fields that were only present in -- the subtype or supertype. They still might be okay if one or -- both record types has an unsolved fields variable or if extra -- fields in the supertype are `Optional` case (subRemainingFields, superRemainingFields) of _ | subRemainingFields == superRemainingFields -> do superRequiredFields <- getRequiredFields Monad.unless (null superRequiredFields) do Exception.throwIO (RecordTypeMismatch subType₀ superType₀ superRequiredFields) -- Both records type have unsolved Fields variables. Great! -- This is the most flexible case, since we can replace these -- unsolved variables with whatever fields we want to make the -- record types line up. -- -- However, it's not as simple as setting each Fields variable -- to the extra fields from the opposing record type. For -- example, if the two record types we're comparing are: -- -- > { x: Bool, p₀ } <: { y: Text, p₁ } -- -- … then it's not correct to say: -- -- > p₀ = y: Text -- > p₁ = x: Bool -- -- … because that is not the most general solution for @p₀@ and -- @p₁@! The actual most general solution is: -- -- p₀ = y: Text, p₂ -- p₁ = x: Bool, p₂ -- -- … where @p₂@ is a fresh Fields type variable representing the -- fact that both records could potentially have even more -- fields other than @x@ and @y@. (Monotype.UnsolvedFields p₀, Monotype.UnsolvedFields p₁) -> do p₂ <- fresh context₁ <- get -- We have to insert p₂ before both p₀ and p₁ within the -- context because the bidirectional type-checking algorithm -- requires that the context is ordered and all variables -- within the context can only reference prior variables -- within the context. -- -- Since @p₀@ and @p₁@ both have to reference @p₂@, then we -- need to insert @p₂@ right before @p₀@ or @p₁@, whichever -- one comes first let p₀First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₀ context₁ Monad.guard (Context.UnsolvedFields p₁ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedFields p₀ : Context.UnsolvedFields p₂ : contextBefore ) ) return command let p₁First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedFields p₁ context₁ Monad.guard (Context.UnsolvedFields p₀ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedFields p₁ : Context.UnsolvedFields p₂ : contextBefore ) ) return command case p₀First <|> p₁First of Nothing -> do Exception.throwIO (MissingOneOfFields [Type.location subType₀, Type.location superType₀] p₀ p₁ context₁) Just setContext -> do setContext context₂ <- get -- Now we solve for @p₀@. This is basically saying: -- -- > p₀ = extraFieldsFromRecordB, p₂ instantiateFieldsL p₀ (Type.location superType₀) (Context.solveRecord context₂ (Type.Fields (Map.toList superExtraFieldTypes) (Monotype.UnsolvedFields p₂) ) ) context₃ <- get -- Similarly, solve for @p₁@. This is basically saying: -- -- > p₁ = extraFieldsFromRecordA, p₂ instantiateFieldsR (Type.location subType₀) (Context.solveRecord context₃ (Type.Fields (Map.toList subExtraFieldTypes) (Monotype.UnsolvedFields p₂) ) ) p₁ -- If only the record subtype has a Fields variable then the -- solution is simpler: just set the Fields variable to the -- extra fields from the opposing record. -- -- Carefully note that it's okay if the record supertype has -- extra required fields. A record with fewer fields can be -- a subtype of a record with a greater number of fields. (Monotype.UnsolvedFields p₀, _) -> do context₁ <- get instantiateFieldsL p₀ (Type.location superType₀) (Context.solveRecord context₁ (Type.Fields (Map.toList superExtraFieldTypes) superRemainingFields) ) -- If only the record supertype has a Fields variable then -- things are slightly trickier because we *don't* allow the -- record subtype to have extra required fields. (_, Monotype.UnsolvedFields p₁) -> do requiredFields <- getRequiredFields Monad.unless (null requiredFields) do Exception.throwIO (RecordTypeMismatch subType₀ superType₀ requiredFields) context₁ <- get instantiateFieldsR (Type.location subType₀) (Context.solveRecord context₁ (Type.Fields (Map.toList subExtraFieldTypes) subRemainingFields) ) p₁ _ | otherwise -> do requiredB <- getRequiredFields Exception.throwIO (RecordTypeMismatch subType₀ superType₀ requiredB) (_A@Type.Union{ alternatives = Type.Alternatives subAlternativeTypesList subRemainingAlternatives }, _B@Type.Union{ alternatives = Type.Alternatives superAlternativesTypesList superRemainingAlternatives }) -> do let subAlternativeTypes = Map.fromList subAlternativeTypesList let superAlternativeTypes = Map.fromList superAlternativesTypesList let subExtraAlternativeTypes = Map.difference subAlternativeTypes superAlternativeTypes let superExtraAlternativeTypes = Map.difference superAlternativeTypes subAlternativeTypes let subtypeAlternative subtype₁ supertype₁ = do context <- get subtype (Context.solveType context subtype₁) (Context.solveType context supertype₁) sequence_ (Map.intersectionWith subtypeAlternative subAlternativeTypes superAlternativeTypes) case (subRemainingAlternatives, superRemainingAlternatives) of _ | subRemainingAlternatives == superRemainingAlternatives && Map.null subExtraAlternativeTypes -> do return () (Monotype.UnsolvedAlternatives p₀, Monotype.UnsolvedAlternatives p₁) -> do p₂ <- fresh context₁ <- get let p₀First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₀ context₁ Monad.guard (Context.UnsolvedAlternatives p₁ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedAlternatives p₀ : Context.UnsolvedAlternatives p₂ : contextBefore ) ) return command let p₁First = do (contextAfter, contextBefore) <- Context.splitOnUnsolvedAlternatives p₁ context₁ Monad.guard (Context.UnsolvedAlternatives p₀ `elem` contextAfter) let command = set ( contextAfter <> ( Context.UnsolvedAlternatives p₁ : Context.UnsolvedAlternatives p₂ : contextBefore ) ) return command case p₀First <|> p₁First of Nothing -> do Exception.throwIO (MissingOneOfAlternatives [Type.location subType₀, Type.location superType₀] p₀ p₁ context₁) Just command -> do command context₂ <- get instantiateAlternativesL p₀ (Type.location superType₀) (Context.solveUnion context₂ (Type.Alternatives (Map.toList superExtraAlternativeTypes) (Monotype.UnsolvedAlternatives p₂) ) ) context₃ <- get instantiateAlternativesR (Type.location subType₀) (Context.solveUnion context₃ (Type.Alternatives (Map.toList subExtraAlternativeTypes) (Monotype.UnsolvedAlternatives p₂) ) ) p₁ (Monotype.UnsolvedAlternatives p₀, _) | Map.null subExtraAlternativeTypes -> do context₁ <- get instantiateAlternativesL p₀ (Type.location superType₀) (Context.solveUnion context₁ (Type.Alternatives (Map.toList superExtraAlternativeTypes) superRemainingAlternatives ) ) (_, Monotype.UnsolvedAlternatives p₁) -> do context₁ <- get instantiateAlternativesR (Type.location subType₀) (Context.solveUnion context₁ (Type.Alternatives (Map.toList subExtraAlternativeTypes) subRemainingAlternatives ) ) p₁ _ | otherwise -> do Exception.throwIO (UnionTypeMismatch subType₀ superType₀ (Map.keys subExtraAlternativeTypes)) -- Unfortunately, we need to have this wildcard match at the end, -- otherwise we'd have to specify a number of cases that is quadratic -- in the number of `Type` constructors. That in turn means that you -- can easily forget to add cases like: -- -- (Type.List _A, Type.List _B) -> do -- subtype _A _B -- -- … because the exhaustivity checker won't warn you if you forget to -- add that case. -- -- The way I remember to do this is that when I add new complex types I -- grep the codebase for all occurrences of an existing complex type -- (like `List`), and then one of the occurrences will be here in this -- `subtype` function and then I'll remember to add a case for my new -- complex type here. (_A, _B) -> do Exception.throwIO (NotSubtype _A _B) {-| This corresponds to the judgment: > Γ ⊢ α̂ :≦ A ⊣ Δ … which updates the context Γ to produce the new context Δ, by instantiating α̂ such that α̂ <: A. The @instantiate*@ family of functions should really be called @solve*@ because their job is to solve an unsolved variable within the context. However, for consistency with the paper we still name them @instantiate*@. -} instantiateTypeL :: Existential Monotype -> Type Location -> Grace () instantiateTypeL a _A₀ = do _Γ₀ <- get (_Γ', _Γ) <- Context.splitOnUnsolvedType a _Γ₀ `orDie` MissingVariable a _Γ₀ let instLSolve τ = do wellFormed _Γ _A₀ set (_Γ' <> (Context.SolvedType a τ : _Γ)) case _A₀ of -- InstLReach Type.UnsolvedType{..} | Just (_Γ', _ΓM) <- Context.splitOnUnsolvedType existential _Γ' -> do set (_Γ' <> (Context.SolvedType existential (Monotype.UnsolvedType a) : _ΓM) <> (Context.UnsolvedType a : _Γ)) -- InstLSolve Type.UnsolvedType{..} -> do instLSolve (Monotype.UnsolvedType existential) Type.VariableType{..} -> do instLSolve (Monotype.VariableType name) Type.Scalar{..} -> do instLSolve (Monotype.Scalar scalar) -- InstLArr Type.Function{..} -> do a₁ <- fresh a₂ <- fresh set (_Γ' <> (Context.SolvedType a (Monotype.Function (Monotype.UnsolvedType a₁) (Monotype.UnsolvedType a₂)) : Context.UnsolvedType a₁ : Context.UnsolvedType a₂ : _Γ)) instantiateTypeR input a₁ _Θ <- get instantiateTypeL a₂ (Context.solveType _Θ output) -- InstLAllR Type.Forall{..} -> do scoped (Context.Variable domain name) do instantiateTypeL a type_ -- This case is the first example of a general pattern we have to -- follow when solving unsolved variables. -- -- Typically when you solve an unsolved variable (e.g. `a`) to some -- type (e.g. `A`), you cannot just directly solve the variable as: -- -- a = A -- -- … because unsolved variables can only be solved to `Monotype`s, but -- `A` is typically a `Type`. -- -- So, instead, what you do is you solve the variable one layer at a -- time. For example, if you try to solve `a` to (the `Type`) -- `Optional (List Bool)`, you will actually get three solved variables -- added to the context: -- -- a = Optional b -- b = List c -- c = Bool -- -- In other words, each time you solve one layer of a complex type, you -- need to create a fresh unsolved variable for each inner type and -- solve each inner unsolved variable. -- -- This may seem really indirect and tedious, but if you try to skip -- this one-layer-at-a-time solving process then you will likely get -- bugs due to solved variables referring to each other out of order. -- -- This wasn't obvious to me from reading the original paper since they -- didn't really cover how to type-check complex types other than -- function types. Type.Optional{..} -> do -- To solve `a` against `Optional _A` we create a fresh unsolved -- variable named `a₁`, … a₁ <- fresh -- … solve `a` to `Optional a₁`, taking care that `a₁` comes before -- `a` within the context, (since `a` refers to `a₁`) … set (_Γ' <> (Context.SolvedType a (Monotype.Optional (Monotype.UnsolvedType a₁)) : Context.UnsolvedType a₁ : _Γ)) -- … and then solve `a₁` against _A` instantiateTypeL a₁ type_ -- We solve an unsolved variable against `List` using the same -- principles described above for solving `Optional` Type.List{..} -> do a₁ <- fresh set (_Γ' <> (Context.SolvedType a (Monotype.List (Monotype.UnsolvedType a₁)) : Context.UnsolvedType a₁ : _Γ)) instantiateTypeL a₁ type_ Type.Record{ fields = Type.Fields fieldTypes remainingFields } -> do p <- fresh let process (field, type_) = do existential <- fresh let monotype = Monotype.UnsolvedType existential let entry = Context.UnsolvedType existential let instantiation = do _Θ <- get instantiateTypeL existential (Context.solveType _Θ type_) return ((field, monotype), entry, instantiation) results <- traverse process fieldTypes let (fieldMonotypes, entries, instantiations) = unzip3 results let recordMonotype = Monotype.Record (Monotype.Fields fieldMonotypes (Monotype.UnsolvedFields p)) set (_Γ' <> (Context.SolvedType a recordMonotype : Context.UnsolvedFields p : (entries <> _Γ))) instantiateFieldsL p (Type.location _A₀) (Type.Fields [] remainingFields) sequence_ instantiations Type.Union{ alternatives = Type.Alternatives alternativeTypes remainingAlternatives } -> do p <- fresh let process (alternative, type_) = do existential <- fresh let monotype = Monotype.UnsolvedType existential let entry = Context.UnsolvedType existential let instantiation = do _Θ <- get instantiateTypeL existential (Context.solveType _Θ type_) return ((alternative, monotype), entry, instantiation) results <- traverse process alternativeTypes let (alternativeMonotypes, entries, instantiations) = unzip3 results let unionMonotype = Monotype.Union (Monotype.Alternatives alternativeMonotypes (Monotype.UnsolvedAlternatives p)) set (_Γ' <> (Context.SolvedType a unionMonotype : Context.UnsolvedAlternatives p : (entries <> _Γ))) instantiateAlternativesL p (Type.location _A₀) (Type.Alternatives [] remainingAlternatives) sequence_ instantiations {-| This corresponds to the judgment: > Γ ⊢ A ≦: α̂ ⊣ Δ … which updates the context Γ to produce the new context Δ, by instantiating α̂ such that A :< α̂. -} instantiateTypeR :: Type Location -> Existential Monotype -> Grace () instantiateTypeR _A₀ a = do _Γ₀ <- get (_Γ', _Γ) <- Context.splitOnUnsolvedType a _Γ₀ `orDie` MissingVariable a _Γ₀ let instRSolve τ = do wellFormed _Γ _A₀ set (_Γ' <> (Context.SolvedType a τ : _Γ)) case _A₀ of -- InstRReach Type.UnsolvedType{..} | Just (_Γ', _ΓM) <- Context.splitOnUnsolvedType existential _Γ' -> do set (_Γ' <> (Context.SolvedType existential (Monotype.UnsolvedType a) : _ΓM) <> (Context.UnsolvedType a : _Γ)) -- InstRSolve Type.UnsolvedType{..} -> do instRSolve (Monotype.UnsolvedType existential) Type.VariableType{..} -> do instRSolve (Monotype.VariableType name) Type.Scalar{..} -> do instRSolve (Monotype.Scalar scalar) -- InstRArr Type.Function{..} -> do a₁ <- fresh a₂ <- fresh set (_Γ' <> (Context.SolvedType a (Monotype.Function (Monotype.UnsolvedType a₁) (Monotype.UnsolvedType a₂)) : Context.UnsolvedType a₁ : Context.UnsolvedType a₂ : _Γ)) instantiateTypeL a₁ input _Θ <- get instantiateTypeR (Context.solveType _Θ output) a₂ -- InstRAllL Type.Forall{ domain = Domain.Type, .. } -> do scopedUnsolvedType nameLocation \b -> do instantiateTypeR (Type.substituteType name 0 b type_) a Type.Forall{ domain = Domain.Fields, .. } -> do scopedUnsolvedFields \b -> do instantiateTypeR (Type.substituteFields name 0 b type_) a Type.Forall{ domain = Domain.Alternatives, .. } -> do scopedUnsolvedAlternatives \b -> do instantiateTypeR (Type.substituteAlternatives name 0 b type_) a Type.Optional{..} -> do a₁ <- fresh set (_Γ' <> (Context.SolvedType a (Monotype.Optional (Monotype.UnsolvedType a₁)) : Context.UnsolvedType a₁ : _Γ)) instantiateTypeR type_ a₁ Type.List{..} -> do a₁ <- fresh set (_Γ' <> (Context.SolvedType a (Monotype.List (Monotype.UnsolvedType a₁)) : Context.UnsolvedType a₁ : _Γ)) instantiateTypeR type_ a₁ Type.Record{ fields = Type.Fields fieldTypes remainingFields } -> do p <- fresh let process (field, type_) = do existential <- fresh let monotype = Monotype.UnsolvedType existential let entry = Context.UnsolvedType existential let instantiation = do _Θ <- get instantiateTypeR (Context.solveType _Θ type_) existential return ((field, monotype), entry, instantiation) results <- traverse process fieldTypes let (fieldMonotypes, entries, instantiations) = unzip3 results let recordMonotype = Monotype.Record (Monotype.Fields fieldMonotypes (Monotype.UnsolvedFields p)) set (_Γ' <> (Context.SolvedType a recordMonotype : Context.UnsolvedFields p : (entries <> _Γ))) instantiateFieldsR (Type.location _A₀) (Type.Fields [] remainingFields) p sequence_ instantiations Type.Union{ alternatives = Type.Alternatives alternativeTypes remainingAlternatives } -> do p <- fresh let process (alternative, type_) = do existential <- fresh let monotype = Monotype.UnsolvedType existential let entry = Context.UnsolvedType existential let instantiation = do _Θ <- get instantiateTypeR (Context.solveType _Θ type_) existential return ((alternative, monotype), entry, instantiation) results <- traverse process alternativeTypes let (alternativeMonotypes, entries, instantiations) = unzip3 results let unionMonotype = Monotype.Union (Monotype.Alternatives alternativeMonotypes (Monotype.UnsolvedAlternatives p)) set (_Γ' <> (Context.SolvedType a unionMonotype : Context.UnsolvedAlternatives p : (entries <> _Γ))) instantiateAlternativesR (Type.location _A₀) (Type.Alternatives [] remainingAlternatives) p sequence_ instantiations {- The following `equateFields` / `instantiateFieldsL` / `instantiateFieldsR`, `equateAlternatives` / `instantiateAlternativesL` / `instantiateAlternativesR` judgments are not present in the bidirectional type-checking paper. These were added in order to support row polymorphism and variant polymorphism, by following the same general type-checking principles as the original paper. If you understand how the `instantiateTypeL` and `instantiateTypeR` functions work, then you will probably understand how these functions work because they follow the same rules: * Always make sure that solved variables only reference variables earlier within the context * Solve for unsolved variables one layer at a time Note that the implementation and the user-facing terminology use the term fields/alternatives instead of rows/variants, respectively. -} equateTypes :: Existential Monotype -> Existential Monotype -> Grace () equateTypes existential₀ existential₁ = do _Γ₀ <- get let existential₀First = do (_Γ', _Γ) <- Context.splitOnUnsolvedType existential₁ _Γ₀ Monad.guard (Context.UnsolvedType existential₀ `elem` _Γ) return (set (_Γ' <> (Context.SolvedType existential₁ (Monotype.UnsolvedType existential₀) : _Γ))) let existential₁First = do (_Γ', _Γ) <- Context.splitOnUnsolvedType existential₀ _Γ₀ Monad.guard (Context.UnsolvedType existential₁ `elem` _Γ) return (set (_Γ' <> (Context.SolvedType existential₀ (Monotype.UnsolvedType existential₁) : _Γ))) case existential₀First <|> existential₁First of Nothing -> do Exception.throwIO (MissingOneOfTypes [] existential₀ existential₁ _Γ₀) Just setContext -> do setContext equateFields :: Existential Monotype.Record -> Existential Monotype.Record -> Grace () equateFields p₀ p₁ = do _Γ₀ <- get let p₀First = do (_Γ', _Γ) <- Context.splitOnUnsolvedFields p₁ _Γ₀ Monad.guard (Context.UnsolvedFields p₀ `elem` _Γ) return (set (_Γ' <> (Context.SolvedFields p₁ (Monotype.Fields [] (Monotype.UnsolvedFields p₀)) : _Γ))) let p₁First = do (_Γ', _Γ) <- Context.splitOnUnsolvedFields p₀ _Γ₀ Monad.guard (Context.UnsolvedFields p₁ `elem` _Γ) return (set (_Γ' <> (Context.SolvedFields p₀ (Monotype.Fields [] (Monotype.UnsolvedFields p₁)) : _Γ))) case p₀First <|> p₁First of Nothing -> do Exception.throwIO (MissingOneOfFields [] p₀ p₁ _Γ₀) Just setContext -> do setContext instantiateFieldsL :: Existential Monotype.Record -> Location -> Type.Record Location -> Grace () instantiateFieldsL p₀ location fields@(Type.Fields kAs rest) = do when (p₀ `Type.fieldsFreeIn` Type.Record{..}) do Exception.throwIO (NotFieldsSubtype location p₀ fields) let process (k, _A) = do b <- fresh return (k, _A, b) kAbs <- traverse process kAs let bs = map (\(_, _, b) -> Context.UnsolvedType b ) kAbs let kbs = map (\(k, _, b) -> (k, Monotype.UnsolvedType b)) kAbs _Γ₀ <- get (_Γ', _Γ) <- Context.splitOnUnsolvedFields p₀ _Γ₀ `orDie` MissingAllFields p₀ _Γ₀ case rest of Monotype.UnsolvedFields p₁ -> do p₂ <- fresh set (_Γ' <> (Context.SolvedFields p₀ (Monotype.Fields kbs (Monotype.UnsolvedFields p₂)) : Context.UnsolvedFields p₂ : bs <> _Γ)) equateFields p₁ p₂ _ -> do wellFormed (bs <> _Γ) Type.Record{ fields = Type.Fields [] rest, .. } set (_Γ' <> (Context.SolvedFields p₀ (Monotype.Fields kbs rest) : bs <> _Γ)) let instantiate (_, _A, b) = do _Θ <- get instantiateTypeL b (Context.solveType _Θ _A) traverse_ instantiate kAbs instantiateFieldsR :: Location -> Type.Record Location -> Existential Monotype.Record -> Grace () instantiateFieldsR location fields@(Type.Fields kAs rest) p₀ = do when (p₀ `Type.fieldsFreeIn` Type.Record{..}) do Exception.throwIO (NotFieldsSubtype location p₀ fields) let process (k, _A) = do b <- fresh return (k, _A, b) kAbs <- traverse process kAs let bs = map (\(_, _, b) -> Context.UnsolvedType b ) kAbs let kbs = map (\(k, _, b) -> (k, Monotype.UnsolvedType b)) kAbs _Γ₀ <- get (_Γ', _Γ) <- Context.splitOnUnsolvedFields p₀ _Γ₀ `orDie` MissingAllFields p₀ _Γ₀ case rest of Monotype.UnsolvedFields p₁ -> do p₂ <- fresh set (_Γ' <> (Context.SolvedFields p₀ (Monotype.Fields kbs (Monotype.UnsolvedFields p₂)) : Context.UnsolvedFields p₂ : bs <> _Γ)) equateFields p₁ p₂ _ -> do wellFormed (bs <> _Γ) Type.Record{ fields = Type.Fields [] rest, .. } set (_Γ' <> (Context.SolvedFields p₀ (Monotype.Fields kbs rest) : bs <> _Γ)) let instantiate (_, _A, b) = do _Θ <- get instantiateTypeR (Context.solveType _Θ _A) b traverse_ instantiate kAbs equateAlternatives :: Existential Monotype.Union-> Existential Monotype.Union -> Grace () equateAlternatives p₀ p₁ = do _Γ₀ <- get let p₀First = do (_Γ', _Γ) <- Context.splitOnUnsolvedAlternatives p₁ _Γ₀ Monad.guard (Context.UnsolvedAlternatives p₀ `elem` _Γ) return (set (_Γ' <> (Context.SolvedAlternatives p₁ (Monotype.Alternatives [] (Monotype.UnsolvedAlternatives p₀)) : _Γ))) let p₁First = do (_Γ', _Γ) <- Context.splitOnUnsolvedAlternatives p₀ _Γ₀ Monad.guard (Context.UnsolvedAlternatives p₁ `elem` _Γ) return (set (_Γ' <> (Context.SolvedAlternatives p₀ (Monotype.Alternatives [] (Monotype.UnsolvedAlternatives p₁)) : _Γ))) case p₀First <|> p₁First of Nothing -> do Exception.throwIO (MissingOneOfAlternatives [] p₀ p₁ _Γ₀) Just setContext -> do setContext instantiateAlternativesL :: Existential Monotype.Union -> Location -> Type.Union Location -> Grace () instantiateAlternativesL p₀ location alternatives@(Type.Alternatives kAs rest) = do when (p₀ `Type.alternativesFreeIn` Type.Union{..}) do Exception.throwIO (NotAlternativesSubtype location p₀ alternatives) let process (k, _A) = do b <- fresh return (k, _A, b) kAbs <- traverse process kAs let bs = map (\(_, _, b) -> Context.UnsolvedType b ) kAbs let kbs = map (\(k, _, b) -> (k, Monotype.UnsolvedType b)) kAbs _Γ₀ <- get (_Γ', _Γ) <- Context.splitOnUnsolvedAlternatives p₀ _Γ₀ `orDie` MissingAllAlternatives p₀ _Γ₀ case rest of Monotype.UnsolvedAlternatives p₁ -> do p₂ <- fresh set (_Γ' <> (Context.SolvedAlternatives p₀ (Monotype.Alternatives kbs (Monotype.UnsolvedAlternatives p₂)) : Context.UnsolvedAlternatives p₂ : bs <> _Γ)) equateAlternatives p₁ p₂ _ -> do wellFormed (bs <> _Γ) Type.Union{ alternatives = Type.Alternatives [] rest, .. } set (_Γ' <> (Context.SolvedAlternatives p₀ (Monotype.Alternatives kbs rest) : bs <> _Γ)) let instantiate (_, _A, b) = do _Θ <- get instantiateTypeL b (Context.solveType _Θ _A) traverse_ instantiate kAbs instantiateAlternativesR :: Location -> Type.Union Location -> Existential Monotype.Union -> Grace () instantiateAlternativesR location alternatives@(Type.Alternatives kAs rest) p₀ = do when (p₀ `Type.alternativesFreeIn` Type.Union{..}) do Exception.throwIO (NotAlternativesSubtype location p₀ alternatives) let process (k, _A) = do b <- fresh return (k, _A, b) kAbs <- traverse process kAs let bs = map (\(_, _, b) -> Context.UnsolvedType b ) kAbs let kbs = map (\(k, _, b) -> (k, Monotype.UnsolvedType b)) kAbs _Γ₀ <- get (_Γ', _Γ) <- Context.splitOnUnsolvedAlternatives p₀ _Γ₀ `orDie` MissingAllAlternatives p₀ _Γ₀ case rest of Monotype.UnsolvedAlternatives p₁ -> do p₂ <- fresh set (_Γ' <> (Context.SolvedAlternatives p₀ (Monotype.Alternatives kbs (Monotype.UnsolvedAlternatives p₂)) : Context.UnsolvedAlternatives p₂ : bs <> _Γ)) equateAlternatives p₁ p₂ _ -> do wellFormed (bs <> _Γ) Type.Union{ alternatives = Type.Alternatives [] rest, .. } set (_Γ' <> (Context.SolvedAlternatives p₀ (Monotype.Alternatives kbs rest) : bs <> _Γ)) let instantiate (_, _A, b) = do _Θ <- get instantiateTypeR (Context.solveType _Θ _A) b traverse_ instantiate kAbs onNameBinding :: NameBinding Location Input -> Grace ((Text, Type Location), Entry Location, NameBinding Location Void) onNameBinding Syntax.NameBinding{ nameLocation, name, annotation = Nothing, assignment = Nothing } = do existential <- fresh push (Context.UnsolvedType existential) let annotation = Type.UnsolvedType { location = nameLocation , existential } let fieldType = (name, annotation) let entry = Context.Annotation name annotation let newNameBinding = Syntax.NameBinding { nameLocation , name , annotation = Nothing , assignment = Nothing } return (fieldType, entry, newNameBinding) onNameBinding Syntax.NameBinding{ nameLocation, name, annotation = Just annotation, assignment = Nothing } = do let fieldType = (name, annotation) let entry = Context.Annotation name annotation let newNameBinding = Syntax.NameBinding { nameLocation , name , annotation = Just annotation , assignment = Nothing } return (fieldType, entry, newNameBinding) onNameBinding Syntax.NameBinding{ nameLocation, name, annotation = Nothing, assignment = Just assignment } = do (annotation₀, newAssignment) <- infer assignment let annotation₁ = Type.Optional { location = Syntax.location assignment , type_ = annotation₀ } let fieldType = (name, annotation₁) let entry = Context.Annotation name annotation₀ let newNameBinding = Syntax.NameBinding { nameLocation , name , annotation = Nothing , assignment = Just newAssignment } return (fieldType, entry, newNameBinding) onNameBinding Syntax.NameBinding{ nameLocation, name, annotation = Just annotation₀, assignment = Just assignment } = do let annotation₁ = Type.Optional { location = Syntax.location assignment , type_ = annotation₀ } context <- get newAssignment <- check assignment (Context.solveType context annotation₀) let fieldType = (name, annotation₁) let entry = Context.Annotation name annotation₀ let newNameBinding = Syntax.NameBinding { nameLocation , name , annotation = Just annotation₀ , assignment = Just newAssignment } return (fieldType, entry, newNameBinding) onBinding :: Binding Location Input -> Grace (Type Location, Context Location, Binding Location Void) onBinding Syntax.PlainBinding{ plain } = do ((_, annotation), entry, newPlain) <- onNameBinding plain return (annotation, [ entry ], Syntax.PlainBinding{ plain = newPlain }) onBinding Syntax.RecordBinding{ fieldNamesLocation, fieldNames } = do tuples <- traverse onNameBinding fieldNames let (fieldTypes, entries, newFieldNames) = unzip3 tuples existential <- fresh push (Context.UnsolvedFields existential) let annotation = Type.Record { location = fieldNamesLocation , fields = Type.Fields fieldTypes (Monotype.UnsolvedFields existential) } let newBinding = Syntax.RecordBinding { fieldNamesLocation , fieldNames = newFieldNames } return (annotation, entries, newBinding) onDefinition :: Definition Location Input -> Grace ((Text, Type Location), Definition Location Void) onDefinition Syntax.Definition { nameLocation , name , bindings , annotation = annotation₀ , assignment = assignment₀ } = do results <- traverse onBinding bindings let (inputs, entriess, newBindings) = unzip3 results annotation₁ <- case annotation₀ of Just annotation₁ -> do return annotation₁ Nothing -> do existential <- fresh preserve (Context.UnsolvedType existential) return Type.UnsolvedType { location = Syntax.location assignment₀ , existential } let nil = check assignment₀ annotation₁ assignment₁ <- foldr scoped nil (concat entriess) context <- get let newDefinition = Syntax.Definition { nameLocation , name , bindings = newBindings , annotation = annotation₀ , assignment = solveSyntax context assignment₁ } let cons input output = Type.Function { location = nameLocation , input , output } let annotation₂ = Context.solveType context (foldr cons annotation₁ inputs) let fieldType = (name, annotation₂) return (fieldType, newDefinition) {-| This corresponds to the judgment: > Γ ⊢ e ⇒ A ⊣ Δ … which infers the type of e under input context Γ, producing an inferred type of A and an updated context Δ. -} infer :: Syntax Location Input -> Grace (Type Location, Syntax Location Void) infer e₀ = do let input ~> output = Type.Function{ location = Syntax.location e₀, ..} let var name = Type.VariableType{ location = Syntax.location e₀, name, .. } case e₀ of Syntax.Variable{ location, name } -> do _Γ <- get inferred <- Context.lookup name _Γ `orDie` UnboundVariable location name return (inferred, Syntax.Variable{ location, name }) Syntax.Lambda{ location, binding, body } -> do (input, entries, newBinding) <- onBinding binding existential <- fresh preserve (Context.UnsolvedType existential) let output = Type.UnsolvedType { location = Syntax.location body , existential } let done = do newBody <- check body output context <- get let inferred = Type.Function{ location, input, output } let newLambda = Syntax.Lambda { location , binding = newBinding , body = newBody } -- TODO: Only `solveSyntax` `newBinding` return (Context.solveType context inferred, solveSyntax context newLambda) foldr scoped done entries Syntax.Application{ location, function, argument } -> do (functionType, newFunction) <- infer function context₀ <- get (inferred, newArgument) <- inferApplication (Context.solveType context₀ functionType) argument context₁ <- get let syntax = Syntax.Application { location , function = solveSyntax context₁ newFunction , argument = newArgument } return (inferred, syntax) Syntax.Annotation{ annotated = annotated₀, annotation, location } -> do context <- get wellFormed context annotation annotated₁ <- check annotated₀ annotation case annotated₁ of Syntax.Annotation{ annotated = annotated₂ } -> do return (annotation, Syntax.Annotation{ annotated = annotated₂, annotation, location }) _ -> do return (annotation, Syntax.Annotation{ annotated = annotated₁, annotation, location }) Syntax.Let{ location, assignments, body } -> do let cons Syntax.Define{ assignmentLocation, definition } action = do ((name, annotation), newDefinition) <- onDefinition definition let entry = Context.Annotation name annotation let newAssignment = Syntax.Define { assignmentLocation , definition = newDefinition } scoped entry do (newAssignments, newBody) <- action return (newAssignment : newAssignments, newBody) cons Syntax.Bind{ assignmentLocation, monad, binding, assignment = value } action = do (annotation₀, newEntries, newBinding) <- onBinding binding (newAssignments, newBody) <- foldr scoped action newEntries let annotation₁ = case monad of IdentityMonad -> annotation₀ ListMonad -> Type.List { location = assignmentLocation , type_ = annotation₀ } OptionalMonad -> Type.Optional { location = assignmentLocation , type_ = annotation₀ } newValue <- check value annotation₁ let newAssignment = Syntax.Bind { assignmentLocation , monad , binding = newBinding , assignment = newValue } return (newAssignment : newAssignments, newBody) b <- fresh push (Context.UnsolvedType b) let unsolved = Type.UnsolvedType { location = Syntax.location body , existential = b } let nil = do newBody <- check body unsolved return ([], newBody) (newAssignments, newBody) <- foldr cons nil assignments let listMonad = do Syntax.Bind{ assignmentLocation, monad = ListMonad } <- toList assignments return assignmentLocation let optionalMonad = do Syntax.Bind{ assignmentLocation, monad = OptionalMonad } <- toList assignments return assignmentLocation output <- case (listMonad, optionalMonad) of (location₀ : _, location₁ : _) -> do Exception.throwIO AssignmentMismatch { location₀ , location₁ } (_: _, []) -> do return Type.List { location , type_ = unsolved } ([], _ : _) -> do return Type.Optional { location , type_ = unsolved } ([], []) -> do return unsolved let newLet = Syntax.Let { location , assignments = NonEmpty.fromList newAssignments , body = newBody } context <- get return (Context.solveType context output, solveSyntax context newLet) Syntax.List{ location, elements = elements₀ } -> do case Seq.viewl elements₀ of EmptyL -> do existential <- fresh push (Context.UnsolvedType existential) return (Type.List{ location, type_ = Type.UnsolvedType{..} }, Syntax.List{ location, elements = Seq.empty }) element₀ :< elements -> do (elementType₀, _) <- infer element₀ results <- traverse infer elements let (elementTypes, _) = unzip (toList results) let cons type₀ type₁ = do context <- get supertypeOf (Context.solveType context type₀) (Context.solveType context type₁) type_ <- Monad.foldM cons elementType₀ elementTypes let process element = do context <- get check element (Context.solveType context type_) newElements <- traverse process (element₀ <| elements) context <- get let inferred = Type.List{ location, type_ } let newList = Syntax.List { location , elements = fmap (solveSyntax context) newElements } return (inferred, newList) Syntax.Record{ location, fieldValues } -> do result <- traverse onDefinition fieldValues let (fieldTypes, newFieldValues) = unzip result let inferred = Type.Record { location , fields = Type.Fields fieldTypes Monotype.EmptyFields } let newRecord = Syntax.Record { location , fieldValues = newFieldValues } return (inferred, newRecord) Syntax.Alternative{ location, name, argument } -> do (argumentType, newArgument) <- infer argument alternatives <- fresh push (Context.UnsolvedAlternatives alternatives) let inferred = Type.Union { location , alternatives = Type.Alternatives [(name, argumentType)] (Monotype.UnsolvedAlternatives alternatives) } let newAlternative = Syntax.Alternative { location , name , argument = newArgument } return (inferred, newAlternative) Syntax.Fold{ location, handlers } -> do let boolFold = do existential <- fresh push (Context.UnsolvedType existential) let bool = Type.UnsolvedType{ location, existential } newHandlers <- check handlers Type.Record { location , fields = Type.Fields [ ("false", bool) , ("true", bool) ] Monotype.EmptyFields } let type_ = Type.Function { location , input = Type.Scalar { location , scalar = Monotype.Bool } , output = bool } let newFold = Syntax.Fold { location , handlers = newHandlers } return (type_, newFold) let naturalFold = do existential <- fresh push (Context.UnsolvedType existential) let natural = Type.UnsolvedType{ location, existential } newHandlers <- check handlers Type.Record { location , fields = Type.Fields [ ( "zero", natural ) , ( "succ" , Type.Function { location , input = natural , output = natural } ) ] Monotype.EmptyFields } let type_ = Type.Function { location , input = Type.Scalar { location , scalar = Monotype.Natural } , output = natural } let newFold = Syntax.Fold { location , handlers = newHandlers } return (type_, newFold) let optionalFold = do existential₀ <- fresh push (Context.UnsolvedType existential₀) let element = Type.UnsolvedType { location , existential = existential₀ } existential₁ <- fresh push (Context.UnsolvedType existential₁) let optional = Type.UnsolvedType { location , existential = existential₁ } newHandlers <- check handlers Type.Record { location , fields = Type.Fields [ ( "null", optional ) , ( "some" , Type.Function { location , input = element , output = optional } ) ] Monotype.EmptyFields } let type_ = Type.Function { location , input = Type.Optional { location , type_ = element } , output = optional } let newFold = Syntax.Fold { location , handlers = newHandlers } return (type_, newFold) let listFold = do existential₀ <- fresh push (Context.UnsolvedType existential₀) let element = Type.UnsolvedType { location , existential = existential₀ } existential₁ <- fresh push (Context.UnsolvedType existential₁) let list = Type.UnsolvedType { location , existential = existential₁ } newHandlers <- check handlers Type.Record { location , fields = Type.Fields [ ( "nil", list ) , ( "cons" , Type.Function { location , input = element , output = Type.Function { location , input = list , output = list } } ) ] Monotype.EmptyFields } let type_ = Type.Function { location , input = Type.List { location , type_ = element } , output = list } let newFold = Syntax.Fold { location , handlers = newHandlers } return (type_, newFold) let jsonFold = do existential <- fresh push (Context.UnsolvedType existential) let json = Type.UnsolvedType{ location, existential } newHandlers <- check handlers Type.Record { location , fields = Type.Fields [ ( "array" , Type.Function { location , input = Type.List { location , type_ = json } , output = json } ) , ( "bool" , Type.Function { location , input = Type.Scalar { location , scalar = Monotype.Bool } , output = json } ) , ( "integer" , Type.Function { location , input = Type.Scalar { location , scalar = Monotype.Integer } , output = json } ) , ( "natural" , Type.Function { location , input = Type.Scalar { location , scalar = Monotype.Natural } , output = json } ) , ( "null", json ) , ( "object" , Type.Function { location , input = Type.List { location , type_ = Type.Record { location , fields = Type.Fields [ ( "key" , Type.Scalar { location , scalar = Monotype.Text } ) , ( "value", json) ] Monotype.EmptyFields } } , output = json } ) , ( "real" , Type.Function { location , input = Type.Scalar { location , scalar = Monotype.Real } , output = json } ) , ( "string" , Type.Function { location , input = Type.Scalar { location , scalar = Monotype.Text } , output = json } ) ] Monotype.EmptyFields } let type_ = Type.Function { location , input = Type.Scalar { location , scalar = Monotype.JSON } , output = json } let newFold = Syntax.Fold { location , handlers = newHandlers } return (type_, newFold) let fold maybeKeys = do keys <- case maybeKeys of Just keys -> do return keys Nothing -> do context₀ <- get existential₀ <- fresh push (Context.UnsolvedFields existential₀) let unsolvedRecord = Type.Fields [] (Monotype.UnsolvedFields existential₀) _ <- check handlers Type.Record { location , fields = unsolvedRecord } context₁ <- get let Type.Fields keyTypes _ = Context.solveRecord context₁ unsolvedRecord set context₀ return do (key, _) <- keyTypes return key existential₁ <- fresh push (Context.UnsolvedType existential₁) let union = Type.UnsolvedType { location , existential = existential₁ } let process key = do existential <- fresh push (Context.UnsolvedType existential) let alternativeType = Type.UnsolvedType { location , existential } let handlerType = Type.Function { location , input = alternativeType , output = union } return ((key, handlerType), (key, alternativeType)) results <- traverse process keys let (fieldTypes, alternativeTypes) = unzip results newHandlers <- check handlers Type.Record { location , fields = Type.Fields fieldTypes Monotype.EmptyFields } let type_ = Type.Function { location , input = Type.Union { location , alternatives = Type.Alternatives alternativeTypes Monotype.EmptyAlternatives } , output = union } let newFold = Syntax.Fold { location , handlers = newHandlers } return (type_, newFold) case handlers of -- Fast path if the handlers argument is a concrete record Syntax.Record{ fieldValues } -> do let fields = Set.fromList do Definition{ name } <- fieldValues return name if | Set.null fields -> do fold (Just (toList fields)) | Set.isSubsetOf fields [ "nil", "cons" ] -> do listFold | Set.isSubsetOf fields [ "null", "some" ] -> do optionalFold | Set.isSubsetOf fields [ "false", "true" ] -> do boolFold | Set.isSubsetOf fields [ "zero", "succ" ] -> do naturalFold | Set.isSubsetOf fields [ "array", "bool", "integer", "natural", "null", "object", "real", "string" ] -> do jsonFold | otherwise -> do fold (Just (toList fields)) -- Slow path: guess and check _ -> do context <- get listFold `Exception.catch` \(_ :: TypeInferenceError) -> do set context optionalFold `Exception.catch` \(_ :: TypeInferenceError) -> do set context boolFold `Exception.catch` \(_ :: TypeInferenceError) -> do set context naturalFold `Exception.catch` \(_ :: TypeInferenceError) -> do set context jsonFold `Exception.catch` \(_ :: TypeInferenceError) -> do set context fold Nothing Syntax.Project{ location, larger, smaller } -> do let processField Syntax.Field{ fieldLocation, field } = do existential <- fresh push (Context.UnsolvedType existential) return (field, Type.UnsolvedType{ location = fieldLocation, .. }) case smaller of Syntax.Single{ single } -> do let Syntax.Field{ fieldLocation, field } = single context <- get (largerType, newLarger₀) <- infer larger case largerType of Type.Record{ fields = Type.Fields fieldTypes _ } | Just type_ <- lookup field fieldTypes -> do return (type_, Syntax.Project{ location, larger = newLarger₀, smaller }) _ -> do set context p <- fresh push (Context.UnsolvedFields p) fieldType@(_, type_) <- processField single newLarger₁ <- check larger Type.Record { fields = Type.Fields [fieldType] (Monotype.UnsolvedFields p) , location = fieldLocation } return (type_, Syntax.Project{ larger = newLarger₁, .. }) Syntax.Multiple{ multipleLocation, multiple } -> do p <- fresh push (Context.UnsolvedFields p) fieldTypes <- traverse processField multiple newLarger <- check larger Type.Record { fields = Type.Fields fieldTypes (Monotype.UnsolvedFields p) , location = multipleLocation } let type_ = Type.Record { fields = Type.Fields fieldTypes Monotype.EmptyFields , location = multipleLocation } _Γ <- get return (type_, Syntax.Project{ larger = solveSyntax _Γ newLarger, .. }) Syntax.Index{ } -> do existential <- fresh push (Context.UnsolvedType existential) let element = Type.UnsolvedType{ location, existential } let listType = Type.List{ location, type_ = element } newLarger <- check larger listType let optional = Type.Optional{ location, type_ = element } return (optional, Syntax.Project{ location, larger = newLarger, .. }) Syntax.Slice{ } -> do existential <- fresh push (Context.UnsolvedType existential) let element = Type.UnsolvedType{ location, existential } let list = Type.List{ location, type_ = element } let optional = Type.Optional{ location, type_ = list } newLarger <- check larger list return (optional, Syntax.Project{ location, larger = newLarger, .. }) Syntax.If{ location, predicate, ifTrue, ifFalse} -> do newPredicate <- check predicate Type.Scalar { location , scalar = Monotype.Bool } (type₀, _) <- infer ifTrue (type₁, _) <- infer ifFalse context₀ <- get supertype <- supertypeOf (Context.solveType context₀ type₀) (Context.solveType context₀ type₁) newIfTrue <- check ifTrue supertype context₁ <- get newIfFalse <- check ifFalse (Context.solveType context₁ supertype) context₂ <- get let type_ = Context.solveType context₂ supertype let newIf = Syntax.If { location , predicate = solveSyntax context₁ newPredicate , ifTrue = solveSyntax context₁ newIfTrue , ifFalse = solveSyntax context₁ newIfFalse } return (type_, newIf) Syntax.Text{ chunks = Syntax.Chunks text₀ rest, .. } -> do let process (interpolation, text) = do newInterpolation <- check interpolation Type.Scalar{ scalar = Monotype.Text, .. } return (newInterpolation, text) newRest <- traverse process rest return (Type.Scalar{ scalar = Monotype.Text, .. }, Syntax.Text{ chunks = Syntax.Chunks text₀ newRest, .. }) Syntax.Prompt{ location, import_, arguments, schema } -> do let argumentsType = fmap (\_ -> location) (expected @Prompt) newArguments <- check arguments argumentsType newSchema <- case schema of Just t -> do return t Nothing -> do existential <- fresh preserve (Context.UnsolvedType existential) return Type.UnsolvedType{ location, existential } context <- get let newPrompt = Syntax.Prompt { location , import_ , arguments = solveSyntax context newArguments , schema = Just newSchema } return (newSchema, newPrompt) Syntax.HTTP{ location, import_, arguments, schema } -> do let argumentsType = fmap (\_ -> location) (expected @HTTP) newArguments <- check arguments argumentsType newSchema <- case schema of Just output -> do return output Nothing -> do existential <- fresh preserve (Context.UnsolvedType existential) return Type.UnsolvedType{ location, existential } context <- get let newHTTP = Syntax.HTTP { location , import_ , arguments = solveSyntax context newArguments , schema = Just newSchema } return (newSchema, newHTTP) Syntax.Read{ location, import_, arguments, schema } -> do let argumentsType = fmap (\_ -> location) (expected @Text) newArguments <- check arguments argumentsType newSchema <- case schema of Just output -> do return output Nothing -> do existential <- fresh preserve (Context.UnsolvedType existential) return Type.UnsolvedType{ location, existential } context <- get let newRead = Syntax.Read { location , import_ , arguments = solveSyntax context newArguments , schema = Just newSchema } return (newSchema, newRead) Syntax.GitHub{ location, import_, arguments, schema } -> do let argumentsType = fmap (\_ -> location) (expected @GitHub) newArguments <- check arguments argumentsType newSchema <- case schema of Just output -> do return output Nothing -> do existential <- fresh preserve (Context.UnsolvedType existential) return Type.UnsolvedType{ location, existential} context <- get let newGitHub = Syntax.GitHub { location , import_ , arguments = solveSyntax context newArguments , schema = Just newSchema } return (newSchema, newGitHub) Syntax.Show{ location, export, arguments, schema } -> do let json = Type.Scalar { location , scalar = Monotype.JSON } input <- case schema of Just input -> do Monad.unless export do isSubtypeOfJSON location input return input Nothing | export -> do existential <- fresh push (Context.UnsolvedType existential) return Type.UnsolvedType { location , existential } | otherwise -> do return json newArguments <- check arguments input context <- get let newShow = Syntax.Show { location , export , arguments = solveSyntax context newArguments , schema = Just input } let type_ = Type.Scalar{ location, scalar = Monotype.Text } return (type_, newShow) -- All the type inference rules for scalars go here. This part is -- pretty self-explanatory: a scalar literal returns the matching -- scalar type. Syntax.Scalar{ scalar = Syntax.Bool bool, .. } -> do return (Type.Scalar{ scalar = Monotype.Bool, .. }, Syntax.Scalar{ scalar = Syntax.Bool bool, .. }) Syntax.Scalar{ scalar = Syntax.Real real, .. } -> do return (Type.Scalar{ scalar = Monotype.Real, .. }, Syntax.Scalar{ scalar = Syntax.Real real, .. }) Syntax.Scalar{ scalar = Syntax.Integer integer, .. } -> do return (Type.Scalar{ scalar = Monotype.Integer, .. }, Syntax.Scalar{ scalar = Syntax.Integer integer, .. }) Syntax.Scalar{ scalar = Syntax.Natural natural, .. } -> do return (Type.Scalar{ scalar = Monotype.Natural, .. }, Syntax.Scalar{ scalar = Syntax.Natural natural, .. }) Syntax.Scalar{ scalar = Syntax.Null, .. } -> do -- NOTE: You might think that you could just infer that `null` -- has type `forall (a : Type) . Optional a`. This does not work -- because it will lead to data structures with impredicative types -- if you store a `null` inside of, say, a `List`. existential <- fresh push (Context.UnsolvedType existential) return (Type.Optional{ type_ = Type.UnsolvedType{..}, .. }, Syntax.Scalar{ scalar = Syntax.Null, .. }) Syntax.Scalar{ scalar = Syntax.Key key, .. } -> do return (Type.Scalar{ scalar = Monotype.Key, .. }, Syntax.Scalar{ scalar = Syntax.Key key, .. }) Syntax.Operator{ operator = Syntax.And, .. } -> do let bool = Type.Scalar { location = operatorLocation , scalar = Monotype.Bool } newLeft <- check left bool newRight <- check right bool context₁ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₁ newLeft , operatorLocation , operator = Syntax.And , right = solveSyntax context₁ newRight } return (bool, newOperator) Syntax.Operator{ operator = Syntax.Or, .. } -> do let bool = Type.Scalar { location = operatorLocation , scalar = Monotype.Bool } newLeft <- check left bool newRight <- check right bool context₁ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₁ newLeft , operatorLocation , operator = Syntax.Or , right = solveSyntax context₁ newRight } return (bool, newOperator) Syntax.Operator{ operator = Syntax.Equal, .. } -> do (type₀, newLeft ) <- infer left (type₁, newRight) <- infer right context₀ <- get supertype <- supertypeOf (Context.solveType context₀ type₀) (Context.solveType context₀ type₁) _ <- check left supertype context₁ <- get _ <- check right (Context.solveType context₁ supertype) context₂ <- get let type₀' = Context.solveType context₂ type₀ let type₁' = Context.solveType context₂ type₁ let isEquatable Type.VariableType{ } = False isEquatable Type.UnsolvedType{ } = False isEquatable Type.Forall{ } = False isEquatable Type.Function{ } = False isEquatable Type.Scalar{ } = True isEquatable Type.Optional{ type_ } = isEquatable type_ isEquatable Type.List{ type_ } = isEquatable type_ isEquatable Type.Record{ fields = Type.Fields fieldTypes Monotype.EmptyFields } = all (isEquatable . snd) fieldTypes isEquatable Type.Record{ } = False isEquatable Type.Union{ alternatives = Type.Alternatives alternativeTypes Monotype.EmptyAlternatives } = all (isEquatable . snd) alternativeTypes isEquatable Type.Union{ } = False let bool = Type.Scalar { location = operatorLocation , scalar = Monotype.Bool } let newOperator = Syntax.Operator { location , left = solveSyntax context₁ newLeft , operatorLocation , operator = Syntax.Equal , right = solveSyntax context₁ newRight } if isEquatable type₀' && isEquatable type₁' then return (bool, newOperator) else Exception.throwIO (InvalidOperands "compare" (Syntax.location left) (Syntax.location right)) Syntax.Operator{ operator = Syntax.NotEqual, .. } -> do (type₀, newLeft ) <- infer left (type₁, newRight) <- infer right context₀ <- get supertype <- supertypeOf (Context.solveType context₀ type₀) (Context.solveType context₀ type₁) _ <- check left supertype context₁ <- get _ <- check right (Context.solveType context₁ supertype) context₂ <- get let type₀' = Context.solveType context₂ type₀ let type₁' = Context.solveType context₂ type₁ let isEquatable Type.VariableType{ } = False isEquatable Type.UnsolvedType{ } = False isEquatable Type.Forall{ } = False isEquatable Type.Function{ } = False isEquatable Type.Scalar{ } = True isEquatable Type.Optional{ type_ } = isEquatable type_ isEquatable Type.List{ type_ } = isEquatable type_ isEquatable Type.Record{ fields = Type.Fields fieldTypes Monotype.EmptyFields } = all (isEquatable . snd) fieldTypes isEquatable Type.Record{ } = False isEquatable Type.Union{ alternatives = Type.Alternatives alternativeTypes Monotype.EmptyAlternatives } = all (isEquatable . snd) alternativeTypes isEquatable Type.Union{ } = False let bool = Type.Scalar { location = operatorLocation , scalar = Monotype.Bool } let newOperator = Syntax.Operator { location , left = solveSyntax context₁ newLeft , operatorLocation , operator = Syntax.NotEqual , right = solveSyntax context₁ newRight } if isEquatable type₀' && isEquatable type₁' then return (bool, newOperator) else Exception.throwIO (InvalidOperands "compare" (Syntax.location left) (Syntax.location right)) Syntax.Operator{ operator = Syntax.LessThan, .. } -> do let real = Type.Scalar { location = operatorLocation , scalar = Monotype.Real } newLeft <- check left real newRight <- check right real let bool = Type.Scalar { location = operatorLocation , scalar = Monotype.Bool } context₁ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₁ newLeft , operatorLocation , operator = Syntax.LessThan , right = solveSyntax context₁ newRight } return (bool, newOperator) Syntax.Operator{ operator = Syntax.LessThanOrEqual, .. } -> do let real = Type.Scalar { location = operatorLocation , scalar = Monotype.Real } newLeft <- check left real newRight <- check right real let bool = Type.Scalar { location = operatorLocation , scalar = Monotype.Bool } context₁ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₁ newLeft , operatorLocation , operator = Syntax.LessThanOrEqual , right = solveSyntax context₁ newRight } return (bool, newOperator) Syntax.Operator{ operator = Syntax.GreaterThan, .. } -> do let real = Type.Scalar { location = operatorLocation , scalar = Monotype.Real } newLeft <- check left real newRight <- check right real let bool = Type.Scalar { location = operatorLocation , scalar = Monotype.Bool } context₁ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₁ newLeft , operatorLocation , operator = Syntax.GreaterThan , right = solveSyntax context₁ newRight } return (bool, newOperator) Syntax.Operator{ operator = Syntax.GreaterThanOrEqual, .. } -> do let real = Type.Scalar { location = operatorLocation , scalar = Monotype.Real } newLeft <- check left real newRight <- check right real let bool = Type.Scalar { location = operatorLocation , scalar = Monotype.Bool } context₁ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₁ newLeft , operatorLocation , operator = Syntax.GreaterThanOrEqual , right = solveSyntax context₁ newRight } return (bool, newOperator) Syntax.Operator{ operator = Syntax.Times, .. } -> do context₁ <- get let natural = Type.Scalar { location = operatorLocation , scalar = Monotype.Natural } let integer = Type.Scalar { location = operatorLocation , scalar = Monotype.Integer } let real = Type.Scalar { location = operatorLocation , scalar = Monotype.Real } let naturalArguments = do newLeft <- check left natural newRight <- check right natural context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Times , right = solveSyntax context₂ newRight } return (natural, newOperator) let integerArguments = do newLeft <- check left integer newRight <- check right integer context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Times , right = solveSyntax context₂ newRight } return (integer, newOperator) let realArguments = do newLeft <- check left real newRight <- check right real context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Times , right = solveSyntax context₂ newRight } return (real, newOperator) naturalArguments `Exception.catch` \(_ :: TypeInferenceError) -> do set context₁ integerArguments `Exception.catch` \(_ :: TypeInferenceError) -> do set context₁ realArguments `Exception.catch` \(_ :: TypeInferenceError) -> do Exception.throwIO (InvalidOperands "multiply" (Syntax.location left) (Syntax.location right)) Syntax.Operator{ operator = Syntax.Plus, .. } -> do context₁ <- get let natural = Type.Scalar { location = operatorLocation , scalar = Monotype.Natural } let integer = Type.Scalar { location = operatorLocation , scalar = Monotype.Integer } let real = Type.Scalar { location = operatorLocation , scalar = Monotype.Real } let text = Type.Scalar { location = operatorLocation , scalar = Monotype.Text } let naturalArguments = do newLeft <- check left natural newRight <- check right natural context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Plus , right = solveSyntax context₂ newRight } return (natural, newOperator) let integerArguments = do newLeft <- check left integer newRight <- check right integer context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Plus , right = solveSyntax context₂ newRight } return (integer, newOperator) let realArguments = do newLeft <- check left real newRight <- check right real context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Plus , right = solveSyntax context₂ newRight } return (real, newOperator) let textArguments = do newLeft <- check left text newRight <- check right text context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Plus , right = solveSyntax context₂ newRight } return (text, newOperator) let listArguments = do existential <- fresh push (Context.UnsolvedType existential) let element = Type.UnsolvedType { location = operatorLocation , existential } let list = Type.List { location = operatorLocation , type_ = element } newLeft <- check left list newRight <- check right list context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Plus , right = solveSyntax context₂ newRight } return (list, newOperator) naturalArguments `Exception.catch` \(_ :: TypeInferenceError) -> do set context₁ integerArguments `Exception.catch` \(_ :: TypeInferenceError) -> do set context₁ realArguments `Exception.catch` \(_ :: TypeInferenceError) -> do set context₁ textArguments `Exception.catch` \(_ :: TypeInferenceError) -> do set context₁ listArguments `Exception.catch` \(_ :: TypeInferenceError) -> do Exception.throwIO (InvalidOperands "add" (Syntax.location left) (Syntax.location right)) Syntax.Operator{ operator = Syntax.Minus, .. } -> do context₁ <- get let natural = Type.Scalar { location = operatorLocation , scalar = Monotype.Natural } let integer = Type.Scalar { location = operatorLocation , scalar = Monotype.Integer } let real = Type.Scalar { location = operatorLocation , scalar = Monotype.Real } let naturalArguments = do newLeft <- check left natural newRight <- check right natural context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Minus , right = solveSyntax context₂ newRight } return (integer, newOperator) let integerArguments = do newLeft <- check left integer newRight <- check right integer context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Minus , right = solveSyntax context₂ newRight } return (integer, newOperator) let realArguments = do newLeft <- check left real newRight <- check right real context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Minus , right = solveSyntax context₂ newRight } return (real, newOperator) naturalArguments `Exception.catch` \(_ :: TypeInferenceError) -> do set context₁ integerArguments `Exception.catch` \(_ :: TypeInferenceError) -> do set context₁ realArguments `Exception.catch` \(_ :: TypeInferenceError) -> do Exception.throwIO (InvalidOperands "subtract" (Syntax.location left) (Syntax.location right)) Syntax.Operator{ operator = Syntax.Modulus, .. } -> do let natural = Type.Scalar { location = operatorLocation , scalar = Monotype.Natural } let integer = Type.Scalar { location = operatorLocation , scalar = Monotype.Integer } let real = Type.Scalar { location = operatorLocation , scalar = Monotype.Real } newRight <- case right of Syntax.Scalar{ scalar = Syntax.Natural 0 } -> do Exception.throwIO (ZeroDivisor (Syntax.location right)) Syntax.Scalar{ scalar = Syntax.Natural n, location = l } -> do return Syntax.Scalar{ scalar = Syntax.Natural n, location = l } _ -> do Exception.throwIO (NeedConcreteDivisor (Syntax.location right)) context₁ <- get let naturalArgument = do newLeft <- check left natural let type_ = Type.Record { location = operatorLocation , fields = Type.Fields [ ("quotient", natural) , ("remainder", natural) ] Monotype.EmptyFields } context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Modulus , right = solveSyntax context₂ newRight } return (type_, newOperator) let integerArgument = do newLeft <- check left integer let type_ = Type.Record { location = operatorLocation , fields = Type.Fields [ ("quotient", integer) , ("remainder", natural) ] Monotype.EmptyFields } context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Modulus , right = solveSyntax context₂ newRight } return (type_, newOperator) let realArgument = do newLeft <- check left real let type_ = Type.Record { location = operatorLocation , fields = Type.Fields [ ("quotient", integer) , ("remainder", real) ] Monotype.EmptyFields } context₂ <- get let newOperator = Syntax.Operator { location , left = solveSyntax context₂ newLeft , operatorLocation , operator = Syntax.Modulus , right = solveSyntax context₂ newRight } return (type_, newOperator) naturalArgument `Exception.catch` \(_ :: TypeInferenceError) -> do set context₁ integerArgument `Exception.catch` \(_ :: TypeInferenceError) -> do set context₁ realArgument `Exception.catch` \(_ :: TypeInferenceError) -> do Exception.throwIO (InvalidOperands "divide" (Syntax.location left) (Syntax.location right)) Syntax.Operator{ operator = Syntax.Divide, .. } -> do let real = Type.Scalar { location = operatorLocation , scalar = Monotype.Real } newLeft <- check left real newRight <- check right real context <- get let newOperator = Syntax.Operator { location , left = solveSyntax context newLeft , operatorLocation , operator = Syntax.Divide , right = solveSyntax context newRight } return (real, newOperator) Syntax.Builtin{ builtin = Syntax.Some, .. }-> do return ( Type.Forall { nameLocation = Syntax.location e₀ , name = "a" , domain = Domain.Type , type_ = var "a" ~> Type.Optional{ type_ = var "a", .. } , .. } , Syntax.Builtin{ builtin = Syntax.Some, .. } ) Syntax.Builtin{ builtin = Syntax.YAML, .. } -> do return ( Type.Scalar{ scalar = Monotype.JSON, .. } ~> Type.Scalar{ scalar = Monotype.Text, .. } , Syntax.Builtin{ builtin = Syntax.YAML, .. } ) Syntax.Builtin{ builtin = Syntax.Indexed, .. } -> do return ( Type.Forall { nameLocation = Syntax.location e₀ , name = "a" , domain = Domain.Type , type_ = Type.List{ type_ = var "a", .. } ~> Type.List { type_ = Type.Record { fields = Type.Fields [ ("index", Type.Scalar{ scalar = Monotype.Natural, .. }) , ("value", var "a") ] Monotype.EmptyFields , .. } , .. } , .. } , Syntax.Builtin{ builtin = Syntax.Indexed, .. } ) Syntax.Builtin{ builtin = Syntax.Length, .. } -> do return ( Type.Forall { nameLocation = Syntax.location e₀ , name = "a" , domain = Domain.Type , type_ = Type.List{ type_ = var "a", .. } ~> Type.Scalar{ scalar = Monotype.Natural, .. } , .. } , Syntax.Builtin{ builtin = Syntax.Length, .. } ) Syntax.Builtin{ builtin = Syntax.Map, .. } -> do return ( Type.Forall { nameLocation = Syntax.location e₀ , name = "a" , domain = Domain.Type , type_ = Type.Forall { nameLocation = Syntax.location e₀ , name = "b" , domain = Domain.Type , type_ = (var "a" ~> var "b") ~> ( Type.List{ type_ = var "a", .. } ~> Type.List{ type_ = var "b", .. } ) , .. } , .. } , Syntax.Builtin{ builtin = Syntax.Map, .. } ) Syntax.Builtin{ builtin = Syntax.Abs, .. } -> do return ( Type.Scalar{ scalar = Monotype.Integer, .. } ~> Type.Scalar{ scalar = Monotype.Natural, .. } , Syntax.Builtin{ builtin = Syntax.Abs, .. } ) Syntax.Builtin{ builtin = Syntax.Reveal, .. } -> do return ( Type.Scalar{ scalar = Monotype.Key, .. } ~> Type.Scalar{ scalar = Monotype.Text, .. } , Syntax.Builtin{ builtin = Syntax.Reveal, .. } ) Syntax.Embed{ embedded } -> do _Γ <- get input <- Reader.ask Reader.local (\i -> i <> embedded) do absolute <- Reader.ask Import.referentiallySane input absolute syntax <- liftIO (Import.resolve AsCode absolute) infer syntax {-| This corresponds to the judgment: > Γ ⊢ e ⇐ A ⊣ Δ … which checks that e has type A under input context Γ, producing an updated context Δ. -} check :: Syntax Location Input -> Type Location -> Grace (Syntax Location Void) -- The check function is the most important function to understand for the -- bidirectional type-checking algorithm. -- -- Most people, when they first run across the `check` function think that you -- could get rid of most rules except for the final `Sub` rule, but that's not -- true! -- -- The reason you should add `check` rules for many more types (especially -- complex types) is to ensure that subtyping rules work correctly. For -- example, consider this expression: -- -- [ 2, -3 ] -- -- If you omit the `check` rule for `List`s then the above expression will -- fail to type-check because the first element of the list is a `Natural` -- number and the second element of the `List` is an `Integer`. -- -- However, if you keep the `check` rule for `List`s and add a type annotation: -- -- [ 2, -3 ] : List Integer -- -- … then it works because the interpreter knows to treat both elements as an -- `Integer`. -- -- In general, if you want subtyping to work reliably then you need to add -- more cases to the `check` function so that the interpreter can propagate -- top-level type annotations down to the "leaves" of your syntax tree. If -- you do this consistently then the user only ever needs to provide top-level -- type annotations to fix any type errors that they might encounter, which is -- a desirable property! check Syntax.Lambda{ location, binding = Syntax.PlainBinding{ plain = Syntax.NameBinding{ name, nameLocation, annotation = Nothing, assignment = Nothing } }, body } Type.Function{ input, output } = do scoped (Context.Annotation name input) do let newBinding = Syntax.PlainBinding { plain = Syntax.NameBinding { nameLocation , name , annotation = Nothing , assignment = Nothing } } newBody <- check body output return Syntax.Lambda{ location, binding = newBinding, body = newBody } check annotated Type.Function{ input, output } = do let candidates₀ = Set.fromList (map Text.singleton [ 'a' .. 'z' ]) let free = Syntax.freeVariables annotated let name = case Set.toList (Set.difference candidates₀ free) of n : _ -> n _ -> let as = Set.filter (Text.isPrefixOf "a") free in head do suffix <- [ (0 :: Int) .. ] let candidate = Text.pack ("a" <> show suffix) Monad.guard (not (Set.member candidate as)) return candidate let nameLocation = Type.location input scoped (Context.Annotation name input) do let argument = Syntax.Variable{ location = nameLocation, name } let body = Syntax.Application { location = Syntax.location annotated , function = annotated , argument } context <- get newBody <- check body (Context.solveType context output) case newBody of Syntax.Application{ function = newAnnotated, argument = Syntax.Variable{ name = newName } } | name == newName && not (Syntax.usedIn name newAnnotated) -> return newAnnotated _ -> do return Syntax.Lambda { location = Syntax.location annotated , binding = Syntax.PlainBinding { plain = Syntax.NameBinding { name , nameLocation , annotation = Nothing , assignment = Nothing } } , body = newBody } check e Type.Forall{..} = do scoped (Context.Variable domain name) do check e type_ check Syntax.Let{ location, assignments, body = body₀ } annotation₀ = do let cons Syntax.Define{ assignmentLocation, definition } action = do ((name, annotation₁), newDefinition) <- onDefinition definition let entry = Context.Annotation name annotation₁ let newAssignment = Syntax.Define { assignmentLocation , definition = newDefinition } scoped entry do (newAssignments, newBody) <- action return (newAssignment : newAssignments, newBody) cons Syntax.Bind{ assignmentLocation, monad, binding, assignment = value } action = do (annotation₁, newEntries, newBinding) <- onBinding binding (newAssignments, newBody) <- foldr scoped action newEntries let annotation₂ = case monad of ListMonad -> Type.List { location = assignmentLocation , type_ = annotation₁ } OptionalMonad -> Type.Optional { location = assignmentLocation , type_ = annotation₁ } IdentityMonad -> annotation₁ newValue <- check value annotation₂ let newAssignment = Syntax.Bind { assignmentLocation , monad , binding = newBinding , assignment = newValue } return (newAssignment : newAssignments, newBody) let nil = do let listMonad = do Syntax.Bind{ assignmentLocation, monad = ListMonad } <- toList assignments return assignmentLocation let optionalMonad = do Syntax.Bind{ assignmentLocation, monad = OptionalMonad } <- toList assignments return assignmentLocation newBody <- case (listMonad, optionalMonad) of (location₀ : _, location₁ : _) -> do Exception.throwIO AssignmentMismatch { location₀ , location₁ } (location₀ : _, []) -> do let body₁ = Syntax.List { location = location₀ , elements = [ body₀ ] } body₂ <- check body₁ annotation₀ case body₂ of Syntax.List{ elements = [ body₃ ] } -> return body₃ _ -> error "Grace.Infer.check: unexpected return value" ([], location₁ : _) -> do let body₁ = Syntax.Application { location = location₁ , function = Syntax.Builtin { location = location₁ , builtin = Syntax.Some } , argument = body₀ } body₂ <- check body₁ annotation₀ case body₂ of Syntax.Application{ argument = body₃ } -> return body₃ _ -> error "Grace.Infer.check: unexpected return value" ([], []) -> do check body₀ annotation₀ return ([], newBody) (newAssignments, newBody) <- foldr cons nil assignments let newLet = Syntax.Let { location , assignments = NonEmpty.fromList newAssignments , body = newBody } context <- get return (solveSyntax context newLet) check Syntax.Alternative{ location, name, argument } annotation@Type.Union{ alternatives = Type.Alternatives alternativeTypes remainingAlternatives } = do existential <- fresh push (Context.UnsolvedAlternatives existential) case lookup name alternativeTypes of Just innerType₁ -> do newArgument <- check argument innerType₁ return Syntax.Alternative{ location, name, argument = newArgument } Nothing -> do (innerType₀, newArgument) <- infer argument let alternatives = Type.Alternatives [ (name, innerType₀) ] (Monotype.UnsolvedAlternatives existential) case remainingAlternatives of Monotype.UnsolvedAlternatives p -> do instantiateAlternativesR location alternatives p return Syntax.Alternative { location , name , argument = newArgument } _ -> do let actual = Type.Union{ location, alternatives } Exception.throwIO (UnionTypeMismatch actual annotation [ name ]) check Syntax.Prompt{ schema = Nothing, .. } annotation = do newArguments <- check arguments (fmap (\_ -> location) (expected @Prompt)) return Syntax.Prompt{ arguments = newArguments, schema = Just annotation, .. } check Syntax.HTTP{ import_, schema = Nothing, .. } annotation = do let input = fmap (\_ -> location) (expected @HTTP) newArguments <- check arguments input Monad.unless import_ do context <- get isSubtypeOfJSON location (Context.solveType context annotation) context <- get return Syntax.HTTP{ arguments = newArguments, schema = Just (Context.solveType context annotation), .. } check Syntax.Read{ import_, schema = Nothing, .. } annotation = do newArguments <- check arguments (fmap (\_ -> location) (expected @Text)) Monad.unless import_ do context <- get isSubtypeOfJSON location (Context.solveType context annotation) context <- get return Syntax.Read{ arguments = newArguments, schema = Just (Context.solveType context annotation), .. } check Syntax.GitHub{ import_, schema = Nothing, .. } annotation = do let argumentsType = fmap (\_ -> location) (expected @GitHub) newArguments <- check arguments argumentsType Monad.unless import_ do context <- get isSubtypeOfJSON location (Context.solveType context annotation) context <- get return Syntax.GitHub{ arguments = newArguments, schema = Just (Context.solveType context annotation), .. } check Syntax.Project{ location, larger, smaller = smaller@Syntax.Single{ single = Syntax.Field{ fieldLocation, field } } } annotation = do context <- get (recordType, newLarger₀) <- infer larger case recordType of Type.Record{ fields = Type.Fields fieldTypes _ } | Just fieldType <- lookup field fieldTypes -> do subtype fieldType annotation return Syntax.Project{ location, larger = newLarger₀, smaller } _ -> do set context fields <- fresh push (Context.UnsolvedFields fields) newLarger₁ <- check larger Type.Record { fields = Type.Fields [(field, annotation)] (Monotype.UnsolvedFields fields) , location = fieldLocation } return Syntax.Project{ location, larger = newLarger₁, smaller } check Syntax.Project{ location, larger, smaller = smaller@Syntax.Multiple{ multiple } } Type.Record{ location = recordLocation, fields = Type.Fields fieldTypes rest } | let m₀ = Map.fromList do Syntax.Field{ field } <- multiple return (field, ()) , let m₁ = Map.fromList fieldTypes , Map.null (Map.difference m₀ m₁) = do let m = Map.intersectionWith (\_ type_ -> type_) m₀ m₁ let newAnnotation = Type.Record { location = recordLocation , fields = Type.Fields (Map.toList m) rest } newLarger <- check larger newAnnotation return Syntax.Project{ location, larger = newLarger, smaller } check Syntax.Project{ location, larger, smaller = smaller@Syntax.Slice{ } } Type.Optional{ type_ } = do newLarger <- check larger type_ return Syntax.Project{ location, larger = newLarger, smaller } check Syntax.Project{ location, larger, smaller = smaller@Syntax.Index{ } } Type.Optional{ type_ } = do newLarger <- check larger Type.List{ location, type_ } return Syntax.Project{ location, larger = newLarger, smaller } check Syntax.Scalar{ location, scalar = Syntax.Null } Type.Optional{ } = do return Syntax.Scalar{ location, scalar = Syntax.Null } check Syntax.Application{ location = location₀, function = Syntax.Builtin{ location = location₁, builtin = Syntax.Some }, argument } Type.Optional{ type_ } = do newArgument <- check argument type_ return Syntax.Application { location = location₀ , function = Syntax.Builtin { location = location₁ , builtin = Syntax.Some } , argument = newArgument } check annotated annotation@Type.Optional{ location, type_ = type₀ } = do let name = "x" (type₁, newAnnotated₀) <- infer annotated context₀ <- get case Context.solveType context₀ type₁ of Type.Optional{ type_ = type₂ } -> do scoped (Context.Annotation name type₂) do let nameLocation = Type.location type₀ let variable = Syntax.Variable{ location = nameLocation, name } context₁ <- get elaborated <- check variable (Context.solveType context₁ type₀) if elaborated == variable then do return newAnnotated₀ else do return Syntax.Let { location , assignments = [ Bind { assignmentLocation = location , monad = OptionalMonad , binding = PlainBinding { plain = NameBinding { nameLocation , name , annotation = Just type₂ , assignment = Nothing } } , assignment = newAnnotated₀ } ] , body = elaborated } Type.UnsolvedType{ existential } -> do instantiateTypeL existential (Context.solveType context₀ annotation) context₁ <- get return (solveSyntax context₁ newAnnotated₀) _ -> do newAnnotated₁ <- check annotated (Context.solveType context₀ type₀) context₁ <- get return Syntax.Application { location , function = Syntax.Builtin { location , builtin = Syntax.Some } , argument = solveSyntax context₁ newAnnotated₁ } check Syntax.Operator{ location, left, operatorLocation, operator = Syntax.Times, right } annotation@Type.Scalar{ scalar } | scalar `elem` ([ Monotype.Natural, Monotype.Integer, Monotype.Real ] :: [Monotype.Scalar]) = do newLeft <- check left annotation context <- get newRight <- check right (Context.solveType context annotation) return Syntax.Operator { location , left = newLeft , operatorLocation , operator = Syntax.Times , right = newRight } check Syntax.Operator{ location, left, operatorLocation, operator = Syntax.Plus, right } annotation@Type.Scalar{ scalar } | scalar `elem` ([ Monotype.Natural, Monotype.Integer, Monotype.Real, Monotype.Text ] :: [Monotype.Scalar]) = do newLeft <- check left annotation context <- get newRight <- check right (Context.solveType context annotation) return Syntax.Operator { location , left = newLeft , operatorLocation , operator = Syntax.Plus , right = newRight } check Syntax.Operator{ location, left, operatorLocation, operator = Syntax.Plus, right } annotation@Type.List{ } = do newLeft <- check left annotation context <- get newRight <- check right (Context.solveType context annotation) return Syntax.Operator { location , left = newLeft , operatorLocation , operator = Syntax.Plus , right = newRight } check Syntax.Operator{ location, left, operatorLocation, operator = Syntax.Minus, right } annotation@Type.Scalar{ scalar } | scalar `elem` ([ Monotype.Integer, Monotype.Real ] :: [Monotype.Scalar]) = do newLeft <- check left annotation context <- get newRight <- check right (Context.solveType context annotation) return Syntax.Operator { location , left = newLeft , operatorLocation , operator = Syntax.Minus , right = newRight } check Syntax.If{ location, predicate, ifTrue, ifFalse } annotation = do newPredicate <- check predicate Type.Scalar { location , scalar = Monotype.Bool } newIfTrue <- check ifTrue annotation newIfFalse <- check ifFalse annotation return Syntax.If { location , predicate = newPredicate , ifTrue = newIfTrue , ifFalse = newIfFalse } check Syntax.List{..} Type.List{ location = _, .. } = do let process element = do _Γ <- get check element (Context.solveType _Γ type_) newElements <- traverse process elements return Syntax.List{ elements = newElements, .. } check annotated@Syntax.Record{ location, fieldValues = fieldValues₀ } annotation@Type.Record{ fields = Type.Fields fieldTypes fields } = do let fieldValues₁ = do Syntax.Definition{ nameLocation, name, bindings, annotation = annotation₀, assignment } <- fieldValues₀ let newAssignment = case annotation₀ of Nothing -> assignment Just annotation₁ -> Syntax.Annotation { location = Syntax.location assignment , annotated = assignment , annotation = annotation₁ } let cons binding body = Syntax.Lambda { location = nameLocation , binding , body } let value = foldr cons newAssignment bindings return (name, value) let subFieldValues = Map.fromList fieldValues₁ let superFieldTypes = Map.fromList fieldTypes let both = Map.intersectionWith (,) subFieldValues superFieldTypes let extraValues = Map.difference subFieldValues superFieldTypes let extraTypes = Map.difference superFieldTypes subFieldValues isRequiredTypes <- traverse isFieldRequired extraTypes let extraRequiredTypes = Map.difference extraTypes (Map.filter not isRequiredTypes) let extraOptionalTypes = Map.difference extraTypes (Map.filter id isRequiredTypes) let process (field, (value, type_)) = do context <- get newValue <- check value (Context.solveType context type_) return (field, newValue) overlappingValues <- traverse process (Map.toList both) let convert (name, assignment) = Syntax.Definition { nameLocation = Syntax.location assignment , name , bindings = [] , annotation = Nothing , assignment } let extraRecordValue = Syntax.Record { location , fieldValues = map convert (Map.toList extraValues) } let extraRecordType = Type.Record { location = Type.location annotation , fields = Type.Fields (Map.toList extraRequiredTypes) fields } Monad.unless (null extraRequiredTypes) do -- TODO: Craft an exception just for this error path (inferred, _) <- infer extraRecordValue context <- get Exception.throwIO (RecordTypeMismatch (Context.solveType context inferred) (Context.solveType context extraRecordType) (Map.keys extraRequiredTypes)) let nullValues = do (field, type_) <- Map.toList extraOptionalTypes return (field, Syntax.Scalar{ location = Type.location type_, scalar = Syntax.Null }) nonOverlappingValues <- case fields of Monotype.UnsolvedFields p -> do results <- traverse infer extraValues let extraValueTypes = fmap fst results let newExtraValues = fmap snd results context <- get instantiateFieldsR (Syntax.location annotated) (Context.solveRecord context (Type.Fields (Map.toList extraValueTypes) Monotype.EmptyFields) ) p return newExtraValues _ -> do return Map.empty return Syntax.Record { location , fieldValues = map convert (overlappingValues <> nullValues <> Map.toList nonOverlappingValues) } check Syntax.Text{ chunks = Syntax.Chunks text₀ rest, .. } Type.Scalar{ scalar = Monotype.Text } = do let process (interpolation, text) = do newInterpolation <- check interpolation Type.Scalar{ scalar = Monotype.Text, .. } return (newInterpolation, text) newRest <- traverse process rest return Syntax.Text{ chunks = Syntax.Chunks text₀ newRest, .. } check Syntax.List{..} annotation@Type.Scalar{ scalar = Monotype.JSON } = do newElements <- traverse (`check` annotation) elements let annotated = Syntax.List{ elements = newElements, .. } return Syntax.Annotation { annotated, annotation, location = Syntax.location annotated } check Syntax.Record{ location, fieldValues } annotation₀@Type.Scalar{ scalar = Monotype.JSON } = do let process definition₀@Syntax.Definition{ bindings, annotation = annotation₁ } = do definition₁ <- case bindings of [] -> do case annotation₁ of Just annotation₂ -> do subtype annotation₂ annotation₀ Nothing -> do return () return (definition₀ :: Definition Location Input){ annotation = Just annotation₀ } _ -> do return definition₀ onDefinition definition₁ result <- traverse process fieldValues let (_, newFieldValues) = unzip result return Syntax.Record{ location, fieldValues = newFieldValues } check e@Syntax.Text{ } Type.Scalar{ scalar = Monotype.JSON, .. } = do check e Type.Scalar{ scalar = Monotype.Text, .. } check Syntax.Scalar{ scalar = Syntax.Natural natural, .. } Type.Scalar{ scalar = Monotype.JSON } = do return Syntax.Scalar{ scalar = Syntax.Natural natural, .. } check Syntax.Scalar{ scalar = Syntax.Integer integer, .. } Type.Scalar{ scalar = Monotype.JSON } = do return Syntax.Scalar{ scalar = Syntax.Integer integer, .. } check Syntax.Scalar{ scalar = Syntax.Real real, .. } Type.Scalar{ scalar = Monotype.JSON } = do return Syntax.Scalar{ scalar = Syntax.Real real, .. } check Syntax.Scalar{ scalar = Syntax.Bool bool, .. } Type.Scalar{ scalar = Monotype.JSON } = do return Syntax.Scalar{ scalar = Syntax.Bool bool, .. } check Syntax.Scalar{ scalar = Syntax.Null, .. } Type.Scalar{ scalar = Monotype.JSON } = do return Syntax.Scalar{ scalar = Syntax.Null, .. } check Syntax.Scalar{ scalar = Syntax.Natural n, .. } Type.Scalar{ scalar = Monotype.Real } = do return Syntax.Scalar{ scalar = Syntax.Real (fromIntegral n), .. } check Syntax.Scalar{ scalar = Syntax.Integer n, .. } Type.Scalar{ scalar = Monotype.Real } = do return Syntax.Scalar{ scalar = Syntax.Real (fromInteger n), .. } check Syntax.Scalar{ scalar = Syntax.Real n, .. } Type.Scalar{ scalar = Monotype.Real } = do return Syntax.Scalar{ scalar = Syntax.Real n, .. } check Syntax.Scalar{ scalar = Syntax.Natural n, .. } Type.Scalar{ scalar = Monotype.Integer } = do return Syntax.Scalar{ scalar = Syntax.Integer (fromIntegral n), .. } check Syntax.Scalar{ scalar = Syntax.Integer n, .. } Type.Scalar{ scalar = Monotype.Integer } = do return Syntax.Scalar{ scalar = Syntax.Integer n, .. } check Syntax.Scalar{ scalar = Syntax.Natural n, .. } Type.Scalar{ scalar = Monotype.Natural } = do return Syntax.Scalar{ scalar = Syntax.Natural n, .. } check annotated annotation@Type.Scalar{ scalar = Monotype.Real } = do (_A₀, newAnnotated) <- infer annotated context <- get let _A₁ = Context.solveType context _A₀ let real = do subtype _A₁ annotation return newAnnotated let integer = do subtype _A₁ Type.Scalar { scalar = Monotype.Integer , location = Syntax.location newAnnotated } return Syntax.Annotation { annotated = newAnnotated , annotation , location = Syntax.location newAnnotated } let natural = do subtype _A₁ Type.Scalar { scalar = Monotype.Natural , location = Syntax.location newAnnotated } return Syntax.Annotation { annotated = newAnnotated , annotation , location = Syntax.location newAnnotated } real `Exception.catch` \(_ :: TypeInferenceError) -> do integer `Exception.catch` \(_ :: TypeInferenceError) -> do natural `Exception.catch` \(_ :: TypeInferenceError) -> do subtype _A₁ annotation return newAnnotated check annotated annotation@Type.Scalar{ scalar = Monotype.Integer } = do (_A₀, newAnnotated) <- infer annotated context <- get let _A₁ = Context.solveType context _A₀ let integer = do subtype _A₁ annotation return newAnnotated let natural = do subtype _A₁ Type.Scalar { scalar = Monotype.Natural , location = Syntax.location newAnnotated } return Syntax.Annotation { annotated = newAnnotated , annotation , location = Syntax.location newAnnotated } integer `Exception.catch` \(_ :: TypeInferenceError) -> do natural `Exception.catch` \(_ :: TypeInferenceError) -> do subtype _A₁ annotation return newAnnotated check Syntax.Embed{ embedded } annotation = do context <- get input <- Reader.ask Reader.local (\i -> i <> embedded) do absolute <- Reader.ask Import.referentiallySane input absolute let mode = case Context.solveType context annotation of Type.Scalar{ scalar = Monotype.Text } -> AsText Type.Scalar{ scalar = Monotype.Key } -> AsKey _ -> AsCode syntax <- liftIO (Import.resolve mode absolute) check syntax annotation check Syntax.Text{ chunks = Syntax.Chunks text₀ [], .. } Type.Scalar{ scalar = Monotype.Key } = do return Syntax.Scalar{ scalar = Syntax.Key text₀, .. } check annotated annotation@Type.Scalar{ scalar = Monotype.Key } = do (_A₀, newAnnotated) <- infer annotated context <- get let _A₁ = Context.solveType context _A₀ let key = do subtype _A₁ annotation return newAnnotated let text = do subtype _A₁ Type.Scalar { scalar = Monotype.Text , location = Syntax.location newAnnotated } return Syntax.Annotation { annotated = newAnnotated , annotation , location = Syntax.location newAnnotated } key `Exception.catch` \(_ :: TypeInferenceError) -> do text `Exception.catch` \(_ :: TypeInferenceError) -> do subtype _A₁ annotation return newAnnotated -- Sub check e _B = do (_A, newE) <- infer e _Θ <- get subtype (Context.solveType _Θ _A) (Context.solveType _Θ _B) return newE {-| This corresponds to the judgment: > Γ ⊢ A • e ⇒⇒ C ⊣ Δ … which infers the result type C when a function of type A is applied to an input argument e, under input context Γ, producing an updated context Δ. -} inferApplication :: Type Location -> Syntax Location Input -> Grace (Type Location, Syntax Location Void) -- ∀App inferApplication Type.Forall{ domain = Domain.Type, .. } e = do a <- fresh push (Context.UnsolvedType a) let a' = Type.UnsolvedType{ location = nameLocation, existential = a} inferApplication (Type.substituteType name 0 a' type_) e inferApplication Type.Forall{ domain = Domain.Fields, .. } e = do a <- fresh push (Context.UnsolvedFields a) let a' = Type.Fields [] (Monotype.UnsolvedFields a) inferApplication (Type.substituteFields name 0 a' type_) e inferApplication Type.Forall{ domain = Domain.Alternatives, .. } e = do a <- fresh push (Context.UnsolvedAlternatives a) let a' = Type.Alternatives [] (Monotype.UnsolvedAlternatives a) inferApplication (Type.substituteAlternatives name 0 a' type_) e -- αApp inferApplication Type.UnsolvedType{ existential = a, .. } e = do _Γ <- get (_Γ', _Γ) <- Context.splitOnUnsolvedType a _Γ `orDie` MissingVariable a _Γ a₁ <- fresh a₂ <- fresh set (_Γ' <> (Context.SolvedType a (Monotype.Function (Monotype.UnsolvedType a₁) (Monotype.UnsolvedType a₂)) : Context.UnsolvedType a₁ : Context.UnsolvedType a₂ : _Γ)) newE <- check e Type.UnsolvedType{ existential = a₁, .. } return (Type.UnsolvedType{ existential = a₂, .. }, newE) inferApplication Type.Function{..} e = do newE <- check e input return (output, newE) inferApplication Type.VariableType{..} _ = do Exception.throwIO (NotNecessarilyFunctionType location name) inferApplication _A _ = do Exception.throwIO (NotFunctionType (location _A) _A) -- | Infer the `Type` of the given `Syntax` tree typeOf :: MonadIO m => Input -> Syntax Location Input -> m (Type Location, Syntax Location Void) typeOf input = typeWith input [] -- | Like `typeOf`, but accepts a custom type-checking `Context` typeWith :: MonadIO m => Input -> Context Location -> Syntax Location Input -> m (Type Location, Syntax Location Void) typeWith input context syntax = do let initialStatus = Status{ count = 0, context } ((_A, elaborated), Status{ context = _Δ }) <- Grace.runGrace input initialStatus (infer syntax) return (Context.complete _Δ _A, solveSyntax _Δ elaborated) solveSyntax :: Context s -> Syntax s a -> Syntax s a solveSyntax _Γ = Lens.transform (Lens.over Syntax.types (Context.solveType _Γ)) -- | Check if a given `Type` is a subtype of `Monotype.JSON` isSubtypeOfJSON :: Location -- ^ `Location` of the `Monotype.JSON` -> Type Location -- ^ Type being checked against `Monotype.JSON` -> Grace () isSubtypeOfJSON location = loop where loop Type.UnsolvedType{ existential } = do let json = Type.Scalar{ location, scalar = Monotype.JSON } instantiateTypeL existential json loop type_@Type.Scalar{ scalar } = do Monad.when (scalar == Monotype.Key) do Exception.throwIO (NotSubtypeOfJSON type_) loop Type.List{ type_ } = do loop type_ loop Type.Optional{ type_ } = do loop type_ loop type_@Type.Record{ fields = Type.Fields fieldTypes remainingFields } = do traverse_ (\(_, type₀) -> loop type₀) fieldTypes case remainingFields of Monotype.EmptyFields -> do return () Monotype.UnsolvedFields existential -> do instantiateFieldsL existential location (Type.Fields [] Monotype.EmptyFields) _ -> do Exception.throwIO (NotSubtypeOfJSON type_) loop type_ = do Exception.throwIO (NotSubtypeOfJSON type_) {-| This covers all the scalar subtyping rules /except/ for `Monotype.JSON`, which is handled by `isSubtypeOfJSON` -} isScalarSubtypeOf :: Monotype.Scalar -> Monotype.Scalar -> Bool isScalarSubtypeOf Monotype.Natural Monotype.Integer = True isScalarSubtypeOf Monotype.Natural Monotype.Real = True isScalarSubtypeOf Monotype.Integer Monotype.Real = True isScalarSubtypeOf Monotype.Text Monotype.Key = True isScalarSubtypeOf scalar₀ scalar₁ = scalar₀ == scalar₁ -- | Convert from JSON, inferring the value purely from the JSON data inferJSON :: Aeson.Value -> Value () inferJSON (Aeson.Object (Compat.sorted -> [("contents", contents), ("tag", Aeson.String tag)])) = Value.Alternative () tag value where value = inferJSON contents inferJSON (Aeson.Object object) = Value.Record () (Map.fromList keyValues) where keyValues = do (key, value) <- Map.toList (Compat.fromAesonMap object) return (key, ((), inferJSON value)) inferJSON (Aeson.Array vector) = Value.List () (Seq.fromList (toList elements)) where elements = fmap inferJSON vector inferJSON (Aeson.String text) = Value.Text () text inferJSON (Aeson.Number scientific) = case Scientific.floatingOrInteger scientific of Left (_ :: Double) -> Value.Scalar () (Syntax.Real scientific) Right (integer :: Integer) | 0 <= integer -> do Value.Scalar () (Syntax.Natural (fromInteger integer)) | otherwise -> do Value.Scalar () (Syntax.Integer integer) inferJSON (Aeson.Bool bool) = Value.Scalar () (Syntax.Bool bool) inferJSON Aeson.Null = Value.Scalar () Syntax.Null -- | Check an `Aeson.Value` against an expected `Type` checkJSON :: Type Location -> Aeson.Value -> Grace (Value ()) checkJSON = loop [] where loop path Type.Union{ Type.alternatives = Type.Alternatives alternativeTypes _ } (Aeson.Object (Compat.sorted -> [("contents", contents), ("tag", Aeson.String tag)])) | Just alternativeType <- Prelude.lookup tag alternativeTypes = do value <- loop ("contents" : path) alternativeType contents pure (Value.Alternative () tag value) loop path Type.Record{ Type.fields = Type.Fields fieldTypes _ } (Aeson.Object object) = do let properties = Compat.fromAesonMap object let process (field, type_) = do let property = case Map.lookup field properties of Just p -> p Nothing -> Aeson.Null expression <- loop (field : path) type_ property return (field, ((), expression)) fieldValues <- traverse process fieldTypes pure (Value.Record () (Map.fromList fieldValues)) loop path type_@Type.Scalar{ scalar = Monotype.JSON } (Aeson.Object object) = do let properties = Map.toList (Compat.fromAesonMap object) let process (key, property) = do expression <- loop (key : path) type_ property return (key, ((), expression)) textValues <- traverse process properties pure (Value.Record () (Map.fromList textValues)) loop path Type.List{ Type.type_ } (Aeson.Array vector) = do elements <- traverse (loop ("*" : path) type_) vector pure (Value.List () (Seq.fromList (toList elements))) loop path type_@Type.Scalar{ scalar = Monotype.JSON } (Aeson.Array vector) = do elements <- traverse (loop ("*" : path) type_) vector pure (Value.List () (Seq.fromList (toList elements))) loop _ Type.Scalar{ scalar = Monotype.Text } (Aeson.String text) = do pure (Value.Text () text) loop _ Type.Scalar{ scalar = Monotype.JSON } (Aeson.String text) = do pure (Value.Text () text) loop _ Type.Scalar{ scalar = Monotype.Real } (Aeson.Number scientific) = do pure (Value.Scalar () (Syntax.Real scientific)) loop path type_@Type.Scalar{ scalar = Monotype.Integer } value@(Aeson.Number scientific) = do case Scientific.floatingOrInteger @Double @Integer scientific of Right integer -> do pure (Value.Scalar () (Syntax.Integer integer)) _ -> do Exception.throwIO InvalidJSON{ path, value, type_ } loop path type_@Type.Scalar{ scalar = Monotype.Natural } value@(Aeson.Number scientific) = case Scientific.floatingOrInteger @Double @Integer scientific of Right integer | 0 <= integer -> do pure (Value.Scalar () (Syntax.Natural (fromInteger integer))) _ -> do Exception.throwIO InvalidJSON{ path, value, type_ } loop _ Type.Scalar{ scalar = Monotype.JSON } (Aeson.Number scientific) = case Scientific.floatingOrInteger scientific of Left (_ :: Double) -> do pure (Value.Scalar () (Syntax.Real scientific)) Right (integer :: Integer) | 0 <= integer -> do pure (Value.Scalar () (Syntax.Natural (fromInteger integer))) | otherwise -> do pure (Value.Scalar () (Syntax.Integer integer)) loop _ Type.Scalar{ Type.scalar = Monotype.Bool } (Aeson.Bool bool) = pure (Value.Scalar () (Syntax.Bool bool)) loop _ Type.Scalar{ Type.scalar = Monotype.JSON } (Aeson.Bool bool) = pure (Value.Scalar () (Syntax.Bool bool)) loop _ Type.Optional{ } Aeson.Null = pure (Value.Scalar () Syntax.Null) loop path Type.Optional{ type_ } value = do result <- loop path type_ value pure (Value.Application () (Value.Builtin () Syntax.Some) result) loop _ Type.Scalar{ scalar = Monotype.JSON } Aeson.Null = pure (Value.Scalar () Syntax.Null) loop _ type₀ value = do let bytes = Aeson.Pretty.encodePretty value text <- case Encoding.decodeUtf8' (ByteString.Lazy.toStrict bytes) of Left exception -> Exception.throwIO exception Right text -> return text let input = Code "(json)" text let mode = case type₀ of Type.Scalar{ scalar = Monotype.Text } -> AsText Type.Scalar{ scalar = Monotype.Key } -> AsKey _ -> AsCode expression <- liftIO (Import.resolve mode input) (type₁, _) <- infer expression context₀ <- get subtype (Context.solveType context₀ type₁) (Context.solveType context₀ type₀) let json = Type.Scalar { location = Type.location type₀ , scalar = Monotype.JSON } context₁ <- get subtype (Context.solveType context₁ type₁) json return (inferJSON value) -- | A data type holding all errors related to type inference data TypeInferenceError = IllFormedAlternatives Location (Existential Monotype.Union) (Context Location) | IllFormedFields Location (Existential Monotype.Record) (Context Location) | IllFormedType Location (Type Location) (Context Location) -- | InvalidOperands Text Location Location | ZeroDivisor Location | NeedConcreteDivisor Location -- | FoldInvalidHandler Location (Type Location) -- | MissingAllAlternatives (Existential Monotype.Union) (Context Location) | MissingAllFields (Existential Monotype.Record) (Context Location) | MissingOneOfTypes [Location] (Existential Monotype) (Existential Monotype) (Context Location) | MissingOneOfAlternatives [Location] (Existential Monotype.Union) (Existential Monotype.Union) (Context Location) | MissingOneOfFields [Location] (Existential Monotype.Record) (Existential Monotype.Record) (Context Location) | MissingVariable (Existential Monotype) (Context Location) -- | NotFunctionType Location (Type Location) | NotNecessarilyFunctionType Location Text -- | NotAlternativesSubtype Location (Existential Monotype.Union) (Type.Union Location) | NotFieldsSubtype Location (Existential Monotype.Record) (Type.Record Location) | NotSubtype (Type Location) (Type Location) | NotSubtypeOfJSON (Type Location) | NoSupertype (Type Location) (Type Location) | NoSubtype (Type Location) (Type Location) | NoUnionSubtype (Type Location) (Type Location) [Text] [Text] -- | UnboundAlternatives Location Text | UnboundFields Location Text | UnboundTypeVariable Location Text | UnboundVariable Location Text -- | RecordTypeMismatch (Type Location) (Type Location) [Text] | UnionTypeMismatch (Type Location) (Type Location) [Text] | FieldsVariableMismatch Location Monotype.RemainingFields Location Monotype.RemainingFields | AlternativesVariableMismatch Location Monotype.RemainingAlternatives Location Monotype.RemainingAlternatives -- deriving stock (Eq, Show) instance Exception TypeInferenceError where displayException (IllFormedAlternatives location a₀ _Γ) = "Internal error: Invalid context\n\ \\n\ \The following unsolved alternatives variable:\n\ \\n\ \" <> insert (Context.UnsolvedAlternatives a₀) <> "\n\ \\n\ \… is not well-formed within the following context:\n\ \\n\ \#{listToText _Γ}\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) displayException (IllFormedFields location a₀ _Γ) = "Internal error: Invalid context\n\ \\n\ \The following unsolved fields variable:\n\ \\n\ \" <> insert (Context.UnsolvedFields a₀) <> "\n\ \\n\ \… is not well-formed within the following context:\n\ \\n\ \" <> listToText _Γ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) displayException (IllFormedType location _A _Γ) = "Internal error: Invalid context\n\ \\n\ \The following type:\n\ \\n\ \" <> insert _A <> "\n\ \\n\ \… is not well-formed within the following context:\n\ \\n\ \" <> listToText _Γ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) displayException (InvalidOperands action left right) = "Invalid operands\n\ \\n\ \You cannot " <> Text.unpack action <> " the following operands:\n\ \\n\ \" <> Text.unpack (Location.renderError "" left) <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" right) displayException (ZeroDivisor location) = "Zero divisor\n\ \\n\ \You cannot divide a number by zero:\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) displayException (NeedConcreteDivisor location) = "Divisor must be concrete\n\ \\n\ \You must divide by a concrete (non-abstract) numeric literal:\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) displayException (FoldInvalidHandler location _A) = "Invalid handler\n\ \\n\ \The fold keyword expects a record of handlers where all handlers are functions,\n\ \but you provided a handler of the following type:\n\ \\n\ \" <> insert _A <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) <> "\n\ \\n\ \… which is not a function type." displayException (MissingAllAlternatives p₀ _Γ) = "Internal error: Invalid context\n\ \\n\ \The following unsolved alternatives variable:\n\ \\n\ \" <> insert (Context.UnsolvedAlternatives p₀) <> "\n\ \\n\ \… cannot be instantiated because the alternatives variable is missing from the\n\ \context:\n\ \\n\ \" <> listToText _Γ displayException (MissingAllFields p₀ _Γ) = "Internal error: Invalid context\n\ \\n\ \The following unsolved fields variable:\n\ \\n\ \" <> insert (Context.UnsolvedFields p₀) <> "\n\ \\n\ \… cannot be instantiated because the fields variable is missing from the\n\ \context:\n\ \\n\ \" <> listToText _Γ displayException (MissingOneOfTypes locations existential₀ existential₁ _Γ) = "Internal error: Invalid context\n\ \\n\ \One of the following type variables:\n\ \\n\ \" <> listToText [Context.UnsolvedType existential₀, Context.UnsolvedType existential₁ ] <> "\n\ \\n\ \… is missing from the following context:\n\ \\n\ \" <> listToText _Γ <> "\n\ \\n\ \" <> locations' where locations' = Text.unpack (Text.unlines (map (Location.renderError "") locations)) displayException (MissingOneOfAlternatives locations p₀ p₁ _Γ) = "Internal error: Invalid context\n\ \\n\ \One of the following alternatives variables:\n\ \\n\ \" <> listToText [Context.UnsolvedAlternatives p₀, Context.UnsolvedAlternatives p₁ ] <> "\n\ \\n\ \… is missing from the following context:\n\ \\n\ \" <> listToText _Γ <> "\n\ \\n\ \" <> locations' where locations' = Text.unpack (Text.unlines (map (Location.renderError "") locations)) displayException (MissingOneOfFields locations p₀ p₁ _Γ) = "Internal error: Invalid context\n\ \\n\ \One of the following fields variables:\\n\ \\n\ \" <> listToText [Context.UnsolvedFields p₀, Context.UnsolvedFields p₁ ] <> "\n\ \\n\ \… is missing from the following context:\n\ \\n\ \" <> listToText _Γ <> "\n\ \\n\ \" <> locations' where locations' = Text.unpack (Text.unlines (map (Location.renderError "") locations)) displayException (MissingVariable a _Γ) = "Internal error: Invalid context\n\ \\n\ \The following unsolved variable:\n\ \\n\ \" <> insert (Context.UnsolvedType a) <> "\n\ \\n\ \… cannot be solved because the variable is missing from the context:\n\ \\n\ \" <> listToText _Γ displayException (NotFunctionType location _A) = "Not a function type\n\ \\n\ \An expression of the following type:\n\ \\n\ \" <> insert _A <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) <> "\n\ \\n\ \… was invoked as if it were a function, but the above type is not a function\n\ \type." displayException (NotNecessarilyFunctionType location a) = "Not necessarily a function type\n\ \\n\ \The following type variable:\n\ \\n\ \" <> insert a <> "\n\ \\n\ \… could potentially be any type and is not necessarily a function type.\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) displayException (NotAlternativesSubtype location p₀ alternatives) = "Not an alternatives subtype\n\ \\n\ \The following alternatives variable:\n\ \\n\ \" <> insert p₀ <> "\n\ \\n\ \… cannot be instantiated to the following union type:\n\ \\n\ \" <> insert (Type.Union location alternatives) <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) <> "\n\ \\n\ \… because the same alternatives variable appears within that union type." displayException (NotFieldsSubtype location p₀ fields) = "Not a fields subtype\n\ \\n\ \The following fields variable:\n\ \\n\ \" <> insert p₀ <> "\n\ \\n\ \… cannot be instantiated to the following record type:\n\ \\n\ \" <> insert (Type.Record location fields) <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) <> "\n\ \\n\ \… because the same fields variable appears within that record type." displayException (NotSubtype type₀ type₁) = "Not a subtype\n\ \\n\ \The following type:\n\ \\n\ \" <> insert type₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₀)) <> "\n\ \\n\ \… is not a subtype of:\n\ \\n\ \" <> insert type₁ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₁)) displayException (NotSubtypeOfJSON type_) = "Not a subtype of JSON\n\ \\n\ \The following type:\n\ \\n\ \" <> insert type_ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type_)) <> "\n\ \\n\ \… is not a subtype of JSON." displayException (NoSupertype type₀ type₁) = "No supertype\n\ \\n\ \The following two types:\n\ \\n\ \" <> insert type₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₀)) <> "\n\ \\n\ \" <> insert type₁ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₁)) <> "\n\ \\n\ \… have no shared supertype." displayException (NoSubtype type₀ type₁) = "No subtype\n\ \\n\ \The following two types:\n\ \\n\ \" <> insert type₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₀)) <> "\n\ \\n\ \" <> insert type₁ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₁)) <> "\n\ \\n\ \… have no shared subtype." displayException (NoUnionSubtype type₀ type₁ extra₀ extra₁) | null extra₀ = "No union subtype\n\ \\n\ \The following two union types:\n\ \\n\ \" <> insert type₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₀)) <> "\n\ \\n\ \" <> insert type₁ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₁)) <> "\n\ \\n\ \… have no shared subtype because the latter has these extra alternatives:\n\ \" <> listToText extra₁ displayException (NoUnionSubtype type₀ type₁ extra₀ extra₁) | null extra₁ = "No union subtype\n\ \\n\ \The following two union types:\n\ \\n\ \" <> insert type₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₀)) <> "\n\ \\n\ \" <> insert type₁ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₁)) <> "\n\ \\n\ \… have no shared subtype because the former has these extra alternatives:\n\ \\n\ \" <> listToText extra₀ displayException (NoUnionSubtype type₀ type₁ extra₀ extra₁) = "No union subtype\n\ \\n\ \The following two union types:\n\ \\n\ \" <> insert type₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₀)) <> "\n\ \\n\ \" <> insert type₁ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location type₁)) <> "\n\ \\n\ \… have no shared subtype because the former has these extra alternatives:\n\ \\n\ \" <> listToText extra₀ <> "\n\ \\n\ \… and the latter has these extra alternatives:\n\ \\n\ \" <> listToText extra₁ displayException (UnboundAlternatives location a) = "Unbound alternatives variable: " <> Text.unpack a <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) displayException (UnboundFields location a) = "Unbound fields variable: " <> Text.unpack a <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) displayException (UnboundTypeVariable location a) = "Unbound type variable: " <> Text.unpack a <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) displayException (UnboundVariable location name) = "Unbound variable: " <> Text.unpack var <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location) where var = Grace.Pretty.toSmart @(Syntax.Syntax () Void) Syntax.Variable{ location = (), .. } displayException (RecordTypeMismatch _A₀ _B₀ extraB) | null extraB = "Record type mismatch\n\ \\n\ \The following record type:\n\ \\n\ \" <> insert _A₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location _A₀)) <> "\n\ \\n\ \… is not a subtype of the following record type:\n\ \\n\ \" <> insert _B₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location _B₀)) displayException (RecordTypeMismatch _A₀ _B₀ extraB) = "Record type mismatch\n\ \\n\ \The following record type:\n\ \\n\ \" <> insert _A₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location _A₀)) <> "\n\ \\n\ \… is not a subtype of the following record type:\n\ \\n\ \" <> insert _B₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location _B₀)) <> "\n\ \\n\ \The latter record has the following extra fields:\n\ \\n\ \" <> listToText extraB displayException (UnionTypeMismatch _A₀ _B₀ extraA) | null extraA = "Union type mismatch\n\ \\n\ \The following union type:\n\ \\n\ \" <> insert _A₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location _A₀)) <> "\n\ \\n\ \… is not a subtype of the following union type:\n\ \\n\ \" <> insert _B₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location _B₀)) displayException (UnionTypeMismatch _A₀ _B₀ extraA) = "Union type mismatch\n\ \\n\ \The following union type:\n\ \\n\ \" <> insert _A₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location _A₀)) <> "\n\ \\n\ \… is not a subtype of the following union type:\n\ \\n\ \" <> insert _B₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" (Type.location _B₀)) <> "\n\ \\n\ \The former union has the following extra alternatives:\n\ \\n\ \" <> listToText extraA displayException (FieldsVariableMismatch location₀ remainingFields₀ location₁ remainingFields₁) = "Fields variable mismatch\n\ \\n\ \This fields variable:\n\ \\n\ \" <> insert remainingFields₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location₀) <> "\n\ \\n\ \… and this fields variable:\n\ \\n\ \" <> insert remainingFields₁ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location₁) <> "\n\ \\n\ \… cannot be unified" displayException (AlternativesVariableMismatch location₀ remainingAlternatives₀ location₁ remainingAlternatives₁) = "Alternatives variable mismatch\n\ \\n\ \This alternatives variable:\n\ \\n\ \" <> insert remainingAlternatives₀ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location₀) <> "\n\ \\n\ \… and this alternatives variable:\n\ \\n\ \" <> insert remainingAlternatives₁ <> "\n\ \\n\ \" <> Text.unpack (Location.renderError "" location₁) <> "\n\ \\n\ \… cannot be unified" data AssignmentMismatch = AssignmentMismatch { location₀ :: Location , location₁ :: Location } deriving stock (Eq, Show) instance Exception AssignmentMismatch where displayException AssignmentMismatch{ location₀, location₁ } = "Assignment mismatch\n\ \\n\ \You cannot mix a List comprehension like this one:\n\ \\n\ \" <> Text.unpack (Location.renderError "" location₀) <> "\n\ \\n\ \… with an Optional comprehension like this one:\n\ \\n\ \" <> Text.unpack (Location.renderError "" location₁) -- | Invalid JSON output which didn't match the expected type data InvalidJSON a = InvalidJSON { path :: [Text] , value :: Aeson.Value , type_ :: Type a } deriving stock (Show) instance (Show a, Typeable a) => Exception (InvalidJSON a) where displayException InvalidJSON{ path, value, type_} = "Invalid JSON\n\ \\n\ \The following JSON value:\n\ \\n\ \" <> string <> "\n\ \\n\ \… does not match the following expected type:\n\ \\n\ \" <> Text.unpack (Grace.Pretty.toSmart type_) <> "\n\ \\n\ \… at the following location:\n\ \\n\ \" <> Text.unpack (Text.intercalate "." (reverse path)) where bytes = Aeson.Pretty.encodePretty value string = case Encoding.decodeUtf8' (ByteString.Lazy.toStrict bytes) of Left _ -> show bytes Right text -> Text.unpack text -- Helper functions for displaying errors insert :: Pretty a => a -> String insert a = Text.unpack (Grace.Pretty.toSmart (" " <> Pretty.align (pretty a))) listToText :: Pretty a => [a] -> String listToText elements = Text.unpack (Text.intercalate "\n" (map prettyEntry elements)) where prettyEntry entry = Grace.Pretty.toSmart ("• " <> Pretty.align (pretty entry)) ================================================ FILE: src/Grace/Input.hs ================================================ -- | This module contains the functions and types that power the URI-based imports module Grace.Input ( -- * Input Input(..) , Mode(..) ) where import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) import Grace.Pretty (Pretty(..)) import System.FilePath (()) import qualified Data.List as List import qualified Data.Text as Text import qualified Grace.Pretty as Pretty import qualified System.FilePath as FilePath import qualified Text.URI as URI {-| Input to the interpreter. You should prefer to use `Path` and `URI` if possible (for better error messages and correctly handling transitive imports). The `Code` constructor is intended for cases like interpreting code read from standard input. -} data Input = Path FilePath Mode -- ^ The path to the code | Code String Text -- ^ Source code: @Code name content@ | URI URI.URI Mode deriving stock (Eq, Show) instance Semigroup Input where _ <> URI uri mode = URI uri mode _ <> Code name code = Code name code Code _ _ <> Path child mode = Path child mode Path parent _ <> Path child mode = Path (FilePath.takeDirectory parent child) mode URI parent _ <> Path child mode | FilePath.isRelative child , Just uri <- URI.relativeTo childURI parent = URI uri mode | otherwise = Path child mode where stripped = case List.stripPrefix "./" child of Nothing -> child Just suffix -> suffix uriPath = do c : cs <- traverse (URI.mkPathPiece . Text.pack) (FilePath.splitPath stripped) return (FilePath.hasTrailingPathSeparator child, c :| cs) childURI = URI.URI { URI.uriScheme = Nothing , URI.uriAuthority = Left False , URI.uriPath = uriPath , URI.uriQuery = [] , URI.uriFragment = Nothing } instance Pretty Input where pretty (Code _ code) = pretty code pretty (Path path mode) = pretty path <> pretty mode pretty (URI uri mode) = pretty uri <> pretty mode -- | How the imported string is interpreted data Mode = AsCode -- ^ Interpret the string as Grace code (the default) | AsText -- ^ Interpret the string as raw Text | AsKey -- ^ Interpret the string as a Key deriving stock (Eq, Show) instance Semigroup Mode where mode <> AsCode = mode _ <> mode = mode instance Pretty Mode where pretty AsCode = mempty pretty AsText = " " <> Pretty.punctuation ":" <> " " <> Pretty.builtin "Text" pretty AsKey = " " <> Pretty.punctuation ":" <> " " <> Pretty.builtin "Key" ================================================ FILE: src/Grace/Interpret.hs ================================================ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module implements the main interpretation function module Grace.Interpret ( -- * Interpret Input(..) , interpret , (<~) , interpretWith -- * Load , load , loadWith ) where import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Text (Text) import Grace.Decode (FromGrace(..)) import Grace.Encode (ToGrace(..), ToGraceType(..)) import Grace.Input (Input(..), Mode(..)) import Grace.Location (Location(..)) import Grace.Monad (Grace, Status(..)) import Grace.Type (Type) import Grace.Value (Value) import qualified Control.Exception.Safe as Exception import qualified Control.Monad.Reader as Reader import qualified Control.Monad.State as State import qualified Grace.Context as Context import qualified Grace.Import as Import import qualified Grace.Infer as Infer import qualified Grace.Monad as Grace import qualified Grace.Normalize as Normalize import qualified Grace.Pretty as Pretty import qualified Grace.Syntax as Syntax import qualified Grace.Type as Type import qualified Grace.Value as Value {-| Interpret Grace source code, return the inferred type and the evaluated result This is the top-level function for the Grace interpreter -} interpret :: MonadIO io => Input -> io (Type Location, Value Location) interpret input = do let initialStatus = Status{ count = 0, context = [] } ((inferred, value), Status{ context }) <- do Grace.runGrace input initialStatus (interpretWith [] Nothing) return (Context.complete context inferred, Value.complete context value) {-| Convenient operator for creating a binding from a Haskell value rather than a Grace type and value -} (<~) :: forall a . ToGrace a => Text -> a -> (Text, Type Location, Value Location) name <~ haskellValue = ( name , fmap (\_ -> Unknown) (expected @a) , fmap (\_ -> Unknown) (encode haskellValue) ) -- | Like `interpret`, but accepts a custom list of bindings interpretWith :: [(Text, Type Location, Value Location)] -- ^ @(name, type, value)@ for each custom binding -> Maybe (Type Location) -- ^ Optional expected type for the input -> Grace (Type Location, Value Location) interpretWith bindings maybeAnnotation = do input <- Reader.ask expression <- liftIO (Import.resolve AsCode input) let annotatedExpression = case maybeAnnotation of Just annotation -> Syntax.Annotation { annotated = expression , annotation , location = Syntax.location expression } Nothing -> expression let typeContext = do (variable, type_, _) <- bindings return (Context.Annotation variable type_) State.modify (\status -> status{ context = typeContext <> context status }) (inferred, elaboratedExpression) <- Infer.infer annotatedExpression let evaluationContext = do (variable, _, value) <- bindings return (variable, value) value <- Normalize.evaluate evaluationContext elaboratedExpression return (inferred, value) -- | Load a Grace expression load :: forall m a . (FromGrace a, MonadIO m) => Input -> m a load = loadWith [] -- | Like `load`, but accepts a custom list of bindings loadWith :: forall m a . (FromGrace a, MonadIO m) => [(Text, Type Location, Value Location)] -> Input -> m a loadWith bindings input = do let type_ = fmap (\_ -> Unknown) (expected @a) let initialStatus = Status{ count = 0, context = [] } (_, value) <- Grace.evalGrace input initialStatus (interpretWith bindings (Just type_) ) case decode value of Left exception -> liftIO (Exception.throwIO exception) Right a -> return a instance (ToGrace a, FromGrace b) => FromGrace (a -> IO b) where decode function = do return \a -> do let inputValue = fmap (\_ -> Unknown) (encode a) let initialStatus = Status{ count = 0, context = [] } let code = Pretty.toText inputValue let input = Code "(decode)" code outputValue <- Grace.evalGrace input initialStatus (Normalize.apply Unknown function inputValue) case decode outputValue of Left e -> Exception.throwIO e Right b -> return b instance (ToGraceType a, ToGraceType b) => ToGraceType (a -> IO b) where expected = Type.Function { location = () , input = expected @a , output = expected @b } ================================================ FILE: src/Grace/Interpret.hs-boot ================================================ {-# LANGUAGE FlexibleContexts #-} module Grace.Interpret where import Data.Text (Text) import Grace.Location (Location) import Grace.Monad (Grace) import Grace.Type (Type) import Grace.Value (Value) -- | Like `interpret`, but accepts a custom list of bindings interpretWith :: [(Text, Type Location, Value Location )] -- ^ @(name, type, value)@ for each custom binding -> Maybe (Type Location) -- ^ Optional expected type for the input -> Grace (Type Location, Value Location) ================================================ FILE: src/Grace/Label.hs ================================================ {-| This module provides label-related logic shared by the parser and pretty-printer -} module Grace.Label ( -- * Reserved tokens reservedLabels , reservedRecordLabels -- * Character matching , isLabel0 , isAlternativeLabel0 , isLabel -- * Label quoting , validLabel , validRecordLabel , validAlternativeLabel ) where import Data.HashSet (HashSet) import Data.Text (Text) import qualified Data.Char as Char import qualified Data.HashSet as HashSet import qualified Data.Text as Text -- | Is this character valid as the first character in an unquoted label? isLabel0 :: Char -> Bool isLabel0 c = Char.isLower c || c == '_' -- | Is this character valid as the first character in an unquoted alternative -- label? isAlternativeLabel0 :: Char -> Bool isAlternativeLabel0 = Char.isUpper -- | Is this character valid as a follow-up character in an unquoted label? isLabel :: Char -> Bool isLabel c = Char.isAlphaNum c || c == '_' || c == '-' || c == '/' -- | Returns `True` if the given label is valid when unquoted validLabel :: Text -> Bool validLabel text_ = case Text.uncons text_ of Nothing -> False Just (h, t) -> isLabel0 h && Text.all isLabel t && not (HashSet.member text_ reservedLabels) -- | Returns `True` if the given record label is valid when unquoted validRecordLabel :: Text -> Bool validRecordLabel text_ = case Text.uncons text_ of Nothing -> False Just (h, t) -> isLabel0 h && Text.all isLabel t && not (HashSet.member text_ reservedRecordLabels) -- | Returns `True` if the given alternative label is valid when unquoted validAlternativeLabel :: Text -> Bool validAlternativeLabel text_ = case Text.uncons text_ of Nothing -> False Just (h, t) -> isAlternativeLabel0 h && Text.all isLabel t && not (HashSet.member text_ reservedLabels) -- | Reserved tokens, which can't be used for labels unless they are quoted reservedLabels :: HashSet Text reservedLabels = HashSet.union (HashSet.fromList [ "some", "null", "true", "false" ]) reservedRecordLabels reservedRecordLabels :: HashSet Text reservedRecordLabels = HashSet.fromList [ "Alternatives" , "Bool" , "Fields" , "Integer" , "List" , "Natural" , "Optional" , "Real" , "Text" , "Type" , "abs" , "else" , "export" , "fold" , "for" , "forall" , "github" , "http" , "if" , "import" , "in" , "indexed" , "length" , "let" , "map" , "of" , "prompt" , "read" , "reveal" , "show" , "then" , "yaml" ] ================================================ FILE: src/Grace/Location.hs ================================================ {-| This module contains the `Location` type used for attaching source code to error messages -} module Grace.Location ( -- * Location Location(..) , Offset(..) , renderError ) where import Data.Text (Text) import Text.Megaparsec (PosState(..), SourcePos(..)) import qualified Data.Text as Text import qualified Text.Megaparsec.Pos as Pos import qualified Text.Megaparsec.Stream as Stream -- | Offsets are stored in characters (0-indexed) newtype Offset = Offset { getOffset :: Int } deriving newtype (Eq, Num, Show) -- | This type stores the location of each subexpression data Location = Location { name :: String -- ^ The file or name describing where the code came from , code :: Text -- ^ The original source code (the entire file) -- -- Note that this will not always be the same for each `Location` -- because different subexpressions might originate from different -- files if they were imported , offset :: Offset -- ^ The offset (in characters) within the code } | Unknown deriving stock (Eq, Show) -- | Render an error message, given a `Location` for the error renderError :: Text -- ^ Error message -> Location -- ^ Location of the error -> Text renderError message Location{ name, code, offset } = prefix <> "\n" <> suffix where initialState = PosState { pstateInput = code , pstateOffset = 0 , pstateSourcePos = Pos.initialPos name , pstateTabWidth = Pos.defaultTabWidth , pstateLinePrefix = "" } (h, state) = Stream.reachOffset (getOffset offset) initialState pos = pstateSourcePos state line = Pos.unPos (sourceLine pos) column = Pos.unPos (sourceColumn pos) suffix = case h of Just string -> let lineText = Text.pack (show line) inner = lineText <> " │" outer = Text.replicate (Text.length lineText) " " <> " │" caret = Text.replicate (column - 1) " " <> "↑" in outer <> "\n\ \" <> inner <> " " <> Text.pack string <> "\n\ \" <> outer <> " " <> caret Nothing -> "" prefix = Text.pack name <> ":" <> Text.pack (show line) <> ":" <> Text.pack (show column) <> ": " <> message renderError message Unknown = message ================================================ FILE: src/Grace/Marshal.hs ================================================ {-# LANGUAGE AllowAmbiguousTypes #-} -- | Internal module shared between "Grace.Decode" and "Grace.Encode" module Grace.Marshal ( Key(..) , ToGraceType(..) , GenericToGraceType(..) , selector ) where import Control.Monad.State (State) import Data.Aeson (FromJSON, ToJSON) import Data.Int (Int8, Int16, Int32, Int64) import Data.Scientific (Scientific) import Data.Sequence (Seq) import Data.String (IsString) import Data.Text (Text) import Data.Word (Word8, Word16, Word32, Word64) import Data.Vector (Vector) import Data.Void (Void) import Grace.Type (Type) import Numeric.Natural (Natural) import GHC.Generics ( Generic(..) , C , Constructor , D , K1(..) , M1(..) , Rep , S , Selector , U1(..) , V1 , (:+:)(..) , (:*:)(..) ) import qualified Control.Monad.State as State import qualified Data.Aeson as Aeson import qualified Data.Kind as Kind import qualified Data.Text as Text import qualified Data.Text.Lazy as Text.Lazy import qualified GHC.Generics as Generics import qualified Grace.Monotype as Monotype import qualified Grace.Type as Type -- | A protected `Text` value newtype Key = Key{ text :: Text } deriving newtype (Eq, IsString, Show, FromJSON, ToJSON) selector :: Selector s => M1 S s f r -> State Int Text selector m1 = do let name₀ = Generics.selName m1 if name₀ == "" then do n <- State.get State.put $! n + 1 return (Text.pack (show n)) else do return (Text.pack name₀) -- | Convert a Haskell type to a Grace type class ToGraceType a where expected :: Type () default expected :: (Generic a, GenericToGraceType (Rep a)) => Type () expected = State.evalState (genericExpected @(Rep a)) 0 instance ToGraceType Void instance ToGraceType () instance (ToGraceType a, ToGraceType b) => ToGraceType (a, b) instance (ToGraceType a, ToGraceType b) => ToGraceType (Either a b) instance ToGraceType Bool where expected = Type.Scalar{ location = (), scalar = Monotype.Bool } instance ToGraceType Natural where expected = Type.Scalar{ location = (), scalar = Monotype.Natural } instance ToGraceType Word where expected = expected @Natural instance ToGraceType Word8 where expected = expected @Natural instance ToGraceType Word16 where expected = expected @Natural instance ToGraceType Word32 where expected = expected @Natural instance ToGraceType Word64 where expected = expected @Natural instance ToGraceType Integer where expected = Type.Scalar{ location = (), scalar = Monotype.Integer } instance ToGraceType Int where expected = expected @Integer instance ToGraceType Int8 where expected = expected @Integer instance ToGraceType Int16 where expected = expected @Integer instance ToGraceType Int32 where expected = expected @Integer instance ToGraceType Int64 where expected = expected @Integer instance ToGraceType Scientific where expected = Type.Scalar{ location = (), scalar = Monotype.Real } instance ToGraceType Double where expected = expected @Scientific instance ToGraceType Float where expected = expected @Scientific instance ToGraceType Text where expected = Type.Scalar{ location = (), scalar = Monotype.Text } instance ToGraceType Text.Lazy.Text where expected = expected @Text instance {-# OVERLAPPING #-} ToGraceType [Char] where expected = expected @Text instance ToGraceType Key where expected = Type.Scalar{ location = (), scalar = Monotype.Key } instance ToGraceType Aeson.Value where expected = Type.Scalar{ location = (), scalar = Monotype.JSON } instance ToGraceType a => ToGraceType (Seq a) where expected = Type.List{ location = (), type_ = expected @a } instance ToGraceType a => ToGraceType [a] where expected = expected @(Seq a) instance ToGraceType a => ToGraceType (Vector a) where expected = expected @[a] instance ToGraceType a => ToGraceType (Maybe a) where expected = Type.Optional{ location = (), type_ = expected @a } {-| This is the underlying class that powers the `ToGraceType` class's support for automatically deriving a `Generic` implementation -} class GenericToGraceType (f :: Kind.Type -> Kind.Type) where genericExpected :: State Int (Type ()) instance GenericToGraceType V1 where genericExpected = do return Type.Union { location = () , alternatives = Type.Alternatives [] Monotype.EmptyAlternatives } instance GenericToGraceType U1 where genericExpected = do return Type.Record { location = () , fields = Type.Fields [] Monotype.EmptyFields } instance GenericToGraceType f => GenericToGraceType (M1 D d f) where genericExpected = genericExpected @f instance GenericToGraceType f => GenericToGraceType (M1 C d f) where genericExpected = genericExpected @f instance (Selector s, ToGraceType a) => GenericToGraceType (M1 S s (K1 i a)) where genericExpected = do let m1 :: M1 S s (K1 i a) r m1 = undefined name <- selector m1 if Generics.selName m1 == "" then do return (expected @a) else do return Type.Record { location = () , fields = Type.Fields [ (name, expected @a) ] Monotype.EmptyFields } instance (Selector s₀, Selector s₁, ToGraceType a₀, ToGraceType a₁) => GenericToGraceType (M1 S s₀ (K1 i₀ a₀) :*: M1 S s₁ (K1 i₁ a₁)) where genericExpected = do name₀ <- selector (undefined :: M1 S s₀ (K1 i₀ a₀) r) name₁ <- selector (undefined :: M1 S s₁ (K1 i₁ a₁) r) return Type.Record { location = () , fields = Type.Fields [ (name₀, expected @a₀) , (name₁, expected @a₁) ] Monotype.EmptyFields } instance (Selector s, GenericToGraceType (f₀ :*: f₁), ToGraceType a) => GenericToGraceType ((f₀ :*: f₁) :*: M1 S s (K1 i a)) where genericExpected = do expected₀ <- genericExpected @(f₀ :*: f₁) name <- selector (undefined :: M1 S s (K1 i a) r) return Type.Record { location = () , fields = Type.Fields ((name, expected @a) : unsafeExpectRecordType expected₀) Monotype.EmptyFields } instance (Selector s, ToGraceType a, GenericToGraceType (f₀ :*: f₁)) => GenericToGraceType (M1 S s (K1 i a) :*: (f₀ :*: f₁)) where genericExpected = do name <- selector (undefined :: M1 S s (K1 i a) r) expected₁ <- genericExpected @(f₀ :*: f₁) return Type.Record { location = () , fields = Type.Fields ((name, expected @a) : unsafeExpectRecordType expected₁) Monotype.EmptyFields } instance (GenericToGraceType (f₀ :*: f₁), GenericToGraceType (f₂ :*: f₃)) => GenericToGraceType ((f₀ :*: f₁) :*: (f₂ :*: f₃)) where genericExpected = do expected₀ <- genericExpected @(f₀ :*: f₁) expected₁ <- genericExpected @(f₂ :*: f₃) return Type.Record { location = () , fields = Type.Fields ( unsafeExpectRecordType expected₀ <> unsafeExpectRecordType expected₁ ) Monotype.EmptyFields } instance (Constructor c₀, Constructor c₁, GenericToGraceType f₀, GenericToGraceType f₁) => GenericToGraceType (M1 C c₀ f₀ :+: M1 C c₁ f₁) where genericExpected = do let name₀ = Text.pack (Generics.conName (undefined :: M1 C c₀ f₀ r)) let name₁ = Text.pack (Generics.conName (undefined :: M1 C c₁ f₁ r)) let expected₀ = State.evalState (genericExpected @f₀) 0 let expected₁ = State.evalState (genericExpected @f₁) 0 return Type.Union { location = () , alternatives = Type.Alternatives [ (name₀, expected₀), (name₁, expected₁) ] Monotype.EmptyAlternatives } instance (Constructor c, GenericToGraceType f₀, GenericToGraceType (f₁ :+: f₂)) => GenericToGraceType (M1 C c f₀ :+: (f₁ :+: f₂)) where genericExpected = do let name₀ = Text.pack (Generics.conName (undefined :: M1 C c f r)) let expected₀ = State.evalState (genericExpected @f₀ ) 0 let expected₁ = State.evalState (genericExpected @(f₁ :+: f₂)) 0 return Type.Union { location = () , alternatives = Type.Alternatives ((name₀, expected₀) : unsafeExpectUnionType expected₁) Monotype.EmptyAlternatives } instance (Constructor c, GenericToGraceType (f₀ :+: f₁), GenericToGraceType f₂) => GenericToGraceType ((f₀ :+: f₁) :+: M1 C c f₂) where genericExpected = do let name₁ = Text.pack (Generics.conName (undefined :: M1 C c f r)) let expected₀ = State.evalState (genericExpected @(f₀ :+: f₁)) 0 let expected₁ = State.evalState (genericExpected @f₂) 0 return Type.Union { location = () , alternatives = Type.Alternatives (unsafeExpectUnionType expected₀ <> [ (name₁, expected₁) ]) Monotype.EmptyAlternatives } instance (GenericToGraceType (f₀ :+: f₁), GenericToGraceType (f₂ :+: f₃)) => GenericToGraceType ((f₀ :+: f₁) :+: (f₂ :+: f₃)) where genericExpected = do let expected₀ = State.evalState (genericExpected @(f₀ :+: f₁)) 0 let expected₁ = State.evalState (genericExpected @(f₂ :+: f₃)) 0 return Type.Union { location = () , alternatives = Type.Alternatives (unsafeExpectUnionType expected₀ <> unsafeExpectUnionType expected₁) Monotype.EmptyAlternatives } unsafeExpectRecordType :: Type s -> [(Text, Type s)] unsafeExpectRecordType Type.Record{ fields = Type.Fields fieldTypes _ } = fieldTypes unsafeExpectRecordType _ = error "Grace.Decode.unsafeExpectRecordType: not a record" unsafeExpectUnionType :: Type s -> [(Text, Type s)] unsafeExpectUnionType Type.Union{ alternatives = Type.Alternatives alternativeTypes _ } = alternativeTypes unsafeExpectUnionType _ = error "Grace.Decode.unsafeExpectUnionType: not a union" ================================================ FILE: src/Grace/Monad.hs ================================================ {-| This module contains the `Grace` `Monad` shared by type inference and evaluation -} module Grace.Monad ( -- * Monad Status(..) , Grace(..) , runGrace , evalGrace , execGrace ) where import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader, ReaderT) import Control.Monad.State (MonadState, StateT) import Grace.Context (Context) import Grace.Input (Input) import Grace.Location (Location) import Grace.Parallelizable (Parallelizable) import qualified Control.Monad.Reader as Reader import qualified Control.Monad.State as State import qualified Grace.Parallelizable as Parallelizable -- | Interpretation state data Status = Status { count :: !Int -- ^ Used to generate fresh unsolved variables (e.g. α̂, β̂ from the -- original paper) , context :: Context Location -- ^ The type-checking context (e.g. Γ, Δ, Θ) } -- | The shared `Monad` threaded throughout all phases of interpretation newtype Grace a = Grace{ parallelizable :: ReaderT Input (Parallelizable (StateT Status IO)) a } deriving newtype ( Functor , Applicative , Monad , MonadCatch , MonadIO , MonadReader Input , MonadState Status , MonadThrow ) -- | Run the `Grace` `Monad`, preserving the result and final `Status` runGrace :: MonadIO io => Input -> Status -> Grace a -> io (a, Status) runGrace input status Grace{ parallelizable } = liftIO (State.runStateT (Parallelizable.serialize (Reader.runReaderT parallelizable input)) status) -- | Run the `Grace` `Monad`, discarding the final `Status` evalGrace :: MonadIO io => Input -> Status -> Grace a -> io a evalGrace input status Grace{ parallelizable } = liftIO (State.evalStateT (Parallelizable.serialize (Reader.runReaderT parallelizable input)) status) -- | Run the `Grace` `Monad`, discarding the result execGrace :: MonadIO io => Input -> Status -> Grace a -> io Status execGrace input status Grace{ parallelizable } = liftIO (State.execStateT (Parallelizable.serialize (Reader.runReaderT parallelizable input)) status) ================================================ FILE: src/Grace/Monotype.hs ================================================ {-| This module stores the `Monotype` type representing monomorphic types and utilites for operating on `Monotype`s -} module Grace.Monotype ( -- * Types Monotype(..) , Scalar(..) , Record(..) , RemainingFields(..) , Union(..) , RemainingAlternatives(..) ) where import Data.String (IsString(..)) import Data.Text (Text) import GHC.Generics (Generic) import Grace.Existential (Existential) import Grace.Pretty (Pretty(..), builtin, label) import Language.Haskell.TH.Syntax (Lift) {-| A monomorphic type This is same type as `Grace.Type.Type`, except without the `Grace.Type.Forall` and `Grace.Type.Exists` constructors -} data Monotype = VariableType Text | UnsolvedType (Existential Monotype) | Function Monotype Monotype | Optional Monotype | List Monotype | Record Record | Union Union | Scalar Scalar deriving stock (Eq, Generic, Show) instance IsString Monotype where fromString string = VariableType (fromString string) -- | A scalar type data Scalar = Bool -- ^ Boolean type -- -- >>> pretty Bool -- Bool | Real -- ^ Real number type -- -- >>> pretty Real -- Real | Integer -- ^ Integer number type -- -- >>> pretty Integer -- Integer | JSON -- ^ JSON type -- -- >>> pretty JSON -- JSON | Natural -- ^ Natural number type -- -- >>> pretty Natural -- Natural | Text -- ^ Text type -- -- >>> pretty Text -- Text | Key -- ^ Key type -- -- >>> pretty Key -- Key deriving stock (Eq, Generic, Lift, Show) instance Pretty Scalar where pretty Bool = builtin "Bool" pretty Real = builtin "Real" pretty JSON = builtin "JSON" pretty Natural = builtin "Natural" pretty Integer = builtin "Integer" pretty Text = builtin "Text" pretty Key = builtin "Key" -- | A monomorphic record type data Record = Fields [(Text, Monotype)] RemainingFields deriving stock (Eq, Generic, Show) -- | This represents whether or not the record type is open or closed data RemainingFields = EmptyFields -- ^ The record type is closed, meaning that all fields are known | UnsolvedFields (Existential Record) -- ^ The record type is open, meaning that some fields are known and there -- is an unsolved fields variable that is a placeholder for other fields -- that may or may not be present | VariableFields Text -- ^ Same as `UnsolvedFields`, except that the user has given the fields -- variable an explicit name in the source code deriving stock (Eq, Generic, Lift, Show) instance Pretty RemainingFields where pretty EmptyFields = mempty pretty (UnsolvedFields existential) = label (pretty existential <> "?") pretty (VariableFields name) = label (pretty name) -- | A monomorphic union type data Union = Alternatives [(Text, Monotype)] RemainingAlternatives deriving stock (Eq, Generic, Show) -- | This represents whether or not the union type is open or closed data RemainingAlternatives = EmptyAlternatives -- ^ The union type is closed, meaning that all alternatives are known | UnsolvedAlternatives (Existential Union) -- ^ The union type is open, meaning that some alternatives are known and -- there is an unsolved alternatives variable that is a placeholder for -- other alternatives that may or may not be present | VariableAlternatives Text -- ^ Same as `UnsolvedAlternatives`, except that the user has given the -- alternatives variable an explicit name in the source code deriving stock (Eq, Generic, Lift, Show) instance Pretty RemainingAlternatives where pretty EmptyAlternatives = mempty pretty (UnsolvedAlternatives existential) = label (pretty existential <> "?") pretty (VariableAlternatives name) = label (pretty name) ================================================ FILE: src/Grace/Normalize.hs ================================================ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} -- | This module contains the logic for efficiently evaluating an expression module Grace.Normalize ( -- * Normalization evaluate , apply , Value.quote , strip -- * Errors related to normalization , MissingCredentials(..) , Prompt.UnsupportedModelOutput(..) , JSONDecodingFailed(..) , MissingSchema(..) ) where import Control.Exception.Safe (Exception(..)) import Control.Monad.IO.Class (MonadIO(..)) import Data.Foldable (toList) import Data.Functor (void) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import Data.Sequence (ViewL(..)) import Data.Text (Text) import Data.Void (Void) import Grace.Aeson (JSONDecodingFailed(..)) import Grace.Decode (FromGrace(..)) import Grace.HTTP (HTTP(..)) import Grace.Input (Input(..), Mode(..)) import Grace.Location (Location(..)) import Grace.Monad (Grace, Status(..)) import Grace.Syntax (BindMonad(..), Builtin(..), Scalar(..), Syntax) import Grace.Value (Value) import Prelude hiding (lookup, null, succ) import {-# SOURCE #-} qualified Grace.Interpret as Interpret import qualified Control.Exception.Safe as Exception import qualified Control.Lens as Lens import qualified Control.Monad as Monad import qualified Control.Monad.Reader as Reader import qualified Control.Monad.State as State import qualified Data.Aeson as Aeson import qualified Data.Aeson.Yaml as YAML import qualified Data.ByteString.Lazy as ByteString.Lazy import qualified Data.HashMap.Strict.InsOrd as HashMap import qualified Data.List as List import qualified Data.Scientific as Scientific import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified Data.Void as Void import qualified Grace.Aeson import qualified Grace.Context as Context import qualified Grace.GitHub as GitHub import qualified Grace.HTTP as HTTP import qualified Grace.Import as Import import qualified Grace.Infer as Infer import qualified Grace.Monotype as Monotype import qualified Grace.Pretty as Pretty import qualified Grace.Prompt as Prompt import qualified Grace.Syntax as Syntax import qualified Grace.Type as Type import qualified Grace.Value as Value import qualified Text.URI as URI import qualified Prelude {- $setup >>> :set -XOverloadedStrings -} {-| Lookup a variable from an ordered environment of name-value pairs using the variable's name and index -} lookupVariable :: Text -- ^ Variable name -> [(Text, Value Location)] -- ^ Evaluation environment -> Value Location lookupVariable name environment = case Prelude.lookup name environment of Just value -> value Nothing -> error "Grace.Normalize.lookupVariable: unbound variable" sorted :: Ord key => InsOrdHashMap key value -> [(key, value)] sorted = List.sortOn fst . HashMap.toList {-| Evaluate an expression, leaving behind a `Value` free of reducible sub-expressions This function uses separate types for the input (i.e. `Syntax`) and the output (i.e. `Value`) in order to avoid wastefully evaluating the same sub-expression multiple times. -} evaluate :: [(Text, Value Location)] -- ^ Evaluation environment (starting at @[]@ for a top-level expression) -> Syntax Location Void -- ^ Surface syntax -> Grace (Value Location) -- ^ Result, free of reducible sub-expressions evaluate env₀ syntax₀ = do loop env₀ syntax₀ where generateContext env = do let infer (name, assignment) = do let expression :: Syntax Location Input expression = fmap Void.absurd (Value.quote assignment) let input = Code "(intermediate value)" (Pretty.toSmart expression) (type_, _) <- Infer.typeOf input expression return (name, type_, assignment) traverse infer env loop :: [(Text, Value Location)] -> Syntax Location Void -> Grace (Value Location) loop env syntax = case syntax of Syntax.Variable{ name } -> do pure (lookupVariable name env) Syntax.Application{ location, function, argument } -> Monad.join do function' <- loop env function argument' <- loop env argument pure (apply location function' argument') Syntax.Lambda{ location, binding = Syntax.PlainBinding{ plain = Syntax.NameBinding{ nameLocation, name, assignment } }, body } -> do newAssignment <- traverse (loop env) assignment pure (Value.Lambda location env (Value.Name nameLocation name newAssignment) body) Syntax.Lambda{ location, binding = Syntax.RecordBinding{ fieldNamesLocation, fieldNames }, body } -> do let process Syntax.NameBinding{ nameLocation, name, assignment } = do newAssignment <- traverse (loop env) assignment pure (nameLocation, name, newAssignment) newFieldNames <- traverse process fieldNames pure (Value.Lambda location env (Value.FieldNames fieldNamesLocation newFieldNames) body) Syntax.Annotation{ annotated, annotation } -> do newAnnotated <- loop env annotated pure do let promote (Value.Scalar location (Natural n)) Type.Scalar{ scalar = Monotype.Real } = Value.Scalar location (Real (fromIntegral n)) promote (Value.Scalar location (Integer n)) Type.Scalar{ scalar = Monotype.Real } = Value.Scalar location (Real (fromInteger n)) promote (Value.Scalar location (Natural n)) Type.Scalar{ scalar = Monotype.Integer } = Value.Scalar location (Integer (fromIntegral n)) promote (Value.Text location t) Type.Scalar{ scalar = Monotype.Key } = Value.Scalar location (Key t) promote _ _ = newAnnotated promote newAnnotated annotation Syntax.Let{ assignments, body = body₀ } -> do let cons Syntax.Define{ definition = Syntax.Definition{ nameLocation, name, bindings, assignment } } action environment = do let lambda binding body = Syntax.Lambda { location = nameLocation , binding , body } let newAssignment = foldr lambda assignment bindings value <- loop environment newAssignment action ((name, value) : environment) cons Syntax.Bind{ monad, binding, assignment = assignment₀ } action environment = do value₀ <- loop environment assignment₀ let once v = case binding of Syntax.PlainBinding{ plain = Syntax.NameBinding{ name, assignment = assignment₁ } } -> do v₁ <- case assignment₁ of Nothing -> do return v Just assignment₂ -> case v of Value.Scalar _ Null -> do loop environment assignment₂ Value.Application _ (Value.Builtin _ Some) v₁ -> do return v₁ v₁ -> do return v₁ action ((name, v₁) : environment) Syntax.RecordBinding{ fieldNames } -> do case v of Value.Record location hashMap -> do let process Syntax.NameBinding{ name, assignment = assignment₁} = do let missing = case assignment₁ of Nothing -> do return (Value.Scalar location Syntax.Null) Just a -> do loop environment a value <- case HashMap.lookup name hashMap of -- This case shouldn't happen in theory, all missing -- fields should be elaborated to present fields set -- to `null` but we handle it as a precaution by -- just treating it as if elaboration had happened. Nothing -> missing Just (_, Value.Scalar _ Syntax.Null) -> missing -- If the field had a default assignment then that -- means that the right-hand side would be elaborated -- to be wrapped in a `some`, which we need to undo -- here Just (_, Value.Application _ (Value.Builtin _ Some) a) | Just _ <- assignment₁ -> return a Just (_, a) -> do return a return (name, value) entries <- traverse process fieldNames action (entries <> environment) _ -> do error "Grace.Normalize.evaluate: non-records can't be destructured as records" case monad of IdentityMonad -> once value₀ OptionalMonad -> case value₀ of Value.Scalar location Null -> do return (Value.Scalar location Null) Value.Application _ (Value.Builtin _ Some) value₁ -> do once value₁ value₁ -> once value₁ ListMonad -> case value₀ of Value.List location elements -> do values <- traverse once elements let newElements = mconcat do Value.List _ xs <- toList values return (toList xs) return (Value.List location (Seq.fromList newElements)) _ -> error "Grace.Normalize.evaluate: cannot bind a non-Listin the List monad" let monad = (maximum . (IdentityMonad :)) do Syntax.Bind{ monad = m } <- toList assignments return m let nil environment = do value <- loop environment body₀ return case monad of IdentityMonad -> value ListMonad -> Value.List (Value.location value) [ value ] OptionalMonad -> Value.Application location (Value.Builtin location Some) value where location = Value.location value foldr cons nil assignments env Syntax.List{ location, elements } -> do values <- traverse (loop env) elements pure (Value.List location values) Syntax.Record{ location, fieldValues } -> do let process Syntax.Definition{ nameLocation, name, bindings, assignment = assignment₀ } = do let cons binding body = Syntax.Lambda { location = nameLocation , binding , body } let assignment₁ = foldr cons assignment₀ bindings assignment₂ <- loop env assignment₁ pure (name, (nameLocation, assignment₂)) newFieldValues <- traverse process fieldValues pure (Value.Record location (HashMap.fromList newFieldValues)) Syntax.Text{ location, chunks = Syntax.Chunks text rest } -> do let onChunk (interpolation, text₁) = do value <- loop env interpolation pure case value of Value.Text _ text₀ -> text₀ <> text₁ _ -> error "Grace.Normalize.evaluate: interpolations must be text values" suffixes <- traverse onChunk rest pure (Value.Text location (text <> Text.concat suffixes)) Syntax.Project{ larger, smaller } -> do let lookup location field fieldValues = case HashMap.lookup field fieldValues of Just (_, v) -> v Nothing -> Value.Scalar location Syntax.Null larger' <- loop env larger pure case (larger', smaller) of (Value.Record location fieldValues, Syntax.Single{ single = Syntax.Field{ field } }) -> lookup location field fieldValues (Value.Record location fieldValues, Syntax.Multiple{ multiple }) -> Value.Record location newFieldValues where process Syntax.Field{ fieldLocation, field } = (field, (fieldLocation, lookup location field fieldValues)) fvs = map process multiple newFieldValues = HashMap.fromList fvs (Value.List location xs, Syntax.Index{ index }) | Seq.null xs -> Value.Scalar location Null | otherwise -> case quotient of 0 -> -- positive index within bounds Value.Application location (Value.Builtin location Some) (Seq.index xs remainder) -1 -> -- negative index within bounds Value.Application location (Value.Builtin location Some) (Seq.index xs remainder) _ -> -- out-of-bounds index Value.Scalar location Null where (quotient, remainder) = fromInteger index `divMod` Seq.length xs (Value.List location xs, Syntax.Slice{ begin, end }) | Seq.null xs -> Value.Scalar location Null | otherwise -> Value.Application location (Value.Builtin location Some) (Value.List location elements₂) where b = case begin of Just x -> x Nothing -> 0 e = case end of Just x -> x Nothing -> 0 n = Seq.length xs elements₀ = Seq.cycleTaking (2 * n) xs elements₁ = Seq.drop (fromInteger b `mod` n) elements₀ elements₂ = Seq.take ((fromInteger (e - b - 1) `mod` n) + 1) elements₁ _ -> error "Grace.Normalize.evaluate: invalid projection" Syntax.Alternative{ location, name, argument } -> do newArgument <- loop env argument pure (Value.Alternative location name newArgument) Syntax.Fold{ location, handlers } -> do newHandlers <- loop env handlers pure (Value.Fold location newHandlers) Syntax.If{ predicate, ifTrue, ifFalse } -> do predicate' <- loop env predicate ifTrue' <- loop env ifTrue ifFalse' <- loop env ifFalse pure case predicate' of Value.Scalar _ (Bool True) -> ifTrue' Value.Scalar _ (Bool False) -> ifFalse' _ -> error "Grace.Normalize.evaluate: if predicate must be a boolean value" Syntax.Prompt{ location, import_, arguments, schema } -> do newArguments <- loop env arguments prompt <- case decode newArguments of Left exception -> Exception.throwIO exception Right prompt -> return prompt Status{ context } <- State.get let solvedSchema = fmap (Context.solveType context) schema Prompt.prompt (generateContext env) import_ location prompt solvedSchema Syntax.HTTP{ schema = Nothing } -> do Exception.throwIO MissingSchema Syntax.HTTP{ import_, arguments, schema = Just schema } -> do newArguments <- loop env arguments http <- case decode newArguments of Left exception -> Exception.throwIO exception Right http -> return http responseBody <- liftIO (HTTP.http import_ http) if import_ then do bindings <- liftIO (generateContext env) uri <- liftIO (URI.mkURI (HTTP.url http)) parent <- Reader.ask Reader.local (\i -> i <> URI uri AsCode) do child <- Reader.ask Import.referentiallySane parent child (_, value) <- Interpret.interpretWith bindings (Just schema) return value else do Status{ context } <- State.get let solvedSchema = Context.solveType context schema case solvedSchema of Type.Scalar{ location, scalar = Monotype.Text } -> return (Value.Text location responseBody) _ -> do responseValue <- liftIO (Grace.Aeson.decode responseBody) value <- Infer.checkJSON solvedSchema responseValue return (fmap (\_ -> Unknown) value) Syntax.Read{ schema = Nothing } -> do Exception.throwIO MissingSchema Syntax.Read{ import_, arguments, schema = Just schema } -> do newArguments <- loop env arguments text <- case decode newArguments of Left exception -> Exception.throwIO exception Right text -> return text if import_ then do bindings <- generateContext env parent <- Reader.ask Reader.local (\i -> i <> Code "(read)" text) do child <- Reader.ask Import.referentiallySane parent child (_, value) <- Interpret.interpretWith bindings (Just schema) return value else do aesonValue <- liftIO (Grace.Aeson.decode text) Status{ context } <- State.get let solvedSchema = Context.solveType context schema value <- Infer.checkJSON solvedSchema aesonValue return (fmap (\_ -> Unknown) value) Syntax.GitHub{ schema = Nothing } -> do Exception.throwIO MissingSchema Syntax.GitHub{ import_, arguments, schema = Just schema } -> do newArguments <- loop env arguments github <- case decode newArguments of Left exception -> Exception.throwIO exception Right http -> return http url <- liftIO (GitHub.github github) if import_ then do bindings <- generateContext env uri <- liftIO (URI.mkURI url) parent <- Reader.ask Reader.local (\i -> i <> URI uri AsCode) do child <- Reader.ask Import.referentiallySane parent child (_, value) <- Interpret.interpretWith bindings (Just schema) return value else do responseBody <- liftIO $ HTTP.http import_ GET { url = url , headers = Nothing , parameters = Nothing } Status{ context } <- State.get let solvedSchema = Context.solveType context schema case solvedSchema of Type.Scalar{ location, scalar = Monotype.Text } -> return (Value.Text location responseBody) _ -> do aesonValue <- liftIO (Grace.Aeson.decode responseBody) value <- Infer.checkJSON solvedSchema aesonValue return (fmap (\_ -> Unknown) value) Syntax.Show{ location, export = False, arguments = v } -> do v' <- loop env v case Value.toJSON v' of Just value -> do let lazyBytes = Aeson.encode value let strictBytes = ByteString.Lazy.toStrict lazyBytes case Encoding.decodeUtf8' strictBytes of Left _ -> error "Grace.Normalize.evaluate: show produced non-UTF8 text" Right text -> pure (Value.Text location text) Nothing -> do error "Grace.Normalize.evaluate: show argument is not valid JSON" Syntax.Show{ location, export = True, arguments = v } -> do v' <- loop env v return (Value.Text location (Pretty.toSmart (Value.quote v'))) Syntax.Scalar{ location, scalar } -> pure (Value.Scalar location scalar) Syntax.Operator{ location, operator = Syntax.And, left, right } -> do left' <- loop env left right' <- loop env right pure case (left', right') of (Value.Scalar _ (Bool l), Value.Scalar _ (Bool r)) -> Value.Scalar location (Bool (l && r)) _ -> error "Grace.Normalize.evaluate: && arguments must be boolean values" Syntax.Operator{ location, operator = Syntax.Or, left, right } -> do left' <- loop env left right' <- loop env right pure case (left', right') of (Value.Scalar _ (Bool l), Value.Scalar _ (Bool r)) -> Value.Scalar location (Bool (l || r)) _ -> error "Grace.Normalize.evaluate: || arguments must be boolean values" Syntax.Operator{ location, operator = Syntax.Equal, left, right } -> do left' <- loop env left right' <- loop env right pure (Value.Scalar location (Bool (void left' == void right'))) Syntax.Operator{ location, operator = Syntax.NotEqual, left, right } -> do left' <- loop env left right' <- loop env right pure (Value.Scalar location (Bool (left' /= right'))) Syntax.Operator{ location, operator = Syntax.LessThan, left, right } -> do left' <- loop env left right' <- loop env right pure case (left', right') of (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) -> Value.Scalar location (Bool (m < n)) (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) -> Value.Scalar location (Bool (m < n)) (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) -> Value.Scalar location (Bool (m < n)) _ -> error "Grace.Normalize.evaluate: < arguments must be numeric values of the same type" Syntax.Operator{ location, operator = Syntax.LessThanOrEqual, left, right } -> do left' <- loop env left right' <- loop env right pure case (left', right') of (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) -> Value.Scalar location (Bool (m <= n)) (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) -> Value.Scalar location (Bool (m <= n)) (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) -> Value.Scalar location (Bool (m <= n)) _ -> error "Grace.Normalize.evaluate: <= arguments must be numeric values of the same type" Syntax.Operator{ location, operator = Syntax.GreaterThan, left, right } -> do left' <- loop env left right' <- loop env right pure case (left', right') of (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) -> Value.Scalar location (Bool (m > n)) (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) -> Value.Scalar location (Bool (m > n)) (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) -> Value.Scalar location (Bool (m > n)) _ -> error "Grace.Normalize.evaluate: > arguments must be numeric values of the same type" Syntax.Operator{ location, operator = Syntax.GreaterThanOrEqual, left, right } -> do left' <- loop env left right' <- loop env right pure case (left', right') of (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) -> Value.Scalar location (Bool (m >= n)) (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) -> Value.Scalar location (Bool (m >= n)) (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) -> Value.Scalar location (Bool (m >= n)) _ -> error "Grace.Normalize.evaluate: >= arguments must be numeric values of the same type" Syntax.Operator{ location, operator = Syntax.Times, left, right } -> do left' <- loop env left right' <- loop env right pure case (left', right') of (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) -> Value.Scalar location (Natural (m * n)) (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) -> Value.Scalar location (Integer (m * n)) (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) -> Value.Scalar location (Real (m * n)) _ -> error "Grace.Normalize.evaluate: * arguments must be numeric values of the same type" Syntax.Operator{ location, operator = Syntax.Plus, left, right } -> do left' <- loop env left right' <- loop env right pure case (left', right') of (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) -> Value.Scalar location (Natural (m + n)) (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) -> Value.Scalar location (Integer (m + n)) (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) -> Value.Scalar location (Real (m + n)) (Value.Text _ l, Value.Text _ r) -> Value.Text location (l <> r) (Value.List _ l, Value.List _ r) -> Value.List location (l <> r) _ -> error "Grace.Normalize.evaluate: + arguments must be numeric values of the same type" Syntax.Operator{ location, operator = Syntax.Minus, left, right } -> do left' <- loop env left right' <- loop env right pure case (left', right') of (Value.Scalar _ (Natural m), Value.Scalar _ (Natural n)) -> Value.Scalar location (Integer (fromIntegral m - fromIntegral n)) (Value.Scalar _ (Integer m), Value.Scalar _ (Integer n)) -> Value.Scalar location (Integer (m - n)) (Value.Scalar _ (Real m), Value.Scalar _ (Real n)) -> Value.Scalar location (Real (m - n)) _ -> error "Grace.Normalize.evaluate: - arguments must be numeric values of the same type" Syntax.Operator{ location, operator = Syntax.Modulus, left, right } -> do left' <- loop env left right' <- loop env right pure do let divisor = case right' of Value.Scalar _ (Natural n) -> n _ -> error "Grace.Normalize.evaluate: right argument to % must be a Natural number literal" let (quotient, remainder) = case left' of Value.Scalar _ (Natural n) -> ( Value.Scalar location (Natural q) , Value.Scalar location (Natural r) ) where (q, r) = n `divMod` divisor Value.Scalar _ (Integer n) -> ( Value.Scalar location (Integer q) , Value.Scalar location (Integer r) ) where (q, r) = n `divMod` fromIntegral divisor Value.Scalar _ (Real x) -> ( Value.Scalar location (Integer q) , Value.Scalar location (Real (fromIntegral r + f')) ) where (n, f) = properFraction x (n', f') | f < 0 = (n - 1, f + 1) | otherwise = (n, f) (q, r) = n' `divMod` fromIntegral divisor _ -> error "Grace.Normalize.evaluate: left argument to % must be a numeric value" Value.Record location [ ("quotient", (location, quotient)) , ("remainder", (location, remainder)) ] Syntax.Operator{ location, operator = Syntax.Divide, left, right } -> do left' <- loop env left right' <- loop env right pure do let numerator = case left' of Value.Scalar _ (Natural n) -> fromIntegral n Value.Scalar _ (Integer n) -> fromInteger n Value.Scalar _ (Real n) -> Scientific.toRealFloat n _ -> error "Grace.Normalize.evaluate: / arguments must be real numbers" let denominator = case right' of Value.Scalar _ (Natural n) -> fromIntegral n Value.Scalar _ (Integer n) -> fromInteger n Value.Scalar _ (Real n) -> Scientific.toRealFloat n _ -> error "Grace.Normalize.evaluate: / arguments must be real numbers" Value.Scalar location (Real (Scientific.fromFloatDigits (numerator / denominator :: Double))) Syntax.Builtin{ location, builtin } -> pure (Value.Builtin location builtin) Syntax.Embed{ embedded } -> Void.absurd embedded {-| This is the function that implements function application, including evaluating anonymous functions and evaluating all built-in functions. -} apply :: Location -> Value Location -- ^ Function -> Value Location -- ^ Argument -> Grace (Value Location) apply applicationLocation function₀ argument₀ = loop function₀ argument₀ where loop (Value.Lambda _ capturedEnv (Value.Name _ name Nothing) body) argument = evaluate ((name, argument) : capturedEnv) body loop (Value.Lambda _ capturedEnv (Value.Name _ name (Just assignment)) body) (Value.Scalar _ Null) = evaluate ((name, assignment) : capturedEnv) body loop (Value.Lambda _ capturedEnv (Value.Name _ name (Just _)) body) (Value.Application _ (Value.Builtin _ Some) argument) = evaluate ((name, argument) : capturedEnv) body loop (Value.Lambda _ capturedEnv (Value.FieldNames _ fieldNames) body) (Value.Record keyValuesLocation keyValues) = evaluate (extraEnv <> capturedEnv) body where extraEnv = do (_, fieldName, assignment) <- fieldNames let value = case assignment of Nothing -> case HashMap.lookup fieldName keyValues of Just (_, n) -> n Nothing -> Value.Scalar keyValuesLocation Null Just a -> case HashMap.lookup fieldName keyValues of Just (_, Value.Application _ (Value.Builtin _ Some) n) -> n Just (_, Value.Scalar _ Null) -> a Nothing -> a -- This case should only be hit if elaboration fails Just (_, n) -> n return (fieldName, value) loop (Value.Fold _ (Value.Record fieldValuesLocation fieldValues)) (Value.Scalar _ (Bool b)) = pure (if b then trueHandler else falseHandler) where falseHandler = case HashMap.lookup "false" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v trueHandler = case HashMap.lookup "true" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v loop (Value.Fold _ (Value.Record fieldValuesLocation fieldValues)) (Value.Scalar _ (Natural n)) = go n zero where zero = case HashMap.lookup "zero" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v succ = case HashMap.lookup "succ" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v go 0 !result = do return result go m !result = do x <- loop succ result go (m - 1) x loop (Value.Fold _ (Value.Record fieldValuesLocation fieldValues)) (Value.Application _ (Value.Builtin _ Some) x) = loop some x where some = case HashMap.lookup "some" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v loop (Value.Fold _ (Value.Record fieldValuesLocation fieldValues)) (Value.Scalar _ Null) = pure null where null = case HashMap.lookup "null" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v loop (Value.Fold _ (Value.Record _ (sorted -> [("cons", (_, cons)), ("nil", (_, nil))]))) (Value.List _ elements) = do inner (Seq.reverse elements) nil where inner xs !result = case Seq.viewl xs of EmptyL -> do return result y :< ys -> do a <- loop cons y b <- loop a result inner ys b loop (Value.Fold _ (Value.Record _ alternativeHandlers)) (Value.Alternative _ alternative x) | Just (_, f) <- HashMap.lookup alternative alternativeHandlers = loop f x loop (Value.Fold _ (Value.Record fieldValuesLocation fieldValues)) v0 = inner v0 where array = case HashMap.lookup "array" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v bool = case HashMap.lookup "bool" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v integer = case HashMap.lookup "integer" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v natural = case HashMap.lookup "natural" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v null = case HashMap.lookup "null" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v object = case HashMap.lookup "object" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v real = case HashMap.lookup "real" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v string = case HashMap.lookup "string" fieldValues of Nothing -> Value.Scalar fieldValuesLocation Null Just (_, v) -> v inner (Value.Scalar location (Bool b)) = loop bool (Value.Scalar location (Bool b)) inner (Value.Scalar location (Natural n)) = loop natural (Value.Scalar location (Natural n)) inner (Value.Scalar location (Integer n)) = loop integer (Value.Scalar location (Integer n)) inner (Value.Scalar location (Real n)) = loop real (Value.Scalar location (Real n)) inner (Value.Text location t) = loop string (Value.Text location t) inner (Value.Scalar _ Null) = pure null inner (Value.List location elements) = do newElements <- traverse inner elements loop array (Value.List location newElements) inner (Value.Record location keyValues) = do elements <- traverse adapt (HashMap.toList keyValues) loop object (Value.List location (Seq.fromList elements)) where adapt (key, (keyLocation, value)) = do newValue <- inner value return ( Value.Record keyLocation [ ("key", (keyLocation, Value.Text keyLocation key)) , ("value", (keyLocation, newValue)) ] ) inner v = pure v loop (Value.Builtin builtinLocation Indexed) (Value.List location elements) = pure (Value.List location (Seq.mapWithIndex adapt elements)) where adapt index value = Value.Record builtinLocation [ ("index", (builtinLocation, Value.Scalar builtinLocation (Natural (fromIntegral index)))) , ("value", (builtinLocation, value)) ] loop (Value.Builtin location Length) (Value.List _ elements) = pure (Value.Scalar location (Natural (fromIntegral (length elements)))) loop (Value.Application _ (Value.Builtin _ Map) f) (Value.List location elements) = do newElements <- traverse (loop f) elements return (Value.List location newElements) loop (Value.Builtin _ Abs) (Value.Scalar location (Integer n)) = pure (Value.Scalar location (Natural (fromInteger (abs n)))) loop (Value.Builtin location YAML) v = do case Value.toJSON v of Just value -> do let lazyBytes = YAML.encodeQuoted value let strictBytes = ByteString.Lazy.toStrict lazyBytes case Encoding.decodeUtf8' strictBytes of Left _ -> error "Grace.Normalize.evaluate: yaml produced non-UTF8 text" Right text -> pure (Value.Text location text) Nothing -> do error "Grace.Normalize.evaluate: yaml argument is not valid JSON" loop (Value.Builtin _ Reveal) (Value.Scalar location (Key text)) = pure (Value.Text location text) loop function argument = pure (Value.Application applicationLocation function argument) -- | Strip all `Some`s from a `Syntax` tree strip :: Syntax s a -> Syntax s a strip = Lens.transform transformation where transformation Syntax.Application{ function = Syntax.Builtin{ builtin = Some }, argument } = argument transformation e = e -- | Missing API credentials data MissingCredentials = MissingCredentials deriving stock (Show) instance Exception MissingCredentials where displayException MissingCredentials = "Missing credentials\n\ \\n\ \You need to provide API credentials in order to use the prompt keyword" -- | Elaboration didn't infer a schema data MissingSchema = MissingSchema deriving stock (Show) instance Exception MissingSchema where displayException MissingSchema = "Internal error - Elaboration failed to infer schema" ================================================ FILE: src/Grace/Parallelizable.hs ================================================ -- | Computations with optional concurrency module Grace.Parallelizable ( -- * Monad Parallelizable(..) , serialize ) where import Control.Applicative (liftA2) import Control.Concurrent.Async (Concurrently(..)) import Control.Exception.Safe (MonadCatch) import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Reader (MonadReader(..)) import Control.Monad.State (MonadState(..)) import Control.Monad.Trans (MonadTrans(..)) import Prelude hiding (liftA2) -- | The `Concurrent` segment (if any) of a `Parallelizable` computation data Concurrent io a = Concurrent (Concurrently (Parallelizable io a)) | Pure a deriving stock (Functor) instance MFunctor Concurrent where hoist nat (Concurrent concurrently) = Concurrent (fmap (hoist nat) concurrently) hoist _ (Pure a) = Pure a {-| This represents a computation that alternates between `Serial` and `Concurrent` segments. The `Applicative` instance will try to run `Concurrent` segments in parallel as much as possible. -} newtype Parallelizable io a = Serial{ serial :: io (Concurrent io a) } deriving stock (Functor) -- | Serialize a `Parallelizable` computation serialize :: MonadIO io => Parallelizable io a -> io a serialize Serial{ serial } = do step <- serial case step of Pure a -> do return a Concurrent concurrently -> do parallelizable <- liftIO (runConcurrently concurrently) serialize parallelizable instance Monad io => Applicative (Parallelizable io) where pure a = Serial{ serial = pure (Pure a) } Serial{ serial = serial₀ } <*> Serial{ serial = serial₁ } = Serial{ serial } where serial = do step₀ <- serial₀ case step₀ of Pure f -> do fmap (fmap f) serial₁ Concurrent concurrently₀ -> do step₁ <- serial₁ case step₁ of Pure x -> do return (Concurrent (fmap (fmap (\f -> f x)) concurrently₀)) Concurrent concurrently₁ -> do let concurrently = do parallelizable₀ <- concurrently₀ parallelizable₁ <- concurrently₁ return (parallelizable₀ <*> parallelizable₁) return (Concurrent concurrently) instance Monad io => Monad (Parallelizable io) where Serial{ serial = serial₀ } >>= f = Serial{ serial = serial₁ } where serial₁ = do step <- serial₀ case step of Pure x -> do serial (f x) Concurrent concurrently -> do return (Concurrent (fmap (>>= f) concurrently)) instance MonadTrans Parallelizable where lift m = Serial{ serial } where serial = do a <- m return (Pure a) instance MonadIO io => MonadIO (Parallelizable io) where liftIO io = lift (liftIO io) instance (Monad io, Semigroup a) => Semigroup (Parallelizable io a) where (<>) = liftA2 (<>) instance (Monad io, Monoid a) => Monoid (Parallelizable io a) where mempty = pure mempty instance MFunctor Parallelizable where hoist nat Serial{ serial = serial₀ } = Serial{ serial = serial₁ } where serial₁ = nat (fmap (hoist nat) serial₀) instance (MonadState s io) => MonadState s (Parallelizable io) where get = lift get put s = lift (put s) state f = lift (state f) instance (MonadThrow io) => MonadThrow (Parallelizable io) where throwM e = lift (throwM e) instance (MonadCatch io, MonadIO io) => MonadCatch (Parallelizable io) where catch m f = lift (catch (serialize m) (serialize . f)) instance (MonadReader r io) => MonadReader r (Parallelizable io) where ask = lift ask local f = hoist (local f) ================================================ FILE: src/Grace/Parser.hs ================================================ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecursiveDo #-} {-| This module contains the logic for lexing and parsing Grace files The main reason for a separate lexing step using is because we would like to use @Earley@ for LR parsing, but @Earley@ is not fast enough to handle character-by-character parsing. Instead, we delegate lexing to a lower-level parsing library that supports efficient bulk parsing (@megaparsec@ in this case). The main reason for not using @alex@ (for lexing) or @happy@ (for parsing) is because they use a separate code generation step, which leads to worse type errors and poor support for interactive type-checking. The main reason for not using @attoparsec@ or @megaparsec@ for everything is because LR parsers are easier to maintain due to not needing to left-factor the grammar. -} module Grace.Parser ( -- * Parsing parse , parseREPLCommand , REPLCommand(..) -- * Errors related to parsing , ParseError(..) ) where import Control.Applicative (empty, many, optional, some, (<|>)) import Control.Applicative.Combinators (endBy, sepBy) import Control.Applicative.Combinators.NonEmpty (sepBy1) import Control.Exception.Safe (Exception(..)) import Control.Monad.Combinators (manyTill) import Data.Functor (void) import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty(..), some1) import Data.Maybe (fromJust) import Data.Scientific (Scientific) import Data.Semigroup (sconcat) import Data.Text (Text) import Data.Void (Void) import Grace.Input (Input(..), Mode(..)) import Grace.Location (Location(..), Offset(..)) import Grace.Type (Type(..)) import Numeric.Natural (Natural) import Prelude hiding (lex, lines, unlines) import Text.Earley (Grammar, Prod, Report(..), rule, ()) import Text.Megaparsec (ParseErrorBundle(..), State(..), try) import Grace.Syntax ( Assignment(..) , Binding(..) , BindMonad(..) , Chunks(..) , Field(..) , NameBinding(..) , Smaller(..) , Syntax(..) ) import qualified Control.Monad as Monad import qualified Control.Monad.Combinators as Combinators import qualified Data.Char as Char import qualified Data.HashSet as HashSet import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Read as Read import qualified Grace.Domain as Domain import qualified Grace.Label as Label import qualified Grace.Location as Location import qualified Grace.Monotype as Monotype import qualified Grace.Syntax as Syntax import qualified Grace.Type as Type import qualified Text.Earley as Earley import qualified Text.Megaparsec as Megaparsec import qualified Text.Megaparsec.Char as Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as Lexer import qualified Text.Megaparsec.Error as Error import qualified Text.URI as URI -- | Short-hand type synonym used by lexing utilities type Lexer = Megaparsec.Parsec Void Text space :: Lexer () space = Lexer.space Megaparsec.Char.space1 (Lexer.skipLineComment "#") empty symbol :: Text -> Lexer Text symbol = Lexer.symbol space lexeme :: Lexer a -> Lexer a lexeme = Lexer.lexeme space lexToken :: Lexer Token lexToken = Combinators.choice [ -- `file` has to come before the lexer for `.` so that a file -- prefix of `.` or `..` is not lexed as a field access lexFile , lexUri , lexLabel , lexNumber , lexDotNumber , Combinators.choice [ Grace.Parser.Or <$ symbol "||" , Grace.Parser.And <$ symbol "&&" , Grace.Parser.Plus <$ symbol "+" , Grace.Parser.Times <$ symbol "*" , Grace.Parser.Modulus <$ symbol "%" , Grace.Parser.ForwardSlash <$ symbol "/" , Grace.Parser.DoubleEquals <$ symbol "==" , Grace.Parser.NotEqual <$ symbol "!=" , Grace.Parser.LessThanOrEqual <$ symbol "<=" , Grace.Parser.GreaterThanOrEqual <$ symbol ">=" ] Megaparsec. "operator" , Combinators.choice [ Grace.Parser.Abs <$ symbol "abs" , Grace.Parser.False_ <$ symbol "false" , Grace.Parser.Indexed <$ symbol "indexed" , Grace.Parser.Length <$ symbol "length" , Grace.Parser.Map <$ symbol "map" , Grace.Parser.Null <$ symbol "null" , Grace.Parser.Reveal <$ symbol "reveal" , Grace.Parser.Some <$ symbol "some" , Grace.Parser.True_ <$ symbol "true" , Grace.Parser.YAML <$ symbol "yaml" ] Megaparsec. "built-in value" , Combinators.choice [ Grace.Parser.Else <$ symbol "else" , Grace.Parser.Export <$ symbol "export" , Grace.Parser.Forall <$ symbol "forall" , Grace.Parser.Fold <$ symbol "fold" , Grace.Parser.For <$ symbol "for" , Grace.Parser.GitHub <$ symbol "github" , Grace.Parser.HTTP <$ symbol "http" , Grace.Parser.Read <$ symbol "read" , Grace.Parser.If <$ symbol "if" , Grace.Parser.Import <$ symbol "import" , Grace.Parser.In <$ symbol "in" , Grace.Parser.Let <$ symbol "let" , Grace.Parser.Of <$ symbol "of" , Grace.Parser.Prompt <$ symbol "prompt" , Grace.Parser.Show <$ symbol "show" , Grace.Parser.Then <$ symbol "then" , Grace.Parser.Alternatives <$ symbol "Alternatives" , Grace.Parser.Fields <$ symbol "Fields" , Grace.Parser.Type <$ symbol "Type" ] Megaparsec. "keyword" , Combinators.choice [ Grace.Parser.List <$ symbol "List" , Grace.Parser.Optional <$ symbol "Optional" , Grace.Parser.Real <$ symbol "Real" , Grace.Parser.Integer <$ symbol "Integer" , Grace.Parser.JSON <$ symbol "JSON" , Grace.Parser.Key <$ symbol "Key" , Grace.Parser.Natural <$ symbol "Natural" , Grace.Parser.Bool <$ symbol "Bool" , Grace.Parser.Text <$ symbol "Text" ] Megaparsec. "built-in type" , Grace.Parser.OpenAngle <$ symbol "<" , Grace.Parser.CloseAngle <$ symbol ">" , Grace.Parser.OpenBrace <$ symbol "{" , Grace.Parser.CloseBrace <$ symbol "}" , Grace.Parser.OpenBracket <$ symbol "[" , Grace.Parser.CloseBracket <$ symbol "]" , Grace.Parser.OpenParenthesis <$ symbol "(" , Grace.Parser.CloseParenthesis <$ symbol ")" , Grace.Parser.Arrow <$ symbol "->" , Grace.Parser.At <$ symbol "@" , Grace.Parser.Bar <$ symbol "|" , Grace.Parser.Colon <$ symbol ":" , Grace.Parser.Comma <$ symbol "," , Grace.Parser.Dash <$ symbol "-" , Grace.Parser.Dot <$ symbol "." , Grace.Parser.Equals <$ symbol "=" , Grace.Parser.Lambda <$ symbol "\\" , lexText , lexAlternative ] lexLocatedToken :: Lexer LocatedToken lexLocatedToken = do state <- Megaparsec.getParserState token <- lexToken return LocatedToken{ token, state } lexLocatedTokens :: Lexer [LocatedToken] lexLocatedTokens = do space manyTill lexLocatedToken Megaparsec.eof -- | Lex a complete expression lex :: String -- ^ Name of the input (used for error messages) -> Text -- ^ Source code -> Either ParseError [LocatedToken] lex name code = case Megaparsec.parse lexLocatedTokens name code of Left ParseErrorBundle{ bundleErrors } -> do let bundleError :| _ = bundleErrors let offset = Offset (Error.errorOffset bundleError) Left (LexingFailed (Location{ name, code, offset })) Right tokens -> do return tokens lexSign :: Lexer Sign lexSign = (Positive <$ "+") <|> (Negative <$ "-") <|> pure Unsigned lexNumber :: Lexer Token lexNumber = try lexInteger <|> try lexScientific where lexInteger = do sign <- lexSign n <- lexeme Lexer.decimal <* Megaparsec.notFollowedBy (Megaparsec.Char.char '.') return (Int sign n) lexScientific = do sign <- lexSign scientific <- lexeme Lexer.scientific return (RealLiteral sign scientific) lexDotNumber :: Lexer Token lexDotNumber = try do symbol "." sign <- lexSign n <- lexeme Lexer.decimal return case sign of Unsigned -> DotNumber (fromInteger n) Positive -> DotNumber (fromInteger n) Negative -> DotNumber (negate (fromInteger n)) lexFile :: Lexer Token lexFile = (lexeme . try) do prefix <- ("../" <|> "./" <|> "/" <|> "~/") Megaparsec. "path character" let isPath c = '\x21' == c || ('\x24' <= c && c <= '\x27') || ('\x2A' <= c && c <= '\x2B') || ('\x2D' <= c && c <= '\x2E') || ('\x30' <= c && c <= '\x3B') || '\x3D' == c || ('\x40' <= c && c <= '\x5A') || ('\x5E' <= c && c <= '\x7A') || ('\x7C' == c) || '\x7E' == c let pathComponent = Megaparsec.takeWhile1P (Just "path character") isPath suffix <- pathComponent `sepBy1` "/" return (File (concatMap Text.unpack (prefix : List.intersperse "/" (toList suffix)))) lexUri :: Lexer Token lexUri = (lexeme . try) do u <- URI.parser let schemes = map (fromJust . URI.mkScheme) [ "https", "http", "env", "file" ] if any (`elem` schemes) (URI.uriScheme u) then return (Grace.Parser.URI u) else fail "Unsupported Grace URI" lines :: Chunks s a -> NonEmpty (Chunks s a) lines = loop mempty where loop :: Chunks s a -> Chunks s a -> NonEmpty (Chunks s a) loop currentLine (Chunks text₀ rest) | Text.null suffix = case rest of [] -> (currentLine <> Chunks prefix []) :| [] (interpolation, text₁) : est -> loop (currentLine <> Chunks prefix [(interpolation, "")]) (Chunks text₁ est) | otherwise = NonEmpty.cons (currentLine <> Chunks prefix []) (loop mempty (Chunks (Text.drop 1 suffix) rest)) where (prefix, suffix) = Text.breakOn "\n" text₀ unlines :: NonEmpty (Chunks s a) -> Chunks s a unlines ls = sconcat (NonEmpty.intersperse "\n" ls) commonPrefix :: NonEmpty (Chunks s a) -> Text commonPrefix ls = List.foldl' longestCommonPrefix t ts where t :| ts = fmap toPrefix (removeEmpty ls) toPrefix (Chunks text₀ _) = Text.takeWhile isPrefixCharacter text₀ where isPrefixCharacter c = c == ' ' || c == '\t' longestCommonPrefix x y = case Text.commonPrefixes x y of Nothing -> "" Just (prefix, _, _) -> prefix removeEmpty :: NonEmpty (Chunks s a) -> NonEmpty (Chunks s a) removeEmpty ls = prependList (filter present initLines) (pure lastLine) where initLines = NonEmpty.init ls lastLine = NonEmpty.last ls present (Chunks "" []) = False present _ = True prependList :: [a] -> NonEmpty a -> NonEmpty a prependList [] ys = ys prependList (x : xs) (y :| ys) = x :| (xs <> (y : ys)) dedent :: Chunks s a -> Chunks s a dedent c = unlines (fmap stripPrefix ls) where ls = lines c prefix = commonPrefix ls stripPrefix (Chunks text₀ rest) = Chunks (Text.drop (Text.length prefix) text₀) rest lexText :: Lexer Token lexText = lexeme do "\"" multiline <- (True <$ "\n") <|> pure False let isText c = ('\x09' <= c && c <= '\x0A' && multiline) || ('\x20' <= c && c <= '\x21') || '\x23' == c || ('\x25' <= c && c <= '\x5b') || ('\x5d' <= c && c <= '\x10FFFF') let unescaped = do t <- Megaparsec.takeWhile1P (Just "text character") isText return (Chunks t []) let unicodeEscape = do "\\u" codepoint <- Combinators.count 4 Megaparsec.Char.hexDigitChar case Read.hexadecimal (Text.pack codepoint) of Right (n, "") -> do return (Chunks (Text.singleton (Char.chr n)) []) _ -> do fail "Internal error - invalid unicode escape sequence" let escaped = Combinators.choice ( ( if multiline then [] else [ "\n" <$ "\\n", "\t" <$ "\\t" ] ) <> [ "\"" <$ "\\\"" , "\\" <$ "\\\\" , "/" <$ "\\/" , "\b" <$ "\\b" , "\f" <$ "\\f" , "\r" <$ "\\r" , "$" <$ "\\$" , unicodeEscape ] ) Megaparsec. "escape sequence" let interpolated = do "${" originalState <- Megaparsec.getParserState let loop state = case result of Left _ -> [] Right token -> token : loop newState where (newState, result) = Megaparsec.runParser' lexLocatedToken state let locatedTokens = loop afterSpace where (afterSpace, _) = Megaparsec.runParser' space originalState (syntax, index) <- case Earley.allParses (Earley.parser (grammar (Interpolation id))) locatedTokens of ([], Report{ position }) -> do case drop position locatedTokens of [] -> return () LocatedToken{ state } : _ -> Megaparsec.setParserState state empty Megaparsec. "Incomplete string interpolation" (result : _, _) -> do return result case drop (index - 1) locatedTokens of [] -> do empty Megaparsec. "Incomplete string literal" LocatedToken{ state } : _ -> do Megaparsec.setParserState state "}" return (Chunks mempty [(syntax, mempty)]) chunks <- many (unescaped <|> interpolated <|> escaped <|> ("$" <$ "$")) let chunk = mconcat chunks let dedented | multiline = dedent chunk | otherwise = chunk "\"" return (TextLiteral dedented) lexLabel :: Lexer Token lexLabel = lexUnquotedLabel <|> lexQuotedLabel lexUnquotedLabel :: Lexer Token lexUnquotedLabel = (try . lexeme) do c0 <- Megaparsec.satisfy Label.isLabel0 Megaparsec. "label character" cs <- Megaparsec.takeWhileP (Just "label character") Label.isLabel let name = Text.cons c0 cs Monad.guard (not (HashSet.member name Label.reservedLabels)) return (Label name) lexQuotedLabel :: Lexer Token lexQuotedLabel = (try . lexeme) do "." name <- lexSingleQuoted return (Label name) lexUnquotedAlternative :: Lexer Token lexUnquotedAlternative = (try . lexeme) do c0 <- Megaparsec.satisfy Label.isAlternativeLabel0 Megaparsec. "alternative character" cs <- Megaparsec.takeWhileP (Just "alternative character") Label.isLabel let name = Text.cons c0 cs Monad.guard (not (HashSet.member name Label.reservedLabels)) return (Grace.Parser.Alternative name) lexSingleQuoted :: Lexer Text lexSingleQuoted = do "'" let isText c = ('\x20' <= c && c <= '\x26') || ('\x28' <= c && c <= '\x5c') || ('\x5d' <= c && c <= '\x10FFFF') let unescaped = Megaparsec.takeWhile1P (Just "alternative character") isText let unicodeEscape = do "\\u" codepoint <- Combinators.count 4 Megaparsec.Char.hexDigitChar case Read.hexadecimal (Text.pack codepoint) of Right (n, "") -> do return (Text.singleton (Char.chr n)) _ -> do fail "Internal error - invalid unicode escape sequence" let escaped = Combinators.choice [ "'" <$ "\\\'" , "\\" <$ "\\\\" , "/" <$ "\\/" , "\b" <$ "\\b" , "\f" <$ "\\f" , "\n" <$ "\\n" , "\r" <$ "\\r" , "\t" <$ "\\t" , unicodeEscape ] Megaparsec. "escape sequence" texts <- many (unescaped <|> escaped) "'" return (Text.concat texts) lexQuotedAlternative :: Lexer Token lexQuotedAlternative = lexeme do name <- lexSingleQuoted return (Grace.Parser.Alternative name) lexAlternative :: Lexer Token lexAlternative = lexUnquotedAlternative <|> lexQuotedAlternative -- | Tokens produced by lexing data Token = Abs | Alternative Text | Alternatives | And | Arrow | At | Bar | Bool | CloseAngle | CloseBrace | CloseBracket | CloseParenthesis | Colon | Comma | Dash | Dot | DotNumber Integer | DoubleEquals | Else | Equals | Export | False_ | Fields | File FilePath | Fold | For | Forall | ForwardSlash | GitHub | GreaterThanOrEqual | If | Import | In | Indexed | Int Sign Natural | Integer | JSON | Key | Label Text | Lambda | Length | LessThanOrEqual | Let | List | Map | Modulus | Natural | NotEqual | Null | Of | OpenAngle | OpenBrace | OpenBracket | OpenParenthesis | Optional | Or | Plus | HTTP | Prompt | Read | Real | RealLiteral Sign Scientific | Reveal | Show | Some | Text | TextLiteral (Chunks Offset Input) | Then | Times | True_ | Type | URI URI.URI | YAML deriving stock (Eq, Show) data Sign = Unsigned | Positive | Negative deriving stock (Eq, Show) {-| A token with parsing state attached, used for reporting line and column numbers in error messages -} data LocatedToken = LocatedToken { token :: Token, state :: State Text Void } deriving stock (Show) -- | Errors related to lexing and parsing data ParseError = LexingFailed Location | ParsingFailed Location deriving stock (Eq, Show) instance Exception ParseError where displayException (LexingFailed location) = Text.unpack (Location.renderError "Invalid input - Lexing failed" location) displayException (ParsingFailed location) = Text.unpack (Location.renderError "Invalid input - Parsing failed" location) type Parser r = Prod r Text LocatedToken matchLabel :: Token -> Maybe Text matchLabel (Grace.Parser.Label l) = Just l matchLabel _ = Nothing matchReservedLabel :: Token -> Maybe Text matchReservedLabel Grace.Parser.Some = Just "some" matchReservedLabel Grace.Parser.Null = Just "null" matchReservedLabel Grace.Parser.True_ = Just "true" matchReservedLabel Grace.Parser.False_ = Just "false" matchReservedLabel _ = Nothing matchAlternative :: Token -> Maybe Text matchAlternative (Grace.Parser.Alternative a) = Just a matchAlternative _ = Nothing matchReal :: Token -> Maybe (Sign, Scientific) matchReal (Grace.Parser.RealLiteral sign n) = Just (sign, n) matchReal _ = Nothing matchInt :: Token -> Maybe (Sign, Natural) matchInt (Grace.Parser.Int sign n) = Just (sign, n) matchInt _ = Nothing matchDotNumber :: Token -> Maybe Integer matchDotNumber (Grace.Parser.DotNumber n) = Just n matchDotNumber _ = Nothing matchChunks :: Token -> Maybe (Chunks Offset Input) matchChunks (Grace.Parser.TextLiteral c) = Just c matchChunks _ = Nothing matchText :: Token -> Maybe Text matchText (Grace.Parser.TextLiteral (Chunks t [])) = Just t matchText _ = Nothing matchFile :: Token -> Maybe FilePath matchFile (Grace.Parser.File f) = Just f matchFile _ = Nothing matchURI :: Token -> Maybe URI.URI matchURI (Grace.Parser.URI t) = Just t matchURI _ = Nothing terminal :: (Token -> Maybe a) -> Parser r a terminal match = Earley.terminal match' where match' locatedToken_ = match (Grace.Parser.token locatedToken_) label :: Parser r Text label = terminal matchLabel reservedLabel :: Parser r Text reservedLabel = terminal matchReservedLabel alternative :: Parser r Text alternative = terminal matchAlternative int :: Parser r (Sign, Natural) int = terminal matchInt dotNumber :: Parser r Integer dotNumber = terminal matchDotNumber text :: Parser r Text text = terminal matchText parseToken :: Token -> Parser r () parseToken t = void (Earley.satisfy predicate render t) where predicate locatedToken_ = token locatedToken_ == t locatedTerminal :: (Token -> Maybe a) -> Parser r (Offset, a) locatedTerminal match = Earley.terminal match' where match' locatedToken_@LocatedToken{ state } = do a <- match (token locatedToken_) return (Offset (stateOffset state), a) locatedLabel :: Parser r (Offset, Text) locatedLabel = locatedTerminal matchLabel locatedReservedLabel :: Parser r (Offset, Text) locatedReservedLabel = locatedTerminal matchReservedLabel locatedAlternative :: Parser r (Offset, Text) locatedAlternative = locatedTerminal matchAlternative locatedReal :: Parser r (Offset, (Sign, Scientific)) locatedReal = locatedTerminal matchReal locatedInt :: Parser r (Offset, (Sign, Natural)) locatedInt = locatedTerminal matchInt locatedChunks :: Parser r (Offset, Chunks Offset Input) locatedChunks = locatedTerminal matchChunks locatedText :: Parser r (Offset, Text) locatedText = locatedTerminal matchText locatedFile :: Parser r (Offset, FilePath) locatedFile = locatedTerminal matchFile locatedURI :: Parser r (Offset, URI.URI) locatedURI = locatedTerminal matchURI locatedToken :: Token -> Parser r Offset locatedToken expectedToken = Earley.terminal capture render expectedToken where capture LocatedToken{ token = actualToken, state } | expectedToken == actualToken = Just (Offset (stateOffset state)) | otherwise = Nothing -- | This render function is currently never used since `Location.renderError` -- does not display expected tokens at all, but I maintain this anyway in -- case someone wants to modify the code to display them. render :: Token -> Text render t = case t of Grace.Parser.Abs -> "abs" Grace.Parser.Alternative _ -> "an alternative" Grace.Parser.Alternatives -> "Alternatives" Grace.Parser.And -> "&&" Grace.Parser.Arrow -> " ->" Grace.Parser.At -> "@" Grace.Parser.Bar -> "|" Grace.Parser.Bool -> "Bool" Grace.Parser.CloseAngle -> ">" Grace.Parser.CloseBrace -> "}" Grace.Parser.CloseBracket -> "]" Grace.Parser.CloseParenthesis -> ")" Grace.Parser.Colon -> ":" Grace.Parser.Comma -> "," Grace.Parser.Dash -> "-" Grace.Parser.Dot -> "." Grace.Parser.DotNumber _ -> ".n" Grace.Parser.DoubleEquals -> "==" Grace.Parser.Else -> "else" Grace.Parser.Equals -> "=" Grace.Parser.Export -> "export" Grace.Parser.False_ -> "False" Grace.Parser.Fields -> "Fields" Grace.Parser.File _ -> "a file" Grace.Parser.Fold -> "fold" Grace.Parser.For -> "for" Grace.Parser.Forall -> "forall" Grace.Parser.ForwardSlash -> "/" Grace.Parser.GitHub -> "github" Grace.Parser.GreaterThanOrEqual -> ">=" Grace.Parser.If -> "if" Grace.Parser.Import -> "import" Grace.Parser.In -> "in" Grace.Parser.Indexed -> "indexed" Grace.Parser.Int _ _ -> "an integer literal" Grace.Parser.Integer -> "Integer" Grace.Parser.JSON -> "JSON" Grace.Parser.Key -> "Key" Grace.Parser.Label _ -> "a label" Grace.Parser.Lambda -> "\\" Grace.Parser.Length -> "length" Grace.Parser.LessThanOrEqual -> "<=" Grace.Parser.Let -> "let" Grace.Parser.List -> "list" Grace.Parser.Map -> "map" Grace.Parser.Modulus -> "%" Grace.Parser.Natural -> "Natural" Grace.Parser.NotEqual -> "!=" Grace.Parser.Null -> "null" Grace.Parser.Of -> "of" Grace.Parser.OpenAngle -> "<" Grace.Parser.OpenBrace -> "{" Grace.Parser.OpenBracket -> "<" Grace.Parser.OpenParenthesis -> "(" Grace.Parser.Optional -> "List" Grace.Parser.Or -> "||" Grace.Parser.Plus -> "+" Grace.Parser.HTTP -> "http" Grace.Parser.Prompt -> "prompt" Grace.Parser.Read -> "read" Grace.Parser.Real -> "Real" Grace.Parser.RealLiteral _ _ -> "a real number literal" Grace.Parser.Reveal -> "reveal" Grace.Parser.Show -> "show" Grace.Parser.Some -> "some" Grace.Parser.Text -> "Text" Grace.Parser.TextLiteral _ -> "a text literal" Grace.Parser.Then -> "then" Grace.Parser.Times -> "*" Grace.Parser.True_ -> "True" Grace.Parser.Type -> "Type" Grace.Parser.URI _ -> "a URI" Grace.Parser.YAML -> "yaml" {-| This is how we decide at the top-level what we want to parse, to work around the fact that the @Earley@ package only lets you return one `Parser` -} data GrammaticalForm a = Expression (Syntax Offset Input -> a) | Interpolation (Syntax Offset Input -> a) | REPLCommand (REPLCommand -> a) -- | data REPLCommand = Evaluate (Syntax Offset Input) | Assign (Assignment Offset Input) grammar :: GrammaticalForm a -> Grammar r (Parser r a) grammar form = mdo parseUnadornedBinding <- rule do ~(nameLocation, name) <- locatedLabel pure PlainBinding { plain = NameBinding { nameLocation , name , annotation = Nothing , assignment = Nothing } } parseAdornedBinding <- rule do let annotated = do parseToken Grace.Parser.OpenParenthesis ~(nameLocation, name) <- locatedLabel annotation <- optional do parseToken Grace.Parser.Colon r <- quantifiedType pure r assignment <- optional do parseToken Grace.Parser.Equals r <- expression pure r parseToken Grace.Parser.CloseParenthesis pure PlainBinding { plain = NameBinding { nameLocation , name , annotation , assignment } } let fields = do let parseAnnotation = do parseToken Grace.Parser.Colon annotation <- quantifiedType pure annotation let parseDefault = do parseToken Grace.Parser.Equals assignment <- expression pure assignment let parseFieldName = do ~(nameLocation, name) <- locatedRecordLabel annotation <- optional parseAnnotation assignment <- optional parseDefault return NameBinding{ nameLocation, name, annotation, assignment } fieldNamesLocation <- locatedToken Grace.Parser.OpenBrace fieldNames <- parseFieldName `sepBy` parseToken Grace.Parser.Comma parseToken Grace.Parser.CloseBrace pure RecordBinding{ fieldNamesLocation, fieldNames } annotated <|> fields parseBinding <- rule (parseUnadornedBinding <|> parseAdornedBinding) expression <- rule ( do location <- locatedToken Grace.Parser.Lambda bindings <- some1 parseBinding parseToken Grace.Parser.Arrow body0 <- expression return do let cons binding body = Syntax.Lambda { location , binding , body } foldr cons body0 bindings <|> do assignments <- some1 parseAssignment parseToken Grace.Parser.In body <- expression return do let location = case NonEmpty.head assignments of Syntax.Define{ definition = Syntax.Definition{ nameLocation } } -> nameLocation Syntax.Bind{ binding = Syntax.PlainBinding{ plain = Syntax.NameBinding{ nameLocation } } } -> nameLocation Syntax.Bind{ binding = Syntax.RecordBinding{ fieldNamesLocation } } -> fieldNamesLocation Syntax.Let{ location, assignments, body } <|> do location <- locatedToken Grace.Parser.If predicate <- expression parseToken Grace.Parser.Then ifTrue <- expression parseToken Grace.Parser.Else ifFalse <- expression return Syntax.If{ location, predicate, ifTrue, ifFalse } <|> do let annotatedFile = do ~(location, file) <- locatedFile return Syntax.Embed { location , embedded = Path file AsCode } let annotatedURI = do ~(location, uri) <- locatedURI return Syntax.Embed { location , embedded = Grace.Input.URI uri AsText } let adapt Syntax.Embed{ location, embedded = Path file AsCode } Type.Scalar{ scalar = Monotype.Text } = Syntax.Embed{ location, embedded = Path file AsText } adapt Syntax.Embed{ location, embedded = Path file AsCode } Type.Scalar{ scalar = Monotype.Key } = Syntax.Embed{ location, embedded = Path file AsKey } adapt Syntax.Embed{ location, embedded = Grace.Input.URI uri AsCode } Type.Scalar{ scalar = Monotype.Text } = Syntax.Embed { location , embedded = Grace.Input.URI uri AsText } adapt Syntax.Embed{ location, embedded = Grace.Input.URI uri AsCode } Type.Scalar{ scalar = Monotype.Key } = Syntax.Embed { location , embedded = Grace.Input.URI uri AsKey } adapt annotated annotation = Syntax.Annotation { location = Syntax.location annotated , annotated , annotation } annotated <- ( annotatedFile <|> annotatedURI <|> operatorExpression ) parseToken Grace.Parser.Colon annotation <- quantifiedType return (adapt annotated annotation) <|> do operatorExpression ) operatorExpression <- rule orExpression let op token_ operator subExpression = do let snoc left (operatorLocation, right) = Syntax.Operator { location = Syntax.location left , left , operatorLocation , operator , right } e0 <- subExpression ses <- many do s <- locatedToken token_ e <- subExpression; return (s, e) return (foldl snoc e0 ses) orExpression <- rule (op Grace.Parser.Or Syntax.Or andExpression) andExpression <- rule (op Grace.Parser.And Syntax.And equalExpression) equalExpression <- rule (op Grace.Parser.DoubleEquals Syntax.Equal notEqualExpression) notEqualExpression <- rule (op Grace.Parser.NotEqual Syntax.NotEqual lessThanExpression) lessThanExpression <- rule (op Grace.Parser.OpenAngle Syntax.LessThan lessThanOrEqualExpression) lessThanOrEqualExpression <- rule (op Grace.Parser.LessThanOrEqual Syntax.LessThanOrEqual greaterThanExpression) greaterThanExpression <- rule (op Grace.Parser.CloseAngle Syntax.GreaterThan greaterThanOrEqualExpression) greaterThanOrEqualExpression <- rule (op Grace.Parser.GreaterThanOrEqual Syntax.GreaterThanOrEqual plusExpression) plusExpression <- rule (op Grace.Parser.Plus Syntax.Plus minusExpression) minusExpression <- rule (op Grace.Parser.Dash Syntax.Minus timesExpression) timesExpression <- rule (op Grace.Parser.Times Syntax.Times modulusExpression) modulusExpression <- rule (op Grace.Parser.Modulus Syntax.Modulus divideExpression) divideExpression <- rule (op Grace.Parser.ForwardSlash Syntax.Divide applicationExpression) let application function argument = Syntax.Application { location = Syntax.location function , function , argument } applicationExpression <- rule do e <- ( do i <- (True <$ locatedToken Grace.Parser.Import) <|> pure False f <- ( do location <- locatedToken Grace.Parser.Prompt arguments <- projectExpression return \import_ -> Syntax.Prompt{ location, import_, arguments, schema = Nothing } <|> do location <- locatedToken Grace.Parser.HTTP arguments <- projectExpression return \import_ -> Syntax.HTTP{ location, import_, arguments, schema = Nothing } <|> do location <- locatedToken Grace.Parser.Read arguments <- projectExpression return \import_ -> Syntax.Read{ location, import_, arguments, schema = Nothing } <|> do location <- locatedToken Grace.Parser.GitHub arguments <- projectExpression return \import_ -> Syntax.GitHub{ location, import_, arguments, schema = Nothing } ) pure (f i) <|> do i <- (True <$ locatedToken Grace.Parser.Export) <|> pure False f <- ( do location <- locatedToken Grace.Parser.Show arguments <- projectExpression return \export -> Syntax.Show{ location, export, arguments, schema = Nothing } <|> do location <- locatedToken Grace.Parser.Show parseToken Grace.Parser.OpenParenthesis arguments <- operatorExpression parseToken Grace.Parser.Colon schema <- quantifiedType parseToken Grace.Parser.CloseParenthesis return \export -> Syntax.Show{ location, export, arguments, schema = Just schema } ) pure (f i) <|> do location <- locatedToken Grace.Parser.Fold handlers <- projectExpression return Syntax.Fold{ location, handlers } <|> do projectExpression ) es <- many projectExpression return (foldl application e es) projectExpression <- rule do let snoc location record f = f location record let parseField = do ~(fieldLocation, field) <- locatedRecordLabel return Syntax.Field{ fieldLocation, field } let parseSingle = do single <- parseField return \location larger -> Syntax.Project{ location, larger, smaller = Syntax.Single{ single } } let parseMultiple = do multipleLocation <- locatedToken Grace.Parser.OpenBrace multiple <- parseField `sepBy` parseToken Grace.Parser.Comma parseToken Grace.Parser.CloseBrace return \location larger -> Syntax.Project{ location, larger, smaller = Multiple{ multipleLocation, multiple } } let parseIndex = do index <- dotNumber return \location larger -> Syntax.Project{ location, larger, smaller = Index { index } } let parseSlice = do let withSign (sign, n) = case sign of Unsigned -> fromIntegral n Positive -> fromIntegral n Negative -> negate (fromIntegral n) parseToken Grace.Parser.OpenBracket begin <- fmap (fmap withSign) (optional int) parseToken Grace.Parser.Colon end <- fmap (fmap withSign) (optional int) parseToken Grace.Parser.CloseBracket return \location larger -> Syntax.Project { location , larger , smaller = Slice{ begin, end } } let parseDotAccess = do smaller <- parseIndex <|> (parseToken Grace.Parser.Dot *> (parseSingle <|> parseMultiple)) pure smaller record <- alternativeExpression projections <- many (do smaller <- parseSlice <|> parseDotAccess pure smaller ) return (foldl (snoc (Syntax.location record)) record projections) alternativeExpression <- rule ( do ~(location, name) <- locatedAlternative argument <- primitiveExpression return Syntax.Alternative{ location, name, argument } <|> primitiveExpression ) primitiveExpression <- rule ( do ~(location, name) <- locatedLabel return Syntax.Variable{ location, name } <|> do location <- locatedToken Grace.Parser.OpenBracket optional (parseToken Grace.Parser.Comma) elements <- expression `sepBy` parseToken Grace.Parser.Comma optional (parseToken Grace.Parser.Comma) parseToken Grace.Parser.CloseBracket return Syntax.List{ location, elements = Seq.fromList elements } <|> do location <- locatedToken Grace.Parser.OpenBrace optional (parseToken Grace.Parser.Comma) fieldValues <- fieldValue `sepBy` parseToken Grace.Parser.Comma optional (parseToken Grace.Parser.Comma) parseToken Grace.Parser.CloseBrace return Syntax.Record{ location, fieldValues } <|> do location <- locatedToken Grace.Parser.True_ return Syntax.Scalar{ location, scalar = Syntax.Bool True } <|> do location <- locatedToken Grace.Parser.False_ return Syntax.Scalar{ location, scalar = Syntax.Bool False } <|> do location <- locatedToken Grace.Parser.Null return Syntax.Scalar{ location, scalar = Syntax.Null } <|> do let withSign Unsigned n = Syntax.Real n withSign Positive n = Syntax.Real n withSign Negative n = Syntax.Real (negate n) ~(location, (sign, n)) <- locatedReal return Syntax.Scalar{ location, scalar = withSign sign n } <|> do let withSign Unsigned n = Syntax.Natural (fromIntegral n) withSign Positive n = Syntax.Integer (fromIntegral n) withSign Negative n = Syntax.Integer (negate (fromIntegral n)) ~(location, (sign, n)) <- locatedInt return Syntax.Scalar{ location, scalar = withSign sign n } <|> do location <- locatedToken Grace.Parser.Some return Syntax.Builtin{ location, builtin = Syntax.Some } <|> do location <- locatedToken Grace.Parser.YAML return Syntax.Builtin{ location, builtin = Syntax.YAML } <|> do location <- locatedToken Grace.Parser.Indexed return Syntax.Builtin{ location, builtin = Syntax.Indexed } <|> do location <- locatedToken Grace.Parser.Length return Syntax.Builtin{ location, builtin = Syntax.Length } <|> do location <- locatedToken Grace.Parser.Map return Syntax.Builtin{ location, builtin = Syntax.Map } <|> do location <- locatedToken Grace.Parser.Abs return Syntax.Builtin{ location, builtin = Syntax.Abs } <|> do location <- locatedToken Grace.Parser.Reveal return Syntax.Builtin{ location, builtin = Syntax.Reveal } <|> do ~(location, chunks) <- locatedChunks return Syntax.Text{ location, chunks } <|> do ~(location, file) <- locatedFile return Syntax.Embed{ location, embedded = Path file AsCode } <|> do ~(location, uri) <- locatedURI return Syntax.Embed { location , embedded = Grace.Input.URI uri AsCode } <|> do parseToken Grace.Parser.OpenParenthesis e <- expression parseToken Grace.Parser.CloseParenthesis return e ) parseLetAssignment <- rule do let parseDefinition = do ~(nameLocation, name) <- locatedLabel bindings <- many parseBinding annotation <- optional do parseToken Grace.Parser.Colon t <- quantifiedType return t parseToken Grace.Parser.Equals assignment <- expression return \assignmentLocation -> Syntax.Define { assignmentLocation , definition = Syntax.Definition { nameLocation , name , bindings , annotation , assignment } } let parseBind = do -- We don't use `parseBinding` here because otherwise -- `parseDefinition` and `parseBind` will overlap for -- assignments of the form `let x = e …` and then the parser -- will double the number of branches it tracks for each such -- assignment, leading to an exponential blowup in the parser. -- Using `parseAdornedBinding` here ensures that every `let` -- assignment is parsed unambiguously as a `Definition` or -- `Bind`. binding <- parseAdornedBinding parseToken Grace.Parser.Equals assignment <- expression return \assignmentLocation -> Syntax.Bind { assignmentLocation , monad = IdentityMonad , binding , assignment } assignmentLocation <- locatedToken Grace.Parser.Let f <- parseDefinition <|> parseBind return (f assignmentLocation) parseAssignment <- rule do let parseListAssignment = do assignmentLocation <- locatedToken Grace.Parser.For binding <- parseBinding parseToken Grace.Parser.Of assignment <- expression return Syntax.Bind { assignmentLocation , monad = ListMonad , binding , assignment } let parseOptionalAssignment = do assignmentLocation <- locatedToken Grace.Parser.If parseToken Grace.Parser.Let binding <- parseBinding parseToken Grace.Parser.Equals assignment <- expression return Syntax.Bind { assignmentLocation , monad = OptionalMonad , binding , assignment } parseLetAssignment <|> parseListAssignment <|> parseOptionalAssignment recordLabel <- rule (reservedLabel <|> label <|> alternative <|> text) locatedRecordLabel <- rule ( locatedReservedLabel <|> locatedLabel <|> locatedAlternative <|> locatedText ) fieldValue <- rule do let setting = do ~(nameLocation, name) <- locatedRecordLabel bindings <- many parseBinding annotation <- optional do parseToken Grace.Parser.Colon t <- quantifiedType return t parseToken Grace.Parser.Colon assignment <- expression return Syntax.Definition { nameLocation , name , bindings , annotation , assignment } let pun = do ~(nameLocation, name) <- locatedRecordLabel return Syntax.Definition { nameLocation , name , bindings = [] , annotation = Nothing , assignment = Syntax.Variable { location = nameLocation , name } } setting <|> pun domain <- rule ( do parseToken Grace.Parser.Type return Domain.Type <|> do parseToken Grace.Parser.Fields return Domain.Fields <|> do parseToken Grace.Parser.Alternatives return Domain.Alternatives ) quantifiedType <- rule do fss <- many ( do location <- locatedToken Grace.Parser.Forall fs <- some do parseToken Grace.Parser.OpenParenthesis ~(typeVariableOffset, typeVariable) <- locatedLabel parseToken Grace.Parser.Colon domain_ <- domain parseToken Grace.Parser.CloseParenthesis return \location_ type_ -> Type.Forall { location = location_ , nameLocation = typeVariableOffset , name = typeVariable , domain = domain_ , type_ } parseToken Grace.Parser.Dot return (map ($ location) fs) ) t <- functionType return (foldr ($) t (concat fss)) functionType <- rule do let function input output = Type.Function{ location = Type.location input, input, output } ts <- applicationType `sepBy1` parseToken Grace.Parser.Arrow return (foldr function (NonEmpty.last ts) (NonEmpty.init ts)) applicationType <- rule ( do location <- locatedToken Grace.Parser.List type_ <- primitiveType return Type.List{ location, type_ } <|> do location <- locatedToken Grace.Parser.Optional type_ <- primitiveType return Type.Optional{ location, type_ } <|> do primitiveType ) primitiveType <- rule ( do location <- locatedToken Grace.Parser.Bool return Type.Scalar{ location, scalar = Monotype.Bool } <|> do location <- locatedToken Grace.Parser.Real return Type.Scalar{ location, scalar = Monotype.Real } <|> do location <- locatedToken Grace.Parser.Integer return Type.Scalar{ location, scalar = Monotype.Integer } <|> do location <- locatedToken Grace.Parser.JSON return Type.Scalar{ location, scalar = Monotype.JSON } <|> do location <- locatedToken Grace.Parser.Natural return Type.Scalar{ location, scalar = Monotype.Natural } <|> do location <- locatedToken Grace.Parser.Text return Type.Scalar{ location, scalar = Monotype.Text } <|> do location <- locatedToken Grace.Parser.Key return Type.Scalar{ location, scalar = Monotype.Key } <|> do ~(location, name) <- locatedLabel return Type.VariableType{ location, name } <|> do locatedOpenBrace <- locatedToken Grace.Parser.OpenBrace optional (parseToken Grace.Parser.Comma) fieldTypes <- fieldType `endBy` parseToken Grace.Parser.Comma toFields <- ( do text_ <- recordLabel pure (\fs -> Type.Fields fs (Monotype.VariableFields text_)) <|> do pure (\fs -> Type.Fields fs Monotype.EmptyFields) <|> do f <- fieldType pure (\fs -> Type.Fields (fs <> [ f ]) Monotype.EmptyFields) ) optional (parseToken Grace.Parser.Comma) parseToken Grace.Parser.CloseBrace return Type.Record { location = locatedOpenBrace , fields = toFields fieldTypes } <|> do locatedOpenAngle <- locatedToken Grace.Parser.OpenAngle optional (parseToken Grace.Parser.Bar) alternativeTypes <- alternativeType `endBy` parseToken Grace.Parser.Bar toAlternatives <- ( do text_ <- label return (\as -> Type.Alternatives as (Monotype.VariableAlternatives text_)) <|> do pure (\as -> Type.Alternatives as Monotype.EmptyAlternatives) <|> do a <- alternativeType return (\as -> Type.Alternatives (as <> [ a ]) Monotype.EmptyAlternatives) ) optional (parseToken Grace.Parser.Bar) parseToken Grace.Parser.CloseAngle return Type.Union { location = locatedOpenAngle , alternatives = toAlternatives alternativeTypes } <|> do parseToken Grace.Parser.OpenParenthesis t <- quantifiedType parseToken Grace.Parser.CloseParenthesis return t ) fieldType <- rule do field <- recordLabel parseToken Grace.Parser.Colon t <- quantifiedType return (field, t) alternativeType <- rule do a <- alternative parseToken Grace.Parser.Colon t <- quantifiedType return (a, t) -- Used for parsing a string interpolation expressionEndingWithBrace <- rule do a <- expression parseToken Grace.Parser.CloseBrace return a replCommand <- rule (fmap Evaluate expression <|> fmap Assign parseLetAssignment) return case form of Expression continuation -> fmap continuation expression Interpolation continuation -> fmap continuation expressionEndingWithBrace REPLCommand continuation -> fmap continuation replCommand -- | Parse a complete expression parse :: String -- ^ Name of the input (used for error messages) -> Text -- ^ Source code -> Either ParseError (Syntax Offset Input) parse = parseGrammaticalForm (Expression id) -- | Parse a grammatical form parseGrammaticalForm :: GrammaticalForm r -- ^ Grammatical form to parse -> String -- ^ Name of the input (used for error messages) -> Text -- ^ Source code -> Either ParseError r parseGrammaticalForm form name code = do tokens <- lex name code case Earley.fullParses (Earley.parser (grammar form)) tokens of ([], Report{ unconsumed }) -> do let offset = case unconsumed of [] -> Offset (Text.length code) locatedToken_ : _ -> Offset (stateOffset (state locatedToken_)) Left (ParsingFailed Location{ name, code, offset }) (result : _, _) -> do return result -- | Parse a @let@ assignment parseREPLCommand :: String -- ^ Name of the input (used for error messages) -> Text -- ^ Source code -> Either ParseError REPLCommand parseREPLCommand = parseGrammaticalForm (REPLCommand id) ================================================ FILE: src/Grace/Pretty.hs ================================================ {-# LANGUAGE FlexibleInstances #-} -- | Pretty-printing logic module Grace.Pretty ( -- * Prettyprinting renderStrict , renderIO , toText , toSmart , Pretty(..) -- * Highlighting , keyword , punctuation , label , scalar , builtin , operator ) where import Data.Scientific (Scientific) import Data.Text (Text) import Data.Void (Void) import Numeric.Natural (Natural) import Prettyprinter (Doc, LayoutOptions(..), PageWidth(..)) import Prettyprinter.Render.Terminal (AnsiStyle) import System.IO (Handle) import qualified Grace.Width as Width import qualified Prettyprinter as Pretty import qualified Prettyprinter.Render.Terminal as Pretty.Terminal import qualified Prettyprinter.Render.Text as Pretty.Text import qualified Text.URI as URI {-| Convenient wrapper around "Prettyprinter.Render.Terminal".`Pretty.Terminal.renderStrict` / "Prettyprinter.Render.Text".`Pretty.Text.renderStrict` -} renderStrict :: Pretty a => Bool -- ^ `True` enable syntax highlighting -> Int -- ^ Available columns -> a -> Text renderStrict highlight columns = render . Pretty.layoutSmart (layoutOptions columns) . pretty where render = if highlight then Pretty.Terminal.renderStrict else Pretty.Text.renderStrict {-| Convenient wrapper around "Prettyprinter.Render.Terminal".`Pretty.Terminal.renderIO` / "Prettyprinter.Render.Text".`Pretty.Text.renderIO` -} renderIO :: Pretty a => Bool -- ^ `True` enables syntax highlighting -> Int -- ^ Available columns -> Handle -> a -> IO () renderIO highlight columns handle = render handle . Pretty.layoutSmart (layoutOptions columns) . pretty where render = if highlight then Pretty.Terminal.renderIO else Pretty.Text.renderIO -- | Simple conversion of a document to `Text` toText :: Pretty a => a -> Text toText = Pretty.Text.renderStrict . Pretty.layoutCompact . pretty {-| This is like @"Prettyprinter".`Prettyprinter.Pretty`@, except that this can return a `Doc` with `AnsiStyle` annotations -} class Pretty a where pretty :: a -> Doc AnsiStyle instance Pretty Double where pretty = Pretty.pretty instance Pretty Scientific where pretty = Pretty.pretty . show instance Pretty Int where pretty = Pretty.pretty instance Pretty Integer where pretty = Pretty.pretty instance Pretty Natural where pretty = Pretty.pretty instance Pretty Text where pretty = Pretty.pretty instance Pretty () where pretty = Pretty.pretty instance Pretty Void where pretty = Pretty.pretty instance Pretty String where pretty = Pretty.pretty instance Pretty URI.URI where pretty = Pretty.pretty . URI.render instance Pretty (Doc AnsiStyle) where pretty = id layoutOptions :: Int -- ^ Available columns -> LayoutOptions layoutOptions columns = LayoutOptions { layoutPageWidth = AvailablePerLine columns 1 } -- | Highlight a keyword (e.g. @let@ or @fold@) keyword :: Doc AnsiStyle -> Doc AnsiStyle keyword = Pretty.annotate ( Pretty.Terminal.bold <> Pretty.Terminal.colorDull Pretty.Terminal.Green ) -- | Highlight punctuation (e.g. @{@ or @,@) punctuation :: Doc AnsiStyle -> Doc AnsiStyle punctuation = Pretty.annotate ( Pretty.Terminal.bold <> Pretty.Terminal.colorDull Pretty.Terminal.Green ) -- | Highlight a label (e.g. @x@) label :: Doc AnsiStyle -> Doc AnsiStyle label = Pretty.annotate mempty -- | Highlight a scalar (e.g. @1@ or @\"abc\"@) scalar :: Doc AnsiStyle -> Doc AnsiStyle scalar = Pretty.annotate (Pretty.Terminal.colorDull Pretty.Terminal.Magenta) -- | Highlight a built-in (e.g. @length@) builtin :: Doc AnsiStyle -> Doc AnsiStyle builtin = Pretty.annotate Pretty.Terminal.underlined -- | Highlight an operator (e.g. @+@ or @&&@) operator :: Doc AnsiStyle -> Doc AnsiStyle operator = Pretty.annotate ( Pretty.Terminal.bold <> Pretty.Terminal.colorDull Pretty.Terminal.Green ) -- | Render as `Text` using the smart layout algorithm toSmart :: Pretty a => a -> Text toSmart = Grace.Pretty.renderStrict False Width.defaultWidth ================================================ FILE: src/Grace/Prompt/Types.hs ================================================ -- | Types associated with prompting LLMs module Grace.Prompt.Types ( -- * Types Prompt(..) , Message(..) , Effort(..) ) where import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import GHC.Generics (Generic) import Grace.Decode (FromGrace, Key(..), ToGraceType) import Grace.Encode (ToGrace) -- | Arguments to the @prompt@ keyword data Prompt = Prompt { key :: Grace.Decode.Key , text :: Maybe Text , history :: Maybe [Message] , model :: Maybe Text , search :: Maybe Bool , effort :: Maybe Effort } deriving stock (Generic) deriving anyclass (FromGrace, FromJSON, ToGrace, ToGraceType, ToJSON) -- | A message added to the conversation history data Message = System{ name :: Maybe Text, text :: Text } | User{ name :: Maybe Text, text :: Text } | Assistant{ name :: Maybe Text, text :: Text } deriving stock (Generic) deriving anyclass (FromGrace, FromJSON, ToGrace, ToGraceType, ToJSON) -- | The amount of effort a reasoning model puts into reasoning data Effort = Minimal | Low | Medium | High deriving stock (Generic) deriving anyclass (FromGrace, FromJSON, ToGrace, ToGraceType, ToJSON) ================================================ FILE: src/Grace/Prompt.hs ================================================ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module implements the @prompt@ keyword module Grace.Prompt ( -- * Prompting Prompt(..) , Effort(..) , prompt -- * Exceptions , UnsupportedModelOutput(..) ) where import Control.Exception.Safe (Exception(..), SomeException(..)) import Control.Monad.IO.Class (MonadIO(..)) import Data.Foldable (fold, toList) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Vector (Vector) import Grace.Decode (FromGrace(..), Key(..), ToGraceType(..)) import Grace.Input (Input(..)) import Grace.Location (Location(..)) import Grace.Monad (Grace) import Grace.Pretty (Pretty(..)) import Grace.Prompt.Types (Effort(..), Prompt(..)) import Grace.Type (Type(..)) import Grace.Value (Value) import OpenAI.V1.Models (Model(..)) import OpenAI.V1.ResponseFormat (JSONSchema(..), ResponseFormat(..)) import System.FilePath (()) import OpenAI.V1.Chat.Completions ( ChatCompletionObject(..) , Choice(..) , CreateChatCompletion(..) , Message(..) , ReasoningEffort(..) , WebSearchOptions(..) , _CreateChatCompletion ) import {-# SOURCE #-} qualified Grace.Interpret as Interpret import qualified Control.Exception.Safe as Exception import qualified Control.Monad.Reader as Reader import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as ByteString.Lazy import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified Data.Vector as Vector import qualified Grace.DataFile as DataFile import qualified Grace.HTTP as HTTP import qualified Grace.Import as Import import qualified Grace.Infer as Infer import qualified Grace.Monotype as Monotype import qualified Grace.Pretty as Pretty import qualified Grace.Prompt.Types as Prompt.Types import qualified Grace.Type as Type import qualified Grace.Value as Value import qualified OpenAI.V1.Chat.Completions as Completions import qualified Prettyprinter as Pretty import qualified System.IO.Unsafe as Unsafe deriving anyclass instance FromGrace ReasoningEffort deriving anyclass instance ToGraceType ReasoningEffort -- | Context used to teach the LLM to code in Grace staticAssets :: [ Message (Vector Completions.Content) ] staticAssets = Unsafe.unsafePerformIO do let instructions₀ = [ System { name = Just "Instructions" , content = [ Completions.Text { text = "Here are some resources which explain how to program using the Fall-from-Grace programming language (\"Grace\" for short)" } ] } ] prompts <- do let files = [ "abnf.md" , "inference.md" ] let process :: FilePath -> IO (Message (Vector Completions.Content)) process file = do text <- DataFile.readDataFile ("prompts" file) return System { name = Just (Text.pack file) , content = [ Completions.Text{ text } ] } traverse process files let instructions₁ = [ System { name = Just "Instructions" , content = [ Completions.Text { text = "Here are some sample Grace programs showcasing various idioms and language features" } ] } ] examples <- do let files = [ "learn-in-y-minutes.ffg" , "chaining.ffg" , "prompt.ffg" , "tools.ffg" ] let process :: FilePath -> IO (Message (Vector Completions.Content)) process file = do text <- DataFile.readDataFile ("examples" file) return System { name = Just (Text.pack file) , content = [ Completions.Text{ text } ] } traverse process files return (instructions₀ <> prompts <> instructions₁ <> examples) {-# NOINLINE staticAssets #-} toJSONSchema :: Type a -> Either (UnsupportedModelOutput a) Aeson.Value toJSONSchema original = loop original where loop Type.Forall{ location, name, type_ } = do loop (Type.substituteType name 0 Type.Scalar{ location, scalar = Monotype.Text } type_) loop Type.Optional{ type_ } = do present <- loop type_ let absent = Aeson.object [ ("type", "null") ] return ( Aeson.object [ ("anyOf", Aeson.toJSON ([ present, absent ] :: [ Aeson.Value ])) ] ) loop Type.List{ type_ } = do items <- loop type_ return (Aeson.object [ ("type", "array"), ("items", items) ]) loop Type.Record{ fields = Type.Fields fieldTypes _ } = do let toProperty (field, type_) = do property <- loop type_ return (field, property) properties <- traverse toProperty fieldTypes let required = fmap fst fieldTypes return ( Aeson.object [ ("type", "object") , ("properties", Aeson.toJSON (Map.fromList properties)) , ("additionalProperties", Aeson.toJSON False) , ("required", Aeson.toJSON required) ] ) loop Type.Union{ alternatives = Type.Alternatives alternativeTypes _ } = do let toAnyOf (alternative, type_) = do contents <- loop type_ return (Aeson.object [ ("type", "object") , ( "properties" , Aeson.object [ ( "tag" , Aeson.object [ ("type", "string") , ("const", Aeson.toJSON alternative) ] ) , ("contents", contents) ] ) , ("required", Aeson.toJSON ([ "tag", "contents" ] :: [Text])) , ("additionalProperties", Aeson.toJSON False) ] ) anyOfs <- traverse toAnyOf alternativeTypes return ( Aeson.object [ ("type", "object"), ("anyOf", Aeson.toJSON anyOfs) ] ) loop Type.Scalar{ scalar = Monotype.Bool } = return (Aeson.object [ ("type", "boolean") ]) loop Type.Scalar{ scalar = Monotype.Real } = return (Aeson.object [ ("type", "number") ]) loop Type.Scalar{ scalar = Monotype.Integer } = return (Aeson.object [ ("type", "integer") ]) loop Type.Scalar{ scalar = Monotype.JSON } = return (Aeson.object [ ]) loop Type.Scalar{ scalar = Monotype.Natural } = return (Aeson.object [ ("type", "number") -- , ("minimum", Aeson.toJSON (0 :: Int)) -- ^ Not supported by OpenAI ] ) loop Type.Scalar{ scalar = Monotype.Text } = return (Aeson.object [ ("type", "string") ]) loop _ = Left UnsupportedModelOutput{ original } toResponseFormat :: Maybe (Type a) -> Either (UnsupportedModelOutput a) ResponseFormat toResponseFormat Nothing = do return JSON_Object toResponseFormat (Just type_) = do value <- toJSONSchema type_ return JSON_Schema { json_schema = JSONSchema { description = Nothing , name = "result" , schema = Just value , strict = Just True } } -- | Implementation of the @prompt@ keyword prompt :: IO [(Text, Type Location, Value Location)] -> Bool -> Location -> Prompt -> Maybe (Type Location) -> Grace (Value Location) prompt generateContext import_ location Prompt{ key = Grace.Decode.Key{ text = key }, text, history, model, search, effort } schema = do keyToMethods <- liftIO HTTP.getMethods let methods = keyToMethods (Text.strip key) let defaultedSearch = case search of Just s -> s Nothing -> False let web_search_options | defaultedSearch = Just WebSearchOptions { search_context_size = Nothing , user_location = Nothing } | otherwise = Nothing let defaultedModel = case model of Just m -> m _ | defaultedSearch -> "gpt-5-search-api" | otherwise -> "gpt-5-mini" let reasoning_effort = do e <- effort return case e of Minimal -> ReasoningEffort_Minimal Low -> ReasoningEffort_Low Medium -> ReasoningEffort_Medium High -> ReasoningEffort_High let toOutput ChatCompletionObject{ choices = [ Choice{ message = Assistant{ assistant_content = Just output } } ] } = do return output toOutput ChatCompletionObject{ choices } = do Exception.throwIO UnexpectedModelResponse{ choices } let lastMessage = case text of Nothing -> [ ] Just t -> [ User { name = Nothing , content = [ Completions.Text{ text = t } ] } ] let initMessages = do message <- fold history return case message of Prompt.Types.System{ name, text = t } -> System { name , content = [ Completions.Text{ text = t } ] } Prompt.Types.Assistant{ name, text = t } -> Assistant { name , assistant_content = Just [ Completions.Text{ text = t } ] , refusal = Nothing , assistant_audio = Nothing , tool_calls = Nothing } Prompt.Types.User{ name, text = t } -> User { name , content = [ Completions.Text{ text = t } ] } let conversation = initMessages <> lastMessage if import_ then do let retry errors | (_, interpretError) : rest <- errors , length rest == 3 = do Exception.throwIO interpretError | otherwise = do let instructions₀ = case conversation of [ ] -> [ System { name = Just "Instructions" , content = [ Completions.Text { text = "Generate a Grace expression." } ] } ] [ _ ] -> [ System { name = Just "Instructions" , content = [ Completions.Text { text = "Generate a Grace expression according to the previous message." } ] } ] _ -> [ System { name = Just "Instructions" , content = [ Completions.Text { text = "Generate a Grace expression according to the previous conversation." } ] } ] let expect = case schema of Nothing -> [ ] Just s -> [ System { name = Just "Instructions" , content = [ Completions.Text { text = "Your generated Grace expression must have the following type" } ] } , System { name = Just "Type" , content = [ Completions.Text { text = Pretty.toSmart s } ] } ] bindings <- liftIO generateContext let renderAssignment (name, type_, _) = Pretty.toSmart (Pretty.group (Pretty.flatAlt long short)) <> "\n\n" where long = Pretty.label (pretty name) <> " " <> Pretty.punctuation ":" <> Pretty.hardline <> " " <> Pretty.nest 2 (pretty type_) short = Pretty.label (pretty name) <> " " <> Pretty.punctuation ":" <> " " <> pretty type_ let environment = do binding <- bindings return System { name = Just "Value" , content = [ Completions.Text { text = renderAssignment binding } ] } let instructions₁ = case environment of [ ] -> [ ] _ -> [ System { name = Just "Instructions" , content = [ Completions.Text { text = "You may use any of the following values to generate your Grace expression, all of which are in scope." } ] } ] let instructions₂ = [ System { name = Just "Instructions" , content = [ Completions.Text { 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." } ] } ] let failedAttempts = do (program, interpretError) <- reverse errors let attempt = Assistant { name = Just "Attempt" , assistant_content = Just [ Completions.Text{ text = program } ] , refusal = Nothing , assistant_audio = Nothing , tool_calls = Nothing } let failure = System { name = Just "Error" , content = [ Completions.Text { text = Text.pack (displayException interpretError) } ] } [ attempt, failure ] let messages = Vector.fromList ( staticAssets <> conversation <> instructions₀ <> expect <> instructions₁ <> environment <> instructions₂ <> failedAttempts ) chatCompletionObject <- liftIO do HTTP.createChatCompletion methods _CreateChatCompletion { messages , model = Model defaultedModel , web_search_options , reasoning_effort } output <- toOutput chatCompletionObject parent <- Reader.ask Reader.local (\i -> i <> Code "(prompt)" output) do child <- Reader.ask Import.referentiallySane parent child Interpret.interpretWith bindings schema `Exception.catch` \(interpretError :: SomeException) -> do retry ((output, interpretError) : errors) (_, e) <- retry [] return e else do let instructions₀ = case conversation of [ ] -> [ System { name = Just "Instructions" , content = [ Completions.Text { text = "Generate JSON." } ] } ] [ _ ] -> [ System { name = Just "Instructions" , content = [ Completions.Text { text = "Generate JSON according to the previous message." } ] } ] _ -> [ System { name = Just "Instructions" , content = [ Completions.Text { text = "Generate JSON according to the previous conversation." } ] } ] let defaultedSchema = do s <- schema return (Type.defaultTo Type.Scalar{ scalar = Monotype.Text, location } s) let decode_ text_ = do let bytes = Encoding.encodeUtf8 text_ let lazyBytes = ByteString.Lazy.fromStrict bytes case Aeson.eitherDecode lazyBytes of Left message_ -> Exception.throwIO ModelDecodingFailed{ message = message_, text = text_ } Right v -> return v let expect = case schema of Nothing -> [ ] Just s -> [ System { name = Just "Instructions" , content = [ Completions.Text { text = "Your generated JSON must have the following type" } ] } , System { name = Just "Type" , content = [ Completions.Text { text = Pretty.toSmart s } ] } ] let instructions₁ = instructions₀ <> expect let extractText = do let extract text_ = do return (Value.Text Unknown text_) return ( [ ] , ResponseFormat_Text , extract ) let extractRecord = do responseFormat <- case toResponseFormat defaultedSchema of Left exception -> Exception.throwIO exception Right result -> return result let extract text_ = do v <- decode_ text_ value <- case defaultedSchema of Nothing -> do return (Infer.inferJSON v) Just s -> do Infer.checkJSON s v return (fmap (\_ -> Unknown) value) return ( instructions₁ , responseFormat , extract ) let extractNonRecord = do let adjustedSchema = do s <- defaultedSchema return (Type.Record (Type.location s) (Type.Fields [("response", s)] Monotype.EmptyFields)) responseFormat <- case toResponseFormat adjustedSchema of Left exception -> Exception.throwIO exception Right result -> return result let extract text_ = do v <- decode_ text_ expression <- case adjustedSchema of Nothing -> do return (Infer.inferJSON v) Just s -> do Infer.checkJSON s v case fmap (\_ -> Unknown) expression of Value.Record _ [("response", (_, response))] -> do return response other -> do return other return ( instructions₁ , responseFormat , extract ) (instructions₂, response_format, extract) <- case defaultedSchema of Just Type.Scalar{ scalar = Monotype.Text } -> extractText Just Type.Record{ } -> extractRecord _ -> extractNonRecord let messages₀ = Vector.fromList (conversation <> instructions₂) let messages₁ = case messages₀ of [ ] -> [ User { name = Nothing , content = [ Completions.Text{ text = "" } ] } ] _ -> messages₀ chatCompletionObject <- liftIO do HTTP.createChatCompletion methods _CreateChatCompletion { messages = messages₁ , model = Model defaultedModel , response_format = Just response_format , reasoning_effort } output <- toOutput chatCompletionObject extract output -- | The expected type for the model output can't be encoded as JSON newtype UnsupportedModelOutput a = UnsupportedModelOutput{ original :: Type a } deriving stock (Show) instance (Show a, Typeable a) => Exception (UnsupportedModelOutput a) where displayException UnsupportedModelOutput{ original } = "Unsupported model output type\n\ \\n\ \The expected type for the model output is:\n\ \\n\ \" <> Text.unpack (Pretty.toSmart original) <> "\n\ \\n\ \… but that type cannot be encoded as JSON" -- | The model didn't return an expected, successful response data UnexpectedModelResponse = UnexpectedModelResponse{ choices :: Vector Choice } deriving stock (Show) instance Exception UnexpectedModelResponse where displayException UnexpectedModelResponse{ choices } = case toList choices of [] -> "Unexpected model response\n\ \\n\ \The model did not return any choices" _ : _ : _ -> "Unexpected model response\n\ \\n\ \The model returned multiple choices when only one was expected" [ Choice{ message = Assistant{ refusal = Just refusal } } ] -> "Unexpected model response\n\ \\n\ \The model refused to answer for the following reason:\n\ \\n\ \" <> Text.unpack refusal [ Choice{ message = Assistant{ assistant_content = Nothing } } ] -> "Unexpected model response\n\ \\n\ \The model returned an empty answer" [ Choice{ message } ] -> "Unexpected model response\n\ \\n\ \The model responded with a non-assistant message\n\ \\n\ \Message:\n\ \\n\ \" <> string where bytes = ByteString.Lazy.toStrict (Aeson.encode message) string = case Encoding.decodeUtf8' bytes of Left _ -> show bytes Right text -> Text.unpack text -- | Model decoding failed data ModelDecodingFailed = ModelDecodingFailed { message :: String , text :: Text } deriving stock (Show) instance Exception ModelDecodingFailed where displayException ModelDecodingFailed{ message, text } = "Failed to decode output as JSON\n\ \\n\ \The model produced the following output:\n\ \\n\ \" <> Text.unpack text <> "\n\ \\n\ \… which failed to decode as JSON.\n\ \\n\ \Decoding error message:\n\ \\n\ \" <> message ================================================ FILE: src/Grace/REPL.hs ================================================ {-# LANGUAGE FlexibleContexts #-} -- | This module contains the implementation of the @grace repl@ subcommand module Grace.REPL ( -- * REPL repl ) where import Control.Applicative (empty) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.State (MonadState(..)) import Data.Bifunctor (first) import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty(..)) import Grace.Interpret (Input(..)) import Grace.Location (Location(..)) import Grace.Monad (Status(..)) import Grace.Parser (REPLCommand(..)) import System.Console.Haskeline (Interrupt(..)) import System.Console.Repline (CompleterStyle(..), MultiLine(..), ReplOpts(..)) import Control.Exception.Safe (Exception, SomeException, displayException, throwIO) import qualified Control.Exception.Safe as Exception import qualified Control.Monad as Monad import qualified Control.Monad.State as State import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Grace.Context as Context import qualified Grace.Infer as Infer import qualified Grace.Label as Label import qualified Grace.Monad as Grace import qualified Grace.Normalize as Normalize import qualified Grace.Parser as Parser import qualified Grace.Pretty as Pretty import qualified Grace.Syntax as Syntax import qualified Grace.Type as Type import qualified Grace.Value as Value import qualified Grace.Width as Width import qualified System.Console.Haskeline.Completion as Completion import qualified System.Console.Repline as Repline import qualified System.IO as IO -- | Entrypoint for the @grace repl@ subcommand repl :: IO () repl = do let err :: (Exception e, MonadIO io) => e -> io () err e = liftIO (Text.IO.hPutStrLn IO.stderr (Text.pack (displayException e))) let command infer string = do let text = Text.pack string let locate offset = Location { name = "(input)" , code = text , offset } let interpret syntax₀ = do assignments₀ <- State.get let syntax₁ = case reverse assignments₀ of [] -> first locate syntax₀ assignment₁ : assignments₁ -> Syntax.Let { location = Unknown , assignments = assignment₁ :| assignments₁ , body = first locate syntax₀ } let input = Code "(input)" text let status = Status { count = 0 , context = [] } let action = do (inferred, elaborated) <- Infer.infer syntax₁ value <- Normalize.evaluate [] elaborated return (inferred, value) result <- liftIO (Exception.try (Grace.runGrace input status action)) case result of Left (e :: SomeException) -> do return (Left e) Right ((inferred, value), Status{ context }) -> do let annotation = Context.complete context inferred let annotated = Value.quote (Value.complete context value) return (Right (annotation, annotated)) case Parser.parseREPLCommand "(input)" text of Left parseError -> do err parseError Right (Evaluate syntax₀) -> do result <- interpret syntax₀ case result of Left (e :: SomeException) -> do err e Right (annotation, annotated) -> do width <- liftIO Width.getWidth let document = if infer then Pretty.pretty annotation else Pretty.pretty annotated liftIO (Pretty.renderIO True width IO.stdout (document <> "\n")) Right (Assign assignment) -> do assignments <- State.get State.put (first locate assignment : assignments) result <- interpret Syntax.Record{ location = 0, fieldValues = [] } case result of Left e -> do State.put assignments err e Right _ -> do return () let help _string = do liftIO (putStrLn "Type any expression to normalize it or use one of the following commands:\n\ \:help\n\ \ Print help text and describe options\n\ \:paste\n\ \ Start a multi-line input. Submit with \n\ \let IDENTIFIER = EXPRESSION\n\ \ Assign an expression to a variable\n\ \:quit\n\ \ Exit the REPL") let quit _ = liftIO (throwIO Interrupt) let options = [ ("help", Repline.dontCrash . help) -- `paste` is included here for auto-completion purposes only. -- `repline`'s `multilineCommand` logic overrides this no-op. , ("paste", Repline.dontCrash . \_ -> return ()) , ("quit", quit) , ("type", Repline.dontCrash . command True) ] let tabComplete = Prefix complete [ (":", completeCommands) ] where completeCommands = Repline.listCompleter (fmap adapt options) where adapt (c, _) = ":" <> c complete = foldr Repline.fallbackCompletion Completion.noCompletion [ completeReserved , completeIdentifiers , completeFields , completeFile ] completeFile = Repline.runMatcher [ ("/" , Repline.fileCompleter) , ("./" , Repline.fileCompleter) , ("../", Repline.fileCompleter) , ("~/" , Repline.fileCompleter) ] Completion.noCompletion completeReserved = Repline.listCompleter (fmap Text.unpack (toList Label.reservedLabels)) completeIdentifiers args = do assignments <- get let completions = do Syntax.Define{ definition = Syntax.Definition{ name } } <- assignments return name Repline.listCompleter (fmap Text.unpack completions) args completeFields = Repline.wordCompleter \prefix -> do let toNonEmpty (x : xs) = x :| xs toNonEmpty [] = "" :| [] let loop (c0 :| c1 : cs) context = do let newContext = do (name, annotation) <- context Monad.guard (c0 == name) case annotation of Just Type.Record{ fields = Type.Fields keyTypes _ } -> do (key, type_) <- keyTypes return (key, Just type_) _ -> do empty results <- loop (c1 :| cs) newContext let prepend result = c0 <> "." <> result return (fmap prepend results) loop (c0 :| []) context = return do (name, _) <- context Monad.guard (Text.isPrefixOf c0 name) return name let startingComponents = toNonEmpty (Text.splitOn "." (Text.pack prefix)) assignments <- get let startingContext = do Syntax.Define{ definition = Syntax.Definition{ name, annotation } } <- assignments return (name, annotation) results <- loop startingComponents startingContext return (fmap Text.unpack results) let banner MultiLine = return "... " banner SingleLine = return ">>> " let initialiser = liftIO (putStrLn "Type :help for more information.") let action = Repline.evalReplOpts ReplOpts { banner , command = command False , options , prefix = Just ':' , multilineCommand = Just "paste" , tabComplete , initialiser , finaliser = return Repline.Exit } State.evalStateT action [] ================================================ FILE: src/Grace/Syntax.hs ================================================ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLists #-} {-| This module contains the syntax tree used for the surface syntax (i.e. the result of parsing), representing the code as the user wrote it. -} module Grace.Syntax ( -- * Syntax Syntax(..) , usedIn , freeVariables , effects , types , complete , Chunks(..) , Field(..) , Smaller(..) , Scalar(..) , Operator(..) , Builtin(..) , NameBinding(..) , Binding(..) , Definition(..) , BindMonad(..) , Assignment(..) ) where import Control.Lens (Getting, Plated(..), Traversal') import Data.Aeson (ToJSON(..)) import Data.Bifunctor (Bifunctor(..)) import Data.Generics.Sum (_As) import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (Any) import Data.Scientific (Scientific) import Data.Sequence (Seq((:<|))) import Data.Set (Set) import Data.String (IsString(..)) import Data.Text (Text) import GHC.Generics (Generic) import Grace.Compat () -- For an orphan instance for Lift (Seq a) import Grace.Context (Context) import Grace.Pretty (Pretty(..), keyword, punctuation) import Grace.Type (Type) import Language.Haskell.TH.Syntax (Lift) import Numeric.Natural (Natural) import Prettyprinter.Render.Terminal (AnsiStyle) import Prettyprinter.Internal ( Doc ( Annotated , Cat , Column , Fail , FlatAlt , Line , Nest , Nesting , Union , WithPageWidth ) ) import qualified Control.Lens as Lens import qualified Control.Monad as Monad import qualified Data.Aeson as Aeson import qualified Data.Set as Set import qualified Data.Text as Text import qualified Grace.Context as Context import qualified Grace.Pretty as Pretty import qualified Grace.Type as Type import qualified Prettyprinter as Pretty {- $setup >>> :set -XOverloadedStrings >>> :set -XOverloadedLists >>> :set -XTypeApplications >>> import Data.Void (Void) -} -- | The surface syntax for the language data Syntax s a = Variable { location :: s, name :: Text } -- ^ -- >>> pretty @(Syntax () Void) (Variable () "x") -- x | Lambda { location :: s, binding :: Binding s a, body :: Syntax s a } -- ^ -- >>> pretty @(Syntax () Void) (Lambda () "x" "x") -- \x -> x -- >>> pretty @(Syntax () Void) (Lambda () (PlainBinding (NameBinding () "x" (Just "A") Nothing)) "x") -- \(x : A) -> x -- >>> pretty @(Syntax () Void) (Lambda () (PlainBinding (NameBinding () "x" Nothing (Just "a"))) "x") -- \(x = a) -> x -- >>> pretty @(Syntax () Void) (Lambda () (PlainBinding (NameBinding () "x" (Just "A") (Just "a"))) "x") -- \(x : A = a) -> x | Application { location :: s, function :: Syntax s a, argument :: Syntax s a } -- ^ -- >>> pretty @(Syntax () Void) (Application () "f" "x") -- f x | Annotation { location :: s, annotated :: Syntax s a, annotation :: Type s } -- ^ -- >>> pretty @(Syntax () Void) (Annotation () "x" "A") -- x : A | Let { location :: s, assignments :: NonEmpty (Assignment s a), body :: Syntax s a } -- ^ -- >>> pretty @(Syntax () Void) (Let () (Define () (Definition () "x" [] Nothing "y") :| []) "z") -- let x = y in z -- >>> pretty @(Syntax () Void) (Let () (Define () (Definition () "x" [PlainBinding (NameBinding () "a" (Just "A") Nothing), PlainBinding (NameBinding () "b" Nothing (Just "e"))] (Just "X") "y") :| []) "z") -- let x (a : A) (b = e) : X = y in z -- >>> pretty @(Syntax () Void) (Let () (Define () (Definition () "a" [] Nothing "b") :| [ Define () (Definition () "c" [] Nothing "d") ]) "e") -- let a = b let c = d in e | List { location :: s, elements :: Seq (Syntax s a) } -- ^ -- >>> pretty @(Syntax () Void) (List () [ "x", "y", "z" ]) -- [ x, y, z ] | Record { location :: s, fieldValues :: [Definition s a] } -- ^ -- >>> pretty @(Syntax () Void) (Record () [ Definition () "x" [] Nothing "a", Definition () "y" [] Nothing "b" ]) -- { "x": a, "y": b } | Project { location :: s, larger :: Syntax s a, smaller :: Smaller s } -- ^ -- >>> pretty @(Syntax () Void) (Project () "x" "a") -- x.a | Alternative { location :: s, name :: Text, argument :: Syntax s a } -- ^ -- >>> pretty @(Syntax () Void) (Alternative () "Foo" "a") -- Foo a | Fold { location :: s, handlers :: Syntax s a } -- ^ -- >>> pretty @(Syntax () Void) (Fold () "x") -- fold x | If { location :: s, predicate :: Syntax s a, ifTrue :: Syntax s a, ifFalse :: Syntax s a } -- ^ -- >>> pretty @(Syntax () Void) (If () "x" "y" "z") -- if x then y else z | Text { location :: s, chunks :: Chunks s a } -- ^ -- >>> pretty @(Syntax () Void) (Text () "a") -- "a" -- >>> pretty @(Syntax () Void) (Text () (Chunks "a" [("x", "b")])) -- "a${x}b" | Prompt{ location :: s, import_ :: Bool, arguments :: Syntax s a, schema :: Maybe (Type s) } | HTTP{ location :: s, import_ :: Bool, arguments :: Syntax s a, schema :: Maybe (Type s) } | Read{ location :: s, import_ :: Bool, arguments :: Syntax s a, schema :: Maybe (Type s) } | GitHub{ location :: s, import_ :: Bool, arguments :: Syntax s a, schema :: Maybe (Type s) } | Show{ location :: s, export :: Bool, arguments :: Syntax s a, schema :: Maybe (Type s) } | Scalar { location :: s, scalar :: Scalar } | Operator { location :: s, left :: Syntax s a, operatorLocation :: s, operator :: Operator, right :: Syntax s a } -- ^ -- >>> pretty @(Syntax () Void) (Operator () "x" () And "y") -- x && y -- >>> pretty @(Syntax () Void) (Operator () "x" () Plus "y") -- x + y | Builtin { location :: s, builtin :: Builtin } | Embed { location :: s, embedded :: a } deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable) instance Applicative (Syntax ()) where pure embedded = Embed{ location = (), embedded } (<*>) = Monad.ap instance Monad (Syntax ()) where Variable{ location, name } >>= _ = Variable{ location, name } Lambda{ location, binding, body } >>= f = Lambda { location , binding = onBinding binding , body = body >>= f } where onBinding PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment} } = PlainBinding { plain = NameBinding { nameLocation , name , annotation , assignment = fmap (>>= f) assignment } } onBinding RecordBinding{ fieldNamesLocation, fieldNames } = RecordBinding { fieldNamesLocation , fieldNames = fmap onFieldName fieldNames } onFieldName NameBinding{ nameLocation, name, annotation, assignment } = NameBinding { nameLocation , name , annotation , assignment = fmap (>>= f) assignment } Application{ location, function, argument } >>= f = Application { location , function = function >>= f , argument = argument >>= f } Annotation{ location, annotated, annotation } >>= f = Annotation{ location, annotated = annotated >>= f, annotation } Let{ location, assignments, body } >>= f = Let { location , assignments = fmap onAssignment assignments , body = body >>= f } where onAssignment Define{ assignmentLocation, definition = Definition{ nameLocation, name, bindings, annotation, assignment } } = Define { assignmentLocation , definition = Definition { name , nameLocation , bindings = fmap onBinding bindings , annotation , assignment = assignment >>= f } } onAssignment Bind{ assignmentLocation, monad, binding, assignment } = Bind { assignmentLocation , monad , binding = onBinding binding , assignment = assignment >>= f } onBinding PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } } = PlainBinding { plain = NameBinding { nameLocation , name , annotation , assignment = fmap (>>= f) assignment } } onBinding RecordBinding{ fieldNamesLocation, fieldNames } = RecordBinding { fieldNamesLocation , fieldNames = fmap onFieldName fieldNames } onFieldName NameBinding{ nameLocation, name, annotation, assignment } = NameBinding { nameLocation , name , annotation , assignment = fmap (>>= f) assignment } List{ location, elements } >>= f = List{ location, elements = fmap (>>= f) elements } Record{ location, fieldValues } >>= f = Record{ location, fieldValues = fmap onDefinition fieldValues } where onDefinition Definition{ nameLocation, name, bindings, annotation, assignment } = Definition { nameLocation , name , bindings = fmap onBinding bindings , annotation , assignment = assignment >>= f } onBinding PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } } = PlainBinding { plain = NameBinding { nameLocation , name , annotation , assignment = fmap (>>= f) assignment } } onBinding RecordBinding{ fieldNamesLocation, fieldNames } = RecordBinding { fieldNamesLocation , fieldNames = fmap onFieldName fieldNames } onFieldName NameBinding{ nameLocation, name, annotation, assignment } = NameBinding { nameLocation , name , annotation , assignment = fmap (>>= f) assignment } Project{ location, larger, smaller } >>= f = Project{ location, larger = larger >>= f, smaller } Alternative{ location, name, argument } >>= f = Alternative{ location, name, argument = argument >>= f } Fold{ location, handlers } >>= f = Fold{ location, handlers = handlers >>= f } If{ location, predicate, ifTrue, ifFalse } >>= f = If { location , predicate = predicate >>= f , ifTrue = ifTrue >>= f , ifFalse = ifFalse >>= f } Text{ location, chunks = Chunks text₀ rest } >>= f = Text{ location, chunks = Chunks text₀ (fmap onChunk rest) } where onChunk (interpolation, text) = (interpolation >>= f, text) Prompt{ location, import_, arguments, schema } >>= f = Prompt{ location, import_, arguments = arguments >>= f, schema } HTTP{ location, import_, arguments, schema } >>= f = HTTP{ location, import_, arguments = arguments >>= f, schema } Read{ location, import_, arguments, schema } >>= f = Read{ location, import_, arguments = arguments >>= f, schema } GitHub{ location, import_, arguments, schema } >>= f = GitHub{ location, import_, arguments = arguments >>= f, schema } Show{ location, export, arguments, schema } >>= f = Show{ location, export, arguments = arguments >>= f, schema } Scalar{ location, scalar } >>= _ = Scalar{ location, scalar } Operator{ location, left, operatorLocation, operator, right } >>= f = Operator { location , left = left >>= f , operatorLocation , operator , right = right >>= f } Builtin{ location, builtin } >>= _ = Builtin{ location, builtin } Embed{ embedded } >>= f = f embedded instance Plated (Syntax s a) where plate onSyntax syntax = case syntax of Variable{ location, name } -> do pure Variable{ location, name } Lambda{ location, binding, body } -> do newBody <- onSyntax body return Lambda{ location, binding, body = newBody } Application{ location, function, argument } -> do newFunction <- onSyntax function newArgument <- onSyntax argument return Application { location , function = newFunction , argument = newArgument } Annotation{ location, annotated, annotation } -> do newAnnotated <- onSyntax annotated return Annotation { location , annotated = newAnnotated , annotation } Let{ location, assignments, body } -> do let onFieldName NameBinding{ nameLocation, name, annotation, assignment } = do newAssignment <- traverse onSyntax assignment return NameBinding { nameLocation , name , annotation , assignment = newAssignment } let onBinding PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } } = do newAssignment <- traverse onSyntax assignment return PlainBinding { plain = NameBinding { nameLocation , name , annotation , assignment = newAssignment } } onBinding RecordBinding{ fieldNamesLocation, fieldNames } = do newFieldNames <- traverse onFieldName fieldNames return RecordBinding { fieldNamesLocation , fieldNames = newFieldNames } let onAssignment Define{ assignmentLocation, definition = Definition{ nameLocation, name, bindings, annotation, assignment } } = do newAssignment <- onSyntax assignment newBindings <- traverse onBinding bindings return Define { assignmentLocation , definition = Definition { nameLocation , name , bindings = newBindings , annotation , assignment = newAssignment } } onAssignment Bind{ assignmentLocation, monad, binding, assignment } = do newBinding <- onBinding binding newAssignment <- onSyntax assignment return Bind { assignmentLocation , monad , binding = newBinding , assignment = newAssignment } newAssignments <- traverse onAssignment assignments newBody <- onSyntax body return Let { location , assignments = newAssignments , body = newBody } List{ location, elements } -> do newElements <- traverse onSyntax elements return List{ location, elements = newElements } Record{ location, fieldValues } -> do let onNameBinding NameBinding{ nameLocation, name, annotation, assignment } = do newAssignment <- traverse onSyntax assignment return NameBinding { nameLocation , name , annotation , assignment = newAssignment } let onBinding PlainBinding{ plain } = do newPlain <- onNameBinding plain return PlainBinding{ plain = newPlain } onBinding RecordBinding{ fieldNamesLocation, fieldNames } = do newFieldNames <- traverse onNameBinding fieldNames return RecordBinding { fieldNamesLocation , fieldNames = newFieldNames } let onDefinition Definition{ name, nameLocation, bindings, annotation, assignment } = do newBindings <- traverse onBinding bindings newAssignment <- onSyntax assignment return Definition { name , nameLocation , bindings = newBindings , annotation , assignment = newAssignment } newFieldValues <- traverse onDefinition fieldValues return Record{ location, fieldValues = newFieldValues } Project{ location, larger, smaller } -> do newLarger <- onSyntax larger return Project{ location, larger = newLarger, smaller } Alternative{ location, name, argument } -> do newArgument <- onSyntax argument pure Alternative{ name, location, argument = newArgument } Fold{ location, handlers } -> do newHandlers <- onSyntax handlers return Fold{ location, handlers = newHandlers } If{ location, predicate, ifTrue, ifFalse } -> do newPredicate <- onSyntax predicate newIfTrue <- onSyntax ifTrue newIfFalse <- onSyntax ifFalse return If { location , predicate = newPredicate , ifTrue = newIfTrue , ifFalse = newIfFalse } Text{ location, chunks = Chunks text₀ rest } -> do let onChunk (interpolation, text) = do newInterpolation <- onSyntax interpolation return (newInterpolation, text) newRest <- traverse onChunk rest return Text{ location, chunks = Chunks text₀ newRest } Prompt{ location, import_, arguments, schema } -> do newArguments <- onSyntax arguments return Prompt{ location, import_, arguments = newArguments, schema } HTTP{ location, import_, arguments, schema } -> do newArguments <- onSyntax arguments return HTTP{ location, import_, arguments = newArguments, schema } Read{ location, import_, arguments, schema } -> do newArguments <- onSyntax arguments return Read{ location, import_, arguments = newArguments, schema } GitHub{ location, import_, arguments, schema } -> do newArguments <- onSyntax arguments return GitHub{ location, import_, arguments = newArguments, schema } Show{ location, export, arguments, schema } -> do newArguments <- onSyntax arguments return Show{ location, export, arguments = newArguments, schema } Scalar{ location, scalar } -> do pure Scalar{ location, scalar } Operator{ location, left, operatorLocation, operator, right } -> do newLeft <- onSyntax left newRight <- onSyntax right return Operator { location , left = newLeft , operatorLocation , operator , right = newRight } Builtin{ location, builtin } -> do pure Builtin{ location, builtin } Embed{ location, embedded } -> do pure Embed{ location, embedded } instance Bifunctor Syntax where first f Variable{ location, name } = Variable{ name, location = f location } first f Lambda{ location, binding, body } = Lambda { location = f location , binding = first f binding , body = first f body } first f Application{ location, function, argument } = Application { location = f location , function = first f function , argument = first f argument } first f Annotation{ location, annotated, annotation } = Annotation { location = f location , annotated = first f annotated , annotation = fmap f annotation } first f Let{ location, assignments, body } = Let { location = f location , assignments = fmap (first f) assignments , body = first f body } first f List{ location, elements } = List{ location = f location, elements = fmap (first f) elements } first f Record{ location, fieldValues } = Record{ location = f location, fieldValues = fmap (first f) fieldValues } first f Project{ location, larger, smaller } = Project { location = f location , larger = first f larger , smaller = fmap f smaller } first f Alternative{ location, name, argument } = Alternative{ location = f location, name, argument = first f argument } first f Fold{ location, handlers } = Fold{ location = f location, handlers = first f handlers } first f If{ location, predicate, ifTrue, ifFalse } = If { location = f location , predicate = first f predicate , ifTrue = first f ifTrue , ifFalse = first f ifFalse } first f Text{ location, chunks } = Text{ location = f location, chunks = first f chunks } first f Prompt{ location, import_, arguments, schema } = Prompt { location = f location , import_ , arguments = first f arguments , schema = fmap (fmap f) schema } first f HTTP{ location, import_, arguments, schema } = HTTP { location = f location , import_ , arguments = first f arguments , schema = fmap (fmap f) schema } first f Read{ location, import_, arguments, schema } = Read { location = f location , import_ , arguments = first f arguments , schema = fmap (fmap f) schema } first f GitHub{ location, import_, arguments, schema } = GitHub { location = f location , import_ , arguments = first f arguments , schema = fmap (fmap f) schema } first f Show{ location, export, arguments, schema } = Show { location = f location , export , arguments = first f arguments , schema = fmap (fmap f) schema } first f Scalar{ location, scalar } = Scalar{ location = f location, scalar } first f Operator{ location, left, operatorLocation, operator, right } = Operator { location = f location , left = first f left , operatorLocation = f operatorLocation , operator , right = first f right } first f Builtin{ location, builtin } = Builtin{ location = f location, builtin } first f Embed{ location, embedded } = Embed{ location = f location, embedded } second = fmap instance IsString (Syntax () a) where fromString string = Variable{ location = (), name = fromString string } instance Pretty a => Pretty (Syntax s a) where pretty = prettyExpression -- | Returns whether the given variable is used within the expression usedIn :: Text -> Syntax s a -> Bool usedIn name₀ Variable{ name = name₁ } = name₀ == name₁ usedIn name₀ Lambda{ binding = PlainBinding{ plain = NameBinding{ name = name₁ } }, body } = (name₀ /= name₁) && usedIn name₀ body usedIn name₀ Lambda{ binding = RecordBinding{ fieldNames }, body } = (name₀ `notElem` fmap toName fieldNames) && usedIn name₀ body where toName NameBinding{ name = name₁ } = name₁ usedIn name₀ Application{ function, argument } = usedIn name₀ function || usedIn name₀ argument usedIn name₀ Annotation{ annotated } = usedIn name₀ annotated usedIn name₀ Let{ assignments = Define{ definition = Definition{ name = name₁, assignment } } :| [], body } = usedIn name₀ assignment || (name₀ /= name₁ && usedIn name₀ body) usedIn name₀ Let{ assignments = Bind{ binding, assignment } :| [], body } = usedIn name₀ assignment || (name₀ `notElem` toNames binding && usedIn name₀ body) where toName NameBinding{ name = name₁ } = name₁ toNames PlainBinding{ plain } = [ toName plain ] toNames RecordBinding{ fieldNames } = map toName fieldNames usedIn name₀ Let{ location, assignments = Define{ definition = Definition{ name = name₁, assignment } } :| (a : as), body } = usedIn name₀ assignment || (name₀ /= name₁ && usedIn name₀ Let{ location, assignments = a :| as, body }) usedIn name₀ Let{ location, assignments = Bind{ binding, assignment } :| (a : as), body } = usedIn name₀ assignment || (name₀ `notElem` toNames binding && usedIn name₀ Let{ location, assignments = a :| as, body }) where toName NameBinding{ name = name₁ } = name₁ toNames PlainBinding{ plain } = [ toName plain ] toNames RecordBinding{ fieldNames } = map toName fieldNames usedIn name₀ List{ elements } = any (usedIn name₀) elements usedIn name₀ Record{ fieldValues } = any onDefinition fieldValues where onDefinition Definition{ bindings, assignment } = name₀ `notElem` concatMap toNames bindings && usedIn name₀ assignment toName NameBinding{ name = name₁ } = name₁ toNames PlainBinding{ plain } = [ toName plain ] toNames RecordBinding{ fieldNames } = map toName fieldNames usedIn name₀ Project{ larger } = usedIn name₀ larger usedIn name₀ Alternative{ argument } = usedIn name₀ argument usedIn name₀ Fold{ handlers } = usedIn name₀ handlers usedIn name₀ If{ predicate, ifTrue, ifFalse } = usedIn name₀ predicate || usedIn name₀ ifTrue || usedIn name₀ ifFalse usedIn name₀ Text{ chunks = Chunks _ pairs } = any (usedIn name₀ . fst) pairs usedIn _ Scalar{ } = False usedIn name₀ Prompt{ arguments } = usedIn name₀ arguments usedIn name₀ HTTP{ arguments } = usedIn name₀ arguments usedIn name₀ Read{ arguments } = usedIn name₀ arguments usedIn name₀ GitHub{ arguments } = usedIn name₀ arguments usedIn name₀ Show{ arguments } = usedIn name₀ arguments usedIn name₀ Operator{ left, right } = usedIn name₀ left || usedIn name₀ right usedIn _ Builtin{ } = False usedIn _ Embed{ } = False -- | Returns all free variables within an expression freeVariables :: Syntax s a -> Set Text freeVariables Variable{ name } = Set.singleton name freeVariables Lambda{ binding = PlainBinding{ plain = NameBinding{ name } }, body } = Set.delete name (freeVariables body) freeVariables Lambda{ binding = RecordBinding{ fieldNames }, body } = Set.difference (freeVariables body) (Set.fromList (map toName fieldNames)) where toName NameBinding{ name = name₁ } = name₁ freeVariables Application{ function, argument } = Set.union (freeVariables function) (freeVariables argument) freeVariables Annotation{ annotated } = freeVariables annotated freeVariables Let{ assignments = Define{ definition = Definition{ name, assignment } } :| [], body } = Set.union (freeVariables assignment) (Set.delete name (freeVariables body)) freeVariables Let{ assignments = Bind{ binding, assignment } :| [], body } = Set.union (freeVariables assignment) (Set.difference (freeVariables body) (Set.fromList (toNames binding))) where toName NameBinding{ name = name₁ } = name₁ toNames PlainBinding{ plain } = [ toName plain ] toNames RecordBinding{ fieldNames } = map toName fieldNames freeVariables Let{ location, assignments = Define{ definition = Definition{ name, assignment } } :| (a : as), body } = Set.union (freeVariables assignment) (Set.delete name (freeVariables Let{ location, assignments = a :| as, body })) freeVariables Let{ location, assignments = Bind{ binding, assignment } :| (a : as), body } = Set.union (freeVariables assignment) (Set.difference (freeVariables Let{ location, assignments = a :| as, body }) (Set.fromList (toNames binding))) where toName NameBinding{ name = name₁ } = name₁ toNames PlainBinding{ plain } = [ toName plain ] toNames RecordBinding{ fieldNames } = map toName fieldNames freeVariables List{ elements } = Set.unions (fmap freeVariables elements) freeVariables Record{ fieldValues } = Set.unions (fmap onDefinition fieldValues) where onDefinition Definition{ bindings, assignment } = Set.difference (freeVariables assignment) (Set.fromList (concatMap toNames bindings)) toName NameBinding{ name = name₁ } = name₁ toNames PlainBinding{ plain } = [ toName plain ] toNames RecordBinding{ fieldNames } = map toName fieldNames freeVariables Project{ larger } = freeVariables larger freeVariables Alternative{ argument } = freeVariables argument freeVariables Fold{ handlers } = freeVariables handlers freeVariables If{ predicate, ifTrue, ifFalse } = Set.unions ( [freeVariables predicate, freeVariables ifTrue, freeVariables ifFalse] :: [Set Text] ) freeVariables Text{ chunks = Chunks _ pairs } = Set.unions (fmap (freeVariables . fst) pairs) freeVariables Scalar{ } = Set.empty freeVariables Prompt{ arguments } = freeVariables arguments freeVariables HTTP{ arguments } = freeVariables arguments freeVariables Read{ arguments } = freeVariables arguments freeVariables GitHub{ arguments } = freeVariables arguments freeVariables Show{ arguments } = freeVariables arguments freeVariables Operator{ left, right } = Set.union (freeVariables left) (freeVariables right) freeVariables Builtin{ } = Set.empty freeVariables Embed{ } = Set.empty -- | `Getting` that matches all effects within a `Syntax` tree effects :: Getting Any (Syntax s a) () effects = Lens.cosmos . effect where effect = (_As @"Prompt" . Lens.to (\_ -> ())) <> (_As @"HTTP" . Lens.to (\_ -> ())) <> (_As @"GitHub" . Lens.to (\_ -> ())) -- | A text literal with interpolated expressions data Chunks s a = Chunks Text [(Syntax s a, Text)] deriving stock (Eq, Foldable, Functor, Lift, Show, Traversable) instance Monoid (Chunks s a) where mempty = Chunks mempty mempty instance Semigroup (Chunks s a) where Chunks text₀ rest₀ <> Chunks text₂ rest₂ = case unsnoc rest₀ of Nothing -> Chunks (text₀ <> text₂) rest₂ Just (rest₁, (syntax, text₁)) -> Chunks text₀ (rest₁ <> ((syntax, text₁ <> text₂) : rest₂)) where unsnoc [ ] = Nothing unsnoc [x] = Just ([], x) unsnoc (x : xs) = do (i, l) <- unsnoc xs return (x : i, l) instance Bifunctor Chunks where first f (Chunks text₀ rest) = Chunks text₀ (fmap (first (first f)) rest) second = fmap instance IsString (Chunks s a) where fromString string = Chunks (fromString string) [] instance Pretty a => Pretty (Chunks s a) where pretty (Chunks text₀ rest) = Pretty.flatAlt long short where short = ( Pretty.punctuation "\"" <> Pretty.scalar (Type.prettyTextBody False text₀) <> foldMap (prettyInterpolation False) rest <> Pretty.punctuation "\"" ) long = (if multiline then Pretty.align else id) ( Pretty.punctuation prefix <> Pretty.scalar (Type.prettyTextBody multiline text₀) <> foldMap (prettyInterpolation multiline) rest <> Pretty.punctuation "\"" ) prefix | multiline = "\"\n" | otherwise = "\"" multiline = Text.any (== '\n') text₀ || any (Text.any (== '\n') . snd) rest prettyInterpolation m (syntax, text) = Pretty.punctuation "${" <> flatten (pretty syntax) <> Pretty.punctuation "}" <> Pretty.scalar (Type.prettyTextBody m text) -- | A field of a record data Field s = Field{ fieldLocation :: s, field :: Text } deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable) instance IsString (Field ()) where fromString string = Field{ fieldLocation = (), field = fromString string } -- | A projection of one or more fields data Smaller s = Single{ single :: Field s } | Multiple{ multipleLocation :: s, multiple :: [Field s] } | Index{ index :: Integer } | Slice{ begin :: Maybe Integer, end :: Maybe Integer } deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable) instance IsString (Smaller ()) where fromString string = Single{ single = fromString string } -- | @Traversal'@ from a `Syntax` to its immediate `Type` types :: Traversal' (Syntax s a) (Type s) types onType Lambda{ location, binding = PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } }, body } = do newAnnotation <- traverse onType annotation return Lambda { location , binding = PlainBinding { plain = NameBinding { nameLocation , name , annotation = newAnnotation , assignment } } , body } types onType Annotation{ location, annotated, annotation } = do newAnnotation <- onType annotation return Annotation{ location, annotated, annotation = newAnnotation } types onType Prompt{ location, import_, arguments, schema } = do newSchema <- traverse onType schema return Prompt{ location, import_, arguments, schema = newSchema } types onType HTTP{ location, import_, arguments, schema } = do newSchema <- traverse onType schema return HTTP{ location, import_, arguments, schema = newSchema } types onType Read{ location, import_, arguments, schema } = do newSchema <- traverse onType schema return Read{ location, import_, arguments, schema = newSchema } types onType GitHub{ location, import_, arguments, schema } = do newSchema <- traverse onType schema return GitHub{ location, import_, arguments, schema = newSchema } types onType Show{ location, export, arguments, schema } = do newSchema <- traverse onType schema return Show{ location, export, arguments, schema = newSchema } types onType Let{ location, assignments, body } = do newAssignments <- traverse onAssignment assignments return Let{ location, assignments = newAssignments, body } where onAssignment Define{ assignmentLocation, definition = Definition{ nameLocation, name, bindings, annotation, assignment } } = do newBindings <- traverse onBinding bindings newAnnotation <- traverse onType annotation return Define { assignmentLocation , definition = Definition { nameLocation , name , bindings = newBindings , annotation = newAnnotation , assignment } } onAssignment Bind{ assignmentLocation, monad, binding, assignment } = do newBinding <- onBinding binding return Bind { assignmentLocation , monad , binding = newBinding , assignment } onBinding PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } } = do newAnnotation <- traverse onType annotation return PlainBinding { plain = NameBinding { nameLocation , name , annotation = newAnnotation , assignment } } onBinding RecordBinding{ fieldNamesLocation, fieldNames } = do newFieldNames <- traverse onFieldName fieldNames return RecordBinding { fieldNamesLocation , fieldNames = newFieldNames } onFieldName NameBinding{ nameLocation, name, annotation, assignment } = do newAnnotation <- traverse onType annotation return NameBinding { nameLocation , name , annotation = newAnnotation , assignment } types _ e = pure e -- | Complete all `Type` annotations in a `Syntax` tree using the provided -- `Context` complete :: Context s -> Syntax s a -> Syntax s a complete context = Lens.transform (Lens.over types (Context.complete context)) -- | A scalar value data Scalar = Real Scientific -- ^ -- >>> pretty (Real 1.0) -- 1.0 | Integer Integer -- ^ -- >>> pretty (Integer 1) -- 1 | Natural Natural -- ^ -- >>> pretty (Natural 1) -- 1 | Bool Bool -- ^ -- >>> pretty (Bool True) -- true -- >>> pretty (Bool False) -- false | Null -- ^ -- >>> pretty Null -- null | Key Text -- ^ -- >>> pretty (Key "secret") -- 🔒 deriving stock (Eq, Generic, Lift, Show) instance ToJSON Scalar where toJSON (Real n) = toJSON n toJSON (Integer n) = toJSON n toJSON (Natural n) = toJSON n toJSON (Bool b) = toJSON b toJSON Null = Aeson.Null toJSON (Key _) = Aeson.Null instance Pretty Scalar where pretty (Bool True ) = Pretty.scalar "true" pretty (Bool False) = Pretty.scalar "false" pretty (Real number) = Pretty.scalar (pretty number) pretty (Integer number) = Pretty.scalar (pretty number) pretty (Natural number) = Pretty.scalar (pretty number) pretty Null = Pretty.scalar "null" pretty (Key _) = Pretty.scalar "🔒" -- | A binary infix operator data Operator = Or -- ^ -- >>> pretty Or -- || | And -- ^ -- >>> pretty And -- && | Equal -- ^ -- >>> pretty Equal -- == | NotEqual -- ^ -- >>> pretty NotEqual -- != | LessThan -- ^ -- >>> pretty LessThan -- < | LessThanOrEqual -- ^ -- >>> pretty LessThanOrEqual -- <= | GreaterThan -- ^ -- >>> pretty GreaterThan -- > | GreaterThanOrEqual -- ^ -- >>> pretty GreaterThanOrEqual -- >= | Plus -- ^ -- >>> pretty Plus -- + | Minus -- ^ -- >>> pretty Minus -- - | Times -- ^ -- >>> pretty Times -- * | Modulus -- ^ -- >>> pretty Modulus -- % | Divide -- ^ -- >>> pretty Divide -- / deriving stock (Eq, Generic, Lift, Show) instance Pretty Operator where pretty And = Pretty.operator "&&" pretty Or = Pretty.operator "||" pretty Equal = Pretty.operator "==" pretty NotEqual = Pretty.operator "!=" pretty LessThan = Pretty.operator "<" pretty LessThanOrEqual = Pretty.operator "<=" pretty GreaterThan = Pretty.operator ">" pretty GreaterThanOrEqual = Pretty.operator ">=" pretty Plus = Pretty.operator "+" pretty Minus = Pretty.operator "-" pretty Times = Pretty.operator "*" pretty Modulus = Pretty.operator "%" pretty Divide = Pretty.operator "/" -- | A built-in function data Builtin = Abs -- ^ -- >>> pretty Abs -- abs | Indexed -- ^ -- >>> pretty Indexed -- indexed | Length -- ^ -- >>> pretty Length -- length | Map -- ^ -- >>> pretty Map -- map | Reveal -- ^ -- >>> pretty Reveal -- reveal | Some -- ^ -- >>> pretty Some -- some | YAML -- ^ -- >>> pretty YAML -- yaml deriving stock (Bounded, Enum, Eq, Generic, Lift, Show) instance Pretty Builtin where pretty Abs = Pretty.builtin "abs" pretty Indexed = Pretty.builtin "indexed" pretty Length = Pretty.builtin "length" pretty Map = Pretty.builtin "map" pretty Reveal = Pretty.builtin "reveal" pretty Some = Pretty.builtin "some" pretty YAML = Pretty.builtin "yaml" -- | Pretty-print an expression prettyExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyExpression expression@Lambda{} = -- Anywhere you see `Pretty.group (Pretty.flatAlt long short)` that means -- that the pretty-printer will first attempt to display `short` if that -- fits on one line, otherwise it will fall back to displaying `long` -- (which is typically a multi-line result) Pretty.group (Pretty.flatAlt long short) where short = punctuation "\\" <> prettyShort expression long = prettyLong expression prettyShort Lambda{ binding, body } = pretty binding <> " " <> prettyShort body prettyShort body = punctuation "->" <> " " <> prettyExpression body prettyLong Lambda{ binding, body } = punctuation "\\" <> pretty binding <> " " <> punctuation "->" <> Pretty.hardline <> prettyLong body prettyLong body = " " <> Pretty.nest 2 (prettyExpression body) prettyExpression Let{ assignments, body } = Pretty.group (Pretty.flatAlt long short) where short = foldMap (\assignment -> pretty assignment <> " ") assignments <> keyword "in" <> " " <> prettyExpression body long = foldMap (\assignment -> pretty assignment <> Pretty.hardline <> Pretty.hardline) assignments <> keyword "in" <> " " <> Pretty.nest 4 (prettyExpression body) prettyExpression If{ predicate, ifTrue, ifFalse } = Pretty.group (Pretty.flatAlt long short) where short = keyword "if" <> " " <> prettyExpression predicate <> " " <> keyword "then" <> " " <> prettyExpression ifTrue <> " " <> keyword "else" <> " " <> prettyExpression ifFalse long = keyword "if" <> " " <> Pretty.nest 4 (prettyExpression predicate) <> Pretty.hardline <> keyword "then" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyExpression ifTrue) <> Pretty.hardline <> keyword "else" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyExpression ifFalse) prettyExpression Prompt{ arguments, import_, schema = Just schema } = Pretty.group (Pretty.flatAlt long short) where short = prefix <> keyword "prompt" <> " " <> prettyProjectExpression arguments <> " " <> Pretty.operator ":" <> " " <> pretty schema long = prefix <> keyword "prompt" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression arguments) <> Pretty.hardline <> " " <> Pretty.operator ":" <> " " <> Pretty.nest 4 (pretty schema) prefix = if import_ then keyword "import" <> " " else mempty prettyExpression HTTP{ arguments, import_, schema = Just schema } = Pretty.group (Pretty.flatAlt long short) where short = prefix <> keyword "http" <> " " <> prettyProjectExpression arguments <> " " <> Pretty.operator ":" <> " " <> pretty schema long = prefix <> keyword "http" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression arguments) <> Pretty.hardline <> " " <> Pretty.operator ":" <> " " <> Pretty.nest 4 (pretty schema) prefix = if import_ then keyword "import" <> " " else mempty prettyExpression Read{ arguments, import_, schema = Just schema } = Pretty.group (Pretty.flatAlt long short) where short = prefix <> keyword "read" <> " " <> prettyProjectExpression arguments <> " " <> Pretty.operator ":" <> " " <> pretty schema long = prefix <> keyword "read" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression arguments) <> Pretty.hardline <> " " <> Pretty.operator ":" <> " " <> Pretty.nest 4 (pretty schema) prefix = if import_ then keyword "import" <> " " else mempty prettyExpression GitHub{ arguments, import_, schema = Just schema } = Pretty.group (Pretty.flatAlt long short) where short = prefix <> keyword "github" <> " " <> prettyProjectExpression arguments <> " " <> Pretty.operator ":" <> " " <> pretty schema long = prefix <> keyword "github" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression arguments) <> Pretty.hardline <> " " <> Pretty.operator ":" <> " " <> Pretty.nest 4 (pretty schema) prefix = if import_ then keyword "import" <> " " else mempty prettyExpression Annotation{ annotated, annotation } = Pretty.group (Pretty.flatAlt long short) where short = prettyOperatorExpression annotated <> " " <> Pretty.operator ":" <> " " <> pretty annotation long = prettyOperatorExpression annotated <> Pretty.hardline <> " " <> Pretty.operator ":" <> " " <> Pretty.nest 4 (pretty annotation) prettyExpression other = prettyOperatorExpression other prettyOperator :: Pretty a => Operator -> (Syntax s a -> Doc AnsiStyle) -> (Syntax s a -> Doc AnsiStyle) prettyOperator operator0 prettyNext expression@Operator{ operator = operator1 } | operator0 == operator1 = Pretty.group (Pretty.flatAlt long short) where short = prettyShort expression long = pretty (Text.replicate indent " ") <> prettyLong expression prettyShort Operator{ left, operator, right } | operator0 == operator = prettyShort left <> " " <> pretty operator <> " " <> prettyShort right prettyShort other = prettyNext other prettyLong Operator{ left, operator, right } | operator0 == operator = Pretty.nest indent (prettyLong left) <> Pretty.hardline <> pretty operator <> pretty (Text.replicate spacing " ") <> prettyLong right prettyLong other = pretty (Text.replicate indent " ") <> Pretty.nest indent (prettyNext other) operatorWidth = Text.length (Pretty.toText operator0) alignment = 2 align n = ((n `div` alignment) + 1) * alignment indent = align operatorWidth spacing = indent - operatorWidth prettyOperator _ prettyNext other = prettyNext other prettyOperatorExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyOperatorExpression = prettyOrExpression prettyOrExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyOrExpression = prettyOperator Or prettyAndExpression prettyAndExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyAndExpression = prettyOperator And prettyEqualExpression prettyEqualExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyEqualExpression = prettyOperator Equal prettyNotEqualExpression prettyNotEqualExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyNotEqualExpression = prettyOperator NotEqual prettyLessThanExpression prettyLessThanExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyLessThanExpression = prettyOperator LessThan prettyLessThanOrEqualExpression prettyLessThanOrEqualExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyLessThanOrEqualExpression = prettyOperator LessThanOrEqual prettyGreaterThanExpression prettyGreaterThanExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyGreaterThanExpression = prettyOperator GreaterThan prettyGreaterThanOrEqualExpression prettyGreaterThanOrEqualExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyGreaterThanOrEqualExpression = prettyOperator GreaterThanOrEqual prettyPlusExpression prettyPlusExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyPlusExpression = prettyOperator Plus prettyMinusExpression prettyMinusExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyMinusExpression = prettyOperator Minus prettyTimesExpression prettyTimesExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyTimesExpression = prettyOperator Times prettyModulusExpression prettyModulusExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyModulusExpression = prettyOperator Modulus prettyDivideExpression prettyDivideExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyDivideExpression = prettyOperator Divide prettyApplicationExpression prettyApplicationExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyApplicationExpression expression | isApplication expression = Pretty.group (Pretty.flatAlt long short) | otherwise = prettyProjectExpression expression where isApplication Application{} = True isApplication Fold{} = True isApplication Prompt{} = True isApplication HTTP{} = True isApplication Read{} = True isApplication GitHub{} = True isApplication Show{} = True isApplication _ = False short = prettyShort expression long = prettyLong expression prettyShort Application{ function, argument } = prettyShort function <> " " <> prettyProjectExpression argument prettyShort Fold{ handlers } = keyword "fold" <> " " <> prettyProjectExpression handlers prettyShort Prompt{ arguments, import_, schema = Nothing } = prefix <> keyword "prompt" <> " " <> prettyProjectExpression arguments where prefix = if import_ then keyword "import" <> " " else mempty prettyShort HTTP{ arguments, import_, schema = Nothing } = prefix <> keyword "http" <> " " <> prettyProjectExpression arguments where prefix = if import_ then keyword "import" <> " " else mempty prettyShort Read{ arguments, import_, schema = Nothing } = prefix <> keyword "read" <> " " <> prettyProjectExpression arguments where prefix = if import_ then keyword "import" <> " " else mempty prettyShort GitHub{ arguments, import_, schema = Nothing } = prefix <> keyword "github" <> " " <> prettyProjectExpression arguments where prefix = if import_ then keyword "import" <> " " else mempty prettyShort Show{ arguments, export, schema } = prefix <> keyword "show" <> " " <> prettyProjectExpression annotatedArguments where prefix = if export then keyword "export" <> " " else mempty annotatedArguments = case schema of Nothing -> arguments Just s -> Annotation { location = Type.location s , annotated = arguments , annotation = s } prettyShort other = prettyProjectExpression other prettyLong Application{ function, argument } = prettyLong function <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression argument) prettyLong Fold{ handlers } = keyword "fold" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression handlers) prettyLong Prompt{ import_, arguments } = prefix <> keyword "prompt" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression arguments) where prefix = if import_ then keyword "import" <> " " else mempty prettyLong HTTP{ import_, arguments } = prefix <> keyword "http" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression arguments) where prefix = if import_ then keyword "import" <> " " else mempty prettyLong Read{ import_, arguments } = prefix <> keyword "read" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression arguments) where prefix = if import_ then keyword "import" <> " " else mempty prettyLong GitHub{ import_, arguments } = prefix <> keyword "github" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression arguments) where prefix = if import_ then keyword "import" <> " " else mempty prettyLong Show{ export, arguments, schema } = prefix <> keyword "show" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyProjectExpression annotatedArguments) where prefix = if export then keyword "export" <> " " else mempty annotatedArguments = case schema of Nothing -> arguments Just s -> Annotation { location = Type.location s , annotated = arguments , annotation = s } prettyLong other = prettyProjectExpression other prettyProjectExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyProjectExpression expression = case expression of Project{ } -> Pretty.group (Pretty.flatAlt long short) _ -> prettyAlternativeExpression expression where short = prettyShort expression long = prettyLong expression prettyShort Project{ larger, smaller = Single{ single = Field{ field } } } = prettyShort larger <> Pretty.operator "." <> Type.prettyRecordLabel False field prettyShort Project{ larger, smaller = Multiple{ multiple = [ ] } } = prettyShort larger <> Pretty.operator "." <> Pretty.punctuation "{" <> " " <> Pretty.punctuation "}" prettyShort Project{ larger, smaller = Multiple{ multiple = Field{ field = f₀ } : fs } } = prettyShort larger <> Pretty.operator "." <> Pretty.punctuation "{" <> " " <> Type.prettyRecordLabel False f₀ <> foldMap (\Field{ field = f } -> Pretty.punctuation "," <> " " <> Type.prettyRecordLabel False f) fs <> " " <> Pretty.punctuation "}" prettyShort Project{ larger, smaller = Index{ index } } = prettyShort larger <> Pretty.operator "." <> Pretty.scalar (pretty index) prettyShort other = prettyAlternativeExpression other prettyLong Project{ larger, smaller = Single{ single = Field{ field } } } = prettyLong larger <> Pretty.hardline <> " " <> Pretty.operator "." <> Type.prettyRecordLabel False field prettyLong Project{ larger, smaller = Multiple{ multiple = [ ] } } = prettyLong larger <> Pretty.hardline <> " " <> Pretty.operator "." <> Pretty.punctuation "{" <> " " <> Pretty.punctuation "}" prettyLong Project{ larger, smaller = Multiple{ multiple = Field{ field = f₀ } : fs } } = prettyLong larger <> Pretty.hardline <> " " <> Pretty.operator "." <> " " <> Pretty.nest 4 ( Pretty.punctuation "{" <> " " <> Type.prettyRecordLabel False f₀ <> foldMap (\Field{ field = f } -> Pretty.hardline <> Pretty.punctuation "," <> " " <> Type.prettyRecordLabel False f) fs <> Pretty.hardline <> Pretty.punctuation "}" ) prettyLong Project{ larger, smaller = Index{ index } } = prettyLong larger <> Pretty.hardline <> " " <> Pretty.operator "." <> Pretty.scalar (pretty index) prettyLong record = prettyAlternativeExpression record prettyAlternativeExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyAlternativeExpression Alternative{ name, argument = argument@Record{ } } = Pretty.group (Pretty.flatAlt long short) where short = Type.prettyAlternativeLabel name <> prettyPrimitiveExpression argument long = Type.prettyAlternativeLabel name <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyPrimitiveExpression argument) prettyAlternativeExpression Alternative{ name, argument } = Pretty.group (Pretty.flatAlt long short) where short = Type.prettyAlternativeLabel name <> " " <> prettyPrimitiveExpression argument long = Type.prettyAlternativeLabel name <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyPrimitiveExpression argument) prettyAlternativeExpression other = prettyPrimitiveExpression other prettyPrimitiveExpression :: Pretty a => Syntax s a -> Doc AnsiStyle prettyPrimitiveExpression Variable{ name } = Type.prettyLabel name prettyPrimitiveExpression List{ elements = [] } = punctuation "[" <> " " <> punctuation "]" prettyPrimitiveExpression List{ elements = element :<| elements } = Pretty.group (Pretty.flatAlt long short) where short = punctuation "[" <> " " <> prettyExpression element <> foldMap (\e -> punctuation "," <> " " <> prettyExpression e) elements <> " " <> punctuation "]" long = punctuation "[" <> " " <> prettyLongElement element <> foldMap (\e -> punctuation "," <> " " <> prettyLongElement e) elements <> punctuation "]" prettyLongElement e = Pretty.nest 2 (prettyExpression e) <> Pretty.hardline prettyPrimitiveExpression Record{ fieldValues = [] } = punctuation "{" <> " " <> punctuation "}" prettyPrimitiveExpression Record { fieldValues = fieldValue : fieldValues } = Pretty.group (Pretty.flatAlt long short) where short = punctuation "{" <> " " <> prettyShortFieldValue fieldValue <> foldMap (\fv -> punctuation "," <> " " <> prettyShortFieldValue fv) fieldValues <> " " <> punctuation "}" long = punctuation "{" <> " " <> prettyLongFieldValue fieldValue <> foldMap (\fv -> punctuation "," <> " " <> prettyLongFieldValue fv) fieldValues <> punctuation "}" prettyShortFieldValue Definition{ name, bindings, assignment } = Type.prettyRecordLabel True name <> foldMap renderBinding bindings <> Pretty.operator ":" <> " " <> prettyExpression assignment where renderBinding binding = " " <> pretty binding prettyLongFieldValue Definition{ name, bindings, assignment } = Type.prettyRecordLabel True name <> foldMap renderBinding bindings <> Pretty.operator ":" <> Pretty.hardline <> " " <> Pretty.nest 4 (prettyExpression assignment) <> Pretty.hardline where renderBinding binding = Pretty.hardline <> " " <> Pretty.nest 4 ( Pretty.punctuation "(" <> " " <> Pretty.nest 2 (pretty binding) <> Pretty.hardline <> Pretty.punctuation ")" ) prettyPrimitiveExpression Builtin{ builtin } = pretty builtin prettyPrimitiveExpression Scalar{ scalar } = pretty scalar prettyPrimitiveExpression Text{ chunks } = pretty chunks prettyPrimitiveExpression Embed{ embedded } = pretty embedded prettyPrimitiveExpression other = Pretty.group (Pretty.flatAlt long short) where short = punctuation "(" <> prettyExpression other <> punctuation ")" long = punctuation "(" <> " " <> Pretty.nest 2 (prettyExpression other) <> Pretty.hardline <> punctuation ")" {-| A bound field name >>> pretty @(NameBinding () Void) (NameBinding () "x" Nothing Nothing) x >>> pretty @(NameBinding () Void) (NameBinding () "x" (Just "A") Nothing) x : A >>> pretty @(NameBinding () Void) (NameBinding () "x" Nothing (Just "a")) x = a >>> pretty @(NameBinding () Void) (NameBinding () "x" (Just "A") (Just "a")) x : A = a -} data NameBinding s a = NameBinding { nameLocation :: s , name :: Text , annotation :: Maybe (Type s) , assignment :: Maybe (Syntax s a) } deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable) instance Bifunctor NameBinding where first f NameBinding{ nameLocation, name, annotation, assignment } = NameBinding { nameLocation = f nameLocation , name , annotation = fmap (fmap f) annotation , assignment = fmap (first f) assignment } second = fmap instance IsString (NameBinding () a) where fromString string = NameBinding { nameLocation = () , name = fromString string , annotation = Nothing , assignment = Nothing } instance Pretty a => Pretty (NameBinding s a) where pretty NameBinding{ name, annotation, assignment } = Type.prettyRecordLabel False name <> foldMap renderAnnotation annotation <> foldMap renderAssignment assignment where renderAnnotation a = " " <> punctuation ":" <> " " <> pretty a renderAssignment a = " " <> punctuation "=" <> " " <> pretty a {-| A bound variable, possibly with a type annotation >>> pretty @(Binding () Void) (PlainBinding (NameBinding () "x" Nothing Nothing)) x >>> pretty @(Binding () Void) (PlainBinding (NameBinding () "x" (Just "A") Nothing)) (x : A) >>> pretty @(Binding () Void) (PlainBinding (NameBinding () "x" Nothing (Just "a"))) (x = a) >>> pretty @(Binding () Void) (PlainBinding (NameBinding () "x" (Just "A") (Just "a"))) (x : A = a) >>> pretty @(Binding () Void) (RecordBinding () []) { } >>> pretty @(Binding () Void) (RecordBinding () [ "x", "y" ]) { x, y } -} data Binding s a = PlainBinding{ plain :: NameBinding s a } | RecordBinding { fieldNamesLocation :: s , fieldNames :: [NameBinding s a] } deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable) instance Bifunctor Binding where first f PlainBinding{ plain = NameBinding{ nameLocation, name, annotation, assignment } } = PlainBinding{ plain = NameBinding{ nameLocation = f nameLocation, name, annotation = fmap (fmap f) annotation, assignment = fmap (first f) assignment } } first f RecordBinding{ fieldNamesLocation, fieldNames } = RecordBinding{ fieldNamesLocation = f fieldNamesLocation, fieldNames = fmap (first f) fieldNames } second = fmap instance IsString (Binding () a) where fromString string = PlainBinding { plain = NameBinding { nameLocation = () , name = fromString string , annotation = Nothing , assignment = Nothing } } instance Pretty a => Pretty (Binding s a) where pretty PlainBinding{ plain = NameBinding{ name, annotation = Nothing, assignment = Nothing } } = Type.prettyLabel name pretty PlainBinding{ plain = NameBinding{ name, annotation, assignment } } = punctuation "(" <> Type.prettyLabel name <> foldMap renderAnnotation annotation <> foldMap renderAssignment assignment <> punctuation ")" where renderAnnotation a = " " <> Pretty.operator ":" <> " " <> pretty a renderAssignment a = " " <> Pretty.operator "=" <> " " <> pretty a pretty RecordBinding{ fieldNames = [ ] } = punctuation "{" <> " " <> punctuation "}" pretty RecordBinding{ fieldNames = fieldName : fieldNames } = punctuation "{" <> " " <> pretty fieldName <> foldMap (\f -> punctuation "," <> " " <> pretty f) fieldNames <> " " <> punctuation "}" data Definition s a = Definition { nameLocation :: s , name :: Text , bindings :: [Binding s a] , annotation :: Maybe (Type s) , assignment :: Syntax s a } deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable) instance Bifunctor Definition where first f Definition{ nameLocation, name, bindings, annotation, assignment } = Definition { nameLocation = f nameLocation , name , bindings = fmap (first f) bindings , annotation = fmap (fmap f) annotation , assignment = first f assignment } second = fmap -- | The monad that a `Bind` takes place in data BindMonad = IdentityMonad | OptionalMonad | ListMonad deriving stock (Eq, Generic, Lift, Ord, Show) instance Pretty BindMonad where pretty IdentityMonad = Pretty.builtin "Identity" pretty OptionalMonad = Pretty.builtin "Optional" pretty ListMonad = Pretty.builtin "List" {-| The assignment part of a @let@ binding >>> pretty @(Assignment () Void) (Define () (Definition () "x" [] Nothing "y")) let x = y >>> pretty @(Assignment () Void) (Define () (Definition () "x" [] (Just "X") "y")) let x : X = y >>> pretty @(Assignment () Void) (Define () (Definition () "x" [PlainBinding (NameBinding () "a" (Just "A") Nothing)] (Just "X") "y")) let x (a : A) : X = y -} data Assignment s a = Define { assignmentLocation :: s , definition :: Definition s a } | Bind { assignmentLocation :: s , monad :: BindMonad , binding :: Binding s a , assignment :: Syntax s a } deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable) instance Bifunctor Assignment where first f Define{ assignmentLocation, definition = Definition{ nameLocation, name, bindings, annotation, assignment } } = Define { assignmentLocation = f assignmentLocation , definition = Definition { nameLocation = f nameLocation , name , bindings = fmap (first f) bindings , annotation = fmap (fmap f) annotation , assignment = first f assignment } } first f Bind{ assignmentLocation, monad, binding, assignment } = Bind { assignmentLocation = f assignmentLocation , monad , binding = first f binding , assignment = first f assignment } second = fmap instance Pretty a => Pretty (Assignment s a) where pretty Define{ definition = Definition{ name, bindings, annotation = Nothing, assignment } } = Pretty.group (Pretty.flatAlt long short) where long = keyword "let" <> " " <> Type.prettyLabel name <> Pretty.hardline <> foldMap (\binding -> " " <> Pretty.nest 6 (pretty binding) <> Pretty.hardline) bindings <> " " <> punctuation "=" <> " " <> Pretty.nest 8 (pretty assignment) short = keyword "let" <> " " <> Type.prettyLabel name <> " " <> foldMap (\binding -> pretty binding <> " ") bindings <> punctuation "=" <> " " <> pretty assignment pretty Define{ definition = Definition{ name, bindings, annotation = Just type_, assignment } } = Pretty.group (Pretty.flatAlt long short) where long = keyword "let" <> " " <> Type.prettyLabel name <> Pretty.hardline <> foldMap (\binding -> " " <> Pretty.nest 6 (pretty binding) <> Pretty.hardline) bindings <> " " <> Pretty.operator ":" <> " " <> Pretty.nest 8 (pretty type_) <> Pretty.hardline <> " " <> punctuation "=" <> " " <> Pretty.nest 8 (pretty assignment) short = keyword "let" <> " " <> Type.prettyLabel name <> " " <> foldMap (\binding -> pretty binding <> " ") bindings <> Pretty.operator ":" <> " " <> pretty type_ <> " " <> punctuation "=" <> " " <> pretty assignment pretty Bind{ monad = IdentityMonad, binding, assignment } = Pretty.group (Pretty.flatAlt long short) where long = keyword "let" <> " " <> pretty binding <> Pretty.hardline <> " " <> punctuation "=" <> " " <> Pretty.nest 8 (pretty assignment) short = keyword "let" <> " " <> pretty binding <> " " <> punctuation "=" <> " " <> pretty assignment pretty Bind{ monad = ListMonad, binding, assignment } = Pretty.group (Pretty.flatAlt long short) where long = keyword "for" <> " " <> pretty binding <> Pretty.hardline <> " " <> punctuation "of" <> " " <> Pretty.nest 8 (pretty assignment) short = keyword "for" <> " " <> pretty binding <> " " <> punctuation "of" <> " " <> pretty assignment pretty Bind{ monad = OptionalMonad, binding, assignment } = Pretty.group (Pretty.flatAlt long short) where long = keyword "if" <> " " <> keyword "let" <> " " <> pretty binding <> Pretty.hardline <> " " <> punctuation "=" <> " " <> Pretty.nest 8 (pretty assignment) short = keyword "if" <> " " <> keyword "let" <> " " <> pretty binding <> " " <> punctuation "of" <> " " <> pretty assignment flatten :: Doc ann -> Doc ann flatten doc = case doc of FlatAlt _ y -> flatten y Cat x y -> Cat (flatten x) (flatten y) Nest i x -> Nest i (flatten x) Line -> Fail Union x _ -> flatten x Column f -> Column (flatten . f) WithPageWidth f -> WithPageWidth (flatten . f) Nesting f -> Nesting (flatten . f) Annotated ann x -> Annotated ann (flatten x) _ -> doc ================================================ FILE: src/Grace/TH.hs ================================================ {- | This module provides Template Haskell functions to embed expression and their times at compile-time. -} module Grace.TH ( grace -- * Embedding an expression , expressionFromCode , expressionFromFile , expressionFromInput -- * Embedding the type of an expression , typeOfCode , typeOfFile , typeOfInput ) where import Control.Monad.IO.Class (liftIO) import Data.Functor (void) import Data.Text (Text) import Data.Void (Void) import Grace.Input (Input(..), Mode(..)) import Grace.Syntax (Syntax) import Grace.Type (Type) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Haskell.TH.Syntax (Code(examineCode), Lift, Q, TExp(..)) import Prelude hiding (exp) import qualified Data.Text as Text import qualified Grace.Interpret as Interpret import qualified Grace.Value as Value import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH -- $setup -- >>> :set -XOverloadedStrings -XQuasiQuotes -XTemplateHaskell {- | A quasi-quoter for expressions. Takes the source code of a expression, type checks it and returns the fully normalized AST. >>> [grace| "hello" |] Text {location = (), chunks = Chunks "hello" []} This quoter is implemented using `expressionFromCode`. Note that other quoting (declarations, patterns, types) is not supported. -} grace :: QuasiQuoter grace = QuasiQuoter { quoteExp = fmap TH.unType . examineCode . expressionFromCode . Text.pack , quoteDec = error "Declaration quoting not supported" , quotePat = error "Pattern quoting not supported" , quoteType = error "Type quoting not supported" } {- | Evaluate an expression at compile time. This function takes the source code of a expressions, type checks it and returns the fully normalized AST. >>> $$(expressionFromCode "\"hello\"") Text {location = (), chunks = Chunks "hello" []} -} expressionFromCode :: Text -> Code Q (Syntax () Void) expressionFromCode code = expressionFromInput (Code "(quasiquote)" code) -- | Like `expressionFromCode`, but takes path of a source file as input. expressionFromFile :: FilePath -> Code Q (Syntax () Void) expressionFromFile path = expressionFromInput (Path path AsCode) -- | Like `expressionFromCode`, but expects `Input` as an argument. expressionFromInput :: Input -> Code Q (Syntax () Void) expressionFromInput = helperFunction snd {- | Infer the type of an expression at compile time. This function takes the source code of an expressions, type checks it and returns the inferred type of that expression. >>> $$(typeOfCode "\"hello\"") Scalar {location = (), scalar = Text} -} typeOfCode :: Text -> Code Q (Type ()) typeOfCode = typeOfInput . Code "(input)" -- | Like `typeOfCode`, but takes path of a source file as input. typeOfFile :: FilePath -> Code Q (Type ()) typeOfFile path = typeOfInput (Path path AsCode) -- | Like `typeOfCode`, but expects `Input` as an argument. typeOfInput :: Input -> Code Q (Type ()) typeOfInput = helperFunction fst -- | Underlying code for all TemplateHaskell utilities helperFunction :: Lift result => ((Type (), Syntax () Void) -> result) -> Input -> Code Q result helperFunction f input = TH.Code do (inferred, value) <- liftIO (Interpret.interpret input) let type_ = void inferred let syntax = Value.quote (void value) exp <- TH.lift (f (type_, syntax)) return (TExp exp) ================================================ FILE: src/Grace/Type.hs ================================================ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-orphans #-} {-| This module stores the `Type` type representing polymorphic types and utilities for operating on `Type`s -} module Grace.Type ( -- * Types Type(..) , Record(..) , Union(..) -- * Utilities , solveType , solveFields , solveAlternatives , typeFreeIn , fieldsFreeIn , alternativesFreeIn , substituteType , substituteFields , substituteAlternatives , defaultTo -- * Pretty-printing , prettyRecordLabel , prettyAlternativeLabel , prettyLabel , prettyTextLiteral , prettyTextBody ) where import Control.Lens (Plated(..)) import Data.Bifunctor (Bifunctor(..)) import Data.Generics.Product (the) import Data.Generics.Sum (_As) import Data.String (IsString(..)) import Data.Text (Text) import GHC.Generics (Generic) import Grace.Domain (Domain) import Grace.Existential (Existential) import Grace.Pretty (Pretty(..), builtin, keyword, label, operator, punctuation) import Language.Haskell.TH.Syntax (Lift) import Prelude hiding (lines) import Prettyprinter (Doc) import Prettyprinter.Render.Terminal (AnsiStyle) import Grace.Monotype (Monotype, RemainingAlternatives(..), RemainingFields(..), Scalar(..)) import qualified Control.Lens as Lens import qualified Data.List as List import qualified Data.Text as Text import qualified Grace.Domain as Domain import qualified Grace.Label as Label import qualified Grace.Monotype as Monotype import qualified Prettyprinter as Pretty {- $setup >>> :set -XOverloadedStrings >>> :set -XTypeApplications -} -- | A potentially polymorphic type data Type s = VariableType { location :: s, name :: Text } -- ^ Type variable -- -- >>> pretty @(Type ()) (VariableType () "a") -- a | UnsolvedType { location :: s, existential :: Existential Monotype } -- ^ A placeholder variable whose type has not yet been inferred -- -- >>> pretty @(Type ()) (UnsolvedType () 0) -- a? | Forall { location :: s, nameLocation :: s, name :: Text, domain :: Domain, type_ :: Type s } -- ^ Universally quantified type -- -- >>> pretty @(Type ()) (Forall () () "a" Domain.Type "a") -- forall (a : Type) . a | Function { location :: s, input :: Type s, output :: Type s } -- ^ Function type -- -- >>> pretty @(Type ()) (Function () "a" "b") -- a -> b | Optional { location :: s, type_ :: Type s } -- ^ Optional type -- -- >>> pretty @(Type ()) (Optional () "a") -- Optional a | List { location :: s, type_ :: Type s } -- ^ List type -- -- >>> pretty @(Type ()) (List () "a") -- List a | Record { location :: s, fields :: Record s } -- ^ Record type -- -- >>> pretty @(Type ()) (Record () (Fields [("x", "X"), ("y", "Y")] Monotype.EmptyFields)) -- { x: X, y: Y } -- >>> pretty @(Type ()) (Record () (Fields [("x", "X"), ("y", "Y")] (Monotype.UnsolvedFields 0))) -- { x: X, y: Y, a? } | Union { location :: s, alternatives :: Union s } -- ^ Union type -- -- >>> pretty @(Type ()) (Union () (Alternatives [("X", "X"), ("Y", "Y")] Monotype.EmptyAlternatives)) -- < X: X | Y: Y > -- >>> pretty @(Type ()) (Union () (Alternatives [("X", "X"), ("Y", "Y")] (Monotype.UnsolvedAlternatives 0))) -- < X: X | Y: Y | a? > | Scalar { location :: s, scalar :: Scalar } deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable) instance IsString (Type ()) where fromString string = VariableType{ name = fromString string, location = () } instance Pretty (Type s) where pretty = prettyQuantifiedType instance Plated (Type s) where plate onType type_ = case type_ of VariableType{..} -> do pure VariableType{..} UnsolvedType{..} -> do pure UnsolvedType{..} Forall{ type_ = oldType, .. } -> do newType <- onType oldType return Forall{ type_ = newType, .. } Function{ input = oldInput, output = oldOutput, .. } -> do newInput <- onType oldInput newOutput <- onType oldOutput return Function{ input = newInput, output = newOutput, .. } Optional{ type_ = oldType, .. } -> do newType <- onType oldType return Optional{ type_ = newType, .. } List{ type_ = oldType, .. } -> do newType <- onType oldType return List{ type_ = newType, .. } Record{ fields = Fields oldFieldTypes remainingFields, .. } -> do let onPair (field, oldType) = do newType <- onType oldType return (field, newType) newFieldTypes <- traverse onPair oldFieldTypes return Record{ fields = Fields newFieldTypes remainingFields, .. } Union{ alternatives = Alternatives oldAlternativeTypes remainingAlternatives, .. } -> do let onPair (alternative, oldType) = do newType <- onType oldType return (alternative, newType) newAlternativeTypes <- traverse onPair oldAlternativeTypes return Union{ alternatives = Alternatives newAlternativeTypes remainingAlternatives, .. } Scalar{..} -> do pure Scalar{..} -- | A potentially polymorphic record type data Record s = Fields [(Text, Type s)] RemainingFields deriving stock (Eq, Foldable, Functor, Generic, Lift, Show, Traversable) instance Pretty (Record s) where pretty = prettyRecordType -- | A potentially polymorphic union type data Union s = Alternatives [(Text, Type s)] RemainingAlternatives deriving stock (Eq, Functor, Foldable, Generic, Lift, Show, Traversable) instance Pretty (Union s) where pretty = prettyUnionType {-| This function should not be exported or generally used because it does not handle the `location` field correctly. It is only really safe to use within one of the @solve*@ functions -} fromMonotype :: Monotype -> Type () fromMonotype monotype = case monotype of Monotype.VariableType name -> VariableType{..} Monotype.UnsolvedType existential -> UnsolvedType{..} Monotype.Function input output -> Function{ input = fromMonotype input, output = fromMonotype output, .. } Monotype.Optional type_ -> Optional{ type_ = fromMonotype type_, .. } Monotype.List type_ -> List{ type_ = fromMonotype type_, .. } Monotype.Record (Monotype.Fields kτs ρ) -> Record{ fields = Fields (map (second fromMonotype) kτs) ρ, .. } Monotype.Union (Monotype.Alternatives kτs ρ) -> Union{ alternatives = Alternatives (map (second fromMonotype) kτs) ρ, .. } Monotype.Scalar scalar -> Scalar{..} where location = () instance Pretty Monotype where pretty = pretty . fromMonotype {-| Substitute a `Type` by replacing all occurrences of the given unsolved variable with a `Monotype` -} solveType :: Existential Monotype -> Monotype -> Type s -> Type s solveType unsolved monotype = Lens.transform transformType where transformType UnsolvedType{..} | unsolved == existential = fmap (\_ -> location) (fromMonotype monotype) transformType type_ = type_ {-| Substitute a `Type` by replacing all occurrences of the given unsolved fields variable with a t`Monotype.Record` -} solveFields :: Existential Monotype.Record -> Monotype.Record -> Type s -> Type s solveFields unsolved (Monotype.Fields fieldMonotypes fields) = Lens.transform transformType where transformType Record{ fields = Fields fieldTypes (UnsolvedFields existential), .. } | unsolved == existential = Record{ fields = Fields fieldTypes' fields, .. } where fieldTypes' = fieldTypes <> map transformPair fieldMonotypes transformPair (field, monotype) = (field, fmap (\_ -> location) (fromMonotype monotype)) transformType type_ = type_ {-| Substitute a `Type` by replacing all occurrences of the given unsolved alternatives variable with a t`Monotype.Union` -} solveAlternatives :: Existential Monotype.Union -> Monotype.Union -> Type s -> Type s solveAlternatives unsolved (Monotype.Alternatives alternativeMonotypes alternatives) = Lens.transform transformType where transformType Union{ alternatives = Alternatives alternativeTypes (UnsolvedAlternatives existential), .. } | unsolved == existential = Union{ alternatives = Alternatives alternativeTypes' alternatives, .. } where alternativeTypes' = alternativeTypes <> map transformPair alternativeMonotypes transformPair (alternative, monotype) = (alternative, fmap (\_ -> location) (fromMonotype monotype)) transformType type_ = type_ {-| Replace all occurrences of a variable within one `Type` with another `Type`, given the variable's label and index -} substituteType :: Text -> Int -> Type s -> Type s -> Type s substituteType a n _A type_ = case type_ of VariableType{..} | a == name && n == 0 -> _A | otherwise -> VariableType{..} UnsolvedType{..} -> UnsolvedType{..} Forall{ type_ = oldType, .. } -> Forall{ type_ = newType, .. } where newType = substituteType a n' _A oldType n' | a == name && domain == Domain.Type = n + 1 | otherwise = n Function{ input = oldInput, output = oldOutput, .. } -> Function{ input = newInput, output = newOutput, .. } where newInput = substituteType a n _A oldInput newOutput = substituteType a n _A oldOutput Optional{ type_ = oldType, .. } -> Optional{ type_ = newType, .. } where newType = substituteType a n _A oldType List{ type_ = oldType, .. } -> List{ type_ = newType, .. } where newType = substituteType a n _A oldType Record{ fields = Fields kAs ρ, .. } -> Record{ fields = Fields (map (second (substituteType a n _A)) kAs) ρ, .. } Union{ alternatives = Alternatives kAs ρ, .. } -> Union{ alternatives = Alternatives (map (second (substituteType a n _A)) kAs) ρ, .. } Scalar{..} -> Scalar{..} {-| Replace all occurrences of a variable within one `Type` with another `Type`, given the variable's label and index -} substituteFields :: Text -> Int -> Record s -> Type s -> Type s substituteFields ρ0 n r@(Fields kτs ρ1) type_ = case type_ of VariableType{..} -> VariableType{..} UnsolvedType{..} -> UnsolvedType{..} Forall{ type_ = oldType, .. } -> Forall{ type_ = newType, .. } where newType = substituteFields ρ0 n' r oldType n' | ρ0 == name && domain == Domain.Fields = n + 1 | otherwise = n Function{ input = oldInput, output = oldOutput, .. } -> Function{ input = newInput, output = newOutput, .. } where newInput = substituteFields ρ0 n r oldInput newOutput = substituteFields ρ0 n r oldOutput Optional{ type_ = oldType, .. } -> Optional{ type_ = newType, .. } where newType = substituteFields ρ0 n r oldType List{ type_ = oldType, .. } -> List{ type_ = newType, .. } where newType = substituteFields ρ0 n r oldType Record{ fields = Fields kAs0 ρ, .. } | VariableFields ρ0 == ρ && n == 0 -> Record{ fields = Fields (map (second (substituteFields ρ0 n r)) kAs1) ρ1, .. } | otherwise -> Record{ fields = Fields (map (second (substituteFields ρ0 n r)) kAs0) ρ, .. } where kAs1 = kAs0 <> map (second (fmap (\_ -> location))) kτs Union{ alternatives = Alternatives kAs ρ, .. } -> Union{ alternatives = Alternatives (map (second (substituteFields ρ0 n r)) kAs) ρ, .. } Scalar{..} -> Scalar{..} {-| Replace all occurrences of a variable within one `Type` with another `Type`, given the variable's label and index -} substituteAlternatives :: Text -> Int -> Union s -> Type s -> Type s substituteAlternatives ρ0 n r@(Alternatives kτs ρ1) type_ = case type_ of VariableType{..} -> VariableType{..} UnsolvedType{..} -> UnsolvedType{..} Forall{ type_ = oldType, .. } -> Forall{ type_ = newType, .. } where newType = substituteAlternatives ρ0 n' r oldType n' | ρ0 == name && domain == Domain.Alternatives = n + 1 | otherwise = n Function{ input = oldInput, output = oldOutput, .. } -> Function{ input = newInput, output = newOutput, .. } where newInput = substituteAlternatives ρ0 n r oldInput newOutput = substituteAlternatives ρ0 n r oldOutput Optional{ type_ = oldType, .. } -> Optional{ type_ = newType, .. } where newType = substituteAlternatives ρ0 n r oldType List{ type_ = oldType, .. } -> List{ type_ = newType, .. } where newType = substituteAlternatives ρ0 n r oldType Record{ fields = Fields kAs ρ, .. } -> Record{ fields = Fields (map (second (substituteAlternatives ρ0 n r)) kAs) ρ, .. } Union{ alternatives = Alternatives kAs0 ρ, .. } | Monotype.VariableAlternatives ρ0 == ρ && n == 0 -> Union{ alternatives = Alternatives (map (second (substituteAlternatives ρ0 n r)) kAs1) ρ1, .. } | otherwise -> Union{ alternatives = Alternatives (map (second (substituteAlternatives ρ0 n r)) kAs0) ρ, .. } where kAs1 = kAs0 <> map (second (fmap (\_ -> location))) kτs Scalar{..} -> Scalar{..} {-| Count how many times the given `Existential` `Type` variable appears within a `Type` -} typeFreeIn :: Existential Monotype -> Type s -> Bool typeFreeIn unsolved = Lens.has ( Lens.cosmos . _As @"UnsolvedType" . the @2 . Lens.only unsolved ) {-| Count how many times the given `Existential` t`Monotype.Record` variable appears within a `Type` -} fieldsFreeIn :: Existential Monotype.Record -> Type s -> Bool fieldsFreeIn unsolved = Lens.has ( Lens.cosmos . _As @"Record" . the @2 . the @2 . _As @"UnsolvedFields" . Lens.only unsolved ) {-| Count how many times the given `Existential` t`Monotype.Union` variable appears within a `Type` -} alternativesFreeIn :: Existential Monotype.Union -> Type s -> Bool alternativesFreeIn unsolved = Lens.has ( Lens.cosmos . _As @"Union" . the @2 . the @2 . _As @"UnsolvedAlternatives" . Lens.only unsolved ) -- | Default unsolved type variables defaultTo :: Type s -> Type s -> Type s defaultTo type₀ = Lens.transform transformation where transformation UnsolvedType{ } = type₀ transformation type₁ = type₁ prettyQuantifiedType :: Type s -> Doc AnsiStyle prettyQuantifiedType type0@Forall{} = Pretty.group (Pretty.flatAlt long short) where short = prettyShort (keyword "forall" <> " ") type0 long = prettyLong type0 prettyShort prefix Forall{..} = prefix <> punctuation "(" <> label (pretty name) <> " " <> punctuation ":" <> " " <> pretty domain <> punctuation ")" <> " " <> prettyShort "" type_ prettyShort _prefix _A = punctuation "." <> " " <> prettyFunctionType _A prettyLong Forall{..} = keyword "forall" <> " " <> punctuation "(" <> label (pretty name) <> " " <> punctuation ":" <> " " <> pretty domain <> punctuation ")" <> " " <> punctuation "." <> Pretty.hardline <> prettyLong type_ prettyLong _A = " " <> Pretty.nest 2 (prettyFunctionType _A) prettyQuantifiedType other = prettyFunctionType other prettyFunctionType :: Type s -> Doc AnsiStyle prettyFunctionType type_@Function{} = Pretty.group (Pretty.flatAlt long short) where long = prettyLong type_ short = prettyShort type_ prettyShort Function{..} = prettyApplicationType input <> " " <> punctuation "->" <> " " <> prettyShort output prettyShort _A = prettyApplicationType _A prettyLong Function{..} = prettyApplicationType input <> " " <> punctuation "->" <> Pretty.hardline <> prettyLong output prettyLong _A = " " <> Pretty.nest 2 (prettyApplicationType _A) prettyFunctionType other = prettyApplicationType other prettyApplicationType :: Type s -> Doc AnsiStyle prettyApplicationType Optional{..} = Pretty.group (Pretty.flatAlt long short) where short = builtin "Optional" <> " " <> prettyPrimitiveType type_ long = builtin "Optional" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyPrimitiveType type_) prettyApplicationType List{..} = Pretty.group (Pretty.flatAlt long short) where short = builtin "List" <> " " <> prettyPrimitiveType type_ long = builtin "List" <> Pretty.hardline <> " " <> Pretty.nest 2 (prettyPrimitiveType type_) prettyApplicationType other = prettyPrimitiveType other prettyPrimitiveType :: Type s -> Doc AnsiStyle prettyPrimitiveType VariableType{..} = label (pretty name) prettyPrimitiveType UnsolvedType{..} = label (pretty existential <> "?") prettyPrimitiveType Record{..} = prettyRecordType fields prettyPrimitiveType Union{..} = prettyUnionType alternatives prettyPrimitiveType Scalar{..} = pretty scalar prettyPrimitiveType other = Pretty.group (Pretty.flatAlt long short) where short = punctuation "(" <> prettyQuantifiedType other <> punctuation ")" long = punctuation "(" <> " " <> Pretty.nest 2 (prettyQuantifiedType other) <> Pretty.hardline <> punctuation ")" prettyRecordType :: Record s -> Doc AnsiStyle prettyRecordType (Fields [] fields) = punctuation "{" <> (case fields of EmptyFields -> " " UnsolvedFields ρ -> " " <> label (pretty ρ <> "?") <> " " VariableFields ρ -> " " <> label (pretty ρ) <> " " ) <> punctuation "}" prettyRecordType (Fields (keyType : keyTypes) fields) = Pretty.group (Pretty.flatAlt long short) where short = punctuation "{" <> " " <> prettyShortFieldType keyType <> foldMap (\ft -> punctuation "," <> " " <> prettyShortFieldType ft) keyTypes <> (case fields of EmptyFields -> mempty UnsolvedFields ρ -> punctuation "," <> " " <> label (pretty ρ <> "?") VariableFields ρ -> punctuation "," <> " " <> label (pretty ρ) ) <> " " <> punctuation "}" long = punctuation "{" <> " " <> prettyLongFieldType keyType <> foldMap (\ft -> punctuation "," <> " " <> prettyLongFieldType ft) keyTypes <> case fields of EmptyFields -> punctuation "}" UnsolvedFields ρ -> punctuation "," <> " " <> label (pretty ρ <> "?") <> Pretty.hardline <> punctuation "}" VariableFields ρ -> punctuation "," <> " " <> label (pretty ρ) <> Pretty.hardline <> punctuation "}" prettyShortFieldType :: (Text, Type s) -> Doc AnsiStyle prettyShortFieldType (key, type_) = prettyRecordLabel False key <> operator ":" <> " " <> prettyQuantifiedType type_ prettyLongFieldType :: (Text, Type s) -> Doc AnsiStyle prettyLongFieldType (key, type_) = prettyRecordLabel False key <> operator ":" <> Pretty.hardline <> " " <> Pretty.nest 4 (prettyQuantifiedType type_) <> Pretty.hardline prettyUnionType :: Union s -> Doc AnsiStyle prettyUnionType (Alternatives [] alternatives) = punctuation "<" <> (case alternatives of EmptyAlternatives -> " " UnsolvedAlternatives ρ -> " " <> label (pretty ρ <> "?") <> " " VariableAlternatives ρ -> " " <> label (pretty ρ) <> " " ) <> punctuation ">" prettyUnionType (Alternatives (keyType : keyTypes) alternatives) = Pretty.group (Pretty.flatAlt long short) where short = punctuation "<" <> " " <> prettyShortAlternativeType keyType <> foldMap (\kt -> " " <> punctuation "|" <> " " <> prettyShortAlternativeType kt) keyTypes <> (case alternatives of EmptyAlternatives -> mempty UnsolvedAlternatives ρ -> " " <> punctuation "|" <> " " <> label (pretty ρ <> "?") VariableAlternatives ρ -> " " <> punctuation "|" <> " " <> label (pretty ρ) ) <> " " <> punctuation ">" long = punctuation "<" <> " " <> prettyLongAlternativeType keyType <> foldMap (\kt -> punctuation "|" <> " " <> prettyLongAlternativeType kt) keyTypes <> case alternatives of EmptyAlternatives -> punctuation ">" UnsolvedAlternatives ρ -> punctuation "|" <> " " <> label (pretty ρ <> "?") <> Pretty.hardline <> punctuation ">" VariableAlternatives ρ -> punctuation "|" <> " " <> label (pretty ρ) <> Pretty.hardline <> punctuation ">" prettyShortAlternativeType (key, type_) = prettyAlternativeLabel key <> operator ":" <> " " <> prettyQuantifiedType type_ prettyLongAlternativeType (key, type_) = prettyAlternativeLabel key <> operator ":" <> Pretty.hardline <> " " <> Pretty.nest 4 (prettyQuantifiedType type_) <> Pretty.hardline -- | Pretty-print a @Text@ literal prettyTextLiteral :: Text -> Doc AnsiStyle prettyTextLiteral text = "\"" <> prettyTextBody False text <> "\"" -- | Pretty-print the body of a @Text@ literal prettyTextBody :: Bool -- ^ Is this a multiline string literal -> Text -> Doc AnsiStyle prettyTextBody False text = ( pretty . Text.replace "\"" "\\\"" . Text.replace "\b" "\\b" . Text.replace "\f" "\\f" . Text.replace "\n" "\\n" . Text.replace "\r" "\\r" . Text.replace "\t" "\\t" . Text.replace "\\" "\\\\" ) text prettyTextBody True text = mconcat (List.intersperse Pretty.hardline (map ( pretty . Text.replace "\"" "\\\"" . Text.replace "\b" "\\b" . Text.replace "\f" "\\f" . Text.replace "\r" "\\r" . Text.replace "\\" "\\\\" ) lines ) ) where lines = Text.splitOn "\n" text -- | Pretty-print a quoted alternative prettyQuotedAlternative :: Text -> Doc AnsiStyle prettyQuotedAlternative text = "'" <> ( pretty . Text.replace "'" "\\\'" . Text.replace "\b" "\\b" . Text.replace "\f" "\\f" . Text.replace "\n" "\\n" . Text.replace "\r" "\\r" . Text.replace "\t" "\\t" . Text.replace "\\" "\\\\" ) text <> "'" -- | Pretty-print a record label prettyRecordLabel :: Bool -- ^ Always quote the label if `True` -- -- This is mainly set to `True` when pretty-printing records so that the -- output is valid JSON -> Text -> Doc AnsiStyle prettyRecordLabel alwaysQuote field | Label.validRecordLabel field && not alwaysQuote = label (pretty field) | otherwise = label (prettyTextLiteral field) -- | Pretty-print an alternative label prettyAlternativeLabel :: Text -> Doc AnsiStyle prettyAlternativeLabel alternative | Label.validAlternativeLabel alternative = label (pretty alternative) | otherwise = label (prettyQuotedAlternative alternative) -- | Pretty-print a label prettyLabel :: Text -> Doc AnsiStyle prettyLabel name | Label.validLabel name = label (pretty name) | otherwise = punctuation "." <> label (prettyQuotedAlternative name) ================================================ FILE: src/Grace/Value.hs ================================================ {-# LANGUAGE OverloadedLists #-} {-| This module contains the `Value` type used internally for efficient evaluation of expressions -} module Grace.Value ( -- * Types Names(..) , Value(..) , location -- * Utilities , quote , fromJSON , toJSON , syntax , complete , effects ) where import Control.Applicative (empty) import Control.Lens (Getting, Plated(..), Traversal') import Data.Aeson (FromJSON(..)) import Data.Bifunctor (first) import Data.Foldable (toList) import Data.Generics.Sum (_As) import Data.Generics.Product (the) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (Any) import Data.Sequence (Seq) import Data.Text (Text) import Data.Void (Void) import GHC.Generics (Generic) import Grace.Context (Context) import Grace.Pretty (Pretty(..)) import Grace.Syntax (Builtin, Scalar, Syntax) import qualified Control.Lens as Lens import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict.InsOrd as HashMap import qualified Data.Sequence as Seq import qualified Grace.Compat as Compat import qualified Grace.Syntax as Syntax {-| This is basically `Syntax.NameBinding` but with only the names and not the values or locations -} data Names location = Name location Text (Maybe (Value location)) | FieldNames location [(location, Text, Maybe (Value location))] deriving stock (Eq, Functor, Show) {-| This type represents a fully evaluated expression with no reducible sub-expressions There are two benefits to using a type separate from the surface syntax for this purpose: * To avoid wastefully reducing the same sub-expression multiple times * To use a more efficient representation for reduction purposes -} data Value location = Lambda location [(Text, Value location)] (Names location) (Syntax location Void) -- The `Lambda` constructor captures the environment at the time it is -- evaluated, so that evaluation can be lazily deferred until the function -- input is known. This is essentially the key optimization that powers -- the fast normalization-by-evaluation algorithm. | Application location (Value location) (Value location) | List location (Seq (Value location)) | Record location (InsOrdHashMap Text (location, Value location)) | Alternative location Text (Value location) | Fold location (Value location) | Text location Text | Builtin location Builtin | Scalar location Scalar deriving stock (Eq, Generic, Show) location :: Value location -> location location (Lambda l _ _ _) = l location (Application l _ _) = l location (List l _) = l location (Record l _) = l location (Alternative l _ _) = l location (Fold l _) = l location (Text l _) = l location (Builtin l _) = l location (Scalar l _) = l instance Functor Value where fmap f (Lambda location₀ environment names body) = Lambda (f location₀) (fmap (fmap (fmap f)) environment) (fmap f names) (first f body) fmap f (Application location₀ function argument) = Application (f location₀) (fmap f function) (fmap f argument) fmap f (List location₀ elements) = List (f location₀) (fmap (fmap f) elements) fmap f (Record location₀ fieldValues) = Record (f location₀) (fmap adapt fieldValues) where adapt (location₁, value) = (f location₁, fmap f value) fmap f (Alternative location₀ text argument) = Alternative (f location₀) text (fmap f argument) fmap f (Fold location₀ handlers) = Fold (f location₀) (fmap f handlers) fmap f (Text location₀ text) = Text (f location₀) text fmap f (Builtin location₀ builtin) = Builtin (f location₀) builtin fmap f (Scalar location₀ scalar) = Scalar (f location₀) scalar instance Plated (Value location₀) where plate onValue value = case value of Lambda location₀ environment names body -> do pure (Lambda location₀ environment names body) Application location₀ function argument -> do newFunction <- onValue function newArgument <- onValue argument return (Application location₀ newFunction newArgument) List location₀ elements -> do newElements <- traverse onValue elements return (List location₀ newElements) Record location₀ fieldValues -> do let onElement (location₁, value₁) = do newValue <- onValue value₁ return (location₁, newValue) newFieldValues <- traverse onElement fieldValues return (Record location₀ newFieldValues) Alternative location₀ text argument -> do newArgument <- onValue argument pure (Alternative location₀ text newArgument) Fold location₀ handlers -> do newHandlers <- onValue handlers return (Fold location₀ newHandlers) Text location₀ text -> do pure (Text location₀ text) Builtin location₀ builtin -> do pure (Builtin location₀ builtin) Scalar location₀ scalar -> do pure (Scalar location₀ scalar) instance FromJSON (Value ()) where parseJSON value = pure (fromJSON value) instance Pretty (Value s) where pretty value = pretty (quote value) -- | Convert a `Value` back into the surface `Syntax` quote :: Value location -> Syntax location Void quote value = case value of Lambda location₀ env names_ body₀ -> foldl snoc newLambda env where binding = case names_ of Name nameLocation name assignment -> Syntax.PlainBinding { plain = Syntax.NameBinding { nameLocation , name , annotation = Nothing , assignment = fmap quote assignment } } FieldNames fieldNamesLocation fieldNames -> Syntax.RecordBinding { fieldNamesLocation , fieldNames = do (nameLocation, name, assignment) <- fieldNames return Syntax.NameBinding { nameLocation , name , annotation = Nothing , assignment = fmap quote assignment } } newLambda = Syntax.Lambda { location = location₀ , binding , body = body₀ } toBinding n v = Syntax.Define { assignmentLocation = location₀ , definition = Syntax.Definition { name = n , nameLocation = location₀ , bindings = [] , annotation = Nothing , assignment = quote v } } snoc e@Syntax.Let{ assignments = a :| as, body = body₁ } (n, v) | Syntax.usedIn n e = Syntax.Let { location = location₀ , assignments = toBinding n v :| (a : as) , body = body₁ } | otherwise = e snoc e (n, v) | Syntax.usedIn n e = Syntax.Let { location = location₀ , assignments = toBinding n v :| [] , body = e } | otherwise = e Application location₀ function argument -> Syntax.Application { location = location₀ , function = quote function , argument = quote argument } List location₀ elements -> Syntax.List{ location = location₀, elements = fmap quote elements } Record location₀ fieldValues -> Syntax.Record { location = location₀ , fieldValues = map adapt (HashMap.toList fieldValues) } where adapt (field, (nameLocation, value_)) = Syntax.Definition { nameLocation , name = field , bindings = [] , annotation = Nothing , assignment = quote value_ } Alternative location₀ name argument -> Syntax.Alternative { location = location₀ , name , argument = quote argument } Fold location₀ handlers -> Syntax.Fold{ location = location₀, handlers = quote handlers } Text location₀ text -> Syntax.Text{ location = location₀, chunks = Syntax.Chunks text [] } Scalar location₀ scalar -> Syntax.Scalar{ location = location₀, scalar } Builtin location₀ builtin -> Syntax.Builtin{ location = location₀, builtin } -- | Convert a JSON `Aeson.Value` to a `Value` fromJSON :: Aeson.Value -> Value () fromJSON (Aeson.Object object) = Record () (Compat.fromAesonMap (fmap adapt object)) where adapt json = ((), fromJSON json) fromJSON (Aeson.Array array) = List () (Seq.fromList (toList (fmap fromJSON array))) fromJSON (Aeson.String text) = Text () text fromJSON (Aeson.Number scientific) = Scalar () (Syntax.Real scientific) fromJSON (Aeson.Bool bool) = do Scalar () (Syntax.Bool bool) fromJSON Aeson.Null = Scalar () Syntax.Null -- | Convert a `Value` to the equivalent JSON `Aeson.Value` toJSON :: Value location -> Maybe Aeson.Value toJSON (Application _ (Builtin _ Syntax.Some) value) = do toJSON value toJSON (List _ elements) = do newElements <- traverse toJSON elements return (Aeson.toJSON newElements) toJSON (Record _ fieldValues) = do let adapt (_, value) = do toJSON value newFieldValues <- traverse adapt fieldValues return (Aeson.toJSON (Compat.toAesonMap newFieldValues)) toJSON (Text _ text) = do return (Aeson.toJSON text) toJSON (Scalar _ scalar) = do return (Aeson.toJSON scalar) toJSON _ = do empty -- | @Traversal'@ from a `Value` to a syntax :: Traversal' (Value location) (Syntax location Void) syntax = _As @"Lambda" . the @4 -- | Complete all `Type` annotations in a `Value` using the provided -- `Context` complete :: Context location -> Value location -> Value location complete context = Lens.transform (Lens.over syntax (Syntax.complete context)) -- | Determines whether the `Value` has an effect effects :: Getting Any (Value location) () effects = Lens.cosmos . syntax . Syntax.effects ================================================ FILE: src/Grace.hs ================================================ {-| This module contains the top-level `main` function that implements the command-line API -} module Grace ( -- * Main main ) where import Control.Applicative (many, (<|>)) import Control.Exception.Safe (Exception(..), SomeException) import Data.Foldable (traverse_) import Data.Void (Void) import Grace.Input (Input(..), Mode(..)) import Grace.Location (Location(..)) import Grace.Monad (Status(..)) import Grace.Syntax (Builtin(..), Syntax(..)) import Grace.Type (Type(..)) import Options.Applicative (Parser, ParserInfo) import Prettyprinter (Doc) import Prettyprinter.Render.Terminal (AnsiStyle) import qualified Control.Exception.Safe as Exception import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified GHC.IO.Encoding import qualified Grace.Infer as Infer import qualified Grace.Interpret as Interpret import qualified Grace.Monad as Grace import qualified Grace.Monotype as Monotype import qualified Grace.Normalize as Normalize import qualified Grace.Parser as Parser import qualified Grace.Pretty import qualified Grace.REPL as REPL import qualified Grace.Syntax as Syntax import qualified Grace.Type as Type import qualified Grace.Value as Value import qualified Grace.Width as Width import qualified Options.Applicative as Options import qualified Prettyprinter as Pretty import qualified System.Console.ANSI as ANSI import qualified System.Exit as Exit import qualified System.IO as IO data Highlight = Color -- ^ Force the use of ANSI color escape sequences to highlight source code | Plain -- ^ Don't highlight source code | Auto -- ^ Auto-detect whether to highlight source code based on whether or not -- @stdout@ is a terminal data Options = Interpret { annotate :: Bool , highlight :: Highlight , file :: FilePath } | Text { file :: FilePath } | Format { highlight :: Highlight, files :: [FilePath] } | Builtins { highlight :: Highlight } | REPL parserInfo :: ParserInfo Options parserInfo = Options.info (Options.helper <*> parser) (Options.progDesc "Command-line utility for the Grace language") parser :: Parser Options parser = do let interpret = do annotate <- Options.switch ( Options.long "annotate" <> Options.help "Add a type annotation for the inferred type" ) file <- Options.strArgument ( Options.help "File to interpret" <> Options.metavar "FILE" ) highlight <- parseHighlight return Interpret{ annotate, file, highlight } let text = do file <- Options.strArgument ( Options.help "File to interpret" <> Options.metavar "FILE" ) return Grace.Text{ file } let format = do let parseFile = Options.strArgument ( Options.help "File to format" <> Options.metavar "FILE" ) highlight <- parseHighlight files <- many parseFile return Format{ highlight, files } let builtins = do highlight <- parseHighlight return Builtins{ highlight } let repl = do pure REPL{ } Options.hsubparser ( Options.command "interpret" (Options.info interpret (Options.progDesc "Interpret a Grace file") ) <> Options.command "text" (Options.info text (Options.progDesc "Render a Grace text literal") ) <> Options.command "format" (Options.info format (Options.progDesc "Format Grace code") ) <> Options.command "builtins" (Options.info builtins (Options.progDesc "List all built-in functions and their types") ) <> Options.command "repl" (Options.info repl (Options.progDesc "Enter a REPL for Grace") ) ) where parseHighlight = Options.flag' Color ( Options.long "color" <> Options.help "Enable syntax highlighting" ) <|> Options.flag' Plain ( Options.long "plain" <> Options.help "Disable syntax highlighting" ) <|> pure Auto detectColor :: Highlight -> IO Bool detectColor Color = do return True detectColor Plain = do return False detectColor Auto = do ANSI.hSupportsANSI IO.stdout getRender :: Highlight -> IO (Doc AnsiStyle -> IO ()) getRender highlight = do color <- detectColor highlight width <- Width.getWidth return (Grace.Pretty.renderIO color width IO.stdout) throws :: Exception e => Either e a -> IO a throws (Left e) = do Text.IO.hPutStrLn IO.stderr (Text.pack (displayException e)) Exit.exitFailure throws (Right result) = do return result -- | Command-line entrypoint main :: IO () main = Exception.handle handler do GHC.IO.Encoding.setLocaleEncoding IO.utf8 options <- Options.execParser parserInfo case options of Interpret{ annotate, highlight, file } -> do input <- case file of "-" -> do Code "(input)" <$> Text.IO.getContents _ -> do return (Path file AsCode) (inferred, value) <- Interpret.interpret input let syntax = Normalize.strip (Value.quote value) let annotatedExpression | annotate = Annotation { annotated = syntax , annotation = inferred , location = Syntax.location syntax } | otherwise = syntax render <- getRender highlight render (Grace.Pretty.pretty annotatedExpression <> Pretty.hardline) Grace.Text{ file } -> do input <- case file of "-" -> do Code "(input)" <$> Text.IO.getContents _ -> do return (Path file AsCode) let location = Location { name = "(input)" , code = "… : Text" , offset = 4 } let expected = Type.Scalar{ scalar = Monotype.Text, location } let initialStatus = Status{ count = 0, context = [] } (_, value) <- Grace.evalGrace input initialStatus (Interpret.interpretWith [] (Just expected)) case value of Value.Text _ text -> Text.IO.putStr text _ -> do Text.IO.hPutStrLn IO.stderr "Internal error: Not a plain Text literal\n\ \\n\ \The input expression did not evaluate to a Text literal, even though it had the\n\ \correct type" Exit.exitFailure Format{ highlight, files } -> do case files of [ "-" ] -> do text <- Text.IO.getContents syntax <- throws (Parser.parse "(input)" text) render <- getRender highlight render (Grace.Pretty.pretty syntax <> Pretty.hardline) _ -> do let formatFile file = do text <- Text.IO.readFile file syntax <- throws (Parser.parse file text) IO.withFile file IO.WriteMode \handle -> do Grace.Pretty.renderIO False Width.defaultWidth handle (Grace.Pretty.pretty syntax <> Pretty.hardline) traverse_ formatFile files Builtins{ highlight } -> do let displayBuiltin :: Builtin -> IO () displayBuiltin builtin = do let code = Grace.Pretty.renderStrict False Width.defaultWidth (Grace.Pretty.pretty builtin) let expression = Syntax.Builtin { location = Location { name = "(input)", code, offset = 0 } , builtin } let input = Code "(input)" code (type_, _) <- Infer.typeOf input expression let annotated :: Syntax Location Void annotated = Annotation { annotated = expression , annotation = type_ , location = Syntax.location expression } render <- getRender highlight render (Grace.Pretty.pretty annotated <> Pretty.hardline) let builtins = [ minBound .. maxBound ] case builtins of [] -> do return () b0 : bs -> do displayBuiltin b0 traverse_ (\b -> Text.IO.putStrLn "" >> displayBuiltin b) bs REPL{ } -> do REPL.repl where handler :: SomeException -> IO a handler e = do Text.IO.hPutStrLn IO.stderr (Text.pack (displayException e)) Exit.exitFailure ================================================ FILE: tasty/Main.hs ================================================ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Control.Exception.Safe (Exception, SomeException) import Data.Aeson (Value) import Data.Int (Int8, Int16, Int32, Int64) import Data.Scientific (Scientific) import Data.Sequence (Seq) import Data.Text (Text) import Data.Word (Word8, Word16, Word32, Word64) import GHC.Generics (Generic) import Grace.Decode (FromGrace, Key, ToGraceType) import Grace.Input (Input(..), Mode(..)) import Grace.Location (Location(..)) import Grace.Pretty (Pretty(..)) import Grace.Type (Type(..)) import Numeric.Natural (Natural) import System.FilePath (()) import Test.Tasty (TestTree) import qualified Control.Exception.Safe as Exception import qualified Data.Aeson as Aeson import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Vector as Vector import qualified Grace.Decode as Decode import qualified Grace.Interpret as Interpret import qualified Grace.Monotype as Monotype import qualified Grace.Pretty import qualified Grace.Syntax as Syntax import qualified Grace.Type as Type import qualified Grace.Value as Value import qualified Grace.Width as Width import qualified Prettyprinter as Pretty import qualified System.Directory as Directory import qualified System.Environment as Environment import qualified System.FilePath as FilePath import qualified System.Timeout as Timeout import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty.HUnit import qualified Test.Tasty.Silver as Silver pretty_ :: Pretty a => a -> Text pretty_ x = Grace.Pretty.renderStrict False Width.defaultWidth (pretty x <> Pretty.hardline) interpret :: Input -> IO (Either SomeException (Type Location, Value.Value ())) interpret input = fmap (fmap (fmap (fmap (\_ -> ())))) (Exception.try (Interpret.interpret input)) throws :: Exception e => IO (Either e a) -> IO a throws io = do result <- io case result of Left e -> Exception.throw e Right a -> return a fileToTestTree :: FilePath -> IO TestTree fileToTestTree prefix = do let input = prefix <> "-input.ffg" let expectedTypeFile = prefix <> "-type.ffg" let expectedOutputFile = prefix <> "-output.ffg" let expectedStderrFile = prefix <> "-stderr.txt" let name = FilePath.takeBaseName input result <- Timeout.timeout 10000000 (interpret (Path input AsCode)) case result of Nothing -> do return (Tasty.testGroup name [ Silver.goldenVsAction (name <> " - timeout") expectedStderrFile (return "timeout") id ] ) Just (Left e) -> do return (Tasty.testGroup name [ Silver.goldenVsAction (name <> " - error") expectedStderrFile (return (Text.pack (Exception.displayException e))) id ] ) Just (Right (inferred, value)) -> do let generateTypeFile = return (pretty_ inferred) let generateOutputFile = return (pretty_ value) return (Tasty.testGroup name [ Silver.goldenVsAction (name <> " - type") expectedTypeFile generateTypeFile id , Silver.goldenVsAction (name <> " - output") expectedOutputFile generateOutputFile id ] ) inputFileToPrefix :: FilePath -> Maybe FilePath inputFileToPrefix inputFile = fmap Text.unpack (Text.stripSuffix "-input.ffg" (Text.pack inputFile)) directoryToTestTree :: FilePath -> IO TestTree directoryToTestTree directory = do let name = FilePath.takeBaseName directory children <- Directory.listDirectory directory let process child = do let childPath = directory child isDirectory <- Directory.doesDirectoryExist childPath if isDirectory then do testTree <- directoryToTestTree childPath return [ testTree ] else do case inputFileToPrefix childPath of Just prefix -> do testTree <- fileToTestTree prefix return [ testTree ] Nothing -> do return [ ] testTreess <- traverse process children return (Tasty.testGroup name (concat testTreess)) data T0 = C0 | C1{ foo :: Text } | C2{ bar :: Natural, baz :: Maybe Bool } | C3{ a :: Maybe Int, b :: Maybe Int, c :: Maybe Int } | C4{ a :: Maybe Int, b :: Maybe Int, c :: Maybe Int, d :: Maybe Int } deriving stock (Eq, Generic, Show) deriving anyclass (FromGrace, ToGraceType) data T1 deriving stock (Generic) deriving anyclass (FromGrace, ToGraceType) main :: IO () main = do autogeneratedTestTree <- directoryToTestTree "tasty/data" let manualTestTree = Tasty.testGroup "Manual tests" [ interpretCode , interpretCodeWithEnvURI , interpretCodeWithFileURI , interpretCodeWithImport , decodeWithTypeError , decodeWithRangeError , loadSuccessfully , load "()" "{ }" () , load "(Bool, Bool)" "{ \"0\": false, \"1\": true }" (False, True) , load "(Bool, Bool)" "{ \"0\": false, \"1\": true }" (False, True) , load "Either Int Bool" "Left 2" (Left 2 :: Either Int Bool) , load "Either Int Bool" "Right true" (Right True :: Either Int Bool) , load "Either Int Bool" "Right true" (Right True :: Either Int Bool) , load "Int" "-2" (-2 :: Int) , load "Int8" "-2" (-2 :: Int8) , load "Int16" "-2" (-2 :: Int16) , load "Int32" "-2" (-2 :: Int32) , load "Int64" "-2" (-2 :: Int64) , load "Word" "2" (2 :: Word) , load "Word8" "2" (2 :: Word8) , load "Word16" "2" (2 :: Word16) , load "Word32" "2" (2 :: Word32) , load "Word64" "2" (2 :: Word64) , load "Natural" "2" (2 :: Natural) , load "Integer" "2" (2 :: Integer) , load "Integer" "+2" (2 :: Integer) , load "Scientific" "2" (2.0 :: Scientific) , load "Scientific" "+2" (2.0 :: Scientific) , load "Scientific" "2.5" (2.5 :: Scientific) , load "Double" "2.5" (2.5 :: Double) , load "Float" "2.5" (2.5 :: Float) , load "Text" "\"abc\"" ("abc" :: Text) , load "Lazy Text" "\"abc\"" ("abc" :: Text.Lazy.Text) , load "String" "\"abc\"" ("abc" :: String) , load "Key" "\"abc\"" ("abc" :: Key) , load "Value" "null" Aeson.Null , load "Seq Bool" "[ false, true ]" (Seq.fromList [ False, True ]) , load "Vector Bool" "[ false, true ]" (Vector.fromList [ False, True ]) , load "T0" "C0{ }" C0{ } , load "T0" "C1{ foo: \"abc\" }" C1{ foo = "abc" } , load "T0" "C2{ bar: 2 }" C2{ bar = 2, baz = Nothing } , load "T0" "C2{ bar: 3, baz: true }" C2{ bar = 3, baz = Just True } , load "T0" "C3{ }" C3{ a = Nothing, b = Nothing, c = Nothing } , load "T0" "C4{ }" C4{ a = Nothing, b = Nothing, c = Nothing, d = Nothing } ] let tests = Tasty.testGroup "Tests" [ autogeneratedTestTree, manualTestTree ] Tasty.defaultMain tests interpretCode :: TestTree interpretCode = Tasty.HUnit.testCase "interpret code" do actualValue <- throws (interpret (Code "(input)" "2 + 2")) let expectedValue = (Type.Scalar{ location, scalar = Monotype.Natural }, Value.Scalar () (Syntax.Natural 4)) where location = Location{ name = "(input)", code = "2 + 2", offset = 2 } Tasty.HUnit.assertEqual "" expectedValue actualValue interpretCodeWithImport :: TestTree interpretCodeWithImport = Tasty.HUnit.testCase "interpret code with import from file" do actualValue <- throws (interpret (Code "(input)" "./tasty/data/unit/plus-input.ffg")) let expectedValue = (Type.Scalar{ location, scalar = Monotype.Natural }, Value.Scalar () (Syntax.Natural 5)) where location = Location{ name = "./tasty/data/unit/plus-input.ffg", code = "2 + 3\n", offset = 2 } Tasty.HUnit.assertEqual "" expectedValue actualValue interpretCodeWithEnvURI :: TestTree interpretCodeWithEnvURI = Tasty.HUnit.testCase "interpret code with env: import" do let key = "GRACE_TEST_VAR" let name = "env:" <> key let open = do m <- Environment.lookupEnv key Environment.setEnv key "true" return m let close Nothing = Environment.unsetEnv key close (Just v ) = Environment.setEnv key v actualValue <- Exception.bracket open close \_ -> do throws (interpret (Code "(input)" (Text.pack name))) let expectedValue = (Type.Scalar{ location, scalar = Monotype.Bool }, Value.Scalar () (Syntax.Bool True)) where location = Location{ name, code = "true", offset = 0 } Tasty.HUnit.assertEqual "" expectedValue actualValue interpretCodeWithFileURI :: TestTree interpretCodeWithFileURI = Tasty.HUnit.testCase "interpret code with file:// import" do absolute <- Directory.makeAbsolute "./tasty/data/true.ffg" let uri = "file://" <> absolute actualValue <- throws (interpret (Code "(input)" (Text.pack uri))) let expectedValue = (Type.Scalar{ location, scalar = Monotype.Bool }, Value.Scalar () (Syntax.Bool True)) where location = Location{ name = absolute, code = "true\n", offset = 0 } Tasty.HUnit.assertEqual "" expectedValue actualValue loadSuccessfully :: TestTree loadSuccessfully = Tasty.HUnit.testCase "load code" do let actual :: Either DecodingError Natural actual = decode (Value.Scalar () (Syntax.Natural 2)) Tasty.HUnit.assertEqual "" (Right 2) actual load :: (Eq a, FromGrace a, Show a) => String -> Text -> a -> TestTree load name code expected = Tasty.HUnit.testCase ("load " <> name) do actual <- Interpret.load (Code "(input)" code) Tasty.HUnit.assertEqual "" expected actual data DecodingError = TypeError | RangeError deriving stock (Eq, Show) decode :: FromGrace a => Value.Value () -> Either DecodingError a decode value = case Decode.decode (fmap (\_ -> Unknown) value) of Left Decode.TypeError{ } -> Left TypeError Left Decode.RangeError{ } -> Left RangeError Right a -> Right a decodeWithTypeError :: TestTree decodeWithTypeError = Tasty.HUnit.testCase "load code with type error" do let actual₀ :: Either DecodingError Bool actual₀ = decode (Value.Scalar () (Syntax.Natural 2)) Tasty.HUnit.assertEqual "" (Left TypeError) actual₀ let actual₁ :: Either DecodingError T0 actual₁ = decode (Value.Alternative () "C1" (Value.Record () mempty)) Tasty.HUnit.assertEqual "" (Left TypeError) actual₁ let actual₂ :: Either DecodingError Natural actual₂ = decode (Value.Scalar () (Syntax.Bool False)) Tasty.HUnit.assertEqual "" (Left TypeError) actual₂ let actual₃ :: Either DecodingError Integer actual₃ = decode (Value.Scalar () (Syntax.Bool False)) Tasty.HUnit.assertEqual "" (Left TypeError) actual₃ let actual₄ :: Either DecodingError Text actual₄ = decode (Value.Scalar () (Syntax.Bool False)) Tasty.HUnit.assertEqual "" (Left TypeError) actual₄ let actual₅ :: Either DecodingError Key actual₅ = decode (Value.Scalar () (Syntax.Bool False)) Tasty.HUnit.assertEqual "" (Left TypeError) actual₅ let actual₆ :: Either DecodingError Value actual₆ = decode (Value.Lambda () [] (Value.Name () "x" Nothing) Syntax.Variable{ location = (), name = "x" }) Tasty.HUnit.assertEqual "" (Left TypeError) actual₆ let actual₇ :: Either DecodingError (Seq Bool) actual₇ = decode (Value.Scalar () (Syntax.Bool False)) Tasty.HUnit.assertEqual "" (Left TypeError) actual₇ let actual₈ :: Either DecodingError Scientific actual₈ = decode (Value.Scalar () (Syntax.Bool False)) Tasty.HUnit.assertEqual "" (Left TypeError) actual₈ decodeWithRangeError :: TestTree decodeWithRangeError = Tasty.HUnit.testCase "load code with range error" do let actual₀ :: Either DecodingError Word8 actual₀ = decode (Value.Scalar () (Syntax.Natural 256)) Tasty.HUnit.assertEqual "" (Left RangeError) actual₀ ================================================ FILE: tasty/data/complex/abstract-fold-input.ffg ================================================ # A `fold` with an abstract record of handlers will default to treating the # record as `List` handlers, meaning that the inferred type of this expression # will be: # # forall (a : Type) (b : Type) # . { nil: a, cons: b -> a -> a } -> List b -> a # # There are other possible choices, but we default to assuming `List` handlers # since the `fold` keyword historically is most closely associated with lists, # even though all supported Grace `fold`s are folds in the more general sense of # the term: # # https://www.haskellforall.com/2021/02/folds-are-constructor-substitution.html \x -> fold x ================================================ FILE: tasty/data/complex/abstract-fold-output.ffg ================================================ \x -> fold x ================================================ FILE: tasty/data/complex/abstract-fold-type.ffg ================================================ forall (a : Type) (b : Type) . { nil: a, cons: b -> a -> a } -> List b -> a ================================================ FILE: tasty/data/complex/alternative-input.ffg ================================================ # The purpose of this test is to verify that alternatives bind to their # arguments more tightly than function application. This should be parsed as: # # \f -> f (Point{x: 1, y: 2 }) # # … and not: # # (\f -> f Point){x: 1, y: 2 } # # This precedence is intentional to reduce the number of parentheses required # when functions have union-valued arguments. One particularly notable example # of this is the `http` builtin, where you can write: # # http GET{ url: "https://httpbin.org" } # # … without parentheses, thanks to the tighter precedence of alternative # application. \f -> f Point{ x: 1, y: 2 } ================================================ FILE: tasty/data/complex/alternative-output.ffg ================================================ \f -> f Point{ "x": 1, "y": 2 } ================================================ FILE: tasty/data/complex/alternative-type.ffg ================================================ forall (a : Type) . forall (b : Alternatives) . (< Point: { x: Natural, y: Natural } | b > -> a) -> a ================================================ FILE: tasty/data/complex/arithmetic-input.ffg ================================================ # This test exercises all of the various arithmetic permutations to make sure # that they work without type annotations and produce a result of the desired # output type { add0: 2 + 2 , add1: 2 + -3 , add2: 2 + 0.1 , add3: "A" + "B" , add4: [ true ] + [ false ] , multiply0: 2 * 2 , multiply1: 2 * -3 , multiply2: 2 * 0.1 , subtract0: 2 - 2 , subtract1: 2 - -3 , subtract2: 2 - 0.1 , divide0: 2 / 2 , divide1: 2 / -3 , divide2: 2 / 0.1 , modulus0: 2 % 2 , modulus1: -3 % 2 , modulus2: 0.1 % 2 , lessThan0: 2 < 2 , lessThan1: 2 < -3 , lessThan2: 2 < 0.1 , lessThanOrEqual0: 2 <= 2 , lessThanOrEqual1: 2 <= -3 , lessThanOrEqual2: 2 <= 0.1 , greaterThan0: 2 > 2 , greaterThan1: 2 > -3 , greaterThan2: 2 > 0.1 , greaterThanOrEqual0: 2 >= 2 , greaterThanOrEqual1: 2 >= -3 , greaterThanOrEqual2: 2 >= 0.1 } ================================================ FILE: tasty/data/complex/arithmetic-output.ffg ================================================ { "add0": 4 , "add1": -1 , "add2": 2.1 , "add3": "AB" , "add4": [ true, false ] , "multiply0": 4 , "multiply1": -6 , "multiply2": 0.2 , "subtract0": 0 , "subtract1": 5 , "subtract2": 1.9 , "divide0": 1.0 , "divide1": -0.6666666666666666 , "divide2": 20.0 , "modulus0": { "quotient": 1, "remainder": 0 } , "modulus1": { "quotient": -2, "remainder": 1 } , "modulus2": { "quotient": 0, "remainder": 0.1 } , "lessThan0": false , "lessThan1": false , "lessThan2": false , "lessThanOrEqual0": true , "lessThanOrEqual1": false , "lessThanOrEqual2": false , "greaterThan0": false , "greaterThan1": true , "greaterThan2": true , "greaterThanOrEqual0": true , "greaterThanOrEqual1": true , "greaterThanOrEqual2": true } ================================================ FILE: tasty/data/complex/arithmetic-type.ffg ================================================ { add0: Natural , add1: Integer , add2: Real , add3: Text , add4: List Bool , multiply0: Natural , multiply1: Integer , multiply2: Real , subtract0: Integer , subtract1: Integer , subtract2: Real , divide0: Real , divide1: Real , divide2: Real , modulus0: { quotient: Natural, remainder: Natural } , modulus1: { quotient: Integer, remainder: Natural } , modulus2: { quotient: Integer, remainder: Real } , lessThan0: Bool , lessThan1: Bool , lessThan2: Bool , lessThanOrEqual0: Bool , lessThanOrEqual1: Bool , lessThanOrEqual2: Bool , greaterThan0: Bool , greaterThan1: Bool , greaterThan2: Bool , greaterThanOrEqual0: Bool , greaterThanOrEqual1: Bool , greaterThanOrEqual2: Bool } ================================================ FILE: tasty/data/complex/chain-identity-input.ffg ================================================ # This test verifies that the type-checker doesn't blow up even when # instantiating `id` to a very high-order type let id : forall (a : Type) . a -> a = \x -> x in id id id id id id id id id id id id id id id id id id id id id id id true ================================================ FILE: tasty/data/complex/chain-identity-output.ffg ================================================ true ================================================ FILE: tasty/data/complex/chain-identity-type.ffg ================================================ Bool ================================================ FILE: tasty/data/complex/check-function-input.ffg ================================================ fold { true: 0, false: 1 } : Bool -> Integer ================================================ FILE: tasty/data/complex/check-function-output.ffg ================================================ \a -> fold { "true": 0, "false": 1 } a : Integer ================================================ FILE: tasty/data/complex/check-function-type.ffg ================================================ Bool -> Integer ================================================ FILE: tasty/data/complex/church-encode-list-input.ffg ================================================ # This tests that Boehm-Berarducci-encoding a list works correctly let nil : forall (a : Type) . forall (list : Type) . (a -> list -> list) -> list -> list = \cons -> \nil -> nil let cons : forall (a : Type) . a -> (forall (list : Type) . (a -> list -> list) -> list -> list) -> (forall (list : Type) . (a -> list -> list) -> list -> list) = \x -> \list -> \cons -> \nil -> cons x (list cons nil) let and : (forall (list : Type) . (Bool -> list -> list) -> list -> list) -> Bool = \list -> list (\x -> \y -> x && y) true in and (cons true (cons false (cons true nil))) ================================================ FILE: tasty/data/complex/church-encode-list-output.ffg ================================================ false ================================================ FILE: tasty/data/complex/church-encode-list-type.ffg ================================================ Bool ================================================ FILE: tasty/data/complex/default-arguments-input.ffg ================================================ # This test verifies that defaults are correctly selected when the argument is # missing, either because it is set to `null` or (if it is a record field) # omitted from the record. let f (x = 1) { y = false } = { x, y } in [ f null { } , f 2 { y: true } ] ================================================ FILE: tasty/data/complex/default-arguments-output.ffg ================================================ [ { "x": 1, "y": false }, { "x": 2, "y": true } ] ================================================ FILE: tasty/data/complex/default-arguments-type.ffg ================================================ List { x: Natural, y: Bool } ================================================ FILE: tasty/data/complex/destructure-lambda-input.ffg ================================================ # This test exercises all of the supported syntax for destructuring a lambda \{ a, b: Natural, c = 0, d: Natural = 0 } -> a + b + c + d ================================================ FILE: tasty/data/complex/destructure-lambda-output.ffg ================================================ \{ a, b, c = 0, d = 0 } -> a + b + c + d ================================================ FILE: tasty/data/complex/destructure-lambda-type.ffg ================================================ forall (a : Fields) . { a: Natural, b: Natural, c: Optional Natural, d: Optional Natural, a } -> Natural ================================================ FILE: tasty/data/complex/destructure-let-argument-input.ffg ================================================ # This test exercises all of the supported syntax for destructuring a function # argument defined using `let` let f { a , b: Natural # Non-`Optional` fields must be present , c = 0 # Defaults are overriden if the field is present , d: Natural = 0 # Annotation must match default and field , e # Absent fields bound as `null` , f = 0 # Absent fields default to default value , g: Optional Natural # `Optional` fields may be omitted , h: Natural = 0 } = { a, b, c, d, e, f, g, h } in f { a: 1, b: 1, c: 1, d: 1 } ================================================ FILE: tasty/data/complex/destructure-let-argument-output.ffg ================================================ { "a": 1, "b": 1, "c": 1, "d": 1, "e": null, "f": 0, "g": null, "h": 0 } ================================================ FILE: tasty/data/complex/destructure-let-argument-type.ffg ================================================ forall (a : Type) . { a: Natural , b: Natural , c: Natural , d: Natural , e: Optional a , f: Natural , g: Optional Natural , h: Natural } ================================================ FILE: tasty/data/complex/destructure-record-input.ffg ================================================ # This test exercises all of the supported cases for destructuring a record, # with or without the field present let { a , b: Natural # Non-`Optional` fields must be present , c = 0 # Defaults are overriden if the field is present , d: Natural = 0 # Annotation must match default and field , e # Absent fields bound as `null` , f = 0 # Absent fields default to default value , g: Optional Natural # `Optional` fields may be omitted , h: Natural = 0 } = { a: 1, b: 1, c: 1, d: 1 } in { a, b, c, d, e, f, g, h } ================================================ FILE: tasty/data/complex/destructure-record-output.ffg ================================================ { "a": 1, "b": 1, "c": 1, "d": 1, "e": null, "f": 0, "g": null, "h": 0 } ================================================ FILE: tasty/data/complex/destructure-record-type.ffg ================================================ forall (a : Type) . { a: Natural , b: Natural , c: Natural , d: Natural , e: Optional a , f: Natural , g: Optional Natural , h: Natural } ================================================ FILE: tasty/data/complex/elaborate-inside-optional-input.ffg ================================================ \(x : Optional Natural) -> x : Optional (Optional Natural) ================================================ FILE: tasty/data/complex/elaborate-inside-optional-output.ffg ================================================ \x -> (if let (x : Natural) of x in some x) : Optional (Optional Natural) ================================================ FILE: tasty/data/complex/elaborate-inside-optional-type.ffg ================================================ Optional Natural -> Optional (Optional Natural) ================================================ FILE: tasty/data/complex/equality-input.ffg ================================================ { number: 0, bool: true, list: [ 2, 3, 5 ], text: "" } == { number: 0, bool: true, list: [ 2, 3, 5 ], text: "" } ================================================ FILE: tasty/data/complex/equality-output.ffg ================================================ true ================================================ FILE: tasty/data/complex/equality-type.ffg ================================================ Bool ================================================ FILE: tasty/data/complex/even-input.ffg ================================================ # This tests that folding `Natural` numbers doesn't have a gross inefficiency by # implementing the even function as a fold let not (b : Bool) : Bool = if b then false else true let even (n : Natural) : Bool = fold { succ: not, zero: true } n in even 1000000 ================================================ FILE: tasty/data/complex/even-output.ffg ================================================ true ================================================ FILE: tasty/data/complex/even-type.ffg ================================================ Bool ================================================ FILE: tasty/data/complex/examples-input.ffg ================================================ # These are all of the examples/tutorial from the trygrace.dev tutorial { hello: ../../../examples/tutorial/hello.ffg , html: ../../../examples/tutorial/html.ffg , data: ../../../examples/tutorial/data.ffg , prompting: ../../../examples/tutorial/prompting.ffg , variables: ../../../examples/tutorial/variables.ffg , functions: ../../../examples/tutorial/functions.ffg , imports: ../../../examples/tutorial/imports.ffg , coding: ../../../examples/tutorial/coding.ffg , conclusion: ../../../examples/tutorial/conclusion.ffg } ================================================ FILE: tasty/data/complex/examples-output.ffg ================================================ { "hello": "Hello, world!" , "html": [ true, false, true ] , "data": { "An example string": "Mercury" , "An example string with a type annotation": "cosmic" , "A boolean value": true , "Annotated boolean value": false , "A natural number": 42 , "An integer": -12 , "A real number": 3.14159265359 , "A list of natural numbers": [ 1, 1, 2, 3, 5, 8, 13 ] , "Annotated list of natural numbers": [ 1, 1, 2, 3, 5, 8, 13 ] , "Annotated record": { "x": 0, "y": 0 } , "A list of records (using JSON syntax with quoted field names)": [ { "isActive": true , "age": 36 , "name": "Dunlap Hubbard" , "email": "dunlaphubbard@example.com" , "phone": "+1 (555) 543-2508" } , { "isActive": true , "age": 24 , "name": "Kirsten Sellers" , "email": "kirstensellers@example.com" , "phone": "+1 (555) 564-2190" } ] } , "prompting": \arguments -> let key = arguments."OpenAI API key" in { "names": prompt { "key": key , "text": some "Give me a list of names" , "history": null , "model": null , "search": null , "effort": null } : forall (p : Type) . p , "structuredNames": prompt { "key": key , "text": some "Give me a list of names" , "history": null , "model": null , "search": null , "effort": null } : List Text , "fullNames": prompt { "key": key , "text": some "Give me a list of names" , "history": null , "model": null , "search": null , "effort": null } : List { firstName: Text, lastName: Text } , "tacitFullNames": prompt { "key": key , "text": null , "history": null , "model": null , "search": null , "effort": null } : List { firstName: Text, lastName: Text } , "differentModel": prompt { "key": key , "model": some "gpt-5-nano" , "text": null , "history": null , "search": null , "effort": null } : List { firstName: Text, lastName: Text } } , "variables": 216 , "functions": { "greet": \{ name } -> "Hello, ${name}!" , "greeting": "Hello, world!" , "makeUser": \{ user } -> let home = "/home/${user}" let privateKey = "${home}/.ssh/id_ed25519" let publicKey = "${privateKey}.pub" in { "home": home, "privateKey": privateKey, "publicKey": publicKey } , "users": [ { "home": "/home/bill" , "privateKey": "/home/bill/.ssh/id_ed25519" , "publicKey": "/home/bill/.ssh/id_ed25519.pub" } , { "home": "/home/jane" , "privateKey": "/home/jane/.ssh/id_ed25519" , "publicKey": "/home/jane/.ssh/id_ed25519.pub" } ] } , "imports": { "URL import": \{ "Filing status", "Taxable income" } -> let toBracket brackets (_ : { }) income = fold { "cons": \bracket -> \result -> if income > bracket."Lower bound" then bracket."Minimum tax" + bracket."Tax rate" * (income - bracket."Lower bound") else result , "nil": 0.0 : Real } brackets let tax = fold { "Single filers": toBracket [ { "Tax rate": 0.37 , "Lower bound": 539900.0 , "Minimum tax": 162718.0 } , { "Tax rate": 0.35 , "Lower bound": 215950.0 , "Minimum tax": 49335.5 } , { "Tax rate": 0.32 , "Lower bound": 170050.0 , "Minimum tax": 34647.5 } , { "Tax rate": 0.24 , "Lower bound": 89075.0 , "Minimum tax": 15213.5 } , { "Tax rate": 0.22 , "Lower bound": 41775.0 , "Minimum tax": 4807.5 } , { "Tax rate": 0.12 , "Lower bound": 10275.0 , "Minimum tax": 1027.5 } , { "Tax rate": 0.1 , "Lower bound": 0.0 , "Minimum tax": 0.0 } ] , "Married, filing jointly": toBracket [ { "Tax rate": 0.37 , "Lower bound": 647850.0 , "Minimum tax": 174253.5 } , { "Tax rate": 0.35 , "Lower bound": 431900.0 , "Minimum tax": 98671.0 } , { "Tax rate": 0.32 , "Lower bound": 340100.0 , "Minimum tax": 69295.0 } , { "Tax rate": 0.24 , "Lower bound": 178150.0 , "Minimum tax": 30427.0 } , { "Tax rate": 0.22 , "Lower bound": 93550.0 , "Minimum tax": 9615.0 } , { "Tax rate": 0.12 , "Lower bound": 20550.0 , "Minimum tax": 2055.0 } , { "Tax rate": 0.1 , "Lower bound": 0.0 , "Minimum tax": 0.0 } ] , "Married, filing separately": toBracket [ { "Tax rate": 0.37 , "Lower bound": 539900.0 , "Minimum tax": 162718.0 } , { "Tax rate": 0.35 , "Lower bound": 215950.0 , "Minimum tax": 49335.5 } , { "Tax rate": 0.32 , "Lower bound": 170050.0 , "Minimum tax": 34647.5 } , { "Tax rate": 0.24 , "Lower bound": 89075.0 , "Minimum tax": 15213.5 } , { "Tax rate": 0.22 , "Lower bound": 41775.0 , "Minimum tax": 4807.5 } , { "Tax rate": 0.12 , "Lower bound": 10275.0 , "Minimum tax": 1027.5 } , { "Tax rate": 0.1 , "Lower bound": 0.0 , "Minimum tax": 0.0 } ] , "Head of household": toBracket [ { "Tax rate": 0.37 , "Lower bound": 539900.0 , "Minimum tax": 161218.5 } , { "Tax rate": 0.35 , "Lower bound": 215950.0 , "Minimum tax": 47836.0 } , { "Tax rate": 0.32 , "Lower bound": 170050.0 , "Minimum tax": 33148.0 } , { "Tax rate": 0.24 , "Lower bound": 89050.0 , "Minimum tax": 13708.0 } , { "Tax rate": 0.22 , "Lower bound": 55900.0 , "Minimum tax": 6415.0 } , { "Tax rate": 0.12 , "Lower bound": 14650.0 , "Minimum tax": 1465.0 } , { "Tax rate": 0.1 , "Lower bound": 0.0 , "Minimum tax": 0.0 } ] } .'Filing status' .'Taxable income' in { "Tax": tax } , "GitHub import": \{ "Filing status", "Taxable income" } -> let toBracket brackets (_ : { }) income = fold { "cons": \bracket -> \result -> if income > bracket."Lower bound" then bracket."Minimum tax" + bracket."Tax rate" * (income - bracket."Lower bound") else result , "nil": 0.0 : Real } brackets let tax = fold { "Single filers": toBracket [ { "Tax rate": 0.37 , "Lower bound": 539900.0 , "Minimum tax": 162718.0 } , { "Tax rate": 0.35 , "Lower bound": 215950.0 , "Minimum tax": 49335.5 } , { "Tax rate": 0.32 , "Lower bound": 170050.0 , "Minimum tax": 34647.5 } , { "Tax rate": 0.24 , "Lower bound": 89075.0 , "Minimum tax": 15213.5 } , { "Tax rate": 0.22 , "Lower bound": 41775.0 , "Minimum tax": 4807.5 } , { "Tax rate": 0.12 , "Lower bound": 10275.0 , "Minimum tax": 1027.5 } , { "Tax rate": 0.1 , "Lower bound": 0.0 , "Minimum tax": 0.0 } ] , "Married, filing jointly": toBracket [ { "Tax rate": 0.37 , "Lower bound": 647850.0 , "Minimum tax": 174253.5 } , { "Tax rate": 0.35 , "Lower bound": 431900.0 , "Minimum tax": 98671.0 } , { "Tax rate": 0.32 , "Lower bound": 340100.0 , "Minimum tax": 69295.0 } , { "Tax rate": 0.24 , "Lower bound": 178150.0 , "Minimum tax": 30427.0 } , { "Tax rate": 0.22 , "Lower bound": 93550.0 , "Minimum tax": 9615.0 } , { "Tax rate": 0.12 , "Lower bound": 20550.0 , "Minimum tax": 2055.0 } , { "Tax rate": 0.1 , "Lower bound": 0.0 , "Minimum tax": 0.0 } ] , "Married, filing separately": toBracket [ { "Tax rate": 0.37 , "Lower bound": 539900.0 , "Minimum tax": 162718.0 } , { "Tax rate": 0.35 , "Lower bound": 215950.0 , "Minimum tax": 49335.5 } , { "Tax rate": 0.32 , "Lower bound": 170050.0 , "Minimum tax": 34647.5 } , { "Tax rate": 0.24 , "Lower bound": 89075.0 , "Minimum tax": 15213.5 } , { "Tax rate": 0.22 , "Lower bound": 41775.0 , "Minimum tax": 4807.5 } , { "Tax rate": 0.12 , "Lower bound": 10275.0 , "Minimum tax": 1027.5 } , { "Tax rate": 0.1 , "Lower bound": 0.0 , "Minimum tax": 0.0 } ] , "Head of household": toBracket [ { "Tax rate": 0.37 , "Lower bound": 539900.0 , "Minimum tax": 161218.5 } , { "Tax rate": 0.35 , "Lower bound": 215950.0 , "Minimum tax": 47836.0 } , { "Tax rate": 0.32 , "Lower bound": 170050.0 , "Minimum tax": 33148.0 } , { "Tax rate": 0.24 , "Lower bound": 89050.0 , "Minimum tax": 13708.0 } , { "Tax rate": 0.22 , "Lower bound": 55900.0 , "Minimum tax": 6415.0 } , { "Tax rate": 0.12 , "Lower bound": 14650.0 , "Minimum tax": 1465.0 } , { "Tax rate": 0.1 , "Lower bound": 0.0 , "Minimum tax": 0.0 } ] } .'Filing status' .'Taxable income' in { "Tax": tax } , "Short link": " The Grace browser also supports short links for code hosted on GitHub. For example, the short link for the above federal income tax form is: [https://trygrace.dev?github=Gabriella439/grace/examples/taxes.ffg](https://trygrace.dev?github=Gabriella439/grace/examples/taxes.ffg) More generally, the format of GitHub short links is: ``` https://trygrace.dev?github=${owner}/${repository}/${path}[&reference=${reference}][&private=true] ``` - `&reference=${reference}` pins the short link to a specific git reference … and defaults to the trunk branch of the repository. - `&private=true` will prompt you for a GitHub personal access token … so that you can import from a private GitHub repository. GitHub code imported in this way is displayed as a \"white-label\" form displaying just the form without the title bar or the code editor. " , "Import Prelude function": \b -> b == false , "Import entire Prelude": \b -> b == false } , "coding": \arguments -> let key = arguments."OpenAI API key" in import prompt { "key": key , "text": null , "history": null , "model": null , "search": null , "effort": null } : { "Job Description": Text } -> { "Is Finance?": Bool, "Rationale": Text } , "conclusion": \{ "Want to get involved?" } -> if .'Want to get involved?' then " Visit Grace's [GitHub repository](https://github.com/Gabriella439/grace) or follow her [Bluesky profile](https://bsky.app/profile/trygrace.dev). " else "Have fun using the Grace browser!" } ================================================ FILE: tasty/data/complex/examples-type.ffg ================================================ forall (k : Fields) . forall (l : Fields) . forall (m : Fields) . forall (n : Fields) . forall (o : Fields) . forall (p : Type) . forall (q : Fields) . { hello: Text , html: List Bool , data: { "An example string": Text , "An example string with a type annotation": Text , "A boolean value": Bool , "Annotated boolean value": Bool , "A natural number": Natural , "An integer": Integer , "A real number": Real , "A list of natural numbers": List Natural , "Annotated list of natural numbers": List Natural , "Annotated record": { x: Natural, y: Natural } , "A list of records (using JSON syntax with quoted field names)": List { isActive: Bool , age: Natural , name: Text , email: Text , phone: Text } } , prompting: { "OpenAI API key": Key, q } -> { names: p , structuredNames: List Text , fullNames: List { firstName: Text, lastName: Text } , tacitFullNames: List { firstName: Text, lastName: Text } , differentModel: List { firstName: Text, lastName: Text } } , variables: Natural , functions: { greet: { name: Text, o } -> Text , greeting: Text , makeUser: { user: Text } -> { home: Text, privateKey: Text, publicKey: Text } , users: List { home: Text, privateKey: Text, publicKey: Text } } , imports: { "URL import": { "Filing status": < 'Head of household': { } | 'Married, filing jointly': { } | 'Married, filing separately': { } | 'Single filers': { } > , "Taxable income": Real , n } -> { "Tax": Real } , "GitHub import": { "Filing status": < 'Head of household': { } | 'Married, filing jointly': { } | 'Married, filing separately': { } | 'Single filers': { } > , "Taxable income": Real , m } -> { "Tax": Real } , "Short link": Text , "Import Prelude function": Bool -> Bool , "Import entire Prelude": Bool -> Bool } , coding: { "OpenAI API key": Key, l } -> { "Job Description": Text } -> { "Is Finance?": Bool, "Rationale": Text } , conclusion: { "Want to get involved?": Bool, k } -> Text } ================================================ FILE: tasty/data/complex/exclaim-input.ffg ================================================ # Test defining and using a function let exclaim t = "${t}!" in exclaim "Hello, world" ================================================ FILE: tasty/data/complex/exclaim-output.ffg ================================================ "Hello, world!" ================================================ FILE: tasty/data/complex/exclaim-type.ffg ================================================ Text ================================================ FILE: tasty/data/complex/exhaust-type-variable-alphabet-input.ffg ================================================ # The purpose of this test is to force the type-inference algorithm to use up # the type variable alphabet so that we start displaying type variables like # `a0` \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 ================================================ FILE: tasty/data/complex/exhaust-type-variable-alphabet-output.ffg ================================================ \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 ================================================ FILE: tasty/data/complex/exhaust-type-variable-alphabet-type.ffg ================================================ forall (a : Type) . forall (b : Type) . forall (c : Type) . forall (d : Type) . forall (e : Type) . forall (f : Type) . forall (g : Type) . forall (h : Type) . forall (i : Type) . forall (j : Type) . forall (k : Type) . forall (l : Type) . forall (m : Type) . forall (n : Type) . forall (o : Type) . forall (p : Type) . forall (q : Type) . forall (r : Type) . forall (s : Type) . forall (t : Type) . forall (u : Type) . forall (v : Type) . forall (w : Type) . forall (x : Type) . forall (y : Type) . forall (z : Type) . forall (a0 : Type) . a0 -> z -> y -> x -> w -> v -> u -> t -> s -> r -> q -> p -> o -> n -> m -> l -> k -> j -> i -> h -> g -> f -> e -> d -> c -> b -> a -> a ================================================ FILE: tasty/data/complex/existential-records-input.ffg ================================================ [ { x: 1, y: true } , { x: 1, z: "" } ] : List { x : Natural, y : Optional Bool, z : Optional Text } ================================================ FILE: tasty/data/complex/existential-records-output.ffg ================================================ [ { "x": 1, "y": some true, "z": null }, { "x": 1, "z": some "", "y": null } ] ================================================ FILE: tasty/data/complex/existential-records-type.ffg ================================================ List { x: Natural, y: Optional Bool, z: Optional Text } ================================================ FILE: tasty/data/complex/export-show-input.ffg ================================================ { "Example 0": # Expressions should be normalized before they are shown, meaning that the # following expression should render as "1" and not "let x = 1 in x" export show (let x = 1 in x) , "Example 1": # Test that a read followed by show works without a type annotation export show (import read "\\x -> x") , "Example 2": # This test illustrates that `export show` has an effective type of # `forall (a : Type) . a -> Text` which means that we are very intentionally # breaking parametricity by permitting this feature. \x -> export show x } ================================================ FILE: tasty/data/complex/export-show-output.ffg ================================================ { "Example 0": "1" , "Example 1": "\\x -> x" , "Example 2": \x -> export show (x : forall (b : Type) . b) } ================================================ FILE: tasty/data/complex/export-show-type.ffg ================================================ forall (b : Type) . { "Example 0": Text, "Example 1": Text, "Example 2": b -> Text } ================================================ FILE: tasty/data/complex/extra-fields-input.ffg ================================================ let f (r : { x : Natural }) = r.x in f { x: 1, y: true } ================================================ FILE: tasty/data/complex/extra-fields-output.ffg ================================================ 1 ================================================ FILE: tasty/data/complex/extra-fields-type.ffg ================================================ Natural ================================================ FILE: tasty/data/complex/fold-bool-input.ffg ================================================ \{ false, true } -> fold{ false, true } ================================================ FILE: tasty/data/complex/fold-bool-output.ffg ================================================ \{ false, true } -> fold { "false": .'false', "true": .'true' } ================================================ FILE: tasty/data/complex/fold-bool-type.ffg ================================================ forall (a : Type) (b : Fields) . { false: a, true: a, b } -> Bool -> a ================================================ FILE: tasty/data/complex/fold-json-input.ffg ================================================ \{ array, bool, integer, natural, null, object, real, string } -> fold{ array, bool, integer, natural, null, object, real, string } ================================================ FILE: tasty/data/complex/fold-json-output.ffg ================================================ \{ array, bool, integer, natural, null, object, real, string } -> fold { "array": array , "bool": bool , "integer": integer , "natural": natural , "null": .'null' , "object": object , "real": real , "string": string } ================================================ FILE: tasty/data/complex/fold-json-type.ffg ================================================ forall (a : Type) . forall (b : Fields) . { array: List a -> a , bool: Bool -> a , integer: Integer -> a , natural: Natural -> a , null: a , object: List { key: Text, value: a } -> a , real: Real -> a , string: Text -> a , b } -> JSON -> a ================================================ FILE: tasty/data/complex/fold-list-input.ffg ================================================ \{ nil, cons } -> fold{ nil, cons } ================================================ FILE: tasty/data/complex/fold-list-output.ffg ================================================ \{ nil, cons } -> fold { "nil": nil, "cons": cons } ================================================ FILE: tasty/data/complex/fold-list-type.ffg ================================================ forall (a : Type) . forall (b : Type) . forall (c : Fields) . { nil: a, cons: b -> a -> a, c } -> List b -> a ================================================ FILE: tasty/data/complex/fold-missing-field-input.ffg ================================================ # This tests how `fold` behaves when missing various arguments, along with # commentary on why each case behaves the way it does: { "Example 0": # The inferred type will be: # # Bool -> Optional Natural # # … because this will elaborate to: # # fold{ false: some 0, true: null } fold{ false: 0 } , "Example 1": # The inferred type will be: # # forall (a : Type) . Natural -> Optional a` # # … because this will elaborate to: # # fold{ succ x: x, zero: null } # # … and the inferred type correctly deduces that must always return `null` # no matter what `Natural` number we provide. fold{ succ x: x } , "Example 2": # The inferred type will be: # # forall (a : Type) . Optional (Optional a) -> Optional a # # … because this will elaborate to: # # fold{ some x: x, null: null } fold{ some x: x } , "Example 3": # The inferred type will be: # # Optional Natural -> Optional Natural # # … because this will elaborate to: # # fold{ some x: some (x + 1), null: null } # # Note that (unlike the previous example) the typechecker has to insert a # `some` around the `some` handler, which is why the inferred type has a # different shape than the previous example. fold{ some x: x + 1 } , "Example 4": # The inferred type will be: # # forall (a : Type) (b : Type) . List a -> Optional b # # … because this will elaborate to: # # fold{ cons: \x y -> y, nil: null } fold{ cons: \x y -> y } } ================================================ FILE: tasty/data/complex/fold-missing-field-output.ffg ================================================ { "Example 0": fold { "false": some 0, "true": null } , "Example 1": fold { "succ": \x -> x, "zero": null } , "Example 2": fold { "some": \x -> x, "null": null } , "Example 3": fold { "some": \x -> some (x + 1), "null": null } , "Example 4": fold { "cons": \x y -> y, "nil": null } } ================================================ FILE: tasty/data/complex/fold-missing-field-type.ffg ================================================ forall (a : Type) . forall (b : Type) . forall (c : Type) . forall (d : Type) . { "Example 0": Bool -> Optional Natural , "Example 1": Natural -> Optional d , "Example 2": Optional (Optional c) -> Optional c , "Example 3": Optional Natural -> Optional Natural , "Example 4": List b -> Optional a } ================================================ FILE: tasty/data/complex/fold-natural-input.ffg ================================================ \{ zero, succ } -> fold{ zero, succ } ================================================ FILE: tasty/data/complex/fold-natural-output.ffg ================================================ \{ zero, succ } -> fold { "zero": zero, "succ": succ } ================================================ FILE: tasty/data/complex/fold-natural-type.ffg ================================================ forall (a : Type) (b : Fields) . { zero: a, succ: a -> a, b } -> Natural -> a ================================================ FILE: tasty/data/complex/fold-optional-input.ffg ================================================ \{ null, some } -> fold{ null, some } ================================================ FILE: tasty/data/complex/fold-optional-output.ffg ================================================ \{ null, some } -> fold { "null": .'null', "some": .'some' } ================================================ FILE: tasty/data/complex/fold-optional-type.ffg ================================================ forall (a : Type) . forall (b : Type) . forall (c : Fields) . { null: a, some: b -> a, c } -> Optional b -> a ================================================ FILE: tasty/data/complex/for-annotation-input.ffg ================================================ (for x of [] in x + 1) : List Natural ================================================ FILE: tasty/data/complex/for-annotation-output.ffg ================================================ [ ] ================================================ FILE: tasty/data/complex/for-annotation-type.ffg ================================================ List Natural ================================================ FILE: tasty/data/complex/for-check-list-input.ffg ================================================ # Exercise the check judgment on Optional comprehensions (if let x = some 1 in x) : Optional Natural ================================================ FILE: tasty/data/complex/for-check-list-output.ffg ================================================ some 1 ================================================ FILE: tasty/data/complex/for-check-list-type.ffg ================================================ Optional Natural ================================================ FILE: tasty/data/complex/for-lambda-input.ffg ================================================ # This test verifies that the `check` rule for `for` assignments works # correctly when the type annotation is an unsolved variable,such as # when checking the body of a lambda without an annotation. \y -> for x of [ 1 ] in x ================================================ FILE: tasty/data/complex/for-lambda-output.ffg ================================================ \y -> for x of [ 1 ] in x ================================================ FILE: tasty/data/complex/for-lambda-type.ffg ================================================ forall (a : Type) . a -> List Natural ================================================ FILE: tasty/data/complex/for-list-input.ffg ================================================ let bools = [ false, true ] for bool of bools let numbers = if bool then [ 1, 2, 3 ] else [ 4, 5, 6 ] for number of numbers in { bool, number } ================================================ FILE: tasty/data/complex/for-list-output.ffg ================================================ [ { "bool": false, "number": 4 } , { "bool": false, "number": 5 } , { "bool": false, "number": 6 } , { "bool": true, "number": 1 } , { "bool": true, "number": 2 } , { "bool": true, "number": 3 } ] ================================================ FILE: tasty/data/complex/for-list-type.ffg ================================================ List { bool: Bool, number: Natural } ================================================ FILE: tasty/data/complex/for-naked-output.ffg ================================================ some 1 ================================================ FILE: tasty/data/complex/for-naked-type.ffg ================================================ Optional Natural ================================================ FILE: tasty/data/complex/for-optional-input.ffg ================================================ let a = some 1 if let x = a let b = some x if let y = b let c = null if let z = c in { x, y, z } ================================================ FILE: tasty/data/complex/for-optional-output.ffg ================================================ null ================================================ FILE: tasty/data/complex/for-optional-type.ffg ================================================ forall (a : Type) . Optional { x: Natural, y: Natural, z: a } ================================================ FILE: tasty/data/complex/forall-annotation-input.ffg ================================================ # Test a polymorphic type annotation (\x -> x) : forall (a : Type) . a -> a ================================================ FILE: tasty/data/complex/forall-annotation-output.ffg ================================================ \x -> x ================================================ FILE: tasty/data/complex/forall-annotation-type.ffg ================================================ forall (a : Type) . a -> a ================================================ FILE: tasty/data/complex/higher-rank-annotation-input.ffg ================================================ # This test illustrates how a type annotation is necessary for higher-rank # functions. In the absence of the annotation the example fails with an # unbound type variable error. ( \id -> [ id : forall (a : Type) . a -> a , \x -> x ] ) : (forall (a : Type) . a -> a) -> List (forall (a : Type) . a -> a) ================================================ FILE: tasty/data/complex/higher-rank-annotation-output.ffg ================================================ \id -> [ id : forall (a : Type) . a -> a, \x -> x ] ================================================ FILE: tasty/data/complex/higher-rank-annotation-type.ffg ================================================ (forall (a : Type) . a -> a) -> List (forall (a : Type) . a -> a) ================================================ FILE: tasty/data/complex/higher-rank-input.ffg ================================================ # This test verifies that higher-rank functions work let f : (forall (a : Type) . a -> a) -> Natural -> Natural = \g -> g let id : forall (a : Type) . a -> a = \x -> x in f id ================================================ FILE: tasty/data/complex/higher-rank-output.ffg ================================================ \x -> x ================================================ FILE: tasty/data/complex/higher-rank-subtype-input.ffg ================================================ # The purpose of this test is to fully exercise the <:∀R judgment let f : Natural -> (forall (a : Type) . Bool) -> Natural = \n _ -> n in f 0 (true : forall (a : Type) . Bool) ================================================ FILE: tasty/data/complex/higher-rank-subtype-output.ffg ================================================ 0 ================================================ FILE: tasty/data/complex/higher-rank-subtype-type.ffg ================================================ Natural ================================================ FILE: tasty/data/complex/higher-rank-type.ffg ================================================ Natural -> Natural ================================================ FILE: tasty/data/complex/if-then-else-input.ffg ================================================ # This checks what type would be inferred for a first-class function equivalent # to an `if` expression \x -> \y -> \z -> if x then y else z ================================================ FILE: tasty/data/complex/if-then-else-output.ffg ================================================ \x y z -> if x then y else z ================================================ FILE: tasty/data/complex/if-then-else-type.ffg ================================================ forall (a : Type) . Bool -> a -> a -> a ================================================ FILE: tasty/data/complex/import-github-input.ffg ================================================ import github { owner: "Gabriella439" , repository: "grace" , reference: "2aa58c1b5aeffab08acf2dd4c0d2de430a380b9b" , path: "prelude/bool/not.ffg" } ================================================ FILE: tasty/data/complex/import-github-output.ffg ================================================ \b -> b == false ================================================ FILE: tasty/data/complex/import-github-type.ffg ================================================ Bool -> Bool ================================================ FILE: tasty/data/complex/impredicative-const-input.ffg ================================================ # Verify that higher-rank predicative polymorphism is allowed by giving the # `const` function the highest-rank polymorphic type possible (\x -> \y -> x) : forall (a : Type) . a -> (forall (b : Type) . b -> a) ================================================ FILE: tasty/data/complex/impredicative-const-output.ffg ================================================ \x y -> x ================================================ FILE: tasty/data/complex/impredicative-const-type.ffg ================================================ forall (a : Type) . a -> (forall (b : Type) . b -> a) ================================================ FILE: tasty/data/complex/index-input.ffg ================================================ { example0: [ 2, 3, 5 ].0 , example1: [ 2, 3, 5 ].-1 , example2: [ 2, 3, 5 ].3 , example3: [ 2, 3, 5 ].-4 , example4: [].0 } ================================================ FILE: tasty/data/complex/index-output.ffg ================================================ { "example0": some 2 , "example1": some 5 , "example2": null , "example3": null , "example4": null } ================================================ FILE: tasty/data/complex/index-type.ffg ================================================ forall (a : Type) . { example0: Optional Natural , example1: Optional Natural , example2: Optional Natural , example3: Optional Natural , example4: Optional a } ================================================ FILE: tasty/data/complex/inequality-input.ffg ================================================ { number: 0, bool: true, list: [ 2, 3, 5 ], text: "" } == { number: 0, bool: true, list: [ 2, 3, 6 ], text: "" } ================================================ FILE: tasty/data/complex/inequality-output.ffg ================================================ false ================================================ FILE: tasty/data/complex/inequality-type.ffg ================================================ Bool ================================================ FILE: tasty/data/complex/infer-higher-order-input.ffg ================================================ # Verify that we can infer the types of higher-order functions \f x -> f x ================================================ FILE: tasty/data/complex/infer-higher-order-output.ffg ================================================ \f x -> f x ================================================ FILE: tasty/data/complex/infer-higher-order-type.ffg ================================================ forall (a : Type) (b : Type) . (b -> a) -> b -> a ================================================ FILE: tasty/data/complex/infer-reverse-input.ffg ================================================ # This is a basic test that type inference can work backwards from output types # to infer input types \x -> x : Bool ================================================ FILE: tasty/data/complex/infer-reverse-output.ffg ================================================ \x -> x : Bool ================================================ FILE: tasty/data/complex/infer-reverse-type.ffg ================================================ Bool -> Bool ================================================ FILE: tasty/data/complex/inner-forall-input.ffg ================================================ let wrappedId : { wrapped : forall (a : Type). a -> a } = { wrapped : \x -> x } in wrappedId : { wrapped: forall (a : Type). a -> a } ================================================ FILE: tasty/data/complex/inner-forall-output.ffg ================================================ { "wrapped": \x -> x } ================================================ FILE: tasty/data/complex/inner-forall-type.ffg ================================================ forall (a : Type) . { wrapped: a -> a } ================================================ FILE: tasty/data/complex/instantiate-nested-type-input.ffg ================================================ # This test is designed to exercise as many code paths as possible for the # `Grace.Type.substitute{Type,Fields,Alternatives}` family of functions let f : forall (a : Type) . forall (a : Fields) . forall (a : Type) . forall (t : Type) . forall (r : Fields) . forall (u : Alternatives) . a -> t -> { r } -> < u > -> List < C : { y : a, t : Text, b : Bool, n : Natural, t : t, r : { r }, u : < u > } > = \x -> \t -> \r -> \u -> [ C { y: x, t: "", b: false, n: 0, t: t, r: r, u: u } ] let g : forall (a : Fields) . forall (a : Alternatives) . forall (a : Fields) . forall (t : Type) . forall (r : Fields) . forall (u : Alternatives) . { a } -> t -> { r } -> < u > -> List < C : { y : { a }, t : Text, b : Bool, n : Natural, t : t, r : { r }, u : < u > } > = f let h : forall (a : Alternatives) . forall (a : Type) . forall (a : Alternatives) . forall (t : Type) . forall (r : Fields) . forall (u : Alternatives) . < a > -> t -> { r } -> < u > -> List < C : { y : < a >, t : Text, b : Bool, n : Natural, t : t, r : { r }, u : < u > } > = f let example0 = f 1 let example1 = g { foo: 1 } let example2 = h (Foo 1) in { } ================================================ FILE: tasty/data/complex/instantiate-nested-type-output.ffg ================================================ { } ================================================ FILE: tasty/data/complex/instantiate-nested-type-type.ffg ================================================ { } ================================================ FILE: tasty/data/complex/instantiate-variable-input.ffg ================================================ # This exercises instantiation of an unsolved variable to a type variable { a: null : forall (a : Type) . Optional a , b: null : forall (a : Fields) . Optional { a } , c: null : forall (a : Alternatives) . Optional < a > } ================================================ FILE: tasty/data/complex/instantiate-variable-output.ffg ================================================ { "a": null, "b": null, "c": null } ================================================ FILE: tasty/data/complex/instantiate-variable-type.ffg ================================================ forall (a : Alternatives) . forall (b : Fields) . forall (c : Type) . { a: Optional c, b: Optional { b }, c: Optional < a > } ================================================ FILE: tasty/data/complex/interpolate-default-input.ffg ================================================ let greet{ name = "John Doe" } = "Hello, ${name}!" in [ greet{ name: "Mary Sue" } , greet{ name: null } , greet{ } ] ================================================ FILE: tasty/data/complex/interpolate-default-output.ffg ================================================ [ "Hello, Mary Sue!", "Hello, John Doe!", "Hello, John Doe!" ] ================================================ FILE: tasty/data/complex/interpolate-default-type.ffg ================================================ List Text ================================================ FILE: tasty/data/complex/interpolation-input.ffg ================================================ { example0: "a${"b" + "c"}d" , example1: "a${ "b" }c" } ================================================ FILE: tasty/data/complex/interpolation-output.ffg ================================================ { "example0": "abcd", "example1": "abc" } ================================================ FILE: tasty/data/complex/interpolation-type.ffg ================================================ { example0: Text, example1: Text } ================================================ FILE: tasty/data/complex/json-fold-input.ffg ================================================ fold { "bool": \b -> if b then 1 else 0 , "natural": \x -> x , "integer": abs , "real": \_ -> 1 , "string": \_ -> 2 , "null": 3 , "object": length , "array": fold { cons: \x -> \y -> x + y : Natural, nil: 0 : Natural } } [ true, 1, [ -2, false, "" ], null, { foo: { } } ] ================================================ FILE: tasty/data/complex/json-fold-output.ffg ================================================ 10 ================================================ FILE: tasty/data/complex/json-fold-type.ffg ================================================ Natural ================================================ FILE: tasty/data/complex/keyword-prefix-input.ffg ================================================ # Check that identifiers can begin with keyword prefixes # # `input` starts with `in`, which is a keyword let input = 1 in input ================================================ FILE: tasty/data/complex/keyword-prefix-output.ffg ================================================ 1 ================================================ FILE: tasty/data/complex/keyword-prefix-type.ffg ================================================ Natural ================================================ FILE: tasty/data/complex/lambda-annotation-input.ffg ================================================ (\(x : forall (a : Type) . a -> a) -> x) (\y -> y) ================================================ FILE: tasty/data/complex/lambda-annotation-output.ffg ================================================ \y -> y ================================================ FILE: tasty/data/complex/lambda-annotation-type.ffg ================================================ forall (a : Type) . a -> a ================================================ FILE: tasty/data/complex/let-functions-input.ffg ================================================ let f0 succ zero = succ (succ zero) let f1 (succ : Natural -> Natural) (zero : Natural) : Natural = succ (succ zero) let succ0 x = x + 1 : Natural let succ1 (x : Natural) : Natural = x + 1 in f0 succ0 0 + f1 succ1 0 ================================================ FILE: tasty/data/complex/let-functions-output.ffg ================================================ 4 ================================================ FILE: tasty/data/complex/let-functions-type.ffg ================================================ Natural ================================================ FILE: tasty/data/complex/list-append-subtype-input.ffg ================================================ [ -2 ] + [ 3 ] ================================================ FILE: tasty/data/complex/list-append-subtype-output.ffg ================================================ [ -2, 3 ] ================================================ FILE: tasty/data/complex/list-append-subtype-type.ffg ================================================ List Integer ================================================ FILE: tasty/data/complex/list-of-alternatives-input.ffg ================================================ # This verifies that you can unify list elements of different types using a # union [ Left 1, Right true ] ================================================ FILE: tasty/data/complex/list-of-alternatives-output.ffg ================================================ [ Left 1, Right true ] ================================================ FILE: tasty/data/complex/list-of-alternatives-type.ffg ================================================ forall (a : Alternatives) . List < Left: Natural | Right: Bool | a > ================================================ FILE: tasty/data/complex/list-unequal-length-input.ffg ================================================ # This verifies that `==` returns `false` for lists of unequal length [ 2 ] == [ ] ================================================ FILE: tasty/data/complex/list-unequal-length-output.ffg ================================================ false ================================================ FILE: tasty/data/complex/list-unequal-length-type.ffg ================================================ Bool ================================================ FILE: tasty/data/complex/merge-multiple-input.ffg ================================================ # This checks that the type-checker correctly infers that the input type of the # `X` handler is `Natural`, by working backwards from the result type of the `Y` # handler fold { X: \x -> x, Y: \_ -> 2 } ================================================ FILE: tasty/data/complex/merge-multiple-output.ffg ================================================ fold { "X": \x -> x, "Y": \_ -> 2 } ================================================ FILE: tasty/data/complex/merge-multiple-type.ffg ================================================ forall (a : Type) . < X: Natural | Y: a > -> Natural ================================================ FILE: tasty/data/complex/merge-optional-input.ffg ================================================ let toNatural : Optional Natural -> Natural = fold { some: \x -> x, null: 0 } in { example0: toNatural [ ].0 , example1: toNatural [ 1 ].0 } ================================================ FILE: tasty/data/complex/merge-optional-output.ffg ================================================ { "example0": 0, "example1": 1 } ================================================ FILE: tasty/data/complex/merge-optional-type.ffg ================================================ { example0: Natural, example1: Natural } ================================================ FILE: tasty/data/complex/minus-natural-input.ffg ================================================ 2 - 3 ================================================ FILE: tasty/data/complex/minus-natural-output.ffg ================================================ -1 ================================================ FILE: tasty/data/complex/minus-natural-type.ffg ================================================ Integer ================================================ FILE: tasty/data/complex/modulus-input.ffg ================================================ { naturals: map (\n -> (n : Natural) % 3) [ 0, 1, 2, 3 ] , integers: map (\n -> (n : Integer) % 3) [ -3, -2, -1, 0, 1, 2, 3 ] , reals: map (\n -> (n : Real) % 3) [ -3.1, -3, -2.9, -0.1, 0, 0.1, 2.9, 3, 3.1 ] } ================================================ FILE: tasty/data/complex/modulus-output.ffg ================================================ { "naturals": [ { "quotient": 0, "remainder": 0 } , { "quotient": 0, "remainder": 1 } , { "quotient": 0, "remainder": 2 } , { "quotient": 1, "remainder": 0 } ] , "integers": [ { "quotient": -1, "remainder": 0 } , { "quotient": -1, "remainder": 1 } , { "quotient": -1, "remainder": 2 } , { "quotient": 0, "remainder": 0 } , { "quotient": 0, "remainder": 1 } , { "quotient": 0, "remainder": 2 } , { "quotient": 1, "remainder": 0 } ] , "reals": [ { "quotient": -2, "remainder": 2.9 } , { "quotient": -1, "remainder": 0.0 } , { "quotient": -1, "remainder": 0.1 } , { "quotient": -1, "remainder": 2.9 } , { "quotient": 0, "remainder": 0.0 } , { "quotient": 0, "remainder": 0.1 } , { "quotient": 0, "remainder": 2.9 } , { "quotient": 1, "remainder": 0.0 } , { "quotient": 1, "remainder": 0.1 } ] } ================================================ FILE: tasty/data/complex/modulus-type.ffg ================================================ { naturals: List { quotient: Natural, remainder: Natural } , integers: List { quotient: Integer, remainder: Natural } , reals: List { quotient: Integer, remainder: Real } } ================================================ FILE: tasty/data/complex/nested-arithmetic-input.ffg ================================================ 1 + 2 * 3 + (4 * 5 + 1) + ( 6 + 2 * 2 ) ================================================ FILE: tasty/data/complex/nested-arithmetic-output.ffg ================================================ 38 ================================================ FILE: tasty/data/complex/nested-arithmetic-type.ffg ================================================ Natural ================================================ FILE: tasty/data/complex/nested-constructor-input.ffg ================================================ # This verifies that multiple occurrences of the same constructor (e.g. `C` in # this example) are not necessarily treated as belonging to the same union type \x -> C (C x) ================================================ FILE: tasty/data/complex/nested-constructor-output.ffg ================================================ \x -> C (C x) ================================================ FILE: tasty/data/complex/nested-constructor-type.ffg ================================================ forall (a : Type) . forall (b : Alternatives) . forall (c : Alternatives) . a -> < C: < C: a | b > | c > ================================================ FILE: tasty/data/complex/nested-fields-input.ffg ================================================ # This test checks to see that fields variables are inferred three levels deep \x -> x.a.b.c ================================================ FILE: tasty/data/complex/nested-fields-output.ffg ================================================ \x -> x.a.b.c ================================================ FILE: tasty/data/complex/nested-fields-type.ffg ================================================ forall (a : Type) . forall (b : Fields) . forall (c : Fields) . forall (d : Fields) . { a: { b: { c: a, b }, c }, d } -> a ================================================ FILE: tasty/data/complex/nested-let-input.ffg ================================================ let f (x: Text) = let y = x in y in f "" ================================================ FILE: tasty/data/complex/nested-let-output.ffg ================================================ "" ================================================ FILE: tasty/data/complex/nested-let-type.ffg ================================================ Text ================================================ FILE: tasty/data/complex/numeric-subtyping-input.ffg ================================================ # This verifies that list subtyping works in the presence of a type annotation { example0: [ 1, -1 ] : List Integer , example1: [ 1, -1, 1.1 ] : List Real } ================================================ FILE: tasty/data/complex/numeric-subtyping-output.ffg ================================================ { "example0": [ 1, -1 ], "example1": [ 1.0, -1.0, 1.1 ] } ================================================ FILE: tasty/data/complex/numeric-subtyping-type.ffg ================================================ { example0: List Integer, example1: List Real } ================================================ FILE: tasty/data/complex/optional-fields-input.ffg ================================================ # This verifies that the idiom of unifying present/absent fields using # `Optional` types works [ { x: 1 }, { y: true } ] : List { x: Optional Natural, y: Optional Bool } ================================================ FILE: tasty/data/complex/optional-fields-output.ffg ================================================ [ { "x": some 1, "y": null }, { "y": some true, "x": null } ] ================================================ FILE: tasty/data/complex/optional-fields-type.ffg ================================================ List { x: Optional Natural, y: Optional Bool } ================================================ FILE: tasty/data/complex/package-input.ffg ================================================ # This checks that anonymous unions work for a realistic example [ GitHub { repository: "https://github.com/Gabriel439/Haskell-Turtle-Library.git" , revision: "ae5edf227b515b34c1cb6c89d9c58ea0eece12d5" } , Local { relativePath: "~/proj/optparse-applicative" } , Local { relativePath: "~/proj/discrimination" } , Hackage { package: "lens", version: "4.15.4" } , GitHub { repository: "https://github.com/haskell/text.git" , revision: "ccbfabedea1cf5b38ff19f37549feaf01225e537" } , Local { relativePath: "~/proj/servant-swagger" } , Hackage { package: "aeson", version: "1.2.3.0" } ] : List < Local : { relativePath : Text } | GitHub : { repository : Text, revision : Text } | Hackage : { package : Text, version : Text } > ================================================ FILE: tasty/data/complex/package-output.ffg ================================================ [ GitHub { "repository": "https://github.com/Gabriel439/Haskell-Turtle-Library.git" , "revision": "ae5edf227b515b34c1cb6c89d9c58ea0eece12d5" } , Local{ "relativePath": "~/proj/optparse-applicative" } , Local{ "relativePath": "~/proj/discrimination" } , Hackage{ "package": "lens", "version": "4.15.4" } , GitHub { "repository": "https://github.com/haskell/text.git" , "revision": "ccbfabedea1cf5b38ff19f37549feaf01225e537" } , Local{ "relativePath": "~/proj/servant-swagger" } , Hackage{ "package": "aeson", "version": "1.2.3.0" } ] ================================================ FILE: tasty/data/complex/package-type.ffg ================================================ List < Local: { relativePath: Text } | GitHub: { repository: Text, revision: Text } | Hackage: { package: Text, version: Text } > ================================================ FILE: tasty/data/complex/pattern-input.ffg ================================================ let match = fold { C0 x: x , C1 bool: Text: if bool then "true" else "false" , C2 (text: Text): text , C3 (number: Natural): Text: show number , C4 { x, y : Natural }: Text: show (x + y) } in map match [ C0 "a", C1 false, C2 "b", C3 2, C4 { x: 3, y: 5 } ] ================================================ FILE: tasty/data/complex/pattern-output.ffg ================================================ [ "a", "false", "b", "2", "8" ] ================================================ FILE: tasty/data/complex/pattern-type.ffg ================================================ List Text ================================================ FILE: tasty/data/complex/polymorphic-instantiation-input.ffg ================================================ # This test illustrates a type variable being instantiated a more specific # type without impredicative polymorphism let f : forall (a : Type) . a -> a = \x -> x # Carefully note the `forall (c : Type)` has to be floated out for this to work. # If the type annotation were: # # (forall (b : Type) . b -> b) -> (forall (c : Type) . c -> c) # # … then that would require impredicative polymorphism let g : forall (c : Type) . (forall (b : Type) . b -> b) -> (c -> c) = f in { } ================================================ FILE: tasty/data/complex/polymorphic-instantiation-output.ffg ================================================ { } ================================================ FILE: tasty/data/complex/polymorphic-instantiation-type.ffg ================================================ { } ================================================ FILE: tasty/data/complex/polymorphic-let-input.ffg ================================================ # This verifies that a type with a polymorphic type annotation can be # instantiated to multiple types within the same expression let id : forall (a : Type) . a -> a = \x -> x in { example0: id true , example1: id { } } ================================================ FILE: tasty/data/complex/polymorphic-let-output.ffg ================================================ { "example0": true, "example1": { } } ================================================ FILE: tasty/data/complex/polymorphic-let-type.ffg ================================================ { example0: Bool, example1: { } } ================================================ FILE: tasty/data/complex/polymorphic-subsumption-input.ffg ================================================ # This checks that a polymorphic type is a subtype of a corresponding # instantiated monomorphic type ((\x -> x) : forall (a : Type) . a -> a) : Bool -> Bool ================================================ FILE: tasty/data/complex/polymorphic-subsumption-output.ffg ================================================ \x -> x ================================================ FILE: tasty/data/complex/polymorphic-subsumption-type.ffg ================================================ Bool -> Bool ================================================ FILE: tasty/data/complex/potpourri-input.ffg ================================================ # This checks a modestly interesting type inference puzzle \f -> \x -> f (x.a [ x.b, x.c ]) ================================================ FILE: tasty/data/complex/potpourri-output.ffg ================================================ \f x -> f (x.a [ x.b, x.c ]) ================================================ FILE: tasty/data/complex/potpourri-type.ffg ================================================ forall (a : Type) . forall (b : Type) . forall (c : Type) . forall (d : Fields) . (c -> a) -> { a: List b -> c, b: b, c: b, d } -> a ================================================ FILE: tasty/data/complex/predicative-null-input.ffg ================================================ # This ensures that `null`'s type is inferred as `Optional a?` where `a?` is an # unsolved type variable, instead of `forall (a : Type) . Optional a`, since # the latter type would lead to a type error due to relying on impredicativity. \x -> [ null, x ] ================================================ FILE: tasty/data/complex/predicative-null-output.ffg ================================================ \x -> [ null, x ] ================================================ FILE: tasty/data/complex/predicative-null-type.ffg ================================================ forall (a : Type) . Optional a -> List (Optional a) ================================================ FILE: tasty/data/complex/prelude-input.ffg ================================================ ../../../prelude/package.ffg ================================================ FILE: tasty/data/complex/prelude-output.ffg ================================================ { "bool": { "and": fold { "cons": \x y -> x && y, "nil": true } , "not": \b -> b == false , "or": fold { "cons": \x y -> x || y, "nil": false } } , "real": { "product": fold { "cons": \x y -> x * y : Real, "nil": 1.0 } , "sum": fold { "cons": \x y -> x + y : Real, "nil": 0.0 } } , "integer": { "clamp": \n -> if (n : Real) < 0.0 then 0 else abs n , "product": fold { "cons": \x y -> x * y : Integer, "nil": 1 } , "sum": fold { "cons": \x y -> x + y : Integer, "nil": 0 } , "toNatural": \n -> if (n : Real) < 0.0 then null else some (abs n) } , "list": { "all": \predicate -> fold { "cons": \element result -> predicate element && result , "nil": true } , "any": \predicate -> fold { "cons": \element result -> predicate element || result , "nil": false } , "concat": \lists -> for list of lists for element of list in element , "generate": let replicate = \n x -> fold { "succ": \xs -> [ x ] + xs, "zero": [ ] } n in \n f -> map (\x -> f x.index) (indexed (replicate n { })) , "null": \xs -> length xs == 0 , "reject": \f -> fold { "cons": \x xs -> if f x then xs else [ x ] + xs, "nil": [ ] } , "replicate": \n x -> fold { "succ": \xs -> [ x ] + xs, "zero": [ ] } n , "select": \f -> fold { "cons": \x xs -> if f x then [ x ] + xs else xs, "nil": [ ] } } , "natural": { "product": fold { "cons": \x y -> x * y : Natural, "nil": 1 } , "sum": fold { "cons": \x y -> x + y : Natural, "nil": 0 } } , "text": { "concat": fold { "cons": \x y -> x + y : Text, "nil": "" } , "concatMap": \f -> fold { "cons": \x y -> f x + y, "nil": "" } , "concatMapSep": let concatSep = \separator -> \(xs : List Text) -> let status = fold { "cons": \element -> fold { "null": some element , "some": \result -> some (element + separator + result) } , "nil": null } xs in fold { "null": "", "some": \result -> result } status in \separator f xs -> concatSep separator (map f xs) , "concatSep": \separator -> \(xs : List Text) -> let status = fold { "cons": \element -> fold { "null": some element , "some": \result -> some (element + separator + result) } , "nil": null } xs in fold { "null": "", "some": \result -> result } status } } ================================================ FILE: tasty/data/complex/prelude-type.ffg ================================================ forall (a : Type) . forall (b : Type) . forall (c : Type) . forall (d : Type) . forall (e : Type) . forall (f : Type) . forall (g : Type) . forall (h : Type) . forall (i : Type) . forall (j : Type) . { bool: { and: List Bool -> Bool, not: Bool -> Bool, or: List Bool -> Bool } , real: { product: List Real -> Real, sum: List Real -> Real } , integer: { clamp: Integer -> Natural , product: List Integer -> Integer , sum: List Integer -> Integer , toNatural: Integer -> Optional Natural } , list: { all: (j -> Bool) -> List j -> Bool , any: (i -> Bool) -> List i -> Bool , concat: List (List h) -> List h , generate: Natural -> (Natural -> g) -> List g , null: List f -> Bool , reject: (e -> Bool) -> List e -> List e , replicate: Natural -> d -> List d , select: (c -> Bool) -> List c -> List c } , natural: { product: List Natural -> Natural, sum: List Natural -> Natural } , text: { concat: List Text -> Text , concatMap: (b -> Text) -> List b -> Text , concatMapSep: Text -> (a -> Text) -> List a -> Text , concatSep: Text -> List Text -> Text } } ================================================ FILE: tasty/data/complex/preserve-row-input.ffg ================================================ # This verifies that type inference correctly detects that the input and # output record should have the same fields variable \x -> let y = x.a && x.b in x ================================================ FILE: tasty/data/complex/preserve-row-output.ffg ================================================ \x -> let y = x.a && x.b in x ================================================ FILE: tasty/data/complex/preserve-row-type.ffg ================================================ forall (a : Fields) . { a: Bool, b: Bool, a } -> { a: Bool, b: Bool, a } ================================================ FILE: tasty/data/complex/principle-of-explosion-input.ffg ================================================ # This is the Grace encoding of the "principle of explosion": # # https://en.wikipedia.org/wiki/Principle_of_explosion fold { } : forall (a : Type) . < > -> a ================================================ FILE: tasty/data/complex/principle-of-explosion-output.ffg ================================================ fold { } ================================================ FILE: tasty/data/complex/principle-of-explosion-type.ffg ================================================ forall (a : Type) . < > -> a ================================================ FILE: tasty/data/complex/quantifiers-input.ffg ================================================ let x : forall (a : Type) (b : Type) . { } = { } in x ================================================ FILE: tasty/data/complex/quantifiers-output.ffg ================================================ { } ================================================ FILE: tasty/data/complex/quantifiers-type.ffg ================================================ { } ================================================ FILE: tasty/data/complex/quoted-label-input.ffg ================================================ let .'The Identity Function' .'Function Argument' = .'Function Argument' in .'The Identity Function' 1 ================================================ FILE: tasty/data/complex/quoted-label-output.ffg ================================================ 1 ================================================ FILE: tasty/data/complex/quoted-label-type.ffg ================================================ Natural ================================================ FILE: tasty/data/complex/read-input.ffg ================================================ (read "{ \"x\": 1 }").x ================================================ FILE: tasty/data/complex/read-output.ffg ================================================ 1 ================================================ FILE: tasty/data/complex/read-type.ffg ================================================ JSON ================================================ FILE: tasty/data/complex/record-mismatch-both-extra-input.ffg ================================================ [ { x: 1 }, { y: 1 } ] ================================================ FILE: tasty/data/complex/record-mismatch-both-extra-output.ffg ================================================ [ { "x": some 1, "y": null }, { "y": some 1, "x": null } ] ================================================ FILE: tasty/data/complex/record-mismatch-both-extra-type.ffg ================================================ List { x: Optional Natural, y: Optional Natural } ================================================ FILE: tasty/data/complex/record-mismatch-left-extra-input.ffg ================================================ [ { x: 1 }, { } ] ================================================ FILE: tasty/data/complex/record-mismatch-left-extra-output.ffg ================================================ [ { "x": some 1 }, { "x": null } ] ================================================ FILE: tasty/data/complex/record-mismatch-left-extra-type.ffg ================================================ List { x: Optional Natural } ================================================ FILE: tasty/data/complex/record-mismatch-right-extra-input.ffg ================================================ [ { }, { x: 1 } ] ================================================ FILE: tasty/data/complex/record-mismatch-right-extra-output.ffg ================================================ [ { "x": null }, { "x": some 1 } ] ================================================ FILE: tasty/data/complex/record-mismatch-right-extra-type.ffg ================================================ List { x: Optional Natural } ================================================ FILE: tasty/data/complex/record-mismatch-two-extra-input.ffg ================================================ [ { x: 1, y: 2 }, { } ] ================================================ FILE: tasty/data/complex/record-mismatch-two-extra-output.ffg ================================================ [ { "x": some 1, "y": some 2 }, { "x": null, "y": null } ] ================================================ FILE: tasty/data/complex/record-mismatch-two-extra-type.ffg ================================================ List { x: Optional Natural, y: Optional Natural } ================================================ FILE: tasty/data/complex/remote-transitive-import-input.ffg ================================================ # This test verifies that transitive relative imports work for remote imports https://gist.githubusercontent.com/Gabriella439/c092e646209d638ba34d74f7b08c91e3/raw/de5741f2ca5a9ddd118b6e4e91f7d3f571466c52/x.ffg ================================================ FILE: tasty/data/complex/remote-transitive-import-output.ffg ================================================ 1 ================================================ FILE: tasty/data/complex/remote-transitive-import-type.ffg ================================================ Natural ================================================ FILE: tasty/data/complex/restrict-project-input.ffg ================================================ # This should return `null` and have type `forall (a : Type) . Optional a` # because restricting the underlying record value to the empty record type # deletes all the fields. ({ x: 1 } : { }).x ================================================ FILE: tasty/data/complex/restrict-project-output.ffg ================================================ null ================================================ FILE: tasty/data/complex/restrict-project-type.ffg ================================================ forall (a : Type) . Optional a ================================================ FILE: tasty/data/complex/separators-input.ffg ================================================ # This test verifies that trailing and leading separators are supported { example0: [ , 1, 2, 3, ] , example1: { , x: 1, y: true, } , example2: (\x -> x) : forall (a : Fields) . { , x : Integer, y: Bool, a, } -> { , x : Integer, y: Bool, a, } , example3: \x -> x : < | A : Natural | B : Bool | > , example4: (\x -> x) : forall (a : Alternatives) . < | A : Natural | B : Bool | a | > -> < | A : Natural | B : Bool | a | > } ================================================ FILE: tasty/data/complex/separators-output.ffg ================================================ { "example0": [ 1, 2, 3 ] , "example1": { "x": 1, "y": true } , "example2": \x -> x , "example3": \x -> x : < A: Natural | B: Bool > , "example4": \x -> x } ================================================ FILE: tasty/data/complex/separators-type.ffg ================================================ forall (a : Alternatives) . forall (b : Fields) . { example0: List Natural , example1: { x: Natural, y: Bool } , example2: { x: Integer, y: Bool, b } -> { x: Integer, y: Bool, b } , example3: < A: Natural | B: Bool > -> < A: Natural | B: Bool > , example4: < A: Natural | B: Bool | a > -> < A: Natural | B: Bool | a > } ================================================ FILE: tasty/data/complex/show-input.ffg ================================================ show { bool: true , list: [ 2, 3, 5 ] , null: null } ================================================ FILE: tasty/data/complex/show-output.ffg ================================================ "{\"bool\":true,\"list\":[2,3,5],\"null\":null}" ================================================ FILE: tasty/data/complex/show-type.ffg ================================================ Text ================================================ FILE: tasty/data/complex/skolem-function-type-input.ffg ================================================ # The following test exercises the case where a universally quantified variable # cannot necessarily be treated as a function type let f : forall (a : Type) . a -> a = \x -> x 1 in f ================================================ FILE: tasty/data/complex/skolem-function-type-stderr.txt ================================================ Not necessarily a function type The following type variable: a … could potentially be any type and is not necessarily a function type. tasty/data/complex/skolem-function-type-input.ffg:3:29: │ 3 │ let f : forall (a : Type) . a -> a = \x -> x 1 in f │ ↑ ================================================ FILE: tasty/data/complex/slice-input.ffg ================================================ let list = [ 2, 3, 5, 7, 11, 13, 17 ] in { "slicing an empty list always return null": [][:] , "otherwise, [:] returns the entire list": list[:] , "[:] is equivalent to [0:0]": list[0:0] , "[n:n] returns the entire list starting and ending at element n": list[3:3] , "[m:n] returns the mth element up to and not including the mth element": list[3:5] , "[n:] drops the first n elements of the list": list[3:] , "[n:] is equivalent to [n:0]": list[3:0] , "[:-n] drops the last n elements of the list": list[:-3] , "[:n] is equivalent to [0:n]": list[0:-3] , "slice indices do not need to be in order": list[5:3] , "both slice indices can be negative": list[-3:-1] , "both slice indices can be past the end of the list": list[8:10] } ================================================ FILE: tasty/data/complex/slice-output.ffg ================================================ { "slicing an empty list always return null": null , "otherwise, [:] returns the entire list": some [ 2, 3, 5, 7, 11, 13, 17 ] , "[:] is equivalent to [0:0]": some [ 2, 3, 5, 7, 11, 13, 17 ] , "[n:n] returns the entire list starting and ending at element n": some [ 7, 11, 13, 17, 2, 3, 5 ] , "[m:n] returns the mth element up to and not including the mth element": some [ 7, 11 ] , "[n:] drops the first n elements of the list": some [ 7, 11, 13, 17 ] , "[n:] is equivalent to [n:0]": some [ 7, 11, 13, 17 ] , "[:-n] drops the last n elements of the list": some [ 2, 3, 5, 7 ] , "[:n] is equivalent to [0:n]": some [ 2, 3, 5, 7 ] , "slice indices do not need to be in order": some [ 13, 17, 2, 3, 5 ] , "both slice indices can be negative": some [ 11, 13 ] , "both slice indices can be past the end of the list": some [ 3, 5 ] } ================================================ FILE: tasty/data/complex/slice-type.ffg ================================================ forall (a : Type) . { "slicing an empty list always return null": Optional (List a) , "otherwise, [:] returns the entire list": Optional (List Natural) , "[:] is equivalent to [0:0]": Optional (List Natural) , "[n:n] returns the entire list starting and ending at element n": Optional (List Natural) , "[m:n] returns the mth element up to and not including the mth element": Optional (List Natural) , "[n:] drops the first n elements of the list": Optional (List Natural) , "[n:] is equivalent to [n:0]": Optional (List Natural) , "[:-n] drops the last n elements of the list": Optional (List Natural) , "[:n] is equivalent to [0:n]": Optional (List Natural) , "slice indices do not need to be in order": Optional (List Natural) , "both slice indices can be negative": Optional (List Natural) , "both slice indices can be past the end of the list": Optional (List Natural) } ================================================ FILE: tasty/data/complex/solve-fields-input.ffg ================================================ # The purpose of this test is to exercise instantiation of unsolved fields # variables \r -> \s -> let _ = [ r.x, 1 ] let _ = [ s.y, 1 ] in { a: [ r, { x: 1, z: 1 } ], b: [ { y: 1, z: 1 }, s ] } ================================================ FILE: tasty/data/complex/solve-fields-output.ffg ================================================ \r -> \s -> let _ = [ r.x, 1 ] let _ = [ s.y, 1 ] in { "a": [ r, { "x": 1, "z": 1 } ], "b": [ { "y": 1, "z": 1 }, s ] } ================================================ FILE: tasty/data/complex/solve-fields-type.ffg ================================================ { x: Natural, z: Natural } -> { y: Natural, z: Natural } -> { a: List { x: Natural, z: Natural }, b: List { y: Natural, z: Natural } } ================================================ FILE: tasty/data/complex/solve-unused-impredicative-polymorphism-input.ffg ================================================ # This test exercises solving a variable to a valid impredicative type \x -> x : List (forall (a : Type) . Bool) ================================================ FILE: tasty/data/complex/solve-unused-impredicative-polymorphism-output.ffg ================================================ \x -> x : List (forall (a : Type) . Bool) ================================================ FILE: tasty/data/complex/solve-unused-impredicative-polymorphism-type.ffg ================================================ List Bool -> List Bool ================================================ FILE: tasty/data/complex/subtype-function-input.ffg ================================================ (\(x : Integer) -> x) : Natural -> Integer ================================================ FILE: tasty/data/complex/subtype-function-output.ffg ================================================ \a -> (\(x : Integer) -> x) (a : Integer) ================================================ FILE: tasty/data/complex/subtype-function-type.ffg ================================================ Natural -> Integer ================================================ FILE: tasty/data/complex/triple-field-input.ffg ================================================ # This is a regression test for an expression that used to break the # type-checker's support for row polymorphism \x -> x.a && x.b && x.c ================================================ FILE: tasty/data/complex/triple-field-output.ffg ================================================ \x -> x.a && x.b && x.c ================================================ FILE: tasty/data/complex/triple-field-type.ffg ================================================ forall (a : Fields) . { a: Bool, b: Bool, c: Bool, a } -> Bool ================================================ FILE: tasty/data/complex/triple-supertype-input.ffg ================================================ # This test ensures that a supertype of 3 or more values doesn't wrap optional # fields in more than one layer of `Optional`. The expected type should be # # List { x: Optional Natural, y: Optional Natural, z: Optional Natural } # # … and not something like: # # List # { x: Optional (Optional Natural) # , y: Optional (Optional Natural) # , z: Optional Natural # } # # More generally, getting this correct ensures that the most-specific supertype # operation is associative and commutative. [ { x: 1 }, { y: 1 }, { z: 1 } ] ================================================ FILE: tasty/data/complex/triple-supertype-output.ffg ================================================ [ { "x": some 1, "y": null, "z": null } , { "y": some 1, "x": null, "z": null } , { "z": some 1, "x": null, "y": null } ] ================================================ FILE: tasty/data/complex/triple-supertype-type.ffg ================================================ List { x: Optional Natural, y: Optional Natural, z: Optional Natural } ================================================ FILE: tasty/data/complex/unbound-alternatives-variable-input.ffg ================================================ # This test exercises the error message for unbound alternatives variables Left 1 : < Left : Natural | a > ================================================ FILE: tasty/data/complex/unbound-alternatives-variable-stderr.txt ================================================ Unbound alternatives variable: a tasty/data/complex/unbound-alternatives-variable-input.ffg:2:10: │ 2 │ Left 1 : < Left : Natural | a > │ ↑ ================================================ FILE: tasty/data/complex/unbound-fields-variable-input.ffg ================================================ # This test exercises the error message for unbound fields variables { } : { a } ================================================ FILE: tasty/data/complex/unbound-fields-variable-stderr.txt ================================================ Unbound fields variable: a tasty/data/complex/unbound-fields-variable-input.ffg:2:7: │ 2 │ { } : { a } │ ↑ ================================================ FILE: tasty/data/complex/undo-elaboration-input.ffg ================================================ # This is a regression test for: # # https://github.com/Gabriella439/grace/pull/175#issuecomment-3449878560 let { x = 0, y } = { x: 1, y: 2 } in x + y ================================================ FILE: tasty/data/complex/undo-elaboration-output.ffg ================================================ 3 ================================================ FILE: tasty/data/complex/undo-elaboration-type.ffg ================================================ Natural ================================================ FILE: tasty/data/complex/unify-json-input.ffg ================================================ # The purpose of this test is to exercise the JSON subtyping rules \(x : JSON) -> [ x, "hi", [ 1, 2 ], some true, { x: "bye" } ] ================================================ FILE: tasty/data/complex/unify-json-output.ffg ================================================ \x -> [ x, "hi", [ 1, 2 ] : JSON, some true, { "x": "bye" } ] ================================================ FILE: tasty/data/complex/unify-json-type.ffg ================================================ JSON -> List JSON ================================================ FILE: tasty/data/complex/unify-null-input.ffg ================================================ # This test illustrates that you can unify `null` with other types so long as # you provide a type annotation, since the interpreter will automatically wrap # the non-`null` values with a `some` in the course of interpretation (and then # strip the `some` in the final result) [ null, 1 ] : List (Optional Natural) ================================================ FILE: tasty/data/complex/unify-null-output.ffg ================================================ [ null, some 1 ] ================================================ FILE: tasty/data/complex/unify-null-type.ffg ================================================ List (Optional Natural) ================================================ FILE: tasty/data/complex/unify-unsolved-input.ffg ================================================ # Exercise unsolved variables for certain unification code paths \r s x -> let a = r.x let b = s.y let c = L 1 let d = R true in { example0: [ r, s ] , example1: [ r, r ] , example2: [ c, d ] , example3: [ c, c ] , example4: [ x, x ] } ================================================ FILE: tasty/data/complex/unify-unsolved-output.ffg ================================================ \r -> \s -> \x -> let a = r.x let b = s.y let c = L 1 let d = R true in { "example0": [ r, s ] , "example1": [ r, r ] , "example2": [ c, d ] , "example3": [ c, c ] , "example4": [ x, x ] } ================================================ FILE: tasty/data/complex/unify-unsolved-type.ffg ================================================ forall (a : Type) . forall (b : Alternatives) . forall (c : Type) . forall (d : Type) . forall (e : Fields) . { x: d, y: c, e } -> { y: c, x: d, e } -> a -> { example0: List { x: d, y: c, e } , example1: List { x: d, y: c, e } , example2: List < L: Natural | R: Bool | b > , example3: List < L: Natural | R: Bool | b > , example4: List a } ================================================ FILE: tasty/data/complex/unused-impredicative-polymorphism-input.ffg ================================================ # This test exercises impredicative polymorphism that is unused, which is the # only case where impredicative polymorphism is permitted. [ true ] : List (forall (a : Type) . Bool) ================================================ FILE: tasty/data/complex/unused-impredicative-polymorphism-output.ffg ================================================ [ true ] ================================================ FILE: tasty/data/complex/unused-impredicative-polymorphism-type.ffg ================================================ List (forall (a : Type) . Bool) ================================================ FILE: tasty/data/complex/unused-polymorphism-input.ffg ================================================ # This exercises the <:∀R rule of the type inference algorithm { x: true } : { x: forall (a : Type) . Bool } ================================================ FILE: tasty/data/complex/unused-polymorphism-output.ffg ================================================ { "x": true } ================================================ FILE: tasty/data/complex/unused-polymorphism-type.ffg ================================================ { x: forall (a : Type) . Bool } ================================================ FILE: tasty/data/complex/use-equation-input.ffg ================================================ # This test exercises weird code paths for the `equate*` unification utilities \a -> \r -> \b -> \u -> let # This forces `r`'s type to be instantiated to a record with an unsolved # fields variable field0 = [ true, r.x ] in { # This triggers instantiation of `a`'s unsolved type to a record type with # an unsolved fields variable field1: [ r, a ] # This triggers instantiation of `b`'s unsolved type to a union type with # an unsolved alternatives variable , field2: [ L 1, b ] } ================================================ FILE: tasty/data/complex/use-equation-output.ffg ================================================ \a -> \r -> \b -> \u -> let field0 = [ true, r.x ] in { "field1": [ r, a ], "field2": [ L 1, b ] } ================================================ FILE: tasty/data/complex/use-equation-type.ffg ================================================ forall (a : Alternatives) . forall (b : Fields) . forall (c : Type) . { x: Bool, b } -> { x: Bool, b } -> < L: Natural | a > -> c -> { field1: List { x: Bool, b }, field2: List < L: Natural | a > } ================================================ FILE: tasty/data/complex/well-formed-input.ffg ================================================ # The purpose of this test is to exercise weird code paths for the well-formed # type check { example0: (\r -> r) : forall (a : Fields) . forall (b : Type) . { a } -> { a } , example1: (\u -> u) : forall (a : Alternatives) . forall (b : Type) . < a > -> < a > } ================================================ FILE: tasty/data/complex/well-formed-output.ffg ================================================ { "example0": \r -> r, "example1": \u -> u } ================================================ FILE: tasty/data/complex/well-formed-type.ffg ================================================ forall (a : Alternatives) . forall (b : Fields) . { example0: { b } -> { b }, example1: < a > -> < a > } ================================================ FILE: tasty/data/complex/yaml-input.ffg ================================================ yaml { multiline: "ab\ncd\n" , elements: [ 1, 2, 3 ] , bool: true , real: -2.3 } ================================================ FILE: tasty/data/complex/yaml-output.ffg ================================================ " 'bool': true 'elements': - 1 - 2 - 3 'multiline': | ab cd 'real': -2.3 " ================================================ FILE: tasty/data/complex/yaml-type.ffg ================================================ Text ================================================ FILE: tasty/data/error/for-naked-input.ffg ================================================ for x of 1 in x ================================================ FILE: tasty/data/error/for-naked-stderr.txt ================================================ Not a subtype The following type: Natural tasty/data/error/for-naked-input.ffg:1:10: │ 1 │ for x of 1 in x │ ↑ … is not a subtype of: List a? tasty/data/error/for-naked-input.ffg:1:1: │ 1 │ for x of 1 in x │ ↑ ================================================ FILE: tasty/data/error/parse/eof-input.ffg ================================================ [ ================================================ FILE: tasty/data/error/parse/eof-stderr.txt ================================================ tasty/data/error/parse/eof-input.ffg:2:1: Invalid input - Parsing failed │ 2 │ │ ↑ ================================================ FILE: tasty/data/error/parse/incomplete-escape-input.ffg ================================================ "\ " ================================================ FILE: tasty/data/error/parse/incomplete-escape-stderr.txt ================================================ tasty/data/error/parse/incomplete-escape-input.ffg:1:2: Invalid input - Lexing failed │ 1 │ "\ " │ ↑ ================================================ FILE: tasty/data/error/parse/incomplete-interpolation-input.ffg ================================================ "a${"b" +}d" ================================================ FILE: tasty/data/error/parse/incomplete-interpolation-stderr.txt ================================================ tasty/data/error/parse/incomplete-interpolation-input.ffg:1:10: Invalid input - Lexing failed │ 1 │ "a${"b" +}d" │ ↑ ================================================ FILE: tasty/data/error/parse/incomplete-string-input.ffg ================================================ "a${"b" + "c"} ================================================ FILE: tasty/data/error/parse/incomplete-string-stderr.txt ================================================ tasty/data/error/parse/incomplete-string-input.ffg:1:15: Invalid input - Lexing failed │ 1 │ "a${"b" + "c"} │ ↑ ================================================ FILE: tasty/data/error/parse/invalid-multiline-input.ffg ================================================ "abc " ================================================ FILE: tasty/data/error/parse/invalid-multiline-stderr.txt ================================================ tasty/data/error/parse/invalid-multiline-input.ffg:1:5: Invalid input - Lexing failed │ 1 │ "abc │ ↑ ================================================ FILE: tasty/data/error/parse/unbalanced-bracket-input.ffg ================================================ 1 ] ================================================ FILE: tasty/data/error/parse/unbalanced-bracket-stderr.txt ================================================ tasty/data/error/parse/unbalanced-bracket-input.ffg:1:3: Invalid input - Parsing failed │ 1 │ 1 ] │ ↑ ================================================ FILE: tasty/data/error/parse/unrecognized-symbol-input.ffg ================================================ True & False ================================================ FILE: tasty/data/error/parse/unrecognized-symbol-stderr.txt ================================================ tasty/data/error/parse/unrecognized-symbol-input.ffg:1:7: Invalid input - Lexing failed │ 1 │ True & False │ ↑ ================================================ FILE: tasty/data/error/resolve/empty-environment-variable-input.ffg ================================================ env: ================================================ FILE: tasty/data/error/resolve/empty-environment-variable-stderr.txt ================================================ Import resolution failed: env: Missing path ================================================ FILE: tasty/data/error/resolve/environment-authority-input.ffg ================================================ env://foo/bar ================================================ FILE: tasty/data/error/resolve/environment-authority-stderr.txt ================================================ Import resolution failed: env://foo/bar Unsupported authority ================================================ FILE: tasty/data/error/resolve/environment-leading-slash-input.ffg ================================================ env:/foo ================================================ FILE: tasty/data/error/resolve/environment-leading-slash-stderr.txt ================================================ Import resolution failed: env:/foo Unsupported path separators ================================================ FILE: tasty/data/error/resolve/environment-missing-input.ffg ================================================ env:Eechiqu4sooCoy8aisei ================================================ FILE: tasty/data/error/resolve/environment-missing-stderr.txt ================================================ Import resolution failed: env:Eechiqu4sooCoy8aisei Missing environment variable ================================================ FILE: tasty/data/error/resolve/environment-variable-slash-input.ffg ================================================ env:foo/ ================================================ FILE: tasty/data/error/resolve/environment-variable-slash-stderr.txt ================================================ Import resolution failed: env:foo/ Unsupported path separators ================================================ FILE: tasty/data/error/resolve/file-authority-input.ffg ================================================ file://a/b ================================================ FILE: tasty/data/error/resolve/file-authority-stderr.txt ================================================ Import resolution failed: file://a/b Unsupported authority ================================================ FILE: tasty/data/error/resolve/file-missing-path-input.ffg ================================================ file: ================================================ FILE: tasty/data/error/resolve/file-missing-path-stderr.txt ================================================ Import resolution failed: file: Missing path ================================================ FILE: tasty/data/error/resolve/host-not-found-input.ffg ================================================ https://MaiYohngaz6jiaWieYea ================================================ FILE: tasty/data/error/resolve/host-not-found-stderr.txt ================================================ Import resolution failed: https://maiyohngaz6jiawieyea Remote host not found ================================================ FILE: tasty/data/error/resolve/invalid-destination-host-input.ffg ================================================ http://:80 ================================================ FILE: tasty/data/error/resolve/invalid-destination-host-stderr.txt ================================================ Import resolution failed: http://:80 Invalid remote host name ================================================ FILE: tasty/data/error/resolve/invalid-utf8-input.ffg ================================================ https://raw.githubusercontent.com/dhall-lang/dhall-lang/1907a1d1a6dff9ff8638547f7bc49d6b5135bcdf/tests/parser/success/reservedPrefixB.dhallb ================================================ FILE: tasty/data/error/resolve/invalid-utf8-stderr.txt ================================================ Import resolution failed: https://raw.githubusercontent.com/dhall-lang/dhall-lang/1907a1d1a6dff9ff8638547f7bc49d6b5135bcdf/tests/parser/success/reservedPrefixB.dhallb Not UTF8 Cannot decode byte '\x85': Data.Text.Internal.Encoding: Invalid UTF-8 stream ================================================ FILE: tasty/data/error/resolve/read-invalid-json-input.ffg ================================================ read "{" ================================================ FILE: tasty/data/error/resolve/read-invalid-json-stderr.txt ================================================ Failed to decode output as JSON The following text: { … to decode as JSON. Decoding error message: Error in $: not enough input ================================================ FILE: tasty/data/error/resolve/remote-invalid-parse-input.ffg ================================================ https://raw.githubusercontent.com/Gabriel439/grace/164038e0277c2c9f08c9e4528d493d316e85bb76/README.md ================================================ FILE: tasty/data/error/resolve/remote-invalid-parse-stderr.txt ================================================ https://raw.githubusercontent.com/Gabriel439/grace/164038e0277c2c9f08c9e4528d493d316e85bb76/README.md:11:75: Invalid input - Lexing failed │ 11 │ * You're interested in learning more about state-of-the-art algorithms for │ ↑ ================================================ FILE: tasty/data/error/resolve/remote-referentially-insane-input.ffg ================================================ https://gist.githubusercontent.com/Gabriella439/7dce61ec95e1c38ecf14448eef7dd827/raw/fbb01f2afb0eaa98ea0e1bd1d4bb1e8fe482b081/test.ffg ================================================ FILE: tasty/data/error/resolve/remote-referentially-insane-stderr.txt ================================================ Import resolution failed: https://gist.githubusercontent.com/Gabriella439/7dce61ec95e1c38ecf14448eef7dd827/raw/fbb01f2afb0eaa98ea0e1bd1d4bb1e8fe482b081/test.ffg Local imports are rejected within remote imports Rejected local import: env:FOO ================================================ FILE: tasty/data/error/type/alternatives-variable-input.ffg ================================================ [ Left 1 : forall (a : Alternatives) . < Left: Natural | a > , Right true : forall (b : Alternatives) . < Right: Bool | b > ] ================================================ FILE: tasty/data/error/type/alternatives-variable-stderr.txt ================================================ Alternatives variable mismatch This alternatives variable: a tasty/data/error/type/alternatives-variable-input.ffg:1:40: │ 1 │ [ Left 1 : forall (a : Alternatives) . < Left: Natural | a > │ ↑ … and this alternatives variable: b tasty/data/error/type/alternatives-variable-input.ffg:2:44: │ 2 │ , Right true : forall (b : Alternatives) . < Right: Bool | b > │ ↑ … cannot be unified ================================================ FILE: tasty/data/error/type/bad-type-annotation-input.ffg ================================================ 1 : Text ================================================ FILE: tasty/data/error/type/bad-type-annotation-stderr.txt ================================================ Not a subtype The following type: Natural tasty/data/error/type/bad-type-annotation-input.ffg:1:1: │ 1 │ 1 : Text │ ↑ … is not a subtype of: Text tasty/data/error/type/bad-type-annotation-input.ffg:1:5: │ 1 │ 1 : Text │ ↑ ================================================ FILE: tasty/data/error/type/destructure-missing-required-input.ffg ================================================ let { x: Natural } = { } in x ================================================ FILE: tasty/data/error/type/destructure-missing-required-stderr.txt ================================================ Record type mismatch The following record type: { } tasty/data/error/type/destructure-missing-required-input.ffg:1:22: │ 1 │ let { x: Natural } = { } in x │ ↑ … is not a subtype of the following record type: { x: Natural, b? } tasty/data/error/type/destructure-missing-required-input.ffg:1:5: │ 1 │ let { x: Natural } = { } in x │ ↑ The latter record has the following extra fields: • x ================================================ FILE: tasty/data/error/type/dynamic-scope-input.ffg ================================================ # This is a regression test for: https://github.com/Gabriella439/grace/issues/67 # # This verifies that `let` bindings are lexically scoped let x = (let y = 4 in y) in y ================================================ FILE: tasty/data/error/type/dynamic-scope-stderr.txt ================================================ Unbound variable: y tasty/data/error/type/dynamic-scope-input.ffg:4:29: │ 4 │ let x = (let y = 4 in y) in y │ ↑ ================================================ FILE: tasty/data/error/type/fields-variable-mismatch-input.ffg ================================================ let f : forall (a : Fields) . forall (b : Fields) . { a } -> { b } -> { a } = \x -> \y -> y in f ================================================ FILE: tasty/data/error/type/fields-variable-mismatch-stderr.txt ================================================ Record type mismatch The following record type: { b } tasty/data/error/type/fields-variable-mismatch-input.ffg:1:62: │ 1 │ let f : forall (a : Fields) . forall (b : Fields) . { a } -> { b } -> { a } │ ↑ … is not a subtype of the following record type: { a } tasty/data/error/type/fields-variable-mismatch-input.ffg:1:71: │ 1 │ let f : forall (a : Fields) . forall (b : Fields) . { a } -> { b } -> { a } │ ↑ ================================================ FILE: tasty/data/error/type/fold-missing-field-input.ffg ================================================ # `fold`s can in some cases tolerate missing fields. For example, this is a # valid `fold`: # # fold{ succ x: x } # # … which elaborates to: # # fold{ succ x: x, zero: null } : forall (a : Type) . Natural -> Optional a # # … but you cannot do it the other way around (keep `zero` and omit the `succ`), # because it is not a valid `fold` no matter how you interpret it. If you # attempt to interpret it as a `fold` for `Natural` numbers the expression is # elaborated to: # # fold{ succ: null, zero: 0 } # # … which doesn't work because the `succ` handler needs to be a function (and # `null` is not a function). However, it also doesn't work if you fall back to # treating it as a fold for a union, because a fold for a union requires all # handlers to be functions (and `0` is not a function). fold{ zero: 0 } ================================================ FILE: tasty/data/error/type/fold-missing-field-stderr.txt ================================================ Record type mismatch The following record type: { } tasty/data/error/type/fold-missing-field-input.ffg:21:5: │ 21 │ fold{ zero: 0 } │ ↑ … is not a subtype of the following record type: { succ: Natural -> Natural } tasty/data/error/type/fold-missing-field-input.ffg:21:1: │ 21 │ fold{ zero: 0 } │ ↑ The latter record has the following extra fields: • succ ================================================ FILE: tasty/data/error/type/fold-typo-field-input.ffg ================================================ # If at least one field is recognized as belonging to a reserved `fold` (e.g. # the `false` field belongs to the reserved `fold` for `Bool`s) then other # unexpected fields (e.g. a typo) will be rejected by the type checker. fold{ false: 0, tru: 1 } ================================================ FILE: tasty/data/error/type/fold-typo-field-stderr.txt ================================================ Not a function type An expression of the following type: Natural tasty/data/error/type/fold-typo-field-input.ffg:4:14: │ 4 │ fold{ false: 0, tru: 1 } │ ↑ … was invoked as if it were a function, but the above type is not a function type. ================================================ FILE: tasty/data/error/type/for-annotation-input.ffg ================================================ (for x of [] in x + 1) : List Text ================================================ FILE: tasty/data/error/type/for-annotation-stderr.txt ================================================ Not a subtype The following type: Natural tasty/data/error/type/for-annotation-input.ffg:1:21: │ 1 │ (for x of [] in x + 1) : List Text │ ↑ … is not a subtype of: Text tasty/data/error/type/for-annotation-input.ffg:1:31: │ 1 │ (for x of [] in x + 1) : List Text │ ↑ ================================================ FILE: tasty/data/error/type/for-mixed-input.ffg ================================================ for x of [ 1, 2, 3 ] for y of some 4 in x + y ================================================ FILE: tasty/data/error/type/for-mixed-stderr.txt ================================================ Not a subtype The following type: Optional Natural tasty/data/error/type/for-mixed-input.ffg:3:10: │ 3 │ for y of some 4 │ ↑ … is not a subtype of: List Natural tasty/data/error/type/for-mixed-input.ffg:3:1: │ 3 │ for y of some 4 │ ↑ ================================================ FILE: tasty/data/error/type/impredicative-instantiation-input.ffg ================================================ # This test verifies that impredicative instantiation of polymorphic types is # not permitted let f : forall (a : Type) . a -> a = \x -> x let g : (forall (b : Type) . b -> b) -> (forall (c : Type) . c -> c) = f in g ================================================ FILE: tasty/data/error/type/impredicative-instantiation-stderr.txt ================================================ Unbound type variable: b tasty/data/error/type/impredicative-instantiation-input.ffg:6:30: │ 6 │ let g : (forall (b : Type) . b -> b) -> (forall (c : Type) . c -> c) │ ↑ ================================================ FILE: tasty/data/error/type/impredicative-polymorphism-input.ffg ================================================ [ \x -> x ] : List (forall (a : Type) . a -> a) ================================================ FILE: tasty/data/error/type/impredicative-polymorphism-output.ffg ================================================ [ \x -> x ] ================================================ FILE: tasty/data/error/type/impredicative-polymorphism-type.ffg ================================================ List (forall (a : Type) . a -> a) ================================================ FILE: tasty/data/error/type/index-slice-input.ffg ================================================ # This should fail because a slice returns an `Optional` [{ }][0:].0 ================================================ FILE: tasty/data/error/type/index-slice-stderr.txt ================================================ Not a subtype The following type: Optional (List { }) tasty/data/error/type/index-slice-input.ffg:2:1: │ 2 │ [{ }][0:].0 │ ↑ … is not a subtype of: List a? tasty/data/error/type/index-slice-input.ffg:2:1: │ 2 │ [{ }][0:].0 │ ↑ ================================================ FILE: tasty/data/error/type/invalid-argument-input.ffg ================================================ let f (x : Natural) = x in f "" ================================================ FILE: tasty/data/error/type/invalid-argument-stderr.txt ================================================ Not a subtype The following type: Text tasty/data/error/type/invalid-argument-input.ffg:3:7: │ 3 │ in f "" │ ↑ … is not a subtype of: Natural tasty/data/error/type/invalid-argument-input.ffg:1:12: │ 1 │ let f (x : Natural) = x │ ↑ ================================================ FILE: tasty/data/error/type/invalid-handler-input.ffg ================================================ fold { x: 1 } ================================================ FILE: tasty/data/error/type/invalid-handler-stderr.txt ================================================ Not a function type An expression of the following type: Natural tasty/data/error/type/invalid-handler-input.ffg:1:11: │ 1 │ fold { x: 1 } │ ↑ … was invoked as if it were a function, but the above type is not a function type. ================================================ FILE: tasty/data/error/type/invalid-plus-annotation-input.ffg ================================================ # This exercises the failing case for checking an addition (true + true) : Bool ================================================ FILE: tasty/data/error/type/invalid-plus-annotation-stderr.txt ================================================ Invalid operands You cannot add the following operands: tasty/data/error/type/invalid-plus-annotation-input.ffg:2:2: │ 2 │ (true + true) : Bool │ ↑ tasty/data/error/type/invalid-plus-annotation-input.ffg:2:9: │ 2 │ (true + true) : Bool │ ↑ ================================================ FILE: tasty/data/error/type/invalid-plus-operands-input.ffg ================================================ # This test exercises the error message if you add invalid types true + true ================================================ FILE: tasty/data/error/type/invalid-plus-operands-stderr.txt ================================================ Invalid operands You cannot add the following operands: tasty/data/error/type/invalid-plus-operands-input.ffg:2:1: │ 2 │ true + true │ ↑ tasty/data/error/type/invalid-plus-operands-input.ffg:2:8: │ 2 │ true + true │ ↑ ================================================ FILE: tasty/data/error/type/invalid-times-annotation-input.ffg ================================================ # This exercises the failing case for checking a multiplication (true * true) : Bool ================================================ FILE: tasty/data/error/type/invalid-times-annotation-stderr.txt ================================================ Invalid operands You cannot multiply the following operands: tasty/data/error/type/invalid-times-annotation-input.ffg:2:2: │ 2 │ (true * true) : Bool │ ↑ tasty/data/error/type/invalid-times-annotation-input.ffg:2:9: │ 2 │ (true * true) : Bool │ ↑ ================================================ FILE: tasty/data/error/type/invalid-times-operands-input.ffg ================================================ # This test exercises the error message if you multiply invalid types true * true ================================================ FILE: tasty/data/error/type/invalid-times-operands-stderr.txt ================================================ Invalid operands You cannot multiply the following operands: tasty/data/error/type/invalid-times-operands-input.ffg:2:1: │ 2 │ true * true │ ↑ tasty/data/error/type/invalid-times-operands-input.ffg:2:8: │ 2 │ true * true │ ↑ ================================================ FILE: tasty/data/error/type/merge-wrong-type-input.ffg ================================================ fold 1 ================================================ FILE: tasty/data/error/type/merge-wrong-type-stderr.txt ================================================ Not a subtype The following type: Natural tasty/data/error/type/merge-wrong-type-input.ffg:1:6: │ 1 │ fold 1 │ ↑ … is not a subtype of: { a? } tasty/data/error/type/merge-wrong-type-input.ffg:1:1: │ 1 │ fold 1 │ ↑ ================================================ FILE: tasty/data/error/type/missing-required-field-input.ffg ================================================ { x: 1 }.y : Bool ================================================ FILE: tasty/data/error/type/missing-required-field-stderr.txt ================================================ Record type mismatch The following record type: { x: Natural } tasty/data/error/type/missing-required-field-input.ffg:1:1: │ 1 │ { x: 1 }.y : Bool │ ↑ … is not a subtype of the following record type: { y: Bool, b? } tasty/data/error/type/missing-required-field-input.ffg:1:10: │ 1 │ { x: 1 }.y : Bool │ ↑ The latter record has the following extra fields: • y ================================================ FILE: tasty/data/error/type/modulus-abstract-input.ffg ================================================ let f x = 3 % x in f 0 ================================================ FILE: tasty/data/error/type/modulus-abstract-stderr.txt ================================================ Divisor must be concrete You must divide by a concrete (non-abstract) numeric literal: tasty/data/error/type/modulus-abstract-input.ffg:1:15: │ 1 │ let f x = 3 % x │ ↑ ================================================ FILE: tasty/data/error/type/modulus-zero-input.ffg ================================================ 3 % 0 ================================================ FILE: tasty/data/error/type/modulus-zero-stderr.txt ================================================ Zero divisor You cannot divide a number by zero: tasty/data/error/type/modulus-zero-input.ffg:1:5: │ 1 │ 3 % 0 │ ↑ ================================================ FILE: tasty/data/error/type/non-singular-pattern-input.ffg ================================================ fold { A x y: x && y } (A true false) ================================================ FILE: tasty/data/error/type/non-singular-pattern-stderr.txt ================================================ Not a function type An expression of the following type: < A: Bool | g? > tasty/data/error/type/non-singular-pattern-input.ffg:1:25: │ 1 │ fold { A x y: x && y } (A true false) │ ↑ … was invoked as if it were a function, but the above type is not a function type. ================================================ FILE: tasty/data/error/type/not-a-function-input.ffg ================================================ 1 1 ================================================ FILE: tasty/data/error/type/not-a-function-stderr.txt ================================================ Not a function type An expression of the following type: Natural tasty/data/error/type/not-a-function-input.ffg:1:1: │ 1 │ 1 1 │ ↑ … was invoked as if it were a function, but the above type is not a function type. ================================================ FILE: tasty/data/error/type/occurs-alternatives-input.ffg ================================================ # This test exercises the occurs check for alternatives variables \x -> [ x, C x ] ================================================ FILE: tasty/data/error/type/occurs-alternatives-stderr.txt ================================================ No supertype The following two types: a? tasty/data/error/type/occurs-alternatives-input.ffg:2:2: │ 2 │ \x -> [ x, C x ] │ ↑ < C: a? | c? > tasty/data/error/type/occurs-alternatives-input.ffg:2:12: │ 2 │ \x -> [ x, C x ] │ ↑ … have no shared supertype. ================================================ FILE: tasty/data/error/type/occurs-type-backwards-input.ffg ================================================ # This test exercises the occurs check when the subtype occurs in the supertype \f -> \x -> [ f, f x ] ================================================ FILE: tasty/data/error/type/occurs-type-backwards-stderr.txt ================================================ No supertype The following two types: e? -> f? tasty/data/error/type/occurs-type-backwards-input.ffg:2:2: │ 2 │ \f -> \x -> [ f, f x ] │ ↑ f? tasty/data/error/type/occurs-type-backwards-input.ffg:2:2: │ 2 │ \f -> \x -> [ f, f x ] │ ↑ … have no shared supertype. ================================================ FILE: tasty/data/error/type/occurs-type-input.ffg ================================================ # This test exercises the occurs check for type variables \x -> x x ================================================ FILE: tasty/data/error/type/occurs-type-stderr.txt ================================================ Not a subtype The following type: c? -> d? tasty/data/error/type/occurs-type-input.ffg:2:2: │ 2 │ \x -> x x │ ↑ … is not a subtype of: c? tasty/data/error/type/occurs-type-input.ffg:2:2: │ 2 │ \x -> x x │ ↑ ================================================ FILE: tasty/data/error/type/pattern-input.ffg ================================================ { f (x : Natural): Text: x } ================================================ FILE: tasty/data/error/type/pattern-stderr.txt ================================================ Not a subtype The following type: Natural tasty/data/error/type/pattern-input.ffg:1:10: │ 1 │ { f (x : Natural): Text: x } │ ↑ … is not a subtype of: Text tasty/data/error/type/pattern-input.ffg:1:20: │ 1 │ { f (x : Natural): Text: x } │ ↑ ================================================ FILE: tasty/data/error/type/pin-fields-variable-input.ffg ================================================ # This verifies that two record types cannot unify if they share the same # fields variable but different monomorphic fields let f : forall (a : Fields) . { a } -> { x : Bool, a } = \x -> x in f ================================================ FILE: tasty/data/error/type/pin-fields-variable-stderr.txt ================================================ Record type mismatch The following record type: { a } tasty/data/error/type/pin-fields-variable-input.ffg:3:31: │ 3 │ let f : forall (a : Fields) . { a } -> { x : Bool, a } │ ↑ … is not a subtype of the following record type: { x: Bool, a } tasty/data/error/type/pin-fields-variable-input.ffg:3:40: │ 3 │ let f : forall (a : Fields) . { a } -> { x : Bool, a } │ ↑ The latter record has the following extra fields: • x ================================================ FILE: tasty/data/error/type/read-fail-input.ffg ================================================ # Grace's support for "eval" is type-safe, so the following example will fail let not x = import read "x == false" in not 4 ================================================ FILE: tasty/data/error/type/read-fail-stderr.txt ================================================ No supertype The following two types: Natural tasty/data/error/type/read-fail-input.ffg:4:9: │ 4 │ in not 4 │ ↑ Bool (read):1:6: │ 1 │ x == false │ ↑ … have no shared supertype. ================================================ FILE: tasty/data/error/type/read-input.ffg ================================================ read "[ 1, 2, 3 ]" : List Text ================================================ FILE: tasty/data/error/type/read-stderr.txt ================================================ Not a subtype The following type: Natural (json):1:1: │ 1 │ 1 │ ↑ … is not a subtype of: Text tasty/data/error/type/read-input.ffg:1:27: │ 1 │ read "[ 1, 2, 3 ]" : List Text │ ↑ ================================================ FILE: tasty/data/error/type/show-key-input.ffg ================================================ show ("skproj-…" : Key) ================================================ FILE: tasty/data/error/type/show-key-stderr.txt ================================================ Not a subtype of JSON The following type: Key tasty/data/error/type/show-key-input.ffg:1:20: │ 1 │ show ("skproj-…" : Key) │ ↑ … is not a subtype of JSON. ================================================ FILE: tasty/data/error/type/subtype-function-input.ffg ================================================ (\(x : Natural) -> x) : Integer -> Natural ================================================ FILE: tasty/data/error/type/subtype-function-stderr.txt ================================================ Not a subtype The following type: Integer tasty/data/error/type/subtype-function-input.ffg:1:25: │ 1 │ (\(x : Natural) -> x) : Integer -> Natural │ ↑ … is not a subtype of: Natural tasty/data/error/type/subtype-function-input.ffg:1:8: │ 1 │ (\(x : Natural) -> x) : Integer -> Natural │ ↑ ================================================ FILE: tasty/data/error/type/type-mismatch-input.ffg ================================================ 1 + true ================================================ FILE: tasty/data/error/type/type-mismatch-stderr.txt ================================================ Invalid operands You cannot add the following operands: tasty/data/error/type/type-mismatch-input.ffg:1:1: │ 1 │ 1 + true │ ↑ tasty/data/error/type/type-mismatch-input.ffg:1:5: │ 1 │ 1 + true │ ↑ ================================================ FILE: tasty/data/error/type/unbound-input.ffg ================================================ x ================================================ FILE: tasty/data/error/type/unbound-stderr.txt ================================================ Unbound variable: x tasty/data/error/type/unbound-input.ffg:1:1: │ 1 │ x │ ↑ ================================================ FILE: tasty/data/error/type/unbound-type-input.ffg ================================================ let f (x : a) : a = x in f ================================================ FILE: tasty/data/error/type/unbound-type-stderr.txt ================================================ Unbound type variable: a tasty/data/error/type/unbound-type-input.ffg:1:12: │ 1 │ let f (x : a) : a = x │ ↑ ================================================ FILE: tasty/data/error/type/union-mismatch-both-extra-input.ffg ================================================ \x -> (x : < A : { } >) : < B : { } > ================================================ FILE: tasty/data/error/type/union-mismatch-both-extra-stderr.txt ================================================ Union type mismatch The following union type: < A: { } > tasty/data/error/type/union-mismatch-both-extra-input.ffg:1:12: │ 1 │ \x -> (x : < A : { } >) : < B : { } > │ ↑ … is not a subtype of the following union type: < B: { } > tasty/data/error/type/union-mismatch-both-extra-input.ffg:1:27: │ 1 │ \x -> (x : < A : { } >) : < B : { } > │ ↑ The former union has the following extra alternatives: • A ================================================ FILE: tasty/data/error/type/union-mismatch-left-extra-input.ffg ================================================ \x -> (x : < A : { } >) : < > ================================================ FILE: tasty/data/error/type/union-mismatch-left-extra-stderr.txt ================================================ Union type mismatch The following union type: < A: { } > tasty/data/error/type/union-mismatch-left-extra-input.ffg:1:12: │ 1 │ \x -> (x : < A : { } >) : < > │ ↑ … is not a subtype of the following union type: < > tasty/data/error/type/union-mismatch-left-extra-input.ffg:1:27: │ 1 │ \x -> (x : < A : { } >) : < > │ ↑ The former union has the following extra alternatives: • A ================================================ FILE: tasty/data/error/type/union-mismatch-right-extra-input.ffg ================================================ \x -> (x : < >) : < A : { } > ================================================ FILE: tasty/data/error/type/union-mismatch-right-extra-output.ffg ================================================ \x -> x : < A: { } > ================================================ FILE: tasty/data/error/type/union-mismatch-right-extra-type.ffg ================================================ < > -> < A: { } > ================================================ FILE: tasty/data/error/type/union-variable-mismatch-input.ffg ================================================ let f : forall (a : Alternatives) . forall (b : Alternatives) . < a > -> < b > -> < a > = \x -> \y -> y in f ================================================ FILE: tasty/data/error/type/union-variable-mismatch-stderr.txt ================================================ Union type mismatch The following union type: < b > tasty/data/error/type/union-variable-mismatch-input.ffg:1:74: │ 1 │ let f : forall (a : Alternatives) . forall (b : Alternatives) . < a > -> < b > -> < a > │ ↑ … is not a subtype of the following union type: < a > tasty/data/error/type/union-variable-mismatch-input.ffg:1:83: │ 1 │ let f : forall (a : Alternatives) . forall (b : Alternatives) . < a > -> < b > -> < a > │ ↑ ================================================ FILE: tasty/data/error/type/variable-mismatch-input.ffg ================================================ let f : forall (a : Type) . forall (b : Type) . a -> b -> a = \x -> \y -> y in f ================================================ FILE: tasty/data/error/type/variable-mismatch-stderr.txt ================================================ Not a subtype The following type: b tasty/data/error/type/variable-mismatch-input.ffg:1:54: │ 1 │ let f : forall (a : Type) . forall (b : Type) . a -> b -> a │ ↑ … is not a subtype of: a tasty/data/error/type/variable-mismatch-input.ffg:1:59: │ 1 │ let f : forall (a : Type) . forall (b : Type) . a -> b -> a │ ↑ ================================================ FILE: tasty/data/json/colors-input.ffg ================================================ # https://www.sitepoint.com/colors-json-example/ # # Note that the example from the above page is not valid JSON (due to a # trailing comma) ./colors.json : { colors: List { color: Text , category: Text , code: { rgba: List Natural, hex: Text } , type: Optional Text } } ================================================ FILE: tasty/data/json/colors-output.ffg ================================================ { "colors": [ { "color": "black" , "category": "hue" , "type": some "primary" , "code": { "rgba": [ 255, 255, 255, 1 ], "hex": "#000" } } , { "color": "white" , "category": "value" , "code": { "rgba": [ 0, 0, 0, 1 ], "hex": "#FFF" } , "type": null } , { "color": "red" , "category": "hue" , "type": some "primary" , "code": { "rgba": [ 255, 0, 0, 1 ], "hex": "#FF0" } } , { "color": "blue" , "category": "hue" , "type": some "primary" , "code": { "rgba": [ 0, 0, 255, 1 ], "hex": "#00F" } } , { "color": "yellow" , "category": "hue" , "type": some "primary" , "code": { "rgba": [ 255, 255, 0, 1 ], "hex": "#FF0" } } , { "color": "green" , "category": "hue" , "type": some "secondary" , "code": { "rgba": [ 0, 255, 0, 1 ], "hex": "#0F0" } } ] } ================================================ FILE: tasty/data/json/colors-type.ffg ================================================ { colors: List { color: Text , category: Text , code: { rgba: List Natural, hex: Text } , type: Optional Text } } ================================================ FILE: tasty/data/json/colors.json ================================================ { "colors": [ { "color": "black", "category": "hue", "type": "primary", "code": { "rgba": [255,255,255,1], "hex": "#000" } }, { "color": "white", "category": "value", "code": { "rgba": [0,0,0,1], "hex": "#FFF" } }, { "color": "red", "category": "hue", "type": "primary", "code": { "rgba": [255,0,0,1], "hex": "#FF0" } }, { "color": "blue", "category": "hue", "type": "primary", "code": { "rgba": [0,0,255,1], "hex": "#00F" } }, { "color": "yellow", "category": "hue", "type": "primary", "code": { "rgba": [255,255,0,1], "hex": "#FF0" } }, { "color": "green", "category": "hue", "type": "secondary", "code": { "rgba": [0,255,0,1], "hex": "#0F0" } }, ] } ================================================ FILE: tasty/data/json/geoip-input.ffg ================================================ # https://www.sitepoint.com/geoip-json-example ./geoip.json ================================================ FILE: tasty/data/json/geoip-output.ffg ================================================ { "as": "AS16509 Amazon.com, Inc." , "city": "Boardman" , "country": "United States" , "countryCode": "US" , "isp": "Amazon" , "lat": 45.8696 , "lon": -119.688 , "org": "Amazon" , "query": "54.148.84.95" , "region": "OR" , "regionName": "Oregon" , "status": "success" , "timezone": "America/Los_Angeles" , "zip": "97818" } ================================================ FILE: tasty/data/json/geoip-type.ffg ================================================ { as: Text , city: Text , country: Text , countryCode: Text , isp: Text , lat: Real , lon: Real , org: Text , query: Text , region: Text , regionName: Text , status: Text , timezone: Text , zip: Text } ================================================ FILE: tasty/data/json/geoip.json ================================================ { "as": "AS16509 Amazon.com, Inc.", "city": "Boardman", "country": "United States", "countryCode": "US", "isp": "Amazon", "lat": 45.8696, "lon": -119.688, "org": "Amazon", "query": "54.148.84.95", "region": "OR", "regionName": "Oregon", "status": "success", "timezone": "America\/Los_Angeles", "zip": "97818" } ================================================ FILE: tasty/data/json/glossary-input.ffg ================================================ # https://json.org/example.html ./glossary.json ================================================ FILE: tasty/data/json/glossary-output.ffg ================================================ { "glossary": { "title": "example glossary" , "GlossDiv": { "title": "S" , "GlossList": { "GlossEntry": { "ID": "SGML" , "SortAs": "SGML" , "GlossTerm": "Standard Generalized Markup Language" , "Acronym": "SGML" , "Abbrev": "ISO 8879:1986" , "GlossDef": { "para": "A meta-markup language, used to create markup languages such as DocBook." , "GlossSeeAlso": [ "GML", "XML" ] } , "GlossSee": "markup" } } } } } ================================================ FILE: tasty/data/json/glossary-type.ffg ================================================ { glossary: { title: Text , "GlossDiv": { title: Text , "GlossList": { "GlossEntry": { "ID": Text , "SortAs": Text , "GlossTerm": Text , "Acronym": Text , "Abbrev": Text , "GlossDef": { para: Text, "GlossSeeAlso": List Text } , "GlossSee": Text } } } } } ================================================ FILE: tasty/data/json/glossary.json ================================================ { "glossary": { "title": "example glossary", "GlossDiv": { "title": "S", "GlossList": { "GlossEntry": { "ID": "SGML", "SortAs": "SGML", "GlossTerm": "Standard Generalized Markup Language", "Acronym": "SGML", "Abbrev": "ISO 8879:1986", "GlossDef": { "para": "A meta-markup language, used to create markup languages such as DocBook.", "GlossSeeAlso": ["GML", "XML"] }, "GlossSee": "markup" } } } } } ================================================ FILE: tasty/data/json/markers-input.ffg ================================================ # https://www.sitepoint.com/google-maps-json-file/ # # Note that the example from the above page is not valid JSON (due to a trailing # comma) ./markers.json : { markers : List { name : Text, location: Optional (List Real), position: Optional (List Real) } } ================================================ FILE: tasty/data/json/markers-output.ffg ================================================ { "markers": [ { "name": "Rixos The Palm Dubai" , "position": some [ 25.1212, 55.1535 ] , "location": null } , { "name": "Shangri-La Hotel" , "location": some [ 25.2084, 55.2719 ] , "position": null } , { "name": "Grand Hyatt" , "location": some [ 25.2285, 55.3273 ] , "position": null } ] } ================================================ FILE: tasty/data/json/markers-type.ffg ================================================ { markers: List { name: Text , location: Optional (List Real) , position: Optional (List Real) } } ================================================ FILE: tasty/data/json/markers.json ================================================ { "markers": [ { "name": "Rixos The Palm Dubai", "position": [25.1212, 55.1535], }, { "name": "Shangri-La Hotel", "location": [25.2084, 55.2719] }, { "name": "Grand Hyatt", "location": [25.2285, 55.3273] } ] } ================================================ FILE: tasty/data/json/menu-input.ffg ================================================ # https://json.org/example.html ./menu.json ================================================ FILE: tasty/data/json/menu-output.ffg ================================================ { "menu": { "id": "file" , "value": "File" , "popup": { "menuitem": [ { "value": "New", "onclick": "CreateNewDoc()" } , { "value": "Open", "onclick": "OpenDoc()" } , { "value": "Close", "onclick": "CloseDoc()" } ] } } } ================================================ FILE: tasty/data/json/menu-type.ffg ================================================ { menu: { id: Text , value: Text , popup: { menuitem: List { value: Text, onclick: Text } } } } ================================================ FILE: tasty/data/json/menu.json ================================================ {"menu": { "id": "file", "value": "File", "popup": { "menuitem": [ {"value": "New", "onclick": "CreateNewDoc()"}, {"value": "Open", "onclick": "OpenDoc()"}, {"value": "Close", "onclick": "CloseDoc()"} ] } }} ================================================ FILE: tasty/data/json/menu2-input.ffg ================================================ ./menu2.json : { menu: { header: Text , items: List (Optional { id: Text, label: Optional Text }) } } ================================================ FILE: tasty/data/json/menu2-output.ffg ================================================ { "menu": { "header": "SVG Viewer" , "items": [ some { "id": "Open", "label": null } , some { "id": "OpenNew", "label": some "Open New" } , null , some { "id": "ZoomIn", "label": some "Zoom In" } , some { "id": "ZoomOut", "label": some "Zoom Out" } , some { "id": "OriginalView", "label": some "Original View" } , null , some { "id": "Quality", "label": null } , some { "id": "Pause", "label": null } , some { "id": "Mute", "label": null } , null , some { "id": "Find", "label": some "Find..." } , some { "id": "FindAgain", "label": some "Find Again" } , some { "id": "Copy", "label": null } , some { "id": "CopyAgain", "label": some "Copy Again" } , some { "id": "CopySVG", "label": some "Copy SVG" } , some { "id": "ViewSVG", "label": some "View SVG" } , some { "id": "ViewSource", "label": some "View Source" } , some { "id": "SaveAs", "label": some "Save As" } , null , some { "id": "Help", "label": null } , some { "id": "About", "label": some "About Adobe CVG Viewer..." } ] } } ================================================ FILE: tasty/data/json/menu2-type.ffg ================================================ { menu: { header: Text, items: List (Optional { id: Text, label: Optional Text }) } } ================================================ FILE: tasty/data/json/menu2.json ================================================ {"menu": { "header": "SVG Viewer", "items": [ {"id": "Open"}, {"id": "OpenNew", "label": "Open New"}, null, {"id": "ZoomIn", "label": "Zoom In"}, {"id": "ZoomOut", "label": "Zoom Out"}, {"id": "OriginalView", "label": "Original View"}, null, {"id": "Quality"}, {"id": "Pause"}, {"id": "Mute"}, null, {"id": "Find", "label": "Find..."}, {"id": "FindAgain", "label": "Find Again"}, {"id": "Copy"}, {"id": "CopyAgain", "label": "Copy Again"}, {"id": "CopySVG", "label": "Copy SVG"}, {"id": "ViewSVG", "label": "View SVG"}, {"id": "ViewSource", "label": "View Source"}, {"id": "SaveAs", "label": "Save As"}, null, {"id": "Help"}, {"id": "About", "label": "About Adobe CVG Viewer..."} ] }} ================================================ FILE: tasty/data/json/numbers-input.ffg ================================================ # https://opensource.adobe.com/Spry/samples/data_region/JSONDataSetSample.html ./numbers.json ================================================ FILE: tasty/data/json/numbers-output.ffg ================================================ [ 100, 500, 300, 200, 400 ] ================================================ FILE: tasty/data/json/numbers-type.ffg ================================================ List Natural ================================================ FILE: tasty/data/json/numbers.json ================================================ [ 100, 500, 300, 200, 400 ] ================================================ FILE: tasty/data/json/people-input.ffg ================================================ # https://www.sitepoint.com/test-data-json-example/ ./people.json ================================================ FILE: tasty/data/json/people-output.ffg ================================================ { "clients": [ { "id": "59761c23b30d971669fb42ff" , "isActive": true , "age": 36 , "name": "Dunlap Hubbard" , "gender": "male" , "company": "CEDWARD" , "email": "dunlaphubbard@cedward.com" , "phone": "+1 (890) 543-2508" , "address": "169 Rutledge Street, Konterra, Northern Mariana Islands, 8551" } , { "id": "59761c233d8d0f92a6b0570d" , "isActive": true , "age": 24 , "name": "Kirsten Sellers" , "gender": "female" , "company": "EMERGENT" , "email": "kirstensellers@emergent.com" , "phone": "+1 (831) 564-2190" , "address": "886 Gallatin Place, Fannett, Arkansas, 4656" } , { "id": "59761c23fcb6254b1a06dad5" , "isActive": true , "age": 30 , "name": "Acosta Robbins" , "gender": "male" , "company": "ORGANICA" , "email": "acostarobbins@organica.com" , "phone": "+1 (882) 441-3367" , "address": "697 Linden Boulevard, Sattley, Idaho, 1035" } ] } ================================================ FILE: tasty/data/json/people-type.ffg ================================================ { clients: List { id: Text , isActive: Bool , age: Natural , name: Text , gender: Text , company: Text , email: Text , phone: Text , address: Text } } ================================================ FILE: tasty/data/json/people.json ================================================ { "clients": [ { "id": "59761c23b30d971669fb42ff", "isActive": true, "age": 36, "name": "Dunlap Hubbard", "gender": "male", "company": "CEDWARD", "email": "dunlaphubbard@cedward.com", "phone": "+1 (890) 543-2508", "address": "169 Rutledge Street, Konterra, Northern Mariana Islands, 8551" }, { "id": "59761c233d8d0f92a6b0570d", "isActive": true, "age": 24, "name": "Kirsten Sellers", "gender": "female", "company": "EMERGENT", "email": "kirstensellers@emergent.com", "phone": "+1 (831) 564-2190", "address": "886 Gallatin Place, Fannett, Arkansas, 4656" }, { "id": "59761c23fcb6254b1a06dad5", "isActive": true, "age": 30, "name": "Acosta Robbins", "gender": "male", "company": "ORGANICA", "email": "acostarobbins@organica.com", "phone": "+1 (882) 441-3367", "address": "697 Linden Boulevard, Sattley, Idaho, 1035" } ] } ================================================ FILE: tasty/data/json/products-input.ffg ================================================ # https://www.sitepoint.com/database-json-file/ ./products.json ================================================ FILE: tasty/data/json/products-output.ffg ================================================ [ { "_id": { "$oid": "5968dd23fc13ae04d9000001" } , "product_name": "sildenafil citrate" , "supplier": "Wisozk Inc" , "quantity": 261 , "unit_cost": "$10.47" } , { "_id": { "$oid": "5968dd23fc13ae04d9000002" } , "product_name": "Mountain Juniperus ashei" , "supplier": "Keebler-Hilpert" , "quantity": 292 , "unit_cost": "$8.74" } , { "_id": { "$oid": "5968dd23fc13ae04d9000003" } , "product_name": "Dextromathorphan HBr" , "supplier": "Schmitt-Weissnat" , "quantity": 211 , "unit_cost": "$20.53" } ] ================================================ FILE: tasty/data/json/products-type.ffg ================================================ List { _id: { "$oid": Text } , product_name: Text , supplier: Text , quantity: Natural , unit_cost: Text } ================================================ FILE: tasty/data/json/products.json ================================================ [{ "_id": { "$oid": "5968dd23fc13ae04d9000001" }, "product_name": "sildenafil citrate", "supplier": "Wisozk Inc", "quantity": 261, "unit_cost": "$10.47" }, { "_id": { "$oid": "5968dd23fc13ae04d9000002" }, "product_name": "Mountain Juniperus ashei", "supplier": "Keebler-Hilpert", "quantity": 292, "unit_cost": "$8.74" }, { "_id": { "$oid": "5968dd23fc13ae04d9000003" }, "product_name": "Dextromathorphan HBr", "supplier": "Schmitt-Weissnat", "quantity": 211, "unit_cost": "$20.53" }] ================================================ FILE: tasty/data/json/recipes-input.ffg ================================================ # https://opensource.adobe.com/Spry/samples/data_region/JSONDataSetSample.html ./recipes.json ================================================ FILE: tasty/data/json/recipes-output.ffg ================================================ [ { "id": "0001" , "type": "donut" , "name": "Cake" , "ppu": 0.55 , "batters": { "batter": [ { "id": "1001", "type": "Regular" } , { "id": "1002", "type": "Chocolate" } , { "id": "1003", "type": "Blueberry" } , { "id": "1004", "type": "Devil's Food" } ] } , "topping": [ { "id": "5001", "type": "None" } , { "id": "5002", "type": "Glazed" } , { "id": "5005", "type": "Sugar" } , { "id": "5007", "type": "Powdered Sugar" } , { "id": "5006", "type": "Chocolate with Sprinkles" } , { "id": "5003", "type": "Chocolate" } , { "id": "5004", "type": "Maple" } ] } , { "id": "0002" , "type": "donut" , "name": "Raised" , "ppu": 0.55 , "batters": { "batter": [ { "id": "1001", "type": "Regular" } ] } , "topping": [ { "id": "5001", "type": "None" } , { "id": "5002", "type": "Glazed" } , { "id": "5005", "type": "Sugar" } , { "id": "5003", "type": "Chocolate" } , { "id": "5004", "type": "Maple" } ] } , { "id": "0003" , "type": "donut" , "name": "Old Fashioned" , "ppu": 0.55 , "batters": { "batter": [ { "id": "1001", "type": "Regular" } , { "id": "1002", "type": "Chocolate" } ] } , "topping": [ { "id": "5001", "type": "None" } , { "id": "5002", "type": "Glazed" } , { "id": "5003", "type": "Chocolate" } , { "id": "5004", "type": "Maple" } ] } ] ================================================ FILE: tasty/data/json/recipes-type.ffg ================================================ List { id: Text , type: Text , name: Text , ppu: Real , batters: { batter: List { id: Text, type: Text } } , topping: List { id: Text, type: Text } } ================================================ FILE: tasty/data/json/recipes.json ================================================ [ { "id": "0001", "type": "donut", "name": "Cake", "ppu": 0.55, "batters": { "batter": [ { "id": "1001", "type": "Regular" }, { "id": "1002", "type": "Chocolate" }, { "id": "1003", "type": "Blueberry" }, { "id": "1004", "type": "Devil's Food" } ] }, "topping": [ { "id": "5001", "type": "None" }, { "id": "5002", "type": "Glazed" }, { "id": "5005", "type": "Sugar" }, { "id": "5007", "type": "Powdered Sugar" }, { "id": "5006", "type": "Chocolate with Sprinkles" }, { "id": "5003", "type": "Chocolate" }, { "id": "5004", "type": "Maple" } ] }, { "id": "0002", "type": "donut", "name": "Raised", "ppu": 0.55, "batters": { "batter": [ { "id": "1001", "type": "Regular" } ] }, "topping": [ { "id": "5001", "type": "None" }, { "id": "5002", "type": "Glazed" }, { "id": "5005", "type": "Sugar" }, { "id": "5003", "type": "Chocolate" }, { "id": "5004", "type": "Maple" } ] }, { "id": "0003", "type": "donut", "name": "Old Fashioned", "ppu": 0.55, "batters": { "batter": [ { "id": "1001", "type": "Regular" }, { "id": "1002", "type": "Chocolate" } ] }, "topping": [ { "id": "5001", "type": "None" }, { "id": "5002", "type": "Glazed" }, { "id": "5003", "type": "Chocolate" }, { "id": "5004", "type": "Maple" } ] } ] ================================================ FILE: tasty/data/json/server-input.ffg ================================================ # https://www.sitepoint.com/local-rest-json-file/ ./server.json ================================================ FILE: tasty/data/json/server-output.ffg ================================================ { "host": "localhost" , "port": 3030 , "public": "../public/" , "paginate": { "default": 10, "max": 50 } , "mongodb": "mongodb://localhost:27017/api" } ================================================ FILE: tasty/data/json/server-type.ffg ================================================ { host: Text , port: Natural , public: Text , paginate: { default: Natural, max: Natural } , mongodb: Text } ================================================ FILE: tasty/data/json/server.json ================================================ { "host": "localhost", "port": 3030, "public": "../public/", "paginate": { "default": 10, "max": 50 }, "mongodb": "mongodb://localhost:27017/api" } ================================================ FILE: tasty/data/json/twitter-input.ffg ================================================ # https://www.sitepoint.com/twitter-json-example/ # # Note that the example from the above page is not valid JSON (due to a trailing # comma) ./twitter.json ================================================ FILE: tasty/data/json/twitter-output.ffg ================================================ [ { "created_at": "Thu Jun 22 21:00:00 +0000 2017" , "id": 877994604561387500 , "id_str": "877994604561387520" , "text": "Creating a Grocery List Manager Using Angular, Part 1: Add & Display Items https://t.co/xFox78juL1 #Angular" , "truncated": false , "entities": { "hashtags": [ { "text": "Angular", "indices": [ 103, 111 ] } ] , "symbols": [ ] , "user_mentions": [ ] , "urls": [ { "url": "https://t.co/xFox78juL1" , "expanded_url": "http://buff.ly/2sr60pf" , "display_url": "buff.ly/2sr60pf" , "indices": [ 79, 102 ] } ] } , "source": "Buffer" , "user": { "id": 772682964 , "id_str": "772682964" , "name": "SitePoint JavaScript" , "screen_name": "SitePointJS" , "location": "Melbourne, Australia" , "description": "Keep up with JavaScript tutorials, tips, tricks and articles at SitePoint." , "url": "http://t.co/cCH13gqeUK" , "entities": { "url": { "urls": [ { "url": "http://t.co/cCH13gqeUK" , "expanded_url": "https://www.sitepoint.com/javascript" , "display_url": "sitepoint.com/javascript" , "indices": [ 0, 22 ] } ] } , "description": { "urls": [ ] } } , "protected": false , "followers_count": 2145 , "friends_count": 18 , "listed_count": 328 , "created_at": "Wed Aug 22 02:06:33 +0000 2012" , "favourites_count": 57 , "utc_offset": 43200 , "time_zone": "Wellington" } } ] ================================================ FILE: tasty/data/json/twitter-type.ffg ================================================ forall (a : Type) . forall (b : Type) . forall (c : Type) . List { created_at: Text , id: Natural , id_str: Text , text: Text , truncated: Bool , entities: { hashtags: List { text: Text, indices: List Natural } , symbols: List c , user_mentions: List b , urls: List { url: Text , expanded_url: Text , display_url: Text , indices: List Natural } } , source: Text , user: { id: Natural , id_str: Text , name: Text , screen_name: Text , location: Text , description: Text , url: Text , entities: { url: { urls: List { url: Text , expanded_url: Text , display_url: Text , indices: List Natural } } , description: { urls: List a } } , protected: Bool , followers_count: Natural , friends_count: Natural , listed_count: Natural , created_at: Text , favourites_count: Natural , utc_offset: Natural , time_zone: Text } } ================================================ FILE: tasty/data/json/twitter.json ================================================ [{ "created_at": "Thu Jun 22 21:00:00 +0000 2017", "id": 877994604561387500, "id_str": "877994604561387520", "text": "Creating a Grocery List Manager Using Angular, Part 1: Add & Display Items https://t.co/xFox78juL1 #Angular", "truncated": false, "entities": { "hashtags": [{ "text": "Angular", "indices": [103, 111] }], "symbols": [], "user_mentions": [], "urls": [{ "url": "https://t.co/xFox78juL1", "expanded_url": "http://buff.ly/2sr60pf", "display_url": "buff.ly/2sr60pf", "indices": [79, 102] }] }, "source": "Buffer", "user": { "id": 772682964, "id_str": "772682964", "name": "SitePoint JavaScript", "screen_name": "SitePointJS", "location": "Melbourne, Australia", "description": "Keep up with JavaScript tutorials, tips, tricks and articles at SitePoint.", "url": "http://t.co/cCH13gqeUK", "entities": { "url": { "urls": [{ "url": "http://t.co/cCH13gqeUK", "expanded_url": "https://www.sitepoint.com/javascript", "display_url": "sitepoint.com/javascript", "indices": [0, 22] }] }, "description": { "urls": [] } }, "protected": false, "followers_count": 2145, "friends_count": 18, "listed_count": 328, "created_at": "Wed Aug 22 02:06:33 +0000 2012", "favourites_count": 57, "utc_offset": 43200, "time_zone": "Wellington", }, }] ================================================ FILE: tasty/data/json/widget-input.ffg ================================================ # https://json.org/example.html ./widget.json ================================================ FILE: tasty/data/json/widget-output.ffg ================================================ { "widget": { "debug": "on" , "window": { "title": "Sample Konfabulator Widget" , "name": "main_window" , "width": 500 , "height": 500 } , "image": { "src": "Images/Sun.png" , "name": "sun1" , "hOffset": 250 , "vOffset": 250 , "alignment": "center" } , "text": { "data": "Click Here" , "size": 36 , "style": "bold" , "name": "text1" , "hOffset": 250 , "vOffset": 100 , "alignment": "center" , "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;" } } } ================================================ FILE: tasty/data/json/widget-type.ffg ================================================ { widget: { debug: Text , window: { title: Text, name: Text, width: Natural, height: Natural } , image: { src: Text , name: Text , hOffset: Natural , vOffset: Natural , alignment: Text } , text: { data: Text , size: Natural , style: Text , name: Text , hOffset: Natural , vOffset: Natural , alignment: Text , onMouseUp: Text } } } ================================================ FILE: tasty/data/json/widget.json ================================================ {"widget": { "debug": "on", "window": { "title": "Sample Konfabulator Widget", "name": "main_window", "width": 500, "height": 500 }, "image": { "src": "Images/Sun.png", "name": "sun1", "hOffset": 250, "vOffset": 250, "alignment": "center" }, "text": { "data": "Click Here", "size": 36, "style": "bold", "name": "text1", "hOffset": 250, "vOffset": 100, "alignment": "center", "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;" } }} ================================================ FILE: tasty/data/json/youtube-input.ffg ================================================ # https://www.sitepoint.com/youtube-json-example/ ./youtube.json : { kind : Text , etag : Text , nextPageToken : Text , regionCode : Text , pageInfo : { totalResults : Natural, resultsPerPage : Natural } , items : List { kind : Text , etag : Text , id : { kind : Text, channelId: Optional Text, videoId: Optional Text } } } ================================================ FILE: tasty/data/json/youtube-output.ffg ================================================ { "kind": "youtube#searchListResponse" , "etag": "\"m2yskBQFythfE4irbTIeOgYYfBU/PaiEDiVxOyCWelLPuuwa9LKz3Gk\"" , "nextPageToken": "CAUQAA" , "regionCode": "KE" , "pageInfo": { "totalResults": 4249, "resultsPerPage": 5 } , "items": [ { "kind": "youtube#searchResult" , "etag": "\"m2yskBQFythfE4irbTIeOgYYfBU/QpOIr3QKlV5EUlzfFcVvDiJT0hw\"" , "id": { "kind": "youtube#channel" , "channelId": some "UCJowOS1R0FnhipXVqEnYU1A" , "videoId": null } } , { "kind": "youtube#searchResult" , "etag": "\"m2yskBQFythfE4irbTIeOgYYfBU/AWutzVOt_5p1iLVifyBdfoSTf9E\"" , "id": { "kind": "youtube#video" , "videoId": some "Eqa2nAAhHN0" , "channelId": null } } , { "kind": "youtube#searchResult" , "etag": "\"m2yskBQFythfE4irbTIeOgYYfBU/2dIR9BTfr7QphpBuY3hPU-h5u-4\"" , "id": { "kind": "youtube#video" , "videoId": some "IirngItQuVs" , "channelId": null } } ] } ================================================ FILE: tasty/data/json/youtube-type.ffg ================================================ { kind: Text , etag: Text , nextPageToken: Text , regionCode: Text , pageInfo: { totalResults: Natural, resultsPerPage: Natural } , items: List { kind: Text , etag: Text , id: { kind: Text, channelId: Optional Text, videoId: Optional Text } } } ================================================ FILE: tasty/data/json/youtube.json ================================================ { "kind": "youtube#searchListResponse", "etag": "\"m2yskBQFythfE4irbTIeOgYYfBU/PaiEDiVxOyCWelLPuuwa9LKz3Gk\"", "nextPageToken": "CAUQAA", "regionCode": "KE", "pageInfo": { "totalResults": 4249, "resultsPerPage": 5 }, "items": [ { "kind": "youtube#searchResult", "etag": "\"m2yskBQFythfE4irbTIeOgYYfBU/QpOIr3QKlV5EUlzfFcVvDiJT0hw\"", "id": { "kind": "youtube#channel", "channelId": "UCJowOS1R0FnhipXVqEnYU1A" } }, { "kind": "youtube#searchResult", "etag": "\"m2yskBQFythfE4irbTIeOgYYfBU/AWutzVOt_5p1iLVifyBdfoSTf9E\"", "id": { "kind": "youtube#video", "videoId": "Eqa2nAAhHN0" } }, { "kind": "youtube#searchResult", "etag": "\"m2yskBQFythfE4irbTIeOgYYfBU/2dIR9BTfr7QphpBuY3hPU-h5u-4\"", "id": { "kind": "youtube#video", "videoId": "IirngItQuVs" } } ] } ================================================ FILE: tasty/data/true.ffg ================================================ true ================================================ FILE: tasty/data/unit/add-integer-input.ffg ================================================ 1 + -1 ================================================ FILE: tasty/data/unit/add-integer-output.ffg ================================================ 0 ================================================ FILE: tasty/data/unit/add-integer-type.ffg ================================================ Integer ================================================ FILE: tasty/data/unit/alternative-input.ffg ================================================ Foo 1 ================================================ FILE: tasty/data/unit/alternative-output.ffg ================================================ Foo 1 ================================================ FILE: tasty/data/unit/alternative-type.ffg ================================================ forall (a : Alternatives) . < Foo: Natural | a > ================================================ FILE: tasty/data/unit/and-input.ffg ================================================ true && false ================================================ FILE: tasty/data/unit/and-output.ffg ================================================ false ================================================ FILE: tasty/data/unit/and-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/append-list-input.ffg ================================================ [ 2, 3 ] + [ 5, 7 ] ================================================ FILE: tasty/data/unit/append-list-output.ffg ================================================ [ 2, 3, 5, 7 ] ================================================ FILE: tasty/data/unit/append-list-type.ffg ================================================ List Natural ================================================ FILE: tasty/data/unit/append-text-input.ffg ================================================ "a" + "b" ================================================ FILE: tasty/data/unit/append-text-output.ffg ================================================ "ab" ================================================ FILE: tasty/data/unit/append-text-type.ffg ================================================ Text ================================================ FILE: tasty/data/unit/application-input.ffg ================================================ show false ================================================ FILE: tasty/data/unit/application-output.ffg ================================================ "false" ================================================ FILE: tasty/data/unit/application-type.ffg ================================================ Text ================================================ FILE: tasty/data/unit/bool-input.ffg ================================================ true ================================================ FILE: tasty/data/unit/bool-output.ffg ================================================ true ================================================ FILE: tasty/data/unit/bool-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/default-argument-input.ffg ================================================ let f (x = 1) = x in f null ================================================ FILE: tasty/data/unit/default-argument-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/default-argument-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/default-record-argument-input.ffg ================================================ let f { x = 1 } = x in f { } ================================================ FILE: tasty/data/unit/default-record-argument-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/default-record-argument-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/destructure-lambda-input.ffg ================================================ \{ x } -> x ================================================ FILE: tasty/data/unit/destructure-lambda-output.ffg ================================================ \{ x } -> x ================================================ FILE: tasty/data/unit/destructure-lambda-type.ffg ================================================ forall (a : Type) (b : Fields) . { x: a, b } -> a ================================================ FILE: tasty/data/unit/destructure-let-argument-input.ffg ================================================ let f { x } = x in f ================================================ FILE: tasty/data/unit/destructure-let-argument-output.ffg ================================================ \{ x } -> x ================================================ FILE: tasty/data/unit/destructure-let-argument-type.ffg ================================================ forall (a : Type) (b : Fields) . { x: a, b } -> a ================================================ FILE: tasty/data/unit/destructure-record-input.ffg ================================================ let { x } = { x: 1 } in x ================================================ FILE: tasty/data/unit/destructure-record-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/destructure-record-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/divide-input.ffg ================================================ -5 / 3 ================================================ FILE: tasty/data/unit/divide-output.ffg ================================================ -1.6666666666666667 ================================================ FILE: tasty/data/unit/divide-type.ffg ================================================ Real ================================================ FILE: tasty/data/unit/equal-input.ffg ================================================ 0 == 0 ================================================ FILE: tasty/data/unit/equal-output.ffg ================================================ true ================================================ FILE: tasty/data/unit/equal-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/export-show-input.ffg ================================================ export show (\x -> x) ================================================ FILE: tasty/data/unit/export-show-output.ffg ================================================ "\\x -> x" ================================================ FILE: tasty/data/unit/export-show-type.ffg ================================================ Text ================================================ FILE: tasty/data/unit/field-input.ffg ================================================ { x: true }.x ================================================ FILE: tasty/data/unit/field-output.ffg ================================================ true ================================================ FILE: tasty/data/unit/field-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/fields-input.ffg ================================================ { x: 1, y: true }.{ z, x } ================================================ FILE: tasty/data/unit/fields-output.ffg ================================================ { "z": null, "x": 1 } ================================================ FILE: tasty/data/unit/fields-type.ffg ================================================ forall (a : Type) . { z: Optional a, x: Natural } ================================================ FILE: tasty/data/unit/for-list-input.ffg ================================================ for x of [ 1, 2, 3 ] in x + 1 ================================================ FILE: tasty/data/unit/for-list-output.ffg ================================================ [ 2, 3, 4 ] ================================================ FILE: tasty/data/unit/for-list-type.ffg ================================================ List Natural ================================================ FILE: tasty/data/unit/for-optional-input.ffg ================================================ if let x = some 1 in x + 1 ================================================ FILE: tasty/data/unit/for-optional-output.ffg ================================================ some 2 ================================================ FILE: tasty/data/unit/for-optional-type.ffg ================================================ Optional Natural ================================================ FILE: tasty/data/unit/greater-than-input.ffg ================================================ 2 > 3 ================================================ FILE: tasty/data/unit/greater-than-or-equal-input.ffg ================================================ 2 >= 3 ================================================ FILE: tasty/data/unit/greater-than-or-equal-output.ffg ================================================ false ================================================ FILE: tasty/data/unit/greater-than-or-equal-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/greater-than-output.ffg ================================================ false ================================================ FILE: tasty/data/unit/greater-than-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/if-input.ffg ================================================ if true then true else false ================================================ FILE: tasty/data/unit/if-output.ffg ================================================ true ================================================ FILE: tasty/data/unit/if-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/import-input.ffg ================================================ ./bool-input.ffg ================================================ FILE: tasty/data/unit/import-output.ffg ================================================ true ================================================ FILE: tasty/data/unit/import-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/index-input.ffg ================================================ [ 2, 3, 5 ].1 ================================================ FILE: tasty/data/unit/index-output.ffg ================================================ some 3 ================================================ FILE: tasty/data/unit/index-type.ffg ================================================ Optional Natural ================================================ FILE: tasty/data/unit/inequality-input.ffg ================================================ 0 == 1 ================================================ FILE: tasty/data/unit/inequality-output.ffg ================================================ false ================================================ FILE: tasty/data/unit/inequality-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/integer-abs-input.ffg ================================================ abs -4 ================================================ FILE: tasty/data/unit/integer-abs-output.ffg ================================================ 4 ================================================ FILE: tasty/data/unit/integer-abs-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/integer-input.ffg ================================================ -1 ================================================ FILE: tasty/data/unit/integer-output.ffg ================================================ -1 ================================================ FILE: tasty/data/unit/integer-type.ffg ================================================ Integer ================================================ FILE: tasty/data/unit/interpolation-input.ffg ================================================ "a${"b"}c" ================================================ FILE: tasty/data/unit/interpolation-output.ffg ================================================ "abc" ================================================ FILE: tasty/data/unit/interpolation-type.ffg ================================================ Text ================================================ FILE: tasty/data/unit/json-input.ffg ================================================ { array: [ 2, 3, 5 ] , string: "ABC" , natural: 0 , integer: -1 , real: 1.1 , bool: true , "null": null , mixed: [ 1, -1, true ] } : JSON ================================================ FILE: tasty/data/unit/json-output.ffg ================================================ { "array": [ 2, 3, 5 ] , "string": "ABC" , "natural": 0 , "integer": -1 , "real": 1.1 , "bool": true , "null": null , "mixed": [ 1, -1, true ] } ================================================ FILE: tasty/data/unit/json-subtype-input.ffg ================================================ (1 : Natural) : JSON ================================================ FILE: tasty/data/unit/json-subtype-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/json-subtype-type.ffg ================================================ JSON ================================================ FILE: tasty/data/unit/json-type.ffg ================================================ JSON ================================================ FILE: tasty/data/unit/key-input.ffg ================================================ "sk-proj-…" : Key ================================================ FILE: tasty/data/unit/key-output.ffg ================================================ 🔒 ================================================ FILE: tasty/data/unit/key-type.ffg ================================================ Key ================================================ FILE: tasty/data/unit/lambda-annotation-input.ffg ================================================ \(x : Natural) -> x ================================================ FILE: tasty/data/unit/lambda-annotation-output.ffg ================================================ \x -> x ================================================ FILE: tasty/data/unit/lambda-annotation-type.ffg ================================================ Natural -> Natural ================================================ FILE: tasty/data/unit/lambda-input.ffg ================================================ \x -> x ================================================ FILE: tasty/data/unit/lambda-output.ffg ================================================ \x -> x ================================================ FILE: tasty/data/unit/lambda-type.ffg ================================================ forall (a : Type) . a -> a ================================================ FILE: tasty/data/unit/less-than-input.ffg ================================================ 1 < 2 ================================================ FILE: tasty/data/unit/less-than-or-equal-input.ffg ================================================ 1 <= 2 ================================================ FILE: tasty/data/unit/less-than-or-equal-output.ffg ================================================ true ================================================ FILE: tasty/data/unit/less-than-or-equal-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/less-than-output.ffg ================================================ true ================================================ FILE: tasty/data/unit/less-than-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/let-default-input.ffg ================================================ let (x = 1) = null in x ================================================ FILE: tasty/data/unit/let-default-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/let-default-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/let-function-input.ffg ================================================ let f x = x in f 1 ================================================ FILE: tasty/data/unit/let-function-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/let-function-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/let-input.ffg ================================================ let x = true let y = x in y ================================================ FILE: tasty/data/unit/let-output.ffg ================================================ true ================================================ FILE: tasty/data/unit/let-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/list-fold-input.ffg ================================================ fold { cons: \x y -> x + y : Natural, nil: 0 } [ 2, 3 ] ================================================ FILE: tasty/data/unit/list-fold-output.ffg ================================================ 5 ================================================ FILE: tasty/data/unit/list-fold-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/list-indexed-input.ffg ================================================ indexed [ true, false ] ================================================ FILE: tasty/data/unit/list-indexed-output.ffg ================================================ [ { "index": 0, "value": true }, { "index": 1, "value": false } ] ================================================ FILE: tasty/data/unit/list-indexed-type.ffg ================================================ List { index: Natural, value: Bool } ================================================ FILE: tasty/data/unit/list-input.ffg ================================================ [ ] ================================================ FILE: tasty/data/unit/list-length-input.ffg ================================================ length [ true, false ] ================================================ FILE: tasty/data/unit/list-length-output.ffg ================================================ 2 ================================================ FILE: tasty/data/unit/list-length-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/list-map-input.ffg ================================================ map (\x -> x + 1) [ 2, 3, 5 ] ================================================ FILE: tasty/data/unit/list-map-output.ffg ================================================ [ 3, 4, 6 ] ================================================ FILE: tasty/data/unit/list-map-type.ffg ================================================ List Natural ================================================ FILE: tasty/data/unit/list-output.ffg ================================================ [ ] ================================================ FILE: tasty/data/unit/list-type.ffg ================================================ forall (a : Type) . List a ================================================ FILE: tasty/data/unit/merge-bool-input.ffg ================================================ fold { false: 0, true: 1 } ================================================ FILE: tasty/data/unit/merge-bool-output.ffg ================================================ fold { "false": 0, "true": 1 } ================================================ FILE: tasty/data/unit/merge-bool-type.ffg ================================================ Bool -> Natural ================================================ FILE: tasty/data/unit/merge-evaluation-input.ffg ================================================ fold { X: \x -> x } (X 1) ================================================ FILE: tasty/data/unit/merge-evaluation-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/merge-evaluation-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/merge-input.ffg ================================================ fold { X: \x -> x } ================================================ FILE: tasty/data/unit/merge-optional-input.ffg ================================================ fold { null: false, some: \_ -> true } ================================================ FILE: tasty/data/unit/merge-optional-output.ffg ================================================ fold { "null": false, "some": \_ -> true } ================================================ FILE: tasty/data/unit/merge-optional-type.ffg ================================================ forall (a : Type) . Optional a -> Bool ================================================ FILE: tasty/data/unit/merge-output.ffg ================================================ fold { "X": \x -> x } ================================================ FILE: tasty/data/unit/merge-type.ffg ================================================ forall (a : Type) . < X: a > -> a ================================================ FILE: tasty/data/unit/minus-input.ffg ================================================ 3 - 2 ================================================ FILE: tasty/data/unit/minus-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/minus-type.ffg ================================================ Integer ================================================ FILE: tasty/data/unit/missing-field-input.ffg ================================================ { x: 1 }.y ================================================ FILE: tasty/data/unit/missing-field-output.ffg ================================================ null ================================================ FILE: tasty/data/unit/missing-field-type.ffg ================================================ forall (a : Type) . Optional a ================================================ FILE: tasty/data/unit/missing-optional-field-input.ffg ================================================ let f (arguments : { x: Natural, y: Optional Bool }) = arguments.x in [ f { x: 1 }, f { x: 2, y: true } ] ================================================ FILE: tasty/data/unit/missing-optional-field-output.ffg ================================================ [ 1, 2 ] ================================================ FILE: tasty/data/unit/missing-optional-field-type.ffg ================================================ List Natural ================================================ FILE: tasty/data/unit/modulus-input.ffg ================================================ 5 % 3 ================================================ FILE: tasty/data/unit/modulus-output.ffg ================================================ { "quotient": 1, "remainder": 2 } ================================================ FILE: tasty/data/unit/modulus-type.ffg ================================================ { quotient: Natural, remainder: Natural } ================================================ FILE: tasty/data/unit/multi-lambda-input.ffg ================================================ \x y -> [x, y] ================================================ FILE: tasty/data/unit/multi-lambda-output.ffg ================================================ \x y -> [ x, y ] ================================================ FILE: tasty/data/unit/multi-lambda-type.ffg ================================================ forall (a : Type) . a -> a -> List a ================================================ FILE: tasty/data/unit/multiline-input.ffg ================================================ let example0 = " a b " let example1 = " a" in { example0, example1 } ================================================ FILE: tasty/data/unit/multiline-output.ffg ================================================ { "example0": "a\n\nb\n", "example1": "a" } ================================================ FILE: tasty/data/unit/multiline-type.ffg ================================================ { example0: Text, example1: Text } ================================================ FILE: tasty/data/unit/multiple-path-components-input.ffg ================================================ ../unit/bool-input.ffg ================================================ FILE: tasty/data/unit/multiple-path-components-output.ffg ================================================ true ================================================ FILE: tasty/data/unit/multiple-path-components-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/natural-fold-input.ffg ================================================ fold { succ: \x -> x + "a", zero: "" } 3 ================================================ FILE: tasty/data/unit/natural-fold-output.ffg ================================================ "aaa" ================================================ FILE: tasty/data/unit/natural-fold-type.ffg ================================================ Text ================================================ FILE: tasty/data/unit/natural-input.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/natural-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/natural-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/not-equal-input.ffg ================================================ 1 == 2 ================================================ FILE: tasty/data/unit/not-equal-output.ffg ================================================ false ================================================ FILE: tasty/data/unit/not-equal-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/null-input.ffg ================================================ null ================================================ FILE: tasty/data/unit/null-output.ffg ================================================ null ================================================ FILE: tasty/data/unit/null-type.ffg ================================================ forall (a : Type) . Optional a ================================================ FILE: tasty/data/unit/or-input.ffg ================================================ true || false ================================================ FILE: tasty/data/unit/or-output.ffg ================================================ true ================================================ FILE: tasty/data/unit/or-type.ffg ================================================ Bool ================================================ FILE: tasty/data/unit/pattern-input.ffg ================================================ fold { some x: x, null: 0 } 1 ================================================ FILE: tasty/data/unit/pattern-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/pattern-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/plus-input.ffg ================================================ 2 + 3 ================================================ FILE: tasty/data/unit/plus-output.ffg ================================================ 5 ================================================ FILE: tasty/data/unit/plus-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/positive-integer-input.ffg ================================================ +1 ================================================ FILE: tasty/data/unit/positive-integer-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/positive-integer-type.ffg ================================================ Integer ================================================ FILE: tasty/data/unit/pun-input.ffg ================================================ let x = 1 in { x } ================================================ FILE: tasty/data/unit/pun-output.ffg ================================================ { "x": 1 } ================================================ FILE: tasty/data/unit/pun-type.ffg ================================================ { x: Natural } ================================================ FILE: tasty/data/unit/quoted-label-input.ffg ================================================ \.'a b' -> .'a b' ================================================ FILE: tasty/data/unit/quoted-label-output.ffg ================================================ \.'a b' -> .'a b' ================================================ FILE: tasty/data/unit/quoted-label-type.ffg ================================================ forall (a : Type) . a -> a ================================================ FILE: tasty/data/unit/read-input.ffg ================================================ read "1" ================================================ FILE: tasty/data/unit/read-output.ffg ================================================ 1 ================================================ FILE: tasty/data/unit/read-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/real-dot-zero-input.ffg ================================================ 1.0 ================================================ FILE: tasty/data/unit/real-dot-zero-output.ffg ================================================ 1.0 ================================================ FILE: tasty/data/unit/real-dot-zero-type.ffg ================================================ Real ================================================ FILE: tasty/data/unit/real-input.ffg ================================================ 1.1 ================================================ FILE: tasty/data/unit/real-output.ffg ================================================ 1.1 ================================================ FILE: tasty/data/unit/real-type.ffg ================================================ Real ================================================ FILE: tasty/data/unit/record-desugar-input.ffg ================================================ { f x: x } ================================================ FILE: tasty/data/unit/record-desugar-output.ffg ================================================ { "f": \x -> x } ================================================ FILE: tasty/data/unit/record-desugar-type.ffg ================================================ forall (a : Type) . { f: a -> a } ================================================ FILE: tasty/data/unit/record-input.ffg ================================================ { x: true, y: false } ================================================ FILE: tasty/data/unit/record-output.ffg ================================================ { "x": true, "y": false } ================================================ FILE: tasty/data/unit/record-type.ffg ================================================ { x: Bool, y: Bool } ================================================ FILE: tasty/data/unit/remote-import-input.ffg ================================================ https://raw.githubusercontent.com/Gabriel439/grace/537e82bc92e31590f258b9aa4fa1db2f227463f8/prelude/bool/not.ffg ================================================ FILE: tasty/data/unit/remote-import-output.ffg ================================================ \b -> if b then false else true ================================================ FILE: tasty/data/unit/remote-import-type.ffg ================================================ Bool -> Bool ================================================ FILE: tasty/data/unit/reveal-input.ffg ================================================ let key: Key = "abc" in reveal key ================================================ FILE: tasty/data/unit/reveal-output.ffg ================================================ "abc" ================================================ FILE: tasty/data/unit/reveal-type.ffg ================================================ Text ================================================ FILE: tasty/data/unit/show-input.ffg ================================================ show 0 ================================================ FILE: tasty/data/unit/show-output.ffg ================================================ "0" ================================================ FILE: tasty/data/unit/show-type.ffg ================================================ Text ================================================ FILE: tasty/data/unit/slice-input.ffg ================================================ [2, 3, 5][1:2] ================================================ FILE: tasty/data/unit/slice-output.ffg ================================================ some [ 3 ] ================================================ FILE: tasty/data/unit/slice-type.ffg ================================================ Optional (List Natural) ================================================ FILE: tasty/data/unit/string-labels-input.ffg ================================================ { "foo bar": 1, "if": 2 } ================================================ FILE: tasty/data/unit/string-labels-output.ffg ================================================ { "foo bar": 1, "if": 2 } ================================================ FILE: tasty/data/unit/string-labels-type.ffg ================================================ { "foo bar": Natural, "if": Natural } ================================================ FILE: tasty/data/unit/text-escaped-input.ffg ================================================ "\"\/\b\f\n\r\t\u024c\\\u2192" ================================================ FILE: tasty/data/unit/text-escaped-output.ffg ================================================ " \"/\b\f \r Ɍ\\→" ================================================ FILE: tasty/data/unit/text-escaped-type.ffg ================================================ Text ================================================ FILE: tasty/data/unit/text-input.ffg ================================================ "a" ================================================ FILE: tasty/data/unit/text-output.ffg ================================================ "a" ================================================ FILE: tasty/data/unit/text-type.ffg ================================================ Text ================================================ FILE: tasty/data/unit/times-input.ffg ================================================ 2 * 3 ================================================ FILE: tasty/data/unit/times-output.ffg ================================================ 6 ================================================ FILE: tasty/data/unit/times-type.ffg ================================================ Natural ================================================ FILE: tasty/data/unit/union-input.ffg ================================================ C 1 ================================================ FILE: tasty/data/unit/union-output.ffg ================================================ C 1 ================================================ FILE: tasty/data/unit/union-type.ffg ================================================ forall (a : Alternatives) . < C: Natural | a > ================================================ FILE: tasty/data/unit/visible-row-quantification-input.ffg ================================================ (\x -> x.foo) : forall (a : Type) . forall (p : Fields) . { foo : a, p } -> a ================================================ FILE: tasty/data/unit/visible-row-quantification-output.ffg ================================================ \x -> x.foo ================================================ FILE: tasty/data/unit/visible-row-quantification-type.ffg ================================================ forall (a : Type) (p : Fields) . { foo: a, p } -> a ================================================ FILE: tasty/data/unit/visible-variant-quantification-input.ffg ================================================ (\x -> X x) : forall (a : Type) . forall (p : Alternatives) . a -> < X : a | p > ================================================ FILE: tasty/data/unit/visible-variant-quantification-output.ffg ================================================ \x -> X x ================================================ FILE: tasty/data/unit/visible-variant-quantification-type.ffg ================================================ forall (a : Type) (p : Alternatives) . a -> < X: a | p > ================================================ FILE: tasty/data/unit/yaml-input.ffg ================================================ yaml [ 1, 2, 3 ] ================================================ FILE: tasty/data/unit/yaml-output.ffg ================================================ " - 1 - 2 - 3 " ================================================ FILE: tasty/data/unit/yaml-type.ffg ================================================ Text ================================================ FILE: try-grace/Main.hs ================================================ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where import Control.Applicative (empty, liftA2, (<|>)) import Control.Concurrent.Async (Async, Concurrently(..)) import Control.Exception.Safe (catch, Exception(..), SomeException) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Morph (hoist) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.State (StateT) import Data.Foldable (toList, traverse_) import Data.IORef (IORef) import Data.Maybe (isJust) import Data.JSString (JSString) import Data.Sequence (ViewR(..), (|>)) import Data.Text (Text) import Data.Traversable (forM) import Data.Void (Void) import Grace.Monad (Status(..)) import Grace.Type (Type(..)) import GHCJS.Foreign.Callback (Callback) import GHCJS.Types (JSVal) import Grace.Decode (FromGrace) import Grace.Encode (ToGrace(..)) import Grace.Input (Input(..)) import Grace.Location (Location(..)) import Grace.Monotype (RemainingFields(..)) import Grace.Syntax (Binding(..), NameBinding(..), Scalar(..), Syntax) import Grace.Value (Value(..)) import JavaScript.Array (JSArray) import Numeric.Natural (Natural) import Prelude hiding (div, error, id, length, span, subtract) import System.FilePath (()) import qualified Control.Concurrent.Async as Async import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM.TVar as TVar import qualified Control.Exception.Safe as Exception import qualified Control.Lens as Lens import qualified Control.Monad as Monad import qualified Control.Monad.State as State import qualified Control.Monad.Trans.Maybe as Maybe import qualified Control.Monad.Trans.Reader as Reader import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict.InsOrd as HashMap import qualified Data.IORef as IORef import qualified Data.JSString as JSString import qualified Data.JSString.Text as JSString.Text import qualified Data.List as List import qualified Data.Scientific as Scientific import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Encoding as Text.Encoding import qualified GHCJS.Foreign.Callback as Callback import qualified GHCJS.Types import qualified Grace.Context as Context import qualified Grace.DataFile as DataFile import qualified Grace.Decode as Decode import qualified Grace.Import as Import import qualified Grace.Infer as Infer import qualified Grace.Input as Input import qualified Grace.Interpret as Interpret import qualified Grace.Monad as Grace import qualified Grace.Monotype as Monotype import qualified Grace.Normalize as Normalize import qualified Grace.Pretty as Pretty import qualified Grace.Syntax as Syntax import qualified Grace.Type as Type import qualified Grace.Value as Value import qualified JavaScript.Array as Array import qualified Network.URI.Encode as URI.Encode instance (Applicative m, Semigroup a) => Semigroup (ReaderT r m a) where (<>) = liftA2 (<>) instance (Applicative m, Monoid a) => Monoid (ReaderT r m a) where mempty = pure mempty instance (Monad m, Semigroup a) => Semigroup (StateT r m a) where (<>) = liftA2 (<>) instance (Monad m, Monoid a) => Monoid (StateT r m a) where mempty = pure mempty foreign import javascript unsafe "document.getElementById($1)" getElementById_ :: JSString -> IO JSVal getElementById :: MonadIO io => Text -> io JSVal getElementById a = liftIO (getElementById_ (fromText a)) foreign import javascript unsafe "$1.value" toValue_ :: JSVal -> IO JSString toValue :: MonadIO io => JSVal -> io Text toValue a = liftIO (fmap toText (toValue_ a)) foreign import javascript unsafe "$1.value = $2" setValue_ :: JSVal -> JSString -> IO () setValue :: MonadIO io => JSVal -> Text -> io () setValue a b = liftIO (setValue_ a (fromText b)) toIntegerValue :: MonadIO io => JSVal -> io Integer toIntegerValue a = liftIO (fmap (read . JSString.unpack) (toValue_ a)) setIntegerValue :: MonadIO io => JSVal -> Integer -> io () setIntegerValue a b = liftIO (setValue_ a (JSString.pack (show b))) toNaturalValue :: MonadIO io => JSVal -> io Natural toNaturalValue a = liftIO (fmap (read . JSString.unpack) (toValue_ a)) setNaturalValue :: MonadIO io => JSVal -> Natural -> io () setNaturalValue a b = liftIO (setValue_ a (JSString.pack (show b))) foreign import javascript unsafe "$1.value" toDoubleValue_ :: JSVal -> IO Double toDoubleValue :: MonadIO io => JSVal -> io Double toDoubleValue a = liftIO (toDoubleValue_ a) foreign import javascript unsafe "$1.value = $2" setDoubleValue_ :: JSVal -> Double -> IO () setDoubleValue :: MonadIO io => JSVal -> Double -> io () setDoubleValue a b = liftIO (setDoubleValue_ a b) foreign import javascript unsafe "$1.checked" getChecked_ :: JSVal -> IO Bool getChecked :: MonadIO io => JSVal -> io Bool getChecked a = liftIO (getChecked_ a) foreign import javascript unsafe "$1.checked = $2" setChecked_ :: JSVal -> Bool -> IO () setChecked :: MonadIO io => JSVal -> Bool -> io () setChecked a b = liftIO (setChecked_ a b) foreign import javascript unsafe "$1.textContent = $2" setTextContent_ :: JSVal -> JSString -> IO () setTextContent :: MonadIO io => JSVal -> Text -> io () setTextContent a b = liftIO (setTextContent_ a (fromText b)) foreign import javascript unsafe "$1.innerText = $2" setInnerText_ :: JSVal -> JSString -> IO () setInnerText :: MonadIO io => JSVal -> Text -> io () setInnerText a b = liftIO (setInnerText_ a (fromText b)) foreign import javascript unsafe "$1.innerHTML = $2" setInnerHTML_ :: JSVal -> JSString -> IO () setInnerHTML :: MonadIO io => JSVal -> Text -> io () setInnerHTML a b = liftIO (setInnerHTML_ a (fromText b)) foreign import javascript unsafe "$1.style.display = $2" setDisplay_ :: JSVal -> JSString -> IO () foreign import javascript unsafe "converter.makeHtml($1)" markdownToHTML_ :: JSString -> JSString markdownToHTML :: Text -> Text markdownToHTML a = toText (markdownToHTML_ (fromText a)) setDisplay :: MonadIO io => JSVal -> Text -> io () setDisplay a b = liftIO (setDisplay_ a (fromText b)) foreign import javascript unsafe "$1.addEventListener($2, $3)" addEventListener_ :: JSVal -> JSString -> Callback (IO ()) -> IO () addEventListener :: MonadIO io => JSVal -> Text -> Callback (IO ()) -> io () addEventListener a b c = liftIO (addEventListener_ a (fromText b) c) foreign import javascript unsafe "autoResize($1)" autoResize_ :: JSVal -> IO () autoResize :: MonadIO io => JSVal -> io () autoResize a = liftIO (autoResize_ a) foreign import javascript unsafe "document.createElement($1)" createElement_ :: JSString -> IO JSVal createElement :: MonadIO io => Text -> io JSVal createElement a = liftIO (createElement_ (fromText a)) foreign import javascript unsafe "$1.setAttribute($2,$3)" setAttribute_ :: JSVal -> JSString -> JSString -> IO () setAttribute :: MonadIO io => JSVal -> Text -> Text -> io () setAttribute a b c = liftIO (setAttribute_ a (fromText b) (fromText c)) foreign import javascript unsafe "$1.disabled = $2" setDisabled_ :: JSVal -> Bool -> IO () setDisabled :: MonadIO io => JSVal -> Bool -> io () setDisabled a b = liftIO (setDisabled_ a b) foreign import javascript unsafe "$1.replaceChildren($2)" replaceChild_ :: JSVal -> JSVal -> IO () replaceChild :: MonadIO io => JSVal -> JSVal -> io () replaceChild a b = liftIO (replaceChild_ a b) foreign import javascript unsafe "new MutationObserver($1)" newObserver_ :: Callback (IO ()) -> IO JSVal newObserver :: MonadIO io => Callback (IO ()) -> io JSVal newObserver a = liftIO (newObserver_ a) foreign import javascript unsafe "$1.observe($2, { childList: true, subtree: true })" observe_ :: JSVal -> JSVal -> IO () observe :: MonadIO io => JSVal -> JSVal -> io () observe a b = liftIO (observe_ a b) foreign import javascript unsafe "(new URL(document.location)).searchParams" getSearchParams_ :: IO JSVal getSearchParams :: MonadIO io => io JSVal getSearchParams = liftIO getSearchParams_ foreign import javascript unsafe "$1.has($2)" hasParam_ :: JSVal -> JSString -> IO Bool hasParam :: MonadIO io => JSVal -> Text -> io Bool hasParam a b = liftIO (hasParam_ a (fromText b)) foreign import javascript unsafe "$1.get($2)" getParam_ :: JSVal -> JSString -> IO JSString getParam :: MonadIO io => JSVal -> Text -> io Text getParam a b = liftIO (fmap toText (getParam_ a (fromText b))) foreign import javascript unsafe "$1.set($2,$3)" setParam_ :: JSVal -> JSString -> JSString -> IO () setParam :: MonadIO io => JSVal -> Text -> Text -> io () setParam a b c = liftIO (setParam_ a (fromText b) (fromText c)) -- @$1.delete($2)@ doesn't work because GHCJS treats delete as a forbidden -- reserved keyword, so we work around this by defining the -- @deleteSearchParamWorkaround@ function in JavaScript which takes care of this -- for us foreign import javascript unsafe "deleteSearchParamWorkaround($1, $2)" deleteParam_ :: JSVal -> JSString -> IO () deleteParam :: MonadIO io => JSVal -> Text -> io () deleteParam a b = liftIO (deleteParam_ a (fromText b)) foreign import javascript unsafe "history.replaceState(null, null, '?'+$1.toString())" saveSearchParams_ :: JSVal -> IO () saveSearchParams :: MonadIO io => JSVal -> io () saveSearchParams a = liftIO (saveSearchParams_ a) -- @$1.replaceChildren(...$2)@ does not work because GHCJS fails to parse the -- spread operator, so we work around this by defining the -- @replaceChildrenWorkaround@ function in JavaScript which takes care of the -- spread operator for us foreign import javascript unsafe "replaceChildrenWorkaround($1, $2)" replaceChildren_ :: JSVal -> JSArray -> IO () replaceChildren :: MonadIO io => JSVal -> [JSVal] -> io () replaceChildren a b = liftIO (replaceChildren_ a (Array.fromList b)) foreign import javascript unsafe "$1.before($2)" before_ :: JSVal -> JSVal -> IO () before :: MonadIO io => JSVal -> JSVal -> io () before a b = liftIO (before_ a b) foreign import javascript unsafe "$1.after($2)" after_ :: JSVal -> JSVal -> IO () after :: MonadIO io => JSVal -> JSVal -> io () after a b = liftIO (after_ a b) foreign import javascript unsafe "$1.remove()" remove_ :: JSVal -> IO () remove :: MonadIO io => JSVal -> io () remove a = liftIO (remove_ a) foreign import javascript unsafe "CodeMirror.fromTextArea($1, { mode: 'python', lineNumbers: true, viewportMargin: Infinity, extraKeys: { 'Shift-Tab': false, 'Tab': false } })" setupCodemirrorInput_ :: JSVal -> IO JSVal setupCodemirrorInput :: MonadIO io => JSVal -> io JSVal setupCodemirrorInput a = liftIO (setupCodemirrorInput_ a) foreign import javascript unsafe "CodeMirror.fromTextArea($1, { mode: 'python', lineNumbers: false, viewportMargin: Infinity, readOnly: true })" setupCodemirrorOutput_ :: JSVal -> IO JSVal setupCodemirrorOutput :: MonadIO io => JSVal -> io JSVal setupCodemirrorOutput a = liftIO (setupCodemirrorOutput_ a) foreign import javascript unsafe "$1.refresh()" refresh_ :: JSVal -> IO () refresh :: MonadIO io => JSVal -> io () refresh a = liftIO (refresh_ a) foreign import javascript unsafe "$1.getWrapperElement()" getWrapperElement :: JSVal -> JSVal foreign import javascript unsafe "$1.on('change', $2)" onChange_ :: JSVal -> Callback (IO ()) -> IO () onChange :: MonadIO io => JSVal -> Callback (IO ()) -> io () onChange a b = liftIO (onChange_ a b) foreign import javascript unsafe "$1.setValue($2)" setCodeValue_ :: JSVal -> JSString -> IO () setCodeValue :: MonadIO io => JSVal -> Text -> io () setCodeValue a b = liftIO (setCodeValue_ a (fromText b)) foreign import javascript unsafe "$1.getValue()" getValue_ :: JSVal -> IO JSString getValue :: MonadIO io => JSVal -> io Text getValue a = liftIO (fmap toText (getValue_ a)) foreign import javascript unsafe "document.getElementsByClassName($1)" getElementsByClassName_ :: JSString -> IO JSArray getElementsByClassName :: MonadIO io => Text -> io [JSVal] getElementsByClassName a = fmap Array.toList (liftIO (getElementsByClassName_ (fromText a))) foreign import javascript unsafe "$1.classList.remove($2)" removeClass_ :: JSVal -> JSString -> IO () removeClass :: MonadIO io => JSVal -> Text -> io () removeClass a b = liftIO (removeClass_ a (fromText b)) foreign import javascript unsafe "$1.classList.add($2)" addClass_ :: JSVal -> JSString -> IO () addClass :: MonadIO io => JSVal -> Text -> io () addClass a b = liftIO (addClass_ a (fromText b)) foreign import javascript unsafe "$1.focus()" focus_ :: JSVal -> IO () focus :: MonadIO io => JSVal -> io () focus a = liftIO (focus_ a) foreign import javascript unsafe "sessionStorage.setItem($1, $2)" setSessionStorage_ :: JSString -> JSString -> IO () setSessionStorage :: MonadIO io => Text -> Text -> io () setSessionStorage a b = liftIO (setSessionStorage_ (fromText a) (fromText b)) foreign import javascript unsafe "sessionStorage.getItem($1)" getSessionStorage_ :: JSString -> IO JSVal getSessionStorage :: MonadIO io => Text -> io (Maybe Text) getSessionStorage a = liftIO do jsVal <- getSessionStorage_ (fromText a) if GHCJS.Types.isNull jsVal then return Nothing else return (Just (JSString.Text.textFromJSVal jsVal)) foreign import javascript unsafe "sessionStorage.removeItem($1)" removeSessionStorage_ :: JSString -> IO () removeSessionStorage :: MonadIO io => Text -> io () removeSessionStorage a = liftIO (removeSessionStorage_ (fromText a)) foreign import javascript unsafe "localStorage.setItem($1, $2)" setLocalStorage_ :: JSString -> JSString -> IO () setLocalStorage :: MonadIO io => Text -> Text -> io () setLocalStorage a b = liftIO (setLocalStorage_ (fromText a) (fromText b)) foreign import javascript unsafe "localStorage.getItem($1)" getLocalStorage_ :: JSString -> IO JSVal getLocalStorage :: MonadIO io => Text -> io (Maybe Text) getLocalStorage a = liftIO do jsVal <- getLocalStorage_ (fromText a) if GHCJS.Types.isNull jsVal then return Nothing else return (Just (JSString.Text.textFromJSVal jsVal)) foreign import javascript unsafe "print($1)" printElement_ :: JSVal -> IO () printElement :: MonadIO io => JSVal -> io () printElement a = liftIO (printElement_ a) foreign import javascript unsafe "navigator.clipboard.writeText($1)" writeClipboard_ :: JSString -> IO () writeClipboard :: MonadIO io => Text -> io () writeClipboard a = liftIO (writeClipboard_ (fromText a)) toText :: JSString -> Text toText = Text.pack . JSString.unpack fromText :: Text -> JSString fromText = JSString.pack . Text.unpack typeToText :: Type s -> Text typeToText = Pretty.renderStrict False 80 valueToText :: Value location -> Text valueToText = Pretty.renderStrict False 80 hideElement :: MonadIO io => JSVal -> io () hideElement element = do setDisplay element "none" addClass element "grace-ignore" showElement :: MonadIO io => Text -> JSVal -> io () showElement display element = do setDisplay element display removeClass element "grace-ignore" data Config = Config { counter :: IORef Natural , status :: Status , input :: Input , edit :: Bool } renderValue :: JSVal -> Type Location -> Value Location -> ReaderT Config IO (IO ()) renderValue parent Type.Optional{ type_ } value = renderValue parent type_ value renderValue parent _ (Value.Text _ text) = do printable <- createElement "div" addClass printable "grace-printable" markdown <- createElement "div" addClass markdown "grace-output-text" let innerHTML = if text == "" then "

\x200B

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

Grace browser