egison 4.2.1 → 5.0.0

raw patch · 189 files changed

+17100/−3956 lines, 189 filesdep ~basedep ~directorydep ~filepathPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, directory, filepath, hashable, megaparsec, mtl, parsec, parser-combinators, prettyprinter, process, random, regex-tdfa

API changes (from Hackage documentation)

Files

• Changelog.md +20/−3
• README.md +107/−61
• benchmark/Benchmark.hs +1/−1
• benchmark/collection-bench-snoc.egi +0/−11
• benchmark/collection-bench-star-colon.egi +11/−0
• egison.cabal +54/−52
• elisp/egison-mode.el +0/−178
• emacs/egison-mode.el +405/−0
• hs-src/Interpreter/egison.hs +132/−42
• hs-src/Language/Egison.hs +26/−25
• hs-src/Language/Egison/AST.hs +239/−25
• hs-src/Language/Egison/CmdOptions.hs +39/−7
• hs-src/Language/Egison/Completion.hs +3/−4
• hs-src/Language/Egison/Core.hs +421/−56
• hs-src/Language/Egison/Data.hs +246/−24
• hs-src/Language/Egison/Data.hs-boot +5/−0
• hs-src/Language/Egison/Data/Utils.hs +31/−2
• hs-src/Language/Egison/Desugar.hs +277/−48
• hs-src/Language/Egison/EnvBuilder.hs +408/−0
• hs-src/Language/Egison/Eval.hs +528/−42
• hs-src/Language/Egison/EvalState.hs +136/−4
• hs-src/Language/Egison/IExpr.hs +358/−6
• hs-src/Language/Egison/Math.hs +1/−0
• hs-src/Language/Egison/Math/Expr.hs +97/−19
• hs-src/Language/Egison/Math/Rewrite.hs +97/−42
• hs-src/Language/Egison/Parser.hs +49/−45
• hs-src/Language/Egison/Parser/NonS.hs +740/−50
• hs-src/Language/Egison/Parser/SExpr.hs +0/−884
• hs-src/Language/Egison/Pretty.hs +644/−21
• hs-src/Language/Egison/PrettyMath/AST.hs +18/−5
• hs-src/Language/Egison/Primitives.hs +84/−1
• hs-src/Language/Egison/Primitives/Arith.hs +49/−36
• hs-src/Language/Egison/Primitives/Types.hs +8/−48
• hs-src/Language/Egison/Primitives/Utils.hs +7/−0
• hs-src/Language/Egison/Tensor.hs +47/−15
• hs-src/Language/Egison/Type.hs +60/−0
• hs-src/Language/Egison/Type/Check.hs +233/−0
• hs-src/Language/Egison/Type/Env.hs +283/−0
• hs-src/Language/Egison/Type/Error.hs +243/−0
• hs-src/Language/Egison/Type/Index.hs +82/−0
• hs-src/Language/Egison/Type/Infer.hs +3337/−0
• hs-src/Language/Egison/Type/Instance.hs +28/−0
• hs-src/Language/Egison/Type/Pretty.hs +157/−0
• hs-src/Language/Egison/Type/Subst.hs +103/−0
• hs-src/Language/Egison/Type/Tensor.hs +32/−0
• hs-src/Language/Egison/Type/TensorMapInsertion.hs +691/−0
• hs-src/Language/Egison/Type/TypeClassExpand.hs +1375/−0
• hs-src/Language/Egison/Type/TypedDesugar.hs +190/−0
• hs-src/Language/Egison/Type/Types.hs +285/−0
• hs-src/Language/Egison/Type/Unify.hs +538/−0
• hs-src/Language/Egison/VarEntry.hs +22/−0
• hs-src/Tool/translator.hs +0/−223
• lib/core/assoc.egi +21/−25
• lib/core/base.egi +75/−27
• lib/core/collection.egi +194/−155
• lib/core/deprecated.egi +100/−0
• lib/core/io.egi +12/−12
• lib/core/maybe.egi +10/−2
• lib/core/number.egi +44/−84
• lib/core/order.egi +69/−64
• lib/core/random.egi +16/−16
• lib/core/shell.egi +0/−49
• lib/core/sort.egi +0/−45
• lib/core/string.egi +66/−41
• lib/math/algebra/equations.egi +18/−18
• lib/math/algebra/group.egi +30/−0
• lib/math/algebra/inverse.egi +1/−1
• lib/math/algebra/matrix.egi +51/−151
• lib/math/algebra/root.egi +39/−37
• lib/math/algebra/tensor.egi +8/−6
• lib/math/algebra/vector.egi +13/−6
• lib/math/analysis/derivative.egi +44/−33
• lib/math/analysis/integral.egi +5/−5
• lib/math/common/arithmetic.egi +30/−55
• lib/math/common/constants.egi +1/−1
• lib/math/common/functions.egi +60/−76
• lib/math/expression.egi +266/−158
• lib/math/geometry/3d-euclidean-space.egi +2/−2
• lib/math/geometry/4d-euclidean-space.egi +2/−2
• lib/math/geometry/differential-form.egi +18/−13
• lib/math/geometry/minkowski-space.egi +2/−2
• lib/math/no-normalize.egi +1/−1
• lib/math/normalize.egi +29/−13
• sample/bellman-ford.egi +13/−10
• sample/binary-counter.egi +11/−0
• sample/bipartite-graph.egi +58/−0
• sample/chopsticks.egi +19/−12
• sample/chopsticks2.egi +19/−14
• sample/chopsticks3.egi +0/−23
• sample/database/edge-sqlite.egi +73/−0
• sample/database/simple-sqlite.egi +7/−0
• sample/demo1-ja.egi +4/−3
• sample/demo1.egi +4/−3
• sample/efficient-backtracking.egi +15/−0
• sample/five-color.egi +40/−0
• sample/generalized-sequential-pattern-mining.egi +24/−26
• sample/graph.egi +32/−25
• sample/io/args.egi +17/−0
• sample/io/cat.egi +8/−0
• sample/io/cut.egi +16/−0
• sample/io/hello.egi +5/−0
• sample/io/print-primes.egi +5/−0
• sample/ioRef.egi +2/−2
• sample/mahjong.egi +35/−14
• sample/math/algebra/cubic-equation.egi +33/−0
• sample/math/algebra/quadratic-equation.egi +34/−0
• sample/math/algebra/quartic-equation.egi +43/−0
• sample/math/analysis/eulers-formula.egi +19/−0
• sample/math/analysis/leibniz-formula.egi +55/−0
• sample/math/analysis/vector-analysis.egi +110/−0
• sample/math/geometry/chern-form-of-CP1.egi +29/−11
• sample/math/geometry/chern-form-of-CP2.egi +20/−17
• sample/math/geometry/curvature-form.egi +11/−14
• sample/math/geometry/euler-form-of-S2.egi +53/−1
• sample/math/geometry/euler-form-of-T2.egi +50/−1
• sample/math/geometry/exterior-derivative.egi +13/−7
• sample/math/geometry/hodge-E3.egi +9/−7
• sample/math/geometry/hodge-Minkowski.egi +17/−16
• sample/math/geometry/hodge-laplacian-polar.egi +13/−15
• sample/math/geometry/hodge-laplacian-spherical.egi +42/−1
• sample/math/geometry/polar-laplacian-2d-2.egi +33/−1
• sample/math/geometry/polar-laplacian-2d-3.egi +35/−1
• sample/math/geometry/polar-laplacian-2d.egi +15/−17
• sample/math/geometry/polar-laplacian-3d-2.egi +35/−1
• sample/math/geometry/polar-laplacian-3d-3.egi +35/−1
• sample/math/geometry/polar-laplacian-3d.egi +15/−27
• sample/math/geometry/riemann-curvature-tensor-of-FLRW-metric.egi +41/−1
• sample/math/geometry/riemann-curvature-tensor-of-S2-no-type-annotations.egi +71/−0
• sample/math/geometry/riemann-curvature-tensor-of-S2.egi +12/−10
• sample/math/geometry/riemann-curvature-tensor-of-S2xS3.egi +63/−1
• sample/math/geometry/riemann-curvature-tensor-of-S3.egi +87/−1
• sample/math/geometry/riemann-curvature-tensor-of-S4.egi +85/−1
• sample/math/geometry/riemann-curvature-tensor-of-S5-non-sym.egi +39/−10
• sample/math/geometry/riemann-curvature-tensor-of-S5.egi +55/−32
• sample/math/geometry/riemann-curvature-tensor-of-S7.egi +78/−1
• sample/math/geometry/riemann-curvature-tensor-of-Schwarzschild-metric.egi +87/−1
• sample/math/geometry/riemann-curvature-tensor-of-T2.egi +10/−8
• sample/math/geometry/surface.egi +40/−30
• sample/math/geometry/thurston-non-sym.egi +4/−2
• sample/math/geometry/thurston.egi +5/−3
• sample/math/geometry/wedge-product.egi +20/−14
• sample/math/geometry/yang-mills-equation-of-U1-gauge-theory.egi +45/−14
• sample/math/number/17th-root-of-unity.egi +15/−15
• sample/math/number/5th-root-of-unity.egi +23/−22
• sample/math/number/7th-root-of-unity.egi +19/−32
• sample/math/number/eisenstein-primes.egi +30/−43
• sample/math/number/euler-totient-function.egi +9/−34
• sample/math/number/gaussian-primes.egi +28/−41
• sample/math/number/tribonacci.egi +29/−19
• sample/mickey.egi +13/−0
• sample/n-queen.egi +44/−0
• sample/n-queens.egi +13/−5
• sample/nishiwaki.egi +24/−0
• sample/one-minute-first.egi +12/−0
• sample/one-minute-second.egi +13/−0
• sample/physics/tension.egi +33/−0
• sample/physics/tension2.egi +23/−0
• sample/physics/tension3.egi +23/−0
• sample/pi.egi +56/−0
• sample/poker-hands-with-joker.egi +22/−6
• sample/poker-hands.egi +19/−4
• sample/prime-millionaire.egi +16/−0
• sample/primes.egi +2/−2
• sample/repl/egison.egi +14/−0
• sample/rosetta/abc_problem.egi +18/−0
• sample/rosetta/consolidate.egi +12/−0
• sample/rosetta/lcs.egi +50/−0
• sample/rosetta/partial.egi +21/−0
• sample/salesman.egi +63/−0
• sample/salesman2.egi +37/−0
• sample/sat/cdcl.egi +64/−29
• sample/sat/dp.egi +5/−5
• sample/tail-recursion.egi +11/−0
• sample/tak.egi +21/−0
• sample/tree.egi +4/−4
• sample/triangle.egi +22/−0
• sample/unify.egi +131/−0
• sample/xml-test.egi +52/−0
• test/CLITest.hs +0/−88
• test/Test.hs +37/−14
• test/fixture/a.egi +0/−1
• test/fixture/b.egi +0/−3
• test/fixture/c.egi +0/−2
• test/lib/core/assoc.egi +8/−7
• test/lib/core/collection.egi +5/−17
• test/lib/core/maybe.egi +6/−6
• test/lib/core/number.egi +5/−36
• test/lib/core/order.egi +6/−22
• test/lib/core/string.egi +0/−20

@@ -1,14 +1,31 @@ # Changelog -## Latest+## 5.0.0 ### New Features+* **Static Type System**: Introduced a static type system for Egison.+  - Type annotations for function parameters and return types: `def f (x: Integer) : Integer := x + 1`+  - Polymorphic type parameters: `def id {a} (x: a) : a := x`+  - Type inference with unification+* **Type Classes**: Added Haskell-style type class system.+  - Type class declarations: `class Eq a where ...`+  - Instance declarations: `instance Eq Integer where ...`+  - Superclass constraints with `extends`: `class Ord a extends Eq a where ...`+  - Type class constraints in function signatures: `def f {Eq a} (x: a) (y: a) : Bool := x == y`+* **Inductive Data Types**: Added support for user-defined algebraic data types.+  - Data type declarations: `inductive Maybe a := | Nothing | Just a`+  - Pattern inductive types: `inductive pattern [a] := | [] | (::) a [a]`+* **Symbol Declarations**: Added `declare symbol` for declaring symbolic variables used in tensor calculations.+  - `declare symbol x, y, z : Integer`+* **Pattern Function Declarations**: Added typed pattern function syntax.+  - `def pattern twin {a} (p1 : a) (p2 : MyList a) : MyList a := ...`+* **New Built-in Types**: `MathExpr`, `IO`, `DiffForm`++### Previous Unreleased Changes * Added binary function notation for arbitrary 2-ary functions. ([#260](https://github.com/egison/egison/pull/260)) ```hs > let mod x y := x % y in 103 `mod` 10 3 ```--### Backward-incompatible Changes * Swapped the notation for `QuoteExpr` and `QuoteSymbolExpr`. ([#262](https://github.com/egison/egison/issues/262)) ```hs > `(a + b) + `(a + b) -- QuoteExpr, which prevents (a + b) from unpacking

@@ -7,6 +7,28 @@  For more information, visit <a target="_blank" href="https://www.egison.org">our website</a>. +## What's New in Egison 5++Egison 5 introduces a static type system based on Hindley-Milner type inference.+The type checker infers types automatically, so **type annotations are completely optional**.+You can add type annotations for documentation and safety, but they are not required.++```hs+-- Type annotations are optional. Both styles work:+def fact n :=+  if n == 0 then 1 else n * fact (n - 1)++def fact (n : Integer) : Integer :=+  if n == 0 then 1 else n * fact (n - 1)+```++In addition, Egison 5 supports:++- **Type classes**: Haskell-style type classes and instances (`class Eq a where ...`, `instance Eq Integer where ...`)+- **Algebraic data types**: User-defined inductive data types (`inductive Maybe a := | Nothing | Just a`)+- **Polymorphism**: Parametric polymorphism with type variables (`def id {a} (x: a) : a := x`)+- **Symbol declarations**: `declare symbol x, y, z` for declaring symbolic variables used in tensor and math calculations+ ## Refereed Papers  ### Pattern Matching@@ -31,9 +53,9 @@ The following code enumerates all twin primes from the infinite list of prime numbers with pattern matching!  ```hs-def twinPrimes :=+def twinPrimes : [(Integer, Integer)] :=   matchAll primes as list integer with-  | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2)+    | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2)  take 8 twinPrimes -- [(3, 5), (5, 7), (11, 13), (17, 19), (29, 31), (41, 43), (59, 61), (71, 73)]@@ -45,25 +67,34 @@ All hands are expressed in a single pattern.  ```hs-def poker cs :=+inductive Suit := Spade | Heart | Club | Diamond+inductive Card := Card Suit Integer++inductive pattern Suit := | spade | heart | club | diamond+inductive pattern Card := | card Suit Integer++def suit := algebraicDataMatcher | spade | heart | club | diamond+def card := algebraicDataMatcher | card suit (mod 13)++def poker (cs: [Card]) : String :=   match cs as multiset card with-  | card $s $n :: card #s #(n-1) :: card #s #(n-2) :: card #s #(n-3) :: card #s #(n-4) :: _+  | [card $s $n, card #s #(n - 1), card #s #(n - 2), card #s #(n - 3), card #s #(n - 4)]     -> "Straight flush"-  | card _ $n :: card _ #n :: card _ #n :: card _ #n :: _ :: []+  | [card _ $n, card _ #n, card _ #n, card _ #n, _]     -> "Four of a kind"-  | card _ $m :: card _ #m :: card _ #m :: card _ $n :: card _ #n :: []+  | [card _ $m, card _ #m, card _ #m, card _ $n, card _ #n]     -> "Full house"-  | card $s _ :: card #s _ :: card #s _ :: card #s _ :: card #s _ :: []+  | [card $s _, card #s _, card #s _, card #s _, card #s _]     -> "Flush"-  | card _ $n :: card _ #(n-1) :: card _ #(n-2) :: card _ #(n-3) :: card _ #(n-4) :: []+  | [card _ $n, card _ #(n - 1), card _ #(n - 2), card _ #(n - 3), card _ #(n - 4)]     -> "Straight"-  | card _ $n :: card _ #n :: card _ #n :: _ :: _ :: []+  | [card _ $n, card _ #n, card _ #n, _, _]     -> "Three of a kind"-  | card _ $m :: card _ #m :: card _ $n :: card _ #n :: _ :: []+  | [card _ $m, card _ #m, card _ $n, card _ #n, _]     -> "Two pair"-  | card _ $n :: card _ #n :: _ :: _ :: _ :: []+  | [card _ $n, card _ #n, _, _, _]     -> "One pair"-  | _ :: _ :: _ :: _ :: _ :: [] -> "Nothing"+  | [_, _, _, _, _] -> "Nothing" ```  ### Graphs@@ -72,26 +103,27 @@ We can write a program to solve the travelling salesman problem in a single pattern-matching expression.  ```hs-def graph := multiset (string, multiset (string, integer))--def graphData :=-  [("Berlin", [("New York", 14), ("London", 2), ("Tokyo", 14), ("Vancouver", 13)]),-   ("New York", [("Berlin", 14), ("London", 12), ("Tokyo", 18), ("Vancouver", 6)]),-   ("London", [("Berlin", 2), ("New York", 12), ("Tokyo", 15), ("Vancouver", 10)]),-   ("Tokyo", [("Berlin", 14), ("New York", 18), ("London", 15), ("Vancouver", 12)]),-   ("Vancouver", [("Berlin", 13), ("New York", 6), ("London", 10), ("Tokyo", 12)])]+def station : Matcher String := string+def price : Matcher Integer := integer+def graph : Matcher [(String, [(String, Integer)])] :=+  multiset (station, multiset (station, price)) -def trips :=-  let n := length graphData in-    matchAll graphData as graph with-    | (#"Berlin", (($s_1,$p_1) : _)) ::-        loop $i (2, n - 1)-          ((#s_(i - 1), ($s_i, $p_i) :: _) :: ...)-          ((#s_(n - 1), (#"Berlin" & $s_n, $p_n) :: _) :: [])-    -> sum (map (\i -> p_i) [1..n]), map (\i -> s_i) [1..n]+def graphData : [(String, [(String, Integer)])] :=+  [ ("Berlin",    [("St. Louis", 14), ("Oxford", 2),  ("Nara", 14), ("Vancouver", 13)])+  , ("St. Louis", [("Berlin", 14),    ("Oxford", 12), ("Nara", 18), ("Vancouver", 6)])+  , ("Oxford",    [("Berlin", 2),     ("St. Louis", 12), ("Nara", 15), ("Vancouver", 10)])+  , ("Nara",      [("Berlin", 14),    ("St. Louis", 18), ("Oxford", 15), ("Vancouver", 12)])+  , ("Vancouver", [("Berlin", 13),    ("St. Louis", 6),  ("Oxford", 10), ("Nara", 12)]) ] -car (sortBy (\(_, x), (_, y) -> compare x y)) trips)--- (["London", "New York", "Vancouver", "Tokyo"," Berlin"], 46)+def trips : [(Integer, [String])] :=+  matchAll graphData as graph with+    | (#"Berlin", ($s_1, $p_1) :: _) :: (loop $i (2, 4, _)+                                           (( #s_(i - 1)+                                           , ($s_i, $p_i) :: _ ) :: ...)+                                           (( #s_4+                                           , ( #"Berlin" & $s_5+                                           , $p_5 ) :: _ ) :: _)) ->+      (sum (map (\i -> p_i) (between 1 5)), s) ```  ## Egison as a Computer Algebra System@@ -104,6 +136,7 @@ Egison treats unbound variables as symbols.  ```+> declare symbol x, y > x x > (x + y)^2@@ -132,6 +165,7 @@ * [Rewriting rule for `i` in `normalize.egi`](https://github.com/egison/egison/blob/master/lib/math/normalize.egi)  ```+> declare symbol x, y > i * i -1 > (1 + i) * (1 + i)@@ -147,6 +181,7 @@ * [Rewriting rule for `sqrt` in `normalize.egi`](https://github.com/egison/egison/blob/master/lib/math/normalize.egi)  ```+> declare symbol x, y > sqrt 2 * sqrt 2 2 > sqrt 6 * sqrt 10@@ -159,7 +194,7 @@  The following is a sample to calculate the 5th roots of unity. -* [Definition of `q-f'` in `equations.egi`](https://github.com/egison/egison/blob/master/lib/math/algebra/equations.egi)+* [Definition of `qF'` in `equations.egi`](https://github.com/egison/egison/blob/master/lib/math/algebra/equations.egi)  ``` > qF' 1 1 (-1)@@ -181,6 +216,7 @@ * [Definition of `d/d` in `derivative.egi`](https://github.com/egison/egison/blob/master/lib/math/analysis/derivative.egi)  ```+> declare symbol x > d/d (x ^ 3) x 3 * x^2 > d/d (e ^ (i * x)) x@@ -196,10 +232,11 @@ The following sample executes Taylor expansion on Egison. We verify [Euler's formula](https://en.wikipedia.org/wiki/Euler%27s_formula) in the following sample. -* [Definition of `taylor-expansion` in `derivative.egi`](https://github.com/egison/egison/blob/master/lib/math/analysis/derivative.egi)+* [Definition of `taylorExpansion` in `derivative.egi`](https://github.com/egison/egison/blob/master/lib/math/analysis/derivative.egi)  ```-> take 8 (taylorExpansion (exp (i * x)) x 0)+> declare symbol x+> take 8 (taylorExpansion (e^(i * x)) x 0) [1, x * i, - x^2 / 2, - x^3 * i / 6, x^4 / 24, x^5 * i / 120, - x^6 / 720, - x^7 * i / 5040] > take 8 (taylorExpansion (cos x) x 0) [1, 0, - x^2 / 2, 0, x^4 / 24, 0, - x^6 / 720, 0]@@ -220,37 +257,39 @@   ```hs+declare symbol r, θ, φ: MathExpr+ -- Parameters-def x := [| θ, φ |]+def x : Vector MathExpr := [| θ, φ |] -def X := [| r * (sin θ) * (cos φ) -- x-      , r * (sin θ) * (sin φ) -- y-      , r * (cos θ)           -- z-      |]+def X : Vector MathExpr := [| r * sin θ * cos φ -- x+          , r * sin θ * sin φ -- y+          , r * cos θ         -- z+          |] -def e_i_j := (∂/∂ X_j x~i)+def e_i_j : Matrix MathExpr := ∂/∂ X_j x~i  -- Metric tensors-def g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2]-def g~i~j := M.inverse g_#_#+def g[_i_j] : Matrix MathExpr := generateTensor (\[a, b] -> V.* e_a e_b) [2, 2]+def g[~i~j] : Matrix MathExpr := M.inverse g_#_#  g_#_# -- [| [| r^2, 0 |], [| 0, r^2 * (sin θ)^2 |] |]_#_# g~#~# -- [| [| 1 / r^2, 0 |], [| 0, 1 / (r^2 * (sin θ)^2) |] |]~#~#  -- Christoffel symbols-def Γ_i_j_k := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i)+def Γ_i[_j_k] : Tensor MathExpr := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i)  Γ_1_#_# -- [| [| 0, 0 |], [| 0, -1 * r^2 * (sin θ) * (cos θ) |] |]_#_# Γ_2_#_# -- [| [| 0, r^2 * (sin θ) * (cos θ) |], [| r^2 * (sin θ) * (cos θ), 0 |] |]_#_# -def Γ~i_j_k := withSymbols [m]+def Γ~i_j_k : Tensor MathExpr := withSymbols [m]   g~i~m . Γ_m_j_k -Γ~1_#_# -- [| [| 0, 0 |], [| 0, -1 * (sin θ) * (cos θ) |] |]_#_#+Γ~1_#_# -- [| [| 0, 0 |], [| 0, -1 * sin θ * cos θ |] |]_#_# Γ~2_#_# -- [| [| 0, (cos θ) / (sin θ) |], [| (cos θ) / (sin θ), 0 |] |]_#_#  -- Riemann curvature-def R~i_j_k_l := withSymbols [m]+def R~i_j_k_l : Tensor MathExpr := withSymbols [m]   ∂/∂ Γ~i_j_l x~k - ∂/∂ Γ~i_j_k x~l + Γ~m_j_l . Γ~i_m_k - Γ~m_j_k . Γ~i_m_l  R~#_#_1_1 -- [| [| 0, 0 |], [| 0, 0 |] |]~#_#@@ -266,37 +305,37 @@ The following sample is from [Curvature Form - Egison Mathematics Notebook](https://www.egison.org/math/curvature-form.html).  ```hs+declare symbol r, θ, φ: MathExpr+ -- Parameters and metric tensor-def x := [| θ, φ |]+def x : Vector MathExpr := [| θ, φ |] -def g_i_j := [| [| r^2, 0 |], [| 0, r^2 * (sin θ)^2 |] |]_i_j-def g~i~j := [| [| 1 / r^2, 0 |], [| 0, 1 / (r^2 * (sin θ)^2) |] |]~i~j+def g_i_j : Matrix MathExpr := [| [| r^2, 0 |], [| 0, r^2 * (sin θ)^2 |] |]_i_j+def g~i~j : Matrix MathExpr := [| [| 1 / r^2, 0 |], [| 0, 1 / (r^2 * (sin θ)^2) |] |]~i~j  -- Christoffel symbols-def Γ_j_l_k := (1 / 2) * (∂/∂ g_j_l x~k + ∂/∂ g_j_k x~l - ∂/∂ g_k_l x~j)--def Γ~i_k_l := withSymbols [j] g~i~j . Γ_j_l_k+def Γ_j_l_k : Tensor MathExpr := (1 / 2) * (∂/∂ g_j_l x~k + ∂/∂ g_j_k x~l - ∂/∂ g_k_l x~j) --- Exterior derivative-def d %t := !(flip ∂/∂) x t+def Γ~i_k_l : Tensor MathExpr := withSymbols [j] g~i~j . Γ_j_l_k --- Wedge product-infixl expression 7 ∧+-- Riemann curvature+def R~i_j_k_l : Tensor MathExpr := withSymbols [m]+  ∂/∂ Γ~i_j_l x~k - ∂/∂ Γ~i_j_k x~l + Γ~m_j_l . Γ~i_m_k - Γ~m_j_k . Γ~i_m_l -def (∧) %x %y := x !. y+-- Exterior derivative+def d (t : Tensor MathExpr) : Tensor MathExpr := !(flip ∂/∂) x t  -- Connection form-def ω~i_j := Γ~i_j_#+def ω~i_j : Matrix MathExpr := Γ~i_j_#  -- Curvature form-def Ω~i_j := withSymbols [k]+def Ω~i_j : Tensor MathExpr := withSymbols [k]   antisymmetrize (d ω~i_j + ω~i_k ∧ ω~k_j)  Ω~#_#_1_1 -- [| [| 0, 0 |], [| 0, 0 |] |]~#_# Ω~#_#_1_2 -- [| [| 0, (sin θ)^2  / 2|], [| -1 / 2, 0 |] |]~#_# Ω~#_#_2_1 -- [| [| 0, -1 * (sin θ)^2 / 2 |], [| 1 / 2, 0 |] |]~#_# Ω~#_#_2_2 -- [| [| 0, 0 |], [| 0, 0 |] |]~#_#- ```  ### Egison Mathematics Notebook@@ -330,12 +369,19 @@ We also have [online interpreter](http://console.egison.org) and [online tutorial](http://try.egison.org/). Enjoy! +## Editor Support++Egison provides syntax highlighting plugins for the following editors:++- **Emacs**: [`emacs/egison-mode.el`](emacs/) -- See [`emacs/README.md`](emacs/README.md) for installation instructions.+- **Vim / Neovim**: [`vim/`](vim/) -- See [`vim/README.md`](vim/README.md) for installation instructions.+- **VS Code / Cursor**: [`vscode-extension/`](vscode-extension/) -- See [`vscode-extension/INSTALL.md`](vscode-extension/INSTALL.md) for installation instructions.+ ## Notes for Developers  You can build Egison as follows: ```-$ stack init-$ stack build --fast+$ cabal build ```  For testing, see [test/README.md](test/README.md).

@@ -25,6 +25,6 @@          , bgroup "collection"            [ bench "cons-bench"       $ whnfIO $ runEgisonFile "benchmark/collection-bench-cons.egi"            , bench "cons-bench-large" $ whnfIO $ runEgisonFile "benchmark/collection-bench-cons-large.egi"-           , bench "snoc-bench"       $ whnfIO $ runEgisonFile "benchmark/collection-bench-snoc.egi"+           , bench "*:-bench"         $ whnfIO $ runEgisonFile "benchmark/collection-bench-*:.egi"            ]          ]

@@ -1,11 +0,0 @@-def countEvens n l :=-  match l as list integer with-    | snoc ?isEven $tl -> countEvens (n + 1) tl-    | snoc _ $tl -> countEvens n tl-    | [] -> n--def testNumbers :=-  let from n := if n <= 0 then [0] else n :: from (n - 1)-   in from 10000--countEvens 0 testNumbers

@@ -0,0 +1,11 @@+def countEvens n l :=+  match l as list integer with+    | $tl *: ?isEven -> countEvens (n + 1) tl+    | $tl *: _ -> countEvens n tl+    | [] -> n++def testNumbers :=+  let from n := if n <= 0 then [0] else n :: from (n - 1)+   in from 10000++countEvens 0 testNumbers

@@ -1,12 +1,16 @@ Name:                egison-Version:             4.2.1+Version:             5.0.0 Synopsis:            Programming language with non-linear pattern-matching against non-free data Description:-  An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language.+  An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language+  with a static type system.   We can directly represent pattern-matching against lists, multisets, sets, trees, graphs and any kind of data types.   .+  Egison 5 introduces a static type system with type classes, inductive data types,+  type inference, and type annotations, while preserving the expressive pattern-matching of Egison 4.+  .   We can find Egison programs in @lib@ and @sample@ directories.-  This package also include Emacs Lisp file @elisp/egison-mode.el@.+  This package also include Emacs Lisp file @emacs/egison-mode.el@.   .   We can do non-linear pattern-matching against non-free data types in Egison.   An non-free data type is a data type whose data have no canonical form, a standard way to represent that object.@@ -29,18 +33,25 @@                      lib/math/analysis/*.egi                      lib/math/geometry/*.egi +Extra-doc-files:     Changelog.md+ Extra-source-files:  README.md-                     Changelog.md                      benchmark/Benchmark.hs                      benchmark/*.egi-                     test/fixture/*.egi                      test/lib/math/*.egi                      test/lib/core/*.egi                      sample/*.egi-                     sample/sat/*.egi+                     sample/database/*.egi+                     sample/io/*.egi+                     sample/math/algebra/*.egi+                     sample/math/analysis/*.egi                      sample/math/geometry/*.egi                      sample/math/number/*.egi-                     elisp/egison-mode.el+                     sample/physics/*.egi+                     sample/repl/*.egi+                     sample/rosetta/*.egi+                     sample/sat/*.egi+                     emacs/egison-mode.el  source-repository head   type: git@@ -50,23 +61,24 @@   default-language:    GHC2021   Build-Depends:       base                 >= 4.8     && < 5-    , random               >= 1.0     && < 2.0+    , random               >= 1.0     && < 2     , containers           >= 0.6     && < 0.8     , unordered-containers >= 0.1.0.0 && < 0.3     , haskeline            >= 0.7     && < 0.9     , transformers         >= 0.4     && < 0.7-    , mtl                  >= 2.2.2   && < 3.0-    , parsec               >= 3.0     && < 4.0-    , megaparsec           >= 7.0.0   && < 12.0-    , parser-combinators   >= 1.0     && < 2.0-    , directory            >= 1.3.0   && < 2.0+    , mtl                  >= 2.2.2   && < 3+    , parsec               >= 3.0     && < 4+    , megaparsec           >= 7.0.0   && < 12+    , parser-combinators   >= 1.0     && < 2+    , directory            >= 1.3.0   && < 2+    , filepath             >= 1.4     && < 2     , text                 >= 0.2     && < 2.2-    , regex-tdfa           >= 1.2.0   && < 2.0-    , process              >= 1.0     && < 2.0+    , regex-tdfa           >= 1.2.0   && < 2+    , process              >= 1.0     && < 2     , vector               >= 0.12    && < 0.14-    , hashable             >= 1.0     && < 2.0+    , hashable             >= 1.0     && < 2     , optparse-applicative >= 0.14    && < 0.20-    , prettyprinter        >= 1.0     && < 2.0+    , prettyprinter        >= 1.0     && < 2     , unicode-show         >= 0.1     && < 0.2     , sweet-egison         >= 0.1.2.1 && < 0.2   if !impl(ghc > 8.0)@@ -78,12 +90,14 @@                    Language.Egison.Core                    Language.Egison.CmdOptions                    Language.Egison.Completion-                   Language.Egison.Desugar+                       Language.Egison.Desugar                    Language.Egison.Data-                   Language.Egison.Data.Collection-                   Language.Egison.Data.Utils-                   Language.Egison.EvalState-                   Language.Egison.Eval+                  Language.Egison.Data.Collection+                  Language.Egison.Data.Utils+                  Language.Egison.EnvBuilder+                  Language.Egison.VarEntry+                  Language.Egison.EvalState+                  Language.Egison.Eval                    Language.Egison.IExpr                    Language.Egison.Match                    Language.Egison.Math.Arith@@ -94,7 +108,6 @@                    Language.Egison.MathOutput                    Language.Egison.MList                    Language.Egison.Parser-                   Language.Egison.Parser.SExpr                    Language.Egison.Parser.NonS                    Language.Egison.Pretty                    Language.Egison.PrettyMath.AST@@ -110,9 +123,24 @@                    Language.Egison.Primitives.Utils                    Language.Egison.RState                    Language.Egison.Tensor+                   Language.Egison.Type+                   Language.Egison.Type.Check+                   Language.Egison.Type.Env+                   Language.Egison.Type.Error+                   Language.Egison.Type.Index+                   Language.Egison.Type.Infer+                   Language.Egison.Type.Subst+                   Language.Egison.Type.TensorMapInsertion+                   Language.Egison.Type.TypeClassExpand+                   Language.Egison.Type.Tensor+                   Language.Egison.Type.TypedDesugar+                   Language.Egison.Type.Types+                   Language.Egison.Type.Unify+                   Language.Egison.Type.Instance+                   Language.Egison.Type.Pretty   Other-modules:   Paths_egison   autogen-modules: Paths_egison-  ghc-options:  -O3 -Wall -Wno-name-shadowing -Wno-incomplete-patterns+  ghc-options:  -Wall -Wno-name-shadowing -Wno-incomplete-patterns  Test-Suite test   default-language:    GHC2021@@ -133,22 +161,6 @@   autogen-modules: Paths_egison   ghc-options:  -Wall -Wno-name-shadowing -Test-Suite test-cli-  default-language:    GHC2021-  Type:           exitcode-stdio-1.0-  Hs-Source-Dirs: test-  Main-Is:        CLITest.hs-  Build-Depends:-      egison-    , base >= 4.8 && < 5-    , process-    , HUnit-    , test-framework-    , test-framework-hunit-  Other-modules:   Paths_egison-  autogen-modules: Paths_egison-  ghc-options:  -Wall -Wno-name-shadowing- Benchmark benchmark   default-language:    GHC2021   Type: exitcode-stdio-1.0@@ -173,7 +185,7 @@     , haskeline     , mtl     , directory-    , filepath             >= 1.4     && < 2.0+    , filepath             >= 1.4     && < 2     , text     , regex-tdfa     , optparse-applicative@@ -182,14 +194,4 @@   Hs-Source-Dirs:      hs-src/Interpreter   Other-modules:       Paths_egison   autogen-modules: Paths_egison-  ghc-options:  -O3 -threaded -rtsopts -Wall -Wno-name-shadowing--Executable egison-translate-  default-language:    GHC2021-  Main-is:          translator.hs-  Build-depends:-      egison-    , base >= 4.8 && < 5-    , prettyprinter-  Hs-Source-Dirs:   hs-src/Tool-  ghc-options:  -Wall -Wno-name-shadowing+  ghc-options:  -threaded -rtsopts -Wall -Wno-name-shadowing

@@ -1,178 +0,0 @@-;;; egison-mode.el --- Egison editing mode--;; Copyright (C) 2011-2015 Satoshi Egi--;; Permission is hereby granted, free of charge, to any person obtaining-;; a copy of this software and associated documentation files (the "Software"),-;; to deal in the Software without restriction, including without limitation-;; the rights to use, copy, modify, merge, publish, distribute, sublicense,-;; and/or sell copies of the Software, and to permit persons to whom the Software-;; is furnished to do so, subject to the following conditions:--;; The above copyright notice and this permission notice shall be included-;; in all copies or substantial portions of the Software.--;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,-;; INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR-;; A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT-;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF-;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE-;; OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.--;;; Author: Satoshi Egi <egisatoshi@gmail.com>-;;; URL: https://github.com/egisatoshi/egison3/blob/master/elisp/egison-mode.el-;;; Version: 0.1.5--;;; Commentary:--;; Emacs Mode for Egison-;;-;; Please put it in your load-path of Emacs. Then, add the following-;; lines in your .emacs.-;;-;;   (autoload 'egison-mode "egison-mode" "Major mode for editing Egison code." t)-;;   (setq auto-mode-alist (cons `("\\.egi$" . egison-mode) auto-mode-alist))--;;; Code:--(defconst egison-font-lock-keywords-1-  (eval-when-compile-    (list-     "\\<load\\>"-     "\\<loadFile\\>"--     "\\<let\\>"-     "\\<withSymbols\\>"-     "\\<if\\>"-     "\\<generateArray\\>"-     "\\<arrayBounds\\>"-     "\\<arrayRef\\>"-     "\\<tensor\\>"-     "\\<generateTensor\\>"-     "\\<contract\\>"-     "\\<tensorMap\\>"--     "\\<loop\\>"-     "\\<match\\>"-     "\\<matchDFS\\>"-     "\\<matchAll\\>"-     "\\<matchAllDFS\\>"-     "\\<as\\>"-     "\\<with\\>"-     "\\<matcher\\>"-     "\\<algebraicDataMatcher\\>"--     "\\<do\\>"-     "\\<io\\>"-     "\\<seq\\>"--     "\\<undefined\\>"-     "\\<something\\>"--;     ":="-     "::"-     "++"-     "\\\.\\\.\\\."-     "->"-     "#"-;     "'"-     "`"-     "\\\#"-     "|"-     "\\\&"-     "@"-     "!"-     "?"-;     "\\<_\\>"--     "\\<assert\\>"-     "\\<assert-equal\\>"-     ))-  "Subdued expressions to highlight in Egison modes.")--(defconst egison-font-lock-keywords-2-  (append egison-font-lock-keywords-1-   (eval-when-compile-     (list-      (cons "\\\$\\\w*" font-lock-variable-name-face)-      (cons "\\\%\\\w*" font-lock-variable-name-face)-      )))-  "Gaudy expressions to highlight in Egison modes.")--(defvar egison-font-lock-keywords egison-font-lock-keywords-1-  "Default expressions to highlight in Egison modes.")--(defun egison-indent-line ()-  "indent current line as Egison code."-  (interactive)-  )---(defvar egison-mode-map-  (let ((smap (make-sparse-keymap)))-    (define-key smap "\C-j" 'newline-and-indent)-    smap)-  "Keymap for Egison mode.")---(defvar egison-mode-syntax-table-  (let ((table (make-syntax-table)))--    (modify-syntax-entry ?\{  "(}1nb" table)-    (modify-syntax-entry ?\}  "){4nb" table)-    (modify-syntax-entry ?-  "_ 123" table)-    (modify-syntax-entry ?\-  "_ 123" table)-;    (modify-syntax-entry ?\;  "_ 123" table)-    (modify-syntax-entry ?\n ">" table)-    table)-  ;; (copy-syntax-table lisp-mode-syntax-table)-  "Syntax table for Egison mode")--(defun egison-mode-set-variables ()-  (set-syntax-table egison-mode-syntax-table)-  (set (make-local-variable 'font-lock-defaults)-       '((egison-font-lock-keywords-          egison-font-lock-keywords-1 egison-font-lock-keywords-2)-         nil t (("+*/=!?%:_~.'∂∇αβγδεζχθικλμνξοπρςστυφχψωΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΧΨΩ" . "w"))-         ))-  (set (make-local-variable 'indent-line-function) 'egison-indent-line)-  (set (make-local-variable 'comment-start) "--")-  (set (make-local-variable 'comment-end) "")-  (set (make-local-variable 'comment-start-skip) "{-+ *\\|--+ *")-  (set (make-local-variable 'comment-add) 1)-  (set (make-local-variable 'comment-end-skip) nil)-  )---;;;###autoload-(defun egison-mode ()-  "Major mode for editing Egison code.--Commands:-\\{egison-mode-map}-Entry to this mode calls the value of `egison-mode-hook'-if that value is non-nil."-  (interactive)-  (kill-all-local-variables)-  (setq indent-tabs-mode nil)-  (use-local-map egison-mode-map)-  (setq major-mode 'egison-mode)-  (setq mode-name "Egison")-  (egison-mode-set-variables)-  (run-mode-hooks 'egison-mode-hook))---(defgroup egison nil-  "Editing Egison code."-  :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)-  :group 'lisp)--(defcustom egison-mode-hook nil-  "Normal hook run when entering `egison-mode'.-See `run-hooks'."-  :type 'hook-  :group 'egison)--(provide 'egison-mode)--;;; egison-mode.el ends here

@@ -0,0 +1,405 @@+;;; egison-mode.el --- Egison editing mode++;; Copyright (C) 2011-2026 Satoshi Egi++;; Permission is hereby granted, free of charge, to any person obtaining+;; a copy of this software and associated documentation files (the "Software"),+;; to deal in the Software without restriction, including without limitation+;; the rights to use, copy, modify, merge, publish, distribute, sublicense,+;; and/or sell copies of the Software, and to permit persons to whom the Software+;; is furnished to do so, subject to the following conditions:++;; The above copyright notice and this permission notice shall be included+;; in all copies or substantial portions of the Software.++;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,+;; INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR+;; A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF+;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE+;; OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.++;;; Author: Satoshi Egi <egisatoshi@gmail.com>+;;; URL: https://github.com/egisatoshi/egison/blob/master/emacs/egison-mode.el+;;; Version: 0.3.0++;;; Commentary:++;; Emacs Mode for Egison+;;+;; Please put it in your load-path of Emacs. Then, add the following+;; lines in your .emacs.+;;+;;   (autoload 'egison-mode "egison-mode" "Major mode for editing Egison code." t)+;;   (setq auto-mode-alist (cons `("\\.egi$" . egison-mode) auto-mode-alist))++;;; Code:++;; ============================================================+;; Face definitions+;; ============================================================++(defface egison-keyword-face+  '((t :inherit font-lock-keyword-face))+  "Face for Egison keywords."+  :group 'egison)++(defface egison-type-keyword-face+  '((t :inherit font-lock-type-face))+  "Face for Egison type system keywords (class, instance, inductive, etc.)."+  :group 'egison)++(defface egison-builtin-type-face+  '((t :inherit font-lock-type-face))+  "Face for Egison built-in type names."+  :group 'egison)++(defface egison-definition-face+  '((t :inherit font-lock-keyword-face))+  "Face for Egison definition keywords."+  :group 'egison)++(defface egison-pattern-variable-face+  '((t :inherit font-lock-variable-name-face))+  "Face for Egison pattern variables ($x, etc.)."+  :group 'egison)++(defface egison-value-pattern-face+  '((t :inherit font-lock-constant-face))+  "Face for Egison value patterns (#x, etc.)."+  :group 'egison)++(defface egison-constructor-face+  '((t :inherit font-lock-constant-face))+  "Face for Egison data constructors and boolean values."+  :group 'egison)++(defface egison-type-constraint-face+  '((t :inherit font-lock-type-face))+  "Face for Egison type constraints ({Eq a}, etc.)."+  :group 'egison)++;; ============================================================+;; Font-lock keywords level 1 (basic)+;; ============================================================++(defconst egison-font-lock-keywords-1+  (eval-when-compile+    (list+     ;; ----- Type system keywords (highlighted prominently) -----+     (cons (concat "\\<" (regexp-opt+       '("class" "instance" "inductive" "extends" "declare") t)+       "\\>")+       'font-lock-type-face)++     ;; ----- Definition keywords -----+     (cons (concat "\\<" (regexp-opt+       '("def" "let" "in" "where") t)+       "\\>")+       'font-lock-keyword-face)++     ;; ----- Module and loading -----+     (cons (concat "\\<" (regexp-opt+       '("load" "loadFile" "execute") t)+       "\\>")+       'font-lock-builtin-face)++     ;; ----- Control flow -----+     (cons (concat "\\<" (regexp-opt+       '("if" "then" "else") t)+       "\\>")+       'font-lock-keyword-face)++     ;; ----- Pattern matching -----+     (cons (concat "\\<" (regexp-opt+       '("match" "matchDFS" "matchAll" "matchAllDFS"+         "as" "with" "forall" "loop") t)+       "\\>")+       'font-lock-keyword-face)++     ;; ----- Matcher definition -----+     (cons (concat "\\<" (regexp-opt+       '("matcher" "algebraicDataMatcher") t)+       "\\>")+       'font-lock-keyword-face)++     ;; ----- Lambda and special forms -----+     (cons (concat "\\<" (regexp-opt+       '("memoizedLambda" "cambda" "capply"+         "withSymbols" "function") t)+       "\\>")+       'font-lock-keyword-face)++     ;; ----- Tensor operations -----+     (cons (concat "\\<" (regexp-opt+       '("tensor" "generateTensor" "contract"+         "tensorMap" "tensorMap2"+         "transpose" "flipIndices"+         "subrefs" "suprefs" "userRefs") t)+       "\\>")+       'font-lock-builtin-face)++     ;; ----- IO and sequencing -----+     (cons (concat "\\<" (regexp-opt+       '("do" "seq") t)+       "\\>")+       'font-lock-keyword-face)++     ;; ----- Infix declarations -----+     (cons (concat "\\<" (regexp-opt+       '("infixr" "infixl" "infix" "expression" "pattern") t)+       "\\>")+       'font-lock-keyword-face)++     ;; ----- Special values -----+     (cons (concat "\\<" (regexp-opt+       '("undefined" "something") t)+       "\\>")+       'font-lock-constant-face)++     ;; ----- Built-in type names -----+     (cons (concat "\\<" (regexp-opt+       '("Integer" "MathExpr" "Float" "Bool" "Char" "String"+         "IO" "Matcher" "Pattern"+         "Tensor" "Vector" "Matrix" "DiffForm"+         "List") t)+       "\\>")+       'font-lock-type-face)++     ;; ----- Boolean literals -----+     (cons (concat "\\<" (regexp-opt '("True" "False") t) "\\>")+       'font-lock-constant-face)++     ;; ----- Testing primitives -----+     (cons (concat "\\<" (regexp-opt+       '("assert" "assertEqual") t)+       "\\>")+       'font-lock-warning-face)++     ;; ----- Operators and symbols -----+     (cons ":=" 'font-lock-keyword-face)+     (cons "::" 'font-lock-keyword-face)+     (cons "++" 'font-lock-keyword-face)+     (cons "=>" 'font-lock-keyword-face)+     (cons "->" 'font-lock-keyword-face)+     (cons "\\.\\.\\." 'font-lock-keyword-face)+     ))+  "Subdued expressions to highlight in Egison modes.")++;; ============================================================+;; Font-lock keywords level 2 (gaudy - includes type annotations)+;; ============================================================++(defconst egison-font-lock-keywords-2+  (append egison-font-lock-keywords-1+   (eval-when-compile+     (list+      ;; Pattern variables ($x, $pat, etc.)+      (cons "\\$[a-zA-Z_][a-zA-Z0-9_']*" 'font-lock-variable-name-face)++      ;; Value patterns (#x, #(expr), etc.)+      (cons "#[a-zA-Z_][a-zA-Z0-9_']*" 'font-lock-constant-face)++      ;; Type class constraints in braces: {Eq a}, {Eq a, Ord b}+      (cons "{[A-Z][a-zA-Z0-9_',: ]*}" 'font-lock-type-face)++      ;; Type annotations in parameter list: (x: Integer), (x: a)+      (list "(\\([a-zA-Z_][a-zA-Z0-9_']*\\)\\s-*:" 1 'font-lock-variable-name-face)++      ;; Type names after colon in type annotations+      (list ":\\s-*\\([A-Z][a-zA-Z0-9_]*\\)" 1 'font-lock-type-face)++      ;; User-defined type names (uppercase identifiers not already matched)+      ;; in inductive/class/instance declarations+      (list "\\<\\(inductive\\|class\\|instance\\)\\s-+\\([A-Z][a-zA-Z0-9_]*\\)"+            2 'font-lock-type-face)++      ;; Data constructors in inductive definitions (after | at start of line)+      (list "^\\s-*|\\s-+\\([A-Z][a-zA-Z0-9_]*\\)" 1 'font-lock-constant-face)++      ;; "declare symbol" combination+      (list "\\<\\(declare\\)\\s-+\\(symbol\\)\\>"+            (list 1 'font-lock-keyword-face)+            (list 2 'font-lock-keyword-face))++      ;; "inductive pattern" combination+      (list "\\<\\(inductive\\)\\s-+\\(pattern\\)\\>"+            (list 1 'font-lock-type-face)+            (list 2 'font-lock-type-face))++      ;; "def pattern" combination+      (list "\\<\\(def\\)\\s-+\\(pattern\\)\\>"+            (list 1 'font-lock-keyword-face)+            (list 2 'font-lock-keyword-face))++      ;; Function name after "def" keyword+      (list "\\<def\\s-+\\([a-zA-Z_][a-zA-Z0-9_']*\\)" 1 'font-lock-function-name-face)++      ;; Index notation: subscripts and superscripts (e.g., v~i, v_j, T~i~j_k)+      (cons "[a-zA-Z0-9_'][~_][a-zA-Z0-9_']+" 'font-lock-preprocessor-face)+      )))+  "Gaudy expressions to highlight in Egison modes.")++(defvar egison-font-lock-keywords egison-font-lock-keywords-1+  "Default expressions to highlight in Egison modes.")++;; ============================================================+;; Indentation+;; ============================================================++(defun egison-indent-line ()+  "Indent current line as Egison code."+  (interactive)+  (let ((indent (egison-calculate-indent)))+    (when indent+      (save-excursion+        (beginning-of-line)+        (delete-horizontal-space)+        (indent-to indent))+      (when (< (current-column) indent)+        (move-to-column indent)))))++(defun egison-calculate-indent ()+  "Calculate the indentation level for the current line."+  (save-excursion+    (beginning-of-line)+    (cond+     ;; Top-level definitions+     ((looking-at "^\\(def\\|load\\|class\\|instance\\|inductive\\|declare\\|infixl\\|infixr\\|infix\\)\\>")+      0)+     ;; Match clause continuation (lines starting with |)+     ((looking-at "^\\s-*|")+      (save-excursion+        (forward-line -1)+        (cond+         ((looking-at "^\\s-*|")+          (current-indentation))+         ((looking-at ".*\\<with\\>\\s-*$")+          (+ (current-indentation) 2))+         ((looking-at ".*:=\\s-*$")+          (+ (current-indentation) 2))+         (t (current-indentation)))))+     ;; Lines after "where"+     ((save-excursion+        (forward-line -1)+        (looking-at ".*\\<where\\>\\s-*$"))+      (save-excursion+        (forward-line -1)+        (+ (current-indentation) 2)))+     ;; Default: match previous line+     (t+      (save-excursion+        (forward-line -1)+        (current-indentation))))))++;; ============================================================+;; Keymap+;; ============================================================++(defvar egison-mode-map+  (let ((smap (make-sparse-keymap)))+    (define-key smap "\C-j" 'newline-and-indent)+    smap)+  "Keymap for Egison mode.")++;; ============================================================+;; Syntax table+;; ============================================================++(defvar egison-mode-syntax-table+  (let ((table (make-syntax-table)))+    ;; Block comments: {- ... -}+    (modify-syntax-entry ?\{  "(}1nb" table)+    (modify-syntax-entry ?\}  "){4nb" table)+    (modify-syntax-entry ?-  "_ 123" table)+    (modify-syntax-entry ?\n ">" table)++    ;; String literals+    (modify-syntax-entry ?\" "\"" table)+    (modify-syntax-entry ?\' "\"" table)++    ;; Operators that are part of words+    (modify-syntax-entry ?_ "w" table)+    (modify-syntax-entry ?~ "w" table)++    ;; Special symbols+    (modify-syntax-entry ?$ "'" table)+    (modify-syntax-entry ?# "'" table)+    (modify-syntax-entry ?& "." table)+    (modify-syntax-entry ?| "." table)+    (modify-syntax-entry ?! "." table)+    (modify-syntax-entry ?? "." table)+    (modify-syntax-entry ?@ "." table)++    table)+  "Syntax table for Egison mode")++;; ============================================================+;; Mode setup+;; ============================================================++(defun egison-mode-set-variables ()+  (set-syntax-table egison-mode-syntax-table)+  (set (make-local-variable 'font-lock-defaults)+       '((egison-font-lock-keywords+          egison-font-lock-keywords-1 egison-font-lock-keywords-2)+         nil t+         ;; Include special characters and mathematical symbols as word constituents+         (("+*/=!?%:_~.'∂∇αβγδεζηθικλμνξοπρςστυφχψωΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΧΨΩ" . "w"))+         ))+  (set (make-local-variable 'indent-line-function) 'egison-indent-line)++  ;; Comment settings for -- and {- -}+  (set (make-local-variable 'comment-start) "-- ")+  (set (make-local-variable 'comment-end) "")+  (set (make-local-variable 'comment-start-skip) "{-+ *\\|--+ *")+  (set (make-local-variable 'comment-add) 1)+  (set (make-local-variable 'comment-end-skip) nil)++  ;; Block comment delimiters+  (set (make-local-variable 'comment-multi-line) t)+  )+++;;;###autoload+(defun egison-mode ()+  "Major mode for editing Egison code.++Features:+  - Syntax highlighting for Egison keywords, type annotations,+    type class definitions, inductive types, and pattern matching.+  - Support for type system keywords: class, instance, inductive,+    extends, declare, pattern.+  - Highlighting for pattern variables ($x), value patterns (#x),+    type constraints ({Eq a}), and type annotations (x: Integer).+  - Basic indentation support.+  - Comment support for line comments (--) and block comments ({- -}).++Commands:+\\{egison-mode-map}+Entry to this mode calls the value of `egison-mode-hook'+if that value is non-nil."+  (interactive)+  (kill-all-local-variables)+  (setq indent-tabs-mode nil)+  (use-local-map egison-mode-map)+  (setq major-mode 'egison-mode)+  (setq mode-name "Egison")+  (egison-mode-set-variables)+  (run-mode-hooks 'egison-mode-hook))+++(defgroup egison nil+  "Editing Egison code."+  :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)+  :group 'lisp)++(defcustom egison-mode-hook nil+  "Normal hook run when entering `egison-mode'.+See `run-hooks'."+  :type 'hook+  :group 'egison)++(provide 'egison-mode)++;;; egison-mode.el ends here

@@ -42,21 +42,45 @@ run :: RuntimeM () run = do   opts <- ask-  coreEnv <- initialEnv-  mEnv <- fromEvalT $ evalTopExprs coreEnv $ map Load (optLoadLibs opts) ++ map LoadFile (optLoadFiles opts)-  case mEnv of+  -- Collect all files to load (core libs, user libs, load files, and test files)+  -- Load core libraries first unless --no-prelude is set+  isNoPrelude <- asks optNoPrelude+  mathNormalize <- asks optMathNormalize+  let coreLibExprs = if isNoPrelude then [] else map Load coreLibraries+      -- Add math normalization library based on option+      mathLibExpr = if isNoPrelude+                      then []+                      else [Load (if mathNormalize+                                    then "lib/math/normalize.egi"+                                    else "lib/math/no-normalize.egi")]+      libExprs = map Load (optLoadLibs opts)+      loadFileExprs = map LoadFile (optLoadFiles opts)+      -- Include test file in the initial load to preserve type class environment+      testFileExprs = case (optTestOnly opts, optExecFile opts) of+        (True, Just (file, _)) -> [LoadFile file]+        _                      -> []+      -- Load core libraries first, then math library, then user libraries and files+      allLoadExprs = coreLibExprs ++ mathLibExpr ++ libExprs ++ loadFileExprs ++ testFileExprs+  -- Load all libraries and user files in a single EvalM context to preserve EvalState+  mResult <- fromEvalTWithState initialEvalState $ do+    env <- initialEnv  -- Only primitive environment+    evalTopExprs' env allLoadExprs True True+  case mResult of     Left err  -> liftIO $ print err-    Right env -> handleOption env opts+    Right (env, evalState) -> handleOptionWithState env evalState opts  handleOption :: Env -> EgisonOpts -> RuntimeM ()-handleOption env opts =+handleOption env opts = handleOptionWithState env initialEvalState opts++handleOptionWithState :: Env -> EvalState -> EgisonOpts -> RuntimeM ()+handleOptionWithState env evalState opts =   case opts of     -- Evaluate the given string     EgisonOpts { optEvalString = Just expr } ->-      runAndPrintExpr env expr+      runAndPrintExprWithState env evalState expr     -- Execute the given string     EgisonOpts { optExecuteString = Just cmd } ->-      executeTopExpr env $ "execute (" ++ cmd ++ ")"+      executeTopExprWithState env evalState $ "execute (" ++ cmd ++ ")"     -- Operate input in tsv format as infinite stream     EgisonOpts { optSubstituteString = Just sub } ->       let (sopts, copts) = unzip (optFieldInfo opts)@@ -66,14 +90,14 @@               ++ "execute (let SH.input := SH.genInput " ++ sopts' ++ " " ++ copts' ++ "\n"               ++ if optTsvOutput opts then "          in each (\\x -> print (showTsv x)) ((" ++ sub ++ ") SH.input))"                                       else "          in each (\\x -> print (show x)) ((" ++ sub ++ ") SH.input))"-        in executeTopExpr env expr+        in executeTopExprWithState env evalState expr     -- Execute a script (test only)-    EgisonOpts { optTestOnly = True, optExecFile = Just (file, _) } -> do-      exprs <- liftIO $ readFile file-      result <- if optNoIO opts-                   then fromEvalT (runTopExprs env exprs)-                   else fromEvalT (evalTopExprs env [LoadFile file])-      liftIO $ either print (const $ return ()) result+    -- Note: The test file has already been loaded in the run function+    -- to preserve the type class environment from library files.+    -- Here we just need to evaluate the test expressions.+    EgisonOpts { optTestOnly = True, optExecFile = Just (_file, _) } -> do+      -- Test file has already been loaded, nothing more to do+      return ()     -- Execute a script from the main function     EgisonOpts { optExecFile = Just (file, args) } -> do       result <- fromEvalT $ evalTopExprs env [LoadFile file, Execute (makeApply "main" [CollectionExpr (map (ConstantExpr . StringExpr . T.pack) args)])]@@ -85,7 +109,7 @@     -- Start the read-eval-print-loop     _ -> do       when (optShowBanner opts) (liftIO showBanner)-      repl env+      replWithState env evalState       when (optShowBanner opts) (liftIO showByebyeMessage)       liftIO exitSuccess @@ -96,6 +120,13 @@      then executeTopExpr env $ "execute (each (\\x -> print (showTsv x)) (" ++ expr ++ "))"      else executeTopExpr env $ "execute (print (show (" ++ expr ++ ")))" +runAndPrintExprWithState :: Env -> EvalState -> String -> RuntimeM ()+runAndPrintExprWithState env evalState expr = do+  isTsvOutput <- asks optTsvOutput+  if isTsvOutput+     then executeTopExprWithState env evalState $ "execute (each (\\x -> print (showTsv x)) (" ++ expr ++ "))"+     else executeTopExprWithState env evalState $ "execute (print (show (" ++ expr ++ ")))"+ executeTopExpr :: Env -> String -> RuntimeM () executeTopExpr env expr = do   cmdRet <- fromEvalT (runTopExprs env expr)@@ -103,6 +134,13 @@     Left err -> liftIO $ hPrint stderr err >> exitFailure     _        -> liftIO exitSuccess +executeTopExprWithState :: Env -> EvalState -> String -> RuntimeM ()+executeTopExprWithState env evalState expr = do+  cmdRet <- fromEvalTWithState evalState (runTopExprs env expr)+  case cmdRet of+    Left err -> liftIO $ hPrint stderr err >> exitFailure+    Right _ -> liftIO exitSuccess+ showBanner :: IO () showBanner = do   putStrLn $ "Egison Version " ++ showVersion version@@ -124,53 +162,105 @@            }  repl :: Env -> RuntimeM ()-repl env = (do+repl env = replWithState env initialEvalState++replWithState :: Env -> EvalState -> RuntimeM ()+replWithState env evalState = (do   home <- liftIO getHomeDirectory-  input <- runInputT (settings home env) getEgisonExpr+  input <- runInputT (settings home env) (getReplInput env)   case input of     Nothing -> return ()-    Just topExpr -> do-      result <- fromEvalT (evalTopExprStr env topExpr)+    Just (ReplExpr topExpr) -> do+      result <- fromEvalTWithState evalState (evalTopExprStr env topExpr)       case result of-        Left err               -> liftIO (print err) >> repl env-        Right (Just str, env') -> liftIO (putStrLn str) >> repl env'-        Right (Nothing, env')  -> repl env'+        Left err -> liftIO (print err) >> replWithState env evalState+        Right ((Just str, env'), evalState') -> liftIO (putStrLn str) >> replWithState env' evalState'+        Right ((Nothing, env'), evalState')  -> replWithState env' evalState'+    Just (ReplTypeStr exprStr) -> do+      -- Parse and type check the expression+      -- Note: This feature is temporarily disabled due to refactoring.+      -- TODO: Re-implement using Infer pipeline.+      liftIO $ putStrLn $ "Type checking in REPL is temporarily disabled during refactoring."+      liftIO $ putStrLn $ "Expression: " ++ exprStr+      replWithState env evalState+    Just ReplHelp -> do+      liftIO showReplHelp+      replWithState env evalState+    Just ReplQuit -> return ()   )   `catch`   (\case-      UserInterrupt -> liftIO (putStrLn "") >> repl env-      StackOverflow -> liftIO (putStrLn "Stack over flow!") >> repl env-      HeapOverflow  -> liftIO (putStrLn "Heap over flow!") >> repl env-      _             -> liftIO (putStrLn "error!") >> repl env+      UserInterrupt -> liftIO (putStrLn "") >> replWithState env evalState+      StackOverflow -> liftIO (putStrLn "Stack over flow!") >> replWithState env evalState+      HeapOverflow  -> liftIO (putStrLn "Heap over flow!") >> replWithState env evalState+      _             -> liftIO (putStrLn "error!") >> replWithState env evalState    ) --- |Get Egison expression from the prompt. We can handle multiline input.-getEgisonExpr :: InputT RuntimeM (Maybe TopExpr)-getEgisonExpr = getEgisonExpr' ""+-- | REPL input types+data ReplInput+  = ReplExpr TopExpr      -- ^ Regular expression to evaluate+  | ReplTypeStr String    -- ^ :type command with expression string+  | ReplHelp              -- ^ :help command+  | ReplQuit              -- ^ :quit command++-- | Show REPL help+showReplHelp :: IO ()+showReplHelp = do+  putStrLn "REPL Commands:"+  putStrLn "  :type <expr>  - Show the type of an expression"+  putStrLn "  :t <expr>     - Short for :type"+  putStrLn "  :help         - Show this help"+  putStrLn "  :h            - Short for :help"+  putStrLn "  :quit         - Exit the REPL"+  putStrLn "  :q            - Short for :quit"++-- |Get REPL input from the prompt. We can handle multiline input and special commands.+getReplInput :: Env -> InputT RuntimeM (Maybe ReplInput)+getReplInput env = getReplInput' ""   where-    getEgisonExpr' prev = do+    getReplInput' prev = do       opts <- lift ask       mLine <- case prev of                  "" -> getInputLine $ optPrompt opts                  _  -> getInputLine $ replicate (length $ optPrompt opts) ' '       case mLine of         Nothing -> return Nothing-        Just [] | null prev -> getEgisonExpr-        Just [] -> getEgisonExpr' prev+        Just [] | null prev -> getReplInput env+        Just [] -> getReplInput' prev         Just line -> do           history <- getHistory           putHistory $ addHistoryUnlessConsecutiveDupe line history           let input = prev ++ line-          parsedExpr <- lift $ parseTopExpr (replaceNewLine input)-          case parsedExpr of-            Left err | err =~ "unexpected end of input" ->-              getEgisonExpr' (input ++ "\n")-            Left err -> do-              liftIO $ putStrLn ("Parse error at: " ++ err)-              getEgisonExpr-            Right topExpr -> do-              -- outputStr $ show topExpr-              return $ Just topExpr+          -- Check for special commands+          case parseReplCommand input of+            Just cmd -> return $ Just cmd+            Nothing -> do+              parsedExpr <- lift $ parseTopExpr (replaceNewLine input)+              case parsedExpr of+                Left err | err =~ "unexpected end of input" ->+                  getReplInput' (input ++ "\n")+                Left err -> do+                  liftIO $ putStrLn ("Parse error at: " ++ err)+                  getReplInput env+                Right topExpr ->+                  return $ Just (ReplExpr topExpr)++-- | Parse REPL special commands+parseReplCommand :: String -> Maybe ReplInput+parseReplCommand input = case words input of+  [":quit"]     -> Just ReplQuit+  [":q"]        -> Just ReplQuit+  [":help"]     -> Just ReplHelp+  [":h"]        -> Just ReplHelp+  (":type":rest) -> parseTypeCommand (unwords rest)+  (":t":rest)    -> parseTypeCommand (unwords rest)+  _             -> Nothing++-- | Parse :type command (returns expression string to be parsed later)+parseTypeCommand :: String -> Maybe ReplInput+parseTypeCommand exprStr+  | null exprStr = Nothing+  | otherwise    = Just $ ReplTypeStr exprStr  replaceNewLine :: String -> String replaceNewLine input =

@@ -9,6 +9,7 @@        ( module Language.Egison.AST        , module Language.Egison.Data        , module Language.Egison.Eval+       , module Language.Egison.EvalState        , module Language.Egison.Parser        , module Language.Egison.Primitives        -- * Modules needed to execute Egison@@ -16,6 +17,7 @@        , module Language.Egison.RState        -- * Environment        , initialEnv+       , coreLibraries        -- * Information        , version       ) where@@ -30,6 +32,7 @@ import           Language.Egison.CmdOptions import           Language.Egison.Data import           Language.Egison.Eval+import           Language.Egison.EvalState import           Language.Egison.Parser import           Language.Egison.Primitives import           Language.Egison.RState@@ -38,46 +41,44 @@ version :: Version version = P.version --- |Environment that contains core libraries-initialEnv :: RuntimeM Env+-- |Create initial environment with only primitive functions+-- Core libraries will be loaded separately to maintain consistent Env chain+-- Returns EvalM Env to preserve EvalState (type environment, class environment)+initialEnv :: EvalM Env initialEnv = do-  isNoIO <- asks optNoIO-  useMathNormalize <- asks optMathNormalize+  isNoIO <- lift $ lift $ asks optNoIO   env <- liftIO $ if isNoIO then primitiveEnvNoIO else primitiveEnv-  let normalizeLib = if useMathNormalize then "lib/math/normalize.egi" else "lib/math/no-normalize.egi"-  ret <- local (const defaultOption)-               (fromEvalT (evalTopExprs env $ map Load (coreLibraries ++ [normalizeLib])))-  case ret of-    Left err -> do-      liftIO $ print (show err)-      return env-    Right env' -> return env'+  return env  coreLibraries :: [String] coreLibraries =   -- Libs that defines user-defined infixes comes first-  [ "lib/core/base.egi"              -- Defines (&&) (||)-  , "lib/math/common/arithmetic.egi" -- Defines (+) (-) (*) (/) (+') (-') (*') (/')-  , "lib/math/algebra/tensor.egi"    -- Defines (.) (.')+  [+    "lib/core/base.egi"              -- Defines (&&) (||)+  , "lib/core/order.egi"   , "lib/core/collection.egi"        -- Defines (++) for patterns-  , "lib/math/expression.egi"        -- Defines (+) (*) (/) (^) for patterns--  , "lib/core/assoc.egi"-  , "lib/core/io.egi"   , "lib/core/maybe.egi"   , "lib/core/number.egi"-  , "lib/core/order.egi"   , "lib/core/random.egi"+  , "lib/core/assoc.egi"   , "lib/core/string.egi"-  , "lib/core/sort.egi"+  , "lib/core/io.egi"++  , "lib/math/expression.egi"        -- Defines (+) (*) (/) (^) for patterns+  , "lib/math/common/arithmetic.egi" -- Defines (+) (-) (*) (/) (+') (-') (*') (/')+  , "lib/math/algebra/group.egi"+   , "lib/math/common/constants.egi"   , "lib/math/common/functions.egi"   , "lib/math/algebra/root.egi"-  , "lib/math/algebra/equations.egi"-  , "lib/math/algebra/inverse.egi"-  , "lib/math/analysis/derivative.egi"-  , "lib/math/analysis/integral.egi"+  , "lib/math/algebra/tensor.egi"    -- Defines (.) (.')   , "lib/math/algebra/vector.egi"++  , "lib/math/algebra/equations.egi"   , "lib/math/algebra/matrix.egi"+  , "lib/math/analysis/derivative.egi"+   , "lib/math/geometry/differential-form.egi"+--  , "lib/math/algebra/inverse.egi"+--  , "lib/math/analysis/integral.egi"   ]

@@ -21,7 +21,7 @@   , PMMode (..)   , BindingExpr (..)   , MatchClause-  , PatternDef+  , PatternDef (..)   , LoopRange (..)   , PrimitivePatPattern (..)   , PDPatternBase (..)@@ -33,6 +33,23 @@   , findOpFrom   , stringToVarWithIndices   , extractNameFromVarWithIndices+  -- Type annotations+  , TypeExpr (..)+  , TensorShapeExpr (..)+  , ShapeDim (..)+  , TensorIndexExpr (..)+  , TypedParam (..)+  , TypedVarWithIndices (..)+  -- Inductive data types+  , InductiveConstructor (..)+  -- Pattern inductive types+  , PatternConstructor (..)+  -- Type classes+  , ClassDecl (..)+  , ClassMethod (..)+  , InstanceDecl (..)+  , InstanceMethod (..)+  , ConstraintExpr (..)   ) where  import           Data.List  (find)@@ -41,14 +58,98 @@  data TopExpr   = Define VarWithIndices Expr+  | DefineWithType TypedVarWithIndices Expr  -- ^ Definition with type annotation   | Test Expr   | Execute Expr     -- temporary : we will replace load to import and export   | LoadFile String   | Load String   | InfixDecl Bool Op -- True for pattern infix; False for expression infix+  | InductiveDecl String [String] [InductiveConstructor]+    -- ^ Inductive data type declaration with type parameters+    -- e.g., inductive Ordering := | Less | Equal | Greater+    --       inductive Maybe a := | Nothing | Just a+    -- String: type name, [String]: type parameters, [InductiveConstructor]: constructors+  | ClassDeclExpr ClassDecl+    -- ^ Type class declaration+    -- e.g., class Eq a where (==) (x: a) (y: a) : Bool+  | InstanceDeclExpr InstanceDecl+    -- ^ Type class instance declaration+    -- e.g., instance Eq Integer where (==) x y := x = y+  | PatternInductiveDecl String [String] [PatternConstructor]+    -- ^ Pattern inductive type declaration+    -- e.g., inductive pattern MyList a := | myNil | myCons a (MyList a)+    -- String: pattern type name, [String]: type parameters, [PatternConstructor]: constructors+  | PatternFunctionDecl String [String] [(String, TypeExpr)] TypeExpr Pattern+    -- ^ Pattern function declaration+    -- e.g., def pattern twin {a} (p1 : a) (p2 : MyList a) : MyList a := ...+    -- String: function name, [String]: type parameters, [(String, TypeExpr)]: parameters, TypeExpr: return type, Pattern: body+  | DeclareSymbol [String] (Maybe TypeExpr)+    -- ^ Symbol declaration+    -- e.g., declare symbol a11, a12, a21, a22+    --       declare symbol x, y, z : Float+    -- [String]: symbol names, Maybe TypeExpr: optional type (defaults to Integer)  deriving Show +-- | Type class declaration+-- e.g., class Eq a where ...+--       class Eq a => Ord a where ...+data ClassDecl = ClassDecl+  { className       :: String           -- ^ Class name (e.g., "Eq", "Ord")+  , classTypeParams :: [String]         -- ^ Type parameters (e.g., ["a"])+  , classSuperclasses :: [ConstraintExpr] -- ^ Superclass constraints (e.g., [Eq a] for Ord)+  , classMethods    :: [ClassMethod]    -- ^ Method declarations+  } deriving Show++-- | Type class method declaration+-- e.g., (==) (x: a) (y: a) : Bool+--       (/=) (x: a) (y: a) : Bool := not (x == y)+data ClassMethod = ClassMethod+  { methodName    :: String             -- ^ Method name (e.g., "==")+  , methodParams  :: [TypedParam]       -- ^ Method parameters with types+  , methodRetType :: TypeExpr           -- ^ Return type+  , methodDefault :: Maybe Expr         -- ^ Optional default implementation+  } deriving Show++-- | Type class instance declaration+-- e.g., instance Eq Integer where ...+--       instance Eq a => Eq [a] where ...+data InstanceDecl = InstanceDecl+  { instanceConstraints :: [ConstraintExpr] -- ^ Instance constraints (e.g., [Eq a] for Eq [a])+  , instanceClass       :: String           -- ^ Class name (e.g., "Eq")+  , instanceTypes       :: [TypeExpr]       -- ^ Instance types (e.g., [Integer] or [[a]])+  , instanceMethods     :: [InstanceMethod] -- ^ Method implementations+  } deriving Show++-- | Instance method implementation+-- e.g., (==) x y := x = y+data InstanceMethod = InstanceMethod+  { instMethodName   :: String          -- ^ Method name+  , instMethodParams :: [String]        -- ^ Parameter names+  , instMethodBody   :: Expr            -- ^ Method body+  } deriving Show++-- | Type constraint expression+-- e.g., Eq a, Ord a+data ConstraintExpr = ConstraintExpr+  { constraintClass :: String           -- ^ Class name+  , constraintTypes :: [TypeExpr]       -- ^ Type arguments+  } deriving (Show, Eq)++-- | Constructor for inductive data type+-- e.g., Less, S Nat, Node Tree Tree+data InductiveConstructor = InductiveConstructor+  { inductiveCtorName :: String      -- ^ Constructor name (e.g., "Less", "S", "Node")+  , inductiveCtorArgs :: [TypeExpr]  -- ^ Constructor argument types (e.g., [], [Nat], [Tree, Tree])+  } deriving (Show, Eq)++-- | Constructor for pattern inductive type+-- e.g., myNil, myCons a (MyList a)+data PatternConstructor = PatternConstructor+  { patternCtorName :: String      -- ^ Pattern constructor name (e.g., "myNil", "myCons")+  , patternCtorArgs :: [TypeExpr]  -- ^ Pattern constructor argument types (e.g., [], [a, MyList a])+  } deriving (Show, Eq)+ data ConstantExpr   = CharExpr Char   | StringExpr Text@@ -76,7 +177,9 @@    | LambdaExpr [Arg ArgPattern] Expr   | LambdaExpr' [Arg VarWithIndices] Expr+  | TypedLambdaExpr [(String, TypeExpr)] TypeExpr Expr  -- ^ Lambda with typed parameters and return type   | MemoizedLambdaExpr [String] Expr+  | TypedMemoizedLambdaExpr [TypedParam] TypeExpr Expr  -- ^ Memoized lambda with typed parameters   | CambdaExpr String Expr   | PatternFunctionExpr [String] Pattern @@ -105,11 +208,10 @@    | SeqExpr Expr Expr   | ApplyExpr Expr [Expr]-  | CApplyExpr Expr Expr-  | AnonParamFuncExpr Integer Expr-  | AnonTupleParamFuncExpr Integer Expr-  | AnonListParamFuncExpr Integer Expr-  | AnonParamExpr Integer+  | AnonParamFuncExpr Integer Expr      -- e.g. 2#2, 3#$1, 2#($1 + $2)+  | AnonTupleParamFuncExpr Integer Expr -- e.g. (2)#2, (3)#$1, (2)#($1 + $2)+  | AnonListParamFuncExpr Integer Expr  -- e.g. [2]#2, [3]#$1, [2]#($1 + $2)+  | AnonParamExpr Integer               -- e.g. $1, $2    | GenerateTensorExpr Expr Expr   | TensorExpr Expr Expr@@ -117,18 +219,19 @@   | TensorMapExpr Expr Expr   | TensorMap2Expr Expr Expr Expr   | TransposeExpr Expr Expr-  | FlipIndicesExpr Expr                              -- Does not appear in user program+  | FlipIndicesExpr Expr    | FunctionExpr [String]++  | TypeAnnotation Expr TypeExpr  -- ^ Expression with type annotation (expr : type)   deriving Show  data VarWithIndices = VarWithIndices String [VarIndex]   deriving (Show, Eq)  data Arg a-  = ScalarArg a-  | InvertedScalarArg a-  | TensorArg a+  = Arg a+  | InvertedArg a   deriving Show  data ArgPattern@@ -166,11 +269,18 @@ data BindingExpr   = Bind PrimitiveDataPattern Expr   | BindWithIndices VarWithIndices Expr+  | BindWithType TypedVarWithIndices Expr  -- ^ Binding with type annotation (for where clauses)   deriving Show  type MatchClause = (Pattern, Expr)-type PatternDef  = (PrimitivePatPattern, Expr, [(PrimitiveDataPattern, Expr)]) +-- | Pattern definition in a matcher (with optional type class constraints)+data PatternDef = PatternDef+  { patDefPattern     :: PrimitivePatPattern+  , patDefMatcher     :: Expr+  , patDefClauses     :: [(PrimitiveDataPattern, Expr)]+  } deriving Show+ data Pattern   = WildCard   | PatVar String@@ -203,7 +313,7 @@ data PrimitivePatPattern   = PPWildCard   | PPPatVar-  | PPValuePat String+  | PPValuePat String  -- Variable name   | PPInductivePat String [PrimitivePatPattern]   | PPTuplePat [PrimitivePatPattern]   deriving Show@@ -217,6 +327,20 @@   | PDConsPat (PDPatternBase var) (PDPatternBase var)   | PDSnocPat (PDPatternBase var) (PDPatternBase var)   | PDConstantPat ConstantExpr+  -- ScalarData (MathExpr) primitive patterns+  | PDDivPat (PDPatternBase var) (PDPatternBase var)        -- Div: ScalarData -> PolyExpr, PolyExpr+  | PDPlusPat (PDPatternBase var)                           -- Plus: PolyExpr -> [TermExpr]+  | PDTermPat (PDPatternBase var) (PDPatternBase var)       -- Term: TermExpr -> Integer, [(SymbolExpr, Integer)]+  | PDSymbolPat (PDPatternBase var) (PDPatternBase var)     -- Symbol: SymbolExpr -> String, [IndexExpr]+  | PDApply1Pat (PDPatternBase var) (PDPatternBase var)     -- Apply1: SymbolExpr -> MathExpr, MathExpr+  | PDApply2Pat (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) -- Apply2+  | PDApply3Pat (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) -- Apply3+  | PDApply4Pat (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) -- Apply4+  | PDQuotePat (PDPatternBase var)                          -- Quote: SymbolExpr -> MathExpr+  | PDFunctionPat (PDPatternBase var) (PDPatternBase var) -- Function: SymbolExpr -> MathExpr, [MathExpr]+  | PDSubPat (PDPatternBase var)                            -- Sub: IndexExpr -> MathExpr+  | PDSupPat (PDPatternBase var)                            -- Sup: IndexExpr -> MathExpr+  | PDUserPat (PDPatternBase var)                           -- User: IndexExpr -> MathExpr   deriving (Functor, Foldable, Show)  type PrimitiveDataPattern = PDPatternBase String@@ -244,23 +368,45 @@  reservedExprOp :: [Op] reservedExprOp =-  [ Op "!"  8 Prefix False -- Wedge-  , Op "-"  7 Prefix False -- Negate-  , Op "%"  7 InfixL False -- primitive function-  , Op "*$" 7 Prefix False -- For InvertedScalarArg-  , Op "*$" 7 InfixL False -- For InvertedScalarArg-  , Op "++" 5 InfixR False-  , Op "::" 5 InfixR False-  , Op "="  4 InfixL False -- primitive function-  , Op "<=" 4 InfixL False -- primitive function-  , Op ">=" 4 InfixL False -- primitive function-  , Op "<"  4 InfixL False -- primitive function-  , Op ">"  4 InfixL False -- primitive function+  [ Op "!"    8 Prefix False -- Wedge and InvertedArg prefix+  , Op "-"    7 Prefix False -- Negate+  , Op "%"    7 InfixL False -- primitive function+  , Op "++"   5 InfixR False+  , Op "::"   5 InfixR False+  , Op "=="   4 InfixL False -- equality (from type class)+  , Op "/="   4 InfixL False -- inequality (from type class)+  , Op "="    4 InfixL False -- primitive function+  , Op "<="   4 InfixL False -- primitive function+  , Op ">="   4 InfixL False -- primitive function+  , Op "<"    4 InfixL False -- primitive function+  , Op ">"    4 InfixL False -- primitive function+  , Op "&&"   3 InfixR False -- logical and (from base)+  , Op "||"   2 InfixR False -- logical or (from base)+  , Op "$"    0 InfixR False -- right-associative lowest-priority (application)+  , Op "+"    6 InfixL False+  , Op "-"    6 InfixL False+  , Op "*"    7 InfixL False+  , Op "/"    7 InfixL False+  , Op "^"    8 InfixL False+  , Op "+'"   6 InfixL False+  , Op "-'"   6 InfixL False+  , Op "*'"   7 InfixL False+  , Op "/'"   7 InfixL False+  , Op "^'"   8 InfixL False+  , Op "∧"    7 InfixL False+  , Op "."    7 InfixL False+  , Op ".'"   7 InfixL False   ]  reservedPatternOp :: [Op] reservedPatternOp =-  [ Op "::" 5 InfixR False  -- required for desugaring collection pattern+  [ Op "++" 5 InfixR False+  , Op "*:" 5 InfixL False+  , Op "+" 7 InfixR False+  , Op "*" 8 InfixR False+  , Op "/" 8 InfixN False+  , Op "^" 9 InfixN False+  , Op "::" 6 InfixR False  -- required for desugaring collection pattern (priority 6 > ++ priority 5)   , Op "&"  3 InfixR False   , Op "|"  2 InfixR False   ]@@ -276,4 +422,72 @@  extractNameFromVarWithIndices :: VarWithIndices -> String extractNameFromVarWithIndices (VarWithIndices name _) = name++--+-- Type expressions (for type annotations)+--++-- | Type expression in source code+data TypeExpr+  = TEInt                              -- ^ Integer (= MathExpr)+  | TEMathExpr                         -- ^ MathExpr (= Integer)+  | TEFloat                            -- ^ Float+  | TEBool                             -- ^ Bool+  | TEChar                             -- ^ Char+  | TEString                           -- ^ String+  | TEVar String                       -- ^ Type variable, e.g., a+  | TEList TypeExpr                    -- ^ List type, e.g., [a]+  | TETuple [TypeExpr]                 -- ^ Tuple type, e.g., (a, b)+  | TEFun TypeExpr TypeExpr            -- ^ Function type, e.g., a -> b+  | TEMatcher TypeExpr                 -- ^ Matcher type+  | TEPattern TypeExpr                 -- ^ Pattern type, e.g., Pattern a+  | TEIO TypeExpr                      -- ^ IO type, e.g., IO ()+  | TETensor TypeExpr                  -- ^ Tensor type, e.g., Tensor a+  | TEVector TypeExpr                  -- ^ Vector type, e.g., Vector a (1D tensor)+  | TEMatrix TypeExpr                  -- ^ Matrix type, e.g., Matrix a (2D tensor)+  | TEDiffForm TypeExpr                -- ^ DiffForm type, e.g., DiffForm a (differential form, alias for Tensor)+  | TEApp TypeExpr [TypeExpr]          -- ^ Type application, e.g., List a+  | TEConstrained [ConstraintExpr] TypeExpr+                                      -- ^ Constrained type, e.g., Eq a => a+  deriving (Show, Eq)++-- | Tensor shape expression+data TensorShapeExpr+  = TSLit [Integer]                    -- ^ Concrete shape, e.g., [2, 2]+  | TSVar String                       -- ^ Shape variable+  | TSMixed [ShapeDim]                 -- ^ Mixed shape, e.g., [n, m, 2]+  deriving (Show, Eq)++-- | Shape dimension (can be concrete or variable)+data ShapeDim+  = SDLit Integer                      -- ^ Concrete dimension, e.g., 2+  | SDVar String                       -- ^ Dimension variable, e.g., n+  deriving (Show, Eq)++-- | Tensor index expression+data TensorIndexExpr+  = TISub String                       -- ^ Subscript, e.g., _i+  | TISup String                       -- ^ Superscript, e.g., ~i+  | TIPlaceholderSub                   -- ^ Subscript placeholder, _#+  | TIPlaceholderSup                   -- ^ Superscript placeholder, ~#+  deriving (Show, Eq)++-- | Typed parameter pattern+data TypedParam+  = TPVar String TypeExpr                    -- ^ Simple variable with type: (x: a)+  | TPInvertedVar String TypeExpr            -- ^ Inverted variable with type: (!x: a)+  | TPTuple [TypedParam]                     -- ^ Tuple pattern: ((x: a), (y: b)) or (x: a, y: b)+  | TPWildcard TypeExpr                      -- ^ Wildcard with type: (_: a)+  | TPUntypedVar String                      -- ^ Untyped variable in tuple: x (inferred)+  | TPUntypedWildcard                        -- ^ Untyped wildcard: _+  deriving (Show, Eq)++-- | Variable with type annotation+data TypedVarWithIndices = TypedVarWithIndices+  { typedVarName        :: String+  , typedVarIndices     :: [VarIndex]+  , typedVarConstraints :: [ConstraintExpr]  -- ^ Type class constraints+  , typedVarParams      :: [TypedParam]      -- ^ Typed parameters (can include tuples)+  , typedVarRetType     :: TypeExpr          -- ^ Return type+  } deriving (Show, Eq) 

@@ -30,16 +30,30 @@     optFilterTsvInput   :: Maybe String,     optTsvOutput        :: Bool,     optNoIO             :: Bool,+    optNoPrelude        :: Bool,       -- ^ Do not load core libraries     optShowBanner       :: Bool,     optTestOnly         :: Bool,     optPrompt           :: String,     optMathExpr         :: Maybe String,-    optSExpr            :: Bool,-    optMathNormalize    :: Bool+    optMathNormalize    :: Bool,+    optTypeCheck        :: Bool,       -- ^ Enable type checking+    optTypeCheckStrict  :: Bool,       -- ^ Strict type checking mode+    optDumpEnv          :: Bool,       -- ^ Dump environment after Phase 2+    optDumpDesugared    :: Bool,       -- ^ Dump desugared AST after Phase 3+    optDumpTyped        :: Bool,       -- ^ Dump typed AST after Phase 6 (type inference & check)+    optDumpTi           :: Bool,       -- ^ Dump typed AST after TensorMap insertion (before type class expansion)+    optDumpTc           :: Bool        -- ^ Dump typed AST after type class expansion (Phase 8 complete)     }  defaultOption :: EgisonOpts-defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing False True+defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False False True False "> " Nothing True True False False False False False False+--                                                                                                     ^^^^^ optNoPrelude+--                                                                                                                                      ^^^^ optTypeCheck is now True by default+--                                                                                                                                              ^^^^^ optDumpEnv+--                                                                                                                                                      ^^^^^ optDumpDesugared+--                                                                                                                                                              ^^^^^ optDumpTyped+--                                                                                                                                                                      ^^^^^ optDumpTi+--                                                                                                                                                                              ^^^^^ optDumpTc  cmdParser :: ParserInfo EgisonOpts cmdParser = info (helper <*> cmdArgParser)@@ -100,6 +114,9 @@             <*> switch                   (long "no-io"                   <> help "Prohibit all io primitives")+            <*> switch+                  (long "no-prelude"+                  <> help "Do not load core libraries")             <*> flag True False                   (long "no-banner"                   <> help "Do not display banner")@@ -118,13 +135,28 @@                   <> long "math"                   <> metavar "(asciimath|latex|mathematica|maxima)"                   <> help "Output in AsciiMath, Latex, Mathematica, or Maxima format"))-            <*> flag False True-                  (short 'S'-                  <> long "sexpr-syntax"-                  <> help "Use s-expression syntax")             <*> flag True False                   (long "no-normalize"                   <> help "Turn off normalization of math expressions")+            <*> pure True  -- Type checking is always enabled+            <*> switch+                  (long "type-check-strict"+                  <> help "Strict type checking (all types must be known)")+            <*> switch+                  (long "dump-env"+                  <> help "Dump environment information after Phase 2 (environment building)")+            <*> switch+                  (long "dump-desugared"+                  <> help "Dump desugared AST after Phase 3 (desugaring)")+            <*> switch+                  (long "dump-typed"+                  <> help "Dump typed AST after Phase 6 (type inference & check)")+            <*> switch+                  (long "dump-ti"+                  <> help "Dump typed AST after TensorMap insertion (before type class expansion)")+            <*> switch+                  (long "dump-tc"+                  <> help "Dump typed AST after type class expansion (Phase 8 complete)")  readFieldOption :: ReadM (String, String) readFieldOption = eitherReader $ \str ->

@@ -9,11 +9,10 @@   ( completeEgison   ) where -import           Data.HashMap.Strict         (keys) import           Data.List import           System.Console.Haskeline    (Completion (..), CompletionFunc, completeWord) -import           Language.Egison.Data        (Env (..))+import           Language.Egison.Data        (Env (..), envToBindingList) import           Language.Egison.IExpr       (Var (..)) import           Language.Egison.Parser.NonS (lowerReservedWords, upperReservedWords) @@ -31,8 +30,8 @@ completeNothing _ = return []  completeEgisonKeyword :: Monad m => Env -> String -> m [Completion]-completeEgisonKeyword (Env env _) str = do-  let definedWords = filter f $ map (\(Var name _) -> name) $ concatMap keys env+completeEgisonKeyword env str = do+  let definedWords = filter f $ map (\(Var name _, _) -> name) $ envToBindingList env   return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) (egisonKeywords ++ definedWords)  where    f [_]         = False

@@ -7,7 +7,21 @@ Module      : Language.Egison.Core Licence     : MIT -This module provides functions to evaluate various objects.+This module implements Phase 10: Evaluation.+It provides functions to evaluate expressions and perform pattern matching.++Evaluation Phase (Phase 10):+  - Pattern matching execution (patternMatch function)+    * Egison's powerful non-linear pattern matching with backtracking+    * Pattern matching is NOT desugared but executed during evaluation+  - Expression evaluation (evalExprShallow, evalExprDeep)+  - IO action execution+  - WHNF (Weak Head Normal Form) evaluation++Design Note (design/implementation.md):+Pattern matching is processed during evaluation, not during desugaring.+This allows Egison's sophisticated pattern matching features to be implemented+directly in the evaluator, keeping the desugaring phase simple. -}  module Language.Egison.Core@@ -16,8 +30,14 @@       evalExprShallow     , evalExprDeep     , evalWHNF+    -- * Type utilities+    , valueToType+    , whnfToType     -- * Environment     , recursiveBind+    , recursiveBindPatFuncs+    , recursiveBindAll+    , makeBindings'     -- * Pattern matching     , patternMatch     ) where@@ -39,7 +59,10 @@ import           Data.Traversable                (mapM)  import qualified Data.HashMap.Lazy               as HL+import qualified Data.HashMap.Strict             as HashMap import qualified Data.Vector                     as V+import           Data.Text                       (Text)+import qualified Data.Text                       as T  import           Language.Egison.Data import           Language.Egison.Data.Collection@@ -51,7 +74,39 @@ import           Language.Egison.Math import           Language.Egison.RState import           Language.Egison.Tensor+import           Language.Egison.Type.Types      (Type(..)) +-- | Get the Type of an EgisonValue+-- Used for type class method dispatch+valueToType :: EgisonValue -> Type+valueToType (Bool _)         = TBool+valueToType (ScalarData (Div (Plus []) (Plus [Term 1 []])))          = TInt+valueToType (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []]))) = TInt+valueToType (ScalarData _)   = TInt  -- MathExpr = TInt in Egison+valueToType (Float _)        = TFloat+valueToType (Char _)         = TChar+valueToType (String _)       = TString+valueToType (Collection _)   = TCollection TAny  -- TODO: infer element type+valueToType (Tuple vs)       = TTuple (map valueToType vs)+valueToType (IntHash _)      = THash TInt TAny+valueToType (CharHash _)     = THash TChar TAny+valueToType (StrHash _)      = THash TString TAny+valueToType (TensorData _)   = TTensor TAny+valueToType (InductiveData name _) = TInductive name []  -- TODO: infer type args+valueToType _                = TAny++-- | Get the Type of a WHNFData+-- This extracts type information from WHNF without fully evaluating+whnfToType :: WHNFData -> Type+whnfToType (Value val) = valueToType val+whnfToType (IInductiveData name _) = TInductive name []+whnfToType (ITuple refs) = TTuple (replicate (length refs) TAny)  -- Can't know element types without evaluation+whnfToType (ICollection _) = TCollection TAny+whnfToType (IIntHash _) = THash TInt TAny+whnfToType (ICharHash _) = THash TChar TAny+whnfToType (IStrHash _) = THash TString TAny+whnfToType (ITensor _) = TTensor TAny+ evalConstant :: ConstantExpr -> EgisonValue evalConstant (CharExpr c)    = Char c evalConstant (StringExpr s)  = toEgison s@@ -61,6 +116,10 @@ evalConstant SomethingExpr   = Something evalConstant UndefinedExpr   = Undefined +--+-- IExpr Evaluation+--+ evalExprShallow :: Env -> IExpr -> EvalM WHNFData evalExprShallow _ (IConstantExpr c) = return $ Value (evalConstant c) @@ -70,12 +129,28 @@     Value (ScalarData s) -> return . Value . ScalarData $ SingleTerm 1 [(Quote s, 1)]     _                    -> throwErrorWithTrace (TypeMismatch "scalar in quote" whnf) -evalExprShallow env (IQuoteSymbolExpr expr) = do-  whnf <- evalExprShallow env expr-  case whnf of-    Value (Func (Just (Var name [])) _ _ _) -> return . Value $ symbolScalarData "" name-    Value (ScalarData _)                    -> return whnf-    _                                       -> throwErrorWithTrace (TypeMismatch "value in quote-function" whnf)+evalExprShallow env (IQuoteSymbolExpr expr) =+  case expr of+    IVarExpr name -> do+      -- Try to evaluate the variable+      case refVar env (stringToVar name) of+        Just ref -> do+          val <- evalRef ref+          case val of+            Value func@(Func _ _ _ _) -> +              -- Quote the function object itself+              return . Value . ScalarData $ SingleTerm 1 [(QuoteFunction val, 1)]+            Value func@(MemoizedFunc _ _ _ _) -> +              -- Quote the memoized function object itself+              return . Value . ScalarData $ SingleTerm 1 [(QuoteFunction val, 1)]+            Value (ScalarData _) -> return val+            _ -> return . Value $ symbolScalarData "" name+        Nothing -> return . Value $ symbolScalarData "" name+    _ -> do+      whnf <- evalExprShallow env expr+      case whnf of+        Value (ScalarData _) -> return whnf+        _                    -> throwErrorWithTrace (TypeMismatch "scalar or symbol in quote-symbol" whnf)  evalExprShallow env (IVarExpr name) =   case refVar env (Var name []) of@@ -84,7 +159,7 @@     Nothing  -> return $ Value (symbolScalarData "" name)     Just ref -> evalRef ref -evalExprShallow _ (ITupleExpr []) = return . Value $ Tuple []+evalExprShallow _ (ITupleExpr []) = return . Value $ Tuple []  -- Unit value () evalExprShallow env (ITupleExpr [expr]) = evalExprShallow env expr evalExprShallow env (ITupleExpr exprs) = ITuple <$> mapM (newThunkRef env) exprs @@ -155,7 +230,7 @@       _            -> throwErrorWithTrace (TypeMismatch "integer or string" (Value val))   makeHashKey whnf = throwErrorWithTrace (TypeMismatch "integer or string" whnf) -evalExprShallow env@(Env fs _) (IIndexedExpr override expr indices) = do+evalExprShallow env@(Env _fs _ _) (IIndexedExpr override expr indices) = do   -- Tensor or hash   whnf <- case expr of               IVarExpr v -> do@@ -168,9 +243,11 @@     Value (ScalarData (SingleTerm 1 [(Symbol id name js', 1)])) -> do       js2 <- mapM evalIndexToScalar indices       return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (js' ++ js2), 1)]))-    Value (Func v@(Just (Var fnName is)) env args body) -> do+    Value (Func v@(Just (Var _fnName is)) env args body) -> do       js <- mapM evalIndex indices+      liftIO $ putStrLn $ "[DEBUG pmIndices] is: " ++ show is ++ ", js: " ++ show js       frame <- pmIndices is js+      liftIO $ putStrLn $ "can reach here"       let env' = extendEnv env frame       return $ Value (Func v env' args body)     Value (TensorData t@Tensor{}) -> do@@ -202,7 +279,12 @@     Value (ScalarData _)          -> return tensor     Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t     ITensor t@Tensor{}            -> refTensorWithOverride override js t-    _                             -> throwErrorWithTrace (NotImplemented "subrefs")+    _ -> do+      val <- evalWHNF tensor+      case val of+        ScalarData _          -> return $ Value val+        TensorData t@Tensor{} -> Value <$> refTensorWithOverride override js t+        _                     -> throwErrorWithTrace (NotImplemented ("subrefs for " ++ show val))  evalExprShallow env (ISuprefsExpr override expr jsExpr) = do   js <- map Sup <$> (evalExprDeep env jsExpr >>= collectionToList)@@ -217,7 +299,12 @@     Value (ScalarData _)          -> return tensor     Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t     ITensor t@Tensor{}            -> refTensorWithOverride override js t-    _                             -> throwErrorWithTrace (NotImplemented "suprefs")+    _ -> do+      val <- evalWHNF tensor+      case val of+        ScalarData _          -> return $ Value val+        TensorData t@Tensor{} -> Value <$> refTensorWithOverride override js t+        _                     -> throwErrorWithTrace (NotImplemented ("suprefs for " ++ show val))  evalExprShallow env (IUserrefsExpr _ expr jsExpr) = do   val <- evalExprDeep env expr@@ -225,11 +312,11 @@   case val of     ScalarData (SingleTerm 1 [(Symbol id name is, 1)]) ->       return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (is ++ js), 1)]))-    ScalarData (SingleTerm 1 [(FunctionData sym argnames args, 1)]) ->+    ScalarData (SingleTerm 1 [(FunctionData sym args, 1)]) ->       case sym of         SingleTerm 1 [(Symbol id name is, 1)] -> do           let sym' = SingleTerm 1 [(Symbol id name (is ++ js), 1)]-          return $ Value (ScalarData (SingleTerm 1 [(FunctionData sym' argnames args, 1)]))+          return $ Value (ScalarData (SingleTerm 1 [(FunctionData sym' args, 1)]))         _ -> throwErrorWithTrace (NotImplemented "user-refs")     _ -> throwErrorWithTrace (NotImplemented "user-refs") @@ -242,14 +329,12 @@  evalExprShallow env (ICambdaExpr name expr) = return . Value $ CFunc env name expr -evalExprShallow env (IPatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern--evalExprShallow (Env _ Nothing) (IFunctionExpr _) = throwError $ Default "function symbol is not bound to a variable"+evalExprShallow (Env _ Nothing _) (IFunctionExpr _) = throwError $ Default "function symbol is not bound to a variable" -evalExprShallow env@(Env _ (Just (name, is))) (IFunctionExpr args) = do+evalExprShallow env@(Env _ (Just (name, is)) _) (IFunctionExpr args) = do   args' <- mapM (evalExprDeep env . IVarExpr) args >>= mapM extractScalar   is' <- mapM unwrapMaybeFromIndex is-  return . Value $ ScalarData (SingleTerm 1 [(FunctionData (SingleTerm 1 [(Symbol "" name is', 1)]) (map symbolScalarData' args) args', 1)])+  return . Value $ ScalarData (SingleTerm 1 [(FunctionData (SingleTerm 1 [(Symbol "" name is', 1)]) args', 1)])  where   unwrapMaybeFromIndex :: Index (Maybe ScalarData) -> EvalM (Index ScalarData) -- Maybe we can refactor this function --  unwrapMaybeFromIndex = return . (fmap fromJust)@@ -297,11 +382,9 @@   syms <- mapM (newEvaluatedObjectRef . Value . symbolScalarData symId) vars   whnf <- evalExprShallow (extendEnv env (makeBindings' vars syms)) expr   case whnf of-    Value (TensorData t@Tensor{}) ->-      Value . TensorData <$> removeTmpScripts symId t-    ITensor t@Tensor{} ->-      ITensor <$> removeTmpScripts symId t-    _ -> return whnf+    Value (TensorData t@Tensor{}) -> Value . TensorData <$> removeTmpScripts symId t+    ITensor t@Tensor{}            -> ITensor <$> removeTmpScripts symId t+    _                             -> return whnf  where   isTmpSymbol :: String -> Index EgisonValue -> Bool   isTmpSymbol symId index = symId == getSymId (extractIndex index)@@ -311,6 +394,7 @@     let (ds, js) = partition (isTmpSymbol symId) is     Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is)     return (Tensor s ys js)+  removeTmpScripts _ t@Scalar{} = return t   evalExprShallow env (IDoExpr bindings expr) = return $ Value $ IOFunc $ do@@ -318,8 +402,16 @@   applyObj env (Value $ Func Nothing env [stringToVar "#1"] body) [WHNF (Value World)]  where   genLet (names, expr) expr' =-    ILetExpr [(PDTuplePat (map PDPatVar [stringToVar "#1", stringToVar "#2"]), IApplyExpr expr [IVarExpr "#1"])] $-    ILetExpr [(names, IVarExpr "#2")] expr'+    case names of+      -- If names is an empty tuple pattern () or wildcard, ignore the result+      PDTuplePat [] ->+        ILetExpr [(PDTuplePat [PDPatVar (stringToVar "#1"), PDWildCard], IApplyExpr expr [IVarExpr "#1"])] expr'+      PDWildCard ->+        ILetExpr [(PDTuplePat [PDPatVar (stringToVar "#1"), PDWildCard], IApplyExpr expr [IVarExpr "#1"])] expr'+      -- Otherwise, bind the result as before+      _ ->+        ILetExpr [(PDTuplePat [PDPatVar (stringToVar "#1"), PDPatVar (stringToVar "#2")], IApplyExpr expr [IVarExpr "#1"])] $+        ILetExpr [(names, IVarExpr "#2")] expr'  evalExprShallow env (IMatchAllExpr pmmode target matcher clauses) = do   target <- evalExprShallow env target@@ -357,14 +449,6 @@   _ <- evalExprDeep env expr1   evalExprShallow env expr2 -evalExprShallow env (ICApplyExpr func arg) = do-  func <- evalExprShallow env func-  args <- evalExprDeep env arg >>= collectionToList-  case func of-    Value (MemoizedFunc hashRef env names body) ->-      evalMemoizedFunc hashRef env names body args-    _ -> applyObj env func (map (WHNF . Value) args)- evalExprShallow env (IApplyExpr func args) = do   func <- appendDF 0 <$> evalExprShallow env func   case func of@@ -380,7 +464,7 @@         newApplyObjThunkRef env f args') t >>= fromTensor >>= removeDF     Value (MemoizedFunc hashRef env' names body) -> do       args <- mapM (evalExprDeep env) args-      evalMemoizedFunc hashRef env' names body args+      evalMemoizedFunc hashRef env' names body args >>= removeDF     _ -> do       let args' = map (newThunk env) args       applyObj env func args' >>= removeDF@@ -391,14 +475,14 @@   let args' = map WHNF (zipWith appendDF [1..] args)   case func of     Value (TensorData t@Tensor{}) ->-      tMap (\f -> newApplyObjThunkRef env (Value f) args') t >>= fromTensor+      tMap (\f -> newApplyObjThunkRef env (Value f) args') t >>= fromTensor >>= removeDF     ITensor t@Tensor{} ->       tMap (\f -> do         f <- evalRef f-        newApplyObjThunkRef env f args') t >>= fromTensor+        newApplyObjThunkRef env f args') t >>= fromTensor >>= removeDF     Value (MemoizedFunc hashRef env names body) -> do       args <- mapM evalWHNF args-      evalMemoizedFunc hashRef env names body args+      evalMemoizedFunc hashRef env names body args >>= removeDF     _ -> applyObj env func args' >>= removeDF  evalExprShallow env (IMatcherExpr info) = return $ Value $ UserMatcher env info@@ -410,8 +494,8 @@   return $ newITensor ns xs  where   evalWithIndex :: Env -> [ScalarData] {- index -} -> EvalM ObjectRef-  evalWithIndex env@(Env frame maybe_vwi) ms = do-    let env' = maybe env (\(name, indices) -> Env frame $ Just (name, zipWith changeIndex indices ms)) maybe_vwi+  evalWithIndex env@(Env frame maybe_vwi pfEnv) ms = do+    let env' = maybe env (\(name, indices) -> Env frame (Just (name, zipWith changeIndex indices ms)) pfEnv) maybe_vwi     fn <- evalExprShallow env' fnExpr     newApplyObjThunkRef env fn [WHNF (Value (Collection (Sq.fromList (map ScalarData ms))))]   changeIndex :: Index (Maybe a) -> a -> Index (Maybe a) -- Maybe we can refactor this function@@ -476,6 +560,34 @@         newApplyThunkRef env fn [x, y]) t2 >>= fromTensor     _ -> applyObj env fn [WHNF whnf1, WHNF whnf2] +evalExprShallow env (ITensorMap2WedgeExpr fnExpr t1Expr t2Expr) = do+  fn <- evalExprShallow env fnExpr+  whnf1 <- evalExprShallow env t1Expr+  whnf2 <- evalExprShallow env t2Expr+  -- Apply different indices to the whole tensors (like WedgeApply)+  let whnf1' = appendDF 1 whnf1+      whnf2' = appendDF 2 whnf2+  case (whnf1', whnf2') of+    -- both of arguments are tensors+    (ITensor t1, ITensor t2) ->+      tMap2 (\x y -> newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor >>= removeDF+    (ITensor t1, Value (TensorData t2)) -> do+      tMap2 (\x y -> do+        y <- newEvaluatedObjectRef (Value y)+        newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor >>= removeDF+    (Value (TensorData t1), ITensor t2) -> do+      tMap2 (\x y -> do+        x <- newEvaluatedObjectRef (Value x)+        newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor >>= removeDF+    (Value (TensorData t1), Value (TensorData t2)) ->+      tMap2 (\x y -> newApplyObjThunkRef env fn [WHNF (Value x), WHNF (Value y)]) t1 t2 >>= fromTensor >>= removeDF+    -- an argument is scalar - this shouldn't happen for tensorMap2Wedge+    _ -> throwErrorWithTrace (TypeMismatch "tensor" whnf1)++evalExprShallow env (IPatternFuncExpr paramNames body) =+  -- Create a PatternFunc value, capturing the current environment+  return $ Value (PatternFunc env paramNames body)+ evalExprShallow _ expr = throwErrorWithTrace (NotImplemented ("evalExprShallow for " ++ show expr))  evalExprDeep :: Env -> IExpr -> EvalM EgisonValue@@ -593,12 +705,52 @@   case args of     [Value World] -> m     arg : _       -> throwErrorWithTrace (TypeMismatch "world" arg)-applyRef _ (Value (ScalarData fn@(SingleTerm 1 [(Symbol{}, 1)]))) refs = do+applyRef _ (Value (ScalarData (SingleTerm 1 [(FunctionData sym args, 1)]))) refs = do+  newArgs <- mapM (\ref -> evalRef ref >>= evalWHNF) refs+  newScalars <- mapM (\arg -> case arg of+    ScalarData s -> return s+    _ -> throwErrorWithTrace (TypeMismatch "scalar" (Value arg))) newArgs+  when (length newScalars /= length args) $+    throwError (Default ("function applied to wrong number of arguments: expected "+      ++ show (length args) ++ ", got " ++ show (length newScalars)))+  return $ Value (ScalarData (SingleTerm 1 [(FunctionData sym newScalars, 1)]))+applyRef _ (Value (ScalarData fn@(SingleTerm 1 [(Symbol _ symName _, 1)]))) refs = do   args <- mapM (\ref -> evalRef ref >>= evalWHNF) refs   mExprs <- mapM (\arg -> case arg of                             ScalarData _ -> extractScalar arg-                            _            -> throwErrorWithTrace (EgisonBug "to use undefined functions, you have to use ScalarData args")) args-  return (Value (ScalarData (SingleTerm 1 [(Apply fn mExprs, 1)])))+                            _            -> throwErrorWithTrace (EgisonBug $ "to use undefined function '" ++ symName ++ "', you have to use ScalarData args")) args+  return (Value (ScalarData (SingleTerm 1 [(makeApplyExpr fn mExprs, 1)])))+-- QuoteFunction pattern: ('fact 3) should create Apply1 fact 3+-- The quoted function object is stored in QuoteFunction+applyRef env (Value (ScalarData fn@(SingleTerm 1 [(QuoteFunction funcWHNF, 1)]))) refs = do+  args <- mapM (\ref -> evalRef ref >>= evalWHNF) refs+  mExprs <- mapM (\arg -> case arg of+                            ScalarData scalar -> return scalar+                            _                 -> throwErrorWithTrace (EgisonBug $ "to use quoted function, you have to use ScalarData args")) args+  -- Create Apply1/Apply2/etc with the function object+  return (Value (ScalarData (SingleTerm 1 [(makeApplyExpr fn mExprs, 1)])))+-- Type class method dispatch: look up implementation based on first argument's type+-- Uses Type from Types.hs for dispatch (not String-based typeName)+applyRef env (Value (ClassMethodRef clsName methName)) refs = do+  case refs of+    [] -> return $ Value (ClassMethodRef clsName methName)  -- Partial application+    (firstRef:_) -> do+      -- Evaluate to WHNF and get Type directly (without full evaluation)+      firstArgWhnf <- evalRef firstRef+      let argType = whnfToType firstArgWhnf+      -- Look up implementation from instance environment using Type+      mImpl <- lookupInstance clsName methName argType+      case mImpl of+        Just implName -> do+          -- Look up the implementation function by name and apply+          case refVar env (stringToVar implName) of+            Just implRef -> do+              impl <- evalRef implRef+              applyRef env impl refs  -- Apply all arguments to the implementation+            Nothing -> throwError (Default +              ("Instance method not found: " ++ implName))+        Nothing -> throwError (Default +          ("No instance of " ++ clsName ++ " for type " ++ show argType)) applyRef _ whnf _ = throwErrorWithTrace (TypeMismatch "function" whnf)  applyObj :: Env -> WHNFData -> [Object] -> EvalM WHNFData@@ -650,9 +802,60 @@   forM_ bindings $ \(var, expr) -> do     let env'' = memorizeVarInEnv env' var     let ref = fromJust (refVar env' var)-    liftIO $ writeIORef ref (newThunk env'' expr)+    -- Set function name for top-level lambda definitions+    let expr' = case expr of+                  ILambdaExpr Nothing args body -> ILambdaExpr (Just var) args body+                  _ -> expr+    liftIO $ writeIORef ref (newThunk env'' expr')   return env' +-- | Bind pattern function definitions into the pattern function environment.+-- Analogous to 'recursiveBind' but uses the separate 'PatFuncEnv' so that+-- pattern functions never pollute the regular value environment.+-- Supports mutual recursion among pattern functions.+recursiveBindPatFuncs :: Env -> [(String, IExpr)] -> EvalM Env+recursiveBindPatFuncs env [] = return env+recursiveBindPatFuncs env bindings = do+  -- Create dummy refs so that mutually-recursive pattern functions can reference+  -- each other via the env that will be closed over by each PatternFunc value.+  refs <- mapM (\_ -> newThunkRef nullEnv (IConstantExpr UndefinedExpr)) bindings+  let namedRefs = zip (map fst bindings) refs+  let env' = extendPatFuncEnv env namedRefs+  -- Fill in each ref with the real thunk, closing over env' so that pattern+  -- functions can call each other.+  forM_ (zip (map snd bindings) refs) $ \(expr, ref) ->+    liftIO $ writeIORef ref (newThunk env' expr)+  return env'++-- | Bind regular value definitions and pattern function definitions together in+-- one step, so that all thunks are closed over a single environment that+-- contains both regular values (in the normal env layers) and pattern functions+-- (in the patFuncEnv).  This is necessary for mutual visibility: ordinary+-- definitions can invoke pattern functions (e.g. in matchAll expressions), and+-- pattern functions can invoke other pattern functions.+recursiveBindAll :: Env -> [(Var, IExpr)] -> [(String, IExpr)] -> EvalM Env+recursiveBindAll env valBindings patFuncBindings = do+  -- 1. Create dummy refs for regular value bindings.+  valBinds <- mapM (\(var, _) -> (var,) <$> newThunkRef nullEnv (IConstantExpr UndefinedExpr)) valBindings+  -- 2. Create dummy refs for pattern function bindings.+  pfRefs  <- mapM (\_ -> newThunkRef nullEnv (IConstantExpr UndefinedExpr)) patFuncBindings+  let pfNamedRefs = zip (map fst patFuncBindings) pfRefs+  -- 3. Build a combined env: regular layers + patFuncEnv, both containing dummies.+  let envWithVal  = extendEnv env valBinds+  let envFinal    = extendPatFuncEnv envWithVal pfNamedRefs+  -- 4. Fill in regular value thunks, closing over envFinal.+  forM_ valBindings $ \(var, expr) -> do+    let envForVar = memorizeVarInEnv envFinal var+    let ref = fromJust (refVar envFinal var)+    let expr' = case expr of+                  ILambdaExpr Nothing args body -> ILambdaExpr (Just var) args body+                  _ -> expr+    liftIO $ writeIORef ref (newThunk envForVar expr')+  -- 5. Fill in pattern function thunks, closing over envFinal.+  forM_ (zip (map snd patFuncBindings) pfRefs) $ \(expr, ref) ->+    liftIO $ writeIORef ref (newThunk envFinal expr)+  return envFinal+ recursiveMatchBind :: Env -> [IBindingExpr] -> EvalM Env recursiveMatchBind env bindings = do   -- List of variables defined in |bindings|@@ -676,8 +879,8 @@   return env'  memorizeVarInEnv :: Env -> Var -> Env-memorizeVarInEnv (Env frame _) (Var var is) =-  Env frame (Just (var, map (fmap (\_ -> Nothing)) is))+memorizeVarInEnv (Env frame _ pfEnv) (Var var is) =+  Env frame (Just (var, map (fmap (\_ -> Nothing)) is)) pfEnv  -- -- Pattern Match@@ -811,15 +1014,12 @@   let env' = extendEnvForNonLinearPatterns env bindings loops in   case pattern of     IInductiveOrPApplyPat name args ->-      case refVar env (stringToVar name) of+      -- Check the pattern function environment first (separate from the value env).+      -- If found there it must be a PatternFunc; otherwise treat as an inductive+      -- pattern constructor.+      case refPatFunc env name of+        Just _  -> processMState' (mstate { mTrees = MAtom (IPApplyPat (IVarExpr name) args) target matcher:trees })         Nothing -> processMState' (mstate { mTrees = MAtom (IInductivePat name args) target matcher:trees })-        Just ref -> do-          whnf <- evalRef ref-          case whnf of-            Value PatternFunc{} ->-              processMState' (mstate { mTrees = MAtom (IPApplyPat (IVarExpr name) args) target matcher:trees })-            _                   ->-              processMState' (mstate { mTrees = MAtom (IInductivePat name args) target matcher:trees })      INotPat _ -> throwErrorWithTrace (EgisonBug "should not reach here (not-pattern)")     IVarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ show pattern@@ -839,7 +1039,14 @@                 else return MNil      IPApplyPat func args -> do-      func' <- evalExprShallow env' func+      -- For a plain variable, look up the pattern function environment first so+      -- that pattern functions and ordinary values live in separate namespaces.+      func' <- case func of+        IVarExpr name ->+          case refPatFunc env' name of+            Just ref -> evalRef ref+            Nothing  -> evalExprShallow env' func+        _ -> evalExprShallow env' func       case func' of         Value (PatternFunc env'' names expr) ->           return . msingleton $ mstate { mTrees = MNode penv (MState env'' [] [] [] [MAtom expr target matcher]) : trees }@@ -1016,6 +1223,26 @@     Nothing      -> throwErrorWithTrace PrimitiveMatchFailure     Just binding -> return binding +-- Helper functions to convert internal math types to ScalarData (MathExpr)+polyExprToScalarData :: PolyExpr -> ScalarData+polyExprToScalarData polyExpr = Div polyExpr (Plus [Term 1 []])++termExprToScalarData :: TermExpr -> ScalarData+termExprToScalarData termExpr = Div (Plus [termExpr]) (Plus [Term 1 []])++symbolExprToScalarData :: SymbolExpr -> ScalarData+symbolExprToScalarData symbolExpr = Div (Plus [Term 1 [(symbolExpr, 1)]]) (Plus [Term 1 []])++-- Check if pattern is a pattern variable+isPatternVar :: IPrimitiveDataPattern -> Bool+isPatternVar (PDPatVar _) = True+isPatternVar _            = False++-- Helper: Extract function object from ScalarData if it contains QuoteFunction+extractFunctionObject :: ScalarData -> WHNFData+extractFunctionObject (SingleTerm 1 [(QuoteFunction funcWHNF, 1)]) = funcWHNF+extractFunctionObject scalarData = Value (ScalarData scalarData)+ primitiveDataPatternMatch :: IPrimitiveDataPattern -> ObjectRef -> MatchM [Binding] primitiveDataPatternMatch PDWildCard _        = return [] primitiveDataPatternMatch (PDPatVar name) ref = return [(name, ref)]@@ -1056,6 +1283,144 @@   case whnf of     Value val | val == evalConstant expr -> return []     _                                    -> matchFail+-- ScalarData (MathExpr) primitive patterns+primitiveDataPatternMatch (PDDivPat patNum patDen) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (ScalarData (Div num den)) -> do+      -- Pattern variable の場合は PolyExpr -> ScalarData に変換+      let numVal = if isPatternVar patNum +                   then Value (ScalarData (polyExprToScalarData num))+                   else Value (PolyExprData num)+      let denVal = if isPatternVar patDen+                   then Value (ScalarData (polyExprToScalarData den))+                   else Value (PolyExprData den)+      numRef <- lift $ newEvaluatedObjectRef numVal+      denRef <- lift $ newEvaluatedObjectRef denVal+      (++) <$> primitiveDataPatternMatch patNum numRef+           <*> primitiveDataPatternMatch patDen denRef+    _ -> matchFail+primitiveDataPatternMatch (PDPlusPat patTerms) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (PolyExprData (Plus terms)) -> do+      -- Pattern variable の場合は [TermExpr] -> [ScalarData] に変換+      let termsCol = if isPatternVar patTerms+                     then Value $ Collection $ Sq.fromList $ map (ScalarData . termExprToScalarData) terms+                     else Value $ Collection $ Sq.fromList $ map TermExprData terms+      termsRef <- lift $ newEvaluatedObjectRef termsCol+      primitiveDataPatternMatch patTerms termsRef+    _ -> matchFail+primitiveDataPatternMatch (PDTermPat patCoeff patMonomials) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (TermExprData (Term coeff monomials)) -> do+      coeffRef <- lift $ newEvaluatedObjectRef (Value (toEgison coeff))+      -- Pattern variable の場合は [(SymbolExpr, Integer)] -> [(ScalarData, Integer)] に変換+      let monomialsCol = if isPatternVar patMonomials+                         then Value $ Collection $ Sq.fromList $ map (\(sym, exp) -> Tuple [ScalarData (symbolExprToScalarData sym), toEgison exp]) monomials+                         else Value $ Collection $ Sq.fromList $ map (\(sym, exp) -> Tuple [SymbolExprData sym, toEgison exp]) monomials+      monomialsRef <- lift $ newEvaluatedObjectRef monomialsCol+      (++) <$> primitiveDataPatternMatch patCoeff coeffRef+           <*> primitiveDataPatternMatch patMonomials monomialsRef+    _ -> matchFail+primitiveDataPatternMatch (PDSymbolPat patName patIndices) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (SymbolExprData (Symbol _ name indices)) -> do+      nameRef <- lift $ newEvaluatedObjectRef (Value (String (T.pack name)))+      -- [Index ScalarData]をCollectionに変換+      let indicesCol = Value $ Collection $ Sq.fromList $ map IndexExprData indices+      indicesRef <- lift $ newEvaluatedObjectRef indicesCol+      (++) <$> primitiveDataPatternMatch patName nameRef+           <*> primitiveDataPatternMatch patIndices indicesRef+    _ -> matchFail+primitiveDataPatternMatch (PDApply1Pat patFn patArg) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (SymbolExprData (Apply1 fn arg)) -> do+      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)+      argRef <- lift $ newEvaluatedObjectRef (Value (ScalarData arg))+      (++) <$> primitiveDataPatternMatch patFn fnRef+           <*> primitiveDataPatternMatch patArg argRef+    _ -> matchFail+primitiveDataPatternMatch (PDApply2Pat patFn patArg1 patArg2) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (SymbolExprData (Apply2 fn arg1 arg2)) -> do+      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)+      arg1Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg1))+      arg2Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg2))+      (++) <$> primitiveDataPatternMatch patFn fnRef+           <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref+                     <*> primitiveDataPatternMatch patArg2 arg2Ref)+    _ -> matchFail+primitiveDataPatternMatch (PDApply3Pat patFn patArg1 patArg2 patArg3) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (SymbolExprData (Apply3 fn arg1 arg2 arg3)) -> do+      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)+      arg1Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg1))+      arg2Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg2))+      arg3Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg3))+      (++) <$> primitiveDataPatternMatch patFn fnRef+           <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref+                     <*> ((++) <$> primitiveDataPatternMatch patArg2 arg2Ref+                               <*> primitiveDataPatternMatch patArg3 arg3Ref))+    _ -> matchFail+primitiveDataPatternMatch (PDApply4Pat patFn patArg1 patArg2 patArg3 patArg4) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (SymbolExprData (Apply4 fn arg1 arg2 arg3 arg4)) -> do+      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)+      arg1Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg1))+      arg2Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg2))+      arg3Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg3))+      arg4Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg4))+      (++) <$> primitiveDataPatternMatch patFn fnRef+           <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref+                     <*> ((++) <$> primitiveDataPatternMatch patArg2 arg2Ref+                               <*> ((++) <$> primitiveDataPatternMatch patArg3 arg3Ref+                                         <*> primitiveDataPatternMatch patArg4 arg4Ref)))+    _ -> matchFail+primitiveDataPatternMatch (PDQuotePat patExpr) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (SymbolExprData (Quote expr)) -> do+      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))+      primitiveDataPatternMatch patExpr exprRef+    _ -> matchFail+primitiveDataPatternMatch (PDFunctionPat patName patArgs) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (SymbolExprData (FunctionData name args)) -> do+      nameRef <- lift $ newEvaluatedObjectRef (Value (ScalarData name))+      let argsCol = Value $ Collection $ Sq.fromList $ map ScalarData args+      argsRef <- lift $ newEvaluatedObjectRef argsCol+      (++) <$> primitiveDataPatternMatch patName nameRef+           <*> primitiveDataPatternMatch patArgs argsRef+    _ -> matchFail+primitiveDataPatternMatch (PDSubPat patExpr) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (IndexExprData (Sub expr)) -> do+      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))+      primitiveDataPatternMatch patExpr exprRef+    _ -> matchFail+primitiveDataPatternMatch (PDSupPat patExpr) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (IndexExprData (Sup expr)) -> do+      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))+      primitiveDataPatternMatch patExpr exprRef+    _ -> matchFail+primitiveDataPatternMatch (PDUserPat patExpr) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Value (IndexExprData (User expr)) -> do+      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))+      primitiveDataPatternMatch patExpr exprRef+    _ -> matchFail  extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopPatContext] -> Env extendEnvForNonLinearPatterns env bindings loops = extendEnv env $ bindings ++ map (\(LoopPatContext (name, ref) _ _ _ _) -> (stringToVar name, ref)) loops@@ -1097,7 +1462,7 @@   where     makeBinding :: Var -> ObjectRef -> EvalM [Binding]     makeBinding v@(Var _ [])    ref = return [(v, ref)]-    makeBinding v@(Var name is) ref = do+    makeBinding v@(Var _name is) ref = do       val <- evalRefDeep ref       case val of         TensorData (Tensor _ _ js) -> do

@@ -33,12 +33,18 @@     , ObjectRef     , WHNFData (..)     , Inner (..)+    , prettyFunctionName     -- * Environment     , Env (..)+    , EnvLayer+    , PatFuncEnv     , Binding     , nullEnv     , extendEnv+    , extendPatFuncEnv     , refVar+    , refPatFunc+    , envToBindingList     -- * Errors     , EgisonError (..)     , throwErrorWithTrace@@ -46,6 +52,7 @@     , EvalM     , fromEvalM     , fromEvalT+    , fromEvalTWithState     ) where  import           Control.Exception@@ -58,13 +65,17 @@ import           Data.Foldable                    (msum, toList) import           Data.HashMap.Strict              (HashMap) import qualified Data.HashMap.Strict              as HashMap+import           Data.Map.Strict                  (Map)+import qualified Data.Map.Strict                  as Map import           Data.IORef++import           Language.Egison.VarEntry         (VarEntry(..)) import           Data.Sequence                    (Seq) import qualified Data.Sequence                    as Sq import qualified Data.Vector                      as V -import           Data.List                        (intercalate)-import           Data.Text                        (Text)+import           Data.List                        (intercalate, sortOn)+import           Data.Text                        (Text, pack, unpack) import           Text.Show.Unicode                (ushow)  import           Data.Ratio@@ -106,6 +117,15 @@   | RefBox (IORef EgisonValue)   | Something   | Undefined+  -- | Type class method reference: dispatches based on argument type at runtime+  -- ClassMethodRef className methodName+  -- Looks up implementation from the instance environment in EvalState+  | ClassMethodRef String String+  -- MathExpr internal types for direct pattern matching+  | PolyExprData PolyExpr+  | TermExprData TermExpr+  | SymbolExprData SymbolExpr+  | IndexExprData (Index ScalarData)  type Matcher = EgisonValue @@ -157,16 +177,25 @@ symbolExprToEgison (Symbol id x js, n) = Tuple [InductiveData "Symbol" [symbolScalarData id x, f js], toEgison n]  where   f js = Collection (Sq.fromList (map scalarIndexToEgison js))-symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [ScalarData fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n]+symbolExprToEgison (Apply1 fn a1, n) = Tuple [InductiveData "Apply1" [ScalarData fn, ScalarData a1], toEgison n]+symbolExprToEgison (Apply2 fn a1 a2, n) = Tuple [InductiveData "Apply2" [ScalarData fn, ScalarData a1, ScalarData a2], toEgison n]+symbolExprToEgison (Apply3 fn a1 a2 a3, n) = Tuple [InductiveData "Apply3" [ScalarData fn, ScalarData a1, ScalarData a2, ScalarData a3], toEgison n]+symbolExprToEgison (Apply4 fn a1 a2 a3 a4, n) = Tuple [InductiveData "Apply4" [ScalarData fn, ScalarData a1, ScalarData a2, ScalarData a3, ScalarData a4], toEgison n] symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n]-symbolExprToEgison (FunctionData name argnames args, n) =-  Tuple [InductiveData "Function" [ScalarData name, Collection (Sq.fromList (map ScalarData argnames)), Collection (Sq.fromList (map ScalarData args))], toEgison n]+symbolExprToEgison (QuoteFunction (Value funcVal), n) = Tuple [InductiveData "QuoteFunction" [funcVal], toEgison n]+symbolExprToEgison (QuoteFunction whnf, n) = error $ "symbolExprToEgison: QuoteFunction with non-Value WHNF: " ++ show whnf+symbolExprToEgison (FunctionData name args, n) =+  Tuple [InductiveData "Function" [ScalarData name, Collection (Sq.fromList (map ScalarData args))], toEgison n]  scalarIndexToEgison :: Index ScalarData -> EgisonValue scalarIndexToEgison (Sup k)  = InductiveData "Sup"  [ScalarData k] scalarIndexToEgison (Sub k)  = InductiveData "Sub"  [ScalarData k] scalarIndexToEgison (User k) = InductiveData "User" [ScalarData k] +-- Direct index conversion for primitive pattern matching+indexToEgison :: Index ScalarData -> EgisonValue+indexToEgison = IndexExprData+ -- Implementation of 'toMathExpr' (Primitive function) egisonToScalarData :: EgisonValue -> EvalM ScalarData egisonToScalarData (InductiveData "Div" [p1, p2]) = Div <$> egisonToPolyExpr p1 <*> egisonToPolyExpr p2@@ -177,15 +206,28 @@ egisonToScalarData s1@(InductiveData "Symbol" _) = do   s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 ::Integer)])   return $ SingleTerm 1 [s1']-egisonToScalarData s1@(InductiveData "Apply" _) = do+egisonToScalarData s1@(InductiveData "Apply1" _) = do   s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])   return $ SingleTerm 1 [s1']+egisonToScalarData s1@(InductiveData "Apply2" _) = do+  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])+  return $ SingleTerm 1 [s1']+egisonToScalarData s1@(InductiveData "Apply3" _) = do+  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])+  return $ SingleTerm 1 [s1']+egisonToScalarData s1@(InductiveData "Apply4" _) = do+  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])+  return $ SingleTerm 1 [s1'] egisonToScalarData s1@(InductiveData "Quote" _) = do   s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])   return $ SingleTerm 1 [s1']+egisonToScalarData s1@(InductiveData "QuoteFunction" _) = do+  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])+  return $ SingleTerm 1 [s1'] egisonToScalarData s1@(InductiveData "Function" _) = do   s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])   return $ SingleTerm 1 [s1']+egisonToScalarData (ScalarData s) = return s egisonToScalarData val = throwErrorWithTrace (TypeMismatch "math expression" (Value val))  egisonToPolyExpr :: EgisonValue -> EvalM PolyExpr@@ -204,21 +246,44 @@   case x of     (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []]))) ->       return (Symbol id name js', n')-egisonToSymbolExpr (Tuple [InductiveData "Apply" [fn, Collection mExprs], n]) = do+egisonToSymbolExpr (Tuple [InductiveData "Apply1" [fn, a1], n]) = do   fn' <- extractScalar fn-  mExprs' <- mapM egisonToScalarData (toList mExprs)+  a1' <- egisonToScalarData a1   n' <- fromEgison n-  return (Apply fn' mExprs', n')+  return (Apply1 fn' a1', n')+egisonToSymbolExpr (Tuple [InductiveData "Apply2" [fn, a1, a2], n]) = do+  fn' <- extractScalar fn+  a1' <- egisonToScalarData a1+  a2' <- egisonToScalarData a2+  n' <- fromEgison n+  return (Apply2 fn' a1' a2', n')+egisonToSymbolExpr (Tuple [InductiveData "Apply3" [fn, a1, a2, a3], n]) = do+  fn' <- extractScalar fn+  a1' <- egisonToScalarData a1+  a2' <- egisonToScalarData a2+  a3' <- egisonToScalarData a3+  n' <- fromEgison n+  return (Apply3 fn' a1' a2' a3', n')+egisonToSymbolExpr (Tuple [InductiveData "Apply4" [fn, a1, a2, a3, a4], n]) = do+  fn' <- extractScalar fn+  a1' <- egisonToScalarData a1+  a2' <- egisonToScalarData a2+  a3' <- egisonToScalarData a3+  a4' <- egisonToScalarData a4+  n' <- fromEgison n+  return (Apply4 fn' a1' a2' a3' a4', n') egisonToSymbolExpr (Tuple [InductiveData "Quote" [mExpr], n]) = do   mExpr' <- egisonToScalarData mExpr   n' <- fromEgison n   return (Quote mExpr', n')-egisonToSymbolExpr (Tuple [InductiveData "Function" [name, Collection argnames, Collection args], n]) = do+egisonToSymbolExpr (Tuple [InductiveData "QuoteFunction" [funcVal], n]) = do+  n' <- fromEgison n+  return (QuoteFunction (Value funcVal), n')+egisonToSymbolExpr (Tuple [InductiveData "Function" [name, Collection args], n]) = do   name' <- extractScalar name-  argnames' <- mapM extractScalar (toList argnames)   args' <- mapM extractScalar (toList args)   n' <- fromEgison n-  return (FunctionData name' argnames' args', n')+  return (FunctionData name' args', n') egisonToSymbolExpr val = throwErrorWithTrace (TypeMismatch "math symbol expression" (Value val))  egisonToScalarIndex :: EgisonValue -> EvalM (Index ScalarData)@@ -236,6 +301,10 @@ extractScalar (ScalarData mExpr) = return mExpr extractScalar val                = throwErrorWithTrace (TypeMismatch "math expression" (Value val)) +extractString :: EgisonValue -> EvalM String+extractString (String t) = return (unpack t)+extractString val        = throwErrorWithTrace (TypeMismatch "string" (Value val))+ -- New-syntax version of EgisonValue pretty printer. -- TODO(momohatt): Don't make it a show instance of EgisonValue. instance Show EgisonValue where@@ -262,7 +331,9 @@   show (CharHash hash) = "{|" ++ intercalate ", " (map (\(key, val) -> "[" ++ show key ++ ", " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   show (StrHash hash)  = "{|" ++ intercalate ", " (map (\(key, val) -> "[" ++ show key ++ ", " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   show UserMatcher{} = "#<user-matcher>"-  show (Func _ _ args _) = "#<lambda [" ++ intercalate ", " (map show args) ++ "] ...>"+  show (Func maybeName _ args _) = case maybeName of+    Just name -> "#<lambda " ++ show name ++ " [" ++ intercalate ", " (map show args) ++ "] ...>"+    Nothing -> "#<lambda [" ++ intercalate ", " (map show args) ++ "] ...>"   show (CFunc _ name _) = "#<cambda " ++ name ++ " ...>"   show (MemoizedFunc _ _ names _) = "#<memoized-lambda [" ++ intercalate ", " names ++ "] ...>"   show PatternFunc{} = "#<pattern-function>"@@ -274,12 +345,22 @@   show Something = "something"   show Undefined = "undefined"   show World = "#<world>"+  show (ClassMethodRef clsName methName) = "#<class-method " ++ clsName ++ "." ++ methName ++ ">"+  -- MathExpr internal types+  show (PolyExprData polyExpr) = show polyExpr+  show (TermExprData termExpr) = show termExpr+  show (SymbolExprData symbolExpr) = show symbolExpr+  show (IndexExprData indexExpr) = show indexExpr  -- False if we have to put parenthesis around it to make it an atomic expression. isAtomic :: EgisonValue -> Bool isAtomic (InductiveData _ []) = True isAtomic (InductiveData _ _)  = False isAtomic (ScalarData m)       = isAtom m+isAtomic (PolyExprData _)     = False+isAtomic (TermExprData _)     = False+isAtomic (SymbolExprData _)   = False+isAtomic (IndexExprData _)    = False isAtomic _                    = True  instance Eq EgisonValue where@@ -295,6 +376,11 @@   (IntHash vals) == (IntHash vals')                                = vals == vals'   (CharHash vals) == (CharHash vals')                              = vals == vals'   (StrHash vals) == (StrHash vals')                                = vals == vals'+  -- MathExpr internal types+  (PolyExprData p) == (PolyExprData p')                            = p == p'+  (TermExprData t) == (TermExprData t')                            = t == t'+  (SymbolExprData s) == (SymbolExprData s')                        = s == s'+  (IndexExprData i) == (IndexExprData i')                          = i == i'   -- Temporary: searching a better solution   (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _)           = name1 == name2   _ == _                                                           = False@@ -408,6 +494,12 @@   = IElement ObjectRef   | ISubCollection ObjectRef +-- Helper to extract function name from WHNFData for pretty printing+-- Returns Nothing for anonymous functions+prettyFunctionName :: WHNFData -> Maybe String+prettyFunctionName (Value (Func (Just (Var name _)) _ _ _)) = Just name+prettyFunctionName _ = Nothing+ instance Show WHNFData where   show (Value val)                = show val   show (IInductiveData name _)    = "<" ++ name ++ " ...>"@@ -430,8 +522,19 @@ -- Environment -- -data Env = Env [HashMap Var ObjectRef] (Maybe (String, [Index (Maybe ScalarData)]))+-- | Environment layer: maps base variable names to all bindings with that name+-- VarEntry list is sorted by index length (shortest first) for efficient prefix matching+type EnvLayer = Map String [VarEntry ObjectRef] +-- | Pattern function environment: maps pattern function names to their ObjectRefs.+-- Kept separate from the regular value environment so that pattern typing is+-- independent of which matcher is in scope (matcher polymorphism).+type PatFuncEnv = Map String ObjectRef++-- | Environment: list of layers (for scoping) plus optional index context,+-- plus a separate store for pattern functions.+data Env = Env [EnvLayer] (Maybe (String, [Index (Maybe ScalarData)])) PatFuncEnv+ type Binding = (Var, ObjectRef)  instance {-# OVERLAPPING #-} Show (Index EgisonValue) where@@ -445,21 +548,128 @@   show (User i) = case i of     ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]"     _                                                 -> "|" ++ show i-  show (DF i j) = "_d" ++ show i ++ show j+  show (DF i j) = "_df-" ++ show i ++ "-" ++ show j  nullEnv :: Env-nullEnv = Env [] Nothing+nullEnv = Env [] Nothing Map.empty +-- | Extend environment with new bindings+-- Groups bindings by base name and sorts by index length (shortest first) extendEnv :: Env -> [Binding] -> Env-extendEnv (Env env idx) bdg = Env (HashMap.fromList bdg : env) idx+extendEnv (Env layers idx pfEnv) bindings = Env (newLayer : layers) idx pfEnv+  where+    -- Group bindings by base variable name+    grouped :: Map String [VarEntry ObjectRef]+    grouped = foldr insertBinding Map.empty bindings+    +    insertBinding :: Binding -> Map String [VarEntry ObjectRef] -> Map String [VarEntry ObjectRef]+    insertBinding (Var name indices, ref) acc =+      let entry = VarEntry indices ref+      in Map.insertWith combineEntries name [entry] acc+    +    -- Combine and sort entries by index length (shortest first)+    combineEntries :: [VarEntry ObjectRef] -> [VarEntry ObjectRef] -> [VarEntry ObjectRef]+    combineEntries new old = +      sortByIndexLength (new ++ old)+    +    -- Sort VarEntry list by index length (ascending)+    sortByIndexLength :: [VarEntry ObjectRef] -> [VarEntry ObjectRef]+    sortByIndexLength = Data.List.sortOn (length . veIndices)+    +    newLayer = grouped +-- | Extend the pattern function environment with new name→ref bindings.+-- The regular value layers and index context are preserved unchanged.+extendPatFuncEnv :: Env -> [(String, ObjectRef)] -> Env+extendPatFuncEnv (Env layers idx pfEnv) newBindings =+  Env layers idx (foldr (\(name, ref) acc -> Map.insert name ref acc) pfEnv newBindings)++-- | Look up a variable in the environment+-- Search algorithm:+--   1. Try exact match+--   2. Try prefix match (find longer indices and auto-complete with #)+--   3. Try suffix removal (find shorter indices, pick longest match)+-- No recursion is used; all matching is done in a single pass to avoid infinite loops. refVar :: Env -> Var -> Maybe ObjectRef-refVar (Env env _) var@(Var _ []) = msum $ map (HashMap.lookup var) env-refVar e@(Env env _) var@(Var name is) =-  case msum $ map (HashMap.lookup var) env of-    Nothing -> refVar e (Var name (init is))-    Just x  -> Just x+refVar (Env layers _ _) (Var name targetIndices) =+  -- Search through all layers+  msum $ map searchInLayer layers+  where+    searchInLayer :: EnvLayer -> Maybe ObjectRef+    searchInLayer layer =+      case Map.lookup name layer of+        Nothing -> Nothing+        Just entries ->+          -- 1. Try exact match first+          case findExactMatch targetIndices entries of+            Just ref -> Just ref+            Nothing ->+              -- 2. Try prefix matching (e_a matches e_i_j with wildcards)+              case findPrefixMatch targetIndices entries of+                Just ref -> Just ref+                Nothing ->+                  -- 3. Try suffix removal (e_i_j_k matches e_i_j, pick longest)+                  findSuffixMatch targetIndices entries+    +    -- Exact match: same length and same indices+    findExactMatch :: [Index (Maybe Var)] -> [VarEntry ObjectRef] -> Maybe ObjectRef+    findExactMatch indices entries =+      case [veValue e | e <- entries, veIndices e == indices] of+        (ref:_) -> Just ref+        [] -> Nothing+    +    -- Prefix matching: find shortest entry where target indices are a prefix+    -- Example: target [a] matches [i, j] in e_i_j (shortest match)+    findPrefixMatch :: [Index (Maybe Var)] -> [VarEntry ObjectRef] -> Maybe ObjectRef+    findPrefixMatch indices entries =+      -- entries are sorted by index length (ascending), so first match is shortest+      case [veValue e | e <- entries, isPrefixOfIndices indices (veIndices e)] of+        (ref:_) -> Just ref+        [] -> Nothing+    +    -- Suffix removal: find longest entry where stored indices are a prefix of target+    -- Example: target [i,j,k] matches e_i_j (stored [i,j]); prefer e_i_j over e_i+    -- Single pass, no recursion - safe from infinite loops+    findSuffixMatch :: [Index (Maybe Var)] -> [VarEntry ObjectRef] -> Maybe ObjectRef+    findSuffixMatch targetIndices entries =+      let suffixMatches = [e | e <- entries, storedIsPrefixOfTarget (veIndices e) targetIndices]+      in case sortByIndexLengthDesc suffixMatches of+        (e:_) -> Just (veValue e)+        [] -> Nothing+    +    -- stored is prefix of target: stored has fewer indices, first part of target matches+    storedIsPrefixOfTarget :: [Index (Maybe Var)] -> [Index (Maybe Var)] -> Bool+    storedIsPrefixOfTarget stored target =+      not (null target) &&+      length stored < length target &&+      stored == take (length stored) target+    +    sortByIndexLengthDesc :: [VarEntry ObjectRef] -> [VarEntry ObjectRef]+    sortByIndexLengthDesc = reverse . Data.List.sortOn (length . veIndices)+    +    -- Check if target is a prefix of candidate (for prefix matching)+    -- Example: [a] is prefix of [i, j]+    -- IMPORTANT: target must be non-empty to avoid matching everything+    isPrefixOfIndices :: [Index (Maybe Var)] -> [Index (Maybe Var)] -> Bool+    isPrefixOfIndices target candidate =+      not (null target) &&+      length target < length candidate &&+      target == take (length target) candidate +-- | Look up a pattern function by name in the pattern function environment.+refPatFunc :: Env -> String -> Maybe ObjectRef+refPatFunc (Env _ _ pfEnv) name = Map.lookup name pfEnv++-- | Convert environment to list of bindings+-- Used for completion and debugging+envToBindingList :: Env -> [Binding]+envToBindingList (Env layers _ _) =+  [ (Var name (veIndices entry), veValue entry)+  | layer <- layers+  , (name, entries) <- Map.toList layer+  , entry <- entries+  ]+ -- -- Errors --@@ -472,7 +682,7 @@   | ArgumentsNumPrimitive String Int Int CallStack   | TupleLength Int Int CallStack   | InconsistentTensorShape CallStack-  | InconsistentTensorIndex CallStack+  | InconsistentTensorIndex [String] [String] CallStack   | TensorIndexOutOfBounds Integer Integer CallStack   | NotImplemented String CallStack   | Assertion String CallStack@@ -492,7 +702,11 @@   show (TupleLength expected got stack) =     "Inconsistent tuple lengths: expected " ++ show expected ++ ", but got " ++  show got ++ showTrace stack   show (InconsistentTensorShape stack) = "Inconsistent tensor shape" ++ showTrace stack-  show (InconsistentTensorIndex stack) = "Inconsistent tensor index" ++ showTrace stack+  show (InconsistentTensorIndex expected actual stack) =+    "Inconsistent tensor index:\n" +++    "  Expected pattern: [" ++ intercalate ", " expected ++ "]\n" +++    "  Actual indices:   [" ++ intercalate ", " actual ++ "]" +++    showTrace stack   show (TensorIndexOutOfBounds m n stack) = "Tensor index out of bounds: " ++ show m ++ ", " ++ show n ++ showTrace stack   show (NotImplemented message stack) = "Not implemented: " ++ message ++ showTrace stack   show (Assertion message stack) = "Assertion failed: " ++ message ++ showTrace stack@@ -523,6 +737,14 @@  fromEvalT :: EvalM a -> RuntimeM (Either EgisonError a) fromEvalT m = runExceptT (evalStateT m initialEvalState)++-- | Run EvalM with a given EvalState (for REPL to preserve state between evaluations)+fromEvalTWithState :: EvalState -> EvalM a -> RuntimeM (Either EgisonError (a, EvalState))+fromEvalTWithState state m = do+  result <- runExceptT (runStateT m state)+  case result of+    Left err -> return $ Left err+    Right (val, state') -> return $ Right (val, state')  fromEvalM :: EgisonOpts -> EvalM a -> IO (Either EgisonError a) fromEvalM opts = evalRuntimeT opts . fromEvalT

@@ -0,0 +1,5 @@+module Language.Egison.Data where++data WHNFData++prettyFunctionName :: WHNFData -> Maybe String

@@ -74,6 +74,35 @@ makeITuple [x] = return x makeITuple xs  = ITuple <$> mapM newEvaluatedObjectRef xs +-- | Convert Index patterns to human-readable strings for error messages+showIndexPattern :: [Index (Maybe Var)] -> [String]+showIndexPattern = map showIndex+  where+    showIndex (Sub (Just (Var name []))) = "_" ++ name+    showIndex (Sub Nothing) = "_?"+    showIndex (Sup (Just (Var name []))) = "~" ++ name+    showIndex (Sup Nothing) = "~?"+    showIndex (MultiSub (Just (Var a [])) s (Just (Var e []))) = "_(" ++ a ++ "_" ++ show s ++ ")..._(" ++ a ++ "_" ++ e ++ ")"+    showIndex (MultiSup (Just (Var a [])) s (Just (Var e []))) = "~(" ++ a ++ "~" ++ show s ++ ")...~(" ++ a ++ "~" ++ e ++ ")"+    showIndex (SupSub (Just (Var name []))) = "~_" ++ name+    showIndex (SupSub Nothing) = "~_?"+    showIndex (User (Just (Var name []))) = "@" ++ name+    showIndex (User Nothing) = "@?"+    showIndex (DF id n) = "_df-" ++ show id ++ "-" ++ show n+    showIndex _ = "?"++-- | Convert actual Index values to human-readable strings for error messages+showIndexValues :: [Index EgisonValue] -> [String]+showIndexValues = map showIndexValue+  where+    showIndexValue (Sub val) = "_<val>"+    showIndexValue (Sup val) = "~<val>"+    showIndexValue (SupSub val) = "~_<val>"+    showIndexValue (User val) = "@<val>"+    showIndexValue (DF id n) = "_df-" ++ show id ++ "-" ++ show n+    showIndexValue (MultiSub val s _) = "_(..." ++ show s ++ "...)"+    showIndexValue (MultiSup val s _) = "~(..." ++ show s ++ "...)"+ pmIndices :: [Index (Maybe Var)] -> [Index EgisonValue] -> EvalM [Binding] pmIndices [] [] = return [] pmIndices (MultiSub (Just a) s (Just e):xs) vs = do@@ -105,7 +134,7 @@   bs <- pmIndex x v   bs' <- pmIndices xs vs   return (bs ++ bs')-pmIndices _ _ = throwErrorWithTrace InconsistentTensorIndex+pmIndices expected actual = throwErrorWithTrace $ InconsistentTensorIndex (showIndexPattern expected) (showIndexValues actual)  pmIndex :: Index (Maybe Var) -> Index EgisonValue -> EvalM [Binding] pmIndex (Sub (Just var)) (Sub val) = do@@ -114,7 +143,7 @@ pmIndex (Sup (Just var)) (Sup val) = do   ref <- newEvaluatedObjectRef (Value val)   return [(var, ref)]-pmIndex _ _ = throwErrorWithTrace InconsistentTensorIndex+pmIndex expected actual = throwErrorWithTrace $ InconsistentTensorIndex (showIndexPattern [expected]) (showIndexValues [actual])  updateHash :: [Integer] -> WHNFData -> WHNFData -> EvalM WHNFData updateHash [index] tgt (IIntHash hash) = do

@@ -4,36 +4,233 @@ Module      : Language.Egison.Desugar Licence     : MIT -This module provides desugar functions.+This module implements Phase 3-4: Syntactic Desugaring (for untyped path).+For the typed path, desugaring is done inside type inference.++Syntactic Desugaring (Phase 3-4):+  - Operator desugaring (infix to function application)+  - Anonymous function expansion (cambda: 1#($1 + $2) etc.)+  - Match-lambda expansion (convert to match expressions)+  - Other syntactic sugar expansions+  +Design Note (design/implementation.md):+Pattern matching itself is NOT desugared here. Match expressions (IMatchExpr, +IMatchAllExpr) are kept as-is and processed during evaluation (Phase 10).+This allows Egison's sophisticated pattern matching to be implemented in the evaluator. -}  module Language.Egison.Desugar     ( desugarTopExpr     , desugarTopExprs     , desugarExpr+    , transVarIndex     ) where  import           Control.Monad.Except   (throwError) import           Data.Char              (toUpper) import           Data.Foldable          (foldrM) import           Data.List              (union)+import           Data.Text              (pack)  import           Language.Egison.AST import           Language.Egison.Data import           Language.Egison.IExpr import           Language.Egison.RState+import           Language.Egison.Type.Types (sanitizeMethodName, typeToName, typeConstructorName, +                                             typeExprToType, capitalizeFirst, lowerFirst, TyVar(..))   desugarTopExpr :: TopExpr -> EvalM (Maybe ITopExpr) desugarTopExpr (Define vwi expr) = do   (var, iexpr) <- desugarDefineWithIndices vwi expr   return . Just $ IDefine var iexpr+desugarTopExpr (DefineWithType typedVwi expr) = do+  -- Convert typed definition to regular definition+  -- Type information is used for type checking, but the runtime representation is the same+  -- Note: Constraints are preserved in the type scheme (by EnvBuilder),+  -- and dictionary passing is handled in TypeClassExpand phase+  let name = typedVarName typedVwi+      indices = typedVarIndices typedVwi+      params = typedVarParams typedVwi+      vwi = VarWithIndices name indices+  -- If there are typed parameters, wrap the body in a lambda+  case params of+    [] -> do+      (var, iexpr) <- desugarDefineWithIndices vwi expr+      return . Just $ IDefine var iexpr+    _  -> do+      -- Create lambda arguments from typed parameters+      let argPatterns = map typedParamToArgPattern params+          lambdaExpr = LambdaExpr argPatterns expr+      (var, iexpr) <- desugarDefineWithIndices vwi lambdaExpr+      return . Just $ IDefine var iexpr desugarTopExpr (Test expr)     = Just . ITest <$> desugar expr desugarTopExpr (Execute expr)  = Just . IExecute <$> desugar expr desugarTopExpr (Load file)     = return . Just $ ILoad file desugarTopExpr (LoadFile file) = return . Just $ ILoadFile file-desugarTopExpr _               = return Nothing +-- Type class declarations: generate dictionary-passing wrapper functions+-- and register the class methods for dispatch+-- For a class like:+--   class Eq a where+--     (==) (x: a) (y: a) : Bool+-- We generate:+--   1. Dictionary wrapper: def classEqEq dict x y := (dict_"eq") x y+--   2. Instance registry variable: def registryEq := {| |}+--   3. Auto-dispatch function: def autoEqEq x y := (resolveEq x)_"eq" x y+desugarTopExpr (ClassDeclExpr (ClassDecl classNm _typeParams _supers methods)) = do+  -- Generate dictionary-passing wrapper functions for each method+  methodWrappers <- mapM (desugarClassMethod classNm) methods+  -- Generate empty instance registry+  let registryDef = makeRegistryDef classNm+  case methodWrappers of+    [] -> return Nothing+    _  -> return $ Just $ IDefineMany (registryDef : methodWrappers)+  where+    desugarClassMethod :: String -> ClassMethod -> EvalM (Var, IExpr)+    desugarClassMethod clsNm (ClassMethod methName methParams _retType _defaultImpl) = do+      -- Generate function name: e.g., "classEqEq" for (==) in Eq+      let wrapperName = "class" ++ clsNm ++ capitalizeFirst (sanitizeMethodName methName)+          var = stringToVar wrapperName+          dictVar = "dict"+          -- Parameter names: dict, x, y, ...+          paramNames = map extractParamName methParams+          allParams = dictVar : paramNames+      -- Build the body: (dict_"methodName") x y ...+      -- dict_"eq" is hash access, then apply to remaining params+      let dictAccessExpr = IIndexedExpr False (IVarExpr dictVar) +                             [Sub (IConstantExpr (StringExpr (pack (sanitizeMethodName methName))))]+          bodyExpr = if null paramNames+                     then dictAccessExpr+                     else IApplyExpr dictAccessExpr (map IVarExpr paramNames)+          lambdaExpr = ILambdaExpr Nothing (map stringToVar allParams) bodyExpr+      return (var, lambdaExpr)+    +    -- Create empty instance registry: registryEq := {| |}+    makeRegistryDef :: String -> (Var, IExpr)+    makeRegistryDef clsNm = +      let registryName = "registry" ++ clsNm+          var = stringToVar registryName+      in (var, IHashExpr [])+    +    extractParamName :: TypedParam -> String+    extractParamName (TPVar name _) = name+    extractParamName (TPInvertedVar name _) = name+    extractParamName (TPUntypedVar name) = name+    extractParamName _ = "x"  -- fallback++-- Instance declarations: generate a dictionary and individual method definitions+-- For an instance like:+--   instance Eq Integer where+--     (==) x y := x = y+--     (/=) x y := not (x = y)+-- We generate:+--   1. Individual method functions:+--      def eqIntegerEq x y := x = y+--      def eqIntegerNeq x y := not (x = y)+--   2. A dictionary for the instance:+--      def eqInteger := {| ("eq", eqIntegerEq), ("neq", eqIntegerNeq) |}+desugarTopExpr (InstanceDeclExpr (InstanceDecl constraints classNm instTypes methods)) = do+  -- Check if instTypes is not empty+  if null instTypes+    then return Nothing+    else do+      -- Use type constructor name only (without type parameters)+      -- e.g., "Collection" not "Collectiona" for [a]+      let instTypeName = typeConstructorName (typeExprToType (head instTypes))+      -- Generate individual method definitions with constraint parameters+      methodDefs <- mapM (desugarInstanceMethod constraints classNm instTypeName) methods+      -- Generate dictionary definition (with constraints if any)+      let dictDef = makeDictDef constraints classNm instTypeName methods+      -- Return all definitions+      case methodDefs of+        []  -> return Nothing+        _   -> return $ Just $ IDefineMany (dictDef : methodDefs)+  where+    desugarInstanceMethod :: [ConstraintExpr] -> String -> String -> InstanceMethod -> EvalM (Var, IExpr)+    desugarInstanceMethod _constrs clsNm typNm (InstanceMethod methName params body) = do+      -- Generate function name using type constructor name only+      -- e.g., "eqCollectionEq" not "eqCollectionaEq" for instance {Eq a} Eq [a]+      let funcName = lowerFirst clsNm ++ typNm ++ capitalizeFirst (sanitizeMethodName methName)+          var = stringToVar funcName+      +      -- Do NOT add dictionary parameters here!+      -- Dictionary parameters will be added automatically by addDictionaryParametersT+      -- after type inference, based on the inferred constraints.+      -- This allows the method body to be properly type-checked with constraints.+      +      -- Create lambda expression with only the method parameters+      let lambdaArgs = map (\p -> Arg (APPatVar (VarWithIndices p []))) params+          lambdaExpr = if null params then body else LambdaExpr lambdaArgs body+      iexpr <- desugar lambdaExpr+      return (var, iexpr)+    +    makeDictDef :: [ConstraintExpr] -> String -> String -> [InstanceMethod] -> (Var, IExpr)+    makeDictDef _constrs clsNm typNm meths =+      let dictName = lowerFirst clsNm ++ typNm  -- e.g., "eqCollection"+          dictVar = stringToVar dictName+          +          -- For nested instances (with constraints), the dictionary becomes a function+          -- that takes dictionary parameters and returns a hash.+          -- e.g., for instance {Eq a} Eq [a]:+          --   eqCollection = \dict_Eq -> {| ("eq", eqCollectionEq dict_Eq), ... |}+          --+          -- Dictionary parameters will be automatically added by addDictionaryParametersT+          -- after type inference, so we don't add them here manually.+          -- We just create the hash with references to the methods.+          +          hashEntries = map (makeHashEntry clsNm typNm) meths+          hashExpr = IHashExpr hashEntries+      in (dictVar, hashExpr)+    +    makeHashEntry :: String -> String -> InstanceMethod -> (IExpr, IExpr)+    makeHashEntry clsNm typNm (InstanceMethod methName _ _) =+      let keyExpr = IConstantExpr (StringExpr (pack (sanitizeMethodName methName)))+          -- Reference to the method function+          funcName = lowerFirst clsNm ++ typNm ++ capitalizeFirst (sanitizeMethodName methName)+          valueExpr = IVarExpr funcName+      in (keyExpr, valueExpr)+    ++-- Inductive declarations don't produce runtime code+-- Constructor registration is handled by the type system+desugarTopExpr (InductiveDecl _ _ _) = return Nothing++-- Infix declarations don't produce runtime code+desugarTopExpr (InfixDecl _ _) = return Nothing+desugarTopExpr (PatternInductiveDecl _ _ _) = return Nothing  -- Handled in environment building phase++-- Pattern function declarations need type checking, so convert to IPatternFunctionDecl+desugarTopExpr (PatternFunctionDecl name typeParams params retType body) = do+  let paramTypes = map (\(pname, pty) -> (pname, typeExprToType pty)) params+      retType' = typeExprToType retType+      tyVars = map TyVar typeParams+  body' <- desugarPattern body+  return . Just $ IPatternFunctionDecl name tyVars paramTypes retType' body'++-- Symbol declarations+desugarTopExpr (DeclareSymbol names mTypeExpr) = do+  -- Convert type expression to type (defaults to Integer if not specified)+  let ty = case mTypeExpr of+             Just texpr -> typeExprToType texpr+             Nothing    -> typeExprToType TEInt+  return . Just $ IDeclareSymbol names (Just ty)++-- | Convert TypedParam to Arg ArgPattern for lambda expressions+typedParamToArgPattern :: TypedParam -> Arg ArgPattern+typedParamToArgPattern (TPVar pname _) =+  Arg (APPatVar (VarWithIndices pname []))+typedParamToArgPattern (TPInvertedVar pname _) =+  InvertedArg (APPatVar (VarWithIndices pname []))+typedParamToArgPattern (TPTuple elems) =+  Arg (APTuplePat (map typedParamToArgPattern elems))+typedParamToArgPattern (TPWildcard _) =+  Arg APWildCard+typedParamToArgPattern (TPUntypedVar pname) =+  Arg (APPatVar (VarWithIndices pname []))+typedParamToArgPattern TPUntypedWildcard =+  Arg APWildCard+ desugarTopExprs :: [TopExpr] -> EvalM [ITopExpr] desugarTopExprs [] = return [] desugarTopExprs (expr : exprs) = do@@ -130,37 +327,37 @@   ILambdaExpr Nothing [stringToVar name] <$>     desugar (MatchExpr BFSMode (VarExpr name) matcher clauses) -desugar (IndexedExpr b expr indices) = do+desugar (IndexedExpr override expr indices) = do   expr' <- desugar expr-  desugarIndexedExpr b expr' indices+  desugarIndexedExpr override expr' indices   where     desugarIndexedExpr :: Bool -> IExpr -> [IndexExpr Expr] -> EvalM IExpr-    desugarIndexedExpr b expr' indices =+    desugarIndexedExpr override expr' indices =       case indices of         [] -> return expr'         (MultiSubscript x y:indices') ->           case (x, y) of-            (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) -> do-              expr'' <- desugarMultiScript b expr' ISubrefsExpr b1 e1 n1 n2+            (IndexedExpr override1 e1 [n1], IndexedExpr _ _ [n2]) -> do+              expr'' <- desugarMultiScript override expr' ISubrefsExpr override1 e1 n1 n2               desugarIndexedExpr False expr'' indices'             _ -> throwError $ Default "Index should be IndexedExpr for multi subscript"         (MultiSuperscript x y:indices') ->           case (x, y) of-            (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) -> do-              expr'' <- desugarMultiScript b expr' ISuprefsExpr b1 e1 n1 n2+            (IndexedExpr override1 e1 [n1], IndexedExpr _ _ [n2]) -> do+              expr'' <- desugarMultiScript override expr' ISuprefsExpr override1 e1 n1 n2               desugarIndexedExpr False expr'' indices'             _ -> throwError $ Default "Index should be IndexedExpr for multi superscript"         _ -> do           let (is, indices') = break isMulti indices-          expr'' <- IIndexedExpr b expr' <$> mapM desugarIndex is+          expr'' <- IIndexedExpr override expr' <$> mapM desugarIndex is           desugarIndexedExpr False expr'' indices'-    desugarMultiScript b expr' refExpr b1 e1 n1 n2 = do+    desugarMultiScript override expr' refExpr override1 e1 n1 n2 = do       k     <- fresh       n1'   <- desugar (extractIndexExpr n1)       n2'   <- desugar (extractIndexExpr n2)       e1'   <- desugar e1-      return $ refExpr b expr' (makeIApply "map"-                                           [ILambdaExpr Nothing [stringToVar k] (IIndexedExpr b1 e1' [Sub (IVarExpr k)]),+      return $ refExpr override expr' (makeIApply "map"+                                           [ILambdaExpr Nothing [stringToVar k] (IIndexedExpr override1 e1' [Sub (IVarExpr k)]),                                             makeIApply "between" [n1', n2']])     isMulti (MultiSubscript _ _)   = True     isMulti (MultiSuperscript _ _) = True@@ -192,21 +389,18 @@  -- Desugar of LambdaExpr takes place in 2 stages. -- * LambdaExpr -> LambdaExpr'  : Desugar pattern matches at the arg positions--- * LambdaExpr' -> ILambdaExpr : Desugar ScalarArg and InvertedScalarArg+-- * LambdaExpr' -> ILambdaExpr : Desugar Arg and InvertedArg desugar (LambdaExpr args expr) = do   (args', expr') <- foldrM desugarArg ([], expr) args   desugar $ LambdaExpr' args' expr'   where     desugarArg :: Arg ArgPattern -> ([Arg VarWithIndices], Expr) -> EvalM ([Arg VarWithIndices], Expr)-    desugarArg (TensorArg x) (args, expr) = do-      (var, expr') <- desugarArgPat x expr-      return (TensorArg var : args, expr')-    desugarArg (ScalarArg x) (args, expr) = do+    desugarArg (Arg x) (args, expr) = do       (var, expr') <- desugarArgPat x expr-      return (ScalarArg var : args, expr')-    desugarArg (InvertedScalarArg x) (args, expr) = do+      return (Arg var : args, expr')+    desugarArg (InvertedArg x) (args, expr) = do       (var, expr') <- desugarArgPat x expr-      return (InvertedScalarArg var : args, expr')+      return (InvertedArg var : args, expr')      -- Desugar argument patterns. Examples:     -- \$(%x, %y) -> expr   ==> \$tmp -> let (tmp1, tmp2) := tmp in (\%x %y -> expr) tmp1 tmp2@@ -240,14 +434,14 @@       tmp1 <- fresh       tmp2 <- fresh       return (tmp', LetExpr [Bind (PDConsPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)]-                     (ApplyExpr (LambdaExpr [arg1, TensorArg arg2] expr) [VarExpr tmp1, VarExpr tmp2]))+                     (ApplyExpr (LambdaExpr [arg1, Arg arg2] expr) [VarExpr tmp1, VarExpr tmp2]))     desugarArgPat (APSnocPat arg1 arg2) expr = do       tmp  <- fresh       let tmp' = stringToVarWithIndices tmp       tmp1 <- fresh       tmp2 <- fresh       return (tmp', LetExpr [Bind (PDSnocPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)]-                     (ApplyExpr (LambdaExpr [TensorArg arg1, arg2] expr) [VarExpr tmp1, VarExpr tmp2]))+                     (ApplyExpr (LambdaExpr [Arg arg1, arg2] expr) [VarExpr tmp1, VarExpr tmp2]))  desugar (LambdaExpr' vwis expr) = do   let (vwis', expr') = foldr desugarInvertedArgs ([], expr) vwis@@ -256,22 +450,35 @@   return $ ILambdaExpr Nothing args' expr'   where     desugarInvertedArgs :: Arg VarWithIndices -> ([VarWithIndices], Expr) -> ([VarWithIndices], Expr)-    desugarInvertedArgs (TensorArg x) (args, expr) = (x : args, expr)-    desugarInvertedArgs (ScalarArg x) (args, expr) =-      (x : args,-       TensorMapExpr (LambdaExpr' [TensorArg x] expr) (VarExpr (extractNameFromVarWithIndices x)))-    desugarInvertedArgs (InvertedScalarArg x) (args, expr) =-      (x : args,-       TensorMapExpr (LambdaExpr' [TensorArg x] expr) (FlipIndicesExpr (VarExpr (extractNameFromVarWithIndices x))))+    desugarInvertedArgs (Arg x) (args, expr) = (x : args, expr)+    desugarInvertedArgs (InvertedArg x) (args, expr) =+      let varName = extractNameFromVarWithIndices x+          flippedExpr = FlipIndicesExpr (VarExpr varName)+          bindPat = PDPatVar varName+      in (x : args, LetExpr [Bind bindPat flippedExpr] expr)  desugar (MemoizedLambdaExpr names expr) =   IMemoizedLambdaExpr names <$> desugar expr +-- Typed memoized lambda is desugared the same way (type info used only for type checking)+desugar (TypedMemoizedLambdaExpr params _ body) =+  IMemoizedLambdaExpr (extractParamNames params) <$> desugar body+  where+    extractParamNames = concatMap extractName+    extractName (TPVar name _) = [name]+    extractName (TPInvertedVar name _) = [name]+    extractName (TPTuple elems) = concatMap extractName elems+    extractName (TPWildcard _) = []+    extractName (TPUntypedVar name) = [name]+    extractName TPUntypedWildcard = []+ desugar (CambdaExpr name expr) =   ICambdaExpr name <$> desugar expr -desugar (PatternFunctionExpr names pattern) =-  IPatternFunctionExpr names <$> desugarPattern pattern+desugar (PatternFunctionExpr _names _pattern) =+  -- Pattern functions are only defined at TopExpr level+  -- They should not appear in expression context+  throwError $ Default "Pattern functions cannot be used as expressions"  desugar (IfExpr expr0 expr1 expr2) =   IIfExpr <$> desugar expr0 <*> desugar expr1 <*> desugar expr2@@ -356,6 +563,7 @@   ITensorMap2Expr <$> desugar fnExpr <*> desugar t1Expr <*> desugar t2Expr  desugar (TransposeExpr vars expr) =+  -- ITransposeExpr takes (permutation, tensor) as arguments to match tTranspose   ITransposeExpr <$> desugar vars <*> desugar expr  desugar (FlipIndicesExpr expr) =@@ -364,9 +572,6 @@ desugar (ApplyExpr expr args) =   IApplyExpr <$> desugar expr <*> mapM desugar args -desugar (CApplyExpr expr0 expr1) =-  ICApplyExpr <$> desugar expr0 <*> desugar expr1- desugar FreshVarExpr = do   id <- fresh   return $ IVarExpr (":::" ++ id)@@ -378,22 +583,22 @@  desugar (AnonParamFuncExpr n expr) = do   let args = map (\n -> stringToVarWithIndices ('%' : show n)) [1..n]-  lambda <- desugar $ LambdaExpr' (map TensorArg args) expr+  lambda <- desugar $ LambdaExpr' (map Arg args) expr   return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0")  desugar (AnonTupleParamFuncExpr 1 expr) = do-  lambda <- desugar $ LambdaExpr' [TensorArg (stringToVarWithIndices "%1")] expr+  lambda <- desugar $ LambdaExpr' [Arg (stringToVarWithIndices "%1")] expr   return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0") desugar (AnonTupleParamFuncExpr n expr) = do   let args = map (\n -> stringToVarWithIndices ('%' : show n)) [1..n]   lambda <- desugar $-    LambdaExpr [TensorArg (APTuplePat $ map (TensorArg . APPatVar) args)] expr+    LambdaExpr [Arg (APTuplePat $ map (Arg . APPatVar) args)] expr   return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0")  desugar (AnonListParamFuncExpr n expr) = do-  let args' = map (\n -> TensorArg (APPatVar (stringToVarWithIndices ('%' : show n)))) [1..n]+  let args' = map (\n -> Arg (APPatVar (stringToVarWithIndices ('%' : show n)))) [1..n]   let args = foldr APConsPat APEmptyPat args'-  lambda <- desugar $ LambdaExpr [TensorArg args] expr+  lambda <- desugar $ LambdaExpr [Arg args] expr   return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0")  desugar (QuoteExpr expr) =@@ -407,6 +612,14 @@  desugar (FunctionExpr args) = return $ IFunctionExpr args +-- Type annotation is erased at runtime+desugar (TypeAnnotation expr _typeExpr) = desugar expr++-- Typed lambda is desugared to regular lambda+desugar (TypedLambdaExpr params _retType body) = do+  let args = map (\(name, _) -> Arg (APPatVar (VarWithIndices name []))) params+  desugar $ LambdaExpr args body+ desugarIndex :: IndexExpr Expr -> EvalM (Index IExpr) desugarIndex (Subscript e)    = Sub <$> desugar e desugarIndex (Superscript e)  = Sup <$> desugar e@@ -463,7 +676,9 @@   (\x y -> IInductivePat f [x, y]) <$> desugarPattern' pat1 <*> desugarPattern' pat2 desugarPattern' (TuplePat pats) = ITuplePat <$> mapM desugarPattern' pats desugarPattern' (InductiveOrPApplyPat name pats) = IInductiveOrPApplyPat name <$> mapM desugarPattern' pats-desugarPattern' (InductivePat name pats) = IInductivePat name <$> mapM desugarPattern' pats+-- Convert all InductivePat to IInductiveOrPApplyPat since we cannot distinguish between+-- pattern constructors and pattern functions at parse time+desugarPattern' (InductivePat name pats) = IInductiveOrPApplyPat name <$> mapM desugarPattern' pats desugarPattern' (IndexedPat pat exprs) = IIndexedPat <$> desugarPattern' pat <*> mapM desugar exprs desugarPattern' (PApplyPat expr pats) = IPApplyPat <$> desugar expr <*> mapM desugarPattern' pats desugarPattern' (DApplyPat pat pats) = IDApplyPat <$> desugarPattern' pat <*> mapM desugarPattern' pats@@ -488,24 +703,37 @@     desugarBinding (BindWithIndices vwi expr) = do       (var, iexpr) <- desugarDefineWithIndices vwi expr       return (PDPatVar var, iexpr)+    -- BindWithType: desugar like DefineWithType+    desugarBinding (BindWithType typedVarWI body) = do+      let name = typedVarName typedVarWI+          params = typedVarParams typedVarWI+          argPatterns = map typedParamToArgPattern params+          lambdaExpr = if null argPatterns+                         then body+                         else LambdaExpr argPatterns body+      body' <- desugar lambdaExpr+      let body'' = case body' of+            ILambdaExpr Nothing args b -> ILambdaExpr (Just (Var name [])) args b+            other -> other+      return (PDPatVar (Var name []), body'')  desugarMatchClauses :: [MatchClause] -> EvalM [IMatchClause] desugarMatchClauses = mapM (\(pat, expr) -> (,) <$> desugarPattern pat <*> desugar expr)  desugarPatternDef :: PatternDef -> EvalM IPatternDef-desugarPatternDef (pp, matcher, pds) =+desugarPatternDef (PatternDef pp matcher pds) =   (pp,,) <$> desugar matcher <*> desugarPrimitiveDataMatchClauses pds  desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, Expr)] -> EvalM [(IPrimitiveDataPattern, IExpr)] desugarPrimitiveDataMatchClauses = mapM (\(pd, expr) -> (fmap stringToVar pd,) <$> desugar expr)  desugarDefineWithIndices :: VarWithIndices -> Expr -> EvalM (Var, IExpr)-desugarDefineWithIndices var@(VarWithIndices _ _) expr@(LambdaExpr _ _) = do-  let var' = varWithIndicesToVar var+-- Case 1: No indices - simple desugaring without withSymbols/transpose+desugarDefineWithIndices (VarWithIndices name []) expr = do   expr' <- desugar expr-  case expr' of-    ILambdaExpr Nothing args body -> return (var', ILambdaExpr (Just var') args body)-    _                             -> return (var', expr')+  return (Var name [], expr')++-- Case 2: Non-empty indices - wrap with withSymbols and transpose desugarDefineWithIndices (VarWithIndices name is) expr = do   let (isSubs, indexNames) = unzip $ concatMap extractSubSupIndex is   expr <- if any isExtendedIndice is@@ -514,6 +742,7 @@   body <- desugar expr   let indexNamesCollection = ICollectionExpr (map IVarExpr indexNames)   let is' = map (\b -> if b then Sub Nothing else Sup Nothing) isSubs+  -- ITransposeExpr takes (permutation, tensor) as arguments to match tTranspose   return (Var name is', IWithSymbolsExpr indexNames (ITransposeExpr indexNamesCollection body))  varWithIndicesToVar :: VarWithIndices -> Var@@ -539,7 +768,7 @@ desugarExtendedIndices indices isSubs indexNames tensorBody = do   tensorName <- fresh   tensorGenExpr <- f indices (VarExpr tensorName) [] []-  let indexFunctionExpr = LambdaExpr [TensorArg $ foldr APConsPat APEmptyPat (map (TensorArg . APPatVar) (map stringToVarWithIndices indexNames))] tensorGenExpr+  let indexFunctionExpr = LambdaExpr [Arg $ foldr APConsPat APEmptyPat (map (Arg . APPatVar) (map stringToVarWithIndices indexNames))] tensorGenExpr   let genTensorExpr = GenerateTensorExpr indexFunctionExpr (makeApply "tensorShape" [VarExpr tensorName])   let tensorIndices = zipWith (\isSub name -> if isSub then Subscript (VarExpr name) else Superscript (VarExpr name)) isSubs indexNames   return $ LetExpr [Bind (PDPatVar tensorName) tensorBody] (IndexedExpr True genTensorExpr tensorIndices)

@@ -0,0 +1,408 @@+{- |+Module      : Language.Egison.EnvBuilder+Licence     : MIT++This module implements Phase 2: Environment Building Phase.+It collects all declarations from TopExpr list before type inference and evaluation.++Environment Building Phase (Phase 2):+  1. Data constructor definitions collection (from InductiveDecl)+  2. Type class definitions collection (from ClassDeclExpr)+  3. Instance definitions collection (from InstanceDeclExpr)+  4. Type signature collection (from Define, DefineWithType)++This phase must be completed BEFORE type inference (Phase 5) begins,+ensuring all necessary information is available for type checking.+-}++module Language.Egison.EnvBuilder+  ( buildEnvironments+  , EnvBuildResult(..)+  ) where++import           Control.Monad              (foldM)+import           Control.Monad.Except       (throwError)+import           Control.Monad.State+import           Data.Char                  (toUpper, toLower)+import qualified Data.HashMap.Strict        as HashMap++import           Language.Egison.AST+import           Language.Egison.Data       (EvalM)+import           Language.Egison.EvalState  (ConstructorInfo(..), ConstructorEnv, PatternConstructorEnv)+import           Language.Egison.IExpr      (Var(..), Index(..), stringToVar)+import           Language.Egison.Desugar    (transVarIndex)+import           Language.Egison.Type.Env   (TypeEnv, ClassEnv, PatternTypeEnv, emptyEnv, emptyClassEnv, emptyPatternEnv,+                                             extendEnv, extendPatternEnv, addClass, addInstance, lookupClass)+import qualified Language.Egison.Type.Types as Types+import           Language.Egison.Type.Types (Type(..), TyVar(..), Constraint(..), TypeScheme(..), TensorShape(..),+                                             ClassInfo, InstanceInfo, freeTyVars, typeToName, sanitizeMethodName, typeExprToType,+                                             capitalizeFirst, lowerFirst)+import qualified Data.Set as Set++-- | Result of environment building phase+data EnvBuildResult = EnvBuildResult+  { ebrTypeEnv        :: TypeEnv         -- ^ Type signatures for definitions+  , ebrClassEnv       :: ClassEnv        -- ^ Type class and instance information+  , ebrConstructorEnv :: ConstructorEnv  -- ^ Data constructor information+  , ebrPatternConstructorEnv :: PatternConstructorEnv  -- ^ Pattern constructor information+  , ebrPatternTypeEnv :: PatternTypeEnv  -- ^ Pattern function information+  } deriving (Show)++--------------------------------------------------------------------------------+-- Phase 2: Environment Building Phase+--------------------------------------------------------------------------------++-- | Build all environments from a list of top-level expressions.+-- This function implements Phase 2 of the processing flow.+-- It must be called AFTER expandLoads (Phase 1) and BEFORE type inference (Phase 5).+buildEnvironments :: [TopExpr] -> EvalM EnvBuildResult+buildEnvironments exprs = do+  -- Start with empty environments+  let initialResult = EnvBuildResult+        { ebrTypeEnv = emptyEnv+        , ebrClassEnv = emptyClassEnv+        , ebrConstructorEnv = HashMap.empty+        , ebrPatternConstructorEnv = emptyPatternEnv+        , ebrPatternTypeEnv = emptyPatternEnv+        }+  +  -- Process each top-level expression to collect declarations+  foldM processTopExpr initialResult exprs++-- | Process a single top-level expression to collect environment information+processTopExpr :: EnvBuildResult -> TopExpr -> EvalM EnvBuildResult+processTopExpr result topExpr = case topExpr of+  +  -- 1. Data Constructor Definitions (from InductiveDecl)+  InductiveDecl typeName typeParams constructors -> do+    let typeParamVars = map (TVar . TyVar) typeParams+        adtType = TInductive typeName typeParamVars+        typeEnv = ebrTypeEnv result+        ctorEnv = ebrConstructorEnv result+    +    -- Register each constructor+    (typeEnv', ctorEnv') <- foldM (registerConstructor typeName typeParams adtType) +                                   (typeEnv, ctorEnv) +                                   constructors+    +    return result { ebrTypeEnv = typeEnv', ebrConstructorEnv = ctorEnv' }+  +  -- 2. Type Class Definitions (from ClassDeclExpr)+  ClassDeclExpr (ClassDecl className [typeParam] superClasses methods) -> do+    let classEnv = ebrClassEnv result+        typeEnv = ebrTypeEnv result+        tyVar = TyVar typeParam+        +        -- Extract superclass names from ConstraintExprs+        superNames = map extractConstraintName superClasses+        +        -- Build method list with types+        methodsWithTypes = map extractMethodWithType methods+        +        -- Create ClassInfo+        -- Note: Use qualified name to avoid ambiguity with ClassDecl.classMethods+        classInfo = Types.ClassInfo+          { Types.classSupers = superNames+          , Types.classParam = tyVar+          , Types.classMethods = methodsWithTypes+          }+        +        -- Register class+        classEnv' = addClass className classInfo classEnv+        +        -- Register each class method to type environment+        typeEnv' = foldl (registerClassMethod tyVar className) typeEnv methods+    +    return result { ebrClassEnv = classEnv', ebrTypeEnv = typeEnv' }+  +  ClassDeclExpr _ -> +    -- Unsupported class declaration format (multiple type parameters, etc.)+    return result+  +  -- 3. Instance Definitions (from InstanceDeclExpr)+  InstanceDeclExpr (InstanceDecl context className instTypes methods) -> do+    let classEnv = ebrClassEnv result+        typeEnv = ebrTypeEnv result+        +        -- Get the main instance type+        mainInstType = case instTypes of+          []    -> TAny+          (t:_) -> typeExprToType t+        +        -- Create InstanceInfo+        instInfo = Types.InstanceInfo+          { Types.instContext = map constraintToInternal context+          , Types.instClass = className+          , Types.instType = mainInstType+          , Types.instMethods = []  -- Methods are handled during desugaring/evaluation+          }+        +        -- Register instance+        classEnv' = addInstance className instInfo classEnv+        +        -- Register method type signatures for generated methods+        -- This prevents "Unbound variable" warnings during type inference+        -- Pass the instance context (constraints) to include in method types+        typeEnv' = registerInstanceMethods className mainInstType (map constraintToInternal context) methods classEnv' typeEnv+    +    return result { ebrClassEnv = classEnv', ebrTypeEnv = typeEnv' }+  +  -- 4. Type Signature Collection (from Define, DefineWithType)+  -- Note: We only collect explicit type signatures here.+  -- Inferred types will be added during type inference.+  DefineWithType typedVar _expr -> do+    let name = typedVarName typedVar+        varIndices = typedVarIndices typedVar+        -- Convert VarIndex to Index (Maybe Var) - like transVarIndex but with Nothing content+        indexTypes = concatMap transVarIndex varIndices+        -- Create Var with index structure (content is Just Var, so map to Nothing)+        var = Var name (map (fmap (const Nothing)) indexTypes)+        params = typedVarParams typedVar+        retType = typeExprToType (typedVarRetType typedVar)+        paramTypes = map typedParamToType params+        +        -- Build function type+        funType = foldr TFun retType paramTypes+        +        -- Convert constraints from AST to internal representation+        constraints = map constraintToInternal (typedVarConstraints typedVar)+        +        -- Generalize free type variables in the type signature+        -- This handles type parameters like {a, b, c} in def compose {a, b, c} ...+        freeVars = Set.toList (freeTyVars funType)+        typeScheme = Types.Forall freeVars constraints funType+        +        typeEnv = ebrTypeEnv result+        typeEnv' = extendEnv var typeScheme typeEnv+    +    return result { ebrTypeEnv = typeEnv' }+  +  -- 5. Pattern Inductive Declarations (from PatternInductiveDecl)+  PatternInductiveDecl typeName typeParams constructors -> do+    let typeParamVars = map (TVar . TyVar) typeParams+        -- Special cases: [a] as TCollection and String as TString+        patternType = case (typeName, typeParams) of+                        ("[]", [param]) -> TCollection (TVar (TyVar param))+                        ("String", [])  -> TString+                        _               -> TInductive typeName typeParamVars+        patternCtorEnv = ebrPatternConstructorEnv result+    +    -- Register each pattern constructor to pattern constructor environment+    patternCtorEnv' <- foldM (registerPatternConstructor typeName typeParams patternType) +                              patternCtorEnv +                              constructors+    +    return result { ebrPatternConstructorEnv = patternCtorEnv' }+  +  -- 6. Pattern Function Declarations (from PatternFunctionDecl)+  PatternFunctionDecl name typeParams params retType _body -> do+    let paramTypes = map (typeExprToType . snd) params+        retType' = typeExprToType retType+        -- Pattern function type: arg1 -> arg2 -> ... -> retType (without Pattern wrapper)+        patternFuncType = foldr TFun retType' paramTypes+        +        -- Quantify over type parameters+        tyVars = map TyVar typeParams+        typeScheme = Types.Forall tyVars [] patternFuncType+        +        patternEnv = ebrPatternTypeEnv result+        patternEnv' = extendPatternEnv name typeScheme patternEnv+    +    return result { ebrPatternTypeEnv = patternEnv' }+  +  -- Other expressions don't contribute to environment building+  Define {} -> return result+  DefineWithType {} -> return result+  Test {} -> return result+  Execute {} -> return result+  LoadFile {} -> return result  -- Should not appear after expandLoads+  InfixDecl {} -> return result+  +  -- 7. Symbol Declarations (from DeclareSymbol)+  DeclareSymbol names mTypeExpr -> do+    let ty = case mTypeExpr of+               Just texpr -> typeExprToType texpr+               Nothing    -> TInt  -- Default to Integer (MathExpr)+        scheme = Forall [] [] ty+        typeEnv = ebrTypeEnv result+        -- Add each symbol to the type environment+        typeEnv' = foldr (\name env -> extendEnv (stringToVar name) scheme env) typeEnv names+    return result { ebrTypeEnv = typeEnv' }++--------------------------------------------------------------------------------+-- Helper Functions+--------------------------------------------------------------------------------++-- | Register a single data constructor+registerConstructor :: String -> [String] -> Type +                    -> (TypeEnv, ConstructorEnv) -> InductiveConstructor +                    -> EvalM (TypeEnv, ConstructorEnv)+registerConstructor typeName typeParams resultType (typeEnv, ctorEnv) +                    (InductiveConstructor ctorName argTypeExprs) = do+  let argTypes = map typeExprToType argTypeExprs+      +      -- Constructor type: argTypes -> resultType+      constructorType = foldr TFun resultType argTypes+      +      -- Quantify over type parameters+      tyVars = map TyVar typeParams+      typeScheme = Types.Forall tyVars [] constructorType+      +      -- Add to type environment+      typeEnv' = extendEnv (stringToVar ctorName) typeScheme typeEnv+      +      -- Add to constructor environment (for pattern matching and evaluation)+      ctorInfo = ConstructorInfo+        { ctorTypeName = typeName+        , ctorArgTypes = argTypes+        , ctorTypeParams = typeParams+        }+      ctorEnv' = HashMap.insert ctorName ctorInfo ctorEnv+  +  return (typeEnv', ctorEnv')++-- | Register a class method to the type environment+registerClassMethod :: TyVar -> String -> TypeEnv -> ClassMethod -> TypeEnv+registerClassMethod tyVar className typeEnv (ClassMethod methName params retType _defaultImpl) =+  let paramTypes = map typedParamToType params+      methodType = foldr TFun (typeExprToType retType) paramTypes+      +      -- Method has constrained type: ClassName a => methodType+      constraint = Types.Constraint className (TVar tyVar)+      typeScheme = Types.Forall [tyVar] [constraint] methodType+  in+    extendEnv (stringToVar methName) typeScheme typeEnv++-- | Register type signatures for instance methods (generated during desugaring)+-- This prevents "Unbound variable" warnings during type inference+registerInstanceMethods :: String -> Type -> [Constraint] -> [InstanceMethod] -> ClassEnv -> TypeEnv -> TypeEnv+registerInstanceMethods className instType instConstraints methods classEnv typeEnv =+  case lookupClass className classEnv of+    Nothing -> typeEnv  -- Class not found, skip+    Just classInfo -> +      -- Register each instance method+      let typeEnv' = foldr (registerInstanceMethod className instType instConstraints classInfo) typeEnv methods+      +          -- Also register the dictionary itself+          -- e.g., eqCollection : {Eq a} Hash String ([a] -> [a] -> Bool)+          typeName' = Types.typeConstructorName instType+          dictName = lowerFirst className ++ typeName'+          +          -- Build dictionary type: Hash String (method type)+          -- All methods should have the same general shape, so we use the first one+          dictValueType = case methods of+            [] -> TAny+            _ -> case lookup (instanceMethodName (head methods)) (Types.classMethods classInfo) of+              Nothing -> TAny+              Just methodType ->+                let tyVar = Types.classParam classInfo+                    substitutedType = substituteTypeVar tyVar instType methodType+                in substitutedType+          +          dictType = THash TString dictValueType+          freeVars = Set.toList (freeTyVars dictType)+          dictScheme = Types.Forall freeVars instConstraints dictType+      in+        extendEnv (stringToVar dictName) dictScheme typeEnv'+  where+    instanceMethodName :: InstanceMethod -> String+    instanceMethodName (InstanceMethod name _ _) = name+    +    registerInstanceMethod :: String -> Type -> [Constraint] -> Types.ClassInfo -> InstanceMethod -> TypeEnv -> TypeEnv+    registerInstanceMethod clsName instTy constraints classInfo (InstanceMethod methName _params _body) env =+      -- Find the method in the class definition+      case lookup methName (Types.classMethods classInfo) of+        Nothing -> env  -- Method not in class definition, skip+        Just methodType -> +          -- Substitute type variable with instance type+          let tyVar = Types.classParam classInfo+              substitutedType = substituteTypeVar tyVar instTy methodType+              +              -- Generate method name using type constructor name only (no type parameters)+              -- e.g., "eqCollectionEq" not "eqCollectionaEq"+              typeName' = Types.typeConstructorName instTy+              sanitizedName = sanitizeMethodName methName+              generatedMethodName = lowerFirst clsName ++ typeName' ++ capitalizeFirst sanitizedName+              +              -- Extract free type variables from the substituted type+              freeVars = Set.toList (freeTyVars substitutedType)+              +              -- Create type scheme with constraints from the instance context+              -- e.g., {Eq a} [a] -> [a] -> Bool for instance {Eq a} Eq [a]+              typeScheme = Types.Forall freeVars constraints substitutedType+          in+            extendEnv (stringToVar generatedMethodName) typeScheme env+    +    -- Substitute type variable with concrete type in a type expression+    substituteTypeVar :: TyVar -> Type -> Type -> Type+    substituteTypeVar oldVar newType = go+      where+        go TInt = TInt+        go TFloat = TFloat+        go TBool = TBool+        go TChar = TChar+        go TString = TString+        go (TVar v) | v == oldVar = newType+                    | otherwise = TVar v+        go (TTuple ts) = TTuple (map go ts)+        go (TCollection t) = TCollection (go t)+        go (TInductive name ts) = TInductive name (map go ts)+        go (TTensor t) = TTensor (go t)+        go (THash k v) = THash (go k) (go v)+        go (TMatcher t) = TMatcher (go t)+        go (TFun t1 t2) = TFun (go t1) (go t2)+        go (TIO t) = TIO (go t)+        go (TIORef t) = TIORef (go t)+        go TAny = TAny++-- | Extract method name from ClassMethod+extractMethodName :: ClassMethod -> String+extractMethodName (ClassMethod name _ _ _) = name++-- | Extract method name and type from ClassMethod+extractMethodWithType :: ClassMethod -> (String, Type)+extractMethodWithType (ClassMethod name params retType _) =+  let paramTypes = map typedParamToType params+      methodType = foldr TFun (typeExprToType retType) paramTypes+  in (name, methodType)++-- | Extract class name from ConstraintExpr+extractConstraintName :: ConstraintExpr -> String+extractConstraintName (ConstraintExpr clsName _) = clsName++-- | Convert ConstraintExpr to internal Constraint+constraintToInternal :: ConstraintExpr -> Types.Constraint+constraintToInternal (ConstraintExpr clsName tyExprs) =+  Types.Constraint clsName (case tyExprs of +    [] -> TAny+    (t:_) -> typeExprToType t)++-- | Register a single pattern constructor+registerPatternConstructor :: String -> [String] -> Type +                           -> PatternConstructorEnv -> PatternConstructor +                           -> EvalM PatternConstructorEnv+registerPatternConstructor _typeName typeParams resultType patternCtorEnv +                          (PatternConstructor ctorName argTypeExprs) = do+  let argTypes = map typeExprToType argTypeExprs+      +      -- Pattern constructor type: arg1 -> arg2 -> ... -> resultType (without Pattern wrapper)+      patternCtorType = foldr TFun resultType argTypes+      +      -- Quantify over type parameters+      tyVars = map TyVar typeParams+      typeScheme = Types.Forall tyVars [] patternCtorType+      +      -- Add to pattern constructor environment (same format as PatternTypeEnv)+      patternCtorEnv' = extendPatternEnv ctorName typeScheme patternCtorEnv+  +  return patternCtorEnv'++-- | Convert TypedParam to Type+typedParamToType :: TypedParam -> Type+typedParamToType (TPVar _ ty) = typeExprToType ty+typedParamToType (TPInvertedVar _ ty) = typeExprToType ty+typedParamToType (TPTuple elems) = TTuple (map typedParamToType elems)+typedParamToType (TPWildcard ty) = typeExprToType ty+typedParamToType (TPUntypedVar _) = TVar (TyVar "a")  -- Will be inferred+typedParamToType TPUntypedWildcard = TVar (TyVar "a")  -- Will be inferred+

@@ -3,6 +3,18 @@ Licence     : MIT  This module provides interface for evaluating Egison expressions.++Processing Flow (design/implementation.md):+  1. TopExpr (Parse result)+  2. expandLoads (File loading with caching)+  3. Environment Building Phase (Collect data constructors, type classes, instances, type signatures)+  4. Desugar (Syntactic desugaring)+  5. Type Inference Phase (Constraint generation, unification, type class constraint processing)+  6. Type Check Phase (Verify type annotations, check type class constraints)+  7. TypedTopExpr (Typed AST)+  8. TypedDesugar (Type-driven transformations: type class expansion, tensorMap insertion)+  9. TITopExpr (Evaluatable typed IR with type info preserved)+ 10. Evaluation (Pattern matching execution, expression evaluation, IO actions) -}  module Language.Egison.Eval@@ -12,6 +24,7 @@   , evalTopExpr   , evalTopExprStr   , evalTopExprs+  , evalTopExprs'   , evalTopExprsNoPrint   , runExpr   , runTopExpr@@ -20,36 +33,349 @@   -- * Load Egison files   , loadEgisonLibrary   , loadEgisonFile+  -- * Load expansion+  , expandLoads   ) where -import           Control.Monad              (forM_, when)-import           Control.Monad.Except       (throwError)+import           Control.Monad              (foldM, forM_, when)+import           Data.List                  (intercalate, partition)+import           Control.Monad.Except       (throwError, catchError) import           Control.Monad.Reader       (ask, asks) import           Control.Monad.State+import           System.IO                  (hPutStrLn, stderr)  import           Language.Egison.AST import           Language.Egison.CmdOptions import           Language.Egison.Core import           Language.Egison.Data-import           Language.Egison.Desugar-import           Language.Egison.EvalState  (MonadEval (..))-import           Language.Egison.IExpr+import           Language.Egison.Data.Utils     (newEvaluatedObjectRef)+import           Language.Egison.Desugar (desugarExpr, desugarTopExpr, desugarTopExprs)+import           Language.Egison.EnvBuilder (buildEnvironments, EnvBuildResult(..))+import           Language.Egison.EvalState  (MonadEval (..), ConstructorEnv, PatternConstructorEnv)+import           Language.Egison.IExpr (TITopExpr(..), ITopExpr(..), IExpr(..), Var(..), stringToVar, stripTypeTopExpr) import           Language.Egison.MathOutput (prettyMath) import           Language.Egison.Parser+import qualified Language.Egison.Type.Types as Types+import           Language.Egison.Type.Infer (inferITopExpr, runInferWithWarningsAndState, InferState(..), initialInferStateWithConfig, permissiveInferConfig, defaultInferConfig)+import           Language.Egison.Type.Env (TypeEnv, ClassEnv, PatternTypeEnv, extendEnvMany, envToList, classEnvToList, lookupInstances, patternEnvToList, mergeClassEnv, extendPatternEnv)+import           Language.Egison.Type.TypeClassExpand ()+import           Language.Egison.Type.TypedDesugar (desugarTypedTopExprT_TensorMapOnly, desugarTypedTopExprT_TypeClassOnly)+import           Language.Egison.Type.Error (formatTypeError, formatTypeWarning)+import           Language.Egison.Type.Check (builtinEnv)+import           Language.Egison.Type.Pretty (prettyTypeScheme, prettyType)+import           Language.Egison.Pretty (prettyStr)+import           Language.Egison.EvalState (ConstructorInfo(..))+import qualified Data.HashMap.Strict as HashMap   -- | Evaluate an Egison expression. evalExpr :: Env -> Expr -> EvalM EgisonValue evalExpr env expr = desugarExpr expr >>= evalExprDeep env +--------------------------------------------------------------------------------+-- Phase 1: expandLoads - File Loading with Caching+--------------------------------------------------------------------------------+-- Recursively expand all Load/LoadFile statements into a flat list of TopExprs.+-- This phase handles file reading and prevents duplicate loading through caching.+-- After this phase, all source code is loaded and ready for environment building.++-- | Expand all Load/LoadFile statements recursively into a flat list of TopExprs.+-- Files are loaded recursively and deduplicated (same file loaded multiple times+-- will only appear once in the final list).+expandLoads :: [TopExpr] -> EvalM [TopExpr]+expandLoads [] = return []+expandLoads (expr:rest) = case expr of+  Load lib -> do+    libExprs <- loadLibraryFile lib+    expanded <- expandLoads libExprs+    restExpanded <- expandLoads rest+    return $ expanded ++ restExpanded+  LoadFile file -> do+    fileExprs <- loadFile file+    expanded <- expandLoads fileExprs+    restExpanded <- expandLoads rest+    return $ expanded ++ restExpanded+  _ -> do+    restExpanded <- expandLoads rest+    return $ expr : restExpanded++--------------------------------------------------------------------------------+-- Main Pipeline Entry Point+--------------------------------------------------------------------------------+ -- | Evaluate an Egison top expression.+-- Implements the complete processing flow:+--   expandLoads → Environment Building → Desugar → Type Inference/Check → +--   TypedDesugar → Evaluation evalTopExpr :: Env -> TopExpr -> EvalM (Maybe EgisonValue, Env) evalTopExpr env topExpr = do-  topExpr <- desugarTopExpr topExpr-  case topExpr of-    Nothing      -> return (Nothing, env)-    Just topExpr -> evalTopExpr' env topExpr+  -- Phase 1: Expand all Load/LoadFile recursively+  expanded <- expandLoads [topExpr]+  -- Phase 2-10: Process all expanded expressions through remaining pipeline+  evalExpandedTopExprsTyped env expanded +-- | Evaluate expanded top expressions using typed pipeline+-- TODO: Implement type environment accumulation for proper type checking+evalExpandedTopExprsTyped :: Env -> [TopExpr] -> EvalM (Maybe EgisonValue, Env)+evalExpandedTopExprsTyped env exprs = evalExpandedTopExprsTyped' env exprs False True++--------------------------------------------------------------------------------+-- Phase 2-10: Environment Building → Desugar → Type Inference/Check → +--             TypedDesugar → Evaluation+--------------------------------------------------------------------------------++-- | Evaluate expanded top expressions using the typed pipeline with optional printing.+-- This function implements phases 2-10 of the processing flow.+evalExpandedTopExprsTyped' :: Env -> [TopExpr] -> Bool -> Bool -> EvalM (Maybe EgisonValue, Env)+evalExpandedTopExprsTyped' env exprs printValues shouldDumpTyped = do+  opts <- ask+  +  --------------------------------------------------------------------------------+  -- Phase 2: Environment Building Phase (完全に独立したフェーズ)+  --------------------------------------------------------------------------------+  -- Collect ALL environment information BEFORE type inference begins:+  --   1. Data constructor definitions (from InductiveDecl)+  --   2. Type class definitions (from ClassDeclExpr)+  --   3. Instance definitions (from InstanceDeclExpr)+  --   4. Type signatures (from DefineWithType)+  +  -- Get existing environments (may contain previously loaded libraries)+  currentTypeEnv <- getTypeEnv+  currentClassEnv <- getClassEnv+  currentPatternEnv <- getPatternEnv++  -- Build environments from current expressions+  envResult <- buildEnvironments exprs++  -- Merge existing environments with newly built environments+  -- New definitions extend existing ones (can override)+  let newTypeEnv = ebrTypeEnv envResult+      -- If currentTypeEnv is empty, use builtinEnv as base+      baseTypeEnv = if null (envToList currentTypeEnv) then builtinEnv else currentTypeEnv+      mergedTypeEnv = extendEnvMany (envToList newTypeEnv) baseTypeEnv+      mergedClassEnv = mergeClassEnv currentClassEnv (ebrClassEnv envResult)+      -- Merge pattern environments (new definitions can override)+      -- Pattern constructors from ebrPatternConstructorEnv and pattern functions from ebrPatternTypeEnv+      patternConstructorEnv = ebrPatternConstructorEnv envResult+      newPatternFuncEnv = ebrPatternTypeEnv envResult+  +  -- Get current pattern function environment+  currentPatternFuncEnv <- getPatternFuncEnv+  +  let -- Merge both into a single pattern environment+      mergedPatternEnv = foldr (\(name, scheme) env -> extendPatternEnv name scheme env) +                               (foldr (\(name, scheme) env -> extendPatternEnv name scheme env)+                                      currentPatternEnv+                                      (patternEnvToList patternConstructorEnv))+                               (patternEnvToList newPatternFuncEnv)+      -- Also update pattern function environment separately+      mergedPatternFuncEnv = foldr (\(name, scheme) env -> extendPatternEnv name scheme env)+                                   currentPatternFuncEnv+                                   (patternEnvToList newPatternFuncEnv)++  -- Update EvalState with merged environments+  setTypeEnv mergedTypeEnv+  setClassEnv mergedClassEnv+  setPatternEnv mergedPatternEnv+  setPatternFuncEnv mergedPatternFuncEnv+  +  -- Register constructors to EvalState+  forM_ (HashMap.toList (ebrConstructorEnv envResult)) $ \(ctorName, ctorInfo) ->+    registerConstructor ctorName ctorInfo+  +  -- Dump environment if requested+  when (optDumpEnv opts) $ do+    dumpEnvironment mergedTypeEnv mergedClassEnv (ebrConstructorEnv envResult) +                    (ebrPatternConstructorEnv envResult) (ebrPatternTypeEnv envResult)+  +  -- Dump desugared AST if requested+  when (optDumpDesugared opts) $ do+    desugaredExprs <- desugarTopExprs exprs+    dumpDesugared (map Just desugaredExprs)+  +  -- Get the environments for type inference+  -- Permissive mode allows falling back to untyped evaluation on type errors+  let permissive = not (optTypeCheckStrict opts)+  +  -- Process each expression sequentially through phases 3-8 (type inference and desugaring)+  -- Collect all definitions to bind them together later (Phase 9)+  -- Non-definition expressions (ITest, IExecute) will be evaluated in Phase 10+  -- Also collect typed ASTs if dump-typed, dump-ti, or dump-tc is enabled+  -- The accumulator separates regular value bindings from pattern function bindings so+  -- they can be placed in different environments after collection.+  ((allBindings, allPatFuncBindings, nonDefExprs), typedExprs, tiExprs, tcExprs) <- foldM (\((bindings, patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs) expr -> do+    -- Get current type and class environments from EvalState+    currentTypeEnv <- getTypeEnv+    currentClassEnv <- getClassEnv+    +    -- Phase 3-4: Desugar (TopExpr → ITopExpr)+    mITopExpr <- desugarTopExpr expr+    +    case mITopExpr of+      Nothing -> return ((bindings, patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs)  -- No desugared output+      Just iTopExpr -> do+        -- Phase 5-6: Type Inference (ITopExpr → TypedITopExpr)+        let inferConfig = if permissive then permissiveInferConfig else defaultInferConfig+        -- Get the current pattern environment from EvalState+        currentPatternEnv' <- getPatternEnv+        currentPatternFuncEnv' <- getPatternFuncEnv+        -- Add pattern function types to inferEnv so they can be referenced as variables+        let patternFuncBindings = [(stringToVar name, scheme) | (name, scheme) <- patternEnvToList currentPatternFuncEnv']+            enrichedTypeEnv = extendEnvMany patternFuncBindings currentTypeEnv+            initState = (initialInferStateWithConfig inferConfig) {+              inferEnv = enrichedTypeEnv,+              inferClassEnv = currentClassEnv,+              inferPatternEnv = currentPatternEnv',+              inferPatternFuncEnv = currentPatternFuncEnv'+            }+        (result, warnings, finalState) <- liftIO $ +          runInferWithWarningsAndState (inferITopExpr iTopExpr) initState+        +        let updatedTypeEnv = inferEnv finalState+        let updatedClassEnv = inferClassEnv finalState+        let updatedPatternEnv = inferPatternEnv finalState+        let updatedPatternFuncEnv = inferPatternFuncEnv finalState+    +        -- Print type warnings if any+        when (not (null warnings)) $ do+          liftIO $ mapM_ (hPutStrLn stderr . formatTypeWarning) warnings+        +        -- Update type, class, and pattern environments in EvalState+        setTypeEnv updatedTypeEnv+        setClassEnv updatedClassEnv+        setPatternEnv updatedPatternEnv+        setPatternFuncEnv updatedPatternFuncEnv+        +        case result of+          Left err -> do+            liftIO $ hPutStrLn stderr $ "Type error:\n" ++ formatTypeError err+            -- Fallback: Use untyped evaluation if type checking fails (permissive mode)+            -- Type errors are handled immediately, not collected+            topExpr' <- desugarTopExpr expr+            case topExpr' of+              Nothing -> return ((bindings, patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs)+              Just topExpr'' -> do+                -- Evaluate type-error expressions immediately (not collected)+                -- This is a fallback for permissive mode+                case topExpr'' of+                  IDefine name expr ->+                    return ((bindings ++ [(name, expr)], patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs)+                  IDefineMany defs ->+                    return ((bindings ++ defs, patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs)+                  IPatternFunctionDecl name _tyVars params _retType body ->+                    let paramNames = map fst params+                        patternFuncExpr = IPatternFuncExpr paramNames body+                    in return ((bindings, patFuncBindings ++ [(name, patternFuncExpr)], nonDefs), typedExprs, tiExprs, tcExprs)+                  _ ->+                    -- Non-definition: collect for later evaluation+                    return ((bindings, patFuncBindings, nonDefs ++ [(topExpr'', printValues)]), typedExprs, tiExprs, tcExprs)++          Right (Nothing, _subst) ->+            -- No code generated (e.g., load statements that are already processed)+            return ((bindings, patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs)+          +          Right (Just tiTopExpr, _subst) -> do+            -- Phase 7: inferITopExpr now returns TITopExpr directly+            -- No need for separate conversion++            -- Collect typed AST for --dump-typed (Phase 6: after type inference, before TypedDesugar)+            let typedExprs' = if optDumpTyped opts then typedExprs ++ [Just tiTopExpr] else typedExprs++            -- Phase 8a: TensorMap Insertion+            -- Insert tensorMap where needed (scalar vs tensor argument type conversion)+            mTiTopExprAfterTensorMap <- desugarTypedTopExprT_TensorMapOnly tiTopExpr++            case mTiTopExprAfterTensorMap of+              Nothing ->+                -- Load/LoadFile statements - no evaluation needed+                return ((bindings, patFuncBindings, nonDefs), typedExprs', tiExprs, tcExprs)++              Just tiTopExprAfterTensorMap -> do+                -- Collect TensorMap-inserted AST for --dump-ti (after TensorMap insertion)+                let tiExprs' = if optDumpTi opts then tiExprs ++ [Just tiTopExprAfterTensorMap] else tiExprs++                -- Phase 8b: Type Class Expansion+                -- Expand type class method calls to dictionary-based dispatch+                mTcTopExprAfterTypeClass <- desugarTypedTopExprT_TypeClassOnly tiTopExprAfterTensorMap++                case mTcTopExprAfterTypeClass of+                  Nothing ->+                    -- Load/LoadFile statements - no evaluation needed+                    return ((bindings, patFuncBindings, nonDefs), typedExprs', tiExprs', tcExprs)++                  Just tcTopExprAfterTypeClass -> do+                    -- Collect TypeClass-expanded AST for --dump-tc (after TypeClass expansion)+                    let tcExprs' = if optDumpTc opts then tcExprs ++ [Just tcTopExprAfterTypeClass] else tcExprs++                    -- Extract ITopExpr for evaluation+                    let iTopExprExpanded = stripTypeTopExpr tcTopExprAfterTypeClass++                    -- Type scheme is already in the environment (added by inferITopExpr), no need to add again++                    -- Phase 9-10: Collect definitions and non-definitions+                    -- Definitions will be bound together using recursiveBind to support mutual recursion+                    -- Non-definitions will be evaluated sequentially after all definitions are bound+                    case iTopExprExpanded of+                      IDefine name expr ->+                        -- Collect definition for later binding+                        return ((bindings ++ [(name, expr)], patFuncBindings, nonDefs), typedExprs', tiExprs', tcExprs')+                      IDefineMany defs ->+                        -- Collect multiple definitions for later binding+                        return ((bindings ++ defs, patFuncBindings, nonDefs), typedExprs', tiExprs', tcExprs')+                      IPatternFunctionDecl name _tyVars params _retType body ->+                        -- Collect pattern function definition separately; it will be bound+                        -- into the pattern function environment (not the value environment)+                        -- via recursiveBindPatFuncs after all regular definitions are bound.+                        let paramNames = map fst params+                            patternFuncExpr = IPatternFuncExpr paramNames body+                        in return ((bindings, patFuncBindings ++ [(name, patternFuncExpr)], nonDefs), typedExprs', tiExprs', tcExprs')+                      _ ->+                        -- Non-definition expressions (ITest, IExecute)+                        -- Collect for evaluation after all definitions are bound+                        return ((bindings, patFuncBindings, nonDefs ++ [(iTopExprExpanded, printValues)]), typedExprs', tiExprs', tcExprs')+    ) (([], [], []), [], [], []) exprs++  -- Dump typed AST BEFORE evaluation (so dumps are available even if evaluation fails)+  -- This is important for debugging - we want to see the typed AST even when there are runtime errors+  when (optDumpTyped opts && shouldDumpTyped) $ do+    dumpTyped typedExprs++  when (optDumpTi opts && shouldDumpTyped) $ do+    dumpTi tiExprs++  when (optDumpTc opts && shouldDumpTyped) $ do+    dumpTc tcExprs++  -- Phase 9: Bind all regular value definitions and pattern function definitions+  -- together in a single step via recursiveBindAll so that every thunk is closed+  -- over a single environment that contains both regular values and pattern+  -- functions.  Regular values go into the normal env layers; pattern functions+  -- go into the separate PatFuncEnv.  This is necessary because ordinary+  -- definitions may contain matchAll expressions that invoke pattern functions.+  envWithPatFuncs <- recursiveBindAll env allBindings allPatFuncBindings++  -- Phase 10: Evaluate non-definition expressions in order+  (lastVal, finalEnv) <- foldM (\(lastVal, currentEnv) (iExpr, shouldPrint) -> do+      evalResult <- catchError+        (Right <$> evalTopExpr' currentEnv iExpr)+        (\err -> do+          liftIO $ hPutStrLn stderr $ "Evaluation error: " ++ show err+          return $ Left err)++      case evalResult of+        Left _ -> return (lastVal, currentEnv)+        Right (mVal, env'') -> do+          when shouldPrint $ case mVal of+            Nothing -> return ()+            Just val -> valueToStr val >>= liftIO . putStrLn+          return (mVal, env'')+    ) (Nothing, envWithPatFuncs) nonDefExprs++  return (lastVal, finalEnv)++--------------------------------------------------------------------------------+-- Phase 2 Helper: Environment Building (moved to EnvBuilder module)+-------------------------------------------------------------------------------- -- | Evaluate an Egison top expression. evalTopExprStr :: Env -> TopExpr -> EvalM (Maybe String, Env) evalTopExprStr env topExpr = do@@ -67,28 +393,23 @@     Just lang -> return (prettyMath lang val)  -- | Evaluate Egison top expressions.+-- Pipeline: ExpandLoads → TypeCheck → TypedDesugar → Eval evalTopExprs :: Env -> [TopExpr] -> EvalM Env-evalTopExprs env exprs = do-  exprs <- desugarTopExprs exprs-  opts <- ask-  (bindings, rest) <- collectDefs opts exprs-  env <- recursiveBind env bindings-  forM_ rest $ \expr -> do-    (val, _) <- evalTopExpr' env expr-    case val of-      Nothing  -> return ()-      Just val -> valueToStr val >>= liftIO . putStrLn-  return env+evalTopExprs env exprs = evalTopExprs' env exprs True True --- | Evaluate Egison top expressions.+-- | Evaluate Egison top expressions with control over printing and dumping.+evalTopExprs' :: Env -> [TopExpr] -> Bool -> Bool -> EvalM Env+evalTopExprs' env exprs printValues shouldDumpTyped = do+  -- Expand all Load/LoadFile recursively+  expanded <- expandLoads exprs+  -- Evaluate using typed pipeline with printing+  (_, env') <- evalExpandedTopExprsTyped' env expanded printValues shouldDumpTyped+  return env'++-- | Evaluate Egison top expressions without printing.+-- Pipeline: ExpandLoads → TypeCheck → TypedDesugar → Eval evalTopExprsNoPrint :: Env -> [TopExpr] -> EvalM Env-evalTopExprsNoPrint env exprs = do-  exprs <- desugarTopExprs exprs-  opts <- ask-  (bindings, rest) <- collectDefs opts exprs-  env <- recursiveBind env bindings-  forM_ rest $ evalTopExpr' env-  return env+evalTopExprsNoPrint env exprs = evalTopExprs' env exprs False True  -- | Evaluate an Egison expression. Input is a Haskell string. runExpr :: Env -> String -> EvalM EgisonValue@@ -127,29 +448,38 @@ -- Helper functions -- -collectDefs :: EgisonOpts -> [ITopExpr] -> EvalM ([(Var, IExpr)], [ITopExpr])-collectDefs opts exprs = collectDefs' opts exprs [] []+collectDefs :: EgisonOpts -> [ITopExpr] -> EvalM ([(Var, IExpr)], [(String, IExpr)], [ITopExpr])+collectDefs opts exprs = collectDefs' opts exprs [] [] []   where-    collectDefs' :: EgisonOpts -> [ITopExpr] -> [(Var, IExpr)] -> [ITopExpr] -> EvalM ([(Var, IExpr)], [ITopExpr])-    collectDefs' opts (expr:exprs) bindings rest =+    collectDefs' :: EgisonOpts -> [ITopExpr] -> [(Var, IExpr)] -> [(String, IExpr)] -> [ITopExpr] -> EvalM ([(Var, IExpr)], [(String, IExpr)], [ITopExpr])+    collectDefs' opts (expr:exprs) bindings patFuncBindings rest =       case expr of-        IDefine name expr -> collectDefs' opts exprs ((name, expr) : bindings) rest-        ITest{}     -> collectDefs' opts exprs bindings (expr : rest)-        IExecute{}  -> collectDefs' opts exprs bindings (expr : rest)+        IDefine name expr -> collectDefs' opts exprs ((name, expr) : bindings) patFuncBindings rest+        IDefineMany defs  -> collectDefs' opts exprs (defs ++ bindings) patFuncBindings rest+        IPatternFunctionDecl name _tyVars params _retType body ->+          let paramNames = map fst params+              patternFuncExpr = IPatternFuncExpr paramNames body+          in collectDefs' opts exprs bindings ((name, patternFuncExpr) : patFuncBindings) rest+        ITest{}     -> collectDefs' opts exprs bindings patFuncBindings (expr : rest)+        IExecute{}  -> collectDefs' opts exprs bindings patFuncBindings (expr : rest)         ILoadFile _ | optNoIO opts -> throwError (Default "No IO support")         ILoadFile file -> do           exprs' <- loadFile file >>= desugarTopExprs-          collectDefs' opts (exprs' ++ exprs) bindings rest+          collectDefs' opts (exprs' ++ exprs) bindings patFuncBindings rest         ILoad _ | optNoIO opts -> throwError (Default "No IO support")         ILoad file -> do           exprs' <- loadLibraryFile file >>= desugarTopExprs-          collectDefs' opts (exprs' ++ exprs) bindings rest-    collectDefs' _ [] bindings rest = return (bindings, reverse rest)+          collectDefs' opts (exprs' ++ exprs) bindings patFuncBindings rest+        _ -> collectDefs' opts exprs bindings patFuncBindings rest+    collectDefs' _ [] bindings patFuncBindings rest = return (bindings, patFuncBindings, reverse rest)  evalTopExpr' :: Env -> ITopExpr -> EvalM (Maybe EgisonValue, Env) evalTopExpr' env (IDefine name expr) = do   env' <- recursiveBind env [(name, expr)]   return (Nothing, env')+evalTopExpr' env (IDefineMany defs) = do+  env' <- recursiveBind env defs+  return (Nothing, env') evalTopExpr' env (ITest expr) = do   pushFuncName (stringToVar "<stdin>")   val <- evalExprDeep env expr@@ -165,13 +495,169 @@   opts <- ask   when (optNoIO opts) $ throwError (Default "No IO support")   exprs <- loadLibraryFile file >>= desugarTopExprs-  (bindings, _) <- collectDefs opts exprs-  env' <- recursiveBind env bindings+  (bindings, patFuncBindings, _) <- collectDefs opts exprs+  env' <- recursiveBindAll env bindings patFuncBindings   return (Nothing, env') evalTopExpr' env (ILoadFile file) = do   opts <- ask   when (optNoIO opts) $ throwError (Default "No IO support")   exprs <- loadFile file >>= desugarTopExprs-  (bindings, _) <- collectDefs opts exprs-  env' <- recursiveBind env bindings+  (bindings, patFuncBindings, _) <- collectDefs opts exprs+  env' <- recursiveBindAll env bindings patFuncBindings   return (Nothing, env')+evalTopExpr' env (IDeclareSymbol _names _mType) = do+  -- Symbol declarations are only used during type inference+  -- At runtime, they don't produce any value or modify the environment+  return (Nothing, env)+evalTopExpr' _env (IPatternFunctionDecl name _ _ _ _) = do+  -- Pattern function declarations are now handled via recursiveBind+  -- They should not reach here; this is a fallback+  throwError $ Default $ "Pattern function " ++ name ++ " should have been converted to IPatternFuncExpr"++--------------------------------------------------------------------------------+-- Environment Dumping+--------------------------------------------------------------------------------++-- | Dump environment information after Phase 2 (Environment Building)+dumpEnvironment :: TypeEnv -> ClassEnv -> ConstructorEnv -> PatternConstructorEnv -> PatternTypeEnv -> EvalM ()+dumpEnvironment typeEnv classEnv ctorEnv patternCtorEnv patternEnv = do+  liftIO $ do+    putStrLn "=== Environment Information (Phase 2: Environment Building) ==="+    putStrLn ""+    +    -- 1. Type Signatures+    putStrLn "--- Type Signatures ---"+    let typeBindings = envToList typeEnv+    if null typeBindings+      then putStrLn "  (none)"+      else forM_ typeBindings $ \(Var varName indices, scheme) ->+        let displayName = if null indices +                          then varName+                          else varName ++ concatMap (const "_") indices+        in putStrLn $ "  " ++ displayName ++ " : " ++ prettyTypeScheme scheme+    putStrLn ""+    +    -- 2. Type Classes+    putStrLn "--- Type Classes ---"+    let classBindings = classEnvToList classEnv+    if null classBindings+      then putStrLn "  (none)"+      else forM_ classBindings $ \(className, classInfo) -> do+        let paramName = case Types.classParam classInfo of+              Types.TyVar name -> name+        putStrLn $ "  class " ++ className ++ " " ++ paramName ++ " where"+        forM_ (Types.classMethods classInfo) $ \(methName, methType) ->+          putStrLn $ "    " ++ methName ++ " : " ++ prettyType methType+    putStrLn ""+    +    -- 3. Instances+    putStrLn "--- Type Class Instances ---"+    let allInstances = concatMap (\(clsName, _) -> +          map (\inst -> (clsName, inst)) (lookupInstances clsName classEnv)) classBindings+    if null allInstances+      then putStrLn "  (none)"+      else forM_ allInstances $ \(className, instInfo) -> do+        let contextStr = if null (Types.instContext instInfo)+              then ""+              else let showConstraint (Types.Constraint cls ty) = cls ++ " " ++ prettyType ty+                   in intercalate ", " (map showConstraint (Types.instContext instInfo)) ++ " => "+        putStrLn $ "  instance " ++ contextStr ++ className ++ " " ++ prettyType (Types.instType instInfo)+    putStrLn ""+    +    -- 4. Data Constructors+    putStrLn "--- Data Constructors ---"+    let ctorBindings = HashMap.toList ctorEnv+    if null ctorBindings+      then putStrLn "  (none)"+      else forM_ ctorBindings $ \(ctorName, ctorInfo) -> do+        let typeParams = ctorTypeParams ctorInfo+        let retType = if null typeParams+              then ctorTypeName ctorInfo+              else ctorTypeName ctorInfo ++ " " ++ unwords typeParams+        let ctorType = if null (ctorArgTypes ctorInfo)+              then retType+              else intercalate " -> " (map prettyType (ctorArgTypes ctorInfo) ++ [retType])+        putStrLn $ "  " ++ ctorName ++ " : " ++ ctorType+    putStrLn ""+    +    -- 5. Pattern Constructors+    putStrLn "--- Pattern Constructors ---"+    let patternCtorBindings = patternEnvToList patternCtorEnv+    if null patternCtorBindings+      then putStrLn "  (none)"+      else forM_ patternCtorBindings $ \(ctorName, scheme) ->+        putStrLn $ "  " ++ ctorName ++ " : " ++ prettyTypeScheme scheme+    putStrLn ""+    +    -- 6. Pattern Functions+    putStrLn "--- Pattern Functions ---"+    let patternBindings = patternEnvToList patternEnv+    if null patternBindings+      then putStrLn "  (none)"+      else forM_ patternBindings $ \(name, scheme) ->+        putStrLn $ "  " ++ name ++ " : " ++ prettyTypeScheme scheme+    putStrLn ""+    +    putStrLn "=== End of Environment Information ==="++-- | Dump desugared AST after Phase 3 (Desugaring)+dumpDesugared :: [Maybe ITopExpr] -> EvalM ()+dumpDesugared desugaredExprs = do+  liftIO $ do+    putStrLn "=== Desugared AST (Phase 3: Desugaring) ==="+    putStrLn ""+    if null desugaredExprs+      then putStrLn "  (none)"+      else forM_ (zip [1 :: Int ..] desugaredExprs) $ \(i :: Int, mExpr) ->+        case mExpr of+          Nothing -> putStrLn $ "  [" ++ show i ++ "] (skipped)"+          Just expr -> putStrLn $ "  [" ++ show i ++ "] " ++ prettyStr expr+    putStrLn ""+    putStrLn "=== End of Desugared AST ==="++-- | Dump typed AST after Phase 6 (Type Inference & Check)+dumpTyped :: [Maybe TITopExpr] -> EvalM ()+dumpTyped typedExprs = do+  liftIO $ do+    putStrLn "=== Typed AST (Phase 5-6: Type Inference) ==="+    putStrLn ""+    if null typedExprs+      then putStrLn "  (none)"+      else forM_ (zip [1 :: Int ..] typedExprs) $ \(i :: Int, mExpr) ->+        case mExpr of+          Nothing -> putStrLn $ "  [" ++ show i ++ "] (skipped)"+          Just expr -> do+            putStrLn $ "  [" ++ show i ++ "] " ++ prettyStr expr+    putStrLn ""+    putStrLn "=== End of Typed AST ==="++dumpTi :: [Maybe TITopExpr] -> EvalM ()+dumpTi tiExprs = do+  liftIO $ do+    putStrLn "=== Typed AST after TensorMap Insertion (Phase 8a) ==="+    putStrLn ""+    if null tiExprs+      then putStrLn "  (none)"+      else forM_ (zip [1 :: Int ..] tiExprs) $ \(i :: Int, mExpr) ->+        case mExpr of+          Nothing -> putStrLn $ "  [" ++ show i ++ "] (skipped)"+          Just expr -> do+            putStrLn $ "  [" ++ show i ++ "] " ++ prettyStr expr+    putStrLn ""+    putStrLn "=== End of TensorMap Insertion AST ==="++dumpTc :: [Maybe TITopExpr] -> EvalM ()+dumpTc tcExprs = do+  liftIO $ do+    putStrLn "=== Typed AST after Type Class Expansion (Phase 8b) ==="+    putStrLn ""+    if null tcExprs+      then putStrLn "  (none)"+      else forM_ (zip [1 :: Int ..] tcExprs) $ \(i :: Int, mExpr) ->+        case mExpr of+          Nothing -> putStrLn $ "  [" ++ show i ++ "] (skipped)"+          Just expr -> do+            putStrLn $ "  [" ++ show i ++ "] " ++ prettyStr expr+    putStrLn ""+    putStrLn "=== End of Type Class Expansion AST ==="+

@@ -12,28 +12,90 @@   , initialEvalState   , MonadEval(..)   , mLabelFuncName+  , InstanceEnv+  , MethodDict+  , ConstructorEnv+  , ConstructorInfo(..)+  , PatternConstructorEnv   ) where  import           Control.Monad.Except import           Control.Monad.Trans.Class        (lift) import           Control.Monad.Trans.State.Strict +import qualified Data.HashMap.Strict              as HashMap+import           Data.HashMap.Strict              (HashMap)+ import           Language.Egison.IExpr+import           Language.Egison.Type.Types       (Type, TypeScheme)+import           Language.Egison.Type.Env          (TypeEnv, ClassEnv, PatternTypeEnv, emptyEnv, emptyClassEnv, emptyPatternEnv, extendEnv) +-- | Instance environment: maps class name -> method name -> type -> implementation+-- The implementation is stored as a function reference (Var name)+type MethodDict = HashMap Type String  -- Type -> implementation function name+type InstanceEnv = HashMap String (HashMap String MethodDict)  -- ClassName -> MethodName -> Dict -newtype EvalState = EvalState-  -- Names of called functions for improved error message-  { funcNameStack :: [Var]+-- | Constructor environment: maps constructor name -> constructor info+-- Used for type inference and pattern matching+data ConstructorInfo = ConstructorInfo+  { ctorTypeName :: String      -- ^ The inductive type name, e.g., "Maybe"+  , ctorArgTypes :: [Type]      -- ^ Constructor argument types+  , ctorTypeParams :: [String]  -- ^ Type parameters of the inductive type, e.g., ["a"]+  } deriving (Show, Eq)++type ConstructorEnv = HashMap String ConstructorInfo++-- | Pattern constructor environment: maps pattern constructor name -> type scheme+-- This uses the same format as PatternTypeEnv for consistency+type PatternConstructorEnv = PatternTypeEnv++data EvalState = EvalState+  { funcNameStack  :: [Var]          -- ^ Names of called functions for improved error message+  , instanceEnv    :: InstanceEnv    -- ^ Type class instance environment (runtime dispatch)+  , constructorEnv :: ConstructorEnv -- ^ Inductive data constructor environment+  , typeEnv        :: TypeEnv        -- ^ Type environment (for type inference)+  , classEnv       :: ClassEnv       -- ^ Class environment (for type inference)+  , patternEnv     :: PatternTypeEnv -- ^ Pattern constructor environment (for type inference)+  , patternFuncEnv :: PatternTypeEnv -- ^ Pattern function environment (for disambiguation)   }  initialEvalState :: EvalState-initialEvalState = EvalState { funcNameStack = [] }+initialEvalState = EvalState+  { funcNameStack = []+  , instanceEnv = HashMap.empty+  , constructorEnv = HashMap.empty+  , typeEnv = emptyEnv+  , classEnv = emptyClassEnv+  , patternEnv = emptyPatternEnv+  , patternFuncEnv = emptyPatternEnv+  }  class (Applicative m, Monad m) => MonadEval m where   pushFuncName :: Var -> m ()   topFuncName :: m Var   popFuncName :: m ()   getFuncNameStack :: m [Var]+  -- Instance environment operations+  getInstanceEnv :: m InstanceEnv+  registerInstance :: String -> String -> Type -> String -> m ()+  lookupInstance :: String -> String -> Type -> m (Maybe String)+  -- Constructor environment operations+  getConstructorEnv :: m ConstructorEnv+  registerConstructor :: String -> ConstructorInfo -> m ()+  lookupConstructor :: String -> m (Maybe ConstructorInfo)+  -- Type environment operations+  getTypeEnv :: m TypeEnv+  setTypeEnv :: TypeEnv -> m ()+  extendTypeEnv :: Var -> TypeScheme -> m ()+  -- Class environment operations+  getClassEnv :: m ClassEnv+  setClassEnv :: ClassEnv -> m ()+  -- Pattern environment operations+  getPatternEnv :: m PatternTypeEnv+  setPatternEnv :: PatternTypeEnv -> m ()+  -- Pattern function environment operations+  getPatternFuncEnv :: m PatternTypeEnv+  setPatternFuncEnv :: PatternTypeEnv -> m ()  instance Monad m => MonadEval (StateT EvalState m) where   pushFuncName name = do@@ -46,12 +108,82 @@     put $ st { funcNameStack = tail $ funcNameStack st }     return ()   getFuncNameStack = funcNameStack <$> get+  +  getInstanceEnv = instanceEnv <$> get+  +  registerInstance className methodName ty implName = do+    st <- get+    let env = instanceEnv st+        classDict = HashMap.lookupDefault HashMap.empty className env+        methodDict = HashMap.lookupDefault HashMap.empty methodName classDict+        methodDict' = HashMap.insert ty implName methodDict+        classDict' = HashMap.insert methodName methodDict' classDict+        env' = HashMap.insert className classDict' env+    put $ st { instanceEnv = env' }+  +  lookupInstance className methodName ty = do+    env <- instanceEnv <$> get+    return $ do+      classDict <- HashMap.lookup className env+      methodDict <- HashMap.lookup methodName classDict+      HashMap.lookup ty methodDict+  +  getConstructorEnv = constructorEnv <$> get+  +  registerConstructor ctorName info = do+    st <- get+    let env = constructorEnv st+        env' = HashMap.insert ctorName info env+    put $ st { constructorEnv = env' }+  +  lookupConstructor ctorName = do+    env <- constructorEnv <$> get+    return $ HashMap.lookup ctorName env+  +  getTypeEnv = typeEnv <$> get+  setTypeEnv env = do+    st <- get+    put $ st { typeEnv = env }+  extendTypeEnv name scheme = do+    st <- get+    let env' = extendEnv name scheme (typeEnv st)+    put $ st { typeEnv = env' }+  +  getClassEnv = classEnv <$> get+  setClassEnv env = do+    st <- get+    put $ st { classEnv = env }+  +  getPatternEnv = patternEnv <$> get+  setPatternEnv env = do+    st <- get+    put $ st { patternEnv = env }+  +  getPatternFuncEnv = patternFuncEnv <$> get+  setPatternFuncEnv env = do+    st <- get+    put $ st { patternFuncEnv = env }  instance (MonadEval m) => MonadEval (ExceptT e m) where   pushFuncName name = lift $ pushFuncName name   topFuncName = lift topFuncName   popFuncName = lift popFuncName   getFuncNameStack = lift getFuncNameStack+  getInstanceEnv = lift getInstanceEnv+  registerInstance cn mn t i = lift $ registerInstance cn mn t i+  lookupInstance cn mn t = lift $ lookupInstance cn mn t+  getConstructorEnv = lift getConstructorEnv+  registerConstructor cn info = lift $ registerConstructor cn info+  lookupConstructor cn = lift $ lookupConstructor cn+  getTypeEnv = lift getTypeEnv+  setTypeEnv = lift . setTypeEnv+  extendTypeEnv name scheme = lift $ extendTypeEnv name scheme+  getClassEnv = lift getClassEnv+  setClassEnv = lift . setClassEnv+  getPatternEnv = lift getPatternEnv+  setPatternEnv = lift . setPatternEnv+  getPatternFuncEnv = lift getPatternFuncEnv+  setPatternFuncEnv = lift . setPatternFuncEnv  mLabelFuncName :: MonadEval m => Maybe Var -> m a -> m a mLabelFuncName Nothing m = m

@@ -18,6 +18,23 @@   , IMatchClause   , IPatternDef   , IPrimitiveDataPattern+  -- Typed versions+  , TITopExpr (..)+  , TIExpr (..)+  , TIExprNode (..)+  , TIPattern (..)+  , TIPatternNode (..)+  , TILoopRange (..)+  , TIBindingExpr+  , TIMatchClause+  , TIPatternDef+  , tiExprType+  , tiExprScheme+  , tiExprTypeVars+  , tiExprConstraints+  , tipType+  , stripType+  , stripTypeTopExpr   , Var (..)   , stringToVar   , extractNameFromVar@@ -36,13 +53,22 @@ import           GHC.Generics        (Generic)  import           Language.Egison.AST (ConstantExpr (..), PDPatternBase (..), PMMode (..), PrimitivePatPattern (..))+import           Language.Egison.Type.Types (Type(..), TypeScheme(..), Constraint(..), TyVar(..))  data ITopExpr   = IDefine Var IExpr+  | IDefineMany [(Var, IExpr)]  -- Multiple definitions (for type class instances)   | ITest IExpr   | IExecute IExpr   | ILoadFile String   | ILoad String+  | IDeclareSymbol [String] (Maybe Type)  -- Symbol declaration+  | IPatternFunctionDecl String [TyVar] [(String, Type)] Type IPattern  -- Pattern function declaration+    -- String: function name+    -- [TyVar]: type parameters+    -- [(String, Type)]: parameters (name and type)+    -- Type: return type+    -- IPattern: body   deriving Show  data IExpr@@ -62,7 +88,6 @@   | ILambdaExpr (Maybe Var) [Var] IExpr   | IMemoizedLambdaExpr [String] IExpr   | ICambdaExpr String IExpr-  | IPatternFunctionExpr [String] IPattern   | IIfExpr IExpr IExpr IExpr   | ILetRecExpr [IBindingExpr] IExpr   | ILetExpr [IBindingExpr] IExpr@@ -76,15 +101,16 @@   | IDoExpr [IBindingExpr] IExpr   | ISeqExpr IExpr IExpr   | IApplyExpr IExpr [IExpr]-  | ICApplyExpr IExpr IExpr   | IGenerateTensorExpr IExpr IExpr   | ITensorExpr IExpr IExpr   | ITensorContractExpr IExpr   | ITensorMapExpr IExpr IExpr   | ITensorMap2Expr IExpr IExpr IExpr+  | ITensorMap2WedgeExpr IExpr IExpr IExpr   | ITransposeExpr IExpr IExpr   | IFlipIndicesExpr IExpr   | IFunctionExpr [String]+  | IPatternFuncExpr [String] IPattern  -- Pattern function: parameter names and pattern body   deriving Show  type IBindingExpr = (IPrimitiveDataPattern, IExpr)@@ -128,7 +154,7 @@   | SupSub a   | User a   | DF Integer Integer-  deriving (Show, Eq, Functor, Foldable, Generic, Traversable)+  deriving (Show, Eq, Ord, Functor, Foldable, Generic, Traversable)  extractSupOrSubIndex :: Index a -> Maybe a extractSupOrSubIndex (Sub x)    = Just x@@ -146,9 +172,9 @@ data Var = Var String [Index (Maybe Var)]   deriving (Generic, Show) --- for eq and hashable+-- for eq, ord and hashable data Var' = Var' String [Index ()]-  deriving (Eq, Generic, Show)+  deriving (Eq, Ord, Generic, Show)  instance Eq Var where   Var name (MultiSup _ _ _:_) == Var name' is' = Var name [] == Var name' is'@@ -157,6 +183,14 @@   Var name is == Var name' (MultiSub _ _ _:_)  = Var name is == Var name' []   Var name is == Var name' is'                 = Var' name (map (fmap (\_ -> ())) is) == Var' name' (map (fmap (\_ -> ())) is') +instance Ord Var where+  compare (Var name (MultiSup _ _ _:_)) (Var name' is') = compare (Var name []) (Var name' is')+  compare (Var name (MultiSub _ _ _:_)) (Var name' is') = compare (Var name []) (Var name' is')+  compare (Var name is) (Var name' (MultiSup _ _ _:_))  = compare (Var name is) (Var name' [])+  compare (Var name is) (Var name' (MultiSub _ _ _:_))  = compare (Var name is) (Var name' [])+  compare (Var name is) (Var name' is') = +    compare (Var' name (map (fmap (\_ -> ())) is)) (Var' name' (map (fmap (\_ -> ())) is'))+ instance Hashable a => Hashable (Index a) instance Hashable Var' instance Hashable Var where@@ -171,7 +205,325 @@ extractNameFromVar (Var name _) = name  makeIApply :: String -> [IExpr] -> IExpr-makeIApply func args = IApplyExpr (IVarExpr func) args+makeIApply fn args = IApplyExpr (IVarExpr fn) args++--+-- Typed Internal Expressions+--------------------------------------------------------------------------------+-- Phase 9: TIExpr - Evaluatable Typed IR with Type Info Preserved+--------------------------------------------------------------------------------+-- TIExpr is the result of Phase 8 (TypedDesugar) and input to Phase 10 (Evaluation).+-- It carries type information alongside the expression for:+--   - Better runtime error messages with type information+--   - Type-based dispatch during evaluation+--   - Debugging support with type annotations+--+-- Design Decision (design/implementation.md):+-- Type information is preserved after TypedDesugar for better error messages.+-- Type classes have already been resolved to dictionary passing, so no type class+-- constraints are needed here.++-- | Typed top-level expression (Phase 9: TITopExpr)+-- Result of TypedDesugar phase, ready for evaluation.+data TITopExpr+  = TIDefine TypeScheme Var TIExpr     -- ^ Typed definition with type scheme (includes type vars & constraints)+  | TIDefineMany [(Var, TIExpr)]       -- ^ Multiple definitions (letrec)+  | TITest TIExpr                      -- ^ Test expression (REPL)+  | TIExecute TIExpr                   -- ^ Execute IO expression+  | TILoadFile String                  -- ^ Load file (should not appear after expandLoads)+  | TILoad String                      -- ^ Load library (should not appear after expandLoads)+  | TIDeclareSymbol [String] Type      -- ^ Typed symbol declaration+  | TIPatternFunctionDecl String TypeScheme [(String, Type)] Type TIPattern  -- ^ Typed pattern function declaration+    -- String: function name+    -- TypeScheme: type scheme with type parameters and constraints+    -- [(String, Type)]: parameters (name and type with type params substituted)+    -- Type: return type (with type params substituted)+    -- TIPattern: typed body+  deriving Show++-- | Typed internal expression (Phase 9: TIExpr)+-- Each expression node carries its inferred/checked type scheme with type variables and constraints.+-- TypeScheme info is preserved for Phase 8 (TypedDesugar) to perform type-driven transformations+-- such as type class dictionary passing and tensorMap insertion.+--+-- NEW: TIExpr is now RECURSIVE - each sub-expression is also a TIExpr,+-- allowing type information to be preserved throughout the tree.+-- This eliminates the need to re-run type inference during TypeClassExpand.+data TIExpr = TIExpr+  { tiScheme :: TypeScheme    -- ^ Type scheme with type variables, constraints, and type+  , tiExprNode :: TIExprNode  -- ^ Typed expression node with typed sub-expressions+  } deriving Show++-- | Typed expression node - each constructor contains typed sub-expressions (TIExpr)+-- This mirrors IExpr but with TIExpr in place of IExpr for all sub-expressions+data TIExprNode+  -- Constants and variables+  = TIConstantExpr ConstantExpr+  | TIVarExpr String+  +  -- Collections+  | TITupleExpr [TIExpr]+  | TICollectionExpr [TIExpr]+  | TIConsExpr TIExpr TIExpr+  | TIJoinExpr TIExpr TIExpr+  | TIHashExpr [(TIExpr, TIExpr)]+  | TIVectorExpr [TIExpr]+  +  -- Lambda expressions+  | TILambdaExpr (Maybe Var) [Var] TIExpr+  | TIMemoizedLambdaExpr [String] TIExpr+  | TICambdaExpr String TIExpr+  +  -- Application+  | TIApplyExpr TIExpr [TIExpr]+  +  -- Control flow+  | TIIfExpr TIExpr TIExpr TIExpr+  +  -- Let expressions+  | TILetExpr [TIBindingExpr] TIExpr+  | TILetRecExpr [TIBindingExpr] TIExpr+  | TIWithSymbolsExpr [String] TIExpr+  +  -- Pattern matching+  | TIMatchExpr PMMode TIExpr TIExpr [TIMatchClause]+  | TIMatchAllExpr PMMode TIExpr TIExpr [TIMatchClause]+  | TIMatcherExpr [TIPatternDef]+  +  -- Inductive data+  | TIInductiveDataExpr String [TIExpr]+  +  -- Quote expressions+  | TIQuoteExpr TIExpr+  | TIQuoteSymbolExpr TIExpr+  +  -- Indexed expressions+  | TIIndexedExpr Bool TIExpr [Index TIExpr]+  | TISubrefsExpr Bool TIExpr TIExpr+  | TISuprefsExpr Bool TIExpr TIExpr+  | TIUserrefsExpr Bool TIExpr TIExpr+  +  -- Application variants+  | TIWedgeApplyExpr TIExpr [TIExpr]+  +  -- Do expressions+  | TIDoExpr [TIBindingExpr] TIExpr+  +  -- Sequence+  | TISeqExpr TIExpr TIExpr+  +  -- Tensor operations+  | TIGenerateTensorExpr TIExpr TIExpr+  | TITensorExpr TIExpr TIExpr+  | TITensorContractExpr TIExpr+  | TITensorMapExpr TIExpr TIExpr+  | TITensorMap2Expr TIExpr TIExpr TIExpr+  | TITensorMap2WedgeExpr TIExpr TIExpr TIExpr  -- Like TensorMap2 but supplements different indices+  | TITransposeExpr TIExpr TIExpr+  | TIFlipIndicesExpr TIExpr+  +  -- Function reference+  | TIFunctionExpr [String]+  deriving Show++-- | Typed binding expression+type TIBindingExpr = (IPrimitiveDataPattern, TIExpr)++-- | Typed match clause+type TIMatchClause = (TIPattern, TIExpr)++-- | Typed pattern definition (for matcher expressions)+type TIPatternDef = (PrimitivePatPattern, TIExpr, [TIBindingExpr])++-- | Get the type of a typed expression (extracts Type from TypeScheme)+tiExprType :: TIExpr -> Type+tiExprType (TIExpr (Forall _ _ t) _) = t++-- | Get the type scheme of a typed expression+tiExprScheme :: TIExpr -> TypeScheme+tiExprScheme = tiScheme++-- | Get the type variables of a typed expression+tiExprTypeVars :: TIExpr -> [TyVar]+tiExprTypeVars (TIExpr (Forall tvs _ _) _) = tvs++-- | Get the constraints of a typed expression+tiExprConstraints :: TIExpr -> [Constraint]+tiExprConstraints (TIExpr (Forall _ cs _) _) = cs++-- | Strip type information, returning the untyped expression+-- This recursively converts TIExpr back to IExpr for evaluation+stripType :: TIExpr -> IExpr+stripType (TIExpr _ node) = case node of+  TIConstantExpr c -> IConstantExpr c+  TIVarExpr name -> IVarExpr name+  TITupleExpr exprs -> ITupleExpr (map stripType exprs)+  TICollectionExpr exprs -> ICollectionExpr (map stripType exprs)+  TIConsExpr e1 e2 -> IConsExpr (stripType e1) (stripType e2)+  TIJoinExpr e1 e2 -> IJoinExpr (stripType e1) (stripType e2)+  TIHashExpr pairs -> IHashExpr [(stripType k, stripType v) | (k, v) <- pairs]+  TIVectorExpr exprs -> IVectorExpr (map stripType exprs)+  TILambdaExpr mVar params body -> ILambdaExpr mVar params (stripType body)+  TIMemoizedLambdaExpr args body -> IMemoizedLambdaExpr args (stripType body)+  TICambdaExpr var body -> ICambdaExpr var (stripType body)+  TIApplyExpr func args -> IApplyExpr (stripType func) (map stripType args)+  TIIfExpr cond thenE elseE -> IIfExpr (stripType cond) (stripType thenE) (stripType elseE)+  TILetExpr bindings body -> ILetExpr (map stripTypeBinding bindings) (stripType body)+  TILetRecExpr bindings body -> ILetRecExpr (map stripTypeBinding bindings) (stripType body)+  TIWithSymbolsExpr syms body -> IWithSymbolsExpr syms (stripType body)+  TIMatchExpr mode target matcher clauses -> +    IMatchExpr mode (stripType target) (stripType matcher) (map stripTypeClause clauses)+  TIMatchAllExpr mode target matcher clauses -> +    IMatchAllExpr mode (stripType target) (stripType matcher) (map stripTypeClause clauses)+  TIMatcherExpr patDefs -> +    IMatcherExpr [(pat, stripType expr, map stripTypeBinding bindings) | (pat, expr, bindings) <- patDefs]+  TIInductiveDataExpr name exprs -> IInductiveDataExpr name (map stripType exprs)+  TIQuoteExpr e -> IQuoteExpr (stripType e)+  TIQuoteSymbolExpr e -> IQuoteSymbolExpr (stripType e)+  TIIndexedExpr override expr indices -> IIndexedExpr override (stripType expr) (fmap stripType <$> indices)+  TISubrefsExpr b e1 e2 -> ISubrefsExpr b (stripType e1) (stripType e2)+  TISuprefsExpr b e1 e2 -> ISuprefsExpr b (stripType e1) (stripType e2)+  TIUserrefsExpr b e1 e2 -> IUserrefsExpr b (stripType e1) (stripType e2)+  TIWedgeApplyExpr func args -> IWedgeApplyExpr (stripType func) (map stripType args)+  TIDoExpr bindings body -> IDoExpr (map stripTypeBinding bindings) (stripType body)+  TISeqExpr e1 e2 -> ISeqExpr (stripType e1) (stripType e2)+  TIGenerateTensorExpr func shape -> IGenerateTensorExpr (stripType func) (stripType shape)+  TITensorExpr shape elems -> ITensorExpr (stripType shape) (stripType elems)+  TITensorContractExpr e -> ITensorContractExpr (stripType e)+  TITensorMapExpr func tensor -> ITensorMapExpr (stripType func) (stripType tensor)+  TITensorMap2Expr func t1 t2 -> ITensorMap2Expr (stripType func) (stripType t1) (stripType t2)+  TITensorMap2WedgeExpr func t1 t2 -> ITensorMap2WedgeExpr (stripType func) (stripType t1) (stripType t2)+  TITransposeExpr perm tensor -> ITransposeExpr (stripType perm) (stripType tensor)+  TIFlipIndicesExpr tensor -> IFlipIndicesExpr (stripType tensor)+  TIFunctionExpr names -> IFunctionExpr names+  where+    stripTypeBinding :: TIBindingExpr -> IBindingExpr+    stripTypeBinding (pat, expr) = (pat, stripType expr)+    +    stripTypeClause :: TIMatchClause -> IMatchClause+    stripTypeClause (tipat, expr) = (stripTypePat tipat, stripType expr)+    +    stripTypePat :: TIPattern -> IPattern+    stripTypePat (TIPattern _ node) = case node of+      TIWildCard -> IWildCard+      TIPatVar name -> IPatVar name+      TIValuePat expr -> IValuePat (stripType expr)+      TIPredPat expr -> IPredPat (stripType expr)+      TIIndexedPat pat exprs -> IIndexedPat (stripTypePat pat) (map stripType exprs)+      TILetPat bindings pat -> ILetPat (map stripTypeBinding bindings) (stripTypePat pat)+      TINotPat pat -> INotPat (stripTypePat pat)+      TIAndPat p1 p2 -> IAndPat (stripTypePat p1) (stripTypePat p2)+      TIOrPat p1 p2 -> IOrPat (stripTypePat p1) (stripTypePat p2)+      TIForallPat p1 p2 -> IForallPat (stripTypePat p1) (stripTypePat p2)+      TITuplePat pats -> ITuplePat (map stripTypePat pats)+      TIInductivePat name pats -> IInductivePat name (map stripTypePat pats)+      TILoopPat var range p1 p2 -> ILoopPat var (stripTypeLoopRange range) (stripTypePat p1) (stripTypePat p2)+      TIContPat -> IContPat+      TIPApplyPat func pats -> IPApplyPat (stripType func) (map stripTypePat pats)+      TIVarPat name -> IVarPat name+      TIInductiveOrPApplyPat name pats -> IInductiveOrPApplyPat name (map stripTypePat pats)+      TISeqNilPat -> ISeqNilPat+      TISeqConsPat p1 p2 -> ISeqConsPat (stripTypePat p1) (stripTypePat p2)+      TILaterPatVar -> ILaterPatVar+      TIDApplyPat pat pats -> IDApplyPat (stripTypePat pat) (map stripTypePat pats)+    +    stripTypeLoopRange :: TILoopRange -> ILoopRange+    stripTypeLoopRange (TILoopRange e1 e2 pat) = ILoopRange (stripType e1) (stripType e2) (stripTypePat pat)+    +    _stripTypeIndex :: Index TIExpr -> Index IExpr+    _stripTypeIndex idx = case idx of+      DF i1 i2 -> DF i1 i2+      Sub e -> Sub (stripType e)+      Sup e -> Sup (stripType e)+      MultiSub e1 n e2 -> MultiSub (stripType e1) n (stripType e2)+      MultiSup e1 n e2 -> MultiSup (stripType e1) n (stripType e2)+      SupSub e -> SupSub (stripType e)+      User e -> User (stripType e)++-- | Strip type information from top-level expression+stripTypeTopExpr :: TITopExpr -> ITopExpr+stripTypeTopExpr (TIDefine _scheme var expr) = IDefine var (stripType expr)+stripTypeTopExpr (TIDefineMany bindings) = IDefineMany [(v, stripType e) | (v, e) <- bindings]+stripTypeTopExpr (TITest expr) = ITest (stripType expr)+stripTypeTopExpr (TIExecute expr) = IExecute (stripType expr)+stripTypeTopExpr (TILoadFile file) = ILoadFile file+stripTypeTopExpr (TILoad file) = ILoad file+stripTypeTopExpr (TIDeclareSymbol names ty) = IDeclareSymbol names (Just ty)+stripTypeTopExpr (TIPatternFunctionDecl name _scheme params retType body) = +  IPatternFunctionDecl name tyVars params retType (stripTypePat body)+  where+    -- Extract type variables from the type scheme+    Forall tyVars _ _ = _scheme+    +    -- Helper function to strip type from pattern+    stripTypePat :: TIPattern -> IPattern+    stripTypePat (TIPattern _ node) = case node of+      TIWildCard -> IWildCard+      TIPatVar v -> IPatVar v+      TIValuePat e -> IValuePat (stripType e)+      TIPredPat e -> IPredPat (stripType e)+      TIIndexedPat p es -> IIndexedPat (stripTypePat p) (map stripType es)+      TILetPat binds p -> ILetPat [(pd, stripType e) | (pd, e) <- binds] (stripTypePat p)+      TIAndPat p1 p2 -> IAndPat (stripTypePat p1) (stripTypePat p2)+      TIOrPat p1 p2 -> IOrPat (stripTypePat p1) (stripTypePat p2)+      TINotPat p -> INotPat (stripTypePat p)+      TITuplePat ps -> ITuplePat (map stripTypePat ps)+      TIInductivePat name ps -> IInductivePat name (map stripTypePat ps)+      TIPApplyPat e ps -> IPApplyPat (stripType e) (map stripTypePat ps)+      TIDApplyPat p ps -> IDApplyPat (stripTypePat p) (map stripTypePat ps)+      TILoopPat v r p1 p2 -> ILoopPat v (stripTypeLoopRange r) (stripTypePat p1) (stripTypePat p2)+      TIVarPat v -> IVarPat v+      TIForallPat p1 p2 -> IForallPat (stripTypePat p1) (stripTypePat p2)+      TIContPat -> IContPat+      TISeqNilPat -> ISeqNilPat+      TISeqConsPat p1 p2 -> ISeqConsPat (stripTypePat p1) (stripTypePat p2)+      TILaterPatVar -> ILaterPatVar+      TIInductiveOrPApplyPat name ps -> IInductiveOrPApplyPat name (map stripTypePat ps)+    +    stripTypeLoopRange :: TILoopRange -> ILoopRange+    stripTypeLoopRange (TILoopRange e1 e2 pat) = ILoopRange (stripType e1) (stripType e2) (stripTypePat pat)++-- | Typed pattern with recursive structure (like TIExpr)+data TIPattern = TIPattern+  { tipScheme :: TypeScheme      -- ^ Type scheme with type variables and constraints+  , tipPatternNode :: TIPatternNode  -- ^ The pattern node+  } deriving Show++-- | Pattern node with type information (recursive structure)+data TIPatternNode+  = TIWildCard+  | TIPatVar String+  | TIValuePat TIExpr+  | TIPredPat TIExpr+  | TIIndexedPat TIPattern [TIExpr]+  | TILetPat [TIBindingExpr] TIPattern+  | TINotPat TIPattern+  | TIAndPat TIPattern TIPattern+  | TIOrPat TIPattern TIPattern+  | TIForallPat TIPattern TIPattern+  | TITuplePat [TIPattern]+  | TIInductivePat String [TIPattern]+  | TILoopPat String TILoopRange TIPattern TIPattern+  | TIContPat+  | TIPApplyPat TIExpr [TIPattern]+  | TIVarPat String+  | TIInductiveOrPApplyPat String [TIPattern]+  | TISeqNilPat+  | TISeqConsPat TIPattern TIPattern+  | TILaterPatVar+  | TIDApplyPat TIPattern [TIPattern]+  deriving Show++-- | Get the type of a typed pattern (extracts Type from TypeScheme)+tipType :: TIPattern -> Type+tipType (TIPattern (Forall _ _ t) _) = t++-- | Typed loop range+data TILoopRange = TILoopRange TIExpr TIExpr TIPattern+  deriving Show++-- NOTE: TIBindingExpr, TIMatchClause, and TIPatternDef are now defined+-- near TIExprNode (around line 302-308) to keep type definitions close together  instance {-# OVERLAPPING #-} Show (Index String) where   show (Sup s)    = "~" ++ s

@@ -25,6 +25,7 @@   , mathNumerator   , mathDenominator   , mathNegate+  , makeApplyExpr   ) where  import           Language.Egison.Math.Arith

@@ -30,11 +30,19 @@     , symbolM     , func     , funcM-    , apply-    , applyM+    , apply1+    , apply1M+    , apply2+    , apply2M+    , apply3+    , apply3M+    , apply4+    , apply4M     , quote     , negQuote     , negQuoteM+    , quoteFunction+    , quoteFunctionM     , equalMonomial     , equalMonomialM     , zero@@ -43,6 +51,7 @@     , singleTermM     , mathScalarMult     , mathNegate+    , makeApplyExpr     ) where  import           Data.List             (intercalate)@@ -52,6 +61,7 @@ import           Control.Monad         (MonadPlus (..))  import           Language.Egison.IExpr (Index (..))+import {-# SOURCE #-} Language.Egison.Data (WHNFData, prettyFunctionName)  -- -- Data@@ -74,11 +84,37 @@  data SymbolExpr   = Symbol Id String [Index ScalarData]-  | Apply ScalarData [ScalarData]-  | Quote ScalarData-  | FunctionData ScalarData [ScalarData] [ScalarData] -- fnname argnames args-  deriving Eq+  | Apply1 ScalarData ScalarData+  | Apply2 ScalarData ScalarData ScalarData+  | Apply3 ScalarData ScalarData ScalarData ScalarData+  | Apply4 ScalarData ScalarData ScalarData ScalarData ScalarData+  | Quote ScalarData                     -- For backtick quote: `expr+  | QuoteFunction WHNFData              -- For single quote on functions: 'func+  | FunctionData ScalarData [ScalarData] -- fnname args +-- Manual Eq instance (QuoteFunction comparison always returns False)+instance Eq SymbolExpr where+  Symbol id1 s1 js1 == Symbol id2 s2 js2 = id1 == id2 && s1 == s2 && js1 == js2+  Apply1 f1 a1 == Apply1 f2 a2 = f1 == f2 && a1 == a2+  Apply2 f1 a1 b1 == Apply2 f2 a2 b2 = f1 == f2 && a1 == a2 && b1 == b2+  Apply3 f1 a1 b1 c1 == Apply3 f2 a2 b2 c2 = f1 == f2 && a1 == a2 && b1 == b2 && c1 == c2+  Apply4 f1 a1 b1 c1 d1 == Apply4 f2 a2 b2 c2 d2 = f1 == f2 && a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2+  Quote m1 == Quote m2 = m1 == m2+  QuoteFunction whnf1 == QuoteFunction whnf2 = +    case (prettyFunctionName whnf1, prettyFunctionName whnf2) of+      (Just n1, Just n2) -> n1 == n2+      _ -> False  -- Anonymous functions are never equal+  FunctionData n1 k1 == FunctionData n2 k2 = n1 == n2 && k1 == k2+  _ == _ = False++-- Helper function to create Apply constructors based on argument count+makeApplyExpr :: ScalarData -> [ScalarData] -> SymbolExpr+makeApplyExpr fn [a1] = Apply1 fn a1+makeApplyExpr fn [a1, a2] = Apply2 fn a1 a2+makeApplyExpr fn [a1, a2, a3] = Apply3 fn a1 a2 a3+makeApplyExpr fn [a1, a2, a3, a4] = Apply4 fn a1 a2 a3 a4+makeApplyExpr _ _ = error "makeApplyExpr: unsupported number of arguments (must be 1-4)"+ type Id = String  -- Matchers@@ -105,17 +141,47 @@  func :: Pattern (PP ScalarData, PP [ScalarData])                 SymbolM SymbolExpr (ScalarData, [ScalarData])-func _ _ (FunctionData name _ args) = pure (name, args)-func _ _ _                             = mzero+func _ _ (FunctionData name args) = pure (name, args)+func _ _ _                        = mzero funcM :: SymbolM -> SymbolExpr -> (ScalarM, List ScalarM) funcM SymbolM _ = (ScalarM, List ScalarM) -apply :: Pattern (PP String, PP [ScalarData]) SymbolM SymbolExpr (String, [ScalarData])-apply _ _ (Apply (SingleSymbol (Symbol _ fn _)) args) = pure (fn, args)-apply _ _ _                                           = mzero-applyM :: SymbolM -> p -> (Eql, List ScalarM)-applyM SymbolM _ = (Eql, List ScalarM)+apply1 :: Pattern (PP String, PP WHNFData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData)+apply1 _ _ (Apply1 (SingleSymbol (QuoteFunction fnWhnf)) a1) =+  case prettyFunctionName fnWhnf of+    Just fn -> pure (fn, fnWhnf, a1)+    Nothing -> mzero+apply1 _ _ _ = mzero+apply1M :: SymbolM -> p -> (Eql, Something, ScalarM)+apply1M SymbolM _ = (Eql, Something, ScalarM) +apply2 :: Pattern (PP String, PP WHNFData, PP ScalarData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData, ScalarData)+apply2 _ _ (Apply2 (SingleSymbol (QuoteFunction fnWhnf)) a1 a2) =+  case prettyFunctionName fnWhnf of+    Just fn -> pure (fn, fnWhnf, a1, a2)+    Nothing -> mzero+apply2 _ _ _ = mzero+apply2M :: SymbolM -> p -> (Eql, Something, ScalarM, ScalarM)+apply2M SymbolM _ = (Eql, Something, ScalarM, ScalarM)++apply3 :: Pattern (PP String, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData, ScalarData, ScalarData)+apply3 _ _ (Apply3 (SingleSymbol (QuoteFunction fnWhnf)) a1 a2 a3) =+  case prettyFunctionName fnWhnf of+    Just fn -> pure (fn, fnWhnf, a1, a2, a3)+    Nothing -> mzero+apply3 _ _ _ = mzero+apply3M :: SymbolM -> p -> (Eql, Something, ScalarM, ScalarM, ScalarM)+apply3M SymbolM _ = (Eql, Something, ScalarM, ScalarM, ScalarM)++apply4 :: Pattern (PP String, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData, ScalarData, ScalarData, ScalarData)+apply4 _ _ (Apply4 (SingleSymbol (QuoteFunction fnWhnf)) a1 a2 a3 a4) =+  case prettyFunctionName fnWhnf of+    Just fn -> pure (fn, fnWhnf, a1, a2, a3, a4)+    Nothing -> mzero+apply4 _ _ _ = mzero+apply4M :: SymbolM -> p -> (Eql, Something, ScalarM, ScalarM, ScalarM, ScalarM)+apply4M SymbolM _ = (Eql, Something, ScalarM, ScalarM, ScalarM, ScalarM)+ quote :: Pattern (PP ScalarData) SymbolM SymbolExpr ScalarData quote _ _ (Quote m) = pure m quote _ _ _         = mzero@@ -126,6 +192,14 @@ negQuoteM :: SymbolM -> p -> ScalarM negQuoteM SymbolM _ = ScalarM +quoteFunction :: Pattern (PP String, PP WHNFData) SymbolM SymbolExpr (String, WHNFData)+quoteFunction _ _ (QuoteFunction whnf) = case prettyFunctionName whnf of+  Just name -> pure (name, whnf)+  Nothing   -> mzero+quoteFunction _ _ _ = mzero+quoteFunctionM :: SymbolM -> p -> Eql+quoteFunctionM SymbolM _ = Eql+ equalMonomial :: Pattern (PP Integer, PP Monomial) (Multiset (SymbolM, Eql)) Monomial (Integer, Monomial) equalMonomial (_, VP xs) _ ys = case isEqualMonomial xs ys of                                   Just sgn -> pure (sgn, xs)@@ -236,17 +310,21 @@       withSign t                   = " + " ++ pretty t  instance Printable SymbolExpr where-  isAtom Symbol{}     = True-  isAtom (Apply _ []) = True-  isAtom Quote{}      = True-  isAtom _            = False+  isAtom Symbol{}        = True+  isAtom Quote{}         = True+  isAtom QuoteFunction{} = True+  isAtom _               = False    pretty (Symbol _ (':':':':':':_) []) = "#"   pretty (Symbol _ s [])               = s   pretty (Symbol _ s js)               = s ++ concatMap show js-  pretty (Apply fn mExprs)             = unwords (map pretty' (fn : mExprs))+  pretty (Apply1 fn a1)                = unwords (map pretty' [fn, a1])+  pretty (Apply2 fn a1 a2)             = unwords (map pretty' [fn, a1, a2])+  pretty (Apply3 fn a1 a2 a3)          = unwords (map pretty' [fn, a1, a2, a3])+  pretty (Apply4 fn a1 a2 a3 a4)       = unwords (map pretty' [fn, a1, a2, a3, a4])   pretty (Quote mExprs)                = "`" ++ pretty' mExprs-  pretty (FunctionData name _ _)    = pretty name+  pretty (QuoteFunction whnf)          = "'" ++ maybe "<function>" id (prettyFunctionName whnf)+  pretty (FunctionData name args)      = unwords (pretty name : map pretty' args)  instance Printable TermExpr where   isAtom (Term _ [])  = True

@@ -16,6 +16,7 @@ import           Language.Egison.Math.Arith import           Language.Egison.Math.Expr import           Language.Egison.Math.Normalize+import {-# SOURCE #-} Language.Egison.Data (WHNFData)   rewriteSymbol :: ScalarData -> ScalarData@@ -24,7 +25,7 @@     [ rewriteI     , rewriteW     , rewriteLog-    , rewriteSinCos+--    , rewriteSinCos     , rewriteExp     , rewritePower     , rewriteSqrt@@ -79,31 +80,31 @@  where   f term@(Term a xs) =     match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply #"log" [zero], _) : _ -> Term 0 [] |]-      , [mc| (apply #"log" [singleTerm _ #1 [(symbol #"e", $n)]], _) : $xss ->+      [ [mc| (apply1 #"log" _ zero, _) : _ -> Term 0 [] |]+      , [mc| (apply1 #"log" _ (singleTerm _ #1 [(symbol #"e", $n)]), _) : $xss ->               Term (n * a) xss |]       , [mc| _ -> term |]       ] -makeApply :: String -> [ScalarData] -> SymbolExpr+makeApply :: WHNFData -> [ScalarData] -> SymbolExpr makeApply f args =-  Apply (SingleSymbol (Symbol "" f [])) args+  makeApplyExpr (SingleSymbol (QuoteFunction f)) args  rewriteExp :: ScalarData -> ScalarData rewriteExp = mapTerms f  where   f term@(Term a xs) =     match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply #"exp" [zero], _) : $xss ->+      [ [mc| (apply1 #"exp" _ zero, _) : $xss ->                f (Term a xss) |]-      , [mc| (apply #"exp" [singleTerm #1 #1 []], _) : $xss ->+      , [mc| (apply1 #"exp" _ (singleTerm #1 #1 []), _) : $xss ->                f (Term a ((Symbol "" "e" [], 1) : xss)) |]-      , [mc| (apply #"exp" [singleTerm $n #1 [(symbol #"i", #1), (symbol #"π", #1)]], _) : $xss ->+      , [mc| (apply1 #"exp" _ (singleTerm $n #1 [(symbol #"i", #1), (symbol #"π", #1)]), _) : $xss ->                f (Term ((-1) ^ n * a) xss) |]-      , [mc| (apply #"exp" [$x], $n & ?(>= 2)) : $xss ->-               f (Term a ((makeApply "exp" [mathScalarMult n x], 1) : xss)) |]-      , [mc| (apply #"exp" [$x], #1) : (apply #"exp" [$y], #1) : $xss ->-               f (Term a ((makeApply "exp" [mathPlus x y], 1) : xss)) |]+      , [mc| (apply1 #"exp" $expWhnf $x, $n & ?(>= 2)) : $xss ->+               f (Term a ((makeApply expWhnf [mathScalarMult n x], 1) : xss)) |]+      , [mc| (apply1 #"exp" $expWhnf $x, #1) : (apply1 #"exp" _ $y, #1) : $xss ->+               f (Term a ((makeApply expWhnf [mathPlus x y], 1) : xss)) |]       , [mc| _ -> term |]       ] @@ -112,62 +113,116 @@  where   f term@(Term a xs) =     match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply #"^" [singleTerm #1 #1 [], _], _) : $xss -> f (Term a xss) |]-      , [mc| (apply #"^" [$x, $y], $n & ?(>= 2)) : $xss ->-               f (Term a ((makeApply "^" [x, mathScalarMult n y], 1) : xss)) |]-      , [mc| (apply #"^" [$x, $y], #1) : (apply #"^" [#x, $z], #1) : $xss ->-               f (Term a ((makeApply "^" [x, mathPlus y z], 1) : xss)) |]+      [ [mc| (apply1 #"^" _ (singleTerm #1 #1 []), _) : $xss -> f (Term a xss) |]+      , [mc| (apply2 #"^" $powerWhnf $x $y, $n & ?(>= 2)) : $xss ->+               f (Term a ((makeApply powerWhnf [x, mathScalarMult n y], 1) : xss)) |]+      , [mc| (apply2 #"^" $powerWhnf $x $y, #1) : (apply2 #"^" _ #x $z, #1) : $xss ->+               f (Term a ((makeApply powerWhnf [x, mathPlus y z], 1) : xss)) |]       , [mc| _ -> term |]       ]  rewriteSinCos :: ScalarData -> ScalarData-rewriteSinCos = mapTerms' h . mapTerms (g . f)+rewriteSinCos = h . mapTerms (g . f)  where   f term@(Term a xs) =     match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply #"sin" [zero], _) : _ -> Term 0 [] |]-      , [mc| (apply #"sin" [singleTerm _ #1 [(symbol #"π", #1)]], _) : _ ->+      [ [mc| (apply1 #"sin" _ zero, _) : _ -> Term 0 [] |]+      , [mc| (apply1 #"sin" _ (singleTerm _ #1 [(symbol #"π", #1)]), _) : _ ->                Term 0 [] |]-      , [mc| (apply #"sin" [singleTerm $n #2 [(symbol #"π", #1)]], $m) : $xss ->+      , [mc| (apply1 #"sin" _ (singleTerm $n #2 [(symbol #"π", #1)]), $m) : $xss ->               Term (a * (-1) ^ (div (abs n - 1) 2) * m) xss |]       , [mc| _ -> term |]       ]   g term@(Term a xs) =     match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply #"cos" [zero], _) : $xss -> Term a xss |]-      , [mc| (apply #"cos" [singleTerm _ #2 [(symbol #"π", #1)]], _) : _ ->+      [ [mc| (apply1 #"cos" _ zero, _) : $xss -> Term a xss |]+      , [mc| (apply1 #"cos" _ (singleTerm _ #2 [(symbol #"π", #1)]), _) : _ ->               Term 0 [] |]-      , [mc| (apply #"cos" [singleTerm $n #1 [(symbol #"π", #1)]], $m) : $xss ->+      , [mc| (apply1 #"cos" _ (singleTerm $n #1 [(symbol #"π", #1)]), $m) : $xss ->                Term (a * (-1) ^ (abs n * m)) xss |]       , [mc| _ -> term |]       ]-  h (Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply #"cos" [$x], #2) : $mr ->-               mathMult-                 (mathMinus (SingleTerm 1 []) (SingleTerm 1 [(makeApply "sin" [x], 2)]))-                 (h (Term a mr)) |]-      , [mc| _ -> SingleTerm a xs |]+  h (Div poly1@(Plus ts1) poly2@(Plus ts2)) =+    match dfs (ts1, ts2) (Multiset TermM, Multiset TermM)+      [ [mc| ((term $a ((apply1 #"cos" $cosWhnf $x, #2) : $mr)) : (term $b ((apply1 #"sin" $sinWhnf #x, #2) : #mr)) : $pr, _) ->+              h (Div (Plus (Term a mr : Term (b - a) ((makeApply sinWhnf [x], 2) : mr) : pr)) poly2) |]+      , [mc| ((term $a ((apply1 #"cos" $cosWhnf $x, #2) : $mr)) : $pr1, (term _ ((apply1 #"sin" $sinWhnf #x, #2) : #mr)) : _) ->+              h (Div (Plus (Term a mr : Term (- a) ((makeApply sinWhnf [x], 2) : mr) : pr1)) poly2) |]+      , [mc| _ -> Div poly1 poly2 |]       ] +-- Determine if a ScalarData is definitely negative+-- Returns Just True if negative, Just False if non-negative, Nothing if unknown+isNegativeScalar :: ScalarData -> Maybe Bool+isNegativeScalar (Div (Plus terms) (Plus [Term d []]))+  | d > 0 = analyzeTerms terms+  | d < 0 = fmap not (analyzeTerms terms)+ where+  analyzeTerms ts+    | all (\(Term a _) -> a < 0) ts = Just True+    | all (\(Term a _) -> a > 0) ts = Just False+    | otherwise =+      -- Two-term case: a + b*sqrt(n), compare a^2 with b^2*n+      match dfs ts (Multiset TermM)+        [ [mc| term $a [] :+               term $b ((apply1 #"sqrt" _ (singleTerm $n #1 []), #1) : []) :+               [] ->+                 if n > 0+                 then let lhs = a * a; rhs = b * b * n+                      in if lhs > rhs then Just (a < 0)+                         else if lhs < rhs then Just (b < 0)+                         else Just False+                 else Nothing |]+        , [mc| _ -> Nothing |]+        ]+isNegativeScalar _ = Nothing++-- Find a pair of sqrts in a monomial whose product simplifies to a single term.+-- Uses matchAll to enumerate all sqrt pairs, avoiding DFS ordering issues.+-- We apply rewriteSqrt to the product because mathMult alone does not simplify+-- sqrt(x)^2 to x, which is needed for products like (-5-2√5)*(-5+2√5).+findSqrtPairToMerge :: Monomial -> Maybe (WHNFData, ScalarData, Monomial, Integer)+findSqrtPairToMerge xs =+  case results of+    (r:_) -> Just r+    []    -> Nothing+ where+  results =+    [ (whnf, simplified, xss, sign)+    | (whnf, x, y, xss) <- matchAll dfs xs (Multiset (SymbolM, Eql))+        [ [mc| (apply1 #"sqrt" $whnf $x, #1) :+               (apply1 #"sqrt" _ $y, #1) : $xss ->+                 (whnf, x, y, xss) |] ]+    , let simplified = rewriteSqrt (mathMult x y)+    , isSingleTermScalar simplified+    , let sign = case (isNegativeScalar x, isNegativeScalar y) of+                   (Just True, Just True) -> -1+                   _                      -> 1+    ]+  isSingleTermScalar (Div (Plus [_]) (Plus [_])) = True+  isSingleTermScalar _ = False+ rewriteSqrt :: ScalarData -> ScalarData rewriteSqrt = mapTerms' f  where   f (Term a xs) =     match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply #"sqrt" [$x], ?(> 1) & $k) : $xss ->+      [ [mc| (apply1 #"sqrt" $sqrtWhnf $x, ?(> 1) & $k) : $xss ->                rewriteSqrt-                 (mathMult (SingleTerm a ((makeApply "sqrt" [x], k `mod` 2) : xss))+                 (mathMult (SingleTerm a ((makeApply sqrtWhnf [x], k `mod` 2) : xss))                            (mathPower x (div k 2))) |]-      , [mc| (apply #"sqrt" [singleTerm $n #1 $x], #1) :-               (apply #"sqrt" [singleTerm $m #1 $y], #1) : $xss ->+      , [mc| (apply1 #"sqrt" $sqrtWhnf (singleTerm $n #1 $x), #1) :+               (apply1 #"sqrt" _ (singleTerm $m #1 $y), #1) : $xss ->              let d@(Term c z) = termsGcd [Term n x, Term m y]                  Term n' x' = mathDivideTerm (Term n x) d                  Term m' y' = mathDivideTerm (Term m y) d                  in case (n' * m', Term n' x', Term m' y') of                       (1, Term _ [], Term _ []) -> mathMult (SingleTerm c z) (SingleTerm a xss)-                      (_, _, _) -> mathMult (SingleTerm c z) (SingleTerm a ((makeApply "sqrt" [SingleTerm (n' * m') (x' ++ y')], 1) : xss)) |]-      , [mc| _ -> SingleTerm a xs |]+                      (_, _, _) -> mathMult (SingleTerm c z) (SingleTerm a ((makeApply sqrtWhnf [SingleTerm (n' * m') (x' ++ y')], 1) : xss)) |]+      , [mc| _ -> case findSqrtPairToMerge xs of+                    Just (whnf, product, remaining, sign) ->+                      rewriteSqrt (SingleTerm (sign * a) ((makeApply whnf [product], 1) : remaining))+                    Nothing -> SingleTerm a xs |]       ]  rewriteRt :: ScalarData -> ScalarData@@ -175,7 +230,7 @@  where   f (Term a xs) =     match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply #"rt" [singleTerm $n #1 [], $x] & $rtnx, ?(>= n) & $k) : $xss ->+      [ [mc| (apply2 #"rt" _ (singleTerm $n #1 []) $x & $rtnx, ?(>= n) & $k) : $xss ->                mathMult (SingleTerm a ((rtnx, k `mod` n) : xss))                         (mathPower x (div k n)) |]       , [mc| _ -> SingleTerm a xs |]@@ -186,13 +241,13 @@  where   f term@(Term a xs) =     match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply #"rtu" [singleTerm $n #1 []] & $rtun, ?(>= n) & $k) : $r ->+      [ [mc| (apply1 #"rtu" _ (singleTerm $n #1 []) & $rtun, ?(>= n) & $k) : $r ->                Term a ((rtun, k `mod` n) : r) |]       , [mc| _ -> term |]       ]   g (Term a xs) =     match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply #"rtu" [singleTerm $n #1 []] & $rtun, ?(== n - 1)) : $mr ->+      [ [mc| (apply1 #"rtu" _ (singleTerm $n #1 []) & $rtun, ?(== n - 1)) : $mr ->                mathMult                  (foldl mathMinus (SingleTerm (-1) []) (map (\k -> SingleTerm 1 [(rtun, k)]) [1..(n-2)]))                  (g (Term a mr)) |]@@ -205,8 +260,8 @@  where   rewriteDdPoly poly =     match dfs poly (Multiset TermM)-      [ [mc| term $a (($f & func $g $arg, $n) : $mr) :-               term $b ((func #g #arg, #n) : #mr) : $pr ->+      [ [mc| term $a (($f & func $g $args, $n) : $mr) :+               term $b ((func #g #args, #n) : #mr) : $pr ->                  rewriteDdPoly (Term (a + b) ((f, n) : mr) : pr) |]       , [mc| _ -> poly |]       ]

@@ -24,67 +24,76 @@ import           Control.Monad                 (unless) import           Control.Monad.Except         (throwError) import           Control.Monad.IO.Class       (liftIO)-import           Control.Monad.Reader         (asks, local) import           Control.Monad.Trans.Class    (lift) -import           System.Directory             (doesFileExist, getHomeDirectory)+import           System.Directory             (doesFileExist, getCurrentDirectory, getHomeDirectory)+import           System.FilePath              (takeDirectory, (</>)) import           System.IO  import           Language.Egison.AST-import           Language.Egison.CmdOptions import           Language.Egison.Data import qualified Language.Egison.Parser.NonS  as NonS-import qualified Language.Egison.Parser.SExpr as SExpr import           Language.Egison.RState import           Paths_egison                 (getDataFileName)  readTopExprs :: String -> EvalM [TopExpr] readTopExprs expr = do-  isSExpr <- asks optSExpr-  if isSExpr-     then either (throwError . Parser) return (SExpr.parseTopExprs expr)-     else do r <- lift . lift $ NonS.parseTopExprs expr-             either (throwError . Parser) return r+  r <- lift . lift $ NonS.parseTopExprs expr+  either (throwError . Parser) return r  parseTopExpr :: String -> RuntimeM (Either String TopExpr)-parseTopExpr expr = do-  isSExpr <- asks optSExpr-  if isSExpr-     then return (SExpr.parseTopExpr expr)-     else NonS.parseTopExpr expr+parseTopExpr = NonS.parseTopExpr  readTopExpr :: String -> EvalM TopExpr readTopExpr expr = do-  isSExpr <- asks optSExpr-  if isSExpr-     then either (throwError . Parser) return (SExpr.parseTopExpr expr)-     else do r <- lift . lift $ NonS.parseTopExpr expr-             either (throwError . Parser) return r+  r <- lift . lift $ NonS.parseTopExpr expr+  either (throwError . Parser) return r  readExprs :: String -> EvalM [Expr] readExprs expr = do-  isSExpr <- asks optSExpr-  if isSExpr-     then either (throwError . Parser) return (SExpr.parseExprs expr)-     else do r <- lift . lift $ NonS.parseExprs expr-             either (throwError . Parser) return r+  r <- lift . lift $ NonS.parseExprs expr+  either (throwError . Parser) return r  readExpr :: String -> EvalM Expr readExpr expr = do-  isSExpr <- asks optSExpr-  if isSExpr-     then either (throwError . Parser) return (SExpr.parseExpr expr)-     else do r <- lift . lift $ NonS.parseExpr expr-             either (throwError . Parser) return r+  r <- lift . lift $ NonS.parseExpr expr+  either (throwError . Parser) return r  -- |Load a libary file+-- Priority order:+-- 1. ~/.egison/lib/ (user customizations)+-- 2. Project lib/ directory (development - current directory or parent directories)+-- 3. Installed data files (getDataFileName) loadLibraryFile :: FilePath -> EvalM [TopExpr] loadLibraryFile file = do   homeDir <- liftIO getHomeDirectory-  doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file-  if doesExist-    then loadFile $ homeDir ++ "/.egison/" ++ file-    else liftIO (getDataFileName file) >>= loadFile+  let userLibPath = homeDir </> ".egison" </> file+  userExists <- liftIO $ doesFileExist userLibPath+  if userExists+    then loadFile userLibPath+    else do+      -- Try project lib directory (for development)+      -- Start from current directory and go up to find lib directory+      projectLibPath <- liftIO $ do+        currentDir <- getCurrentDirectory+        let findLibDir dir = do+              let libPath = dir </> "lib" </> file+              exists <- doesFileExist libPath+              if exists+                then return (Just libPath)+                else do+                  let parentDir = takeDirectory dir+                  if parentDir == dir  -- reached root+                    then return Nothing+                    else findLibDir parentDir+        findLibDir currentDir+      case projectLibPath of+        Just path -> loadFile path+        Nothing -> do+          -- Fall back to installed data files+          -- This may fail if not installed, but that's expected in development+          installedPath <- liftIO (getDataFileName file)+          loadFile installedPath  -- |Load a file loadFile :: FilePath -> EvalM [TopExpr]@@ -92,24 +101,19 @@   doesExist <- liftIO $ doesFileExist file   unless doesExist $ throwError $ Default ("file does not exist: " ++ file)   input <- liftIO $ readUTF8File file-  let useSExpr = checkIfUseSExpr file-  exprs <- local (\opt -> opt { optSExpr = useSExpr })-                 (readTopExprs (removeShebang useSExpr input))+  exprs <- readTopExprs (removeShebang input)   concat <$> mapM recursiveLoad exprs  where-  recursiveLoad (Load file)     = loadLibraryFile file-  recursiveLoad (LoadFile file) = loadFile file-  recursiveLoad expr            = return [expr]+  recursiveLoad (Load file')     = loadLibraryFile file'+  recursiveLoad (LoadFile file') = loadFile file'+  recursiveLoad expr             = return [expr] -removeShebang :: Bool -> String -> String-removeShebang useSExpr cs@('#':'!':_) = if useSExpr then ';' : cs else "--" ++ cs-removeShebang _        cs             = cs+removeShebang :: String -> String+removeShebang cs@('#':'!':_) = "--" ++ cs+removeShebang cs             = cs  readUTF8File :: FilePath -> IO String readUTF8File name = do   h <- openFile name ReadMode   hSetEncoding h utf8   hGetContents h--checkIfUseSExpr :: String -> Bool-checkIfUseSExpr file = drop (length file - 5) file == ".segi"

@@ -25,7 +25,7 @@ import           Data.Function                  (on) import           Data.Functor                   (($>)) import           Data.List                      (groupBy, insertBy, sortOn)-import           Data.Maybe                     (isJust, isNothing)+import           Data.Maybe                     (catMaybes, isJust, isNothing) import           Data.Text                      (pack)  import           Control.Monad.Combinators.Expr@@ -89,11 +89,294 @@ topExpr = Load     <$> (reserved "load" >> stringLiteral)       <|> LoadFile <$> (reserved "loadFile" >> stringLiteral)       <|> Execute  <$> (reserved "execute" >> expr)-      <|> (reserved "def" >> defineExpr)+      <|> (reserved "def" >> try patternFunctionExpr <|> defineExpr)+      <|> declareSymbolExpr+      <|> try patternInductiveExpr+      <|> inductiveExpr+      <|> classExpr+      <|> instanceExpr       <|> infixExpr       <|> Test     <$> expr       <?> "toplevel expression" +-- | Parse pattern inductive type declaration+-- e.g., inductive pattern MyList a := | myNil | myCons a (MyList a)+--       inductive pattern [a] := | (::) a [a] | (++) [a] [a]+patternInductiveExpr :: Parser TopExpr+patternInductiveExpr = try $ do+  pos <- L.indentLevel+  reserved "inductive"+  reserved "pattern"+  -- Type name can be either uppercase identifier or list type [a]+  (typeName, typeParams) <- try listTypeName <|> regularTypeName+  _ <- symbol ":="+  -- Parse constructors - they must be indented more than the 'inductive pattern' keyword+  -- or on the same line separated by |+  constructors <- patternConstructors pos+  return $ PatternInductiveDecl typeName typeParams constructors+  where+    regularTypeName = do+      name <- upperId+      params <- many typeVarIdent+      return (name, params)+    listTypeName = do+      -- Parse [a] as type name "[]" with type parameter "a"+      _ <- symbol "["+      param <- typeVarIdent+      _ <- symbol "]"+      return ("[]", [param])++-- | Parse constructors for pattern inductive type+patternConstructors :: Pos -> Parser [PatternConstructor]+patternConstructors basePos = do+  -- Optional leading |+  _ <- optional (symbol "|")+  first <- patternConstructor+  rest <- many $ try $ do+    -- Either | separator or indented on new line+    (symbol "|" >> patternConstructor) <|> (indentGuardGT basePos >> patternConstructor)+  return (first : rest)++-- | Parse a single pattern constructor+-- e.g., [], myNil, myCons a (MyList a), (::) a [a], (++) [a] [a]+-- Note: Infix operator notation (e.g., a :: [a]) is not supported.+--       Only prefix notation with operators in parentheses (e.g., (::) a [a]) is allowed.+patternConstructor :: Parser PatternConstructor+patternConstructor = prefixPatternConstructor+  where+    -- Prefix notation: [], myNil, myCons a (MyList a), (::) a [a]+    prefixPatternConstructor = do+      name <- try emptyListConstructor <|> try parenOperator <|> lowerId  -- Pattern constructors can be [], operator in parens, or lowercase identifier+      -- Parse argument types+      args <- many (try inductiveArgType)+      return $ PatternConstructor name args+    +    -- Empty list constructor: []+    emptyListConstructor = do+      _ <- symbol "[]"+      return "[]"+    +    parenOperator = do+      _ <- symbol "("+      op <- some (oneOf ("!#$%&*+./<=>?@\\^|-~:" :: String))+      _ <- symbol ")"+      return op++-- | Parse inductive data type declaration+-- e.g., inductive Ordering := | Less | Equal | Greater+--       inductive Nat := | O | S Nat+--       inductive Ordering := Less | Equal | Greater  (also valid)+inductiveExpr :: Parser TopExpr+inductiveExpr = try $ do+  pos <- L.indentLevel+  reserved "inductive"+  typeName <- upperId+  -- Parse optional type parameters (lowercase identifiers)+  typeParams <- many typeVarIdent+  _ <- symbol ":="+  -- Parse constructors - they must be indented more than the 'inductive' keyword+  -- or on the same line separated by |+  constructors <- inductiveConstructors pos+  return $ InductiveDecl typeName typeParams constructors++-- | Parse constructors for inductive data type+-- Constructors must be indented more than the base position, or separated by |+inductiveConstructors :: Pos -> Parser [InductiveConstructor]+inductiveConstructors basePos = do+  -- Optional leading |+  _ <- optional (symbol "|")+  first <- inductiveConstructor+  rest <- many $ try $ do+    -- Either | separator or indented on new line+    (symbol "|" >> inductiveConstructor) <|> (indentGuardGT basePos >> inductiveConstructor)+  return (first : rest)++-- | Parse a single constructor+-- e.g., Less, S Nat, Node Tree Tree+inductiveConstructor :: Parser InductiveConstructor+inductiveConstructor = do+  name <- upperId+  -- Parse argument types using typeAtom (handles both uppercase and lowercase)+  args <- many (try inductiveArgType)+  return $ InductiveConstructor name args++-- | Parse an argument type for inductive constructor+-- Only parses simple type atoms that are clearly types+inductiveArgType :: Parser TypeExpr+inductiveArgType = try $ do+  -- Don't parse if next token is | (constructor separator)+  notFollowedBy (symbol "|")+  -- Parse type atom, but use a restricted version that only accepts:+  -- - Builtin types (Integer, Bool, etc.)+  -- - Type names (uppercase identifiers)+  -- - Type variables (lowercase, but short to avoid function names)+  -- - List types [a]+  -- - Tuple types (a, b)+  inductiveTypeAtom++-- | Restricted type atom parser for inductive constructors+inductiveTypeAtom :: Parser TypeExpr+inductiveTypeAtom =+      TEInt     <$ reserved "Integer"+  <|> TEMathExpr <$ reserved "MathExpr"+  <|> TEFloat   <$ reserved "Float"+  <|> TEBool    <$ reserved "Bool"+  <|> TEChar    <$ reserved "Char"+  <|> TEString  <$ reserved "String"+  <|> TEList    <$> brackets typeExpr+  <|> TEVar     <$> typeNameIdent     -- Uppercase type names (Nat, Tree, etc.)+  <|> TEVar     <$> inductiveTypeVar  -- Short lowercase type variables+  <|> inductiveParenType              -- Parenthesized types like (Tree a)+  <?> "type expression in inductive constructor"++-- | Parse parenthesized type in inductive context+-- Handles both simple parens (Tree a) and tuples (a, b)+inductiveParenType :: Parser TypeExpr+inductiveParenType = parens $ do+  first <- optional inductiveTypeExprInParen+  case first of+    Nothing -> return $ TETuple []  -- Unit type: ()+    Just t -> do+      rest <- optional (symbol "," >> inductiveTypeExprInParen `sepBy1` symbol ",")+      return $ case rest of+        Nothing  -> t              -- Just parenthesized: (Tree a)+        Just ts  -> TETuple (t:ts) -- Tuple: (a, b)++-- | Type expression inside parentheses in inductive context+-- Allows function types and type applications+inductiveTypeExprInParen :: Parser TypeExpr+inductiveTypeExprInParen = typeExprWithApp++-- | Parse type variable in inductive context (must be short)+inductiveTypeVar :: Parser String+inductiveTypeVar = lexeme $ try $ do+  c <- lowerChar+  cs <- many identChar+  let name = c : cs+  -- Reject if it looks like a keyword or function name (> 2 chars usually)+  -- Common type vars: a, b, c, t, k, v, xs, elem+  if length name > 4 || name `elem` inductiveReserved+    then fail $ "Not a type variable: " ++ name+    else return name+  where+    inductiveReserved = ["def", "let", "if", "match", "load", "assert", "true", "false", "class", "instance", "where"]++-- | Parse type class declaration+-- e.g., class Eq a where+--         (==) (x: a) (y: a) : Bool+--         (/=) (x: a) (y: a) : Bool := not (x == y)+--       class Ord a extends Eq a where+--         compare (x: a) (y: a) : Ordering+classExpr :: Parser TopExpr+classExpr = try $ do+  pos <- L.indentLevel+  reserved "class"+  -- Parse optional superclass constraints: extends Eq a+  (superclasses, classNm, typeParams) <- classHeader+  reserved "where"+  -- Parse methods - use alignSome for consistent indentation handling+  methods <- many $ try $ do+    _ <- indentGuardGT pos+    -- Check that this looks like a method definition+    notFollowedBy (reserved "def" <|> reserved "class" <|> reserved "instance" <|> reserved "inductive")+    classMethod+  return $ ClassDeclExpr $ ClassDecl classNm typeParams superclasses methods++-- | Parse class header: "Ord a extends Eq a" or "Eq a"+-- Note: type parameters are parsed until "where" or "extends" is encountered+classHeader :: Parser ([ConstraintExpr], String, [String])+classHeader = try withExtends <|> withoutExtends+  where+    withExtends = do+      classNm <- upperId+      typeParams <- someTill typeVarIdent (lookAhead (reserved "extends"))+      reserved "extends"+      -- Parse superclass constraints (single constraint only for now)+      superClassName <- upperId+      superTypeArgs <- manyTill typeVarIdent (lookAhead (reserved "where"))+      let constraints = [ConstraintExpr superClassName (map TEVar superTypeArgs)]+      return (constraints, classNm, typeParams)++    withoutExtends = do+      classNm <- upperId+      typeParams <- manyTill typeVarIdent (lookAhead (reserved "where"))+      return ([], classNm, typeParams)++-- | Parse a single class method+-- e.g., (==) (x: a) (y: a) : Bool+--       (/=) (x: a) (y: a) : Bool := not (x == y)+classMethod :: Parser ClassMethod+classMethod = do+  name <- methodName'+  params <- many (try typedParam)+  _ <- symbol ":"+  -- Use typeAtomSimple to avoid consuming too much+  retType <- typeAtomSimple+  -- Check if there's a default implementation on the same line (not crossing to new unindented line)+  defaultImpl <- optional $ try $ do+    _ <- symbol ":="+    expr+  return $ ClassMethod name params retType defaultImpl++-- | Parse method name (can be operator in parens or regular identifier)+methodName' :: Parser String+methodName' = try parenOperator <|> lowerId+  where+    parenOperator = do+      _ <- symbol "("+      op <- some (oneOf ("!#$%&*+./<=>?@\\^|-~:" :: String))+      _ <- symbol ")"+      return op++-- | Parse type class instance declaration+-- e.g., instance Eq Integer where+--         (==) x y := x = y+--       instance Eq a => Eq [a] where+--         (==) xs ys := ...+instanceExpr :: Parser TopExpr+instanceExpr = try $ do+  pos <- L.indentLevel+  reserved "instance"+  -- Parse optional instance constraints: Eq a =>+  (constraints, classNm, instTypes) <- instanceHeader+  reserved "where"+  -- Parse method implementations (indented)+  methods <- instanceMethodsParser pos+  return $ InstanceDeclExpr $ InstanceDecl constraints classNm instTypes methods++-- | Parse instance header: "Eq Integer" or "{Eq a} Eq [a]"+-- Note: instance types are parsed until "where" is encountered+instanceHeader :: Parser ([ConstraintExpr], String, [TypeExpr])+instanceHeader = try withConstraints <|> withoutConstraints+  where+    -- New syntax: {Eq a} Eq [a]+    withConstraints = do+      constraints <- typeConstraints+      classNm <- upperId+      instTypes <- someTill typeAtomSimple (lookAhead (reserved "where"))+      return (constraints, classNm, instTypes)++    withoutConstraints = do+      classNm <- upperId+      instTypes <- someTill typeAtomSimple (lookAhead (reserved "where"))+      return ([], classNm, instTypes)++-- | Parse instance methods+instanceMethodsParser :: Pos -> Parser [InstanceMethod]+instanceMethodsParser basePos = option [] $ do+  _ <- indentGuardGT basePos+  alignSome instanceMethod++-- | Parse a single instance method+-- e.g., (==) x y := x = y+instanceMethod :: Parser InstanceMethod+instanceMethod = do+  name <- methodName'+  params <- many lowerId+  _ <- symbol ":="+  body <- expr+  return $ InstanceMethod name params body+ -- Sort binaryop table on the insertion addNewOp :: Op -> Bool -> Parser () addNewOp newop isPattern | isPattern = do@@ -134,18 +417,289 @@     reservedOp = [":", ":=", "->"]     reservedPOp = ["&", "|", ":=", "->"] +-- | Parse pattern function declaration+-- e.g., def pattern twin {a} (p1 : a) (p2 : MyList a) : MyList a := ...+patternFunctionExpr :: Parser TopExpr+patternFunctionExpr = do+  reserved "pattern"+  ops <- gets exprOps+  varWithIdx <- parens (stringToVarWithIndices . repr <$> choice (map (infixLiteral . repr) ops))+            <|> varWithIndicesLiteral+  let (name, _indices) = extractVarWithIndices varWithIdx+  -- Parse optional type parameters: {a, b}+  typeParams <- option [] (braces $ typeVarIdent `sepBy1` symbol ",")+  -- Parse parameters with types: (p1 : a) (p2 : MyList a)+  params <- many $+    try (parens $ do+      paramName <- lowerId+      _ <- symbol ":"+      paramType <- typeExpr+      return (paramName, paramType)+    ) <|> do+      paramName <- lowerId+      _ <- symbol ":"+      paramType <- typeExpr+      return (paramName, paramType)+  _ <- symbol ":"+  retType <- typeExpr+  _ <- symbol ":="+  -- Parse pattern body+  body <- pattern+  return $ PatternFunctionDecl name typeParams params retType body++declareSymbolExpr :: Parser TopExpr+declareSymbolExpr = try $ do+  reserved "declare"+  keyword <- lowerId+  -- Check that the keyword is "symbol"+  if keyword /= "symbol"+    then fail "Expected 'symbol' after 'declare'"+    else return ()+  -- Parse comma-separated list of symbol names+  names <- sepBy1 ident (symbol ",")+  -- Parse optional type annotation (must be simple type, not function type)+  mType <- optional $ try $ do+    _ <- symbol ":"+    -- Use typeAtomSimple to avoid parsing across lines+    typeAtomSimple+  return $ DeclareSymbol names mType+ defineExpr :: Parser TopExpr-defineExpr = do-  ops  <- gets exprOps-  f    <-   parens (stringToVarWithIndices . repr <$> choice (map (infixLiteral . repr) ops))-        <|> varWithIndicesLiteral-  args <- many arg-  _    <- symbol ":="-  body <- expr-  case args of-    [] -> return (Define f body)-    _  -> return (Define f (LambdaExpr args body))+defineExpr = try defineWithType <|> defineWithoutType+  where+    defineWithoutType = do+      ops  <- gets exprOps+      f    <-   parens (stringToVarWithIndices . repr <$> choice (map (infixLiteral . repr) ops))+            <|> varWithIndicesLiteral+      args <- many arg+      _    <- symbol ":="+      body <- expr+      case args of+        [] -> return (Define f body)+        _  -> return (Define f (LambdaExpr args body)) +    defineWithType = do+      ops <- gets exprOps+      varWithIdx <- parens (stringToVarWithIndices . repr <$> choice (map (infixLiteral . repr) ops))+                    <|> varWithIndicesLiteral+      let (name, indices) = extractVarWithIndices varWithIdx+      -- Parse optional type class constraints: {a : Eq, b : Ord}+      constraints <- option [] typeConstraints+      typedParams <- many typedParam+      _ <- symbol ":"+      retType <- typeExpr+      _ <- symbol ":="+      body <- expr+      let typedVar = TypedVarWithIndices name indices constraints typedParams retType+      return (DefineWithType typedVar body)++-- | Extract name and indices from VarWithIndices+extractVarWithIndices :: VarWithIndices -> (String, [VarIndex])+extractVarWithIndices (VarWithIndices name indices) = (name, indices)++-- | Parse type class constraints: {Eq a, Ord b}+-- Type variables without constraints are ignored (they are inferred automatically)+-- Format: {Eq a, Ord b}  -- className typeVar+--         {}  -- empty (no constraints)+typeConstraints :: Parser [ConstraintExpr]+typeConstraints = braces $ (catMaybes <$> (typeConstraintOrVar `sepBy1` symbol ",")) <|> return []+  where+    typeConstraintOrVar = (Just <$> try typeConstraint) <|> (try typeVar >> return Nothing)+    +    -- Format: {Eq a} - className typeVar+    typeConstraint = do+      className <- upperId+      typeVar <- typeVarIdent+      return $ ConstraintExpr className [TEVar typeVar]+    +    -- Type variable without constraint (ignored)+    typeVar = typeVarIdent++-- | Parse a typed parameter: supports both simple (x: a) and tuple ((x: a), (y: b)) patterns+typedParam :: Parser TypedParam+typedParam = parens typedParamInner++-- Parse the inner part of a typed parameter (inside parentheses)+typedParamInner :: Parser TypedParam+typedParamInner = try typedTupleParam <|> typedSimpleParam++-- Parse a tuple pattern with typed elements: (x: a), (y: b) or x: a, y: b+typedTupleParam :: Parser TypedParam+typedTupleParam = do+  first <- typedTupleElement+  _ <- symbol ","+  rest <- typedTupleElement `sepBy1` symbol ","+  return $ TPTuple (first : rest)++-- Parse an element in a typed tuple+typedTupleElement :: Parser TypedParam+typedTupleElement =+      try (parens typedParamInner)  -- Nested: ((x: a))+  <|> try typedWildcard             -- Wildcard with type: _: a+  <|> try typedInvertedVar         -- Inverted variable with type: !x: a+  <|> try typedVar                  -- Variable with type: x: a+  <|> untypedWildcard               -- Just wildcard: _+  <|> untypedVar                    -- Just variable: x++-- Simple typed parameter: x: a, !x: a, or _: a+typedSimpleParam :: Parser TypedParam+typedSimpleParam = try typedWildcard <|> try typedInvertedVar <|> typedVar++typedVar :: Parser TypedParam+typedVar = do+  paramName <- ident+  _ <- symbol ":"+  paramType <- typeExpr+  return $ TPVar paramName paramType++typedInvertedVar :: Parser TypedParam+typedInvertedVar = do+  _ <- symbol "!"+  paramName <- ident+  _ <- symbol ":"+  paramType <- typeExpr+  return $ TPInvertedVar paramName paramType++typedWildcard :: Parser TypedParam+typedWildcard = do+  _ <- symbol "_"+  _ <- symbol ":"+  paramType <- typeExpr+  return $ TPWildcard paramType++untypedVar :: Parser TypedParam+untypedVar = TPUntypedVar <$> ident++untypedWildcard :: Parser TypedParam+untypedWildcard = TPUntypedWildcard <$ symbol "_"++-- | Parse a type expression (used in typedParam - stops at closing paren/comma)+typeExpr :: Parser TypeExpr+typeExpr = typeExprWithApp++typeAtomOrParenType :: Parser TypeExpr+typeAtomOrParenType =+      try parenTypeOrTuple  -- Allow (a -> b) or (a, b) as a type atom+  <|> typeAtom++-- Parse parenthesized type or tuple type (including unit type ())+parenTypeOrTuple :: Parser TypeExpr+parenTypeOrTuple = parens $ do+  first <- optional typeExprWithApp+  case first of+    Nothing -> return $ TETuple []  -- Unit type: ()+    Just t -> do+      rest <- optional (symbol "," >> typeExprWithApp `sepBy1` symbol ",")+      return $ case rest of+        Nothing  -> t              -- Just parenthesized: (a -> b) or (Maybe a)+        Just ts  -> TETuple (t:ts) -- Tuple: (a, b, c)++-- | Type expression with type application support+-- e.g., Maybe a, List Integer, Tree a b+typeExprWithApp :: Parser TypeExpr+typeExprWithApp = do+  atoms <- some typeAtomSimple+  rest <- optional (symbol "->" >> typeExprWithApp)+  let baseType = case atoms of+                   [t]    -> t+                   (t:ts) -> TEApp t ts+                   []     -> error "unreachable"+  return $ case rest of+    Nothing -> baseType+    Just r  -> TEFun baseType r++-- | Simple type atom (no function arrows)+typeAtomSimple :: Parser TypeExpr+typeAtomSimple =+      TEInt     <$ reserved "Integer"+  <|> TEMathExpr <$ reserved "MathExpr"+  <|> TEFloat   <$ reserved "Float"+  <|> TEBool    <$ reserved "Bool"+  <|> TEChar    <$ reserved "Char"+  <|> TEString  <$ reserved "String"+  <|> TEIO      <$> (reserved "IO" >> typeAtomOrParenType)+  <|> TEList    <$> brackets typeExpr+  <|> try tensorTypeExpr+  <|> try vectorTypeExpr+  <|> try matrixTypeExpr+  <|> try diffFormTypeExpr+  <|> TEMatcher <$> (reserved "Matcher" >> typeAtomOrParenType)+  <|> TEPattern <$> (reserved "Pattern" >> typeAtomOrParenType)+  <|> TEVar     <$> typeVarIdent      -- lowercase type variables (a, b, etc.)+  <|> TEVar     <$> typeNameIdent     -- uppercase type names (Nat, Tree, Ordering, etc.)+  <|> parenTypeOrTuple                -- Parenthesized or tuple types+  <?> "type expression"++typeAtom :: Parser TypeExpr+typeAtom =+      TEInt     <$ reserved "Integer"+  <|> TEMathExpr <$ reserved "MathExpr"+  <|> TEFloat   <$ reserved "Float"+  <|> TEBool    <$ reserved "Bool"+  <|> TEChar    <$ reserved "Char"+  <|> TEString  <$ reserved "String"+  <|> TEIO      <$> (reserved "IO" >> typeAtomOrParenType)+  <|> TEList    <$> brackets typeExpr+  <|> try tensorTypeExpr+  <|> try vectorTypeExpr+  <|> try matrixTypeExpr+  <|> try diffFormTypeExpr+  <|> TEMatcher <$> (reserved "Matcher" >> typeAtomOrParenType)+  <|> TEPattern <$> (reserved "Pattern" >> typeAtomOrParenType)+  <|> TEVar     <$> typeVarIdent      -- lowercase type variables (a, b, etc.)+  <|> TEVar     <$> typeNameIdent     -- uppercase type names (Nat, Tree, Ordering, etc.)+  <?> "type expression"++-- | Parse an uppercase type name (for user-defined inductive types)+typeNameIdent :: Parser String+typeNameIdent = lexeme $ do+  c <- upperChar+  cs <- many identChar+  let name = c : cs+  -- Don't consume reserved type keywords+  if name `elem` typeReservedKeywords+    then fail $ "Reserved type keyword: " ++ name+    else return name+  where+    typeReservedKeywords = ["Integer", "MathExpr", "Float", "Bool", "Char", "String", "Matcher", "Pattern", "Tensor", "Vector", "Matrix", "IO"]++tensorTypeExpr :: Parser TypeExpr+tensorTypeExpr = do+  _ <- reserved "Tensor"+  elemType <- typeAtomOrParenType  -- Allow parenthesized types like (IORef [a])+  -- TETensor now only takes the element type+  return $ TETensor elemType++vectorTypeExpr :: Parser TypeExpr+vectorTypeExpr = do+  _ <- reserved "Vector"+  elemType <- typeAtomOrParenType+  return $ TEVector elemType++matrixTypeExpr :: Parser TypeExpr+matrixTypeExpr = do+  _ <- reserved "Matrix"+  elemType <- typeAtomOrParenType+  return $ TEMatrix elemType++diffFormTypeExpr :: Parser TypeExpr+diffFormTypeExpr = do+  _ <- reserved "DiffForm"+  elemType <- typeAtomOrParenType+  return $ TEDiffForm elemType+++typeVarIdent :: Parser String+typeVarIdent = lexeme $ do+  c <- lowerChar+  cs <- many identChar+  let name = c : cs+  if name `elem` typeReservedWords+    then fail $ "Reserved word: " ++ name+    else return name+  where+    typeReservedWords = ["Integer", "MathExpr", "Float", "Bool", "Char", "String", "Matcher", "Pattern", "Tensor", "Vector", "Matrix", "DiffForm"]+ expr :: Parser Expr expr = do   body <- exprWithoutWhere@@ -168,7 +722,6 @@    <|> withSymbolsExpr    <|> doExpr    <|> seqExpr-   <|> capplyExpr    <|> matcherExpr    <|> algebraicDataMatcherExpr    <|> tensorExpr@@ -260,19 +813,42 @@  lambdaLikeExpr :: Parser Expr lambdaLikeExpr =-        (reserved "memoizedLambda" >> MemoizedLambdaExpr <$> tupleOrSome lowerId <*> (symbol "->" >> expr))+        try typedMemoizedLambda+    <|> (reserved "memoizedLambda" >> MemoizedLambdaExpr <$> tupleOrSome lowerId <*> (symbol "->" >> expr))     <|> (reserved "cambda"         >> CambdaExpr         <$> lowerId      <*> (symbol "->" >> expr))+  where+    -- memoizedLambda (x: Integer) : Integer -> body+    -- Note: retType must be parsed with typeAtomOrParenType to avoid consuming the "->" arrow+    typedMemoizedLambda = do+      reserved "memoizedLambda"+      params <- some typedParam+      _ <- symbol ":"+      retType <- typeAtomOrParenType+      _ <- symbol "->"+      body <- expr+      return $ TypedMemoizedLambdaExpr params retType body  arg :: Parser (Arg ArgPattern)-arg = InvertedScalarArg <$> (string "*$" >> argPatternAtom)-  <|> TensorArg         <$> (char '%' >> argPatternAtom)-  <|> ScalarArg         <$> (char '$' >> argPatternAtom)-  <|> TensorArg         <$> argPattern+arg = InvertedArg <$> (char '!' >> argPatternAtom)+  <|> Arg         <$> argPattern   <?> "argument"  argPattern :: Parser ArgPattern-argPattern =-  argPatternAtom+argPattern = makeExprParser argPatternAtom table+        <?> "argument pattern"+  where+    table :: [[Operator Parser ArgPattern]]+    table =+      [ [ InfixR (apConsPatOp <$ symbol "::")+        , InfixL (apSnocPatOp <$ symbol "*:")+        ]+      ]+    +    apConsPatOp :: ArgPattern -> ArgPattern -> ArgPattern+    apConsPatOp lhs rhs = APConsPat (Arg lhs) rhs+    +    apSnocPatOp :: ArgPattern -> ArgPattern -> ArgPattern+    apSnocPatOp lhs rhs = APSnocPat lhs (Arg rhs)  argPatternAtom :: Parser ArgPattern argPatternAtom@@ -295,16 +871,33 @@     oneLiner = braces $ sepBy binding (symbol ";")  binding :: Parser BindingExpr-binding = do-  id <- Left <$> try varWithIndicesLiteral' <|> Right <$> pdAtom-  args <- many arg-  body <- symbol ":=" >> expr-  case (id, args) of-    (Left var, [])  -> return $ BindWithIndices var body-    (Right pdp, []) -> return $ Bind pdp body-    (Right pdp, _)  -> return $ Bind pdp (LambdaExpr args body)-    _               -> error "unreachable"+binding = try bindingWithType <|> bindingWithoutType+  where+    -- Binding with type annotation: f {a : Eq} (x: Integer) : Integer := body+    bindingWithType = do+      varWithIdx <- varWithIndicesLiteral+      let (name, indices) = extractVarWithIndices varWithIdx+      -- Parse optional type class constraints+      constraints <- option [] typeConstraints+      typedParams <- many typedParam+      _ <- symbol ":"+      retType <- typeExpr+      _ <- symbol ":="+      body <- expr+      let typedVar = TypedVarWithIndices name indices constraints typedParams retType+      return $ BindWithType typedVar body +    -- Original binding without type annotation+    bindingWithoutType = do+      id <- Left <$> try varWithIndicesLiteral' <|> Right <$> pdAtom+      args <- many arg+      body <- symbol ":=" >> expr+      case (id, args) of+        (Left var, [])  -> return $ BindWithIndices var body+        (Right pdp, []) -> return $ Bind pdp body+        (Right pdp, _)  -> return $ Bind pdp (LambdaExpr args body)+        _               -> error "unreachable"+ withSymbolsExpr :: Parser Expr withSymbolsExpr = WithSymbolsExpr <$> (reserved "withSymbols" >> brackets (sepBy ident comma)) <*> expr @@ -317,7 +910,13 @@     _:_                         -> customFailure LastStmtInDoBlock   where     statement :: Parser BindingExpr-    statement = (reserved "let" >> binding) <|> Bind (PDTuplePat []) <$> expr+    statement = try bindArrow <|> (reserved "let" >> binding) <|> Bind (PDTuplePat []) <$> expr+      where+        bindArrow = do+          pat <- pdPattern+          symbol "<-"+          e <- expr+          return (Bind pat e)      oneLiner :: Parser [BindingExpr]     oneLiner = braces $ sepBy statement (symbol ";")@@ -325,9 +924,6 @@ seqExpr :: Parser Expr seqExpr = SeqExpr <$> (reserved "seq" >> atomExpr) <*> atomExpr -capplyExpr :: Parser Expr-capplyExpr = CApplyExpr <$> (reserved "capply" >> atomExpr) <*> atomExpr- matcherExpr :: Parser Expr matcherExpr = do   reserved "matcher"@@ -336,12 +932,12 @@   -- expression.   MatcherExpr <$> alignSome (symbol "|" >> patternDef)   where-    patternDef :: Parser (PrimitivePatPattern, Expr, [(PrimitiveDataPattern, Expr)])+    patternDef :: Parser PatternDef     patternDef = do       pp <- ppPattern       returnMatcher <- reserved "as" >> expr <* reserved "with"       datapat <- alignSome (symbol "|" >> dataCases)-      return (pp, returnMatcher, datapat)+      return $ PatternDef pp returnMatcher datapat      dataCases :: Parser (PrimitiveDataPattern, Expr)     dataCases = (,) <$> pdPattern <*> (symbol "->" >> expr)@@ -361,6 +957,7 @@   <|> (reserved "tensorMap"      >> TensorMapExpr      <$> atomExpr <*> atomExpr)   <|> (reserved "tensorMap2"     >> TensorMap2Expr     <$> atomExpr <*> atomExpr <*> atomExpr)   <|> (reserved "transpose"      >> TransposeExpr      <$> atomExpr <*> atomExpr)+  <|> (reserved "flipIndices"    >> FlipIndicesExpr    <$> atomExpr)  functionExpr :: Parser Expr functionExpr = FunctionExpr <$> (reserved "function" >> parens (sepBy ident comma))@@ -486,7 +1083,7 @@         <|> hashExpr         <|> QuoteExpr <$> (try (symbol "`" <* notFollowedBy ident) >> atomExpr') -- must come after |constantExpr|         <|> QuoteSymbolExpr <$> try (char '\'' >> atomExpr')-        <|> AnonParamExpr  <$> try (char '%' >> positiveIntegerLiteral)+        <|> AnonParamExpr  <$> try (char '$' >> positiveIntegerLiteral)         <?> "atomic expression"  anonParamFuncExpr :: Parser Expr@@ -514,9 +1111,25 @@            <|> UndefinedExpr <$ reserved "undefined"  numericExpr :: Parser ConstantExpr-numericExpr = FloatExpr <$> try positiveFloatLiteral+numericExpr = try negativeFloatLiteral+          <|> try negativeIntegerLiteral+          <|> FloatExpr <$> try positiveFloatLiteral           <|> IntegerExpr <$> positiveIntegerLiteral           <?> "numeric expression"+  where+    -- Parse negative number literals (-1, -2.5, etc.)+    -- Only recognize as negative literal if there's no space after '-'+    negativeFloatLiteral = lexeme $ do+      char '-'+      notFollowedBy spaceChar+      n <- L.float+      return $ FloatExpr (negate n)+    +    negativeIntegerLiteral = lexeme $ do+      char '-'+      notFollowedBy spaceChar+      n <- L.decimal+      return $ IntegerExpr (negate n) -- -- Pattern --@@ -550,7 +1163,7 @@      defaultEnds s =       makeApply "from"-                [makeApply "-'" [s, ConstantExpr (IntegerExpr 1)]]+                [makeApply "i.-" [s, ConstantExpr (IntegerExpr 1)]]  seqPattern :: Parser Pattern seqPattern = do@@ -564,8 +1177,8 @@  makePatternTable :: [Op] -> [[Operator Parser Pattern]] makePatternTable ops =-  let ops' = map toOperator ops-   in map (map snd) (groupBy (\x y -> fst x == fst y) ops')+  reverse $ map (map snd) $ groupBy ((==) `on` fst) $ sortOn fst $+    map toOperator ops   where     toOperator :: Op -> (Int, Operator Parser Pattern)     toOperator op = (priority op, infixToOperator binary op)@@ -591,7 +1204,7 @@   elems <- sepBy pattern comma   return $ foldr (InfixPat consOp) nilPat elems     where-      nilPat = InductivePat "nil" []+      nilPat = InductivePat "[]" []       consOp = findOpFrom "::" reservedPatternOp  -- (Possibly indexed) atomic pattern@@ -627,7 +1240,8 @@   where     makeTable :: [Op] -> [[Operator Parser PrimitivePatPattern]]     makeTable ops =-      map (map toOperator) (groupBy (\x y -> priority x == priority y) ops)+      reverse $ map (map toOperator) $ groupBy (\x y -> priority x == priority y) $+        sortOn priority ops      toOperator :: Op -> Operator Parser PrimitivePatPattern     toOperator = infixToOperator inductive2@@ -638,7 +1252,7 @@     ppAtom = PPWildCard <$ symbol "_"          <|> PPPatVar   <$ symbol "$"          <|> PPValuePat <$> (string "#$" >> lowerId)-         <|> PPInductivePat "nil" [] <$ (symbol "[" >> symbol "]")+         <|> PPInductivePat "[]" [] <$ (symbol "[" >> symbol "]")          <|> makeTupleOrParen ppPattern PPTuplePat  pdPattern :: Parser PrimitiveDataPattern@@ -647,13 +1261,87 @@   where     table :: [[Operator Parser PrimitiveDataPattern]]     table =-      [ [ InfixR (PDConsPat <$ symbol "::") ]+      [ [ InfixR (PDConsPat <$ symbol "::")+        , InfixL (PDSnocPat <$ symbol "*:")+        ]       ]      pdApplyOrAtom :: Parser PrimitiveDataPattern-    pdApplyOrAtom = PDInductivePat <$> upperId <*> many pdAtom-                <|> PDSnocPat <$> (symbol "snoc" >> pdAtom) <*> pdAtom+    pdApplyOrAtom = try mathExprPrimitivePattern+                <|> PDInductivePat <$> upperId <*> many pdAtom                 <|> pdAtom+    +    -- MathExpr primitive patterns+    mathExprPrimitivePattern :: Parser PrimitiveDataPattern+    mathExprPrimitivePattern = do+      name <- upperId+      case name of+        "Div" -> do+          args <- many pdAtom+          case args of+            [p1, p2] -> return $ PDDivPat p1 p2+            _ -> fail "Div requires exactly 2 arguments"+        "Plus" -> do+          args <- many pdAtom+          case args of+            [p] -> return $ PDPlusPat p+            _ -> fail "Plus requires exactly 1 argument"+        "Term" -> do+          args <- many pdAtom+          case args of+            [p1, p2] -> return $ PDTermPat p1 p2+            _ -> fail "Term requires exactly 2 arguments"+        "Symbol" -> do+          args <- many pdAtom+          case args of+            [p1, p2] -> return $ PDSymbolPat p1 p2+            _ -> fail "Symbol requires exactly 2 arguments"+        "Apply1" -> do+          args <- many pdAtom+          case args of+            [p1, p2] -> return $ PDApply1Pat p1 p2+            _ -> fail "Apply1 requires exactly 2 arguments"+        "Apply2" -> do+          args <- many pdAtom+          case args of+            [p1, p2, p3] -> return $ PDApply2Pat p1 p2 p3+            _ -> fail "Apply2 requires exactly 3 arguments"+        "Apply3" -> do+          args <- many pdAtom+          case args of+            [p1, p2, p3, p4] -> return $ PDApply3Pat p1 p2 p3 p4+            _ -> fail "Apply3 requires exactly 4 arguments"+        "Apply4" -> do+          args <- many pdAtom+          case args of+            [p1, p2, p3, p4, p5] -> return $ PDApply4Pat p1 p2 p3 p4 p5+            _ -> fail "Apply4 requires exactly 5 arguments"+        "Quote" -> do+          args <- many pdAtom+          case args of+            [p] -> return $ PDQuotePat p+            _ -> fail "Quote requires exactly 1 argument"+        "Function" -> do+          args <- many pdAtom+          case args of+            [p1, p2] -> return $ PDFunctionPat p1 p2+            _ -> fail "Function requires exactly 2 arguments"+        "Sub" -> do+          args <- many pdAtom+          case args of+            [p] -> return $ PDSubPat p+            _ -> fail "Sub requires exactly 1 argument"+        "Sup" -> do+          args <- many pdAtom+          case args of+            [p] -> return $ PDSupPat p+            _ -> fail "Sup requires exactly 1 argument"+        "User" -> do+          args <- many pdAtom+          case args of+            [p] -> return $ PDUserPat p+            _ -> fail "User requires exactly 1 argument"+        _ -> fail "Not a MathExpr primitive pattern"  pdAtom :: Parser PrimitiveDataPattern pdAtom = PDWildCard    <$ symbol "_"@@ -715,8 +1403,8 @@ varIndex = (char '_' >> subscript)        <|> (char '~' >> supscript)        <|> parens (VGroupScripts <$> some varIndex)-       <|> braces (VSymmScripts <$> some varIndex)-       <|> brackets (VAntiSymmScripts <$> some varIndex)+       <|> brackets (VSymmScripts <$> some varIndex)+       <|> braces (VAntiSymmScripts <$> some varIndex)   where     subscript = VSubscript <$> ident'             <|> (do@@ -768,7 +1456,7 @@  -- Characters that can consist expression operators. opChar :: Parser Char-opChar = oneOf ("%^&*-+\\|:<>?!./'#@$" ++ "∧")+opChar = oneOf ("%^&*-+\\|:<>=?!./'#@$" ++ "∧")  -- Characters that can consist pattern operators. -- ! ? # @ $ are omitted because they can appear at the beginning of atomPattern@@ -827,7 +1515,7 @@ upperId :: Parser String upperId = (lexeme . try) (p >>= check)   where-    p = (:) <$> satisfy isAsciiUpper <*> many alphaNumChar+    p = (:) <$> satisfy isAsciiUpper <*> identString     check x = if x `elem` upperReservedWords                 then fail $ "keyword " ++ show x ++ " cannot be an identifier"                 else return x@@ -863,6 +1551,7 @@   [ "loadFile"   , "load"   , "def"+  , "declare"   , "if"   , "then"   , "else"@@ -893,6 +1582,7 @@   , "tensorMap"   , "tensorMap2"   , "transpose"+  , "flipIndices"   , "subrefs"   , "subrefs!"   , "suprefs"