purekell (empty) → 0.1.0.0

raw patch · 18 files changed

+3632/−0 lines, 18 filesdep +QuickCheckdep +basedep +hspec

Dependencies added: QuickCheck, base, hspec, megaparsec, purekell, text

Files

• CHANGELOG.md +21/−0
• LICENSE +190/−0
• README.md +59/−0
• purekell.cabal +113/−0
• src/Purekell.hs +66/−0
• src/Purekell/AST.hs +124/−0
• src/Purekell/Codec.hs +42/−0
• src/Purekell/Haskell.hs +43/−0
• src/Purekell/Instance.hs +86/−0
• src/Purekell/Parser.hs +386/−0
• src/Purekell/Printer.hs +322/−0
• src/Purekell/PureScript.hs +54/−0
• test/Purekell/ASTSpec.hs +67/−0
• test/Purekell/Arbitrary.hs +391/−0
• test/Purekell/DivergentSpec.hs +342/−0
• test/Purekell/InstanceSpec.hs +270/−0
• test/Purekell/RoundtripSpec.hs +1055/−0
• test/Spec.hs +1/−0

@@ -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)

@@ -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.

@@ -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.

@@ -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,

@@ -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)

@@ -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)

@@ -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

@@ -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 }

@@ -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

@@ -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

@@ -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

@@ -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 }

@@ -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

@@ -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]

@@ -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")])

@@ -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

@@ -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")))

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}