diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,21 @@ +# Changelog for `purekell` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - 2026-03-06 + +### Added +- Shared AST for Haskell and PureScript expressions, patterns, and types +- Megaparsec-based parser with language-specific postfix (PS dot access) +- Target-aware printer handling divergent syntax (tuples, cons, records, record access) +- Codec abstraction pairing parsers with printers +- Haskell and PureScript codec instances +- Instance method equation parsing and printing +- Backtick infix operators and function-style let/where bindings +- 331 tests (unit + property-based roundtrip) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,190 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + Copyright 2026 philippedev101 + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,59 @@ +# purekell + +Bidirectional Haskell/PureScript expression translator. Parses expressions from either language into a shared AST, then prints them back in the target language with correct syntax. + +Built to complement [purescript-bridge](https://hackage.haskell.org/package/purescript-bridge) — while purescript-bridge generates PureScript *types* from Haskell types, purekell translates *expressions* (specifically typeclass instance method bodies). + +## Usage + +```haskell +import Purekell + +-- Translate expressions between languages +hsToPs "uid x == uid y" -- Right "x.uid == y.uid" +psToHs "x.uid == y.uid" -- Right "uid x == uid y" + +-- Parse and print instance method bodies +import Purekell.Instance + +parseMethodBody "eq x y = x == y" -- Right [MethodEquation ...] +printMethodBody Haskell eqs -- "eq x y = x == y" +printMethodBody PureScript eqs -- "eq x y = x == y" +``` + +## Supported syntax + +Expressions: literals (int, float, char, string), variables, constructors, application, infix operators (symbolic and backtick), lambda, if/then/else, case/of, let/in, do notation, negation, tuples, lists, operator sections, where clauses, type annotations, record construction/update, qualified names. + +Patterns: variable, constructor, literal, wildcard, tuple, list, cons, as-pattern, negated literal, record. + +Types: constructors, variables, application, function arrows, qualified constructors. + +## Divergent syntax + +Most syntax is shared between Haskell and PureScript. The printer handles these divergences: + +| Construct | Haskell | PureScript | +|---|---|---| +| Record access | `field rec` | `rec.field` | +| Tuples | `(a, b, c)` | `Tuple a (Tuple b c)` | +| Cons patterns | `x : xs` | `Cons x xs` | +| Record construction | `Foo { bar = 1 }` | `Foo { bar: 1 }` | +| Record patterns | `Foo { bar = x }` | `Foo { bar: x }` | + +## Architecture + +- **`Purekell.AST`** — Shared AST types (`Expr`, `Pat`, `Type`, `Binding`, etc.) +- **`Purekell.Parser`** — Megaparsec-based parser, parameterized for language-specific postfix (e.g. PS dot access) +- **`Purekell.Printer`** — Target-aware printer with correct parenthesization +- **`Purekell.Codec`** — `Codec a` pairs a parser with a printer; provides `runParse`, `runPrint`, `roundtrip` +- **`Purekell.Haskell`** / **`Purekell.PureScript`** — Language-specific codec instances +- **`Purekell.Instance`** — Parsing/printing of typeclass method equations (`name pat1 pat2 = body`) + +## Testing + +```bash +cd purekell && stack test +``` + +331 tests covering parse, print, roundtrip (Haskell, PureScript, cross-language), and property-based roundtrip tests using QuickCheck with `Arbitrary` instances for all AST types. diff --git a/purekell.cabal b/purekell.cabal new file mode 100644 --- /dev/null +++ b/purekell.cabal @@ -0,0 +1,113 @@ +cabal-version: 3.0 +name: purekell +version: 0.1.0.0 +synopsis: Bidirectional Haskell/PureScript expression translator +description: + Parses Haskell and PureScript expressions into a shared AST, then + prints them back in either language with correct syntax. Handles + divergent syntax like record access, tuples, cons patterns, and + record field separators. Designed for translating typeclass instance + method bodies. + +category: Language +license: Apache-2.0 +license-file: LICENSE +author: philippedev101 +maintainer: philippedev101 +copyright: 2026 philippedev101 +homepage: https://github.com/philippedev101/purekell#readme +bug-reports: https://github.com/philippedev101/purekell/issues +build-type: Simple + +extra-source-files: + README.md + +extra-doc-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/philippedev101/purekell + +flag dev + description: Enable -Werror for development + manual: True + default: False + +common warnings + default-language: GHC2021 + default-extensions: + DerivingVia + LambdaCase + OverloadedStrings + ghc-options: + -Weverything + -Wno-unrecognised-warning-flags + -- Not useful for this project + -Wno-missing-safe-haskell-mode + -Wno-safe + -Wno-unsafe + -Wno-implicit-prelude + -Wno-missing-import-lists + -Wno-missing-local-signatures + -Wno-missing-kind-signatures + -Wno-missing-deriving-strategies + -Wno-missing-export-lists + -Wno-missing-role-annotations + -Wno-prepositive-qualified-module + -Wno-unticked-promoted-constructors + -- Intentional in this codebase + -Wno-orphans + -Wno-name-shadowing + -Wno-unused-imports + -Wno-monomorphism-restriction + -Wno-type-defaults + -Wno-deprecations + -- Not actionable + -Wno-missed-specialisations + -Wno-all-missed-specialisations + if flag(dev) + ghc-options: -Werror + +library + import: warnings + hs-source-dirs: src + exposed-modules: + Purekell + Purekell.AST + Purekell.Codec + Purekell.Haskell + Purekell.Instance + Purekell.Parser + Purekell.Printer + Purekell.PureScript + build-depends: + base >= 4.7 && < 5, + megaparsec >= 9.0 && < 9.8, + text >= 2.0 && < 2.2, + +test-suite purekell-test + import: warnings + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + Purekell.Arbitrary + Purekell.ASTSpec + Purekell.DivergentSpec + Purekell.InstanceSpec + Purekell.RoundtripSpec + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + -Wno-unused-packages + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + base >= 4.7 && < 5, + hspec, + megaparsec >= 9.0 && < 9.8, + purekell, + QuickCheck, + text >= 2.0 && < 2.2, diff --git a/src/Purekell.hs b/src/Purekell.hs new file mode 100644 --- /dev/null +++ b/src/Purekell.hs @@ -0,0 +1,66 @@ +-- | Purekell: bidirectional Haskell\/PureScript expression translator. +-- +-- This is the main entry point for the library. For simple use cases, +-- 'hsToPs' and 'psToHs' translate expression source code between languages: +-- +-- >>> hsToPs "fmap f (x, y)" +-- Right "map f (Tuple x y)" +-- +-- >>> psToHs "arr.name" +-- Right "name arr" +-- +-- For more control, use the 'Codec' type from "Purekell.Codec" together with +-- the language-specific codecs in "Purekell.Haskell" and "Purekell.PureScript". +-- +-- For translating typeclass instance method bodies (with pattern arguments and +-- guards), see "Purekell.Instance". +module Purekell + ( -- * Quick translation + hsToPs + , psToHs + -- * Re-exports + , module Purekell.AST + , module Purekell.Codec + , module Purekell.Instance + ) where + +import Data.Text (Text) +import Data.Void (Void) +import Text.Megaparsec (ParseErrorBundle) + +import Purekell.AST +import Purekell.Codec +import Purekell.Haskell (haskellExpr) +import Purekell.Instance +import Purekell.PureScript (purescriptExpr) + +-- | Translate a Haskell expression to PureScript. +-- +-- Parses the input as a Haskell expression, converts divergent syntax +-- (tuples, record access, cons patterns, etc.), and prints it as PureScript. +-- +-- >>> hsToPs "map f xs" +-- Right "map f xs" +-- +-- >>> hsToPs "field rec" +-- Right "rec.field" +hsToPs :: Text -> Either (ParseErrorBundle Text Void) Text +hsToPs input = do + ast <- runParse haskellExpr input + pure (runPrint purescriptExpr ast) + +-- | Translate a PureScript expression to Haskell. +-- +-- Parses the input as a PureScript expression, converts divergent syntax +-- (dot-access, @Tuple@ constructors, @Cons@ patterns, etc.), and prints +-- it as Haskell. +-- +-- >>> psToHs "arr.name" +-- Right "name arr" +-- +-- >>> psToHs "Tuple x y" +-- Right "(x, y)" +psToHs :: Text -> Either (ParseErrorBundle Text Void) Text +psToHs input = do + ast <- runParse purescriptExpr input + pure (runPrint haskellExpr ast) diff --git a/src/Purekell/AST.hs b/src/Purekell/AST.hs new file mode 100644 --- /dev/null +++ b/src/Purekell/AST.hs @@ -0,0 +1,124 @@ +-- | The shared abstract syntax tree for Haskell and PureScript expressions. +-- +-- This AST is language-neutral: it represents the common subset of both +-- languages plus nodes for constructs that exist in both but with different +-- concrete syntax. For example, 'RecordAccess' represents @rec.field@ in +-- PureScript and @field rec@ in Haskell — same AST node, different surface +-- syntax handled by the printer. +-- +-- All AST types derive 'Generic' for use with property-based testing +-- (arbitrary instance generation). +module Purekell.AST + ( -- * Names + Name (..) + -- * Literals + , Lit (..) + -- * Expressions + , Expr (..) + -- * Patterns + , Pat (..) + -- * Guards, alternatives, bindings, statements + , Guard (..) + , CaseAlt (..) + , Binding (..) + , Stmt (..) + -- * Types + , Type (..) + ) where + +import Data.Text (Text) +import GHC.Generics (Generic) + +-- | An identifier or operator name. Wraps a 'Text' value. +newtype Name = Name Text + deriving (Eq, Show, Ord, Generic) + +-- | Literal values shared by both languages. +data Lit + = IntLit Integer -- ^ Integer literal: @42@ + | FloatLit Double -- ^ Floating-point literal: @3.14@ + | StringLit Text -- ^ String literal: @\"hello\"@ + | CharLit Char -- ^ Character literal: @\'x\'@ + deriving (Eq, Show, Generic) + +-- | A guard expression: @| condition@. +-- +-- Used in case alternatives and method equations. +newtype Guard = Guard Expr + deriving (Eq, Show, Generic) + +-- | A case alternative: @pattern guards -> body@. +-- +-- The guard list may be empty for unconditional alternatives. +data CaseAlt = CaseAlt Pat [Guard] Expr + deriving (Eq, Show, Generic) + +-- | A let\/where binding: @pattern = expression@. +-- +-- Function-style bindings like @f x = body@ are represented as +-- @'Binding' ('VarPat' \"f\") ('Lam' ['VarPat' \"x\"] body)@. +data Binding = Binding Pat Expr + deriving (Eq, Show, Generic) + +-- | A do-notation statement. +data Stmt + = StmtBind Pat Expr -- ^ Bind statement: @pat <- expr@ + | StmtExpr Expr -- ^ Expression statement: @expr@ + | StmtLet [Binding] -- ^ Let statement: @let { bindings }@ + deriving (Eq, Show, Generic) + +-- | Expressions — the core of the AST. +-- +-- Covers the shared expression syntax of Haskell and PureScript: +-- function application, infix operators, lambdas, conditionals, +-- case expressions, let\/where bindings, do-notation, record operations, +-- sections, type annotations, and more. +data Expr + = Literal Lit -- ^ A literal value + | Var Name -- ^ Variable reference: @x@, @foo@ + | Con Name -- ^ Data constructor: @Just@, @True@ + | App Expr Expr -- ^ Function application: @f x@ + | InfixApp Expr Name Expr -- ^ Infix operator application: @x + y@, @x \`div\` y@ + | Lam [Pat] Expr -- ^ Lambda: @\\x y -> body@ + | If Expr Expr Expr -- ^ Conditional: @if c then t else e@ + | Case Expr [CaseAlt] -- ^ Case expression: @case x of { alts }@ + | Let [Binding] Expr -- ^ Let expression: @let { bindings } in body@ + | Do [Stmt] -- ^ Do-notation: @do { stmts }@ + | Neg Expr -- ^ Prefix negation: @-expr@ + | RecordAccess Expr Name -- ^ Record field access: @rec.field@ (PS) \/ @field rec@ (HS) + | Tuple [Expr] -- ^ Tuple literal (≥2 elements): @(a, b)@ (HS) \/ @Tuple a b@ (PS) + | ListLit [Expr] -- ^ List literal: @[1, 2, 3]@ + | LeftSection Expr Name -- ^ Left operator section: @(expr +)@ + | RightSection Name Expr -- ^ Right operator section: @(+ expr)@ + | Where Expr [Binding] -- ^ Where clause: @expr where { bindings }@ + | Ann Expr Type -- ^ Type annotation: @expr :: Type@ + | RecordUpdate Expr [(Name, Expr)] -- ^ Record update: @rec { field = val, ... }@ + | QVar [Name] Name -- ^ Qualified variable: @Data.Map.lookup@ + | QCon [Name] Name -- ^ Qualified constructor: @Data.Map.Map@ + deriving (Eq, Show, Generic) + +-- | Patterns for case alternatives, lambda arguments, and bindings. +data Pat + = VarPat Name -- ^ Variable pattern: @x@ + | ConPat Name [Pat] -- ^ Constructor pattern: @Just x@, @Nothing@ + | LitPat Lit -- ^ Literal pattern: @42@, @\"hello\"@ + | WildPat -- ^ Wildcard pattern: @_@ + | TuplePat [Pat] -- ^ Tuple pattern (≥2 elements): @(a, b)@ (HS) \/ @Tuple a b@ (PS) + | ListPat [Pat] -- ^ List pattern: @[x, y, z]@ + | ConsPat Pat Pat -- ^ Cons pattern: @x : xs@ (HS) \/ @Cons x xs@ (PS) + | AsPat Name Pat -- ^ As-pattern: @name\@pat@ + | NegLitPat Lit -- ^ Negated literal pattern: @-42@, @-3.14@ + | RecordPat Name [(Name, Pat)] -- ^ Record pattern: @Foo { bar = x, baz = y }@ + deriving (Eq, Show, Generic) + +-- | Types for type annotations (@expr :: Type@). +-- +-- Only a minimal subset is supported — enough for type annotations +-- that appear in instance method bodies. +data Type + = TyCon Name -- ^ Named type: @Int@, @Bool@, @Maybe@ + | TyVar Name -- ^ Type variable: @a@, @b@ + | TyApp Type Type -- ^ Type application: @Maybe a@ + | TyFun Type Type -- ^ Function type: @a -> b@ + | TyQCon [Name] Name -- ^ Qualified type constructor: @Data.Map.Map@ + deriving (Eq, Show, Generic) diff --git a/src/Purekell/Codec.hs b/src/Purekell/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Purekell/Codec.hs @@ -0,0 +1,42 @@ +-- | Bidirectional codecs that pair a megaparsec parser with a pretty-printer. +-- +-- A 'Codec' bundles a parser and printer for the same type, making it easy +-- to parse source text into an AST and print it back. This is the core +-- abstraction that enables roundtrip translation between languages. +-- +-- See "Purekell.Haskell" and "Purekell.PureScript" for concrete codecs. +module Purekell.Codec + ( Codec (..) + , runParse + , runPrint + , roundtrip + ) where + +import Data.Text (Text) +import Data.Void (Void) +import Text.Megaparsec (Parsec, ParseErrorBundle, parse) + +-- | A bidirectional codec pairing a parser and printer for type @a@. +-- +-- The parser consumes 'Text' input and produces an @a@; the printer +-- converts an @a@ back to 'Text'. When the parser and printer are +-- inverses, @'roundtrip' codec@ is the identity on well-formed values. +data Codec a = Codec + { codecParser :: Parsec Void Text a -- ^ Megaparsec parser for @a@ + , codecPrinter :: a -> Text -- ^ Pretty-printer for @a@ + } + +-- | Parse source text using a codec's parser. +runParse :: Codec a -> Text -> Either (ParseErrorBundle Text Void) a +runParse c = parse (codecParser c) "" + +-- | Print a value using a codec's printer. +runPrint :: Codec a -> a -> Text +runPrint = codecPrinter + +-- | Parse, print, and re-parse — testing that printed output is stable. +-- +-- @roundtrip codec val@ prints @val@ then parses the result. If the codec +-- is well-behaved, @roundtrip codec val == Right val@. +roundtrip :: Codec a -> a -> Either (ParseErrorBundle Text Void) a +roundtrip c = runParse c . runPrint c diff --git a/src/Purekell/Haskell.hs b/src/Purekell/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Purekell/Haskell.hs @@ -0,0 +1,43 @@ +-- | Haskell-specific codecs for expressions, patterns, and literals. +-- +-- These codecs parse and print using Haskell syntax conventions: +-- +-- * Record access as function application: @field rec@ +-- * Tuples with parentheses: @(a, b, c)@ +-- * Cons patterns with @:@ operator: @x : xs@ +-- * Record fields separated by @=@: @Foo { bar = 1 }@ +module Purekell.Haskell + ( -- * Codecs + haskellLit + , haskellExpr + , haskellPat + ) where + +import Text.Megaparsec (eof) + +import Purekell.AST +import Purekell.Codec (Codec (..)) +import Purekell.Parser (ExprParsers (..), mkExprParsers, pLit, pPat, sc) +import Purekell.Printer (Target (..), printExpr, printLit, printPat) + +hsParsers :: ExprParsers +hsParsers = mkExprParsers pure + +-- | Codec for Haskell literals (integers, floats, strings, chars). +haskellLit :: Codec Lit +haskellLit = Codec { codecParser = pLit <* eof, codecPrinter = printLit } + +-- | Codec for Haskell expressions. +-- +-- Parses and prints the full expression grammar using Haskell syntax. +-- Record access is printed as function application (@field rec@), +-- tuples use parenthesized comma-separated syntax, etc. +haskellExpr :: Codec Expr +haskellExpr = Codec { codecParser = sc *> epExpr hsParsers <* eof, codecPrinter = printExpr Haskell } + +-- | Codec for Haskell patterns. +-- +-- Cons patterns use the @:@ operator (@x : xs@), tuples use parenthesized +-- comma-separated syntax, etc. +haskellPat :: Codec Pat +haskellPat = Codec { codecParser = sc *> pPat <* eof, codecPrinter = printPat Haskell } diff --git a/src/Purekell/Instance.hs b/src/Purekell/Instance.hs new file mode 100644 --- /dev/null +++ b/src/Purekell/Instance.hs @@ -0,0 +1,86 @@ +-- | Parsing and printing of typeclass instance method equations. +-- +-- This module handles the specific format of method bodies as they appear +-- in typeclass instances: +-- +-- @ +-- methodName pat1 pat2 | guard1 | guard2 = body +-- @ +-- +-- Multiple equations can be separated by semicolons: +-- +-- @ +-- fromEnum Sunday = 0; fromEnum Monday = 1 +-- @ +-- +-- This is the primary use case for purekell: translating instance method +-- bodies between Haskell and PureScript when generating bridge code. +module Purekell.Instance + ( -- * Method equations + MethodEquation (..) + -- * Target language + , Target (..) + -- * Parsing and printing + , parseMethodBody + , printMethodBody + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void (Void) +import Text.Megaparsec (Parsec, ParseErrorBundle, eof, many, parse, sepBy1) + +import Purekell.AST +import Purekell.Parser (ExprParsers (..), mkExprParsers, pAtomPat, pLowerName, sc, symbol) +import Purekell.Printer (Target (..), printExpr, printGuards, printPatAtom) + +type Parser = Parsec Void Text + +-- | A single method equation: @methodName pat1 pat2 | guard = body@. +-- +-- Represents one clause of a method definition, with the method name, +-- pattern arguments, optional guards, and the right-hand side expression. +data MethodEquation = MethodEquation + { methodName :: Name -- ^ The method name (e.g., @show@, @fromEnum@) + , methodPats :: [Pat] -- ^ Pattern arguments (may be empty) + , methodGuards :: [Guard] -- ^ Guard conditions (may be empty) + , methodBody :: Expr -- ^ The right-hand side expression + } deriving (Eq, Show) + +instanceParsers :: ExprParsers +instanceParsers = mkExprParsers pure + +pMethodEquation :: Parser MethodEquation +pMethodEquation = do + name <- pLowerName + pats <- many pAtomPat + guards <- many (epGuard instanceParsers) + _ <- symbol "=" + body <- epExpr instanceParsers + pure (MethodEquation name pats guards body) + +-- | Parse a method body consisting of one or more equations separated +-- by semicolons. +-- +-- >>> parseMethodBody "show True = \"True\"; show False = \"False\"" +-- Right [MethodEquation ...] +parseMethodBody :: Text -> Either (ParseErrorBundle Text Void) [MethodEquation] +parseMethodBody = parse (sc *> pMethodEquation `sepBy1` symbol ";" <* eof) "" + +-- | Print method equations for a target language. +-- +-- Multiple equations are separated by newlines. +-- +-- >>> printMethodBody Haskell eqs +-- "show True = \"True\"\nshow False = \"False\"" +printMethodBody :: Target -> [MethodEquation] -> Text +printMethodBody target eqs = T.intercalate "\n" (map (printMethodEq target) eqs) + +printMethodEq :: Target -> MethodEquation -> Text +printMethodEq target (MethodEquation (Name name) pats guards body) = + name <> patsText <> guardsText <> " = " <> printExpr target body + where + patsText + | null pats = "" + | otherwise = " " <> T.intercalate " " (map (printPatAtom target) pats) + guardsText = printGuards target guards diff --git a/src/Purekell/Parser.hs b/src/Purekell/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Purekell/Parser.hs @@ -0,0 +1,386 @@ +-- | Megaparsec-based parsers for the shared expression grammar. +-- +-- This module provides the building blocks for parsing both Haskell and +-- PureScript expressions into the shared AST. The parsers are +-- language-neutral — divergent syntax (like record dot-access) is handled +-- by a postfix callback passed to 'mkExprParsers'. +-- +-- Most users should use the codecs in "Purekell.Haskell" and +-- "Purekell.PureScript" rather than these parsers directly. +module Purekell.Parser + ( -- * Expression parser construction + ExprParsers (..) + , mkExprParsers + -- * Lexer utilities + , sc + , lexeme + , symbol + , keyword + -- * Literal and name parsers + , pLit + , pLowerName + , pUpperName + -- * Operator parsers + , pBacktickOp + , pOperator + -- * Field separator + , pFieldSep + -- * Pattern parsers + , pAtomPat + , pConPat + , pPat + -- * Type parser + , pType + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +import Purekell.AST + +type Parser = Parsec Void Text + +-- | Skip whitespace (spaces, tabs, newlines). No comment support. +sc :: Parser () +sc = L.space space1 empty empty + +-- | Wrap a parser to consume trailing whitespace. +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +-- | Parse an exact symbol and consume trailing whitespace. +symbol :: Text -> Parser Text +symbol = L.symbol sc + +-- | Parse a keyword (must not be followed by identifier characters). +keyword :: Text -> Parser () +keyword w = lexeme (string w *> notFollowedBy (alphaNumChar <|> char '_' <|> char '\'')) + +-- Literal parsers + +pIntLit :: Parser Lit +pIntLit = IntLit <$> lexeme L.decimal + +pFloatLit :: Parser Lit +pFloatLit = FloatLit <$> lexeme (try L.float) + +pCharLit :: Parser Lit +pCharLit = CharLit <$> lexeme (between (char '\'') (char '\'') L.charLiteral) + +pStringLit :: Parser Lit +pStringLit = StringLit . T.pack <$> lexeme (char '"' *> manyTill L.charLiteral (char '"')) + +-- | Parse a literal: character, string, float, or integer. +-- +-- Float is tried before integer to handle @3.14@ correctly. +pLit :: Parser Lit +pLit = pCharLit <|> pStringLit <|> pFloatLit <|> pIntLit + +-- Name parsers + +-- | Parse a lowercase identifier (variable or function name). +-- +-- Rejects reserved words: @case@, @of@, @let@, @in@, @where@, @do@, +-- @if@, @then@, @else@, @_@. +pLowerName :: Parser Name +pLowerName = lexeme $ try $ do + c <- lowerChar <|> char '_' + cs <- many (alphaNumChar <|> char '_' <|> char '\'') + let n = T.pack (c : cs) + if n `elem` reserved then fail ("reserved: " ++ T.unpack n) else pure (Name n) + where + reserved = ["case", "of", "let", "in", "where", "do", "if", "then", "else", "_"] + +-- | Parse an uppercase identifier (constructor or module name). +pUpperName :: Parser Name +pUpperName = lexeme $ do + c <- upperChar + cs <- many (alphaNumChar <|> char '_' <|> char '\'') + pure (Name (T.pack (c : cs))) + +-- Raw name parsers (no trailing whitespace, for qualified name components) + +pRawUpperIdent :: Parser Text +pRawUpperIdent = do + c <- upperChar + cs <- many (alphaNumChar <|> char '_' <|> char '\'') + pure (T.pack (c : cs)) + +pRawLowerIdent :: Parser Text +pRawLowerIdent = try $ do + c <- lowerChar <|> char '_' + cs <- many (alphaNumChar <|> char '_' <|> char '\'') + let n = T.pack (c : cs) + if n `elem` reserved then fail ("reserved: " ++ T.unpack n) else pure n + where + reserved = ["case", "of", "let", "in", "where", "do", "if", "then", "else", "_"] + +-- Qualified name parsers + +-- | Parse a possibly-qualified name starting with uppercase. +-- Returns 'Con', 'QCon', or 'QVar' depending on the structure. +pQualifiedOrCon :: Parser Expr +pQualifiedOrCon = lexeme $ do + first <- pRawUpperIdent + rest <- many (try (char '.' *> pRawUpperIdent)) + mLower <- optional (try (char '.' *> pRawLowerIdent)) + let allUpper = first : rest + case mLower of + Just low -> pure (QVar (map Name allUpper) (Name low)) + Nothing -> case allUpper of + [one] -> pure (Con (Name one)) + _ -> pure (QCon (map Name (init allUpper)) (Name (last allUpper))) + +-- | Parse a possibly-qualified type constructor. +pQualifiedOrTyCon :: Parser Type +pQualifiedOrTyCon = lexeme $ do + first <- pRawUpperIdent + rest <- many (try (char '.' *> pRawUpperIdent)) + let allUpper = first : rest + case allUpper of + [one] -> pure (TyCon (Name one)) + _ -> pure (TyQCon (map Name (init allUpper)) (Name (last allUpper))) + +-- | Parse a backtick-quoted operator: @\`div\`@, @\`elem\`@. +pBacktickOp :: Parser Name +pBacktickOp = lexeme $ do + _ <- char '`' + n <- pRawLowerIdent <|> pRawUpperIdent + _ <- char '`' + pure (Name n) + +-- | Parse a symbolic operator: @+@, @>>=@, @<>@, etc. +-- +-- Rejects reserved operators: @->@, @|@, @<-@, @=@, @::@. +pSymbolicOp :: Parser Name +pSymbolicOp = lexeme $ try $ do + op <- some (oneOf ("!#$%&*+./<=>?@\\^|-~:" :: [Char])) + let n = T.pack op + if n `elem` ["->", "|", "<-", "=", "::"] then fail "reserved operator" else pure (Name n) + +-- | Parse an operator — either backtick-quoted or symbolic. +pOperator :: Parser Name +pOperator = pBacktickOp <|> pSymbolicOp + +-- Pattern parsers + +pPatMinus :: Parser () +pPatMinus = () <$ lexeme (try (char '-' <* notFollowedBy (oneOf ("!#$%&*+./<=>?@\\^|-~:" :: [Char])))) + +pNumLit :: Parser Lit +pNumLit = pFloatLit <|> pIntLit + +-- | Parse an atomic pattern (no infix operators, no constructor arguments). +-- +-- Handles: negated literals, literals, wildcards, nullary constructors, +-- as-patterns, variable patterns, parenthesized\/tuple patterns, and +-- list patterns. +pAtomPat :: Parser Pat +pAtomPat = choice + [ NegLitPat <$> (pPatMinus *> pNumLit) + , LitPat <$> pLit + , WildPat <$ lexeme (char '_' <* notFollowedBy (alphaNumChar <|> char '_' <|> char '\'')) + , ConPat <$> pUpperName <*> pure [] + , try (AsPat <$> pLowerName <*> (symbol "@" *> pAtomPat)) + , VarPat <$> pLowerName + , pParenOrTuplePat + , pListPat + ] + +pListPat :: Parser Pat +pListPat = ListPat <$> (symbol "[" *> pPat `sepBy` symbol "," <* symbol "]") + +pParenOrTuplePat :: Parser Pat +pParenOrTuplePat = do + _ <- symbol "(" + p <- pPat + rest <- many (symbol "," *> pPat) + _ <- symbol ")" + pure $ case rest of + [] -> p + _ -> TuplePat (p : rest) + +pRecordPatFields :: Parser [(Name, Pat)] +pRecordPatFields = symbol "{" *> fieldPatAssign `sepBy1` symbol "," <* symbol "}" + +fieldPatAssign :: Parser (Name, Pat) +fieldPatAssign = (,) <$> pLowerName <*> (pFieldSep *> pPat) + +-- | Parse a constructor pattern, possibly with record fields or arguments. +pConPat :: Parser Pat +pConPat = do + name <- pUpperName + (RecordPat name <$> try pRecordPatFields) <|> (ConPat name <$> many pAtomPat) + +pConsOp :: Parser () +pConsOp = lexeme $ try $ () <$ char ':' <* notFollowedBy (oneOf ("!#$%&*+./<=>?@\\^|-~:" :: [Char])) + +-- | Parse a record field separator: @=@ (Haskell-style) or @:@ (PureScript-style). +-- +-- Accepts both styles so the parser is language-neutral. +pFieldSep :: Parser () +pFieldSep = () <$ symbol "=" + <|> () <$ lexeme (try (char ':' <* notFollowedBy (oneOf ("!#$%&*+./<=>?@\\^|-~:" :: [Char])))) + +-- | Parse a full pattern, including cons patterns (@x : xs@). +pPat :: Parser Pat +pPat = do + left <- pConPat <|> pAtomPat + rest <- optional (pConsOp *> pPat) + pure $ case rest of + Nothing -> left + Just r -> ConsPat left r + +-- Type parsers + +-- | Parse a type expression. +-- +-- Supports type constructors, type variables, type application, +-- function arrows (@->@), qualified type constructors, and +-- parenthesized types. +pType :: Parser Type +pType = pTyFun + +pTyFun :: Parser Type +pTyFun = do + t <- pTyApp + rest <- optional (symbol "->" *> pTyFun) -- right-associative + pure $ case rest of + Nothing -> t + Just r -> TyFun t r + +pTyApp :: Parser Type +pTyApp = do + f <- pTyAtom + args <- many pTyAtom + pure (foldl TyApp f args) + +pTyAtom :: Parser Type +pTyAtom = choice + [ pQualifiedOrTyCon + , TyVar <$> pLowerName + , symbol "(" *> pType <* symbol ")" + ] + +pDoubleColon :: Parser () +pDoubleColon = () <$ lexeme (try (string "::" <* notFollowedBy (oneOf ("!#$%&*+./<=>?@\\^|-~:" :: [Char])))) + +-- Expression parsers + +-- | The expression parsers produced by 'mkExprParsers'. +data ExprParsers = ExprParsers + { epExpr :: Parser Expr -- ^ Full expression parser + , epGuard :: Parser Guard -- ^ Guard parser (@| condition@) + } + +-- | Build expression parsers with a language-specific postfix callback. +-- +-- The postfix callback adds extra postfix operations after each atom. +-- For Haskell, this is @'pure'@ (no postfix operations). For PureScript, +-- this chains dot-accessed field names (@.field1.field2@). +-- +-- This is the key extension point that makes the parser language-neutral: +-- the entire expression grammar is shared, with only the postfix +-- callback differing between languages. +mkExprParsers :: (Expr -> Parser Expr) -> ExprParsers +mkExprParsers postfix = ExprParsers { epExpr = expr, epGuard = guard } + where + atom = choice + [ Literal <$> pLit + , pQualifiedOrCon + , Var <$> pLowerName + , pParenOrTupleOrSection + , pList + ] + pList = ListLit <$> (symbol "[" *> expr `sepBy` symbol "," <* symbol "]") + pNonMinusSymOp = lexeme $ try $ do + op <- some (oneOf ("!#$%&*+./<=>?@\\^|-~:" :: [Char])) + let n = T.pack op + if n `elem` ["->", "|", "<-", "=", "-", "::"] then fail "reserved/excluded operator" else pure (Name n) + pNonMinusOp = pBacktickOp <|> pNonMinusSymOp + pParenOrTupleOrSection = do + _ <- symbol "(" + choice + [ -- Right section: (op expr) — exclude solo minus to avoid (-x) conflict + try (RightSection <$> pNonMinusOp <*> expr <* symbol ")") + , -- Parse prefix-level expr, then decide (for left sections + infix) + do e <- prefixExpr + choice + [ -- Left section: expr op ) + try (LeftSection e <$> pOperator <* symbol ")") + , -- Infix continuation → then optional ann, then optional where, then tuple or grouping + do rest <- many ((,) <$> pOperator <*> prefixExpr) + let infE = foldl (\l (op, r) -> InfixApp l op r) e rest + annE <- pOptionalAnn infE + fullE <- pOptionalWhere annE + choice + [ Tuple . (fullE :) <$> some (symbol "," *> expr) <* symbol ")" + , fullE <$ symbol ")" + ] + ] + , -- Non-prefix expressions (lambda, if, case, let, do) inside parens + do e <- lam <|> try ifE <|> try caseE <|> try letE <|> try doE + e1 <- pOptionalAnn e + e' <- pOptionalWhere e1 + choice + [ Tuple . (e' :) <$> some (symbol "," *> expr) <* symbol ")" + , e' <$ symbol ")" + ] + ] + fieldAssign = (,) <$> pLowerName <*> (pFieldSep *> expr) + postfixChain e = do + e1 <- postfix e + updates <- many (try (symbol "{" *> fieldAssign `sepBy1` symbol "," <* symbol "}")) + case updates of + [] -> pure e1 + _ -> postfixChain (foldl RecordUpdate e1 updates) + atomWithPostfix = atom >>= postfixChain + appExpr = do + f <- atomWithPostfix + args <- many atomWithPostfix + pure (foldl App f args) + pPrefixMinus = lexeme (try (char '-' <* notFollowedBy (oneOf ("!#$%&*+./<=>?@\\^|-~:" :: [Char])))) + prefixExpr = (Neg <$> (pPrefixMinus *> appExpr)) <|> appExpr + infixExpr = do + first <- prefixExpr + rest <- many ((,) <$> pOperator <*> prefixExpr) + pure (foldl (\l (op, r) -> InfixApp l op r) first rest) + pOptionalAnn e = do + mty <- optional (pDoubleColon *> pType) + pure $ case mty of + Nothing -> e + Just ty -> Ann e ty + annExpr = infixExpr >>= pOptionalAnn + guard = symbol "|" *> (Guard <$> infixExpr) + lam = Lam <$> (symbol "\\" *> some pAtomPat) <*> (symbol "->" *> expr) + ifE = If <$> (keyword "if" *> expr) <*> (keyword "then" *> expr) <*> (keyword "else" *> expr) + caseAlt = CaseAlt <$> pPat <*> many guard <*> (symbol "->" *> expr) + caseE = Case <$> (keyword "case" *> expr <* keyword "of" <* symbol "{") + <*> (caseAlt `sepBy1` symbol ";" <* symbol "}") + binding = try funBinding <|> simpleBinding + funBinding = do + name <- pLowerName + pats <- some pAtomPat + _ <- symbol "=" + body <- expr + pure (Binding (VarPat name) (Lam pats body)) + simpleBinding = Binding <$> pPat <*> (symbol "=" *> expr) + letE = Let <$> (keyword "let" *> symbol "{" *> binding `sepBy1` symbol ";" <* symbol "}") + <*> (keyword "in" *> expr) + stmtBind = StmtBind <$> pPat <*> (symbol "<-" *> expr) + stmtLet = keyword "let" *> symbol "{" *> (StmtLet <$> binding `sepBy1` symbol ";") + <* symbol "}" <* notFollowedBy (keyword "in") + stmtExpr = StmtExpr <$> expr + stmt = try stmtBind <|> try stmtLet <|> stmtExpr + doE = Do <$> (keyword "do" *> symbol "{" *> stmt `sepBy1` symbol ";" <* symbol "}") + pOptionalWhere e = do + mbs <- optional (keyword "where" *> symbol "{" *> binding `sepBy1` symbol ";" <* symbol "}") + pure $ case mbs of + Nothing -> e + Just bs -> Where e bs + whereExpr = annExpr >>= pOptionalWhere + expr = lam <|> try ifE <|> try caseE <|> try letE <|> try doE <|> whereExpr diff --git a/src/Purekell/Printer.hs b/src/Purekell/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Purekell/Printer.hs @@ -0,0 +1,322 @@ +-- | Pretty-printers for the shared AST. +-- +-- Converts AST nodes back to source text for a given 'Target' language. +-- The printer handles all divergent syntax automatically: +-- +-- * __Record access__: @field rec@ (Haskell) vs @rec.field@ (PureScript) +-- * __Tuples__: @(a, b)@ (Haskell) vs @Tuple a b@ (PureScript) +-- * __Cons patterns__: @x : xs@ (Haskell) vs @Cons x xs@ (PureScript) +-- * __Record field separators__: @=@ (Haskell) vs @:@ (PureScript, constructor context) +-- +-- The printer inserts parentheses as needed to preserve meaning. +module Purekell.Printer + ( -- * Target language + Target (..) + -- * Operator printing + , printOp + -- * Expression printing + , printExpr + , printLit + -- * Pattern printing + , printPat + , printPatAtom + -- * Parenthesization helpers + , printAtom + , printAppFun + , printInfixArg + , printInfixLevel + -- * Guard, case alt, binding, and statement printing + , printGuard + , printGuards + , printCaseAlt + , printBinding + , printStmt + -- * Type printing + , printType + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Purekell.AST + +-- | Target language for printing. Determines syntax choices for +-- divergent constructs like record access, tuples, and cons patterns. +data Target = Haskell | PureScript + deriving (Eq, Show) + +-- Qualified name helper + +printQual :: [Name] -> Text +printQual ns = T.intercalate "." [m | Name m <- ns] + +-- | Print an operator name. Symbolic operators are printed bare (@+@, @>>=@); +-- alphanumeric operators are wrapped in backticks (@\`div\`@, @\`elem\`@). +printOp :: Name -> Text +printOp (Name n) + | T.all isSymChar n = n + | otherwise = "`" <> n <> "`" + where + isSymChar c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: [Char]) + +-- | Print an expression for the given target language. +-- +-- This is the main entry point for expression printing. It dispatches +-- to the appropriate syntax based on the 'Target' and the AST node. +printExpr :: Target -> Expr -> Text +printExpr _ (Literal l) = printLit l +printExpr _ (Var (Name n)) = n +printExpr _ (Con (Name n)) = n +printExpr t (App f x) = printAppFun t f <> " " <> printAtom t x +printExpr t (InfixApp l op r) = + printInfixArg t l <> " " <> printOp op <> " " <> printInfixArg t r +printExpr t (Lam pats body) = + "\\" <> T.intercalate " " (map (printPatAtom t) pats) <> " -> " <> printExpr t body +printExpr t (If c th el) = + "if " <> printExpr t c <> " then " <> printExpr t th <> " else " <> printExpr t el +printExpr t (Case scrut alts) = + "case " <> printExpr t scrut <> " of { " + <> T.intercalate "; " (map (printCaseAlt t) alts) + <> " }" +printExpr t (Let bindings body) = + "let { " <> T.intercalate "; " (map (printBinding t) bindings) + <> " } in " <> printExpr t body +printExpr t (Do stmts) = + "do { " <> T.intercalate "; " (map (printStmt t) stmts) <> " }" +printExpr t (Neg e) = "-" <> printAppFun t e +printExpr Haskell (RecordAccess rec (Name field)) = + field <> " " <> printAtom Haskell rec +printExpr PureScript (RecordAccess rec (Name field)) = + printAtom PureScript rec <> "." <> field +printExpr Haskell (Tuple es) = + "(" <> T.intercalate ", " (map (printExpr Haskell) es) <> ")" +printExpr PureScript (Tuple [a, b]) = + "Tuple " <> printAtom PureScript a <> " " <> printAtom PureScript b +printExpr PureScript (Tuple (a : rest)) = + "Tuple " <> printAtom PureScript a <> " " <> printAtom PureScript (Tuple rest) +printExpr PureScript (Tuple []) = + error "Tuple must have at least 2 elements" +printExpr _ (ListLit []) = "[]" +printExpr t (ListLit es) = "[" <> T.intercalate ", " (map (printExpr t) es) <> "]" +printExpr t (LeftSection e op) = "(" <> printInfixArg t e <> " " <> printOp op <> ")" +printExpr t (RightSection op e) = "(" <> printOp op <> " " <> printInfixArg t e <> ")" +printExpr t (Where e bs) = + printInfixLevel t e <> " where { " <> T.intercalate "; " (map (printBinding t) bs) <> " }" +printExpr t (Ann e ty) = + printInfixLevel t e <> " :: " <> printType ty +printExpr t (RecordUpdate e fields) = + printAtom t e <> " { " <> T.intercalate ", " (map (printRecField t e) fields) <> " }" +printExpr _ (QVar qual (Name n)) = printQual qual <> "." <> n +printExpr _ (QCon qual (Name n)) = printQual qual <> "." <> n + +printRecField :: Target -> Expr -> (Name, Expr) -> Text +printRecField t base (Name n, val) + | PureScript <- t, isConExpr base = n <> ": " <> printExpr t val + | otherwise = n <> " = " <> printExpr t val + +isConExpr :: Expr -> Bool +isConExpr (Con _) = True +isConExpr (QCon _ _) = True +isConExpr _ = False + +-- Parenthesization helpers + +-- | Determine whether an expression needs parentheses in atom position. +isCompound :: Target -> Expr -> Bool +isCompound Haskell (Tuple {}) = False +isCompound PureScript (Tuple {}) = True +isCompound _ (ListLit {}) = False +isCompound _ (LeftSection {}) = False +isCompound _ (RightSection {}) = False +isCompound _ (Neg {}) = True +isCompound Haskell (RecordAccess {}) = True +isCompound PureScript (RecordAccess {}) = False +isCompound _ (App {}) = True +isCompound _ (InfixApp {}) = True +isCompound _ (Lam {}) = True +isCompound _ (If {}) = True +isCompound _ (Case {}) = True +isCompound _ (Let {}) = True +isCompound _ (Do {}) = True +isCompound _ (Where {}) = True +isCompound _ (Ann {}) = True +isCompound _ _ = False + +-- | Print an expression in atom position, adding parentheses if needed. +-- +-- Atoms are the tightest binding context: function arguments, +-- record update targets, etc. +printAtom :: Target -> Expr -> Text +printAtom t e + | isCompound t e = "(" <> printExpr t e <> ")" + | otherwise = printExpr t e + +-- | Print an expression in function position of an application. +-- +-- Like 'printAtom' but allows nested applications without parentheses +-- (since application is left-associative). +printAppFun :: Target -> Expr -> Text +printAppFun t e@(App {}) = printExpr t e -- left-assoc app doesn't need parens on left +printAppFun t e + | isCompound t e = "(" <> printExpr t e <> ")" + | otherwise = printExpr t e + +-- | Print an expression as an argument to an infix operator. +-- +-- Parenthesizes nested infix expressions, lambdas, and other constructs +-- that would be ambiguous. +printInfixArg :: Target -> Expr -> Text +printInfixArg t e@(InfixApp {}) = "(" <> printExpr t e <> ")" +printInfixArg t e@(Lam {}) = "(" <> printExpr t e <> ")" +printInfixArg t e@(If {}) = "(" <> printExpr t e <> ")" +printInfixArg t e@(Case {}) = "(" <> printExpr t e <> ")" +printInfixArg t e@(Let {}) = "(" <> printExpr t e <> ")" +printInfixArg t e@(Do {}) = "(" <> printExpr t e <> ")" +printInfixArg t e@(Where {}) = "(" <> printExpr t e <> ")" +printInfixArg t e@(Ann {}) = "(" <> printExpr t e <> ")" +printInfixArg t e = printExpr t e + +-- | Print an expression at infix level (for where\/annotation left-hand sides). +-- +-- Parenthesizes lambdas, conditionals, and other non-infix constructs +-- but allows infix expressions and applications through. +printInfixLevel :: Target -> Expr -> Text +printInfixLevel t e@(Lam {}) = "(" <> printExpr t e <> ")" +printInfixLevel t e@(If {}) = "(" <> printExpr t e <> ")" +printInfixLevel t e@(Case {}) = "(" <> printExpr t e <> ")" +printInfixLevel t e@(Let {}) = "(" <> printExpr t e <> ")" +printInfixLevel t e@(Do {}) = "(" <> printExpr t e <> ")" +printInfixLevel t e@(Where {}) = "(" <> printExpr t e <> ")" +printInfixLevel t e@(Ann {}) = "(" <> printExpr t e <> ")" +printInfixLevel t e = printExpr t e + +-- Guard, case alt, binding, and statement printers + +-- | Print a single guard condition. +printGuard :: Target -> Guard -> Text +printGuard t (Guard e) = "| " <> printInfixLevel t e + +-- | Print a list of guards, or empty text if there are none. +printGuards :: Target -> [Guard] -> Text +printGuards _ [] = "" +printGuards t gs = " " <> T.intercalate " " (map (printGuard t) gs) + +-- | Print a case alternative: @pattern -> body@ or @pattern | guard -> body@. +printCaseAlt :: Target -> CaseAlt -> Text +printCaseAlt t (CaseAlt pat guards body) = + printPat t pat <> printGuards t guards <> " -> " <> printExpr t body + +-- | Print a let\/where binding. +-- +-- Function-style bindings (@f x = body@) are recognized when the pattern +-- is a 'VarPat' and the body is a 'Lam', and printed in compact form +-- rather than as @f = \\x -> body@. +printBinding :: Target -> Binding -> Text +printBinding t (Binding (VarPat name) (Lam pats body)) = + printPat t (VarPat name) <> " " <> T.intercalate " " (map (printPatAtom t) pats) <> " = " <> printExpr t body +printBinding t (Binding pat body) = printPat t pat <> " = " <> printExpr t body + +-- | Print a do-notation statement. +printStmt :: Target -> Stmt -> Text +printStmt t (StmtBind pat body) = printPat t pat <> " <- " <> printExpr t body +printStmt t (StmtExpr e) = printExpr t e +printStmt t (StmtLet bindings) = + "let { " <> T.intercalate "; " (map (printBinding t) bindings) <> " }" + +-- Type printer + +-- | Print a type expression. +printType :: Type -> Text +printType (TyCon (Name n)) = n +printType (TyVar (Name n)) = n +printType (TyApp f x) = printTyAppFun f <> " " <> printTyAtom x +printType (TyFun a b) = printTyFunArg a <> " -> " <> printType b +printType (TyQCon qual (Name n)) = printQual qual <> "." <> n + +printTyAtom :: Type -> Text +printTyAtom ty@(TyApp {}) = "(" <> printType ty <> ")" +printTyAtom ty@(TyFun {}) = "(" <> printType ty <> ")" +printTyAtom ty = printType ty + +printTyAppFun :: Type -> Text +printTyAppFun ty@(TyFun {}) = "(" <> printType ty <> ")" +printTyAppFun ty = printType ty + +printTyFunArg :: Type -> Text +printTyFunArg ty@(TyFun {}) = "(" <> printType ty <> ")" +printTyFunArg ty = printType ty + +-- Literal printer + +-- | Print a literal value with proper escaping. +printLit :: Lit -> Text +printLit (IntLit n) = T.pack (show n) +printLit (FloatLit d) = T.pack (show d) +printLit (StringLit s) = "\"" <> escapeString s <> "\"" +printLit (CharLit c) = "'" <> escapeChar c <> "'" + +escapeString :: Text -> Text +escapeString = T.concatMap escapeStringChar + where + escapeStringChar '"' = "\\\"" + escapeStringChar '\\' = "\\\\" + escapeStringChar '\n' = "\\n" + escapeStringChar '\t' = "\\t" + escapeStringChar c = T.singleton c + +escapeChar :: Char -> Text +escapeChar '\'' = "\\'" +escapeChar '\\' = "\\\\" +escapeChar '\n' = "\\n" +escapeChar '\t' = "\\t" +escapeChar c = T.singleton c + +-- Pattern printers + +-- | Print a pattern for the given target language. +-- +-- Handles divergent syntax: +-- +-- * __Tuples__: @(a, b)@ (Haskell) vs @Tuple a b@ (PureScript) +-- * __Cons__: @x : xs@ (Haskell) vs @Cons x xs@ (PureScript) +-- * __Record fields__: @=@ separator (Haskell) vs @:@ separator (PureScript) +printPat :: Target -> Pat -> Text +printPat _ (VarPat (Name n)) = n +printPat _ (LitPat l) = printLit l +printPat _ WildPat = "_" +printPat _ (ConPat (Name n) []) = n +printPat t (ConPat (Name n) args) = n <> " " <> T.intercalate " " (map (printPatAtom t) args) +printPat Haskell (TuplePat ps) = + "(" <> T.intercalate ", " (map (printPat Haskell) ps) <> ")" +printPat PureScript (TuplePat [a, b]) = + "Tuple " <> printPatAtom PureScript a <> " " <> printPatAtom PureScript b +printPat PureScript (TuplePat (a : rest)) = + "Tuple " <> printPatAtom PureScript a <> " " <> printPatAtom PureScript (TuplePat rest) +printPat PureScript (TuplePat []) = + error "TuplePat must have at least 2 elements" +printPat _ (ListPat []) = "[]" +printPat t (ListPat ps) = "[" <> T.intercalate ", " (map (printPat t) ps) <> "]" +printPat Haskell (ConsPat l r) = printPatAtom Haskell l <> " : " <> printPat Haskell r +printPat PureScript (ConsPat l r) = "Cons " <> printPatAtom PureScript l <> " " <> printPatAtom PureScript r +printPat t (AsPat (Name n) p) = n <> "@" <> printPatAtom t p +printPat _ (NegLitPat l) = "-" <> printLit l +printPat t (RecordPat (Name n) fields) = + n <> " { " <> T.intercalate ", " (map pf fields) <> " }" + where pf (Name fn, p) = fn <> sep <> printPat t p + sep = case t of { PureScript -> ": "; Haskell -> " = " } + +-- | Print a pattern in atom position, adding parentheses where needed. +-- +-- Constructor patterns with arguments, tuple patterns (in PureScript), +-- cons patterns, as-patterns, negated literals, and record patterns +-- all require parentheses in atom position. +printPatAtom :: Target -> Pat -> Text +printPatAtom t p@(ConPat _ (_:_)) = "(" <> printPat t p <> ")" +printPatAtom t p@(TuplePat _) = case t of + Haskell -> printPat t p -- already parenthesized + PureScript -> "(" <> printPat t p <> ")" +printPatAtom t p@(ConsPat _ _) = "(" <> printPat t p <> ")" +printPatAtom t p@(AsPat _ _) = "(" <> printPat t p <> ")" +printPatAtom t p@(NegLitPat _) = "(" <> printPat t p <> ")" +printPatAtom t p@(RecordPat _ _) = "(" <> printPat t p <> ")" +printPatAtom t p = printPat t p diff --git a/src/Purekell/PureScript.hs b/src/Purekell/PureScript.hs new file mode 100644 --- /dev/null +++ b/src/Purekell/PureScript.hs @@ -0,0 +1,54 @@ +-- | PureScript-specific codecs for expressions, patterns, and literals. +-- +-- These codecs parse and print using PureScript syntax conventions: +-- +-- * Record access with dot notation: @rec.field@ +-- * Tuples as nested @Tuple@ constructors: @Tuple a (Tuple b c)@ +-- * Cons patterns as @Cons@ constructor: @Cons x xs@ +-- * Record fields separated by @:@ in constructor contexts: @Foo { bar: 1 }@ +module Purekell.PureScript + ( -- * Codecs + purescriptLit + , purescriptExpr + , purescriptPat + ) where + +import Data.Text (Text) +import Data.Void (Void) +import Text.Megaparsec (Parsec, eof, many) +import Text.Megaparsec.Char (char) + +import Purekell.AST +import Purekell.Codec (Codec (..)) +import Purekell.Parser (ExprParsers (..), mkExprParsers, pLit, pLowerName, pPat, sc) +import Purekell.Printer (Target (..), printExpr, printLit, printPat) + +type Parser = Parsec Void Text + +-- | Parse a chain of dot-accessed fields: @.foo.bar.baz@ +pDotAccess :: Expr -> Parser Expr +pDotAccess e = do + fields <- many (char '.' *> pLowerName) + pure (foldl RecordAccess e fields) + +psParsers :: ExprParsers +psParsers = mkExprParsers pDotAccess + +-- | Codec for PureScript literals (integers, floats, strings, chars). +purescriptLit :: Codec Lit +purescriptLit = Codec { codecParser = pLit <* eof, codecPrinter = printLit } + +-- | Codec for PureScript expressions. +-- +-- Parses and prints the full expression grammar using PureScript syntax. +-- Record access uses dot notation (@rec.field@), tuples use the @Tuple@ +-- constructor, etc. +purescriptExpr :: Codec Expr +purescriptExpr = Codec { codecParser = sc *> epExpr psParsers <* eof, codecPrinter = printExpr PureScript } + +-- | Codec for PureScript patterns. +-- +-- Cons patterns use the @Cons@ constructor (@Cons x xs@), tuples use +-- the @Tuple@ constructor, etc. +purescriptPat :: Codec Pat +purescriptPat = Codec { codecParser = sc *> pPat <* eof, codecPrinter = printPat PureScript } diff --git a/test/Purekell/ASTSpec.hs b/test/Purekell/ASTSpec.hs new file mode 100644 --- /dev/null +++ b/test/Purekell/ASTSpec.hs @@ -0,0 +1,67 @@ +module Purekell.ASTSpec (spec) where + +import qualified Data.Text as T +import Test.Hspec +import Test.QuickCheck + +import Purekell.AST +import Purekell.Arbitrary () + +spec :: Spec +spec = do + describe "AST" $ do + describe "Arbitrary Name" $ do + it "generates non-empty names" $ property $ \(Name n) -> + not (T.null n) + + it "generates names starting with lowercase" $ property $ \(Name n) -> + case T.uncons n of + Just (c, _) -> c `elem` ['a'..'z'] + Nothing -> False + + describe "Arbitrary Lit" $ do + it "generates valid literals" $ property $ \lit -> + case lit of + IntLit n -> n >= 0 + FloatLit d -> d >= 0 && not (isNaN d) && not (isInfinite d) + StringLit _ -> True + CharLit _ -> True + + describe "Arbitrary Expr" $ do + it "generates valid expressions" $ property $ \expr -> + case (expr :: Expr) of + Literal _ -> True + Var _ -> True + Con _ -> True + App _ _ -> True + InfixApp {} -> True + Lam {} -> True + If {} -> True + Case {} -> True + Let {} -> True + Do {} -> True + Neg {} -> True + RecordAccess {} -> True + Tuple {} -> True + ListLit {} -> True + LeftSection {} -> True + RightSection {} -> True + Where {} -> True + Ann {} -> True + RecordUpdate {} -> True + QVar {} -> True + QCon {} -> True + + describe "Arbitrary Pat" $ do + it "generates valid patterns including RecordPat" $ property $ \pat -> + case (pat :: Pat) of + VarPat {} -> True + ConPat {} -> True + LitPat {} -> True + WildPat -> True + TuplePat {} -> True + ListPat {} -> True + ConsPat {} -> True + AsPat {} -> True + NegLitPat {} -> True + RecordPat {} -> True diff --git a/test/Purekell/Arbitrary.hs b/test/Purekell/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Purekell/Arbitrary.hs @@ -0,0 +1,391 @@ +module Purekell.Arbitrary + ( genIdent + , genUpperIdent + , noRecordAccess + , noTuple + , noTuplePat + , noConsExpr + , noConsPat + , noQualClash + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Test.QuickCheck + +import Purekell.AST +import Purekell.Instance (MethodEquation (..)) + +-- | Generate a valid Haskell/PureScript lowercase identifier +genIdent :: Gen Text +genIdent = do + c <- elements ['a'..'z'] + cs <- listOf (elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_']) + let ident = T.pack (c : cs) + if ident `elem` keywords then genIdent else pure ident + where + keywords :: [Text] + keywords = [ "case", "of", "let", "in", "where", "do", "if", "then" + , "else", "data", "type", "class", "instance", "module" + , "import", "forall", "infixl", "infixr", "infix" ] + +-- | Generate a valid uppercase identifier (for constructors) +genUpperIdent :: Gen Text +genUpperIdent = do + c <- elements ['A'..'Z'] + cs <- listOf (elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_']) + pure (T.pack (c : cs)) + +-- | Generate a qualifier (1-2 uppercase components) +genQualifier :: Gen [Name] +genQualifier = do + n <- choose (1, 2) + vectorOf n (Name <$> genUpperIdent) + +-- | Generate a valid operator name +genOperator :: Gen Name +genOperator = Name <$> elements + ["==", "/=", "<", ">", "<=", ">=", "<>", "&&", "||", "+", "*" + , "div", "mod", "elem", "seq"] + +instance Arbitrary Type where + arbitrary = sized go + where + go 0 = oneof + [ TyCon . Name <$> genUpperIdent + , TyVar <$> arbitrary + , TyQCon <$> genQualifier <*> (Name <$> genUpperIdent) + ] + go n = oneof + [ go 0 + , TyApp <$> go (n `div` 2) <*> go (n `div` 2) + , TyFun <$> go (n `div` 2) <*> go (n `div` 2) + ] + shrink (TyApp f x) = [f, x] + shrink (TyFun a b) = [a, b] + shrink (TyQCon [_] n) = [TyCon n] + shrink (TyQCon qs n) = [TyQCon (drop 1 qs) n] + shrink _ = [] + +instance Arbitrary Name where + arbitrary = Name <$> genIdent + +instance Arbitrary Lit where + arbitrary = oneof + [ IntLit . getNonNegative <$> arbitrary + , FloatLit <$> (getNonNegative <$> arbitrary) `suchThat` (\d -> not (isNaN d) && not (isInfinite d)) + , StringLit <$> genSafeString + , CharLit <$> elements (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']) + ] + where + genSafeString = T.pack <$> listOf (elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ [' ']) + +instance Arbitrary Guard where + arbitrary = sized $ \n -> Guard <$> resize (n `div` 2) arbitrary + +instance Arbitrary CaseAlt where + arbitrary = sized $ \n -> do + pat <- resize (n `div` 3) arbitrary + numGuards <- choose (0, 1) + guards <- vectorOf numGuards (resize (n `div` 3) arbitrary) + body <- resize (n `div` 3) arbitrary + pure (CaseAlt pat guards body) + + shrink (CaseAlt p gs e) = + [CaseAlt p [] e | not (null gs)] + ++ [CaseAlt p gs e' | e' <- shrink e] + +instance Arbitrary Binding where + arbitrary = sized $ \n -> Binding <$> resize (n `div` 2) arbitrary <*> resize (n `div` 2) arbitrary + + shrink (Binding p e) = [Binding p e' | e' <- shrink e] + +instance Arbitrary Stmt where + arbitrary = sized $ \n -> oneof + [ StmtBind <$> resize (n `div` 2) arbitrary <*> resize (n `div` 2) arbitrary + , StmtExpr <$> resize (n `div` 2) arbitrary + , do numBinds <- choose (1, 2) + StmtLet <$> vectorOf numBinds (resize (n `div` 3) arbitrary) + ] + + shrink (StmtBind _ e) = [StmtExpr e] + shrink (StmtExpr e) = [StmtExpr e' | e' <- shrink e] + shrink (StmtLet bs) = [StmtLet bs' | bs' <- shrinkList shrink bs, not (null bs')] + +instance Arbitrary Expr where + arbitrary = sized go + where + go 0 = oneof + [ Literal <$> arbitrary + , Var <$> arbitrary + , Con . Name <$> genUpperIdent + , QVar <$> genQualifier <*> arbitrary + , QCon <$> genQualifier <*> (Name <$> genUpperIdent) + ] + go n = frequency + [ (3, go 0) + , (2, App <$> go half <*> go half) + , (2, InfixApp <$> go half <*> genOperator <*> go half) + , (1, do numPats <- choose (1, 2) + pats <- vectorOf numPats (resize half arbitrary) + body <- go half + pure (Lam pats body)) + , (1, If <$> go third <*> go third <*> go third) + , (1, do scrut <- go half + numAlts <- choose (1, 2) + alts <- vectorOf numAlts (resize half arbitrary) + pure (Case scrut alts)) + , (1, do numBinds <- choose (1, 2) + bindings <- vectorOf numBinds (resize half arbitrary) + body <- go half + pure (Let bindings body)) + , (1, do numStmts <- choose (1, 3) + stmts <- vectorOf numStmts (resize half arbitrary) + pure (Do stmts)) + , (1, Neg <$> go half) + , (1, RecordAccess <$> go half <*> (Name <$> genIdent)) + , (1, do numElems <- choose (2, 3) + Tuple <$> vectorOf numElems (go (n `div` (numElems + 1)))) + , (1, do numElems <- choose (0, 3) + ListLit <$> vectorOf numElems (go (n `div` (numElems + 1)))) + , (1, LeftSection <$> go half <*> genOperator) + , (1, RightSection <$> genOperator <*> go half) + , (1, do numBinds <- choose (1, 2) + bindings <- vectorOf numBinds (resize half arbitrary) + body <- go half + pure (Where body bindings)) + , (1, Ann <$> go half <*> resize half arbitrary) + , (1, do numFields <- choose (1, 2) + fields <- vectorOf numFields ((,) <$> (Name <$> genIdent) <*> go (n `div` (numFields + 1))) + RecordUpdate <$> go half <*> pure fields) + , (1, QVar <$> genQualifier <*> arbitrary) + , (1, QCon <$> genQualifier <*> (Name <$> genUpperIdent)) + ] + where + half = n `div` 2 + third = n `div` 3 + + shrink (App f x) = [f, x] ++ [App f' x | f' <- shrink f] ++ [App f x' | x' <- shrink x] + shrink (InfixApp l _ r) = [l, r] + shrink (Lam _ body) = [body] + shrink (If c t e) = [c, t, e] + shrink (Case scrut alts) = scrut : [body | CaseAlt _ _ body <- alts] + shrink (Let _ body) = [body] + shrink (Do stmts) = [e | StmtExpr e <- stmts] + shrink (Neg e) = e : [Neg e' | e' <- shrink e] + shrink (RecordAccess rec _) = [rec] + shrink (Tuple es) = es + shrink (ListLit es) = es ++ [ListLit es' | es' <- shrinkList shrink es] + shrink (LeftSection e _) = [e] + shrink (RightSection _ e) = [e] + shrink (Where e bs) = [e] ++ [Where e bs' | bs' <- shrinkList shrink bs, not (null bs')] + shrink (Ann e _) = [e] + shrink (RecordUpdate e _) = [e] + shrink (QVar [_] n) = [Var n] + shrink (QVar qs n) = [QVar (drop 1 qs) n] + shrink (QCon [_] n) = [Con n] + shrink (QCon qs n) = [QCon (drop 1 qs) n] + shrink _ = [] + +instance Arbitrary Pat where + arbitrary = sized go + where + go 0 = oneof + [ VarPat <$> arbitrary + , LitPat <$> arbitrary + , pure WildPat + , ConPat . Name <$> genUpperIdent <*> pure [] + ] + go n = oneof + [ go 0 + , do con <- Name <$> genUpperIdent + numArgs <- choose (1, 3) + args <- vectorOf numArgs (go (n `div` (numArgs + 1))) + pure (ConPat con args) + , do numElems <- choose (2, 3) + TuplePat <$> vectorOf numElems (go (n `div` (numElems + 1))) + , do numElems <- choose (0, 3) + ListPat <$> vectorOf numElems (go (n `div` (numElems + 1))) + , ConsPat <$> go (n `div` 2) <*> go (n `div` 2) + , AsPat <$> arbitrary <*> go (n `div` 2) + , NegLitPat <$> oneof + [ IntLit . getNonNegative <$> arbitrary + , FloatLit <$> (getNonNegative <$> arbitrary) `suchThat` (\d -> not (isNaN d) && not (isInfinite d)) + ] + , do con <- Name <$> genUpperIdent + numFields <- choose (1, 2) + fields <- vectorOf numFields ((,) <$> (Name <$> genIdent) <*> go (n `div` (numFields + 1))) + pure (RecordPat con fields) + ] + + shrink (ConPat n args) = [ConPat n (take i args) | i <- [0 .. length args - 1]] + ++ [ConPat n args' | args' <- shrinkList shrink args] + shrink (TuplePat ps) = ps ++ [TuplePat ps' | ps' <- shrinkList shrink ps, length ps' >= 2] + shrink (ListPat ps) = ps ++ [ListPat ps' | ps' <- shrinkList shrink ps] + shrink (ConsPat l r) = [l, r] ++ [ConsPat l' r | l' <- shrink l] ++ [ConsPat l r' | r' <- shrink r] + shrink (AsPat _ p) = [p] + shrink (NegLitPat l) = [LitPat l] + shrink (RecordPat n [(_, p)]) = [ConPat n [p]] + shrink (RecordPat n fields) = [RecordPat n (take i fields) | i <- [1 .. length fields - 1]] + shrink _ = [] + +-- | Check recursively that an expression tree contains no RecordAccess. +-- RecordAccess only roundtrips in PureScript (dot syntax), not Haskell +-- (prints as function application) or Instance (no dot access parser). +noRecordAccess :: Expr -> Bool +noRecordAccess (Neg e) = noRecordAccess e +noRecordAccess (RecordAccess _ _) = False +noRecordAccess (App f x) = noRecordAccess f && noRecordAccess x +noRecordAccess (InfixApp l _ r) = noRecordAccess l && noRecordAccess r +noRecordAccess (Lam _ e) = noRecordAccess e +noRecordAccess (If c t e) = noRecordAccess c && noRecordAccess t && noRecordAccess e +noRecordAccess (Case scrut alts) = noRecordAccess scrut && all altOk alts + where altOk (CaseAlt _ gs e) = all guardOk gs && noRecordAccess e + guardOk (Guard e) = noRecordAccess e +noRecordAccess (Let bs e) = all bindOk bs && noRecordAccess e + where bindOk (Binding _ e') = noRecordAccess e' +noRecordAccess (Do stmts) = all stmtOk stmts + where stmtOk (StmtBind _ e) = noRecordAccess e + stmtOk (StmtExpr e) = noRecordAccess e + stmtOk (StmtLet bs) = all (\(Binding _ e) -> noRecordAccess e) bs +noRecordAccess (Tuple es) = all noRecordAccess es +noRecordAccess (ListLit es) = all noRecordAccess es +noRecordAccess (LeftSection e _) = noRecordAccess e +noRecordAccess (RightSection _ e) = noRecordAccess e +noRecordAccess (Where e bs) = noRecordAccess e && all bindOk bs + where bindOk (Binding p e') = noRecordAccessPat p && noRecordAccess e' +noRecordAccess (Ann e _) = noRecordAccess e +noRecordAccess (RecordUpdate e fields) = noRecordAccess e && all (\(_, v) -> noRecordAccess v) fields +noRecordAccess _ = True + +noRecordAccessPat :: Pat -> Bool +noRecordAccessPat (ConPat _ args) = all noRecordAccessPat args +noRecordAccessPat (TuplePat ps) = all noRecordAccessPat ps +noRecordAccessPat (ListPat ps) = all noRecordAccessPat ps +noRecordAccessPat (ConsPat l r) = noRecordAccessPat l && noRecordAccessPat r +noRecordAccessPat (AsPat _ p) = noRecordAccessPat p +noRecordAccessPat (RecordPat _ fields) = all (noRecordAccessPat . snd) fields +noRecordAccessPat _ = True + +-- | Check recursively that an expression tree contains no Tuple. +-- Tuple doesn't roundtrip in PureScript (prints as App (Con "Tuple") ...). +noTuple :: Expr -> Bool +noTuple (Tuple _) = False +noTuple (Neg e) = noTuple e +noTuple (RecordAccess e _) = noTuple e +noTuple (App f x) = noTuple f && noTuple x +noTuple (InfixApp l _ r) = noTuple l && noTuple r +noTuple (Lam ps e) = all noTuplePat ps && noTuple e +noTuple (If c t e) = noTuple c && noTuple t && noTuple e +noTuple (Case scrut alts) = noTuple scrut && all altOk alts + where altOk (CaseAlt p gs e) = noTuplePat p && all guardOk gs && noTuple e + guardOk (Guard e) = noTuple e +noTuple (Let bs e) = all bindOk bs && noTuple e + where bindOk (Binding p e') = noTuplePat p && noTuple e' +noTuple (Do stmts) = all stmtOk stmts + where stmtOk (StmtBind p e) = noTuplePat p && noTuple e + stmtOk (StmtExpr e) = noTuple e + stmtOk (StmtLet bs) = all (\(Binding p e) -> noTuplePat p && noTuple e) bs +noTuple (ListLit es) = all noTuple es +noTuple (LeftSection e _) = noTuple e +noTuple (RightSection _ e) = noTuple e +noTuple (Where e bs) = noTuple e && all bindOk bs + where bindOk (Binding p e') = noTuplePat p && noTuple e' +noTuple (Ann e _) = noTuple e +noTuple (RecordUpdate e fields) = noTuple e && all (\(_, v) -> noTuple v) fields +noTuple _ = True + +-- | Check that a pattern contains no TuplePat (and no Tuple in nested expressions). +noTuplePat :: Pat -> Bool +noTuplePat (TuplePat _) = False +noTuplePat (ConPat _ args) = all noTuplePat args +noTuplePat (ListPat ps) = all noTuplePat ps +noTuplePat (ConsPat l r) = noTuplePat l && noTuplePat r +noTuplePat (AsPat _ p) = noTuplePat p +noTuplePat (RecordPat _ fields) = all (noTuplePat . snd) fields +noTuplePat (NegLitPat _) = True +noTuplePat _ = True + +-- | Check recursively that an expression tree contains no ConsPat. +-- ConsPat doesn't roundtrip in PureScript (prints as Cons → parses as ConPat). +noConsExpr :: Expr -> Bool +noConsExpr (Neg e) = noConsExpr e +noConsExpr (RecordAccess e _) = noConsExpr e +noConsExpr (App f x) = noConsExpr f && noConsExpr x +noConsExpr (InfixApp l _ r) = noConsExpr l && noConsExpr r +noConsExpr (Lam ps e) = all noConsPat ps && noConsExpr e +noConsExpr (If c t e) = noConsExpr c && noConsExpr t && noConsExpr e +noConsExpr (Case scrut alts) = noConsExpr scrut && all altOk alts + where altOk (CaseAlt p gs e) = noConsPat p && all guardOk gs && noConsExpr e + guardOk (Guard e) = noConsExpr e +noConsExpr (Let bs e) = all bindOk bs && noConsExpr e + where bindOk (Binding p e') = noConsPat p && noConsExpr e' +noConsExpr (Do stmts) = all stmtOk stmts + where stmtOk (StmtBind p e) = noConsPat p && noConsExpr e + stmtOk (StmtExpr e) = noConsExpr e + stmtOk (StmtLet bs) = all (\(Binding p e) -> noConsPat p && noConsExpr e) bs +noConsExpr (Tuple es) = all noConsExpr es +noConsExpr (ListLit es) = all noConsExpr es +noConsExpr (LeftSection e _) = noConsExpr e +noConsExpr (RightSection _ e) = noConsExpr e +noConsExpr (Where e bs) = noConsExpr e && all bindOk bs + where bindOk (Binding p e') = noConsPat p && noConsExpr e' +noConsExpr (Ann e _) = noConsExpr e +noConsExpr (RecordUpdate e fields) = noConsExpr e && all (\(_, v) -> noConsExpr v) fields +noConsExpr _ = True + +-- | Check that a pattern contains no ConsPat. +noConsPat :: Pat -> Bool +noConsPat (ConsPat _ _) = False +noConsPat (ConPat _ args) = all noConsPat args +noConsPat (TuplePat ps) = all noConsPat ps +noConsPat (ListPat ps) = all noConsPat ps +noConsPat (AsPat _ p) = noConsPat p +noConsPat (RecordPat _ fields) = all (noConsPat . snd) fields +noConsPat (NegLitPat _) = True +noConsPat _ = True + +-- | Check recursively that no RecordAccess has a Con or QCon as its base. +-- RecordAccess (Con "Foo") "bar" prints as Foo.bar which re-parses as QVar. +noQualClash :: Expr -> Bool +noQualClash (RecordAccess (Con _) _) = False +noQualClash (RecordAccess (QCon _ _) _) = False +noQualClash (Neg e) = noQualClash e +noQualClash (RecordAccess e _) = noQualClash e +noQualClash (App f x) = noQualClash f && noQualClash x +noQualClash (InfixApp l _ r) = noQualClash l && noQualClash r +noQualClash (Lam _ e) = noQualClash e +noQualClash (If c t e) = noQualClash c && noQualClash t && noQualClash e +noQualClash (Case scrut alts) = noQualClash scrut && all altOk alts + where altOk (CaseAlt _ gs e) = all guardOk gs && noQualClash e + guardOk (Guard e) = noQualClash e +noQualClash (Let bs e) = all bindOk bs && noQualClash e + where bindOk (Binding _ e') = noQualClash e' +noQualClash (Do stmts) = all stmtOk stmts + where stmtOk (StmtBind _ e) = noQualClash e + stmtOk (StmtExpr e) = noQualClash e + stmtOk (StmtLet bs) = all (\(Binding _ e) -> noQualClash e) bs +noQualClash (Tuple es) = all noQualClash es +noQualClash (ListLit es) = all noQualClash es +noQualClash (LeftSection e _) = noQualClash e +noQualClash (RightSection _ e) = noQualClash e +noQualClash (Where e bs) = noQualClash e && all bindOk bs + where bindOk (Binding _ e') = noQualClash e' +noQualClash (Ann e _) = noQualClash e +noQualClash (RecordUpdate e fields) = noQualClash e && all (\(_, v) -> noQualClash v) fields +noQualClash _ = True + +instance Arbitrary MethodEquation where + arbitrary = sized $ \n -> do + name <- Name <$> genIdent + numPats <- choose (0, 3) + pats <- vectorOf numPats (resize (n `div` 3) arbitrary) + numGuards <- choose (0, 1) + guards <- vectorOf numGuards (resize (n `div` 3) arbitrary) + body <- resize (n `div` 2) arbitrary + pure (MethodEquation name pats guards body) + + shrink (MethodEquation name pats guards body) = + [MethodEquation name pats [] body | not (null guards)] + ++ [MethodEquation name [] guards body | not (null pats)] + ++ [MethodEquation name pats guards body' | body' <- shrink body] diff --git a/test/Purekell/DivergentSpec.hs b/test/Purekell/DivergentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Purekell/DivergentSpec.hs @@ -0,0 +1,342 @@ +module Purekell.DivergentSpec (spec) where + +import Test.Hspec + +import Purekell.AST +import Purekell.Codec (runParse, runPrint) +import Purekell.Haskell (haskellExpr, haskellPat) +import Purekell.PureScript (purescriptExpr, purescriptPat) + +spec :: Spec +spec = do + describe "Divergent constructs" $ do + describe "Record access" $ do + let ast = RecordAccess (Var (Name "rec")) (Name "field") + + it "Haskell prints as function application: field rec" $ do + runPrint haskellExpr ast `shouldBe` "field rec" + + it "PureScript prints as dot access: rec.field" $ do + runPrint purescriptExpr ast `shouldBe` "rec.field" + + it "PureScript parses dot access" $ do + runParse purescriptExpr "rec.field" `shouldBe` Right ast + + it "Haskell -> PureScript translation works for RecordAccess" $ do + -- The Haskell output "field rec" is App (Var field) (Var rec) + -- when parsed by Haskell; but the AST RecordAccess translates + -- to different syntax in each language + let hsText = runPrint haskellExpr ast + hsText `shouldBe` "field rec" + let psText = runPrint purescriptExpr ast + psText `shouldBe` "rec.field" + + describe "Chained record access" $ do + let ast = RecordAccess (RecordAccess (Var (Name "rec")) (Name "inner")) (Name "field") + + it "PureScript prints chained dots" $ do + runPrint purescriptExpr ast `shouldBe` "rec.inner.field" + + it "PureScript parses chained dots" $ do + runParse purescriptExpr "rec.inner.field" `shouldBe` Right ast + + it "Haskell prints as nested application" $ do + runPrint haskellExpr ast `shouldBe` "field (inner rec)" + + describe "Tuple expressions" $ do + describe "Pair" $ do + let ast = Tuple [Var (Name "a"), Var (Name "b")] + + it "Haskell prints as (a, b)" $ do + runPrint haskellExpr ast `shouldBe` "(a, b)" + + it "PureScript prints as Tuple a b" $ do + runPrint purescriptExpr ast `shouldBe` "Tuple a b" + + it "Haskell parses (a, b) as Tuple" $ do + runParse haskellExpr "(a, b)" `shouldBe` Right ast + + describe "Triple" $ do + let ast = Tuple [Var (Name "a"), Var (Name "b"), Var (Name "c")] + + it "Haskell prints as (a, b, c)" $ do + runPrint haskellExpr ast `shouldBe` "(a, b, c)" + + it "PureScript prints as nested Tuple" $ do + runPrint purescriptExpr ast `shouldBe` "Tuple a (Tuple b c)" + + it "Haskell parses (a, b, c) as Tuple" $ do + runParse haskellExpr "(a, b, c)" `shouldBe` Right ast + + describe "4-tuple" $ do + let ast = Tuple [Var (Name "a"), Var (Name "b"), Var (Name "c"), Var (Name "d")] + + it "Haskell prints as (a, b, c, d)" $ do + runPrint haskellExpr ast `shouldBe` "(a, b, c, d)" + + it "PureScript prints as nested Tuple" $ do + runPrint purescriptExpr ast `shouldBe` "Tuple a (Tuple b (Tuple c d))" + + it "Haskell roundtrips" $ do + runParse haskellExpr "(a, b, c, d)" `shouldBe` Right ast + + describe "5-tuple" $ do + let ast = Tuple [Var (Name "a"), Var (Name "b"), Var (Name "c"), Var (Name "d"), Var (Name "e")] + + it "Haskell prints as (a, b, c, d, e)" $ do + runPrint haskellExpr ast `shouldBe` "(a, b, c, d, e)" + + it "PureScript prints as nested Tuple" $ do + runPrint purescriptExpr ast `shouldBe` "Tuple a (Tuple b (Tuple c (Tuple d e)))" + + it "Haskell roundtrips" $ do + runParse haskellExpr "(a, b, c, d, e)" `shouldBe` Right ast + + describe "Tuple patterns" $ do + describe "Pair pattern" $ do + let ast = TuplePat [VarPat (Name "x"), VarPat (Name "y")] + + it "Haskell prints as (x, y)" $ do + runPrint haskellPat ast `shouldBe` "(x, y)" + + it "PureScript prints as Tuple x y" $ do + runPrint purescriptPat ast `shouldBe` "Tuple x y" + + it "Haskell parses (x, y) as TuplePat" $ do + runParse haskellPat "(x, y)" `shouldBe` Right ast + + describe "Triple pattern" $ do + let ast = TuplePat [VarPat (Name "x"), VarPat (Name "y"), VarPat (Name "z")] + + it "Haskell prints as (x, y, z)" $ do + runPrint haskellPat ast `shouldBe` "(x, y, z)" + + it "PureScript prints as nested Tuple" $ do + runPrint purescriptPat ast `shouldBe` "Tuple x (Tuple y z)" + + it "Haskell parses (x, y, z) as TuplePat" $ do + runParse haskellPat "(x, y, z)" `shouldBe` Right ast + + describe "4-tuple pattern" $ do + let ast = TuplePat [VarPat (Name "a"), VarPat (Name "b"), VarPat (Name "c"), VarPat (Name "d")] + + it "Haskell prints as (a, b, c, d)" $ do + runPrint haskellPat ast `shouldBe` "(a, b, c, d)" + + it "PureScript prints as nested Tuple" $ do + runPrint purescriptPat ast `shouldBe` "Tuple a (Tuple b (Tuple c d))" + + it "Haskell roundtrips" $ do + runParse haskellPat "(a, b, c, d)" `shouldBe` Right ast + + describe "Nested tuple expressions" $ do + describe "Tuple as first element" $ do + let ast = Tuple [Tuple [Var (Name "a"), Var (Name "b")], Var (Name "c")] + + it "Haskell prints as ((a, b), c)" $ do + runPrint haskellExpr ast `shouldBe` "((a, b), c)" + + it "Haskell parses ((a, b), c)" $ do + runParse haskellExpr "((a, b), c)" `shouldBe` Right ast + + it "PureScript prints as Tuple (Tuple a b) c" $ do + runPrint purescriptExpr ast `shouldBe` "Tuple (Tuple a b) c" + + describe "Tuple as second element" $ do + let ast = Tuple [Var (Name "a"), Tuple [Var (Name "b"), Var (Name "c")]] + + it "Haskell prints as (a, (b, c))" $ do + runPrint haskellExpr ast `shouldBe` "(a, (b, c))" + + it "Haskell parses (a, (b, c))" $ do + runParse haskellExpr "(a, (b, c))" `shouldBe` Right ast + + it "PureScript prints as Tuple a (Tuple b c)" $ do + runPrint purescriptExpr ast `shouldBe` "Tuple a (Tuple b c)" + + describe "Triple vs nested pair" $ do + -- (a, b, c) and (a, (b, c)) are different ASTs but print the same in PS + let triple = Tuple [Var (Name "a"), Var (Name "b"), Var (Name "c")] + nested = Tuple [Var (Name "a"), Tuple [Var (Name "b"), Var (Name "c")]] + + it "PureScript prints both as Tuple a (Tuple b c)" $ do + runPrint purescriptExpr triple `shouldBe` "Tuple a (Tuple b c)" + runPrint purescriptExpr nested `shouldBe` "Tuple a (Tuple b c)" + + it "Haskell distinguishes them" $ do + runPrint haskellExpr triple `shouldBe` "(a, b, c)" + runPrint haskellExpr nested `shouldBe` "(a, (b, c))" + + it "Haskell roundtrips preserve the distinction" $ do + runParse haskellExpr "(a, b, c)" `shouldBe` Right triple + runParse haskellExpr "(a, (b, c))" `shouldBe` Right nested + + describe "Nested tuple patterns" $ do + describe "Tuple in first position" $ do + let ast = TuplePat [TuplePat [VarPat (Name "a"), VarPat (Name "b")], VarPat (Name "c")] + + it "Haskell prints as ((a, b), c)" $ do + runPrint haskellPat ast `shouldBe` "((a, b), c)" + + it "Haskell parses ((a, b), c) pattern" $ do + runParse haskellPat "((a, b), c)" `shouldBe` Right ast + + it "PureScript prints as Tuple (Tuple a b) c" $ do + runPrint purescriptPat ast `shouldBe` "Tuple (Tuple a b) c" + + describe "Tuple in second position" $ do + let ast = TuplePat [VarPat (Name "a"), TuplePat [VarPat (Name "b"), VarPat (Name "c")]] + + it "Haskell prints as (a, (b, c))" $ do + runPrint haskellPat ast `shouldBe` "(a, (b, c))" + + it "Haskell parses (a, (b, c)) pattern" $ do + runParse haskellPat "(a, (b, c))" `shouldBe` Right ast + + it "PureScript prints as Tuple a (Tuple b c)" $ do + runPrint purescriptPat ast `shouldBe` "Tuple a (Tuple b c)" + + describe "Triple vs nested pair patterns" $ do + let triple = TuplePat [VarPat (Name "a"), VarPat (Name "b"), VarPat (Name "c")] + nested = TuplePat [VarPat (Name "a"), TuplePat [VarPat (Name "b"), VarPat (Name "c")]] + + it "PureScript prints both as Tuple a (Tuple b c)" $ do + runPrint purescriptPat triple `shouldBe` "Tuple a (Tuple b c)" + runPrint purescriptPat nested `shouldBe` "Tuple a (Tuple b c)" + + it "Haskell distinguishes them" $ do + runPrint haskellPat triple `shouldBe` "(a, b, c)" + runPrint haskellPat nested `shouldBe` "(a, (b, c))" + + it "Haskell roundtrips preserve the distinction" $ do + runParse haskellPat "(a, b, c)" `shouldBe` Right triple + runParse haskellPat "(a, (b, c))" `shouldBe` Right nested + + describe "Cons patterns" $ do + describe "Simple cons" $ do + let ast = ConsPat (VarPat (Name "x")) (VarPat (Name "xs")) + + it "Haskell prints as x : xs" $ do + runPrint haskellPat ast `shouldBe` "x : xs" + + it "PureScript prints as Cons x xs" $ do + runPrint purescriptPat ast `shouldBe` "Cons x xs" + + it "Haskell parses x : xs" $ do + runParse haskellPat "x : xs" `shouldBe` Right ast + + describe "Nested cons" $ do + let ast = ConsPat (VarPat (Name "x")) (ConsPat (VarPat (Name "y")) (VarPat (Name "zs"))) + + it "Haskell prints as x : y : zs" $ do + runPrint haskellPat ast `shouldBe` "x : y : zs" + + it "PureScript prints as Cons x (Cons y zs)" $ do + runPrint purescriptPat ast `shouldBe` "Cons x (Cons y zs)" + + describe "Cons with constructor" $ do + let ast = ConsPat (ConPat (Name "Just") [VarPat (Name "x")]) (VarPat (Name "xs")) + + it "Haskell prints as (Just x) : xs" $ do + runPrint haskellPat ast `shouldBe` "(Just x) : xs" + + it "PureScript prints as Cons (Just x) xs" $ do + runPrint purescriptPat ast `shouldBe` "Cons (Just x) xs" + + describe "Cross-language one-way" $ do + it "PS Cons x xs parses as ConPat, not ConsPat" $ do + let ast = ConsPat (VarPat (Name "x")) (VarPat (Name "xs")) + psText = runPrint purescriptPat ast + psText `shouldBe` "Cons x xs" + runParse purescriptPat psText `shouldBe` + Right (ConPat (Name "Cons") [VarPat (Name "x"), VarPat (Name "xs")]) + + describe "Record construction" $ do + let ast = RecordUpdate (Con (Name "MkFoo")) [(Name "bar", Literal (IntLit 1))] + + it "Haskell prints with = separator" $ do + runPrint haskellExpr ast `shouldBe` "MkFoo { bar = 1 }" + + it "PureScript prints with : separator" $ do + runPrint purescriptExpr ast `shouldBe` "MkFoo { bar: 1 }" + + it "Haskell roundtrips" $ do + runParse haskellExpr "MkFoo { bar = 1 }" `shouldBe` Right ast + + it "PureScript roundtrips" $ do + runParse purescriptExpr "MkFoo { bar: 1 }" `shouldBe` Right ast + + it "cross-language roundtrip" $ do + let hsText = runPrint haskellExpr ast + let psText = runPrint purescriptExpr ast + runParse purescriptExpr hsText `shouldBe` Right ast + runParse haskellExpr psText `shouldBe` Right ast + + describe "Record construction with QCon" $ do + let ast = RecordUpdate (QCon [Name "Data", Name "Foo"] (Name "MkBar")) [(Name "x", Literal (IntLit 1))] + + it "Haskell prints with = separator" $ do + runPrint haskellExpr ast `shouldBe` "Data.Foo.MkBar { x = 1 }" + + it "PureScript prints with : separator" $ do + runPrint purescriptExpr ast `shouldBe` "Data.Foo.MkBar { x: 1 }" + + describe "Record update (non-constructor base)" $ do + let ast = RecordUpdate (Var (Name "rec")) [(Name "bar", Literal (IntLit 1))] + + it "Haskell prints with = separator" $ do + runPrint haskellExpr ast `shouldBe` "rec { bar = 1 }" + + it "PureScript also prints with = separator" $ do + runPrint purescriptExpr ast `shouldBe` "rec { bar = 1 }" + + describe "Record patterns" $ do + let ast = RecordPat (Name "Foo") [(Name "bar", VarPat (Name "x"))] + + it "Haskell prints with = separator" $ do + runPrint haskellPat ast `shouldBe` "Foo { bar = x }" + + it "PureScript prints with : separator" $ do + runPrint purescriptPat ast `shouldBe` "Foo { bar: x }" + + it "Haskell roundtrips" $ do + runParse haskellPat "Foo { bar = x }" `shouldBe` Right ast + + it "PureScript roundtrips" $ do + runParse purescriptPat "Foo { bar: x }" `shouldBe` Right ast + + it "cross-language roundtrip" $ do + let hsText = runPrint haskellPat ast + let psText = runPrint purescriptPat ast + runParse purescriptPat hsText `shouldBe` Right ast + runParse haskellPat psText `shouldBe` Right ast + + describe "Multi-field record pattern" $ do + let ast = RecordPat (Name "Foo") [(Name "bar", VarPat (Name "x")), (Name "baz", VarPat (Name "y"))] + + it "Haskell prints with = separator" $ do + runPrint haskellPat ast `shouldBe` "Foo { bar = x, baz = y }" + + it "PureScript prints with : separator" $ do + runPrint purescriptPat ast `shouldBe` "Foo { bar: x, baz: y }" + + it "both roundtrip" $ do + runParse haskellPat "Foo { bar = x, baz = y }" `shouldBe` Right ast + runParse purescriptPat "Foo { bar: x, baz: y }" `shouldBe` Right ast + + describe "Tuple cross-language one-way translation" $ do + it "HS Tuple -> PS text -> PS parse gives App/Con, not Tuple" $ do + let ast = Tuple [Var (Name "a"), Var (Name "b")] + psText = runPrint purescriptExpr ast + psText `shouldBe` "Tuple a b" + -- Parsing this back gives constructor application, not Tuple node + runParse purescriptExpr psText `shouldBe` + Right (App (App (Con (Name "Tuple")) (Var (Name "a"))) (Var (Name "b"))) + + it "HS TuplePat -> PS text -> PS parse gives ConPat, not TuplePat" $ do + let ast = TuplePat [VarPat (Name "x"), VarPat (Name "y")] + psText = runPrint purescriptPat ast + psText `shouldBe` "Tuple x y" + -- Parsing this back gives constructor pattern, not TuplePat node + runParse purescriptPat psText `shouldBe` + Right (ConPat (Name "Tuple") [VarPat (Name "x"), VarPat (Name "y")]) diff --git a/test/Purekell/InstanceSpec.hs b/test/Purekell/InstanceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Purekell/InstanceSpec.hs @@ -0,0 +1,270 @@ +module Purekell.InstanceSpec (spec) where + +import Test.Hspec +import Test.QuickCheck + +import Purekell.AST +import Purekell.Arbitrary (noRecordAccess, noTuple, noTuplePat, noConsExpr, noConsPat) +import Purekell.Instance + +spec :: Spec +spec = do + describe "Instance" $ do + describe "parseMethodBody" $ do + it "parses simple equality method" $ do + let input = "eq x y = x == y" + let expected = [MethodEquation + (Name "eq") + [VarPat (Name "x"), VarPat (Name "y")] + [] + (InfixApp (Var (Name "x")) (Name "==") (Var (Name "y")))] + parseMethodBody input `shouldBe` Right expected + + it "parses method with pattern matching on constructors" $ do + let input = "compare (MkId x) (MkId y) = compare x y" + let expected = [MethodEquation + (Name "compare") + [ConPat (Name "MkId") [VarPat (Name "x")], ConPat (Name "MkId") [VarPat (Name "y")]] + [] + (App (App (Var (Name "compare")) (Var (Name "x"))) (Var (Name "y")))] + parseMethodBody input `shouldBe` Right expected + + it "parses method with case expression" $ do + let input = "show x = case x of { MkId i -> show i }" + let expected = [MethodEquation + (Name "show") + [VarPat (Name "x")] + [] + (Case (Var (Name "x")) + [CaseAlt (ConPat (Name "MkId") [VarPat (Name "i")]) + [] + (App (Var (Name "show")) (Var (Name "i")))])] + parseMethodBody input `shouldBe` Right expected + + it "parses multiple equations separated by semicolons" $ do + let input = "eq (Left x) (Left y) = eq x y; eq (Right x) (Right y) = eq x y; eq _ _ = False" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> length eqs `shouldBe` 3 + + describe "printMethodBody" $ do + it "prints for Haskell" $ do + let eq = MethodEquation (Name "eq") [VarPat (Name "x"), VarPat (Name "y")] [] + (InfixApp (Var (Name "x")) (Name "==") (Var (Name "y"))) + printMethodBody Haskell [eq] `shouldBe` "eq x y = x == y" + + it "prints for PureScript" $ do + let eq = MethodEquation (Name "eq") [VarPat (Name "x"), VarPat (Name "y")] [] + (InfixApp (Var (Name "x")) (Name "==") (Var (Name "y"))) + printMethodBody PureScript [eq] `shouldBe` "eq x y = x == y" + + it "prints record access differently per target" $ do + let eq = MethodEquation (Name "eq") [VarPat (Name "x"), VarPat (Name "y")] [] + (InfixApp + (RecordAccess (Var (Name "x")) (Name "uid")) + (Name "==") + (RecordAccess (Var (Name "y")) (Name "uid"))) + printMethodBody Haskell [eq] `shouldBe` "eq x y = uid x == uid y" + printMethodBody PureScript [eq] `shouldBe` "eq x y = x.uid == y.uid" + + describe "hsToPs golden tests" $ do + it "DataID Eq instance body" $ do + let hsBody = "eq (MkDataID x) (MkDataID y) = x == y" + case parseMethodBody hsBody of + Left err -> expectationFailure (show err) + Right eqs -> do + printMethodBody Haskell eqs `shouldBe` "eq (MkDataID x) (MkDataID y) = x == y" + printMethodBody PureScript eqs `shouldBe` "eq (MkDataID x) (MkDataID y) = x == y" + + it "Show instance with string concatenation" $ do + let hsBody = "show (MkId x) = \"MkId \" <> show x" + case parseMethodBody hsBody of + Left err -> expectationFailure (show err) + Right eqs -> do + -- Same syntax in both languages with <> + printMethodBody PureScript eqs `shouldBe` "show (MkId x) = \"MkId \" <> show x" + + describe "Tuple in instance methods" $ do + it "Haskell prints tuple in method body" $ do + let eq = MethodEquation (Name "toPair") [ConPat (Name "MkT") [VarPat (Name "x"), VarPat (Name "y")]] [] + (Tuple [Var (Name "x"), Var (Name "y")]) + printMethodBody Haskell [eq] `shouldBe` "toPair (MkT x y) = (x, y)" + + it "PureScript prints tuple in method body" $ do + let eq = MethodEquation (Name "toPair") [ConPat (Name "MkT") [VarPat (Name "x"), VarPat (Name "y")]] [] + (Tuple [Var (Name "x"), Var (Name "y")]) + printMethodBody PureScript [eq] `shouldBe` "toPair (MkT x y) = Tuple x y" + + it "Haskell prints tuple pattern in method args" $ do + let eq = MethodEquation (Name "fst'") [TuplePat [VarPat (Name "a"), VarPat (Name "b")]] [] + (Var (Name "a")) + printMethodBody Haskell [eq] `shouldBe` "fst' (a, b) = a" + + it "PureScript prints tuple pattern in method args" $ do + let eq = MethodEquation (Name "fst'") [TuplePat [VarPat (Name "a"), VarPat (Name "b")]] [] + (Var (Name "a")) + printMethodBody PureScript [eq] `shouldBe` "fst' (Tuple a b) = a" + + it "Haskell tuple in method body roundtrips" $ do + let input = "toPair (MkT x y) = (x, y)" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> printMethodBody Haskell eqs `shouldBe` input + + it "Haskell tuple pattern in method args roundtrips" $ do + let input = "fst' (a, b) = a" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> printMethodBody Haskell eqs `shouldBe` input + + describe "Cons pattern in instance methods" $ do + it "Haskell prints cons pattern in method args" $ do + let eq = MethodEquation (Name "head'") [ConsPat (VarPat (Name "x")) WildPat] [] + (Var (Name "x")) + printMethodBody Haskell [eq] `shouldBe` "head' (x : _) = x" + + it "PureScript prints cons pattern in method args" $ do + let eq = MethodEquation (Name "head'") [ConsPat (VarPat (Name "x")) WildPat] [] + (Var (Name "x")) + printMethodBody PureScript [eq] `shouldBe` "head' (Cons x _) = x" + + describe "List in instance methods" $ do + it "list pattern in method args" $ do + let eq = MethodEquation (Name "single") [ListPat [VarPat (Name "x")]] [] + (Var (Name "x")) + printMethodBody Haskell [eq] `shouldBe` "single [x] = x" + printMethodBody PureScript [eq] `shouldBe` "single [x] = x" + + it "list literal in method body" $ do + let eq = MethodEquation (Name "wrap") [VarPat (Name "x")] [] + (ListLit [Var (Name "x")]) + printMethodBody Haskell [eq] `shouldBe` "wrap x = [x]" + printMethodBody PureScript [eq] `shouldBe` "wrap x = [x]" + + describe "As-pattern in method args" $ do + it "Haskell prints as-pattern in method args" $ do + let eq = MethodEquation (Name "head'") [AsPat (Name "xs") (ConsPat (VarPat (Name "x")) WildPat)] [] + (Var (Name "x")) + printMethodBody Haskell [eq] `shouldBe` "head' (xs@(x : _)) = x" + printMethodBody PureScript [eq] `shouldBe` "head' (xs@(Cons x _)) = x" + + it "Haskell as-pattern roundtrips via parseMethodBody" $ do + let input = "head' (xs@(x : _)) = x" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> printMethodBody Haskell eqs `shouldBe` input + + describe "Negated literal in method" $ do + it "prints and roundtrips negated literal pattern" $ do + let eq = MethodEquation (Name "isNegOne") [NegLitPat (IntLit 1)] [] + (Con (Name "True")) + printMethodBody Haskell [eq] `shouldBe` "isNegOne (-1) = True" + printMethodBody PureScript [eq] `shouldBe` "isNegOne (-1) = True" + + it "Haskell negated literal roundtrips via parseMethodBody" $ do + let input = "isNegOne (-1) = True" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> printMethodBody Haskell eqs `shouldBe` input + + describe "Where clause in method body" $ do + it "prints and roundtrips where in method body" $ do + let input = "f x = y where { y = x + 1 }" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> printMethodBody Haskell eqs `shouldBe` input + + it "where with multiple bindings in method body" $ do + let input = "f x = a + b where { a = x; b = 1 }" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> printMethodBody Haskell eqs `shouldBe` input + + describe "Type annotation in method body" $ do + it "prints and roundtrips type annotation in method body" $ do + let input = "f x = x :: Int" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> printMethodBody Haskell eqs `shouldBe` input + + it "prints type annotation for PureScript" $ do + let eq = MethodEquation (Name "f") [VarPat (Name "x")] [] + (Ann (Var (Name "x")) (TyCon (Name "Int"))) + printMethodBody PureScript [eq] `shouldBe` "f x = x :: Int" + + describe "Record update in method body" $ do + it "prints and roundtrips record update in method body" $ do + let input = "f x = x { y = 1 }" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> printMethodBody Haskell eqs `shouldBe` input + + it "prints record update for PureScript" $ do + let eq = MethodEquation (Name "f") [VarPat (Name "x")] [] + (RecordUpdate (Var (Name "x")) [(Name "y", Literal (IntLit 1))]) + printMethodBody PureScript [eq] `shouldBe` "f x = x { y = 1 }" + + describe "Qualified names in methods" $ do + it "method with qualified variable" $ do + let input = "f x = Data.Map.lookup x m" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> do + printMethodBody Haskell eqs `shouldBe` input + printMethodBody PureScript eqs `shouldBe` input + + it "method with qualified constructor" $ do + let input = "f x = Data.Map.Map x" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> do + printMethodBody Haskell eqs `shouldBe` input + printMethodBody PureScript eqs `shouldBe` input + + describe "Record pattern in method" $ do + it "method with record pattern" $ do + let input = "f (Foo { bar = x }) = x" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> do + printMethodBody Haskell eqs `shouldBe` input + printMethodBody PureScript eqs `shouldBe` "f (Foo { bar: x }) = x" + + it "method with record construction" $ do + let eq = MethodEquation (Name "f") [VarPat (Name "x")] [] + (RecordUpdate (Con (Name "MkFoo")) [(Name "bar", Var (Name "x"))]) + printMethodBody Haskell [eq] `shouldBe` "f x = MkFoo { bar = x }" + printMethodBody PureScript [eq] `shouldBe` "f x = MkFoo { bar: x }" + + describe "Roundtrip" $ do + let noRA (MethodEquation _ _ gs body) = + noRecordAccess body && all (\(Guard e) -> noRecordAccess e) gs + let noPsTuple (MethodEquation _ pats gs body) = + noRA (MethodEquation (Name "") [] gs body) + && noTuple body && all (\(Guard e) -> noTuple e) gs + && all noTuplePat pats + && noConsExpr body && all (\(Guard e) -> noConsExpr e) gs + && all noConsPat pats + it "Haskell printMethodBody roundtrips" $ property $ + forAll (arbitrary `suchThat` noRA) $ \eq -> + parseMethodBody (printMethodBody Haskell [eq]) === Right [eq :: MethodEquation] + + it "PureScript printMethodBody roundtrips" $ property $ + forAll (arbitrary `suchThat` noPsTuple) $ \eq -> + parseMethodBody (printMethodBody PureScript [eq]) === Right [eq :: MethodEquation] + + describe "Backtick operator in method body" $ do + it "method body with backtick operator" $ do + let input = "f x y = x `div` y" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> do + printMethodBody Haskell eqs `shouldBe` input + printMethodBody PureScript eqs `shouldBe` input + + describe "Function binding in method where" $ do + it "method body with where containing function binding" $ do + let input = "f x = g x where { g y = y + 1 }" + case parseMethodBody input of + Left err -> expectationFailure (show err) + Right eqs -> printMethodBody Haskell eqs `shouldBe` input diff --git a/test/Purekell/RoundtripSpec.hs b/test/Purekell/RoundtripSpec.hs new file mode 100644 --- /dev/null +++ b/test/Purekell/RoundtripSpec.hs @@ -0,0 +1,1055 @@ +module Purekell.RoundtripSpec (spec) where + +import Test.Hspec +import Test.QuickCheck + +import Purekell.AST +import Purekell.Arbitrary (noRecordAccess, noTuple, noTuplePat, noConsExpr, noConsPat, noQualClash) +import Purekell.Codec (roundtrip, runParse, runPrint) +import Purekell.Haskell (haskellExpr, haskellLit, haskellPat) +import Purekell.PureScript (purescriptExpr, purescriptLit, purescriptPat) + +spec :: Spec +spec = do + describe "Roundtrip" $ do + describe "Haskell" $ do + it "lit roundtrips" $ property $ \lit -> + roundtrip haskellLit lit === Right (lit :: Lit) + + it "expr roundtrips" $ property $ forAll (arbitrary `suchThat` noRecordAccess) $ \expr -> + roundtrip haskellExpr expr === Right expr + + it "pat roundtrips" $ property $ \pat -> + roundtrip haskellPat pat === Right (pat :: Pat) + + describe "PureScript" $ do + it "lit roundtrips" $ property $ \lit -> + roundtrip purescriptLit lit === Right (lit :: Lit) + + it "expr roundtrips" $ property $ forAll (arbitrary `suchThat` (\e -> noTuple e && noConsExpr e && noQualClash e)) $ \expr -> + roundtrip purescriptExpr expr === Right (expr :: Expr) + + it "pat roundtrips" $ property $ forAll (arbitrary `suchThat` (\p -> noTuplePat p && noConsPat p)) $ \pat -> + roundtrip purescriptPat pat === Right (pat :: Pat) + + describe "Cross-language" $ do + it "Haskell expr -> PureScript expr -> Haskell expr" $ property $ forAll (arbitrary `suchThat` (\e -> noRecordAccess e && noTuple e && noConsExpr e)) $ \expr -> + let hsText = runPrint haskellExpr expr + in case runParse purescriptExpr hsText of + Left err -> counterexample (show err) False + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in case runParse haskellExpr psText of + Left err -> counterexample (show err) False + Right hsExpr -> hsExpr === expr + + describe "Negation" $ do + it "parses -x" $ + runParse haskellExpr "-x" `shouldBe` Right (Neg (Var (Name "x"))) + + it "parses -42" $ + runParse haskellExpr "-42" `shouldBe` Right (Neg (Literal (IntLit 42))) + + it "parses -f x" $ + runParse haskellExpr "-f x" `shouldBe` Right (Neg (App (Var (Name "f")) (Var (Name "x")))) + + it "parses -x + y" $ + runParse haskellExpr "-x + y" `shouldBe` Right (InfixApp (Neg (Var (Name "x"))) (Name "+") (Var (Name "y"))) + + it "parses x + -y" $ + runParse haskellExpr "x + -y" `shouldBe` Right (InfixApp (Var (Name "x")) (Name "+") (Neg (Var (Name "y")))) + + it "prints -x" $ + runPrint haskellExpr (Neg (Var (Name "x"))) `shouldBe` "-x" + + it "prints -(a + b)" $ + runPrint haskellExpr (Neg (InfixApp (Var (Name "a")) (Name "+") (Var (Name "b")))) `shouldBe` "-(a + b)" + + it "prints -(-x)" $ + runPrint haskellExpr (Neg (Neg (Var (Name "x")))) `shouldBe` "-(-x)" + + it "roundtrips negation via PureScript" $ + runParse purescriptExpr (runPrint purescriptExpr (Neg (Var (Name "x")))) `shouldBe` Right (Neg (Var (Name "x"))) + + it "does not treat -> as negation" $ + runParse haskellExpr "\\x -> x" `shouldBe` Right (Lam [VarPat (Name "x")] (Var (Name "x"))) + + describe "Float literals" $ do + it "parses 3.14 as FloatLit" $ + runParse haskellExpr "3.14" `shouldBe` Right (Literal (FloatLit 3.14)) + + it "parses 0.5 as FloatLit" $ + runParse haskellExpr "0.5" `shouldBe` Right (Literal (FloatLit 0.5)) + + it "parses 1.0e-2 (scientific notation)" $ + runParse haskellExpr "1.0e-2" `shouldBe` Right (Literal (FloatLit 1.0e-2)) + + it "42 remains IntLit (not FloatLit)" $ + runParse haskellExpr "42" `shouldBe` Right (Literal (IntLit 42)) + + it "prints FloatLit 3.14" $ + runPrint haskellExpr (Literal (FloatLit 3.14)) `shouldBe` "3.14" + + it "parses -3.14 as negated float" $ + runParse haskellExpr "-3.14" `shouldBe` Right (Neg (Literal (FloatLit 3.14))) + + it "parses x + 3.14" $ + runParse haskellExpr "x + 3.14" `shouldBe` Right (InfixApp (Var (Name "x")) (Name "+") (Literal (FloatLit 3.14))) + + it "PureScript parses 3.14" $ + runParse purescriptExpr "3.14" `shouldBe` Right (Literal (FloatLit 3.14)) + + it "PureScript prints FloatLit 3.14" $ + runPrint purescriptExpr (Literal (FloatLit 3.14)) `shouldBe` "3.14" + + it "float literal in pattern" $ + runParse haskellExpr "case x of { 3.14 -> y }" `shouldBe` + Right (Case (Var (Name "x")) [CaseAlt (LitPat (FloatLit 3.14)) [] (Var (Name "y"))]) + + describe "Tuple in context" $ do + it "parses \\(x, y) -> x" $ + runParse haskellExpr "\\(x, y) -> x" `shouldBe` + Right (Lam [TuplePat [VarPat (Name "x"), VarPat (Name "y")]] (Var (Name "x"))) + + it "prints \\(x, y) -> x" $ + runPrint haskellExpr (Lam [TuplePat [VarPat (Name "x"), VarPat (Name "y")]] (Var (Name "x"))) + `shouldBe` "\\(x, y) -> x" + + it "parses case p of { (a, b) -> a }" $ + runParse haskellExpr "case p of { (a, b) -> a }" `shouldBe` + Right (Case (Var (Name "p")) + [CaseAlt (TuplePat [VarPat (Name "a"), VarPat (Name "b")]) [] (Var (Name "a"))]) + + it "prints case with tuple pattern" $ + runPrint haskellExpr (Case (Var (Name "p")) + [CaseAlt (TuplePat [VarPat (Name "a"), VarPat (Name "b")]) [] (Var (Name "a"))]) + `shouldBe` "case p of { (a, b) -> a }" + + it "roundtrips \\(x, y) -> x + y" $ + let ast = Lam [TuplePat [VarPat (Name "x"), VarPat (Name "y")]] + (InfixApp (Var (Name "x")) (Name "+") (Var (Name "y"))) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips case with tuple pattern" $ + let ast = Case (Var (Name "p")) + [CaseAlt (TuplePat [VarPat (Name "a"), VarPat (Name "b")]) [] (Var (Name "a"))] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "parses complex expressions inside tuple" $ + runParse haskellExpr "(a + b, f c)" `shouldBe` + Right (Tuple + [ InfixApp (Var (Name "a")) (Name "+") (Var (Name "b")) + , App (Var (Name "f")) (Var (Name "c")) + ]) + + it "prints complex expressions inside tuple" $ + runPrint haskellExpr (Tuple + [ InfixApp (Var (Name "a")) (Name "+") (Var (Name "b")) + , App (Var (Name "f")) (Var (Name "c")) + ]) + `shouldBe` "(a + b, f c)" + + it "roundtrips complex expressions inside tuple" $ + let ast = Tuple + [ InfixApp (Var (Name "a")) (Name "+") (Var (Name "b")) + , App (Var (Name "f")) (Var (Name "c")) + ] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "Haskell tuple as function argument" $ + let ast = App (Var (Name "f")) (Tuple [Var (Name "a"), Var (Name "b")]) + in do + runPrint haskellExpr ast `shouldBe` "f (a, b)" + roundtrip haskellExpr ast `shouldBe` Right ast + + it "PureScript tuple as function argument gets parens" $ + let ast = App (Var (Name "f")) (Tuple [Var (Name "a"), Var (Name "b")]) + in runPrint purescriptExpr ast `shouldBe` "f (Tuple a b)" + + describe "Cross-language" $ do + it "Haskell pat -> PureScript pat -> Haskell pat" $ property $ forAll (arbitrary `suchThat` (\p -> noTuplePat p && noConsPat p)) $ \pat -> + let hsText = runPrint haskellPat (pat :: Pat) + in case runParse purescriptPat hsText of + Left err -> counterexample (show err) False + Right psPat -> + let psText = runPrint purescriptPat psPat + in case runParse haskellPat psText of + Left err -> counterexample (show err) False + Right hsPat -> hsPat === pat + + describe "List literals" $ do + it "parses []" $ + runParse haskellExpr "[]" `shouldBe` Right (ListLit []) + + it "parses [x]" $ + runParse haskellExpr "[x]" `shouldBe` Right (ListLit [Var (Name "x")]) + + it "parses [1, 2, 3]" $ + runParse haskellExpr "[1, 2, 3]" `shouldBe` + Right (ListLit [Literal (IntLit 1), Literal (IntLit 2), Literal (IntLit 3)]) + + it "parses [a + b, f c]" $ + runParse haskellExpr "[a + b, f c]" `shouldBe` + Right (ListLit + [ InfixApp (Var (Name "a")) (Name "+") (Var (Name "b")) + , App (Var (Name "f")) (Var (Name "c")) + ]) + + it "parses [[1], [2]]" $ + runParse haskellExpr "[[1], [2]]" `shouldBe` + Right (ListLit [ListLit [Literal (IntLit 1)], ListLit [Literal (IntLit 2)]]) + + it "prints []" $ + runPrint haskellExpr (ListLit []) `shouldBe` "[]" + + it "prints [1, 2, 3]" $ + runPrint haskellExpr (ListLit [Literal (IntLit 1), Literal (IntLit 2), Literal (IntLit 3)]) + `shouldBe` "[1, 2, 3]" + + it "roundtrips [] in Haskell" $ + roundtrip haskellExpr (ListLit []) `shouldBe` Right (ListLit []) + + it "roundtrips [x] in Haskell" $ + roundtrip haskellExpr (ListLit [Var (Name "x")]) `shouldBe` Right (ListLit [Var (Name "x")]) + + it "roundtrips [1, 2, 3] in Haskell" $ + let ast = ListLit [Literal (IntLit 1), Literal (IntLit 2), Literal (IntLit 3)] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips in PureScript" $ + let ast = ListLit [Var (Name "x"), Var (Name "y")] + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "list literal as function argument" $ + let ast = App (Var (Name "f")) (ListLit [Var (Name "a"), Var (Name "b")]) + in do + runPrint haskellExpr ast `shouldBe` "f [a, b]" + roundtrip haskellExpr ast `shouldBe` Right ast + + it "PureScript prints list same as Haskell" $ + runPrint purescriptExpr (ListLit [Literal (IntLit 1), Literal (IntLit 2)]) + `shouldBe` "[1, 2]" + + it "cross-language roundtrips" $ + let ast = ListLit [Literal (IntLit 1), Literal (IntLit 2)] + hsText = runPrint haskellExpr ast + in case runParse purescriptExpr hsText of + Left err -> expectationFailure (show err) + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in runParse haskellExpr psText `shouldBe` Right ast + + describe "List patterns" $ do + it "parses []" $ + runParse haskellPat "[]" `shouldBe` Right (ListPat []) + + it "parses [x]" $ + runParse haskellPat "[x]" `shouldBe` Right (ListPat [VarPat (Name "x")]) + + it "parses [x, y, z]" $ + runParse haskellPat "[x, y, z]" `shouldBe` + Right (ListPat [VarPat (Name "x"), VarPat (Name "y"), VarPat (Name "z")]) + + it "list in case" $ + runParse haskellExpr "case xs of { [] -> 0; [x] -> x }" `shouldBe` + Right (Case (Var (Name "xs")) + [ CaseAlt (ListPat []) [] (Literal (IntLit 0)) + , CaseAlt (ListPat [VarPat (Name "x")]) [] (Var (Name "x")) + ]) + + it "list in lambda" $ + runParse haskellExpr "\\[x] -> x" `shouldBe` + Right (Lam [ListPat [VarPat (Name "x")]] (Var (Name "x"))) + + it "roundtrips [] pattern in Haskell" $ + roundtrip haskellPat (ListPat []) `shouldBe` Right (ListPat []) + + it "roundtrips [x, y] pattern in Haskell" $ + let ast = ListPat [VarPat (Name "x"), VarPat (Name "y")] + in roundtrip haskellPat ast `shouldBe` Right ast + + it "roundtrips list pattern in PureScript" $ + let ast = ListPat [VarPat (Name "x"), VarPat (Name "y")] + in roundtrip purescriptPat ast `shouldBe` Right ast + + it "cross-language roundtrips" $ + let ast = ListPat [VarPat (Name "x"), VarPat (Name "y")] + hsText = runPrint haskellPat ast + in case runParse purescriptPat hsText of + Left err -> expectationFailure (show err) + Right psPat -> + let psText = runPrint purescriptPat psPat + in runParse haskellPat psText `shouldBe` Right ast + + describe "Cons patterns" $ do + it "parses x : xs" $ + runParse haskellPat "x : xs" `shouldBe` + Right (ConsPat (VarPat (Name "x")) (VarPat (Name "xs"))) + + it "parses x : y : zs (right-associative)" $ + runParse haskellPat "x : y : zs" `shouldBe` + Right (ConsPat (VarPat (Name "x")) (ConsPat (VarPat (Name "y")) (VarPat (Name "zs")))) + + it "parses (Just x) : xs" $ + runParse haskellPat "(Just x) : xs" `shouldBe` + Right (ConsPat (ConPat (Name "Just") [VarPat (Name "x")]) (VarPat (Name "xs"))) + + it "Haskell prints x : xs" $ + runPrint haskellPat (ConsPat (VarPat (Name "x")) (VarPat (Name "xs"))) + `shouldBe` "x : xs" + + it "Haskell prints x : y : zs" $ + runPrint haskellPat (ConsPat (VarPat (Name "x")) (ConsPat (VarPat (Name "y")) (VarPat (Name "zs")))) + `shouldBe` "x : y : zs" + + it "roundtrips x : xs in Haskell" $ + let ast = ConsPat (VarPat (Name "x")) (VarPat (Name "xs")) + in roundtrip haskellPat ast `shouldBe` Right ast + + it "roundtrips x : y : zs in Haskell" $ + let ast = ConsPat (VarPat (Name "x")) (ConsPat (VarPat (Name "y")) (VarPat (Name "zs"))) + in roundtrip haskellPat ast `shouldBe` Right ast + + it "cons in case" $ + runParse haskellExpr "case xs of { x : rest -> x; [] -> 0 }" `shouldBe` + Right (Case (Var (Name "xs")) + [ CaseAlt (ConsPat (VarPat (Name "x")) (VarPat (Name "rest"))) [] (Var (Name "x")) + , CaseAlt (ListPat []) [] (Literal (IntLit 0)) + ]) + + it "roundtrips cons in case" $ + let ast = Case (Var (Name "xs")) + [ CaseAlt (ConsPat (VarPat (Name "x")) (VarPat (Name "rest"))) [] (Var (Name "x")) + , CaseAlt (ListPat []) [] (Literal (IntLit 0)) + ] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "Just x : xs (constructor then cons)" $ + runParse haskellPat "Just x : xs" `shouldBe` + Right (ConsPat (ConPat (Name "Just") [VarPat (Name "x")]) (VarPat (Name "xs"))) + + describe "Operator sections" $ do + it "parses (+ 1)" $ + runParse haskellExpr "(+ 1)" `shouldBe` + Right (RightSection (Name "+") (Literal (IntLit 1))) + + it "parses (1 +)" $ + runParse haskellExpr "(1 +)" `shouldBe` + Right (LeftSection (Literal (IntLit 1)) (Name "+")) + + it "parses (== 0)" $ + runParse haskellExpr "(== 0)" `shouldBe` + Right (RightSection (Name "==") (Literal (IntLit 0))) + + it "parses (<> \"x\")" $ + runParse haskellExpr "(<> \"x\")" `shouldBe` + Right (RightSection (Name "<>") (Literal (StringLit "x"))) + + it "(-x) is NOT a section (still negation)" $ + runParse haskellExpr "(-x)" `shouldBe` + Right (Neg (Var (Name "x"))) + + it "section as argument: map (+ 1) xs" $ + runParse haskellExpr "map (+ 1) xs" `shouldBe` + Right (App (App (Var (Name "map")) (RightSection (Name "+") (Literal (IntLit 1)))) (Var (Name "xs"))) + + it "left section with app: (f x +)" $ + runParse haskellExpr "(f x +)" `shouldBe` + Right (LeftSection (App (Var (Name "f")) (Var (Name "x"))) (Name "+")) + + it "(a + b) is grouped infix, NOT a section" $ + runParse haskellExpr "(a + b)" `shouldBe` + Right (InfixApp (Var (Name "a")) (Name "+") (Var (Name "b"))) + + it "prints (+ 1)" $ + runPrint haskellExpr (RightSection (Name "+") (Literal (IntLit 1))) + `shouldBe` "(+ 1)" + + it "prints (1 +)" $ + runPrint haskellExpr (LeftSection (Literal (IntLit 1)) (Name "+")) + `shouldBe` "(1 +)" + + it "roundtrips (+ 1) in Haskell" $ + let ast = RightSection (Name "+") (Literal (IntLit 1)) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips (1 +) in Haskell" $ + let ast = LeftSection (Literal (IntLit 1)) (Name "+") + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips (+ 1) in PureScript" $ + let ast = RightSection (Name "+") (Literal (IntLit 1)) + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "roundtrips (1 +) in PureScript" $ + let ast = LeftSection (Literal (IntLit 1)) (Name "+") + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "PureScript prints (+ 1) same as Haskell" $ + runPrint purescriptExpr (RightSection (Name "+") (Literal (IntLit 1))) + `shouldBe` "(+ 1)" + + it "PureScript prints (1 +) same as Haskell" $ + runPrint purescriptExpr (LeftSection (Literal (IntLit 1)) (Name "+")) + `shouldBe` "(1 +)" + + it "cross-language roundtrips" $ + let ast = LeftSection (Var (Name "x")) (Name "+") + hsText = runPrint haskellExpr ast + in case runParse purescriptExpr hsText of + Left err -> expectationFailure (show err) + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in runParse haskellExpr psText `shouldBe` Right ast + + describe "As-patterns" $ do + it "parses x@(Just y)" $ + runParse haskellPat "x@(Just y)" `shouldBe` + Right (AsPat (Name "x") (ConPat (Name "Just") [VarPat (Name "y")])) + + it "parses xs@[]" $ + runParse haskellPat "xs@[]" `shouldBe` + Right (AsPat (Name "xs") (ListPat [])) + + it "parses xs@(a : b)" $ + runParse haskellPat "xs@(a : b)" `shouldBe` + Right (AsPat (Name "xs") (ConsPat (VarPat (Name "a")) (VarPat (Name "b")))) + + it "prints AsPat in Haskell" $ + runPrint haskellPat (AsPat (Name "x") (ConPat (Name "Just") [VarPat (Name "y")])) + `shouldBe` "x@(Just y)" + + it "prints AsPat in PureScript" $ + runPrint purescriptPat (AsPat (Name "x") (ConPat (Name "Just") [VarPat (Name "y")])) + `shouldBe` "x@(Just y)" + + it "roundtrips x@(Just y) in Haskell" $ + let ast = AsPat (Name "x") (ConPat (Name "Just") [VarPat (Name "y")]) + in roundtrip haskellPat ast `shouldBe` Right ast + + it "roundtrips xs@[a, b] in Haskell" $ + let ast = AsPat (Name "xs") (ListPat [VarPat (Name "a"), VarPat (Name "b")]) + in roundtrip haskellPat ast `shouldBe` Right ast + + it "roundtrips x@(Just y) in PureScript" $ + let ast = AsPat (Name "x") (ConPat (Name "Just") [VarPat (Name "y")]) + in roundtrip purescriptPat ast `shouldBe` Right ast + + it "cross-language roundtrips" $ + let ast = AsPat (Name "x") (ConPat (Name "Just") [VarPat (Name "y")]) + hsText = runPrint haskellPat ast + in case runParse purescriptPat hsText of + Left err -> expectationFailure (show err) + Right psPat -> + let psText = runPrint purescriptPat psPat + in runParse haskellPat psText `shouldBe` Right ast + + it "in case" $ + runParse haskellExpr "case xs of { ys@(x : _) -> ys; _ -> [] }" `shouldBe` + Right (Case (Var (Name "xs")) + [ CaseAlt (AsPat (Name "ys") (ConsPat (VarPat (Name "x")) WildPat)) [] (Var (Name "ys")) + , CaseAlt WildPat [] (ListLit []) + ]) + + it "in lambda" $ + runParse haskellExpr "\\xs@(x : _) -> x" `shouldBe` + Right (Lam [AsPat (Name "xs") (ConsPat (VarPat (Name "x")) WildPat)] (Var (Name "x"))) + + describe "Negated literal patterns" $ do + it "parses -1" $ + runParse haskellPat "-1" `shouldBe` Right (NegLitPat (IntLit 1)) + + it "parses -3.14" $ + runParse haskellPat "-3.14" `shouldBe` Right (NegLitPat (FloatLit 3.14)) + + it "prints NegLitPat" $ + runPrint haskellPat (NegLitPat (IntLit 1)) `shouldBe` "-1" + + it "prints NegLitPat in PureScript" $ + runPrint purescriptPat (NegLitPat (FloatLit 3.14)) `shouldBe` "-3.14" + + it "prints NegLitPat in constructor (gets parens)" $ + runPrint haskellPat (ConPat (Name "Just") [NegLitPat (IntLit 1)]) + `shouldBe` "Just (-1)" + + it "roundtrips Just (-1) in Haskell" $ + let ast = ConPat (Name "Just") [NegLitPat (IntLit 1)] + in roundtrip haskellPat ast `shouldBe` Right ast + + it "roundtrips -1 in Haskell" $ + roundtrip haskellPat (NegLitPat (IntLit 1)) `shouldBe` Right (NegLitPat (IntLit 1)) + + it "roundtrips -3.14 in Haskell" $ + roundtrip haskellPat (NegLitPat (FloatLit 3.14)) `shouldBe` Right (NegLitPat (FloatLit 3.14)) + + it "roundtrips -1 in PureScript" $ + roundtrip purescriptPat (NegLitPat (IntLit 1)) `shouldBe` Right (NegLitPat (IntLit 1)) + + it "cross-language roundtrips" $ + let ast = NegLitPat (IntLit 42) + hsText = runPrint haskellPat ast + in case runParse purescriptPat hsText of + Left err -> expectationFailure (show err) + Right psPat -> + let psText = runPrint purescriptPat psPat + in runParse haskellPat psText `shouldBe` Right ast + + it "in case" $ + runParse haskellExpr "case x of { -1 -> True; _ -> False }" `shouldBe` + Right (Case (Var (Name "x")) + [ CaseAlt (NegLitPat (IntLit 1)) [] (Con (Name "True")) + , CaseAlt WildPat [] (Con (Name "False")) + ]) + + it "parenthesized (-1) as pattern" $ + runParse haskellPat "(-1)" `shouldBe` Right (NegLitPat (IntLit 1)) + + describe "Where clauses" $ do + it "parses x + 1 where { x = 42 }" $ + runParse haskellExpr "x + 1 where { x = 42 }" `shouldBe` + Right (Where + (InfixApp (Var (Name "x")) (Name "+") (Literal (IntLit 1))) + [Binding (VarPat (Name "x")) (Literal (IntLit 42))]) + + it "parses y where { y = f x; x = 3 }" $ + runParse haskellExpr "y where { y = f x; x = 3 }" `shouldBe` + Right (Where + (Var (Name "y")) + [ Binding (VarPat (Name "y")) (App (Var (Name "f")) (Var (Name "x"))) + , Binding (VarPat (Name "x")) (Literal (IntLit 3)) + ]) + + it "prints Where" $ + runPrint haskellExpr (Where + (InfixApp (Var (Name "x")) (Name "+") (Literal (IntLit 1))) + [Binding (VarPat (Name "x")) (Literal (IntLit 42))]) + `shouldBe` "x + 1 where { x = 42 }" + + it "roundtrips x + 1 where { x = 42 } in Haskell" $ + let ast = Where + (InfixApp (Var (Name "x")) (Name "+") (Literal (IntLit 1))) + [Binding (VarPat (Name "x")) (Literal (IntLit 42))] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips in PureScript" $ + let ast = Where + (InfixApp (Var (Name "x")) (Name "+") (Literal (IntLit 1))) + [Binding (VarPat (Name "x")) (Literal (IntLit 42))] + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "cross-language roundtrips" $ + let ast = Where (Var (Name "y")) [Binding (VarPat (Name "y")) (Literal (IntLit 1))] + hsText = runPrint haskellExpr ast + in case runParse purescriptExpr hsText of + Left err -> expectationFailure (show err) + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in runParse haskellExpr psText `shouldBe` Right ast + + it "where in lambda body" $ + runParse haskellExpr "\\x -> y where { y = x + 1 }" `shouldBe` + Right (Lam [VarPat (Name "x")] + (Where (Var (Name "y")) + [Binding (VarPat (Name "y")) (InfixApp (Var (Name "x")) (Name "+") (Literal (IntLit 1)))])) + + it "where in case alt body" $ + runParse haskellExpr "case n of { 0 -> 1; _ -> n * f n where { f = fac } }" `shouldBe` + Right (Case (Var (Name "n")) + [ CaseAlt (LitPat (IntLit 0)) [] (Literal (IntLit 1)) + , CaseAlt WildPat [] + (Where (InfixApp (Var (Name "n")) (Name "*") (App (Var (Name "f")) (Var (Name "n")))) + [Binding (VarPat (Name "f")) (Var (Name "fac"))]) + ]) + + it "nested where" $ + runParse haskellExpr "x where { x = y where { y = 1 } }" `shouldBe` + Right (Where (Var (Name "x")) + [Binding (VarPat (Name "x")) + (Where (Var (Name "y")) + [Binding (VarPat (Name "y")) (Literal (IntLit 1))])]) + + it "where as function argument needs parens" $ + let ast = App (Var (Name "f")) (Where (Var (Name "x")) [Binding (VarPat (Name "x")) (Literal (IntLit 1))]) + in do + runPrint haskellExpr ast `shouldBe` "f (x where { x = 1 })" + roundtrip haskellExpr ast `shouldBe` Right ast + + it "where with multiple bindings" $ + let ast = Where + (InfixApp (Var (Name "x")) (Name "+") (Var (Name "y"))) + [ Binding (VarPat (Name "x")) (Literal (IntLit 1)) + , Binding (VarPat (Name "y")) (Literal (IntLit 2)) + ] + in roundtrip haskellExpr ast `shouldBe` Right ast + + describe "Type annotations" $ do + it "parses x :: Int" $ + runParse haskellExpr "x :: Int" `shouldBe` + Right (Ann (Var (Name "x")) (TyCon (Name "Int"))) + + it "parses f x :: Maybe Int" $ + runParse haskellExpr "f x :: Maybe Int" `shouldBe` + Right (Ann (App (Var (Name "f")) (Var (Name "x"))) (TyApp (TyCon (Name "Maybe")) (TyCon (Name "Int")))) + + it "parses x :: a -> b" $ + runParse haskellExpr "x :: a -> b" `shouldBe` + Right (Ann (Var (Name "x")) (TyFun (TyVar (Name "a")) (TyVar (Name "b")))) + + it "prints Ann" $ + runPrint haskellExpr (Ann (Var (Name "x")) (TyCon (Name "Int"))) + `shouldBe` "x :: Int" + + it "prints Ann as function argument (gets parens)" $ + let ast = App (Var (Name "f")) (Ann (Var (Name "x")) (TyCon (Name "Int"))) + in runPrint haskellExpr ast `shouldBe` "f (x :: Int)" + + it "roundtrips x :: Int in Haskell" $ + let ast = Ann (Var (Name "x")) (TyCon (Name "Int")) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips (x + y) :: Int in Haskell" $ + let ast = Ann (InfixApp (Var (Name "x")) (Name "+") (Var (Name "y"))) (TyCon (Name "Int")) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips x :: Int in PureScript" $ + let ast = Ann (Var (Name "x")) (TyCon (Name "Int")) + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "cross-language roundtrips" $ + let ast = Ann (Var (Name "x")) (TyCon (Name "Int")) + hsText = runPrint haskellExpr ast + in case runParse purescriptExpr hsText of + Left err -> expectationFailure (show err) + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in runParse haskellExpr psText `shouldBe` Right ast + + it "in lambda body: \\x -> x :: Int" $ + runParse haskellExpr "\\x -> x :: Int" `shouldBe` + Right (Lam [VarPat (Name "x")] (Ann (Var (Name "x")) (TyCon (Name "Int")))) + + it "nested: (x :: Int) :: Int" $ + runParse haskellExpr "(x :: Int) :: Int" `shouldBe` + Right (Ann (Ann (Var (Name "x")) (TyCon (Name "Int"))) (TyCon (Name "Int"))) + + it "type with function arrow: f :: Int -> Bool" $ + let ast = Ann (Var (Name "f")) (TyFun (TyCon (Name "Int")) (TyCon (Name "Bool"))) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "type application: x :: Maybe Int" $ + let ast = Ann (Var (Name "x")) (TyApp (TyCon (Name "Maybe")) (TyCon (Name "Int"))) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "parenthesized type: f :: (a -> b) -> c" $ + let ast = Ann (Var (Name "f")) (TyFun (TyFun (TyVar (Name "a")) (TyVar (Name "b"))) (TyVar (Name "c"))) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "in case scrutinee: case (x :: Int) of { ... }" $ + runParse haskellExpr "case (x :: Int) of { _ -> y }" `shouldBe` + Right (Case (Ann (Var (Name "x")) (TyCon (Name "Int"))) + [CaseAlt WildPat [] (Var (Name "y"))]) + + it "annotation then where: x :: Int where { y = 1 }" $ + runParse haskellExpr "x :: Int where { y = 1 }" `shouldBe` + Right (Where (Ann (Var (Name "x")) (TyCon (Name "Int"))) + [Binding (VarPat (Name "y")) (Literal (IntLit 1))]) + + it ":: is not an operator" $ + runParse haskellExpr "x :: Int" `shouldBe` + Right (Ann (Var (Name "x")) (TyCon (Name "Int"))) + + describe "Record updates" $ do + it "parses rec { x = 1 }" $ + runParse haskellExpr "rec { x = 1 }" `shouldBe` + Right (RecordUpdate (Var (Name "rec")) [(Name "x", Literal (IntLit 1))]) + + it "parses rec { x = 1, y = 2 }" $ + runParse haskellExpr "rec { x = 1, y = 2 }" `shouldBe` + Right (RecordUpdate (Var (Name "rec")) + [ (Name "x", Literal (IntLit 1)) + , (Name "y", Literal (IntLit 2)) + ]) + + it "prints RecordUpdate" $ + runPrint haskellExpr (RecordUpdate (Var (Name "rec")) [(Name "x", Literal (IntLit 1))]) + `shouldBe` "rec { x = 1 }" + + it "roundtrips rec { x = 1 } in Haskell" $ + let ast = RecordUpdate (Var (Name "rec")) [(Name "x", Literal (IntLit 1))] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips rec { x = 1, y = 2 } in Haskell" $ + let ast = RecordUpdate (Var (Name "rec")) + [ (Name "x", Literal (IntLit 1)) + , (Name "y", Literal (IntLit 2)) + ] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips rec { x = 1 } in PureScript" $ + let ast = RecordUpdate (Var (Name "rec")) [(Name "x", Literal (IntLit 1))] + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "cross-language roundtrips" $ + let ast = RecordUpdate (Var (Name "rec")) [(Name "x", Literal (IntLit 1))] + hsText = runPrint haskellExpr ast + in case runParse purescriptExpr hsText of + Left err -> expectationFailure (show err) + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in runParse haskellExpr psText `shouldBe` Right ast + + it "as function argument: f rec { x = 1 } parses as f (RecordUpdate rec ...)" $ + runParse haskellExpr "f rec { x = 1 }" `shouldBe` + Right (App (Var (Name "f")) (RecordUpdate (Var (Name "rec")) [(Name "x", Literal (IntLit 1))])) + + it "with parenthesized base: (f x) { y = 1 }" $ + let ast = RecordUpdate (App (Var (Name "f")) (Var (Name "x"))) [(Name "y", Literal (IntLit 1))] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "complex field values: rec { x = a + b }" $ + let ast = RecordUpdate (Var (Name "rec")) + [(Name "x", InfixApp (Var (Name "a")) (Name "+") (Var (Name "b")))] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "nested: rec { x = inner { y = 1 } }" $ + let ast = RecordUpdate (Var (Name "rec")) + [(Name "x", RecordUpdate (Var (Name "inner")) [(Name "y", Literal (IntLit 1))])] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "in infix: rec { x = 1 } + y" $ + runParse haskellExpr "rec { x = 1 } + y" `shouldBe` + Right (InfixApp + (RecordUpdate (Var (Name "rec")) [(Name "x", Literal (IntLit 1))]) + (Name "+") + (Var (Name "y"))) + + it "chained record updates: rec { x = 1 } { y = 2 }" $ + let ast = RecordUpdate (RecordUpdate (Var (Name "rec")) [(Name "x", Literal (IntLit 1))]) + [(Name "y", Literal (IntLit 2))] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "in case scrutinee: case rec { x = 1 } of { ... }" $ + runParse haskellExpr "case rec { x = 1 } of { _ -> y }" `shouldBe` + Right (Case (RecordUpdate (Var (Name "rec")) [(Name "x", Literal (IntLit 1))]) + [CaseAlt WildPat [] (Var (Name "y"))]) + + describe "Qualified names" $ do + -- Parse tests + it "parses Data.Map.lookup as QVar" $ + runParse haskellExpr "Data.Map.lookup" `shouldBe` + Right (QVar [Name "Data", Name "Map"] (Name "lookup")) + + it "parses Data.Map.Map as QCon" $ + runParse haskellExpr "Data.Map.Map" `shouldBe` + Right (QCon [Name "Data", Name "Map"] (Name "Map")) + + it "parses Foo.bar as QVar" $ + runParse haskellExpr "Foo.bar" `shouldBe` + Right (QVar [Name "Foo"] (Name "bar")) + + it "parses Foo.Bar as QCon" $ + runParse haskellExpr "Foo.Bar" `shouldBe` + Right (QCon [Name "Foo"] (Name "Bar")) + + it "parses Foo as Con (unchanged)" $ + runParse haskellExpr "Foo" `shouldBe` + Right (Con (Name "Foo")) + + -- Print tests + it "prints QVar" $ + runPrint haskellExpr (QVar [Name "Data", Name "Map"] (Name "lookup")) + `shouldBe` "Data.Map.lookup" + + it "prints QCon" $ + runPrint haskellExpr (QCon [Name "Data", Name "Map"] (Name "Map")) + `shouldBe` "Data.Map.Map" + + -- Roundtrip tests + it "QVar roundtrips in Haskell" $ + let ast = QVar [Name "Data", Name "Map"] (Name "lookup") + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "QCon roundtrips in Haskell" $ + let ast = QCon [Name "Data", Name "Map"] (Name "Map") + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "QVar roundtrips in PureScript" $ + let ast = QVar [Name "Data", Name "Map"] (Name "lookup") + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "QCon roundtrips in PureScript" $ + let ast = QCon [Name "Data", Name "Map"] (Name "Map") + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "cross-language roundtrips" $ + let ast = QVar [Name "Data", Name "Map"] (Name "lookup") + hsText = runPrint haskellExpr ast + in case runParse purescriptExpr hsText of + Left err -> expectationFailure (show err) + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in runParse haskellExpr psText `shouldBe` Right ast + + -- Context tests + it "Data.Map.lookup x parses as App (QVar ...) (Var x)" $ + runParse haskellExpr "Data.Map.lookup x" `shouldBe` + Right (App (QVar [Name "Data", Name "Map"] (Name "lookup")) (Var (Name "x"))) + + it "x :: Data.Map.Map Int String parses with TyQCon" $ + runParse haskellExpr "x :: Data.Map.Map Int String" `shouldBe` + Right (Ann (Var (Name "x")) + (TyApp (TyApp (TyQCon [Name "Data", Name "Map"] (Name "Map")) (TyCon (Name "Int"))) (TyCon (Name "String")))) + + it "Foo.bar.baz in PS parses as RecordAccess (QVar ...) baz" $ + runParse purescriptExpr "Foo.bar.baz" `shouldBe` + Right (RecordAccess (QVar [Name "Foo"] (Name "bar")) (Name "baz")) + + it "rec.field in PS still parses as RecordAccess (Var rec) field" $ + runParse purescriptExpr "rec.field" `shouldBe` + Right (RecordAccess (Var (Name "rec")) (Name "field")) + + -- Edge cases + it "Foo . bar (spaces) is NOT qualified — it's infix . operator" $ + runParse haskellExpr "Foo . bar" `shouldBe` + Right (InfixApp (Con (Name "Foo")) (Name ".") (Var (Name "bar"))) + + it "qualified in record update: Foo.Bar { x = 1 }" $ + runParse haskellExpr "Foo.Bar { x = 1 }" `shouldBe` + Right (RecordUpdate (QCon [Name "Foo"] (Name "Bar")) [(Name "x", Literal (IntLit 1))]) + + describe "Record patterns" $ do + it "parses Foo { bar = x }" $ + runParse haskellPat "Foo { bar = x }" `shouldBe` + Right (RecordPat (Name "Foo") [(Name "bar", VarPat (Name "x"))]) + + it "parses Foo { bar: x } (colon separator)" $ + runParse haskellPat "Foo { bar: x }" `shouldBe` + Right (RecordPat (Name "Foo") [(Name "bar", VarPat (Name "x"))]) + + it "parses MkFoo { bar: 1 } as RecordUpdate (colon in expression)" $ + runParse haskellExpr "MkFoo { bar: 1 }" `shouldBe` + Right (RecordUpdate (Con (Name "MkFoo")) [(Name "bar", Literal (IntLit 1))]) + + it "multi-field record pattern roundtrips in Haskell" $ + let ast = RecordPat (Name "Foo") [(Name "bar", VarPat (Name "x")), (Name "baz", VarPat (Name "y"))] + in roundtrip haskellPat ast `shouldBe` Right ast + + it "record pattern inside parenthesized context" $ + runParse haskellPat "(Foo { bar = x })" `shouldBe` + Right (RecordPat (Name "Foo") [(Name "bar", VarPat (Name "x"))]) + + it "record construction roundtrips in Haskell" $ + let ast = RecordUpdate (Con (Name "MkFoo")) [(Name "bar", Literal (IntLit 1))] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "record construction roundtrips in PureScript" $ + let ast = RecordUpdate (Con (Name "MkFoo")) [(Name "bar", Literal (IntLit 1))] + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "cross-language roundtrip for record construction" $ + let ast = RecordUpdate (Con (Name "MkFoo")) [(Name "bar", Literal (IntLit 1))] + hsText = runPrint haskellExpr ast + in case runParse purescriptExpr hsText of + Left err -> expectationFailure (show err) + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in runParse haskellExpr psText `shouldBe` Right ast + + it "cross-language roundtrip for record pattern" $ + let ast = RecordPat (Name "Foo") [(Name "bar", VarPat (Name "x"))] + hsText = runPrint haskellPat ast + in case runParse purescriptPat hsText of + Left err -> expectationFailure (show err) + Right psPat -> + let psText = runPrint purescriptPat psPat + in runParse haskellPat psText `shouldBe` Right ast + + it "RecordPat in case alt" $ + runParse haskellExpr "case x of { Foo { bar = y } -> y }" `shouldBe` + Right (Case (Var (Name "x")) + [CaseAlt (RecordPat (Name "Foo") [(Name "bar", VarPat (Name "y"))]) [] (Var (Name "y"))]) + + it "QCon-based record construction roundtrips" $ + let ast = RecordUpdate (QCon [Name "Data", Name "Foo"] (Name "MkBar")) [(Name "x", Literal (IntLit 1))] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "qualified type roundtrips: TyQCon" $ + let ast = Ann (Var (Name "x")) (TyQCon [Name "Data", Name "Map"] (Name "Map")) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "QCon cross-language roundtrips" $ + let ast = QCon [Name "Data", Name "Map"] (Name "Map") + hsText = runPrint haskellExpr ast + in case runParse purescriptExpr hsText of + Left err -> expectationFailure (show err) + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in runParse haskellExpr psText `shouldBe` Right ast + + it "reserved word after dot is NOT qualified: Foo.case" $ + -- Foo.case should parse as Con "Foo", then fail or parse "case" as keyword + -- It should NOT parse as QVar ["Foo"] "case" + case runParse haskellExpr "Foo.case" of + Right (QVar _ _) -> expectationFailure "should not parse as QVar" + _ -> pure () + + it "qualified in application context: Data.Map.insert k v" $ + runParse haskellExpr "Data.Map.insert k v" `shouldBe` + Right (App (App (QVar [Name "Data", Name "Map"] (Name "insert")) (Var (Name "k"))) (Var (Name "v"))) + + it "multiple qualified names in expression" $ + runParse haskellExpr "Data.Map.insert k v Data.Map.empty" `shouldBe` + Right (App (App (App (QVar [Name "Data", Name "Map"] (Name "insert")) (Var (Name "k"))) (Var (Name "v"))) + (QVar [Name "Data", Name "Map"] (Name "empty"))) + + describe "Backtick operators" $ do + it "parses x `div` y" $ + runParse haskellExpr "x `div` y" `shouldBe` + Right (InfixApp (Var (Name "x")) (Name "div") (Var (Name "y"))) + + it "parses a `mod` b `div` c (left-associative)" $ + runParse haskellExpr "a `mod` b `div` c" `shouldBe` + Right (InfixApp + (InfixApp (Var (Name "a")) (Name "mod") (Var (Name "b"))) + (Name "div") + (Var (Name "c"))) + + it "parses (`div` 2) as RightSection" $ + runParse haskellExpr "(`div` 2)" `shouldBe` + Right (RightSection (Name "div") (Literal (IntLit 2))) + + it "parses (10 `div`) as LeftSection" $ + runParse haskellExpr "(10 `div`)" `shouldBe` + Right (LeftSection (Literal (IntLit 10)) (Name "div")) + + it "prints InfixApp with alphanumeric op using backticks" $ + runPrint haskellExpr (InfixApp (Var (Name "x")) (Name "div") (Var (Name "y"))) + `shouldBe` "x `div` y" + + it "prints RightSection with backtick" $ + runPrint haskellExpr (RightSection (Name "div") (Literal (IntLit 2))) + `shouldBe` "(`div` 2)" + + it "prints LeftSection with backtick" $ + runPrint haskellExpr (LeftSection (Literal (IntLit 10)) (Name "div")) + `shouldBe` "(10 `div`)" + + it "roundtrips x `div` y in Haskell" $ + let ast = InfixApp (Var (Name "x")) (Name "div") (Var (Name "y")) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips x `div` y in PureScript" $ + let ast = InfixApp (Var (Name "x")) (Name "div") (Var (Name "y")) + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "roundtrips (`div` 2) in Haskell" $ + let ast = RightSection (Name "div") (Literal (IntLit 2)) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips (10 `div`) in Haskell" $ + let ast = LeftSection (Literal (IntLit 10)) (Name "div") + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "cross-language roundtrip" $ + let ast = InfixApp (Var (Name "x")) (Name "div") (Var (Name "y")) + hsText = runPrint haskellExpr ast + in case runParse purescriptExpr hsText of + Left err -> expectationFailure (show err) + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in runParse haskellExpr psText `shouldBe` Right ast + + it "symbolic operators still work (regression)" $ + let ast = InfixApp (Var (Name "x")) (Name "+") (Var (Name "y")) + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "backtick in application context: map (`div` 2) xs" $ + runParse haskellExpr "map (`div` 2) xs" `shouldBe` + Right (App (App (Var (Name "map")) (RightSection (Name "div") (Literal (IntLit 2)))) (Var (Name "xs"))) + + it "backtick with function args: f x `div` g y" $ + runParse haskellExpr "f x `div` g y" `shouldBe` + Right (InfixApp + (App (Var (Name "f")) (Var (Name "x"))) + (Name "div") + (App (Var (Name "g")) (Var (Name "y")))) + + describe "Function-style bindings" $ do + it "parses f x = x + 1 in where" $ + runParse haskellExpr "y where { f x = x + 1 }" `shouldBe` + Right (Where (Var (Name "y")) + [Binding (VarPat (Name "f")) (Lam [VarPat (Name "x")] + (InfixApp (Var (Name "x")) (Name "+") (Literal (IntLit 1))))]) + + it "parses f x y = x + y in let" $ + runParse haskellExpr "let { f x y = x + y } in f 1 2" `shouldBe` + Right (Let + [Binding (VarPat (Name "f")) (Lam [VarPat (Name "x"), VarPat (Name "y")] + (InfixApp (Var (Name "x")) (Name "+") (Var (Name "y"))))] + (App (App (Var (Name "f")) (Literal (IntLit 1))) (Literal (IntLit 2)))) + + it "simple binding still works" $ + runParse haskellExpr "let { x = 1 } in x" `shouldBe` + Right (Let [Binding (VarPat (Name "x")) (Literal (IntLit 1))] (Var (Name "x"))) + + it "constructor binding still works" $ + runParse haskellExpr "let { Just x = y } in x" `shouldBe` + Right (Let [Binding (ConPat (Name "Just") [VarPat (Name "x")]) (Var (Name "y"))] (Var (Name "x"))) + + it "wildcard binding still works" $ + runParse haskellExpr "let { _ = x } in y" `shouldBe` + Right (Let [Binding WildPat (Var (Name "x"))] (Var (Name "y"))) + + it "prints function binding" $ + runPrint haskellExpr (Where (Var (Name "y")) + [Binding (VarPat (Name "f")) (Lam [VarPat (Name "x")] + (InfixApp (Var (Name "x")) (Name "+") (Literal (IntLit 1))))]) + `shouldBe` "y where { f x = x + 1 }" + + it "prints multi-arg function binding" $ + runPrint haskellExpr (Let + [Binding (VarPat (Name "f")) (Lam [VarPat (Name "x"), VarPat (Name "y")] + (InfixApp (Var (Name "x")) (Name "+") (Var (Name "y"))))] + (Var (Name "r"))) + `shouldBe` "let { f x y = x + y } in r" + + it "prints simple binding unchanged" $ + runPrint haskellExpr (Let [Binding (VarPat (Name "x")) (Literal (IntLit 1))] (Var (Name "x"))) + `shouldBe` "let { x = 1 } in x" + + it "roundtrips function binding in Haskell" $ + let ast = Where (Var (Name "y")) + [Binding (VarPat (Name "f")) (Lam [VarPat (Name "x")] + (InfixApp (Var (Name "x")) (Name "+") (Literal (IntLit 1))))] + in roundtrip haskellExpr ast `shouldBe` Right ast + + it "roundtrips function binding in PureScript" $ + let ast = Where (Var (Name "y")) + [Binding (VarPat (Name "f")) (Lam [VarPat (Name "x")] + (InfixApp (Var (Name "x")) (Name "+") (Literal (IntLit 1))))] + in roundtrip purescriptExpr ast `shouldBe` Right ast + + it "cross-language roundtrip" $ + let ast = Let + [Binding (VarPat (Name "f")) (Lam [VarPat (Name "x")] (Var (Name "x")))] + (App (Var (Name "f")) (Literal (IntLit 1))) + hsText = runPrint haskellExpr ast + in case runParse purescriptExpr hsText of + Left err -> expectationFailure (show err) + Right psExpr -> + let psText = runPrint purescriptExpr psExpr + in runParse haskellExpr psText `shouldBe` Right ast + + it "function binding in do-let" $ + runParse haskellExpr "do { let { f x = x + 1 }; f 2 }" `shouldBe` + Right (Do + [ StmtLet [Binding (VarPat (Name "f")) (Lam [VarPat (Name "x")] + (InfixApp (Var (Name "x")) (Name "+") (Literal (IntLit 1))))] + , StmtExpr (App (Var (Name "f")) (Literal (IntLit 2))) + ]) + + it "function binding with constructor pattern arg" $ + runParse haskellExpr "let { f (Just x) = x } in f" `shouldBe` + Right (Let + [Binding (VarPat (Name "f")) (Lam [ConPat (Name "Just") [VarPat (Name "x")]] (Var (Name "x")))] + (Var (Name "f"))) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}